From f1aa63c5d5fb5d645a7f503ef052b3ba27534539 Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Fri, 9 Sep 2022 01:24:25 +0200
Subject: [PATCH] Change shm example code to use new surface abstraction
---
examples/Client.hs | 103 +++++++++++++++--------
quasar-wayland.cabal | 2 +-
src/Quasar/Wayland/Client/Buffer.hs | 103 -----------------------
src/Quasar/Wayland/Client/JuicyPixels.hs | 18 ++--
src/Quasar/Wayland/Client/ShmBuffer.hs | 51 +++++++++++
5 files changed, 129 insertions(+), 148 deletions(-)
delete mode 100644 src/Quasar/Wayland/Client/Buffer.hs
create mode 100644 src/Quasar/Wayland/Client/ShmBuffer.hs
diff --git a/examples/Client.hs b/examples/Client.hs
index 9ebf899..329526b 100644
--- a/examples/Client.hs
+++ b/examples/Client.hs
@@ -6,10 +6,12 @@ import Quasar
import Quasar.Prelude
import Quasar.Timer
import Quasar.Wayland.Client
-import Quasar.Wayland.Client.Buffer
import Quasar.Wayland.Client.JuicyPixels
+import Quasar.Wayland.Client.Surface
import Quasar.Wayland.Protocol
import Quasar.Wayland.Protocol.Generated
+import Quasar.Wayland.Shm
+import Quasar.Wayland.Surface
import Codec.Picture
@@ -39,8 +41,8 @@ mkDimensions width height = Dimensions { width, height, aspect }
mkPosition :: Dimensions -> Int -> Int -> Position
mkPosition dimensions pixelX pixelY = Position { dimensions, pixelX, pixelY, u, v, x, y }
where
- width' = width dimensions
- height' = height dimensions
+ width' = dimensions.width
+ height' = dimensions.height
u :: Double
u = (fromIntegral pixelX) / (fromIntegral width')
v :: Double
@@ -52,9 +54,10 @@ mkPosition dimensions pixelX pixelY = Position { dimensions, pixelX, pixelY, u,
y :: Double
y = (fromIntegral $ pixelY - (div height' 2)) / (fromIntegral innerRadius)
-color :: RealFrac a => a -> a -> a -> PixelRGBA8
+color :: forall a. RealFrac a => a -> a -> a -> PixelRGBA8
color r g b = PixelRGBA8 (toWord r) (toWord g) (toWord b) 255
where
+ toWord :: a -> Word8
toWord = truncate . (* 255) . (max 0) . (min 1)
gradient :: Position -> PixelRGBA8
@@ -78,22 +81,24 @@ mkImage fn = generateImage pixel width height
main :: IO ()
main = do
- runQuasarAndExit (stderrLogger LogLevelWarning) do
+ _ <- runQuasarAndExit (stderrLogger LogLevelWarning) do
traceIO "Connecting"
client <- connectWaylandClient
traceIO "Connected"
join $ liftIO $ atomically do
- wlCompositor <- bindSingleton @Interface_wl_compositor client.registry
+ -- wlSurface <- wlCompositor.create_surface
+ -- setMessageHandler wlSurface EventHandler_wl_surface {
+ -- enter = \_ -> pure (),
+ -- leave = \_ -> pure ()
+ -- }
- shm <- newShmBufferManager client
-
- wlSurface <- wlCompositor.create_surface
- setMessageHandler wlSurface EventHandler_wl_surface {
- enter = \_ -> pure (),
- 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 {
@@ -113,52 +118,80 @@ main = do
--xdgToplevel.set_title "foobar"
+ (surface, wlSurface) <- newClientSurface @ShmBufferBackend client
+ (surface2, wlSurface2) <- newClientSurface @ShmBufferBackend client
+
+
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 {
- configure = \serial width height -> do
+ configure = \serial _width _height -> do
wlrLayerSurface.ack_configure serial
writeTVar configuredVar True,
closed = pure ()
}
wlrLayerSurface.set_size 512 512
+ wlrLayerSurface.set_anchor 1
+
+ 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
+ wlrLayerSurface2.set_anchor 2
-- Commit role
wlSurface.commit
+ wlSurface2.commit
-- Should await first `configure` event
pure do
- buffer <- liftIO $ toImageBuffer shm (mkImage gradient)
+ buffer <- liftIO $ toImageBuffer (mkImage gradient)
+ buffer2 <- liftIO $ toImageBuffer (mkImage solidColor)
liftIO $ atomically do
check =<< readTVar configuredVar
- wlSurface.attach (Just buffer) 0 0
- wlSurface.commit
-
- await =<< newDelay 1000000
-
- buffer2 <- liftIO $ toImageBuffer shm (mkImage solidColor)
-
- liftIO $ atomically do
- wlSurface.attach (Just buffer2) 0 0
- wlSurface.damage 0 0 42 42
- wlSurface.commit
-
- await =<< newDelay 1000000
+ check =<< readTVar configuredVar2
+ commitSurface surface SurfaceCommit {
+ buffer = Just buffer,
+ offset = (0, 0),
+ bufferDamage = DamageAll
+ }
+ commitSurface surface2 SurfaceCommit {
+ buffer = Just buffer2,
+ offset = (0, 0),
+ bufferDamage = DamageList [Rectangle 0 0 42 42]
+ }
+ --destroyBuffer buffer
+ --destroyBuffer buffer2
+
+ await =<< newDelay 100000
+ traceIO "Waiting 2s"
+ await =<< newDelay 2000000
liftIO $ atomically do
- wlSurface.attach (Nothing) 0 0
- wlSurface.damage 100 100 42 42
- wlSurface.commit
-
- traceIO . ("shm buffer formats: " <>) . mconcat . intersperse ", " . fmap show . toList =<< await shm.formats
+ commitSurface surface SurfaceCommit {
+ buffer = Nothing,
+ offset = (0, 0),
+ bufferDamage = DamageList []
+ }
+ commitSurface surface2 SurfaceCommit {
+ buffer = Nothing,
+ offset = (0, 0),
+ bufferDamage = DamageList []
+ }
+
+ -- traceIO . ("shm buffer formats: " <>) . mconcat . intersperse ", " . fmap show . toList =<< await shm.formats
pure ()
- traceIO "Waiting 2s"
- await =<< newDelay 2000000
+ await =<< newDelay 1000000
traceIO "Closing"
traceIO "Closed"
diff --git a/quasar-wayland.cabal b/quasar-wayland.cabal
index b7e075b..0e30137 100644
--- a/quasar-wayland.cabal
+++ b/quasar-wayland.cabal
@@ -75,7 +75,7 @@ library
import: shared-properties
exposed-modules:
Quasar.Wayland.Client
- Quasar.Wayland.Client.Buffer
+ Quasar.Wayland.Client.ShmBuffer
Quasar.Wayland.Client.JuicyPixels
Quasar.Wayland.Client.Registry
Quasar.Wayland.Client.Socket
diff --git a/src/Quasar/Wayland/Client/Buffer.hs b/src/Quasar/Wayland/Client/Buffer.hs
deleted file mode 100644
index 796cc8c..0000000
--- a/src/Quasar/Wayland/Client/Buffer.hs
+++ /dev/null
@@ -1,103 +0,0 @@
-module Quasar.Wayland.Client.Buffer (
- -- * wl_shm
- ShmBufferManager(formats),
- newShmBufferManager,
- newShmPool,
- newShmBuffer,
-) where
-
-import Control.Monad.Catch
-import Data.Set qualified as Set
-import Foreign
-import Quasar
-import Quasar.Prelude
-import Quasar.Wayland.Client
-import Quasar.Wayland.Protocol
-import Quasar.Wayland.Protocol.Generated
-import Quasar.Wayland.Utils.SharedMemory
-import System.Posix.IO (closeFd)
-import System.Posix.Types (Fd)
-
-
-data ShmBufferManager = ShmBufferManager {
- wlShm :: Object 'Client Interface_wl_shm,
- formats :: Future (Set.Set Word32)
-}
-
-newShmBufferManager :: WaylandClient -> STM ShmBufferManager
-newShmBufferManager client = do
- formatsVar <- newTVar mempty
-
- wlShm <- bindSingleton @Interface_wl_shm client.registry
- setEventHandler wlShm $ EventHandler_wl_shm {
- format = modifyTVar formatsVar . Set.insert
- }
-
- -- Formats are emittet all at once; sync ensures the list is complete
- formatListComplete <- client.sync
- let formats = formatListComplete >> unsafeAwaitSTM (readTVar formatsVar)
-
- pure ShmBufferManager {
- wlShm,
- formats
- }
-
-data ShmPool = ShmPool {
- wlShmPool :: Object 'Client Interface_wl_shm_pool,
- shmPtr :: TVar (Maybe (ForeignPtr Word8))
-}
-
-newShmPool :: ShmBufferManager -> Int32 -> IO ShmPool
-newShmPool shm size = do
- (wlShmPool, ptr) <- trySendShm size (\fd -> shm.wlShm.create_pool fd size)
-
- shmPtr <- newTVarIO (Just ptr)
-
- pure ShmPool {
- wlShmPool,
- shmPtr
- }
-
-
-newShmBuffer
- :: ShmBufferManager
- -> Int32
- -> Int32
- -> IO (Object 'Client Interface_wl_buffer, ForeignPtr Word32)
-newShmBuffer shm width height = do
- (wlShmPool, ptr) <- trySendShm size (\fd -> shm.wlShm.create_pool fd size)
-
- wlBuffer <- liftIO $ atomically do
- wlBuffer <- wlShmPool.create_buffer offset width height stride pixelFormat
- setEventHandler wlBuffer EventHandler_wl_buffer {
- -- TODO
- release = pure () -- wlBuffer.destroy
- }
- pure wlBuffer
-
- atomically wlShmPool.destroy
-
- pure (wlBuffer, castForeignPtr ptr)
-
- where
- bytePerPixel = 4
- offset = 0
- stride = width * bytePerPixel
- size = width * height * bytePerPixel
- pixelFormat = 0 -- argb8888
-
-
-trySendShm :: Int32 -> (Fd -> STM a) -> IO (a, ForeignPtr Word8)
-trySendShm size sendAction = do
- fd <- memfdCreate $ fromIntegral size
-
- -- Has to be created before sending since the fd will be closed when sent
- ptr <- mmap fd $ fromIntegral size
-
- -- Fd ownership is transferred to the outbox (it will be closed after it has
- -- been sent)
- result <- atomically (sendAction fd)
- `onException`
- (closeFd fd >> finalizeForeignPtr ptr)
-
- pure (result, ptr)
diff --git a/src/Quasar/Wayland/Client/JuicyPixels.hs b/src/Quasar/Wayland/Client/JuicyPixels.hs
index 6ce293f..b331f6d 100644
--- a/src/Quasar/Wayland/Client/JuicyPixels.hs
+++ b/src/Quasar/Wayland/Client/JuicyPixels.hs
@@ -7,18 +7,18 @@ module Quasar.Wayland.Client.JuicyPixels (
import Codec.Picture
import Foreign
import Quasar.Prelude
-import Quasar.Wayland.Client.Buffer
-import Quasar.Wayland.Protocol
-import Quasar.Wayland.Protocol.Generated
+import Quasar.Wayland.Client.ShmBuffer
+import Quasar.Wayland.Shm
+import Quasar.Wayland.Surface
-loadImageBuffer :: ShmBufferManager -> FilePath -> IO (Object 'Client Interface_wl_buffer)
-loadImageBuffer shm path = do
+loadImageBuffer :: FilePath -> IO (Buffer ShmBufferBackend)
+loadImageBuffer path = do
image <- either fail (pure . convertRGBA8) =<< readImage path
- toImageBuffer shm image
+ toImageBuffer image
-toImageBuffer :: ShmBufferManager -> Image PixelRGBA8 -> IO (Object 'Client Interface_wl_buffer)
-toImageBuffer shm image = do
- (buffer, ptr) <- newShmBuffer shm (fromIntegral (imageWidth image)) (fromIntegral (imageHeight image))
+toImageBuffer :: Image PixelRGBA8 -> IO (Buffer ShmBufferBackend)
+toImageBuffer image = do
+ (buffer, ptr) <- newLocalShmBuffer (fromIntegral (imageWidth image)) (fromIntegral (imageHeight image))
let
width = imageWidth image
height = imageHeight image
diff --git a/src/Quasar/Wayland/Client/ShmBuffer.hs b/src/Quasar/Wayland/Client/ShmBuffer.hs
new file mode 100644
index 0000000..3f5a5d5
--- /dev/null
+++ b/src/Quasar/Wayland/Client/ShmBuffer.hs
@@ -0,0 +1,51 @@
+module Quasar.Wayland.Client.ShmBuffer (
+ -- * wl_shm
+ newLocalShmPool,
+ newLocalShmBuffer,
+) where
+
+import Control.Monad.Catch
+import Foreign
+import Quasar.Prelude
+import Quasar.Wayland.Shm
+import Quasar.Wayland.Surface
+import Quasar.Wayland.Utils.SharedMemory
+import System.Posix.IO (closeFd)
+
+
+newLocalShmPool :: Int32 -> IO (ShmPool, ForeignPtr Word8)
+newLocalShmPool size = do
+ fd <- memfdCreate $ fromIntegral size
+
+ ptr <- mmap fd $ fromIntegral size
+
+ -- Passes ownership of the fd to the pool
+ pool <- atomically (newShmPool fd size)
+ `onException`
+ (closeFd fd >> finalizeForeignPtr ptr)
+
+ pure (pool, ptr)
+
+
+newLocalShmBuffer
+ :: Int32
+ -> Int32
+ -> IO (Buffer ShmBufferBackend, ForeignPtr Word32)
+newLocalShmBuffer width height = do
+ (pool, ptr) <- newLocalShmPool size
+
+ atomically do
+ buffer <- newShmBuffer pool offset width height stride pixelFormat
+
+ -- Pool won't be reused
+ destroyShmPool pool
+
+ pure (buffer, castForeignPtr ptr)
+
+ where
+ bytePerPixel = 4
+ offset = 0
+ stride = width * bytePerPixel
+ size = width * height * bytePerPixel
+ pixelFormat = 0 -- argb8888
+
--
GitLab