quasar: Add futureDisposer function

Co-authored-by: Jan Beinke <[email protected]>

quasar/quasar.cabal

@@ -90,6 +90,7 @@ library
     Quasar.PreludeExtras
     Quasar.Resources
     Quasar.Resources.DisposableVar
+    Quasar.Resources.FutureDisposer
     Quasar.Resources.RcVar
     Quasar.Utils.CallbackRegistry
     Quasar.Utils.Exceptions

quasar/src/Quasar/Resources/DisposableVar.hs

@@ -28,15 +28,16 @@ data DisposableVar a = DisposableVar Unique (DisposableVarState a)
 
 instance ToFuture () (DisposableVar a) where
   toFuture (DisposableVar _ state) = do
-    mdeps <- join (toFuture state)
-    mapM_ flattenDisposeDependencies mdeps
+    deps <- join (toFuture state)
+    mapM_ flattenDisposeDependencies deps
 
 instance IsDisposerElement (DisposableVar a) where
   disposerElementKey (DisposableVar key _) = key
+
   beginDispose# (DisposableVar key disposeState) = do
-    deps <- mapFinalizeTOnce disposeState \(fn, value) ->
+    fdeps <- mapFinalizeTOnce disposeState \(fn, value) ->
       beginDisposeDisposer =<< fn value
-    pure (DisposeResultDependencies (DisposeDependencies key deps))
+    pure (DisposeResultDependencies (DisposeDependencies key fdeps))
 
   disposeEventually# self = do
     beginDispose# self <&> \case

quasar/src/Quasar/Resources/FutureDisposer.hs

@@ -0,0 +1,44 @@
+module Quasar.Resources.FutureDisposer (
+  futureDisposer,
+) where
+
+import Quasar.Prelude
+import Quasar.Future
+import Quasar.Resources.Disposer
+import Quasar.Utils.TOnce
+
+data FutureDisposer = FutureDisposer Unique (TOnce (Future Disposer) (Future [DisposeDependencies]))
+
+instance IsDisposerElement FutureDisposer where
+  disposerElementKey (FutureDisposer key _) = key
+
+  disposeEventually# self = do
+    beginDispose# self <&> \case
+      DisposeResultAwait future -> future
+      DisposeResultDependencies deps -> flattenDisposeDependencies deps
+
+  beginDispose# (FutureDisposer key var) = do
+    fdeps <- mapFinalizeTOnce var \future -> do
+
+      promise <- newPromise
+      callOnceCompleted_ future \disposer -> do
+        fdeps <- beginDisposeDisposer disposer
+        tryFulfillPromise_ promise fdeps
+
+      pure (join (toFuture promise))
+
+    pure (DisposeResultDependencies (DisposeDependencies key fdeps))
+
+instance ToFuture () FutureDisposer where
+  toFuture (FutureDisposer _ var) = do
+    deps <- join (toFuture var)
+    mapM_ flattenDisposeDependencies deps
+
+instance Disposable FutureDisposer where
+  getDisposer x = mkDisposer [x]
+
+futureDisposer :: Future Disposer -> STMc NoRetry '[] Disposer
+futureDisposer future = do
+  key <- newUniqueSTM
+  var <- newTOnce future
+  pure (getDisposer (FutureDisposer key var))