Add DisposedException and HasCallStack to getExportBufferId

queezle42 · Jun 5, 2024 · 3c70898 · 3c70898
1 parent bb2f99b
commit 3c70898
Show file tree

Hide file tree

Showing 4 changed files with 21 additions and 22 deletions.
diff --git a/flake.lock b/flake.lock
diff --git a/quasar-wayland-skia/src/Quasar/Wayland/Skia.hs b/quasar-wayland-skia/src/Quasar/Wayland/Skia.hs
@@ -32,7 +32,7 @@ import Language.C.Inline.Context qualified as C
 import Language.C.Inline.Cpp qualified as CPP
 import Language.C.Inline.Cpp.Unsafe qualified as CPPU
 import Language.C.Types qualified as C
-import Quasar.Exceptions (AsyncException(..), mkDisposedException, ExceptionSink)
+import Quasar.Exceptions (AsyncException(..), mkDisposedException, ExceptionSink, DisposedException)
 import Quasar.Exceptions.ExceptionSink (loggingExceptionSink)
 import Quasar.Future
 import Quasar.Prelude
@@ -156,11 +156,8 @@ newSkiaSurface skia width height = runSkiaIO skia.thread do
 skiaSurfaceKey :: SkiaSurface s -> Unique
 skiaSurfaceKey (SkiaSurface var) = disposerElementKey var
 
-readSkiaSurfaceState :: SkiaSurface s -> STMc NoRetry '[] (SkiaSurfaceState s)
-readSkiaSurfaceState (SkiaSurface var) =
-  tryReadDisposableVar var >>= \case
-    Nothing -> undefined
-    Just surfaceState -> pure surfaceState
+readSkiaSurfaceState :: SkiaSurface s -> STMc NoRetry '[DisposedException] (SkiaSurfaceState s)
+readSkiaSurfaceState (SkiaSurface var) = readDisposableVar var
 
 readSkiaSurfaceStateIO :: SkiaSurface s -> IO (SkiaSurfaceState s)
 readSkiaSurfaceStateIO (SkiaSurface var) =
@@ -255,15 +252,16 @@ instance IsSkiaBackend s => ClientBufferBackend (Skia s) where
   renderFrame :: Rc (SkiaFrame s) -> IO (Rc (SkiaRenderedFrame s))
   renderFrame frame = renderFrameInternal frame
 
-  getExportBufferId :: SkiaRenderedFrame s -> STMc NoRetry '[] SkiaExportBufferId
+  getExportBufferId ::
+    HasCallStack =>
+    SkiaRenderedFrame s -> STMc NoRetry '[DisposedException] SkiaExportBufferId
   getExportBufferId (SkiaRenderedFrameOwnedSurface surface) =
     pure (SkiaExportBufferIdUnique (skiaSurfaceKey surface))
   getExportBufferId (SkiaRenderedFrameBorrowedSurface (Borrowed _ surface)) =
     pure (SkiaExportBufferIdUnique (skiaSurfaceKey surface))
-  getExportBufferId (SkiaRenderedFrameImportedDmabuf _ _ rc) =
-    tryReadRc rc >>= \case
-      Nothing -> undefined
-      Just (ExternalDmabuf key _) -> pure (SkiaExportBufferIdUnique key)
+  getExportBufferId (SkiaRenderedFrameImportedDmabuf _ _ rc) = do
+    (ExternalDmabuf key _) <- readRc rc
+    pure (SkiaExportBufferIdUnique key)
   getExportBufferId (SkiaRenderedFrameSinglePixel pixel) = pure (SkiaExportBufferIdSinglePixel pixel)
 
   exportWlBuffer :: SkiaClientBufferManager s -> SkiaRenderedFrame s -> IO (NewObject 'Client Interface_wl_buffer)

diff --git a/quasar-wayland/src/Quasar/Wayland/Client/Surface.hs b/quasar-wayland/src/Quasar/Wayland/Client/Surface.hs
@@ -16,6 +16,7 @@ import Data.HashMap.Strict (HashMap)
 import Data.HashMap.Strict qualified as HM
 import Data.Typeable (Typeable)
 import Quasar.Async.Fork (forkSTM_)
+import Quasar.Exceptions
 import Quasar.Exceptions.ExceptionSink (loggingExceptionSink)
 import Quasar.Future (Future, Promise, ToFuture (toFuture), newPromise, peekFuture, fulfillPromise, MonadAwait (await), callOnceCompleted_)
 import Quasar.Prelude
@@ -56,7 +57,7 @@ class (RenderBackend b, Typeable (ClientBufferManager b), Hashable (ExportBuffer
   --
   -- This should return the id of an internal buffer that the frame has been
   -- rendered to.
-  getExportBufferId :: RenderedFrame b -> STMc NoRetry '[] (ExportBufferId b)
+  getExportBufferId :: HasCallStack => RenderedFrame b -> STMc NoRetry '[DisposedException] (ExportBufferId b)
 
   -- | Called by the `Surface`-implementation when a buffer should be mapped
   -- from the wayland client to the wayland server. This usually shares memory
@@ -69,8 +70,8 @@ class (RenderBackend b, Typeable (ClientBufferManager b), Hashable (ExportBuffer
   -- The caller takes ownership of the resulting @wl_buffer@ and will attach the
   -- event handler.
   --
-  -- The buffer argument is owned by the caller and must not be disposed by
-  -- the callee.
+  -- The @RenderedFrame@ argument is owned by the caller and must not be
+  -- disposed by the callee.
   exportWlBuffer :: ClientBufferManager b -> RenderedFrame b -> IO (NewObject 'Client Interface_wl_buffer)
 
   syncExportBuffer :: RenderedFrame b -> IO ()

diff --git a/quasar-wayland/src/Quasar/Wayland/Shm.hs b/quasar-wayland/src/Quasar/Wayland/Shm.hs
@@ -13,6 +13,7 @@ import Data.HashMap.Strict qualified as HM
 import Data.Hashable (Hashable(hash, hashWithSalt))
 import Data.Set (Set)
 import Data.Set qualified as Set
+import Quasar.Exceptions
 import Quasar.Future
 import Quasar.Observable.Core
 import Quasar.Prelude
@@ -119,11 +120,10 @@ instance ClientBufferBackend ShmBufferBackend where
   renderFrame :: Rc ShmBufferFrame -> IO (Rc ShmBufferFrame)
   renderFrame = pure
 
-  getExportBufferId :: ShmBufferFrame -> STMc NoRetry '[] Unique
-  getExportBufferId (ShmBufferFrame _ bufferRc) =
-    tryReadRc bufferRc >>= \case
-      Nothing -> undefined -- "ShmBufferBackend: Trying to get export id for a disposed frame"
-      Just (Borrowed _ buffer) -> pure buffer.key
+  getExportBufferId :: HasCallStack => ShmBufferFrame -> STMc NoRetry '[DisposedException] Unique
+  getExportBufferId (ShmBufferFrame _ bufferRc) = do
+    (Borrowed _ buffer) <- readRc bufferRc
+    pure buffer.key
 
   exportWlBuffer :: ClientShmManager -> ShmBufferFrame -> IO (NewObject 'Client Interface_wl_buffer)
   exportWlBuffer client (ShmBufferFrame _ rc) = atomicallyC do