From 7c9877f9070911092f7a1672940e0a89e76b68af Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Mon, 27 Sep 2021 13:13:14 +0200
Subject: [PATCH] Generate (empty) send functions for all messages
---
src/Quasar/Wayland/Protocol/Core.hs | 4 +++
src/Quasar/Wayland/Protocol/TH.hs | 47 +++++++++++++++++++++++------
2 files changed, 41 insertions(+), 10 deletions(-)
diff --git a/src/Quasar/Wayland/Protocol/Core.hs b/src/Quasar/Wayland/Protocol/Core.hs
index 839963b..51f7e33 100644
--- a/src/Quasar/Wayland/Protocol/Core.hs
+++ b/src/Quasar/Wayland/Protocol/Core.hs
@@ -31,6 +31,7 @@ module Quasar.Wayland.Protocol.Core (
-- * Low-level protocol interaction
sendMessage,
+ objectSendMessage,
newObject,
-- ** WireCallbacks
@@ -577,6 +578,9 @@ sendMessage object message = do
putWord32host objectIdWord
putWord32host $ (fromIntegral msgSize `shiftL` 16) .|. fromIntegral opcode
+objectSendMessage :: forall s i. IsInterfaceSide s i => Object s i -> WireUp s i -> STM ()
+objectSendMessage object@(Object protocol _ _ _ _) message = runProtocolM protocol $ sendMessage object message
+
receiveMessages :: IsSide s => ProtocolM s ()
receiveMessages = receiveRawMessage >>= \case
diff --git a/src/Quasar/Wayland/Protocol/TH.hs b/src/Quasar/Wayland/Protocol/TH.hs
index 8683ec2..ac71b06 100644
--- a/src/Quasar/Wayland/Protocol/TH.hs
+++ b/src/Quasar/Wayland/Protocol/TH.hs
@@ -112,8 +112,8 @@ interfaceDecs interface = do
iName = interfaceN interface
iT = interfaceT interface
instanceDecs = [
- tySynInstD (tySynEqn Nothing (appT (conT ''Requests) iT) (orVoid (requestsT interface))),
- tySynInstD (tySynEqn Nothing (appT (conT ''Events) iT) (orVoid (eventsT interface))),
+ tySynInstD (tySynEqn Nothing (appT (conT ''Requests) iT) (orUnit (requestsT interface))),
+ tySynInstD (tySynEqn Nothing (appT (conT ''Events) iT) (orUnit (eventsT interface))),
tySynInstD (tySynEqn Nothing (appT (conT ''WireRequest) iT) wireRequestT),
tySynInstD (tySynEqn Nothing (appT (conT ''WireEvent) iT) eT),
tySynInstD (tySynEqn Nothing (appT (conT ''InterfaceName) iT) (litT (strTyLit interface.name))),
@@ -156,6 +156,38 @@ interfaceDecs interface = do
eventRecordD :: Q Dec
eventRecordD = messageRecordD (eventsName interface) eventContexts
+ objectName = mkName "object"
+ objectP = varP objectName
+ objectE = varE objectName
+
+ interfaceSideInstanceDs :: InterfaceSpec -> Q [Dec]
+ interfaceSideInstanceDs interface = execWriterT do
+ tellQ $ instanceD (pure []) ([t|IsInterfaceSide 'Client $iT|]) [createProxyD Client]
+ tellQ $ instanceD (pure []) ([t|IsInterfaceSide 'Server $iT|]) [createProxyD Server]
+ where
+ iT = interfaceT interface
+ createProxyD :: Side -> Q Dec
+ createProxyD Client = funD 'createProxy [clause [objectP] (normalB requestsProxyE) (sendMessageProxy <$> requestContexts)]
+ createProxyD Server = funD 'createProxy [clause [objectP] (normalB eventsProxyE) (sendMessageProxy <$> eventContexts)]
+ requestsProxyE :: Q Exp
+ requestsProxyE
+ | length interface.requests > 0 = recConE (requestsName interface) (sendMessageProxyField <$> requestContexts)
+ | otherwise = [|()|]
+ eventsProxyE :: Q Exp
+ eventsProxyE
+ | length interface.events > 0 = recConE (eventsName interface) (sendMessageProxyField <$> eventContexts)
+ | otherwise = [|()|]
+
+ sendMessageProxyField :: MessageContext -> Q (Name, Exp)
+ sendMessageProxyField msg = (mkName msg.msgSpec.name,) <$> varE (sendMessageFunctionName msg)
+
+ sendMessageFunctionName :: MessageContext -> Name
+ sendMessageFunctionName msg = mkName $ "send_" <> msg.msgSpec.name
+
+ sendMessageProxy :: MessageContext -> Q Dec
+ sendMessageProxy msg = funD (sendMessageFunctionName msg) [clause [] (normalB [|undefined|]) []]
+
+
messageRecordD :: Name -> [MessageContext] -> Q Dec
messageRecordD name messageContexts = dataD (cxt []) name [] Nothing [con] []
where
@@ -169,14 +201,6 @@ messageRecordD name messageContexts = dataD (cxt []) name [] Nothing [con] []
returnType = buildTupleType $ sequence $ catMaybes $ argumentReturnType <$> msg.msgSpec.arguments
-interfaceSideInstanceDs :: InterfaceSpec -> Q [Dec]
-interfaceSideInstanceDs interface = execWriterT do
- tellQ $ instanceD (pure []) ([t|IsInterfaceSide 'Client $iT|]) [createProxyD Client]
- tellQ $ instanceD (pure []) ([t|IsInterfaceSide 'Server $iT|]) [createProxyD Server]
- where
- iT = interfaceT interface
- createProxyD :: Side -> Q Dec
- createProxyD side = funD 'createProxy [clause [] (normalB [|undefined|]) []]
interfaceN :: InterfaceSpec -> Name
@@ -200,6 +224,9 @@ eventsT interface = if (length interface.events) > 0 then Just (conT (eventsName
orVoid :: Maybe (Q Type) -> Q Type
orVoid = fromMaybe [t|Void|]
+orUnit :: Maybe (Q Type) -> Q Type
+orUnit = fromMaybe [t|()|]
+
data MessageContext = MessageContext {
--
GitLab