examples/Server.hs

@@ -2,12 +2,39 @@ module Main (main) where
 
 import Quasar
 import Quasar.Prelude
+import Quasar.Wayland.Surface
 import Quasar.Wayland.Server
 import Quasar.Wayland.Server.Registry
+import Quasar.Wayland.Protocol
+import Quasar.Wayland.Protocol.Generated
 
 main :: IO ()
 main = runQuasarAndExit (stderrLogger LogLevelWarning) do
-  registry <- newRegistry
+  let
+    shmGlobal = createGlobal @Interface_wl_shm maxVersion (\_ -> traceM "wl_shm not implemented")
+    layerShellGlobal = createGlobal @Interface_zwlr_layer_shell_v1 maxVersion (\x -> setRequestHandler x layerShellHandler)
+  registry <- newRegistry [compositorGlobal @ShmBufferBackend, shmGlobal, layerShellGlobal]
   server <- newWaylandServer registry
   listenAt "example.socket" server
   sleepForever
+
+layerShellHandler :: RequestHandler_zwlr_layer_shell_v1
+layerShellHandler =
+  RequestHandler_zwlr_layer_shell_v1 {
+    get_layer_surface = \wlLayerSurface _ _ _ _ -> setRequestHandler wlLayerSurface layerSurfaceHandler,
+    destroy = pure ()
+  }
+
+layerSurfaceHandler :: RequestHandler_zwlr_layer_surface_v1
+layerSurfaceHandler =
+  RequestHandler_zwlr_layer_surface_v1 {
+    set_size = \_ _ -> pure (),
+    set_anchor = \_ -> pure (),
+    set_exclusive_zone = \_ -> pure (),
+    set_margin = \_ _ _ _ -> pure (),
+    set_keyboard_interactivity = \_ -> pure (),
+    get_popup = \_ -> pure (),
+    ack_configure = \_ -> pure (),
+    destroy = pure (),
+    set_layer = \_ -> pure ()
+  }

flake.lock

@@ -2,11 +2,11 @@
   "nodes": {
     "nixpkgs": {
       "locked": {
-        "lastModified": 1659077768,
-        "narHash": "sha256-P0XIHBVty6WIuIrk2DZNvLcYev9956y1prT4zL212H8=",
+        "lastModified": 1660396586,
+        "narHash": "sha256-ePuWn7z/J5p2lO7YokOG1o01M0pDDVL3VrStaPpS5Ig=",
         "owner": "NixOS",
         "repo": "nixpkgs",
-        "rev": "2a93ea177c3d7700b934bf95adfe00c435f696b8",
+        "rev": "e105167e98817ba9fe079c6c3c544c6ef188e276",
         "type": "github"
       },
       "original": {

flake.nix

@@ -21,7 +21,7 @@
       ]; };
     in rec {
       default = quasar-wayland;
-      quasar-wayland = pkgs.haskell.packages.ghc923.quasar-wayland;
+      quasar-wayland = pkgs.haskell.packages.ghc924.quasar-wayland;
     }
     );
 

src/Quasar/Wayland/Server.hs

@@ -4,6 +4,7 @@ module Quasar.Wayland.Server (
   newWaylandServer,
   newWaylandServerConnection,
   listenAt,
+  compositorGlobal,
 ) where
 
 import Control.Monad.Catch
@@ -13,8 +14,10 @@ import Quasar.Prelude
 import Quasar.Wayland.Connection
 import Quasar.Wayland.Protocol
 import Quasar.Wayland.Protocol.Generated
+import Quasar.Wayland.Region
 import Quasar.Wayland.Server.Registry
 import Quasar.Wayland.Server.Socket
+import Quasar.Wayland.Surface
 
 
 data WaylandServer = WaylandServer {
@@ -58,3 +61,16 @@ listenAt socketPath server = disposeOnError do
   asyncWithUnmask_ \_ -> forever do
     socket <- atomically $ takeTMVar var
     newWaylandServerConnection server socket
+
+
+compositorGlobal :: forall b. BufferBackend b => Global
+compositorGlobal = createGlobal @Interface_wl_compositor maxVersion bindCompositor
+  where
+    bindCompositor :: Object 'Server Interface_wl_compositor -> STM ()
+    bindCompositor wlCompositor = setMessageHandler wlCompositor handler
+
+    handler :: RequestHandler_wl_compositor
+    handler = RequestHandler_wl_compositor {
+      create_surface = initializeServerSurface @b,
+      create_region = initializeServerRegion
+    }