From 6948fd25a82a1bb671bc26303eb589bfd95c7680 Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Sun, 24 Jul 2022 20:43:52 +0200
Subject: [PATCH] Handle destructor messages
---
src/Quasar/Wayland/Protocol/Core.hs | 25 +++++++++-------
src/Quasar/Wayland/Protocol/TH.hs | 44 +++++++++++++++++++++--------
2 files changed, 47 insertions(+), 22 deletions(-)
diff --git a/src/Quasar/Wayland/Protocol/Core.hs b/src/Quasar/Wayland/Protocol/Core.hs
index 21edd76..5d8f742 100644
--- a/src/Quasar/Wayland/Protocol/Core.hs
+++ b/src/Quasar/Wayland/Protocol/Core.hs
@@ -17,7 +17,6 @@ module Quasar.Wayland.Protocol.Core (
Version,
interfaceVersion,
IsInterfaceSide(..),
- IsInterfaceHandler(..),
Object(objectProtocol),
setEventHandler,
setRequestHandler,
@@ -41,6 +40,7 @@ module Quasar.Wayland.Protocol.Core (
-- * Low-level protocol interaction
objectWireArgument,
nullableObjectWireArgument,
+ handleDestructor,
checkObject,
sendMessage,
newObject,
@@ -260,7 +260,7 @@ class (
IsMessage (WireDown s i)
)
=> IsInterfaceSide (s :: Side) i where
- handleMessage :: MessageHandler s i -> WireDown s i -> ProtocolM s ()
+ handleMessage :: Object s i -> 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))
@@ -270,10 +270,6 @@ putWireUp :: forall s i. IsInterfaceSide s i => Object s i -> WireUp s i -> Eith
putWireUp _ = putMessage @(WireUp s i)
-class IsInterfaceSide s i => IsInterfaceHandler s i a where
- handlerHandleMessage :: a -> Object s i -> WireDown s i -> ProtocolM s ()
-
-
-- | Data kind
data Side = Client | Server
deriving stock (Eq, Show)
@@ -283,7 +279,8 @@ data Side = Client | Server
data Object s i = IsInterfaceSide s i => Object {
objectProtocol :: (ProtocolHandle s),
objectId :: ObjectId (InterfaceName i),
- messageHandler :: TVar (Maybe (MessageHandler s i))
+ messageHandler :: TVar (Maybe (MessageHandler s i)),
+ destroyed :: TVar Bool
}
@@ -488,7 +485,8 @@ initializeProtocol wlDisplayMessageHandler initializationAction = do
writeTVar stateVar (Right state)
messageHandlerVar <- newTVar (Just (wlDisplayMessageHandler protocol))
- let wlDisplay = Object protocol wlDisplayId messageHandlerVar
+ destroyed <- newTVar False
+ let wlDisplay = Object protocol wlDisplayId messageHandlerVar destroyed
modifyTVar' objectsVar (HM.insert (toGenericObjectId wlDisplayId) (SomeObject wlDisplay))
result <- initializationAction wlDisplay
@@ -591,8 +589,9 @@ newObjectFromId
newObjectFromId messageHandler (NewId oId) = do
protocol <- askProtocol
messageHandlerVar <- lift $ newTVar messageHandler
+ destroyed <- lift $ newTVar False
let
- object = Object protocol oId messageHandlerVar
+ object = Object protocol oId messageHandlerVar destroyed
someObject = SomeObject object
modifyProtocolVar (.objectsVar) (HM.insert (genericObjectId object) someObject)
pure object
@@ -665,9 +664,15 @@ handleWlDisplayError _protocol oId code message = throwM $ ServerError code (toS
-- to be called from the client module.
handleWlDisplayDeleteId :: ProtocolHandle 'Client -> Word32 -> STM ()
handleWlDisplayDeleteId protocol oId = runProtocolM protocol do
+ -- TODO call destructor
modifyProtocolVar (.objectsVar) $ HM.delete (GenericObjectId oId)
+handleDestructor :: IsInterfaceSide s i => Object s i -> ProtocolM s ()
+handleDestructor object = do
+ traceM $ "Handling destructor for " <> showObject object
+ lift $ writeTVar object.destroyed True
+
checkObject :: IsInterface i => Object s i -> ProtocolM s (Either String ())
checkObject object = do
@@ -748,7 +753,7 @@ handleRawMessage (oId, opcode, body) = do
message <- verifyMessage
traceM $ "<- " <> showObjectMessage object message
messageHandler <- lift $ getMessageHandler object
- handleMessage @s @i messageHandler message
+ handleMessage @s @i object 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 9a53e0e..489df04 100644
--- a/src/Quasar/Wayland/Protocol/TH.hs
+++ b/src/Quasar/Wayland/Protocol/TH.hs
@@ -15,7 +15,7 @@ import Language.Haskell.TH
import Language.Haskell.TH.Syntax (addDependentFile)
import Quasar.Prelude
import Quasar.Wayland.Protocol.Core
-import System.Posix.Types (Fd(Fd))
+import System.Posix.Types (Fd)
import Text.Read (readEither)
import Text.XML.Light
@@ -150,27 +150,27 @@ interfaceDecs interface = do
tySynInstD (tySynEqn Nothing (appT (conT ''InterfaceName) iT) (litT (strTyLit interface.name))),
tySynInstD (tySynEqn Nothing (appT (conT ''InterfaceVersion) iT) (litT (numTyLit interface.version)))
]
- -- | IsInterfaceSide instance
+ -- IsInterfaceSide instance
tellQs interfaceSideInstanceDs
when (length interface.requests > 0) do
- -- | Requests record
+ -- Requests record
tellQ requestCallbackRecordD
- -- | Request proxies
+ -- Request proxies
tellQs requestProxyInstanceDecs
when (length interface.events > 0) do
- -- | Events record
+ -- Events record
tellQ eventCallbackRecordD
- -- | Event proxies
+ -- Event proxies
tellQs eventProxyInstanceDecs
internals <- execWriterT do
- -- | Request wire type
+ -- Request wire type
when (length interface.requests > 0) do
tellQs $ messageTypeDecs rTypeName wireRequestContexts
- -- | Event wire type
+ -- Event wire type
when (length interface.events > 0) do
tellQs $ messageTypeDecs eTypeName wireEventContexts
@@ -222,6 +222,12 @@ interfaceDecs interface = do
eventProxyInstanceDecs :: Q [Dec]
eventProxyInstanceDecs = messageProxyInstanceDecs Server wireEventContexts
+ objectName = mkName "object"
+ objectP :: Q Pat
+ objectP = varP objectName
+ objectE :: Q Exp
+ objectE = varE objectName
+
handlerName = mkName "handler"
handlerP :: Q Pat
handlerP = varP handlerName
@@ -238,18 +244,24 @@ interfaceDecs interface = do
handleMessageD Server = funD 'handleMessage (handleMessageClauses wireRequestContexts)
handleMessageClauses :: [MessageContext] -> [Q Clause]
- handleMessageClauses [] = [clause [wildP] (normalB [|absurd|]) []]
+ handleMessageClauses [] = [clause [wildP, wildP] (normalB [|absurd|]) []]
handleMessageClauses messageContexts = handleMessageClause <$> messageContexts
handleMessageClause :: MessageContext -> Q Clause
- handleMessageClause msg = clause [handlerP, msgConP msg] (normalB bodyE) []
+ handleMessageClause msg = clause [objectIfRequiredP, handlerP, msgConP msg] (normalB bodyE) []
where
+ objectIfRequiredP :: Q Pat
+ objectIfRequiredP = if msg.msgSpec.isDestructor then objectP else wildP
fieldNameLitT :: Q Type
fieldNameLitT = litT (strTyLit (messageFieldNameString msg))
msgHandlerE :: Q Exp
msgHandlerE = [|$(appTypeE [|getField|] fieldNameLitT) $handlerE|]
bodyE :: Q Exp
- bodyE = [|lift =<< $(applyMsgArgs msgHandlerE)|]
+ bodyE
+ | msg.msgSpec.isDestructor = [|handleDestructor $objectE >> $msgE|]
+ | otherwise = msgE
+ msgE :: Q Exp
+ msgE = [|$(applyMsgArgs msgHandlerE) >>= lift|]
applyMsgArgs :: Q Exp -> Q Exp
applyMsgArgs base = applyA base (argE <$> msg.msgSpec.arguments)
@@ -287,7 +299,10 @@ messageProxyInstanceDecs side messageContexts = mapM messageProxyInstanceD messa
args = proxyArguments msg.msgSpec
actionE :: Q Exp
- actionE = if msg.msgSpec.isConstructor then ctorE else normalE
+ actionE
+ | msg.msgSpec.isConstructor = ctorE
+ | msg.msgSpec.isDestructor = dtorE
+ | otherwise = normalE
-- Constructor: the first argument becomes the return value
ctorE :: Q Exp
@@ -296,6 +311,9 @@ messageProxyInstanceDecs side messageContexts = mapM messageProxyInstanceD messa
msgE :: Q Exp -> Q Exp
msgE idArgE = mkWireMsgE (idArgE : (wireArgE <$> args))
+ dtorE :: Q Exp
+ dtorE = [|handleDestructor object >> $normalE|]
+
-- Body for a normal (i.e. non-constructor) proxy
normalE :: Q Exp
normalE = [|sendMessage object =<< $(msgE)|]
@@ -603,6 +621,8 @@ parseMessage isRequest interface (opcode, element) = do
Just "destructor" -> pure True
Just messageType -> fail $ "Unknown message type: " <> messageType
+ when (isDestructor && not (null arguments)) $ fail $ "Destructor must not have arguments: " <> loc
+
forM_ arguments \arg -> do
when
do arg.argType == GenericNewIdArgument && (interface /= "wl_registry" || name /= "bind")
--
GitLab