Send wl_display.delete_id

src/Quasar/Wayland/Client.hs

@@ -48,7 +48,7 @@ newWaylandClient socket = do
   }
   where
     newClientDisplay :: STM ((Object 'Client Interface_wl_display, Registry), ProtocolHandle 'Client)
-    newClientDisplay = initializeProtocol wlDisplayEventHandler initalize
+    newClientDisplay = initializeProtocol wlDisplayEventHandler (\_ _ -> unreachableCodePathM) initalize
 
     initalize :: Object 'Client Interface_wl_display -> STM (Object 'Client Interface_wl_display, Registry)
     initalize wlDisplay = do

src/Quasar/Wayland/Protocol/Core.hs

@@ -42,7 +42,6 @@ module Quasar.Wayland.Protocol.Core (
   -- * Low-level protocol interaction
   objectWireArgument,
   nullableObjectWireArgument,
-  handleDestructor,
   checkObject,
   sendMessage,
   newObject,
@@ -71,7 +70,7 @@ module Quasar.Wayland.Protocol.Core (
 ) where
 
 import Control.Monad.Catch
-import Control.Monad.Reader (ReaderT, runReaderT, ask, lift)
+import Control.Monad.Reader (ReaderT, runReaderT, ask, asks, lift)
 import Data.Binary
 import Data.Binary.Get
 import Data.Binary.Put
@@ -104,6 +103,9 @@ newtype GenericObjectId = GenericObjectId Word32
 toGenericObjectId :: ObjectId j -> GenericObjectId
 toGenericObjectId (ObjectId oId) = GenericObjectId oId
 
+objectIdValue :: ObjectId j -> Word32
+objectIdValue (ObjectId value) = value
+
 type Opcode = Word16
 
 type Version = Word32
@@ -243,6 +245,8 @@ class Typeable s => IsSide (s :: Side) where
   type WireDown s i
   initialId :: Word32
   maximumId :: Word32
+  -- | Should be called by generated code _after_ calling a destructor.
+  handleDestructor :: IsInterfaceSide s i => Object s i -> ProtocolM s () -> ProtocolM s ()
 
 instance IsSide 'Client where
   type MessageHandler 'Client i = EventHandler i
@@ -251,6 +255,7 @@ instance IsSide 'Client where
   -- Id #1 is reserved for wl_display
   initialId = 2
   maximumId = 0xfeffffff
+  handleDestructor object msgFn = handleDestructorPre object >> msgFn
 
 instance IsSide 'Server where
   type MessageHandler 'Server i = RequestHandler i
@@ -258,6 +263,21 @@ instance IsSide 'Server where
   type WireDown 'Server i = WireRequest i
   initialId = 0xff000000
   maximumId = 0xffffffff
+  handleDestructor object msgFn = do
+    handleDestructorPre object
+    msgFn
+    when (oid <= maximumId @'Client) do
+      sendWlDisplayDeleteId :: Word32 -> STM () <- asks (.sendWlDisplayDeleteId)
+      liftSTM $ sendWlDisplayDeleteId oid
+    where
+      oid :: Word32
+      oid = objectIdValue object.objectId
+
+-- Shared destructor code for client and server
+handleDestructorPre :: IsInterfaceSide s i => Object s i -> ProtocolM s ()
+handleDestructorPre object = do
+  traceM $ "Destroying " <> showObject object
+  lift $ writeTVar object.destroyed True
 
 
 class (
@@ -416,13 +436,14 @@ data ProtocolState (s :: Side) = ProtocolState {
   outboxVar :: TVar (Maybe Put),
   outboxFdsVar :: TVar (Seq Fd),
   objectsVar :: TVar (HashMap GenericObjectId (SomeObject s)),
-  nextIdVar :: TVar Word32
+  nextIdVar :: TVar Word32,
+  sendWlDisplayDeleteId :: Word32 -> STM ()
 }
 
 type ProtocolM s a = ReaderT (ProtocolState s) STM a
 
 askProtocol :: ProtocolM s (ProtocolHandle s)
-askProtocol = (.protocolHandle) <$> ask
+askProtocol = asks (.protocolHandle)
 
 readProtocolVar :: (ProtocolState s -> TVar a) -> ProtocolM s a
 readProtocolVar fn = do
@@ -457,9 +478,13 @@ swapProtocolVar fn x = do
 initializeProtocol
   :: forall s wl_display a. (IsInterfaceSide s wl_display)
   => (ProtocolHandle s -> MessageHandler s wl_display)
+  -- FIXME only required for server code
+  -> (Object s wl_display -> Word32 -> STM ())
+  -- ^ Send a wl_display.delete_id message. Because this is part of the core protocol but generated from the xml it has
+  -- to be provided by the main server module.
   -> (Object s wl_display -> STM a)
   -> STM (a, ProtocolHandle s)
-initializeProtocol wlDisplayMessageHandler initializationAction = do
+initializeProtocol wlDisplayMessageHandler sendWlDisplayDeleteId initializationAction = do
   bytesReceivedVar <- newTVar 0
   bytesSentVar <- newTVar 0
   inboxDecoderVar <- newTVar $ runGetIncremental getRawMessage
@@ -477,6 +502,10 @@ initializeProtocol wlDisplayMessageHandler initializationAction = do
     stateVar
   }
 
+  messageHandlerVar <- newTVar (Just (wlDisplayMessageHandler protocol))
+  destroyed <- newTVar False
+  let wlDisplay = Object protocol wlDisplayId messageHandlerVar destroyed
+
   let state = ProtocolState {
     protocolHandle = protocol,
     protocolKey,
@@ -487,13 +516,11 @@ initializeProtocol wlDisplayMessageHandler initializationAction = do
     outboxVar,
     outboxFdsVar,
     objectsVar,
-    nextIdVar
+    nextIdVar,
+    sendWlDisplayDeleteId = (sendWlDisplayDeleteId wlDisplay)
   }
   writeTVar stateVar (Right state)
 
-  messageHandlerVar <- newTVar (Just (wlDisplayMessageHandler protocol))
-  destroyed <- newTVar False
-  let wlDisplay = Object protocol wlDisplayId messageHandlerVar destroyed
   modifyTVar' objectsVar (HM.insert (toGenericObjectId wlDisplayId) (SomeObject wlDisplay))
 
   result <- initializationAction wlDisplay
@@ -675,12 +702,6 @@ handleWlDisplayDeleteId protocol oId = runProtocolM protocol do
   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
   -- TODO check if object belongs to current connection

src/Quasar/Wayland/Protocol/TH.hs

@@ -258,7 +258,7 @@ interfaceDecs interface = do
         msgHandlerE = [|$(appTypeE [|getField|] fieldNameLitT) $handlerE|]
         bodyE :: Q Exp
         bodyE
-          | msg.msgSpec.isDestructor = [|handleDestructor $objectE >> $msgE|]
+          | msg.msgSpec.isDestructor = [|handleDestructor $objectE $msgE|]
           | otherwise = msgE
         msgE :: Q Exp
         msgE = [|$(applyMsgArgs msgHandlerE) >>= lift|]
@@ -312,7 +312,7 @@ messageProxyInstanceDecs side messageContexts = mapM messageProxyInstanceD messa
             msgE idArgE = mkWireMsgE (idArgE : (wireArgE <$> args))
 
         dtorE :: Q Exp
-        dtorE = [|handleDestructor object >> $normalE|]
+        dtorE = [|handleDestructor object $normalE|]
 
         -- Body for a normal (i.e. non-constructor) proxy
         normalE :: Q Exp

src/Quasar/Wayland/Server.hs

@@ -41,7 +41,7 @@ newWaylandServerConnection server socket = do
   }
   where
     newServerDisplay :: STM (Object 'Server Interface_wl_display, ProtocolHandle 'Server)
-    newServerDisplay = initializeProtocol wlDisplayRequestHandler pure
+    newServerDisplay = initializeProtocol wlDisplayRequestHandler (.delete_id) pure
 
     wlDisplayRequestHandler :: ProtocolHandle 'Server -> RequestHandler_wl_display
     wlDisplayRequestHandler _protocol =