From da604cd797c7b83240261c2b4c36cff30a410d1f Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Thu, 16 Sep 2021 14:11:21 +0200
Subject: [PATCH] Add WIP wl_display implementation
---
quasar-wayland.cabal | 2 ++
src/Quasar/Wayland/Protocol.hs | 34 +++++++++++++++++++++++++++++
src/Quasar/Wayland/Protocol/Core.hs | 9 ++++++++
3 files changed, 45 insertions(+)
create mode 100644 src/Quasar/Wayland/Protocol.hs
diff --git a/quasar-wayland.cabal b/quasar-wayland.cabal
index 5b06cac..4a053b4 100644
--- a/quasar-wayland.cabal
+++ b/quasar-wayland.cabal
@@ -85,6 +85,7 @@ library
exposed-modules:
Quasar.Wayland.Client
Quasar.Wayland.Connection
+ Quasar.Wayland.Protocol
Quasar.Wayland.Protocol.Core
Quasar.Wayland.Protocol.Generated
Quasar.Wayland.Protocol.TH
@@ -99,6 +100,7 @@ library
quasar,
template-haskell,
unordered-containers,
+ utf8-string,
stm,
xml,
-- required for record-dot-preprocessor
diff --git a/src/Quasar/Wayland/Protocol.hs b/src/Quasar/Wayland/Protocol.hs
new file mode 100644
index 0000000..03dd836
--- /dev/null
+++ b/src/Quasar/Wayland/Protocol.hs
@@ -0,0 +1,34 @@
+module Quasar.Wayland.Protocol (
+ -- * A pure implementation of the Wayland wire protocol
+ createClientStateWithRegistry
+) where
+
+import Control.Monad.Catch
+import Control.Monad.State (StateT, runStateT)
+import Data.ByteString.UTF8 (toString)
+import Quasar.Prelude
+import Quasar.Wayland.Protocol.Core
+import Quasar.Wayland.Protocol.Generated
+
+
+createClientStateWithRegistry :: forall m. MonadCatch m => m (ProtocolState 'Client m)
+createClientStateWithRegistry = do
+ (wlRegistry, state') <- runStateT go initialState'
+ pure state'
+ where
+ (initialState', wlDisplay) = initialProtocolState wlDisplayCallback
+
+ go :: ProtocolAction 'Client m (Object 'Client m I_wl_registry)
+ go = do
+ (wlRegistry, newId) <- newObjectInternal @'Client @m @I_wl_registry (traceCallback ignoreMessage)
+ sendMessageInternal wlDisplay $ R_wl_display_get_registry newId
+
+ pure wlRegistry
+
+ wlDisplayCallback :: forall m. (IsInterfaceSide 'Client I_wl_display, MonadCatch m) => Callback 'Client m I_wl_display
+ wlDisplayCallback = internalFnCallback handler
+ where
+ handler :: Object 'Client m I_wl_display -> E_wl_display -> ProtocolAction 'Client m ()
+ -- TODO parse oId
+ handler _ (E_wl_display_error oId code message) = throwM $ ServerError code (toString message)
+ handler _ (E_wl_display_delete_id deletedId) = pure () -- TODO confirm delete
diff --git a/src/Quasar/Wayland/Protocol/Core.hs b/src/Quasar/Wayland/Protocol/Core.hs
index 25ca5ca..a8e355a 100644
--- a/src/Quasar/Wayland/Protocol/Core.hs
+++ b/src/Quasar/Wayland/Protocol/Core.hs
@@ -16,6 +16,7 @@ module Quasar.Wayland.Protocol.Core (
IsObject,
IsMessage(..),
ProtocolState,
+ ProtocolAction,
Callback(..),
internalFnCallback,
traceCallback,
@@ -26,10 +27,14 @@ module Quasar.Wayland.Protocol.Core (
newObject,
feedInput,
setException,
+ newObjectInternal,
+ sendMessageInternal,
showObjectMessage,
isNewId,
+ ServerError(..),
+
-- * Message decoder operations
WireFormat(..),
dropRemaining,
@@ -349,6 +354,10 @@ data MaximumIdReached = MaximumIdReached
deriving stock Show
deriving anyclass Exception
+data ServerError = ServerError Word32 String
+ deriving stock Show
+ deriving anyclass Exception
+
-- * Monad plumbing
type ProtocolStep s m a = ProtocolState s m -> m (Either SomeException a, Maybe BSL.ByteString, ProtocolState s m)
--
GitLab