Add WIP wl_display implementation

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

src/Quasar/Wayland/Protocol.hs

+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

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)