From 176817a1b73ddc6d5ccf7a229bb1e330be0f947c Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Wed, 14 Sep 2022 16:35:48 +0200
Subject: [PATCH] Clean up example client
---
examples/Client.hs | 164 ++++++++++++++++++++-------------------------
1 file changed, 74 insertions(+), 90 deletions(-)
diff --git a/examples/Client.hs b/examples/Client.hs
index 9d68f32..570b4c3 100644
--- a/examples/Client.hs
+++ b/examples/Client.hs
@@ -1,7 +1,5 @@
module Main (main) where
-import Data.List (intersperse)
-import Data.Foldable (toList)
import Quasar
import Quasar.Prelude
import Quasar.Timer
@@ -15,70 +13,6 @@ import Quasar.Wayland.Surface
import Codec.Picture
-
-data Dimensions = Dimensions {
- width :: Int,
- height :: Int,
- aspect :: Double
-}
-
-data Position = Position {
- dimensions :: Dimensions,
- pixelX :: Int,
- pixelY :: Int,
- u :: Double,
- v :: Double,
- x :: Double,
- y :: Double
-}
-
-mkDimensions :: Int -> Int -> Dimensions
-mkDimensions width height = Dimensions { width, height, aspect }
- where
- aspect :: Double
- aspect = (fromIntegral width) / (fromIntegral height)
-
-mkPosition :: Dimensions -> Int -> Int -> Position
-mkPosition dimensions pixelX pixelY = Position { dimensions, pixelX, pixelY, u, v, x, y }
- where
- width' = dimensions.width
- height' = dimensions.height
- u :: Double
- u = (fromIntegral pixelX) / (fromIntegral width')
- v :: Double
- v = (fromIntegral pixelY) / (fromIntegral height')
- innerRadius :: Int
- innerRadius = div (min width' height') 2
- x :: Double
- x = (fromIntegral $ pixelX - (div width' 2)) / (fromIntegral innerRadius)
- y :: Double
- y = (fromIntegral $ pixelY - (div height' 2)) / (fromIntegral innerRadius)
-
-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
-gradient p = color (u p) 0 (v p)
-
-solidColor :: Position -> PixelRGBA8
-solidColor p = color 255 0 0
-
-mkImage :: (Position -> PixelRGBA8) -> Image PixelRGBA8
-mkImage fn = generateImage pixel width height
- where
- width :: Int
- width = 512
- height :: Int
- height = 512
- dimensions :: Dimensions
- dimensions = mkDimensions width height
- pixel :: Int -> Int -> PixelRGBA8
- pixel x y = fn $ mkPosition dimensions x y
-
-
main :: IO ()
main = do
_ <- runQuasarAndExit (stderrLogger LogLevelWarning) do
@@ -86,26 +20,11 @@ main = do
client <- connectWaylandClient
traceIO "Connected"
- join $ liftIO $ atomically do
-
- --xdgWmBase <- bindSingleton @Interface_xdg_wm_base client.registry
- --setMessageHandler xdgWmBase EventHandler_xdg_wm_base {
- -- ping = \serial -> xdgWmBase.pong serial
- --}
-
- --xdgToplevel <- xdgSurface.get_toplevel
- --setMessageHandler xdgToplevel EventHandler_xdg_toplevel {
- -- configure = \_ _ _ -> pure (),
- -- close = pure ()
- --}
-
- --xdgToplevel.set_title "foobar"
-
+ join $ atomically do
(surface, wlSurface) <- newClientSurface @ShmBufferBackend client
(surface2, wlSurface2) <- newClientSurface @ShmBufferBackend client
-
wlrLayerShell <- bindSingleton @Interface_zwlr_layer_shell_v1 client.registry
configuredVar <- newTVar False
@@ -134,15 +53,16 @@ main = do
-- Commit role
wlSurface.commit
wlSurface2.commit
- -- Should await first `configure` event
pure do
buffer <- liftIO $ toImageBuffer (mkImage gradient)
buffer2 <- liftIO $ toImageBuffer (mkImage solidColor)
- liftIO $ atomically do
+ atomically do
+ -- Await first `configure` event on both surfaces
check =<< readTVar configuredVar
check =<< readTVar configuredVar2
+
commitSurface surface SurfaceCommit {
buffer = Just buffer,
offset = (0, 0),
@@ -151,8 +71,9 @@ main = do
commitSurface surface2 SurfaceCommit {
buffer = Just buffer2,
offset = (0, 0),
- bufferDamage = DamageList [Rectangle 0 0 42 42]
+ bufferDamage = DamageAll
}
+ -- Destroying the buffers somehow changes compositor behavior and no error is produced
--destroyBuffer buffer
--destroyBuffer buffer2
@@ -160,7 +81,7 @@ main = do
traceIO "Waiting 2s"
await =<< newDelay 2000000
- liftIO $ atomically do
+ atomically do
commitSurface surface SurfaceCommit {
buffer = Nothing,
offset = (0, 0),
@@ -172,10 +93,73 @@ main = do
bufferDamage = DamageList []
}
- -- traceIO . ("shm buffer formats: " <>) . mconcat . intersperse ", " . fmap show . toList =<< await shm.formats
-
- pure ()
-
await =<< newDelay 1000000
traceIO "Closing"
traceIO "Closed"
+
+
+
+-- * Old code to generate test images
+
+data Dimensions = Dimensions {
+ width :: Int,
+ height :: Int,
+ aspect :: Double
+}
+
+data Position = Position {
+ dimensions :: Dimensions,
+ pixelX :: Int,
+ pixelY :: Int,
+ u :: Double,
+ v :: Double,
+ x :: Double,
+ y :: Double
+}
+
+mkDimensions :: Int -> Int -> Dimensions
+mkDimensions width height = Dimensions { width, height, aspect }
+ where
+ aspect :: Double
+ aspect = (fromIntegral width) / (fromIntegral height)
+
+mkPosition :: Dimensions -> Int -> Int -> Position
+mkPosition dimensions pixelX pixelY = Position { dimensions, pixelX, pixelY, u, v, x, y }
+ where
+ width' = dimensions.width
+ height' = dimensions.height
+ u :: Double
+ u = fromIntegral pixelX / fromIntegral width'
+ v :: Double
+ v = fromIntegral pixelY / fromIntegral height'
+ innerRadius :: Int
+ innerRadius = div (min width' height') 2
+ x :: Double
+ x = fromIntegral (pixelX - (div width' 2)) / (fromIntegral innerRadius)
+ y :: Double
+ y = fromIntegral (pixelY - (div height' 2)) / (fromIntegral innerRadius)
+
+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
+gradient p = color (u p) 0 (v p)
+
+solidColor :: Position -> PixelRGBA8
+solidColor _p = color @Double 255 0 0
+
+mkImage :: (Position -> PixelRGBA8) -> Image PixelRGBA8
+mkImage fn = generateImage pixel width height
+ where
+ width :: Int
+ width = 512
+ height :: Int
+ height = 512
+ dimensions :: Dimensions
+ dimensions = mkDimensions width height
+ pixel :: Int -> Int -> PixelRGBA8
+ pixel x y = fn $ mkPosition dimensions x y
+
--
GitLab