From a7b9e28b36b535a501d088b0319b524fe5bb0337 Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Sun, 21 Aug 2022 21:59:59 +0200
Subject: [PATCH] WIP
---
examples/Client.hs | 35 ++++++++++++++----
quasar-wayland.cabal | 1 +
src/Quasar/Wayland/Client/Surface.hs | 47 +++++++++++++++++++++++++
src/Quasar/Wayland/Server/LayerShell.hs | 7 ++++
src/Quasar/Wayland/Surface.hs | 11 +++++-
5 files changed, 94 insertions(+), 7 deletions(-)
create mode 100644 src/Quasar/Wayland/Client/Surface.hs
create mode 100644 src/Quasar/Wayland/Server/LayerShell.hs
diff --git a/examples/Client.hs b/examples/Client.hs
index 9ebf899..cf5d40e 100644
--- a/examples/Client.hs
+++ b/examples/Client.hs
@@ -95,6 +95,12 @@ main = do
leave = \_ -> pure ()
}
+ wlSurface2 <- wlCompositor.create_surface
+ setMessageHandler wlSurface2 EventHandler_wl_surface {
+ enter = \_ -> pure (),
+ leave = \_ -> pure ()
+ }
+
--xdgWmBase <- bindSingleton @Interface_xdg_wm_base client.registry
--setMessageHandler xdgWmBase EventHandler_xdg_wm_base {
-- ping = \serial -> xdgWmBase.pong serial
@@ -116,6 +122,7 @@ main = do
wlrLayerShell <- bindSingleton @Interface_zwlr_layer_shell_v1 client.registry
configuredVar <- newTVar False
+ configuredVar2 <- newTVar False
wlrLayerSurface <- wlrLayerShell.get_layer_surface wlSurface Nothing 2 "demo"
setMessageHandler wlrLayerSurface EventHandler_zwlr_layer_surface_v1 {
@@ -126,8 +133,18 @@ main = do
}
wlrLayerSurface.set_size 512 512
+ wlrLayerSurface2 <- wlrLayerShell.get_layer_surface wlSurface2 Nothing 2 "demo"
+ setMessageHandler wlrLayerSurface2 EventHandler_zwlr_layer_surface_v1 {
+ configure = \serial width height -> do
+ wlrLayerSurface2.ack_configure serial
+ writeTVar configuredVar2 True,
+ closed = pure ()
+ }
+ wlrLayerSurface2.set_size 512 512
+
-- Commit role
wlSurface.commit
+ wlSurface2.commit
-- Should await first `configure` event
pure do
@@ -135,24 +152,30 @@ main = do
liftIO $ atomically do
check =<< readTVar configuredVar
+ check =<< readTVar configuredVar2
wlSurface.attach (Just buffer) 0 0
wlSurface.commit
+ wlSurface2.attach (Just buffer) 0 0
+ wlSurface2.commit
await =<< newDelay 1000000
- buffer2 <- liftIO $ toImageBuffer shm (mkImage solidColor)
+ --buffer2 <- liftIO $ toImageBuffer shm (mkImage solidColor)
- liftIO $ atomically do
- wlSurface.attach (Just buffer2) 0 0
- wlSurface.damage 0 0 42 42
- wlSurface.commit
+ --liftIO $ atomically do
+ -- wlSurface.attach (Just buffer2) 0 0
+ -- wlSurface.damage 0 0 42 42
+ -- wlSurface.commit
- await =<< newDelay 1000000
+ --await =<< newDelay 1000000
liftIO $ atomically do
wlSurface.attach (Nothing) 0 0
wlSurface.damage 100 100 42 42
wlSurface.commit
+ wlSurface2.attach (Nothing) 0 0
+ wlSurface2.damage 100 100 42 42
+ wlSurface2.commit
traceIO . ("shm buffer formats: " <>) . mconcat . intersperse ", " . fmap show . toList =<< await shm.formats
diff --git a/quasar-wayland.cabal b/quasar-wayland.cabal
index e57de7a..829cafb 100644
--- a/quasar-wayland.cabal
+++ b/quasar-wayland.cabal
@@ -79,6 +79,7 @@ library
Quasar.Wayland.Client.JuicyPixels
Quasar.Wayland.Client.Registry
Quasar.Wayland.Client.Socket
+ Quasar.Wayland.Client.Surface
Quasar.Wayland.Client.Sync
Quasar.Wayland.Connection
Quasar.Wayland.Protocol
diff --git a/src/Quasar/Wayland/Client/Surface.hs b/src/Quasar/Wayland/Client/Surface.hs
new file mode 100644
index 0000000..ce53cf6
--- /dev/null
+++ b/src/Quasar/Wayland/Client/Surface.hs
@@ -0,0 +1,47 @@
+module Quasar.Wayland.Client.Surface (
+ newClientSurface,
+ initializeClientSurface,
+) where
+
+import Quasar.Prelude
+import Quasar.Wayland.Protocol
+import Quasar.Wayland.Protocol.Generated
+import Quasar.Wayland.Surface
+import Quasar.Wayland.Region (Rectangle, appRect)
+
+newtype ClientSurface b = ClientSurface {
+ wlSurface :: Object 'Client Interface_wl_surface
+}
+
+newClientSurface :: Object 'Client Interface_wl_compositor -> STM (Surface b)
+newClientSurface wlCompositor = do
+ surface <- newSurface
+ wlSurface <- wlCompositor.create_surface
+ initializeClientSurface surface wlSurface
+ -- TODO: add finalizer, so that the surface is destroyed with the wlSurface
+ pure surface
+
+initializeClientSurface :: Surface b -> Object 'Client Interface_wl_surface -> STM ()
+initializeClientSurface surface wlSurface = do
+ connectSurfaceDownstream surface (surfaceDownstream (ClientSurface wlSurface))
+
+surfaceDownstream :: ClientSurface b -> SurfaceDownstream b
+surfaceDownstream surface = commitClientSurface surface
+
+commitClientSurface :: ClientSurface b -> SurfaceCommit b -> STM ()
+commitClientSurface surface commit = do
+ -- TODO catch exceptions and redirect to client owner (so the shared surface can continue to work when one backend fails)
+ wlBuffer <- mapM getClientBuffer commit.buffer
+ wlSurface.attach wlBuffer (fst commit.offset) (snd commit.offset)
+ applyBufferDamage surface.wlSurface commit.bufferDamage
+ wlSurface.commit
+ where
+ wlSurface = surface.wlSurface
+
+applyBufferDamage :: Object 'Client Interface_wl_surface -> Damage -> STM ()
+applyBufferDamage wlSurface DamageAll = wlSurface.damage_buffer minBound minBound maxBound maxBound
+applyBufferDamage wlSurface (DamageList xs) = mapM_ (appRect wlSurface.damage_buffer) xs
+
+
+getClientBuffer :: Buffer b -> STM (Object 'Client Interface_wl_buffer)
+getClientBuffer = undefined
diff --git a/src/Quasar/Wayland/Server/LayerShell.hs b/src/Quasar/Wayland/Server/LayerShell.hs
new file mode 100644
index 0000000..3b76a3d
--- /dev/null
+++ b/src/Quasar/Wayland/Server/LayerShell.hs
@@ -0,0 +1,7 @@
+module Quasar.Wayland.Server.LayerShell (
+) where
+
+import Quasar.Prelude
+
+layerShellGlobal :: Global
+layerShellGlobal = undefined
diff --git a/src/Quasar/Wayland/Surface.hs b/src/Quasar/Wayland/Surface.hs
index 0902461..e947d0d 100644
--- a/src/Quasar/Wayland/Surface.hs
+++ b/src/Quasar/Wayland/Surface.hs
@@ -11,10 +11,12 @@ module Quasar.Wayland.Surface (
Damage(..),
Surface,
SurfaceCommit(..),
+ SurfaceDownstream,
defaultSurfaceCommit,
newSurface,
assignSurfaceRole,
commitSurface,
+ connectSurfaceDownstream,
) where
import Control.Monad.Catch
@@ -118,6 +120,13 @@ data SurfaceCommit b = SurfaceCommit {
bufferDamage :: Damage
}
+--instance Semigroup (SurfaceCommit b) where
+-- old <> new = SurfaceCommit {
+-- buffer = new.buffer,
+-- offset = new.offset,
+-- bufferDamage = old.bufferDamage <> new.bufferDamage
+-- }
+
type SurfaceDownstream b = SurfaceCommit b -> STM ()
defaultSurfaceCommit :: Damage -> SurfaceCommit b
@@ -166,4 +175,4 @@ commitSurface surface commit = do
mapM_ ($ commit) downstreams
connectSurfaceDownstream :: forall b. Surface b -> SurfaceDownstream b -> STM ()
-connectSurfaceDownstream = undefined
+connectSurfaceDownstream surface = modifyTVar surface.downstreams . (:)
--
GitLab