Clean up example client

examples/Client.hs

 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 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
+