From a9b397802e9be0534489466d4efc69baa45dbcc4 Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Sun, 13 Mar 2022 16:04:34 +0100
Subject: [PATCH] Implement trivialDisposer

---
 src/Quasar/Resources.hs          |  1 +
 src/Quasar/Resources/Disposer.hs | 22 +++++++++++++++++++++-
 2 files changed, 22 insertions(+), 1 deletion(-)

diff --git a/src/Quasar/Resources.hs b/src/Quasar/Resources.hs
index a991b42..cafc84f 100644
--- a/src/Quasar/Resources.hs
+++ b/src/Quasar/Resources.hs
@@ -26,6 +26,7 @@ module Quasar.Resources (
   Disposer,
   newUnmanagedIODisposerSTM,
   newUnmanagedSTMDisposerSTM,
+  trivialDisposer,
 
   -- ** Resource manager
   ResourceManager,
diff --git a/src/Quasar/Resources/Disposer.hs b/src/Quasar/Resources/Disposer.hs
index 15197f7..71ed426 100644
--- a/src/Quasar/Resources/Disposer.hs
+++ b/src/Quasar/Resources/Disposer.hs
@@ -9,6 +9,7 @@ module Quasar.Resources.Disposer (
   isDisposing,
   isDisposed,
   newUnmanagedPrimitiveDisposer,
+  trivialDisposer,
 
   -- * Resource manager
   ResourceManager,
@@ -30,6 +31,7 @@ import Quasar.Exceptions
 import Quasar.Prelude
 import Quasar.Utils.ShortIO
 import Quasar.Utils.TOnce
+import GHC.IO (unsafePerformIO, unsafeDupablePerformIO)
 
 
 class Resource a where
@@ -39,7 +41,8 @@ class Resource a where
 type DisposerState = TOnce DisposeFn (Future ())
 
 data Disposer
-  = FnDisposer Unique TIOWorker ExceptionSink DisposerState Finalizers
+  = TrivialDisposer
+  | FnDisposer Unique TIOWorker ExceptionSink DisposerState Finalizers
   | ResourceManagerDisposer ResourceManager
 
 instance Resource Disposer where
@@ -48,6 +51,10 @@ instance Resource Disposer where
 type DisposeFn = ShortIO (Future ())
 
 
+-- | A trivial disposer that does not perform any action when disposed.
+trivialDisposer :: Disposer
+trivialDisposer = TrivialDisposer
+
 newUnmanagedPrimitiveDisposer :: ShortIO (Future ()) -> TIOWorker -> ExceptionSink -> STM Disposer
 newUnmanagedPrimitiveDisposer fn worker exChan = do
   key <- newUniqueSTM
@@ -60,6 +67,7 @@ dispose resource = liftIO $ await =<< atomically (disposeEventuallySTM resource)
 disposeEventuallySTM :: Resource r => r -> STM (Future ())
 disposeEventuallySTM resource =
   case getDisposer resource of
+    TrivialDisposer -> pure (pure ())
     FnDisposer _ worker exChan state finalizers -> do
       beginDisposeFnDisposer worker exChan state finalizers
     ResourceManagerDisposer resourceManager ->
@@ -72,12 +80,14 @@ disposeEventuallySTM_ resource = void $ disposeEventuallySTM resource
 isDisposed :: Resource a => a -> Future ()
 isDisposed resource =
   case getDisposer resource of
+    TrivialDisposer -> pure ()
     FnDisposer _ _ _ state _ -> join (toFuture state)
     ResourceManagerDisposer resourceManager -> resourceManagerIsDisposed resourceManager
 
 isDisposing :: Resource a => a -> Future ()
 isDisposing resource =
   case getDisposer resource of
+    TrivialDisposer -> pure ()
     FnDisposer _ _ _ state _ -> unsafeAwaitSTM (check . isRight =<< readTOnceState state)
     ResourceManagerDisposer resourceManager -> resourceManagerIsDisposing resourceManager
 
@@ -107,11 +117,17 @@ beginDisposeFnDisposer worker exChan disposeState finalizers =
           throwM $ DisposeException ex
 
 disposerKey :: Disposer -> Unique
+disposerKey TrivialDisposer = trivialDisposableKey
 disposerKey (FnDisposer key _ _ _ _) = key
 disposerKey (ResourceManagerDisposer resourceManager) = resourceManagerKey resourceManager
 
 
+trivialDisposableKey :: Unique
+trivialDisposableKey = unsafePerformIO newUnique
+{-# NOINLINE trivialDisposableKey #-}
+
 disposerFinalizers :: Disposer -> Finalizers
+disposerFinalizers TrivialDisposer = completedFinalizers
 disposerFinalizers (FnDisposer _ _ _ _ finalizers) = finalizers
 disposerFinalizers (ResourceManagerDisposer rm) = resourceManagerFinalizers rm
 
@@ -215,6 +231,7 @@ beginDisposeResourceManagerInternal rm = do
     rmKey = resourceManagerKey rm
 
     resourceManagerBeginDispose :: Disposer -> STM DisposeResult
+    resourceManagerBeginDispose TrivialDisposer = pure $ DisposeResultAwait $ pure ()
     resourceManagerBeginDispose (FnDisposer _ worker exChan state finalizers) =
       DisposeResultAwait <$> beginDisposeFnDisposer worker exChan state finalizers
     resourceManagerBeginDispose (ResourceManagerDisposer resourceManager) =
@@ -286,3 +303,6 @@ runFinalizersAfter finalizers awaitable = do
       void $ forkIOShortIO do
         await awaitable
         atomically $ runFinalizers finalizers
+
+completedFinalizers :: Finalizers
+completedFinalizers = unsafeDupablePerformIO $ Finalizers <$> newEmptyTMVarIO
-- 
GitLab