diff --git a/src/Quasar/Wayland/Client.hs b/src/Quasar/Wayland/Client.hs index ac7f70f057920e6d3ce0d8b13eb78cac031d7333..ce645517768d06690e2bacf95cbea27268d6e662 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 c461cfff16c2c483ac35e551542b89b98a818312..bc2f4066767c36e7ec2523354bfc70c768b7cb31 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 06fdf5f718077153a81d264fbdbbea597d69255b..cc6fb87376cc890f846ca1b51b3f360db6c819dc 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