From 9714aaac55fdb6a616e38576ccdd99701a844fea Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Wed, 15 Dec 2021 07:28:23 +0100
Subject: [PATCH] Re-introduce Registry module
---
quasar-wayland.cabal | 1 +
src/Quasar/Wayland/Client.hs | 100 ++++++-------------------
src/Quasar/Wayland/Client/Registry.hs | 53 +++++++++++++
src/Quasar/Wayland/Protocol/Display.hs | 10 +++
4 files changed, 88 insertions(+), 76 deletions(-)
create mode 100644 src/Quasar/Wayland/Client/Registry.hs
diff --git a/quasar-wayland.cabal b/quasar-wayland.cabal
index ebb8ae0..0131719 100644
--- a/quasar-wayland.cabal
+++ b/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
diff --git a/src/Quasar/Wayland/Client.hs b/src/Quasar/Wayland/Client.hs
index c9bcf13..ee2b9f0 100644
--- a/src/Quasar/Wayland/Client.hs
+++ b/src/Quasar/Wayland/Client.hs
@@ -1,26 +1,19 @@
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 ()
diff --git a/src/Quasar/Wayland/Client/Registry.hs b/src/Quasar/Wayland/Client/Registry.hs
new file mode 100644
index 0000000..26ee1e6
--- /dev/null
+++ b/src/Quasar/Wayland/Client/Registry.hs
@@ -0,0 +1,53 @@
+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 ()
diff --git a/src/Quasar/Wayland/Protocol/Display.hs b/src/Quasar/Wayland/Protocol/Display.hs
index 6f9bb63..c37e3e1 100644
--- a/src/Quasar/Wayland/Protocol/Display.hs
+++ b/src/Quasar/Wayland/Protocol/Display.hs
@@ -1,8 +1,10 @@
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
+ }
--
GitLab