diff --git a/quasar/quasar.cabal b/quasar/quasar.cabal index bf8a626..8b3c7e6 100644 --- a/quasar/quasar.cabal +++ b/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 diff --git a/quasar/src/Quasar/Resources/DisposableVar.hs b/quasar/src/Quasar/Resources/DisposableVar.hs index 130303d..8238613 100644 --- a/quasar/src/Quasar/Resources/DisposableVar.hs +++ b/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 diff --git a/quasar/src/Quasar/Resources/FutureDisposer.hs b/quasar/src/Quasar/Resources/FutureDisposer.hs new file mode 100644 index 0000000..5fa86eb --- /dev/null +++ b/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))