Add initial WindowCommit argument to newWindow function

examples/Client.hs

@@ -32,7 +32,7 @@ main = do
 
     window <- atomicallyC do
       windowManager <- getClientWindowManager client
-      newWindow windowManager properties (writeTMVar configurationVar) (\WindowRequestClose -> writeTVar shouldClose True)
+      newWindow windowManager properties defaultWindowCommit (writeTMVar configurationVar) (\WindowRequestClose -> writeTVar shouldClose True)
 
     frameId <- newTVarIO 0
 

examples/Proxy.hs

@@ -51,7 +51,8 @@ main = runQuasarAndExit do
 
 mapWindowManager :: IsWindowManager (Skia GL) w a => a -> FnWindowManager (Skia GL)
 mapWindowManager upstream = fnWindowManager {
-  newWindowFn = \props cfg req -> fnWindowManager.newWindowFn (mapProperties props) cfg req
+  newWindowFn = \props ic cfg req ->
+    fnWindowManager.newWindowFn (mapProperties props) ic cfg req
 }
   where
     fnWindowManager = toFnWindowManager upstream

examples/ShmClient.hs

@@ -34,7 +34,7 @@ main = do
 
     window <- atomicallyC do
       windowManager <- getClientWindowManager @ShmBufferBackend client
-      newWindow windowManager properties (writeTMVar configurationVar) \case
+      newWindow windowManager properties defaultWindowCommit (writeTMVar configurationVar) \case
         WindowRequestClose -> writeTVar closeRequestedVar True
 
     forM_ [gradient, red, green, blue, alpha, transparent, gradient, gradient2, gradient3, gradient4] \img -> do

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

@@ -3,7 +3,7 @@ module Quasar.Wayland.Client.Surface (
   ClientSurfaceManager,
   getClientSurfaceManager,
 
-  ClientSurface,
+  ClientSurface(wlSurface),
   newClientSurface,
   commitClientSurface,
 
@@ -203,9 +203,8 @@ newWlCompositor client = do
 newClientSurface ::
   ClientBufferBackend b =>
   WaylandClient b ->
-  (Object 'Client Interface_wl_surface -> STMc NoRetry '[SomeException] a) ->
-  STMc NoRetry '[SomeException] (ClientSurface b, a)
-newClientSurface client initializeSurfaceRoleFn = do
+  STMc NoRetry '[SomeException] (ClientSurface b)
+newClientSurface client = do
   surfaceManager <- getClientSurfaceManager client
 
   wlSurface <- liftSTMc surfaceManager.wlCompositor.create_surface
@@ -218,7 +217,6 @@ newClientSurface client initializeSurfaceRoleFn = do
     preferred_buffer_scale = \_ -> pure (),
     preferred_buffer_transform = \_ -> pure ()
   }
-  fnResult <- initializeSurfaceRoleFn wlSurface
 
   pendingCommit <- newTVar Nothing
   pendingDisposerFuture <- newTVar mempty
@@ -234,7 +232,7 @@ newClientSurface client initializeSurfaceRoleFn = do
   -- is garbage collected.
   forkSTM_ (clientSurfaceCommitWorker clientSurface) loggingExceptionSink
 
-  pure (clientSurface, fnResult)
+  pure clientSurface
 
 commitClientSurface ::
   ClientSurface b -> Owned (SurfaceCommit b) -> STMc NoRetry '[SomeException] (Future '[] ())

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

@@ -95,53 +95,49 @@ newClientXdgToplevel ::
   ClientBufferBackend b =>
   ClientWindowManager b ->
   WindowProperties ->
+  WindowCommit ->
   WindowConfigurationCallback ->
   WindowRequestCallback ->
   STMc NoRetry '[SomeException] (ClientXdgToplevel b)
-newClientXdgToplevel ClientWindowManager{client, wlXdgWmBase} properties configureCallback requestCallback = do
+newClientXdgToplevel ClientWindowManager{client, wlXdgWmBase} properties windowCommit configureCallback requestCallback = do
   nextConfigureSerial <- newTVar Nothing
   configurationAccumulator <- newTVar defaultWindowConfiguration
 
-  (clientSurface, (xdgSurface, xdgToplevel, propertiesDisposer)) <- newClientSurface @b client \wlSurface -> do
-
-    xdgSurface <- wlXdgWmBase.get_xdg_surface wlSurface
-    setEventHandler xdgSurface EventHandler_xdg_surface {
-      configure = \serial -> do
-        traceM ("configure: " <> show serial)
-        writeTVar nextConfigureSerial (Just serial)
-        configuration <- readTVar configurationAccumulator
-        configureCallback (configuration { configureSerial = unsafeConfigureSerial })
-    }
-
-    xdgToplevel <- xdgSurface.get_toplevel
-    setEventHandler xdgToplevel EventHandler_xdg_toplevel {
-      configure = \width height states -> modifyTVar configurationAccumulator \x -> x { width = width, height = height, states = states },
-      close = liftSTMc $ requestCallback WindowRequestClose,
-      configure_bounds = undefined,
-      wm_capabilities = undefined
-    }
+  clientSurface <- newClientSurface @b client
+  let wlSurface = clientSurface.wlSurface
 
-    (d1, initialTitle) <- liftSTMc $ attachSimpleObserver properties.title do
-      -- TODO ensure this logs/normalizes invalid titles but does not crash the downstream connection
-      tryCall . xdgToplevel.set_title
+  xdgSurface <- wlXdgWmBase.get_xdg_surface wlSurface
+  setEventHandler xdgSurface EventHandler_xdg_surface {
+    configure = \serial -> do
+      traceM ("configure: " <> show serial)
+      writeTVar nextConfigureSerial (Just serial)
+      configuration <- readTVar configurationAccumulator
+      configureCallback (configuration { configureSerial = unsafeConfigureSerial })
+  }
 
-    unless (nullWlString initialTitle) do
-      xdgToplevel.set_title initialTitle
+  xdgToplevel <- xdgSurface.get_toplevel
+  setEventHandler xdgToplevel EventHandler_xdg_toplevel {
+    configure = \width height states -> modifyTVar configurationAccumulator \x -> x { width = width, height = height, states = states },
+    close = liftSTMc $ requestCallback WindowRequestClose,
+    configure_bounds = undefined,
+    wm_capabilities = undefined
+  }
 
-    (d2, initialAppId) <- liftSTMc $ attachSimpleObserver properties.appId do
-      -- TODO ensure this logs/normalizes invalid app_ids but does not crash the downstream connection
-      tryCall . xdgToplevel.set_app_id
+  (d1, initialTitle) <- liftSTMc $ attachSimpleObserver properties.title do
+    -- TODO ensure this logs/normalizes invalid titles but does not crash the downstream connection
+    tryCall . xdgToplevel.set_title
 
-    unless (nullWlString initialAppId) do
-      xdgToplevel.set_app_id initialAppId
+  unless (nullWlString initialTitle) do
+    xdgToplevel.set_title initialTitle
 
-    let propertiesDisposer = d1 <> d2
+  (d2, initialAppId) <- liftSTMc $ attachSimpleObserver properties.appId do
+    -- TODO ensure this logs/normalizes invalid app_ids but does not crash the downstream connection
+    tryCall . xdgToplevel.set_app_id
 
-    -- Commit xdg_surface/xdg_toplevel state (this is an xdg_surface quirk).
-    -- This is required to receive the initial configure event.
-    liftSTMc wlSurface.commit
+  unless (nullWlString initialAppId) do
+    xdgToplevel.set_app_id initialAppId
 
-    pure (xdgSurface, xdgToplevel, propertiesDisposer)
+  let propertiesDisposer = d1 <> d2
 
   geometry <- newTVar (0, 0, 0, 0)
   maxSize <- newTVar (0, 0)
@@ -159,6 +155,12 @@ newClientXdgToplevel ClientWindowManager{client, wlXdgWmBase} properties configu
     minSize
   }
 
+  applyWindowCommit state windowCommit
+
+  -- Commit xdg_surface/xdg_toplevel state (this is an xdg_surface quirk).
+  -- This is required to receive the initial configure event.
+  liftSTMc wlSurface.commit
+
   ClientXdgToplevel <$> newTDisposableVar state disposeClientXdgToplevel
 
 commitClientXdgToplevel ::
@@ -173,27 +175,29 @@ commitClientXdgToplevel toplevel@(ClientXdgToplevel var) configureSerial windowC
   tryReadTDisposableVar var >>= \case
     Nothing -> disposeEventually surfaceCommit
     Just state -> do
-
-      let geometry@(x, y, w, h) = windowCommit.geometry
-      lastGeometry <- readTVar state.geometry
-      when (windowCommit.geometry /= lastGeometry) do
-        state.xdgSurface.set_window_geometry x y w h
-        writeTVar state.geometry geometry
-
-      let maxSize@(maxW, maxH) = windowCommit.maxSize
-      lastMaxSize <- readTVar state.maxSize
-      when (windowCommit.maxSize /= lastMaxSize) do
-        state.xdgToplevel.set_max_size maxW maxH
-        writeTVar state.maxSize maxSize
-
-      let minSize@(minW, minH) = windowCommit.minSize
-      lastMinSize <- readTVar state.minSize
-      when (windowCommit.minSize /= lastMinSize) do
-        state.xdgToplevel.set_min_size minW minH
-        writeTVar state.minSize minSize
-
+      applyWindowCommit state windowCommit
       commitClientSurface state.clientSurface surfaceCommit
 
+applyWindowCommit :: ClientXdgToplevelState b -> WindowCommit -> STMc NoRetry '[SomeException] ()
+applyWindowCommit state windowCommit = do
+  let geometry@(x, y, w, h) = windowCommit.geometry
+  lastGeometry <- readTVar state.geometry
+  when (windowCommit.geometry /= lastGeometry) do
+    state.xdgSurface.set_window_geometry x y w h
+    writeTVar state.geometry geometry
+
+  let maxSize@(maxW, maxH) = windowCommit.maxSize
+  lastMaxSize <- readTVar state.maxSize
+  when (windowCommit.maxSize /= lastMaxSize) do
+    state.xdgToplevel.set_max_size maxW maxH
+    writeTVar state.maxSize maxSize
+
+  let minSize@(minW, minH) = windowCommit.minSize
+  lastMinSize <- readTVar state.minSize
+  when (windowCommit.minSize /= lastMinSize) do
+    state.xdgToplevel.set_min_size minW minH
+    writeTVar state.minSize minSize
+
 ackToplevelConfigure :: ClientXdgToplevel b -> ConfigureSerial -> STMc NoRetry '[SomeException] ()
 ackToplevelConfigure toplevel _configureSerial = do
   withState toplevel \state ->