Handle xdg_toplevel.close requests

examples/Client.hs

@@ -24,7 +24,7 @@ main = do
     tl <- atomicallyC do
       windowManager <- getClientWindowManager @ShmBufferBackend client
       --windowManager <- newDummyWindowManager @ShmBufferBackend
-      tl <- newWindow windowManager (writeTMVar configurationVar)
+      tl <- newWindow windowManager (writeTMVar configurationVar) undefined
       setTitle tl "quasar-wayland-example-client"
       pure tl
 

examples/GlesClient.hs

@@ -27,13 +27,19 @@ main = do
 
     configurationVar <- newEmptyTMVarIO
 
+    shouldClose <- newTVarIO False
+
     tl <- atomicallyC do
       windowManager <- getClientWindowManager @GlesBackend client
-      tl <- newWindow windowManager (writeTMVar configurationVar)
+      tl <- newWindow windowManager (writeTMVar configurationVar) (\WindowRequestClose -> writeTVar shouldClose True)
       setTitle tl "quasar-wayland-example-client"
       pure tl
 
-    forM_ [0,1..480] \i -> do
+    frameId <- newTVarIO 0
+
+    whileM (not <$> readTVarIO shouldClose) do
+      i <- atomically $ stateTVar frameId (\i -> (i, i + 1))
+
       -- Blocks until first configure event
       configuration <- atomically $ readTMVar configurationVar
 
@@ -48,5 +54,10 @@ main = do
         liftSTMc $ destroyBuffer buffer
 
       await =<< newDelay 16000
+      pure ()
+
     traceIO "Closing"
   traceIO "Closed"
+
+whileM :: Monad m => m Bool -> m () -> m ()
+whileM pred action = whenM pred (action >> whileM pred action)

examples/GlesProxy.hs

@@ -50,7 +50,7 @@ main = runQuasarAndExit do
 
 mapWindowManager :: IsWindowManager GlesBackend a => ProxyDemo -> TQueue (IO ()) -> a -> FnWindowManager GlesBackend
 mapWindowManager demo jobQueue upstream = fnWindowManager {
-  newWindowFn = \cfg -> mapWindow demo jobQueue <$> fnWindowManager.newWindowFn cfg
+  newWindowFn = \cfg req -> mapWindow demo jobQueue <$> fnWindowManager.newWindowFn cfg req
 }
   where
     fnWindowManager = toFnWindowManager upstream
@@ -69,7 +69,7 @@ onWindowContentCommit demo jobQueue window serial commit = do
     Just buffer -> do
       disposer <- liftSTMc $ lockBuffer buffer
       writeTQueue jobQueue do
-        b <- proxyDemo demo $ getDmabuf $ buffer.storage
+        b <- proxyDemo demo $ getDmabuf buffer.storage
         atomicallyC do
           disposeTSimpleDisposer disposer
           commitWindowContent window serial commit {

quasar-wayland/src/Quasar/Wayland/Client/XdgShell.hs

@@ -10,8 +10,13 @@ module Quasar.Wayland.Client.XdgShell (
 
   -- ** Window configuration
   WindowConfiguration(..),
+  WindowConfigurationCallback,
   ConfigureSerial,
   commitClientXdgToplevel,
+
+  -- ** Window request
+  WindowRequest(..),
+  WindowRequestCallback,
 ) where
 
 import Quasar.Prelude
@@ -88,9 +93,10 @@ newClientXdgToplevel ::
   forall b.
   ClientBufferBackend b =>
   ClientWindowManager b ->
-  (WindowConfiguration ->
-  STMc NoRetry '[SomeException] ()) -> STMc NoRetry '[SomeException] (ClientXdgToplevel b)
-newClientXdgToplevel ClientWindowManager{client, wlXdgWmBase} configureCallback = do
+  WindowConfigurationCallback ->
+  WindowRequestCallback ->
+  STMc NoRetry '[SomeException] (ClientXdgToplevel b)
+newClientXdgToplevel ClientWindowManager{client, wlXdgWmBase} configureCallback requestCallback = do
   nextConfigureSerial <- newTVar Nothing
   configurationAccumulator <- newTVar defaultWindowConfiguration
 
@@ -108,7 +114,7 @@ newClientXdgToplevel ClientWindowManager{client, wlXdgWmBase} configureCallback
     xdgToplevel <- xdgSurface.get_toplevel
     setEventHandler xdgToplevel EventHandler_xdg_toplevel {
       configure = \width height states -> modifyTVar configurationAccumulator \x -> x { width = width, height = height, states = states },
-      close = pure () -- TODO
+      close = liftSTMc $ requestCallback WindowRequestClose
     }
 
     pure (xdgSurface, xdgToplevel)

quasar-wayland/src/Quasar/Wayland/Server/XdgShell.hs

@@ -152,7 +152,7 @@ initializeXdgToplevel xdgSurface wlXdgToplevel = do
 
     -- `newWindow` might call the configure callback immediately, so the window
     -- should be created after request handlers are attached.
-    newWindow xdgSurface.xdgWmBase.wm (sendConfigureEvent xdgToplevel)
+    newWindow xdgSurface.xdgWmBase.wm (sendConfigureEvent xdgToplevel) (sendWindowRequest xdgToplevel)
 
 sendConfigureEvent :: XdgToplevel b wm -> WindowConfiguration -> STMc NoRetry '[SomeException] ()
 sendConfigureEvent xdgToplevel windowConfiguration = do
@@ -161,6 +161,12 @@ sendConfigureEvent xdgToplevel windowConfiguration = do
   xdgToplevel.wlXdgToplevel.configure windowConfiguration.width windowConfiguration.height windowConfiguration.states
   xdgToplevel.xdgSurface.wlXdgSurface.configure 0
 
+sendWindowRequest :: XdgToplevel b wm -> WindowRequest -> STMc NoRetry '[SomeException] ()
+sendWindowRequest xdgToplevel WindowRequestClose = do
+  traceM "Sending window close request"
+
+  xdgToplevel.wlXdgToplevel.close
+
 onNullSurfaceCommit :: XdgToplevel b wm -> STM ()
 onNullSurfaceCommit = undefined -- TODO unmap surface
 

quasar-wayland/src/Quasar/Wayland/Shared/DummyWindowManager.hs

@@ -19,7 +19,7 @@ data DummyWindow b = DummyWindow
 
 instance BufferBackend b => IsWindowManager b (DummyWindowManager b) where
   type Window b (DummyWindowManager b) = DummyWindow b
-  newWindow _wm configCallback = do
+  newWindow _wm configCallback _requestCallback = do
     traceM "New window created"
     configCallback defaultWindowConfiguration
     pure DummyWindow

quasar-wayland/src/Quasar/Wayland/Shared/FnWindowManager.hs

@@ -12,7 +12,7 @@ import Quasar.Wayland.Surface
 import Quasar.Resources (Disposer, Disposable(getDisposer))
 
 newtype FnWindowManager b = FnWindowManager {
-  newWindowFn :: (WindowConfiguration -> STMc NoRetry '[SomeException] ()) -> STMc NoRetry '[SomeException] (FnWindow b)
+  newWindowFn :: WindowConfigurationCallback -> WindowRequestCallback -> STMc NoRetry '[SomeException] (FnWindow b)
 }
 
 data FnWindow b = FnWindow {
@@ -40,7 +40,7 @@ instance Disposable (FnWindow b) where
 
 toFnWindowManager :: forall b a. IsWindowManager b a => a -> FnWindowManager b
 toFnWindowManager upstream = FnWindowManager {
-  newWindowFn = \windowConfiguration -> toFnWindow <$> newWindow upstream windowConfiguration
+  newWindowFn = \confCB reqCB -> toFnWindow <$> newWindow upstream confCB reqCB
 }
 
 toFnWindow :: forall b a. IsWindow b a => a -> FnWindow b

quasar-wayland/src/Quasar/Wayland/Shared/WindowManagerApi.hs

@@ -3,7 +3,10 @@ module Quasar.Wayland.Shared.WindowManagerApi (
   IsWindow(..),
 
   WindowConfiguration(..),
+  WindowConfigurationCallback,
   defaultWindowConfiguration,
+  WindowRequest(..),
+  WindowRequestCallback,
   ConfigureSerial,
   unsafeConfigureSerial,
 ) where
@@ -16,7 +19,7 @@ import Quasar.Wayland.Surface
 
 class IsWindow b (Window b a) => IsWindowManager b a | a -> b where
   type Window b a
-  newWindow :: a -> (WindowConfiguration -> STMc NoRetry '[SomeException] ()) -> STMc NoRetry '[SomeException] (Window b a)
+  newWindow :: a -> WindowConfigurationCallback -> WindowRequestCallback -> STMc NoRetry '[SomeException] (Window b a)
 
 class (BufferBackend b, Disposable a) => IsWindow b a | a -> b where
   setTitle :: a -> WlString -> STMc NoRetry '[SomeException] ()
@@ -44,6 +47,12 @@ data WindowConfiguration = WindowConfiguration {
 }
   deriving Eq
 
+type WindowConfigurationCallback = WindowConfiguration -> STMc NoRetry '[SomeException] ()
+
+data WindowRequest = WindowRequestClose
+
+type WindowRequestCallback = WindowRequest -> STMc NoRetry '[SomeException] ()
+
 -- Default values as defined by the xdg-shell protocol
 defaultWindowConfiguration :: WindowConfiguration
 defaultWindowConfiguration = WindowConfiguration {