Re-introduce Registry module

quasar-wayland.cabal

@@ -75,6 +75,7 @@ library
   import: shared-properties
   exposed-modules:
     Quasar.Wayland.Client
+    Quasar.Wayland.Client.Registry
     Quasar.Wayland.Client.Socket
     Quasar.Wayland.Connection
     Quasar.Wayland.Protocol

src/Quasar/Wayland/Client.hs

 module Quasar.Wayland.Client (
-  WaylandClient(display),
+  WaylandClient(registry),
   connectWaylandClient,
   newWaylandClient,
-  connectWaylandSocket,
-
-  -- * wl_display
-  ClientDisplay,
-  newClientDisplay,
 
   -- * wl_registry
-  ClientRegistry,
-  createClientRegistry,
+  Registry,
 ) where
 
 import Control.Concurrent.STM
 import Control.Monad.Catch
-import Data.HashMap.Strict qualified as HM
-import Data.Tuple (swap)
 import GHC.Records
 import Network.Socket (Socket)
 import Quasar
 import Quasar.Prelude
+import Quasar.Wayland.Client.Registry
 import Quasar.Wayland.Client.Socket
 import Quasar.Wayland.Connection
 import Quasar.Wayland.Protocol
@@ -30,86 +23,41 @@ import Quasar.Wayland.Protocol.Generated
 
 data WaylandClient = WaylandClient {
   connection :: WaylandConnection 'Client,
-  display :: ClientDisplay
+  wlDisplay :: Object 'Client Interface_wl_display,
+  registry :: Registry
 }
 
 instance IsResourceManager WaylandClient where
-  toResourceManager (WaylandClient connection _) = toResourceManager connection
+  toResourceManager client = toResourceManager client.connection
 
 instance IsDisposable WaylandClient where
-  toDisposable (WaylandClient connection _) = toDisposable connection
-
-newWaylandClient :: MonadResourceManager m => Socket -> m WaylandClient
-newWaylandClient socket = do
-  (display, connection) <- newWaylandConnection newClientDisplay socket
-  pure WaylandClient {
-    connection,
-    display
-  }
+  toDisposable client = toDisposable client.connection
 
 connectWaylandClient :: MonadResourceManager m => m WaylandClient
 connectWaylandClient = mask_ do
   socket <- liftIO connectWaylandSocket
   newWaylandClient socket
 
+newWaylandClient :: MonadResourceManager m => Socket -> m WaylandClient
+newWaylandClient socket = do
+  ((wlDisplay, registry), connection) <- newWaylandConnection newClientDisplay socket
+  pure WaylandClient {
+    connection,
+    wlDisplay,
+    registry
+  }
+  where
+    newClientDisplay :: STM ((Object 'Client Interface_wl_display, Registry), ProtocolHandle 'Client)
+    newClientDisplay =
+      initializeProtocol wlDisplayEventHandler \wlDisplay -> do
+        registry <- createRegistry wlDisplay
+        pure (wlDisplay, registry)
 
 
--- * wl_display
-
-data ClientDisplay = ClientDisplay {
-  wlDisplay :: Object 'Client Interface_wl_display,
-  registry :: ClientRegistry
-}
-
-newClientDisplay :: STM (ClientDisplay, ProtocolHandle 'Client)
-newClientDisplay =
-  initializeProtocol wlDisplayEventHandler \wlDisplay -> do
-    registry <- createClientRegistry wlDisplay
-    pure ClientDisplay {
-      wlDisplay,
-      registry
-    }
 
-instance HasField "sync" ClientDisplay (STM (Awaitable ())) where
-  getField display = do
+instance HasField "sync" WaylandClient (STM (Awaitable ())) where
+  getField client = do
     var <- newAsyncVarSTM
-    wlCallback <- display.wlDisplay.sync
-    setEventHandler wlCallback EventHandler_wl_callback {
-      done = const $ putAsyncVarSTM_ var ()
-    }
+    lowLevelSync client.wlDisplay \_ -> putAsyncVarSTM_ var ()
     pure $ toAwaitable var
 
-
-
--- * wl_registry
-
-data ClientRegistry = ClientRegistry {
-  wlRegistry :: Object 'Client Interface_wl_registry,
-  globalsVar :: TVar (HM.HashMap Word32 (WlString, Word32))
-}
-
-createClientRegistry :: Object 'Client Interface_wl_display -> STM ClientRegistry
-createClientRegistry wlDisplay = mfix \clientRegistry -> do
-  globalsVar <- newTVar HM.empty
-
-  wlRegistry <- wlDisplay.get_registry
-  setMessageHandler wlRegistry (messageHandler clientRegistry)
-
-  pure ClientRegistry {
-    wlRegistry,
-    globalsVar
-  }
-  where
-    messageHandler :: ClientRegistry -> EventHandler_wl_registry
-    messageHandler clientRegistry = EventHandler_wl_registry { global, global_remove }
-      where
-        global :: Word32 -> WlString -> Word32 -> STM ()
-        global name interface version = do
-          modifyTVar clientRegistry.globalsVar (HM.insert name (interface, version))
-
-        global_remove :: Word32 -> STM ()
-        global_remove name = do
-          result <- stateTVar clientRegistry.globalsVar (swap . lookupDelete name)
-          case result of
-            Nothing -> traceM $ "Invalid global removed by server: " <> show name
-            Just (interface, version) -> pure ()

src/Quasar/Wayland/Client/Registry.hs

+module Quasar.Wayland.Client.Registry (
+  Registry,
+  createRegistry
+) where
+
+import Control.Concurrent.STM
+import Data.HashMap.Strict qualified as HM
+import Data.Tuple (swap)
+import Quasar
+import Quasar.Prelude
+import Quasar.Wayland.Protocol
+import Quasar.Wayland.Protocol.Display
+import Quasar.Wayland.Protocol.Generated
+
+-- * wl_registry
+
+data Registry = Registry {
+  wlRegistry :: Object 'Client Interface_wl_registry,
+  globalsVar :: TVar (HM.HashMap Word32 (WlString, Word32)),
+  initialSyncComplete :: Awaitable ()
+}
+
+createRegistry :: Object 'Client Interface_wl_display -> STM Registry
+createRegistry wlDisplay = mfix \clientRegistry -> do
+  globalsVar <- newTVar HM.empty
+
+  wlRegistry <- wlDisplay.get_registry
+  setMessageHandler wlRegistry (messageHandler clientRegistry)
+
+  -- Manual sync (without high-level wrapper) to prevent a dependency loop to the client
+  var <- newAsyncVarSTM
+  lowLevelSync wlDisplay \_ -> putAsyncVarSTM_ var ()
+  let initialSyncComplete = toAwaitable var
+
+  pure Registry {
+    wlRegistry,
+    globalsVar,
+    initialSyncComplete
+  }
+  where
+    messageHandler :: Registry -> EventHandler_wl_registry
+    messageHandler clientRegistry = EventHandler_wl_registry { global, global_remove }
+      where
+        global :: Word32 -> WlString -> Word32 -> STM ()
+        global name interface version = do
+          modifyTVar clientRegistry.globalsVar (HM.insert name (interface, version))
+
+        global_remove :: Word32 -> STM ()
+        global_remove name = do
+          result <- stateTVar clientRegistry.globalsVar (swap . lookupDelete name)
+          case result of
+            Nothing -> traceM $ "Invalid global removed by server: " <> show name
+            Just (interface, version) -> pure ()

src/Quasar/Wayland/Protocol/Display.hs

 module Quasar.Wayland.Protocol.Display (
+  lowLevelSync,
   wlDisplayEventHandler,
 ) where
 
 import Control.Monad.Catch
+import Control.Monad.STM
 import Quasar.Prelude
 import Quasar.Wayland.Protocol.Core
 import Quasar.Wayland.Protocol.Generated
@@ -18,3 +20,11 @@ wlDisplayEventHandler = EventHandler_wl_display { error = waylandError, delete_i
   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
+  setEventHandler wlCallback EventHandler_wl_callback {
+    done = callback
+  }