Refactor wl_display to keep core implementation free from generated code

quasar-wayland.cabal

@@ -77,9 +77,9 @@ library
     Quasar.Wayland.Client
     Quasar.Wayland.Client.Registry
     Quasar.Wayland.Client.Socket
+    Quasar.Wayland.Client.Sync
     Quasar.Wayland.Connection
     Quasar.Wayland.Protocol
-    Quasar.Wayland.Protocol.Display
     Quasar.Wayland.Protocol.Generated
     Quasar.Wayland.Protocol.TH
   other-modules:

src/Quasar/Wayland/Client.hs

@@ -13,11 +13,11 @@ import GHC.Records
 import Network.Socket (Socket)
 import Quasar
 import Quasar.Prelude
+import Quasar.Wayland.Client.Sync
 import Quasar.Wayland.Client.Registry
 import Quasar.Wayland.Client.Socket
 import Quasar.Wayland.Connection
 import Quasar.Wayland.Protocol
-import Quasar.Wayland.Protocol.Display
 import Quasar.Wayland.Protocol.Generated
 
 
@@ -48,10 +48,19 @@ newWaylandClient socket = do
   }
   where
     newClientDisplay :: STM ((Object 'Client Interface_wl_display, Registry), ProtocolHandle 'Client)
-    newClientDisplay =
-      initializeProtocol wlDisplayEventHandler \wlDisplay -> do
-        registry <- createRegistry wlDisplay
-        pure (wlDisplay, registry)
+    newClientDisplay = initializeProtocol wlDisplayEventHandler init
+
+    init :: Object 'Client Interface_wl_display -> STM (Object 'Client Interface_wl_display, Registry)
+    init wlDisplay = do
+      registry <- createRegistry wlDisplay
+      pure (wlDisplay, registry)
+
+    wlDisplayEventHandler :: ProtocolHandle 'Client -> EventHandler_wl_display
+    wlDisplayEventHandler protocol =
+      EventHandler_wl_display {
+        error = handleWlDisplayError protocol,
+        delete_id = handleWlDisplayDeleteId protocol
+      }
 
 
 

src/Quasar/Wayland/Client/Registry.hs

@@ -8,8 +8,8 @@ import Data.HashMap.Strict qualified as HM
 import Data.Tuple (swap)
 import Quasar
 import Quasar.Prelude
+import Quasar.Wayland.Client.Sync
 import Quasar.Wayland.Protocol
-import Quasar.Wayland.Protocol.Display
 import Quasar.Wayland.Protocol.Generated
 
 -- * wl_registry

src/Quasar/Wayland/Protocol/Display.hs → src/Quasar/Wayland/Client/Sync.hs

-module Quasar.Wayland.Protocol.Display (
+module Quasar.Wayland.Client.Sync (
   lowLevelSync,
-  wlDisplayEventHandler,
 ) where
 
-import Control.Monad.Catch
 import Control.Monad.STM
 import Quasar.Prelude
-import Quasar.Wayland.Protocol.Core
+import Quasar.Wayland.Protocol
 import Quasar.Wayland.Protocol.Generated
 
-
-
--- | Default implementation for @wl_display@ that handles errors and confirms deleted object ids.
---
--- This is only required when manually managing the @wl_display@ interface (usually it's applied by
--- 'Quasar.Wayland.Display.newClientDisplay').
-wlDisplayEventHandler :: EventHandler_wl_display
-wlDisplayEventHandler = EventHandler_wl_display { error = waylandError, delete_id }
-  where
-    waylandError oId code message = throwM $ ServerError code (toString message)
-    delete_id deletedId = pure () -- TODO confirm delete
-
-
 lowLevelSync :: Object 'Client Interface_wl_display -> (Word32 -> STM ()) -> STM ()
 lowLevelSync wlDisplay callback = do
   wlCallback <- wlDisplay.sync

src/Quasar/Wayland/Protocol.hs

@@ -32,6 +32,10 @@ module Quasar.Wayland.Protocol (
   interfaceName,
   Side(..),
   IsSide,
+
+  -- * wl_display interface
+  handleWlDisplayError,
+  handleWlDisplayDeleteId,
 ) where
 
 import Quasar.Wayland.Protocol.Core

src/Quasar/Wayland/Protocol/Core.hs

@@ -43,6 +43,10 @@ module Quasar.Wayland.Protocol.Core (
   getObject,
   lookupObject,
 
+  -- * wl_display interface
+  handleWlDisplayError,
+  handleWlDisplayDeleteId,
+
   -- * Protocol exceptions
   WireCallbackFailed(..),
   ParserFailed(..),
@@ -420,7 +424,7 @@ stateProtocolVar fn x = do
 
 initializeProtocol
   :: forall s wl_display a. (IsInterfaceSide s wl_display)
-  => MessageHandler s wl_display
+  => (ProtocolHandle s -> MessageHandler s wl_display)
   -> (Object s wl_display -> STM a)
   -> STM (a, ProtocolHandle s)
 initializeProtocol wlDisplayMessageHandler initializationAction = do
@@ -451,7 +455,7 @@ initializeProtocol wlDisplayMessageHandler initializationAction = do
   }
   writeTVar stateVar (Right state)
 
-  messageHandlerVar <- newTVar (Just wlDisplayMessageHandler)
+  messageHandlerVar <- newTVar (Just (wlDisplayMessageHandler protocol))
   let wlDisplay = Object protocol wlDisplayId messageHandlerVar
   modifyTVar' objectsVar (HM.insert (toGenericObjectId wlDisplayId) (SomeObject wlDisplay))
 
@@ -592,6 +596,20 @@ getObject oId = either (throwM . InvalidObject) pure =<< lookupObject oId
 
 
 
+-- | Handle a wl_display.error message. Because this is part of the core protocol but generated from the xml it has to
+-- be called from the client module.
+handleWlDisplayError :: ProtocolHandle 'Client -> GenericObjectId -> Word32 -> WlString -> STM ()
+handleWlDisplayError _protocol oId code message = throwM $ ServerError code (toString message)
+
+-- | Handle a wl_display.delete_id message. Because this is part of the core protocol but generated from the xml it has
+-- to be called from the client module.
+handleWlDisplayDeleteId :: ProtocolHandle 'Client -> Word32 -> STM ()
+handleWlDisplayDeleteId protocol oId = runProtocolM protocol do
+  modifyProtocolVar (.objectsVar) $ HM.delete (GenericObjectId oId)
+  traceM $ mconcat ["Deleted object id ", show oId]
+
+
+
 -- | Sends a message without checking any ids or creating proxy objects objects. (TODO)
 sendMessage :: forall s i. IsInterfaceSide s i => Object s i -> WireUp s i -> ProtocolM s ()
 sendMessage object message = do