From 169767197b7e8c5c865e0486909e83f65974aa51 Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Mon, 13 Dec 2021 22:39:29 +0100
Subject: [PATCH] Simplify message handling, remove (now) unused exports
---
src/Quasar/Wayland/Display.hs | 4 +---
src/Quasar/Wayland/Protocol.hs | 6 +++---
src/Quasar/Wayland/Protocol/Core.hs | 23 +++++++++++++----------
src/Quasar/Wayland/Protocol/TH.hs | 20 ++++++++++----------
4 files changed, 27 insertions(+), 26 deletions(-)
diff --git a/src/Quasar/Wayland/Display.hs b/src/Quasar/Wayland/Display.hs
index 3d84912..c42353e 100644
--- a/src/Quasar/Wayland/Display.hs
+++ b/src/Quasar/Wayland/Display.hs
@@ -15,9 +15,7 @@ data ClientDisplay = ClientDisplay {
registry :: ClientRegistry
}
-newClientDisplay
- :: (IsInterfaceSide 'Client Interface_wl_display)
- => STM (ClientDisplay, ProtocolHandle 'Client)
+newClientDisplay :: STM (ClientDisplay, ProtocolHandle 'Client)
newClientDisplay =
initializeProtocol wlDisplayEventHandler \wlDisplay -> do
registry <- createClientRegistry wlDisplay
diff --git a/src/Quasar/Wayland/Protocol.hs b/src/Quasar/Wayland/Protocol.hs
index 94d7612..6cbd1ad 100644
--- a/src/Quasar/Wayland/Protocol.hs
+++ b/src/Quasar/Wayland/Protocol.hs
@@ -3,6 +3,8 @@ module Quasar.Wayland.Protocol (
-- | This module exports everything required to implement Wayland interfaces generated by
-- "Quasar.Wayland.Protocol.TH".
+ Object,
+
-- ** Wire types
ObjectId,
GenericObjectId,
@@ -14,8 +16,7 @@ module Quasar.Wayland.Protocol (
IsInterface(InterfaceName),
interfaceName,
Side(..),
- IsSide(WireUp, WireDown),
- IsInterfaceSide,
+ IsSide,
-- ** Protocol execution
ProtocolHandle,
@@ -28,7 +29,6 @@ module Quasar.Wayland.Protocol (
ProtocolM,
runProtocolTransaction,
runProtocolM,
- Object,
newObject,
sendMessage,
diff --git a/src/Quasar/Wayland/Protocol/Core.hs b/src/Quasar/Wayland/Protocol/Core.hs
index 754cc1f..fa77c9e 100644
--- a/src/Quasar/Wayland/Protocol/Core.hs
+++ b/src/Quasar/Wayland/Protocol/Core.hs
@@ -16,7 +16,7 @@ module Quasar.Wayland.Protocol.Core (
interfaceName,
IsInterfaceSide(..),
IsInterfaceHandler(..),
- Object(messageHandler),
+ Object,
IsObject,
IsMessage(..),
ProtocolHandle,
@@ -29,10 +29,10 @@ module Quasar.Wayland.Protocol.Core (
takeOutbox,
runProtocolTransaction,
runProtocolM,
+ enterObject,
-- * Low-level protocol interaction
sendMessage,
- objectSendMessage,
newObject,
newObjectFromId,
@@ -223,7 +223,7 @@ class (
IsMessage (WireDown s i)
)
=> IsInterfaceSide (s :: Side) i where
- objectHandleMessage :: Object s i -> WireDown s i -> STM ()
+ handleMessage :: MessageHandler s i -> WireDown s i -> ProtocolM s ()
getWireDown :: forall s i. IsInterfaceSide s i => Object s i -> Opcode -> Get (ProtocolM s (WireDown s i))
@@ -244,7 +244,7 @@ data Side = Client | Server
data Object s i = IsInterfaceSide s i => Object {
objectProtocol :: (ProtocolHandle s),
objectObjectId :: GenericObjectId,
- messageHandler :: (MessageHandler s i)
+ messageHandler :: TMVar (MessageHandler s i)
}
instance IsInterface i => Show (Object s i) where
@@ -423,7 +423,8 @@ initializeProtocol wlDisplayMessageHandler initializationAction = do
}
writeTVar stateVar (Right state)
- let wlDisplay = Object protocol wlDisplayId wlDisplayMessageHandler
+ messageHandlerVar <- newTMVar wlDisplayMessageHandler
+ let wlDisplay = Object protocol wlDisplayId messageHandlerVar
modifyTVar' objectsVar (HM.insert wlDisplayId (SomeObject wlDisplay))
result <- runReaderT (initializationAction wlDisplay) state
@@ -522,9 +523,10 @@ newObjectFromId
-> ProtocolM s (Object s i)
newObjectFromId (NewId oId) messageHandler = do
protocol <- askProtocol
+ messageHandlerVar <- lift $ newTMVar messageHandler
let
genericObjectId = toGenericObjectId oId
- object = Object protocol genericObjectId messageHandler
+ object = Object protocol genericObjectId messageHandlerVar
someObject = SomeObject object
modifyProtocolVar (.objectsVar) (HM.insert genericObjectId someObject)
pure object
@@ -554,8 +556,8 @@ 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 message = runProtocolM object.objectProtocol $ sendMessage object message
+enterObject :: forall s i a. Object s i -> ProtocolM s a -> STM a
+enterObject object action = runProtocolM object.objectProtocol action
receiveMessages :: IsSide s => ProtocolM s ()
@@ -583,7 +585,7 @@ handleRawMessage (oId, opcode, body) = do
throwM $ ProtocolException $ "Received message for object without handler: " <> interface <> "@" <> show oId
where
getMessageAction
- :: IsInterfaceSide s i
+ :: forall s i. IsInterfaceSide s i
=> Object s i
-> Opcode
-> Get (ProtocolM s ())
@@ -592,7 +594,8 @@ handleRawMessage (oId, opcode, body) = do
pure do
message <- verifyMessage
traceM $ "<- " <> showObjectMessage object message
- lift $ objectHandleMessage object message
+ messageHandler <- lift $ readTMVar object.messageHandler
+ handleMessage @s @i messageHandler message
type RawMessage = (GenericObjectId, Opcode, BSL.ByteString)
diff --git a/src/Quasar/Wayland/Protocol/TH.hs b/src/Quasar/Wayland/Protocol/TH.hs
index e178f56..362ee86 100644
--- a/src/Quasar/Wayland/Protocol/TH.hs
+++ b/src/Quasar/Wayland/Protocol/TH.hs
@@ -190,9 +190,9 @@ interfaceDecs interface = do
eventProxyInstanceDecs :: Q [Dec]
eventProxyInstanceDecs = messageProxyInstanceDecs [t|'Server|] wireEventContexts
- objectName = mkName "object"
- objectP = varP objectName
- objectE = varE objectName
+ handlerName = mkName "handler"
+ handlerP = varP handlerName
+ handlerE = varE handlerName
interfaceSideInstanceDs :: Q [Dec]
interfaceSideInstanceDs = execWriterT do
@@ -200,29 +200,29 @@ interfaceDecs interface = do
tellQ $ instanceD (pure []) ([t|IsInterfaceSide 'Server $iT|]) [handleMessageD Server]
handleMessageD :: Side -> Q Dec
- handleMessageD Client = funD 'objectHandleMessage (handleMessageClauses wireEventContexts)
- handleMessageD Server = funD 'objectHandleMessage (handleMessageClauses wireRequestContexts)
+ handleMessageD Client = funD 'handleMessage (handleMessageClauses wireEventContexts)
+ handleMessageD Server = funD 'handleMessage (handleMessageClauses wireRequestContexts)
handleMessageClauses :: [MessageContext] -> [Q Clause]
handleMessageClauses [] = [clause [wildP] (normalB [|absurd|]) []]
handleMessageClauses messageContexts = handleMessageClause <$> messageContexts
handleMessageClause :: MessageContext -> Q Clause
- handleMessageClause msg = clause [objectP, msgConP msg] (normalB bodyE) []
+ handleMessageClause msg = clause [handlerP, msgConP msg] (normalB bodyE) []
where
fieldNameLitT :: Q Type
fieldNameLitT = litT (strTyLit (messageFieldNameString msg))
- fieldE :: Q Exp
- fieldE = [|$(appTypeE [|getField|] fieldNameLitT) $objectE.messageHandler|]
+ msgHandlerE :: Q Exp
+ msgHandlerE = [|$(appTypeE [|getField|] fieldNameLitT) $handlerE|]
bodyE :: Q Exp
- bodyE = applyMsgArgs msg fieldE
+ bodyE = [|lift $(applyMsgArgs msg msgHandlerE)|]
messageProxyInstanceDecs :: Q Type -> [MessageContext] -> Q [Dec]
messageProxyInstanceDecs sideT messageContexts = mapM messageProxyInstanceD messageContexts
where
messageProxyInstanceD :: MessageContext -> Q Dec
messageProxyInstanceD msg = instanceD (pure []) instanceT [
- funD 'getField [clause ([varP objectName] <> msgArgPats msg) (normalB [|objectSendMessage object $(msgE msg)|]) []]
+ funD 'getField [clause ([varP objectName] <> msgArgPats msg) (normalB [|enterObject object (sendMessage object $(msgE msg))|]) []]
]
where
objectName = mkName "object"
--
GitLab