From c58d6da65ae9c9f75447d06f98500bfc8b8593ab Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Wed, 15 Dec 2021 08:54:03 +0100
Subject: [PATCH] Refactor wl_display to keep core implementation free from
generated code
---
quasar-wayland.cabal | 2 +-
src/Quasar/Wayland/Client.hs | 19 +++++++++++-----
src/Quasar/Wayland/Client/Registry.hs | 2 +-
src/Quasar/Wayland/Client/Sync.hs | 15 +++++++++++++
src/Quasar/Wayland/Protocol.hs | 4 ++++
src/Quasar/Wayland/Protocol/Core.hs | 22 +++++++++++++++++--
src/Quasar/Wayland/Protocol/Display.hs | 30 --------------------------
7 files changed, 55 insertions(+), 39 deletions(-)
create mode 100644 src/Quasar/Wayland/Client/Sync.hs
delete mode 100644 src/Quasar/Wayland/Protocol/Display.hs
diff --git a/quasar-wayland.cabal b/quasar-wayland.cabal
index 0131719..027da67 100644
--- a/quasar-wayland.cabal
+++ b/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:
diff --git a/src/Quasar/Wayland/Client.hs b/src/Quasar/Wayland/Client.hs
index ee2b9f0..848a985 100644
--- a/src/Quasar/Wayland/Client.hs
+++ b/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
+ }
diff --git a/src/Quasar/Wayland/Client/Registry.hs b/src/Quasar/Wayland/Client/Registry.hs
index 26ee1e6..138a46e 100644
--- a/src/Quasar/Wayland/Client/Registry.hs
+++ b/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
diff --git a/src/Quasar/Wayland/Client/Sync.hs b/src/Quasar/Wayland/Client/Sync.hs
new file mode 100644
index 0000000..06fdf5f
--- /dev/null
+++ b/src/Quasar/Wayland/Client/Sync.hs
@@ -0,0 +1,15 @@
+module Quasar.Wayland.Client.Sync (
+ lowLevelSync,
+) where
+
+import Control.Monad.STM
+import Quasar.Prelude
+import Quasar.Wayland.Protocol
+import Quasar.Wayland.Protocol.Generated
+
+lowLevelSync :: Object 'Client Interface_wl_display -> (Word32 -> STM ()) -> STM ()
+lowLevelSync wlDisplay callback = do
+ wlCallback <- wlDisplay.sync
+ setEventHandler wlCallback EventHandler_wl_callback {
+ done = callback
+ }
diff --git a/src/Quasar/Wayland/Protocol.hs b/src/Quasar/Wayland/Protocol.hs
index 68e59f5..c3f9e73 100644
--- a/src/Quasar/Wayland/Protocol.hs
+++ b/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
diff --git a/src/Quasar/Wayland/Protocol/Core.hs b/src/Quasar/Wayland/Protocol/Core.hs
index 2650d89..0205a20 100644
--- a/src/Quasar/Wayland/Protocol/Core.hs
+++ b/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
diff --git a/src/Quasar/Wayland/Protocol/Display.hs b/src/Quasar/Wayland/Protocol/Display.hs
deleted file mode 100644
index c37e3e1..0000000
--- a/src/Quasar/Wayland/Protocol/Display.hs
+++ /dev/null
@@ -1,30 +0,0 @@
-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
-
-
-
--- | 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
- setEventHandler wlCallback EventHandler_wl_callback {
- done = callback
- }
--
GitLab