From eeab2bb159432fbc68fa1eb4ea820381ae270ceb Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Thu, 9 Sep 2021 21:18:36 +0200
Subject: [PATCH] Combine IsMessage generation
---
src/Quasar/Wayland/Protocol/TH.hs | 20 ++++++++++++--------
1 file changed, 12 insertions(+), 8 deletions(-)
diff --git a/src/Quasar/Wayland/Protocol/TH.hs b/src/Quasar/Wayland/Protocol/TH.hs
index 986f0eb..440cbd3 100644
--- a/src/Quasar/Wayland/Protocol/TH.hs
+++ b/src/Quasar/Wayland/Protocol/TH.hs
@@ -71,12 +71,10 @@ interfaceDec interface = execWriterT do
tellQ $ instanceD (pure []) [t|IsInterface $iT|] instanceDecs
when (length interface.requests > 0) do
- tellQ $ messageTypeD rTypeName rConName (.messageSpec) interface.requests
- tellQ $ messageInstanceD rT ((\req@(RequestSpec msg) -> (msg, rConName req)) <$> interface.requests)
+ tellQs $ messageTypeDecs rTypeName rConName (.messageSpec) interface.requests
when (length interface.events > 0) do
- tellQ $ messageTypeD eTypeName eConName (.messageSpec) interface.events
- tellQ $ messageInstanceD eT ((\ev@(EventSpec msg) -> (msg, eConName ev)) <$> interface.events)
+ tellQs $ messageTypeDecs eTypeName eConName (.messageSpec) interface.events
where
iName = interfaceN interface
@@ -99,14 +97,20 @@ interfaceDec interface = execWriterT do
eConName :: EventSpec -> Name
eConName (EventSpec event) = mkName $ "E_" <> interface.name <> "_" <> event.name
-messageTypeD :: forall a. Name -> (a -> Name) -> (a -> MessageSpec) -> [a] -> Q Dec
-messageTypeD name conName msgSpec msgs = dataD (pure []) name [] Nothing (con <$> msgs) [derivingEq, derivingShow]
+messageTypeDecs :: forall a. Name -> (a -> Name) -> (a -> MessageSpec) -> [a] -> Q [Dec]
+messageTypeDecs name conName msgSpec msgs = execWriterT do
+ tellQ $ messageTypeD
+ tellQ $ isMessageInstanceD t ((\msg -> (msgSpec msg, conName msg)) <$> msgs)
where
+ t :: Q Type
+ t = conT name
+ messageTypeD :: Q Dec
+ messageTypeD = dataD (pure []) name [] Nothing (con <$> msgs) [derivingEq, derivingShow]
con :: a -> Q Con
con msg = normalC (conName msg) (defaultBangType <$> messageArgTs (msgSpec msg))
-messageInstanceD :: Q Type -> [(MessageSpec, Name)] -> Q Dec
-messageInstanceD t messages = instanceD (pure []) [t|IsMessage $t|] [opcodeNameD, showMessageD, getMessageD, putMessageD]
+isMessageInstanceD :: Q Type -> [(MessageSpec, Name)] -> Q Dec
+isMessageInstanceD t messages = instanceD (pure []) [t|IsMessage $t|] [opcodeNameD, showMessageD, getMessageD, putMessageD]
where
opcodeNameD :: Q Dec
opcodeNameD = funD 'opcodeName (opcodeNameClauseD <$> messages)
--
GitLab