From ba39db4163ab3994b17f1eb5b6de1500870f8257 Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Tue, 26 Jul 2022 02:58:03 +0200
Subject: [PATCH] Merge sync code and remove some warnings
---
src/Quasar/Wayland/Client.hs | 11 ++++-------
src/Quasar/Wayland/Client/Registry.hs | 7 ++-----
src/Quasar/Wayland/Client/Sync.hs | 8 ++++++++
3 files changed, 14 insertions(+), 12 deletions(-)
diff --git a/src/Quasar/Wayland/Client.hs b/src/Quasar/Wayland/Client.hs
index ac7f70f..ce64551 100644
--- a/src/Quasar/Wayland/Client.hs
+++ b/src/Quasar/Wayland/Client.hs
@@ -48,10 +48,10 @@ newWaylandClient socket = do
}
where
newClientDisplay :: STM ((Object 'Client Interface_wl_display, Registry), ProtocolHandle 'Client)
- newClientDisplay = initializeProtocol wlDisplayEventHandler init
+ newClientDisplay = initializeProtocol wlDisplayEventHandler initalize
- init :: Object 'Client Interface_wl_display -> STM (Object 'Client Interface_wl_display, Registry)
- init wlDisplay = do
+ initalize :: Object 'Client Interface_wl_display -> STM (Object 'Client Interface_wl_display, Registry)
+ initalize wlDisplay = do
registry <- createRegistry wlDisplay
pure (wlDisplay, registry)
@@ -64,7 +64,4 @@ newWaylandClient socket = do
instance HasField "sync" WaylandClient (STM (Future ())) where
- getField client = do
- var <- newPromiseSTM
- lowLevelSync client.wlDisplay \_ -> fulfillPromiseSTM var ()
- pure $ toFuture var
+ getField client = lowLevelSyncFuture client.wlDisplay
diff --git a/src/Quasar/Wayland/Client/Registry.hs b/src/Quasar/Wayland/Client/Registry.hs
index c461cff..bc2f406 100644
--- a/src/Quasar/Wayland/Client/Registry.hs
+++ b/src/Quasar/Wayland/Client/Registry.hs
@@ -7,7 +7,6 @@ module Quasar.Wayland.Client.Registry (
import Control.Monad.Catch
import Data.HashMap.Strict qualified as HM
-import Data.Tuple (swap)
import Quasar
import Quasar.Prelude
import Quasar.Wayland.Client.Sync
@@ -44,9 +43,7 @@ createRegistry wlDisplay = mfix \clientRegistry -> do
setMessageHandler wlRegistry (messageHandler clientRegistry)
-- Manual sync (without high-level wrapper) to prevent a dependency loop to the Client module
- var <- newPromiseSTM
- lowLevelSync wlDisplay \_ -> fulfillPromiseSTM var ()
- let initialSyncComplete = toFuture var
+ initialSyncComplete <- lowLevelSyncFuture wlDisplay
pure Registry {
wlRegistry,
@@ -71,7 +68,7 @@ createRegistry wlDisplay = mfix \clientRegistry -> do
-- | Bind a new client object to a compositor singleton. Throws an exception if the global is not available.
--
--- Blocks until the the registry has sent the initial list of globals.
+-- Will retry until the the registry has sent the initial list of globals.
bindSingleton :: IsInterfaceSide 'Client i => Registry -> STM (Object 'Client i)
bindSingleton registry = either (throwM . ProtocolUsageError) pure =<< tryBindSingleton registry
diff --git a/src/Quasar/Wayland/Client/Sync.hs b/src/Quasar/Wayland/Client/Sync.hs
index 06fdf5f..cc6fb87 100644
--- a/src/Quasar/Wayland/Client/Sync.hs
+++ b/src/Quasar/Wayland/Client/Sync.hs
@@ -1,8 +1,10 @@
module Quasar.Wayland.Client.Sync (
lowLevelSync,
+ lowLevelSyncFuture,
) where
import Control.Monad.STM
+import Quasar.Future
import Quasar.Prelude
import Quasar.Wayland.Protocol
import Quasar.Wayland.Protocol.Generated
@@ -13,3 +15,9 @@ lowLevelSync wlDisplay callback = do
setEventHandler wlCallback EventHandler_wl_callback {
done = callback
}
+
+lowLevelSyncFuture :: Object 'Client Interface_wl_display -> STM (Future ())
+lowLevelSyncFuture wlDisplay = do
+ var <- newPromiseSTM
+ lowLevelSync wlDisplay \_ -> fulfillPromiseSTM var ()
+ pure $ toFuture var
--
GitLab