From c8c216039a8edb6d4b6de582d6178534ac5b04dc Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Thu, 2 Sep 2021 18:16:21 +0200
Subject: [PATCH] Move registerDisposable out of MonadResourceManager
---
src/Quasar/Disposable.hs | 37 +++++++++++++++++++------------------
1 file changed, 19 insertions(+), 18 deletions(-)
diff --git a/src/Quasar/Disposable.hs b/src/Quasar/Disposable.hs
index c15bfce..d6128f0 100644
--- a/src/Quasar/Disposable.hs
+++ b/src/Quasar/Disposable.hs
@@ -10,6 +10,8 @@ module Quasar.Disposable (
-- * MonadResourceManager
MonadResourceManager(..),
+ registerDisposable,
+ registerDisposeAction,
disposeEventually,
withOnResourceManager,
onResourceManager,
@@ -37,7 +39,6 @@ module Quasar.Disposable (
-- ** Task exceptions
CancelTask(..),
TaskDisposed(..),
-
) where
import Control.Concurrent (forkIOWithUnmask)
@@ -225,43 +226,43 @@ class IsResourceManager a where
-- TODO move to class
--attachDisposable :: (IsDisposable b, MonadIO m) => a -> b -> m ()
+ --subResourceManager :: MonadResourceManager m => m (DisposableResourceThingy)
+
+
instance IsResourceManager ResourceManager where
toResourceManager = id
class (MonadAwait m, MonadMask m, MonadIO m) => MonadResourceManager m where
- registerDisposable :: IsDisposable a => a -> m ()
-
- registerDisposeAction :: IO (Awaitable ()) -> m ()
- registerDisposeAction disposeAction = mask_ $ registerDisposable =<< newDisposable disposeAction
+ -- | Get the underlying resource manager.
+ askResourceManager :: m ResourceManager
+ -- | Replace the resource manager for a computation.
localResourceManager :: ResourceManager -> m a -> m a
- -- | Get the underlying resource manager. This is intended to fork the Monad (e.g. in the `async`-Function) and must
- -- not be used to dispose the resource manager (also doing so is a deadlock).
- --
- -- Might be replaced with an alternative mechanism in the future.
- askResourceManager :: m ResourceManager
+
+registerDisposable :: (IsDisposable a, MonadResourceManager m) => a -> m ()
+registerDisposable disposable = do
+ resourceManager <- askResourceManager
+ attachDisposable resourceManager disposable
-instance (MonadAwait m, MonadMask m, MonadIO m) => MonadResourceManager (ReaderT ResourceManager m) where
- registerDisposable disposable = do
- resourceManager <- ask
- attachDisposable resourceManager disposable
+registerDisposeAction :: MonadResourceManager m => IO (Awaitable ()) -> m ()
+registerDisposeAction disposeAction = mask_ $ registerDisposable =<< newDisposable disposeAction
+
+instance (MonadAwait m, MonadMask m, MonadIO m) => MonadResourceManager (ReaderT ResourceManager m) where
localResourceManager resourceManager = local (const resourceManager)
askResourceManager = ask
instance {-# OVERLAPPABLE #-} MonadResourceManager m => MonadResourceManager (ReaderT r m) where
- registerDisposable disposable = lift $ registerDisposable disposable
+ askResourceManager = lift askResourceManager
localResourceManager resourceManager action = do
x <- ask
lift $ localResourceManager resourceManager $ runReaderT action x
- askResourceManager = lift askResourceManager
-
onResourceManager :: (IsResourceManager a) => a -> ReaderT ResourceManager m r -> m r
onResourceManager target action = runReaderT action (toResourceManager target)
@@ -271,7 +272,7 @@ captureTask :: MonadResourceManager m => m (Awaitable a) -> m (Task a)
captureTask action = do
-- TODO improve performance by only creating a new resource manager when two or more disposables are attached
resourceManager <- newResourceManager
- awaitable <- localResourceManager resourceManager $ action
+ awaitable <- localResourceManager resourceManager action
pure $ Task (toDisposable resourceManager) awaitable
captureDisposable :: MonadResourceManager m => m () -> m Disposable
--
GitLab