Handle destructor messages

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)
 

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")