From f643c2ab0f954a127004e104c22ccff44f668dca Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Sun, 21 Nov 2021 01:53:08 +0100
Subject: [PATCH] Add async disposable

Co-authored-by: Jan Beinke <git@janbeinke.com>
---
 src/Quasar/Disposable.hs | 32 ++++++++++++++++++++++++++++++++
 1 file changed, 32 insertions(+)

diff --git a/src/Quasar/Disposable.hs b/src/Quasar/Disposable.hs
index 678b7ba..40a3105 100644
--- a/src/Quasar/Disposable.hs
+++ b/src/Quasar/Disposable.hs
@@ -9,6 +9,9 @@ module Quasar.Disposable (
   newDisposable,
   noDisposable,
 
+  -- ** Async Disposable
+  newAsyncDisposable,
+
   -- ** STM disposable
   STMDisposable,
   newSTMDisposable,
@@ -25,6 +28,7 @@ module Quasar.Disposable (
   awaitResourceManagerResult,
 ) where
 
+import Control.Concurrent (forkIO)
 import Control.Concurrent.STM
 import Control.Monad.Catch
 import Control.Monad.Reader
@@ -149,6 +153,34 @@ newDisposable disposeAction = liftIO do
   fmap toDisposable $ IODisposable key <$> newTMVarIO disposeAction <*> newDisposableFinalizers <*> newAsyncVar
 
 
+data AsyncDisposable = AsyncDisposable Unique (TMVar (IO ())) DisposableFinalizers (AsyncVar ())
+
+instance IsDisposable AsyncDisposable where
+  beginDispose (AsyncDisposable key actionVar finalizers resultVar) = do
+    -- This is only safe when run in masked state
+    atomically (tryTakeTMVar actionVar) >>= mapM_ \action -> do
+      void $ forkIO do
+        result <- try action
+        atomically do
+          putAsyncVarEitherSTM_ resultVar result
+          defaultRunFinalizers finalizers
+    pure $ DisposeResultAwait $ await resultVar
+
+  isDisposed (AsyncDisposable _ _ _ resultVar) = toAwaitable resultVar `catchAll` \_ -> pure ()
+
+  registerFinalizer (AsyncDisposable _ _ finalizers _) = defaultRegisterFinalizer finalizers
+
+-- | Create a new disposable from an IO action. The action will be run asynchrously. Is is guaranteed, that the IO
+-- action will only be called once (even when `dispose` is called multiple times).
+--
+-- The action must not block for an unbound time.
+newAsyncDisposable :: MonadIO m => IO () -> m Disposable
+newAsyncDisposable disposeAction = liftIO do
+  key <- newUnique
+  fmap toDisposable $ AsyncDisposable key <$> newTMVarIO disposeAction <*> newDisposableFinalizers <*> newAsyncVar
+
+
+
 data STMDisposable = STMDisposable Unique (TMVar (STM ())) DisposableFinalizers (AsyncVar ())
 
 instance IsDisposable STMDisposable where
-- 
GitLab