From caf16546d799b65d697a931bd06291b83c6aaf63 Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Fri, 10 Sep 2021 00:07:05 +0200
Subject: [PATCH] Implement message serialization
---
src/Quasar/Wayland/Protocol/TH.hs | 8 +++++++-
1 file changed, 7 insertions(+), 1 deletion(-)
diff --git a/src/Quasar/Wayland/Protocol/TH.hs b/src/Quasar/Wayland/Protocol/TH.hs
index 6e51367..840ce05 100644
--- a/src/Quasar/Wayland/Protocol/TH.hs
+++ b/src/Quasar/Wayland/Protocol/TH.hs
@@ -182,7 +182,13 @@ isMessageInstanceD t msgs = instanceD (pure []) [t|IsMessage $t|] [opcodeNameD,
getMessageE :: Q Exp
getMessageE = applyA (conE (msg.msgConName)) ((\argT -> [|getArgument @($argT)|]) . argumentSpecType <$> msg.msgSpec.arguments)
putMessageD :: Q Dec
- putMessageD = funD 'putMessage [clause [] (normalB [|undefined|]) []]
+ putMessageD = funD 'putMessage (putMessageClauseD <$> msgs)
+ putMessageClauseD :: MessageContext -> Q Clause
+ putMessageClauseD msg = clause [msgConP msg] (normalB (putMessageE msg.msgSpec.arguments)) []
+ where
+ putMessageE :: [ArgumentSpec] -> Q Exp
+ putMessageE [] = [|pure ()|]
+ putMessageE args = doE ((\arg -> noBindS [|putArgument @($(argumentSpecType arg)) $(msgArgE msg arg)|]) <$> args)
interfaceN :: InterfaceSpec -> Name
--
GitLab