From f414b5532d0f3c1afa814bdf2bea200b1eaf952d Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Fri, 25 Feb 2022 18:55:13 +0100
Subject: [PATCH] Remove old resource manager and async modules
---
quasar.cabal | 7 +-
src/Quasar/Disposable.hs | 272 --------
src/Quasar/Old/Async.hs | 95 ---
src/Quasar/Old/UnmanagedAsync.hs | 133 ----
src/Quasar/ResourceManager.hs | 628 ------------------
test/Quasar/AsyncSpec.hs | 12 +-
test/Quasar/DisposableSpec.hs | 36 -
.../Observable/ObservableHashMapSpec.hs | 18 +-
test/Quasar/ObservableSpec.hs | 8 +-
test/Quasar/ResourceManagerSpec.hs | 147 ----
test/Quasar/ResourcesSpec.hs | 178 +++++
11 files changed, 198 insertions(+), 1336 deletions(-)
delete mode 100644 src/Quasar/Disposable.hs
delete mode 100644 src/Quasar/Old/Async.hs
delete mode 100644 src/Quasar/Old/UnmanagedAsync.hs
delete mode 100644 src/Quasar/ResourceManager.hs
delete mode 100644 test/Quasar/DisposableSpec.hs
delete mode 100644 test/Quasar/ResourceManagerSpec.hs
create mode 100644 test/Quasar/ResourcesSpec.hs
diff --git a/quasar.cabal b/quasar.cabal
index 589d624..5ee209b 100644
--- a/quasar.cabal
+++ b/quasar.cabal
@@ -90,7 +90,6 @@ library
Quasar.Async.STMHelper
Quasar.Async.V2
Quasar.Awaitable
- Quasar.Disposable
Quasar.Exceptions
Quasar.Exceptions.ExceptionChannel
Quasar.Monad
@@ -98,11 +97,8 @@ library
Quasar.Observable.Delta
Quasar.Observable.ObservableHashMap
Quasar.Observable.ObservablePriority
- Quasar.Old.Async
- Quasar.Old.UnmanagedAsync
Quasar.Prelude
Quasar.PreludeExtras
- Quasar.ResourceManager
Quasar.Resources
Quasar.Timer
Quasar.Timer.PosixTimer
@@ -130,10 +126,9 @@ test-suite quasar-test
other-modules:
Quasar.AsyncSpec
Quasar.AwaitableSpec
- Quasar.DisposableSpec
Quasar.ObservableSpec
Quasar.Observable.ObservableHashMapSpec
Quasar.Observable.ObservablePrioritySpec
- Quasar.ResourceManagerSpec
+ Quasar.ResourcesSpec
hs-source-dirs:
test
diff --git a/src/Quasar/Disposable.hs b/src/Quasar/Disposable.hs
deleted file mode 100644
index d232f2d..0000000
--- a/src/Quasar/Disposable.hs
+++ /dev/null
@@ -1,272 +0,0 @@
-module Quasar.Disposable (
- -- * Disposable
- IsDisposable(..),
- Disposable,
- dispose,
- disposeEventually,
- disposeEventually_,
-
- newDisposable,
- noDisposable,
-
- -- ** Async Disposable
- newAsyncDisposable,
-
- -- ** STM disposable
- STMDisposable,
- newSTMDisposable,
- newSTMDisposable',
- disposeSTMDisposable,
-
- -- * Implementation internals
- DisposeResult(..),
- ResourceManagerResult(..),
- DisposableFinalizers,
- newDisposableFinalizers,
- newDisposableFinalizersSTM,
- defaultRegisterFinalizer,
- defaultRunFinalizers,
- awaitResourceManagerResult,
-) where
-
-import Control.Concurrent (forkIO)
-import Control.Concurrent.STM
-import Control.Monad.Catch
-import Control.Monad.Reader
-import Data.HashSet (HashSet)
-import Data.HashSet qualified as HashSet
-import GHC.Conc (unsafeIOToSTM)
-import Quasar.Awaitable
-import Quasar.Prelude
-
-
--- * Disposable
-
-class IsDisposable a where
- -- | Convert an `IsDisposable`-Object to a `Disposable`.
- --
- -- When implementing the `IsDisposable`-class this can be used to defer the dispose behavior to a disposable created
- -- by e.g. `newDisposable`.
- toDisposable :: a -> Disposable
- toDisposable = Disposable
-
- -- | Begin to dispose (/release) resource(s).
- --
- -- The implementation has to be idempotent, i.e. calling `beginDispose` once or multiple times should have the same
- -- effect.
- --
- -- `beginDispose` must be called in masked state.
- --
- -- `beginDispose` must not block for an unbounded time.
- --
- -- TODO document finalizers (finalizers also have to run when an exception is thrown)
- beginDispose :: a -> IO DisposeResult
- beginDispose = beginDispose . toDisposable
-
- isDisposed :: a -> Awaitable ()
- isDisposed = isDisposed . toDisposable
-
- -- | Finalizers MUST NOT throw exceptions.
- --
- -- The boolean returned by register finalizer indicates if the operation was successful.
- registerFinalizer :: a -> STM () -> STM Bool
- registerFinalizer = registerFinalizer . toDisposable
-
- {-# MINIMAL toDisposable | (beginDispose, isDisposed, registerFinalizer) #-}
-
-dispose :: MonadIO m => IsDisposable a => a -> m ()
-dispose disposable = liftIO do
- uninterruptibleMask_ (beginDispose disposable) >>= \case
- DisposeResultDisposed -> pure ()
- (DisposeResultAwait awaitable) -> await awaitable
- (DisposeResultResourceManager result) -> awaitResourceManagerResult result
-
--- | Begin to dispose a resource.
-disposeEventually :: (IsDisposable a, MonadIO m) => a -> m (Awaitable ())
-disposeEventually disposable = do
- disposeEventually_ disposable
- pure $ isDisposed disposable
-
--- | Begin to dispose a resource.
-disposeEventually_ :: (IsDisposable a, MonadIO m) => a -> m ()
-disposeEventually_ disposable = liftIO do
- uninterruptibleMask_ $ void $ beginDispose disposable
-
-awaitResourceManagerResult :: forall m. MonadAwait m => ResourceManagerResult -> m ()
-awaitResourceManagerResult = void . go mempty
- where
- go :: HashSet Unique -> ResourceManagerResult -> m (HashSet Unique)
- go keys (ResourceManagerResult key awaitable)
- | HashSet.member key keys = pure keys -- resource manager was encountered before
- | otherwise = do
- dependencies <- await awaitable
- foldM go (HashSet.insert key keys) dependencies
-
-
-data DisposeResult
- = DisposeResultDisposed
- | DisposeResultAwait (Awaitable ())
- | DisposeResultResourceManager ResourceManagerResult
-
-data ResourceManagerResult = ResourceManagerResult Unique (Awaitable [ResourceManagerResult])
-
-
-instance IsDisposable a => IsDisposable (Maybe a) where
- toDisposable = maybe noDisposable toDisposable
-
-
-data Disposable = forall a. IsDisposable a => Disposable a
-
-instance IsDisposable Disposable where
- beginDispose (Disposable x) = beginDispose x
- isDisposed (Disposable x) = isDisposed x
- registerFinalizer (Disposable x) = registerFinalizer x
- toDisposable = id
-
-instance IsAwaitable () Disposable where
- toAwaitable = isDisposed
-
-
-
-data IODisposable = IODisposable Unique (TMVar (IO ())) DisposableFinalizers (AsyncVar ())
-
-instance IsDisposable IODisposable where
- beginDispose (IODisposable key actionVar finalizers resultVar) = do
- -- This is only safe when run in masked state
- atomically (tryTakeTMVar actionVar) >>= mapM_ \action -> do
- result <- try action
- atomically do
- putAsyncVarEitherSTM_ resultVar result
- defaultRunFinalizers finalizers
- -- Await so concurrent `beginDispose` calls don't exit too early
- await resultVar
- pure DisposeResultDisposed
-
- isDisposed (IODisposable _ _ _ resultVar) = toAwaitable resultVar `catchAll` \_ -> pure ()
-
- registerFinalizer (IODisposable _ _ finalizers _) = defaultRegisterFinalizer finalizers
-
-
--- | Create a new disposable from an IO action. 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.
-newDisposable :: IO () -> STM Disposable
-newDisposable disposeAction = do
- key <- newUniqueSTM
- fmap toDisposable $ IODisposable key <$> newTMVar disposeAction <*> newDisposableFinalizersSTM <*> newAsyncVarSTM
-
-
-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 :: IO () -> STM Disposable
-newAsyncDisposable disposeAction = do
- key <- newUniqueSTM
- fmap toDisposable $ AsyncDisposable key <$> newTMVar disposeAction <*> newDisposableFinalizersSTM <*> newAsyncVarSTM
-
-
-
-data STMDisposable = STMDisposable Unique (TMVar (STM ())) DisposableFinalizers (AsyncVar ())
-
-instance IsDisposable STMDisposable where
- beginDispose (STMDisposable key actionVar finalizers resultVar) = do
- -- This is only safe when run in masked state
- atomically (tryTakeTMVar actionVar) >>= mapM_ \action -> do
- atomically do
- result <- try action
- putAsyncVarEitherSTM_ resultVar result
- defaultRunFinalizers finalizers
- -- Await so concurrent `beginDispose` calls don't exit too early
- await resultVar
- pure DisposeResultDisposed
-
- isDisposed (STMDisposable _ _ _ resultVar) = toAwaitable resultVar `catchAll` \_ -> pure ()
-
- registerFinalizer (STMDisposable _ _ finalizers _) = defaultRegisterFinalizer finalizers
-
--- | Create a new disposable from an STM action. Is is guaranteed, that the STM action will only be called once (even
--- when `dispose` is called multiple times).
---
--- The action must not block (retry) for an unbound time.
-newSTMDisposable :: STM () -> STM Disposable
-newSTMDisposable disposeAction = toDisposable <$> newSTMDisposable' disposeAction
-
--- | Create a new disposable from an STM action. Is is guaranteed, that the STM action will only be called once (even
--- when `dispose` is called multiple times).
---
--- The action must not block (retry) for an unbound time.
---
--- This variant of `newSTMDisposable` returns an unboxed `STMDisposable` which can be disposed from `STM` by using
--- `disposeSTMDisposable`.
-newSTMDisposable' :: STM () -> STM STMDisposable
-newSTMDisposable' disposeAction = do
- key <- unsafeIOToSTM newUnique
- STMDisposable key <$> newTMVar disposeAction <*> newDisposableFinalizersSTM <*> newAsyncVarSTM
-
-disposeSTMDisposable :: STMDisposable -> STM ()
-disposeSTMDisposable (STMDisposable key actionVar finalizers resultVar) = do
- tryTakeTMVar actionVar >>= \case
- Just action -> do
- result <- try action
- putAsyncVarEitherSTM_ resultVar result
- defaultRunFinalizers finalizers
- Nothing -> readAsyncVarSTM resultVar
-
-
-data EmptyDisposable = EmptyDisposable
-
-instance IsDisposable EmptyDisposable where
- beginDispose EmptyDisposable = pure DisposeResultDisposed
- isDisposed _ = pure ()
- registerFinalizer _ _ = pure False
-
-
-
--- | A `Disposable` for which `dispose` is a no-op and which reports as already disposed.
-noDisposable :: Disposable
-noDisposable = toDisposable EmptyDisposable
-
-
-
--- * Implementation internals
-
-newtype DisposableFinalizers = DisposableFinalizers (TMVar [STM ()])
-
-newDisposableFinalizers :: IO DisposableFinalizers
-newDisposableFinalizers = DisposableFinalizers <$> newTMVarIO []
-
-newDisposableFinalizersSTM :: STM DisposableFinalizers
-newDisposableFinalizersSTM = DisposableFinalizers <$> newTMVar []
-
-defaultRegisterFinalizer :: DisposableFinalizers -> STM () -> STM Bool
-defaultRegisterFinalizer (DisposableFinalizers finalizerVar) finalizer =
- tryTakeTMVar finalizerVar >>= \case
- Just finalizers -> do
- putTMVar finalizerVar (finalizer : finalizers)
- pure True
- Nothing -> pure False
-
-defaultRunFinalizers :: DisposableFinalizers -> STM ()
-defaultRunFinalizers (DisposableFinalizers finalizerVar) = do
- tryTakeTMVar finalizerVar >>= \case
- Just finalizers -> sequence_ finalizers
- Nothing -> throwM $ userError "defaultRunFinalizers was called multiple times (it must only be run once)"
diff --git a/src/Quasar/Old/Async.hs b/src/Quasar/Old/Async.hs
deleted file mode 100644
index e93e95f..0000000
--- a/src/Quasar/Old/Async.hs
+++ /dev/null
@@ -1,95 +0,0 @@
-module Quasar.Old.Async (
- -- * Async
- Async,
- async,
- async_,
- asyncWithUnmask,
- asyncWithUnmask_,
- withAsync,
-
- -- ** Async with explicit error handling
- asyncWithHandler,
- asyncWithHandler_,
- asyncWithHandlerAndUnmask,
- asyncWithHandlerAndUnmask_,
-
- -- ** Async exceptions
- CancelAsync(..),
- AsyncDisposed(..),
- AsyncException(..),
- isCancelAsync,
- isAsyncDisposed,
-) where
-
-import Control.Monad.Catch
-import Control.Monad.Reader
-import Quasar.Disposable
-import Quasar.Old.UnmanagedAsync
-import Quasar.Prelude
-import Quasar.ResourceManager
-
--- | TODO: Documentation
---
--- The action will be run with asynchronous exceptions unmasked.
-async :: (MonadResourceManager m, MonadIO m, MonadMask m) => ResourceManagerIO a -> m (Async a)
-async action = asyncWithUnmask \unmask -> unmask action
-
--- | TODO: Documentation
---
--- The action will be run with asynchronous exceptions masked and will be passed an action that can be used to unmask.
-asyncWithUnmask
- :: (MonadResourceManager m, MonadIO m, MonadMask m)
- => ((ResourceManagerIO a -> ResourceManagerIO a)
- -> ResourceManagerIO r)
- -> m (Async r)
-asyncWithUnmask action = do
- resourceManager <- askResourceManager
- asyncWithHandlerAndUnmask (onResourceManager resourceManager . throwToResourceManager . AsyncException) action
-
-async_ :: (MonadResourceManager m, MonadIO m, MonadMask m) => ResourceManagerIO () -> m ()
-async_ action = void $ async action
-
-asyncWithUnmask_ :: (MonadResourceManager m, MonadIO m, MonadMask m) => ((ResourceManagerIO a -> ResourceManagerIO a) -> ResourceManagerIO ()) -> m ()
-asyncWithUnmask_ action = void $ asyncWithUnmask action
-
--- | TODO: Documentation
---
--- The action will be run with asynchronous exceptions unmasked. When an exception is thrown that is not caused from
--- the disposable instance (i.e. the task being canceled), the handler is called with that exception.
-asyncWithHandlerAndUnmask
- :: (MonadResourceManager m, MonadIO m, MonadMask m)
- => (SomeException -> IO ())
- -> ((ResourceManagerIO a -> ResourceManagerIO a)
- -> ResourceManagerIO r)
- -> m (Async r)
-asyncWithHandlerAndUnmask handler action = do
- resourceManager <- askResourceManager
- registerNewResource do
- unmanagedAsyncWithHandlerAndUnmask wrappedHandler \unmask ->
- onResourceManager resourceManager (action (liftUnmask unmask))
- where
- wrappedHandler :: SomeException -> IO ()
- wrappedHandler (fromException -> Just AsyncDisposed) = pure ()
- wrappedHandler ex = handler ex
- liftUnmask :: (forall b. IO b -> IO b) -> ResourceManagerIO a -> ResourceManagerIO a
- liftUnmask unmask innerAction = do
- resourceManager <- askResourceManager
- liftIO $ unmask $ onResourceManager resourceManager innerAction
-
-asyncWithHandlerAndUnmask_
- :: (MonadResourceManager m, MonadIO m, MonadMask m)
- => (SomeException -> IO ())
- -> ((ResourceManagerIO a -> ResourceManagerIO a)
- -> ResourceManagerIO r)
- -> m ()
-asyncWithHandlerAndUnmask_ handler action = void $ asyncWithHandlerAndUnmask handler action
-
-asyncWithHandler :: (MonadResourceManager m, MonadIO m, MonadMask m) => (SomeException -> IO ()) -> ResourceManagerIO r -> m (Async r)
-asyncWithHandler handler action = asyncWithHandlerAndUnmask handler \unmask -> unmask action
-
-asyncWithHandler_ :: (MonadResourceManager m, MonadIO m, MonadMask m) => (SomeException -> IO ()) -> ResourceManagerIO r -> m ()
-asyncWithHandler_ handler action = void $ asyncWithHandler handler action
-
-
-withAsync :: (MonadResourceManager m, MonadIO m, MonadMask m) => ResourceManagerIO r -> (Async r -> m a) -> m a
-withAsync action = bracket (async action) dispose
diff --git a/src/Quasar/Old/UnmanagedAsync.hs b/src/Quasar/Old/UnmanagedAsync.hs
deleted file mode 100644
index 1b1254c..0000000
--- a/src/Quasar/Old/UnmanagedAsync.hs
+++ /dev/null
@@ -1,133 +0,0 @@
-module Quasar.Old.UnmanagedAsync (
- -- ** Unmanaged variant
- Async,
- unmanagedAsync,
- unmanagedAsyncWithHandler,
- unmanagedAsyncWithUnmask,
- unmanagedAsyncWithHandlerAndUnmask,
-
- -- ** Async exceptions
- CancelAsync(..),
- AsyncDisposed(..),
- AsyncException(..),
- isCancelAsync,
- isAsyncDisposed,
-) where
-
-
-import Control.Concurrent (ThreadId, forkIO, forkIOWithUnmask, throwTo)
-import Control.Concurrent.STM
-import Control.Monad.Catch
-import Quasar.Exceptions
-import Quasar.Awaitable
-import Quasar.Disposable
-import Quasar.Prelude
-
-
--- | A async is an asynchronously running computation that can be cancelled.
---
--- The result (or exception) can be aquired by using the `IsAwaitable` class (e.g. by calling `await` or `awaitIO`).
--- It is possible to cancel the async by using `dispose` if the operation has not been completed.
-data Async r = Async Unique (TVar AsyncState) DisposableFinalizers (Awaitable r)
-
-data AsyncState = AsyncStateInitializing | AsyncStateRunning ThreadId | AsyncStateThrowing | AsyncStateCompleted
-
-instance IsAwaitable r (Async r) where
- toAwaitable (Async _ _ _ resultAwaitable) = resultAwaitable
-
-instance IsDisposable (Async r) where
- beginDispose self@(Async key stateVar _ _) = uninterruptibleMask_ do
- join $ atomically do
- readTVar stateVar >>= \case
- AsyncStateInitializing -> unreachableCodePathM
- AsyncStateRunning threadId -> do
- writeTVar stateVar AsyncStateThrowing
- -- Fork to prevent synchronous exceptions when disposing this thread, and to prevent blocking when disposing
- -- a thread that is running in uninterruptible masked state.
- pure $ void $ forkIO do
- throwTo threadId $ CancelAsync key
- atomically $ writeTVar stateVar AsyncStateCompleted
- AsyncStateThrowing -> pure $ pure @IO ()
- AsyncStateCompleted -> pure $ pure @IO ()
-
- -- Wait for async completion or failure. Asyncs must not ignore `CancelAsync` or this will hang.
- pure $ DisposeResultAwait $ isDisposed self
-
- isDisposed (Async _ _ _ resultAwaitable) = awaitSuccessOrFailure resultAwaitable
-
- registerFinalizer (Async _ _ finalizers _) = defaultRegisterFinalizer finalizers
-
-instance Functor Async where
- fmap fn (Async key actionVar finalizerVar resultAwaitable) = Async key actionVar finalizerVar (fn <$> resultAwaitable)
-
-
-
--- | Base implementation for the `unmanagedAsync`- and `Quasar.Async.async`-class of functions.
-unmanagedAsyncWithHandlerAndUnmask :: MonadIO m => (SomeException -> IO ()) -> ((forall b. IO b -> IO b) -> IO a) -> m (Async a)
-unmanagedAsyncWithHandlerAndUnmask handler action = do
- liftIO $ mask_ do
- key <- newUnique
- resultVar <- newAsyncVar
- stateVar <- newTVarIO AsyncStateInitializing
- finalizers <- newDisposableFinalizers
-
- threadId <- forkIOWithUnmask \unmask ->
- handleAll
- do \ex -> fail $ "coreAsyncImplementation thread failed: " <> displayException ex
- do
- result <- try $ catchAll
- do action unmask
- \ex -> do
- -- Rewrite exception if its the cancel exception for this async
- when (fromException ex == Just (CancelAsync key)) $ throwIO AsyncDisposed
- throwIO $ AsyncException ex
-
- -- The `action` has completed its work.
- -- "disarm" dispose:
- catchIf
- do \(CancelAsync exKey) -> key == exKey
- do
- atomically $ readTVar stateVar >>= \case
- AsyncStateInitializing -> retry
- AsyncStateRunning _ -> writeTVar stateVar AsyncStateCompleted
- AsyncStateThrowing -> retry -- Could not disarm so we have to wait for the exception to arrive
- AsyncStateCompleted -> pure ()
- do mempty -- ignore exception if it matches; this can only happen once (see AsyncStateThrowing above)
-
- catchAll
- case result of
- Left (fromException -> Just AsyncDisposed) -> pure ()
- Left (fromException -> Just (AsyncException ex)) -> handler ex
- -- Impossible code path reached
- Left ex -> traceIO $ "Error in unmanagedAsyncWithHandlerAndUnmask: " <> displayException ex
- _ -> pure ()
- \ex -> traceIO $ "An exception was thrown while handling an async exception: " <> displayException ex
-
- atomically do
- putAsyncVarEitherSTM_ resultVar result
- defaultRunFinalizers finalizers
-
- atomically $ writeTVar stateVar $ AsyncStateRunning threadId
-
- pure $ Async key stateVar finalizers (toAwaitable resultVar)
-
-
-unmanagedAsync :: MonadIO m => IO a -> m (Async a)
-unmanagedAsync action = unmanagedAsyncWithUnmask \unmask -> unmask action
-
-unmanagedAsyncWithHandler :: MonadIO m => (SomeException -> IO ()) -> IO a -> m (Async a)
-unmanagedAsyncWithHandler handler action = unmanagedAsyncWithHandlerAndUnmask handler \unmask -> unmask action
-
-unmanagedAsyncWithUnmask :: MonadIO m => ((forall b. IO b -> IO b) -> IO a) -> m (Async a)
-unmanagedAsyncWithUnmask = unmanagedAsyncWithHandlerAndUnmask (traceIO . ("Unhandled exception in unmanaged async: " <>) . displayException)
-
-
--- | Run a computation concurrently to another computation. When the current thread leaves `withAsync`, the async
--- computation is cancelled.
---
--- While the async is disposed when `withUnmanagedAsync` exits, an exception would be ignored if the action fails. This
--- behavior is similar to the @withAsync@ function from the @async@ package.
---
--- For an exception-safe version, see `Quasar.Async.withAsync`.
-withUnmanagedAsync :: (MonadIO m, MonadMask m) => IO r -> (Async r -> m a) -> m a
-withUnmanagedAsync action = bracket (unmanagedAsync action) dispose
diff --git a/src/Quasar/ResourceManager.hs b/src/Quasar/ResourceManager.hs
deleted file mode 100644
index 7bf218d..0000000
--- a/src/Quasar/ResourceManager.hs
+++ /dev/null
@@ -1,628 +0,0 @@
-module Quasar.ResourceManager (
- -- * MonadResourceManager
- MonadResourceManager(..),
- ResourceManagerT,
- ResourceManagerIO,
- ResourceManagerSTM,
- FailedToRegisterResource,
- attachDisposable,
- registerNewResource,
- registerNewResource_,
- registerDisposable,
- registerDisposeAction,
- registerAsyncDisposeAction,
- throwToResourceManager,
- withScopedResourceManager,
- onResourceManager,
- onResourceManagerSTM,
- captureDisposable,
- captureDisposable_,
- disposeOnError,
- liftResourceManagerIO,
- runInResourceManagerSTM,
- enterResourceManager,
- enterResourceManagerSTM,
- newUniqueRM,
-
- -- ** Top level initialization
- withRootResourceManager,
-
- -- ** ResourceManager
- IsResourceManager(..),
- ResourceManager,
- newResourceManager,
- newResourceManagerSTM,
- attachDisposeAction,
- attachDisposeAction_,
-
- -- ** Linking computations to a resource manager
- linkExecution,
- CancelLinkedExecution,
-
- -- * Reexports
- CombinedException,
- combinedExceptions,
-) where
-
-
-import Control.Concurrent (ThreadId, forkIO, myThreadId, throwTo, threadDelay)
-import Control.Concurrent.STM
-import Control.Monad.Catch
-import Control.Monad.Reader
-import Data.Foldable (toList)
-import Data.HashMap.Strict (HashMap)
-import Data.HashMap.Strict qualified as HM
-import Data.List.NonEmpty ((<|), nonEmpty)
-import Data.Sequence (Seq(..), (|>))
-import Data.Sequence qualified as Seq
-import Quasar.Awaitable
-import Quasar.Disposable
-import Quasar.Exceptions
-import Quasar.Old.UnmanagedAsync
-import Quasar.Prelude
-import Quasar.Utils.Exceptions
-
-
-data FailedToRegisterResource = FailedToRegisterResource
- deriving stock (Eq, Show)
-
-instance Exception FailedToRegisterResource where
- displayException FailedToRegisterResource =
- "FailedToRegisterResource: Failed to register a resource to a resource manager. This might result in leaked resources if left unhandled."
-
-data FailedToLockResourceManager = FailedToLockResourceManager
- deriving stock (Eq, Show)
-
-instance Exception FailedToLockResourceManager where
- displayException FailedToLockResourceManager =
- "FailedToLockResourceManager: Failed to lock a resource manager."
-
--- TODO HasResourceManager, getResourceManager
-class IsDisposable a => IsResourceManager a where
- toResourceManager :: a -> ResourceManager
-
-
-class MonadFix m => MonadResourceManager m where
- -- | Get the underlying resource manager.
- askResourceManager :: m ResourceManager
-
- -- | Replace the resource manager for a computation.
- localResourceManager :: IsResourceManager a => a -> m r -> m r
-
- -- | Locks the resource manager. As long as the resource manager is locked, it's possible to register new resources
- -- on the resource manager.
- --
- -- This prevents the resource manager from disposing, so the computation must not block for an unbound amount of time.
- lockResourceManager :: MonadResourceManager m => m a -> m a
-
- -- | Run an `STM` computation. Depending on the monad this may be run in a dedicated STM transaction or may be
- -- embedded in a larger transaction.
- runInSTM :: MonadResourceManager m => STM a -> m a
-
- maskIfRequired :: MonadResourceManager m => m a -> m a
-
-
--- | Forward an exception that happened asynchronously.
-throwToResourceManager :: (Exception e, MonadResourceManager m) => e -> m ()
-throwToResourceManager ex = do
- resourceManager <- askResourceManager
- runInSTM $ throwToResourceManagerImpl resourceManager (toException ex)
-
-
-runInResourceManagerSTM :: MonadResourceManager m => ResourceManagerSTM a -> m a
-runInResourceManagerSTM action = do
- resourceManager <- askResourceManager
- runInSTM $ runReaderT action resourceManager
-
--- | Register a `Disposable` to the resource manager.
---
--- May throw an `FailedToRegisterResource` if the resource manager is disposing/disposed.
-registerDisposable :: (IsDisposable a, MonadResourceManager m) => a -> m ()
-registerDisposable disposable = do
- resourceManager <- askResourceManager
- runInSTM $ attachDisposable resourceManager disposable
-
-
-registerDisposeAction :: MonadResourceManager m => IO () -> m ()
-registerDisposeAction disposeAction = runInResourceManagerSTM do
- disposable <- lift (newDisposable disposeAction)
- registerDisposable disposable
-
-registerAsyncDisposeAction :: MonadResourceManager m => IO () -> m ()
-registerAsyncDisposeAction disposeAction = runInResourceManagerSTM do
- disposable <- lift (newAsyncDisposable disposeAction)
- registerDisposable disposable
-
--- | Locks the resource manager (which may fail), runs the computation and registeres the resulting disposable.
---
--- The computation will be run in masked state (if not running atomically in `STM`).
---
--- The computation must not block for an unbound amount of time.
-registerNewResource :: (IsDisposable a, MonadResourceManager m) => m a -> m a
-registerNewResource action = maskIfRequired $ lockResourceManager do
- resource <- action
- registerDisposable resource
- pure resource
-
-registerNewResource_ :: (IsDisposable a, MonadResourceManager m) => m a -> m ()
-registerNewResource_ action = void $ registerNewResource action
-
-withScopedResourceManager :: (MonadResourceManager m, MonadIO m, MonadMask m) => m a -> m a
-withScopedResourceManager action =
- bracket newResourceManager dispose \scope -> localResourceManager scope action
-
-
-type ResourceManagerT = ReaderT ResourceManager
-type ResourceManagerIO = ResourceManagerT IO
-type ResourceManagerSTM = ResourceManagerT STM
-
-instance (MonadAwait m, MonadMask m, MonadIO m, MonadFix m) => MonadResourceManager (ResourceManagerT m) where
- localResourceManager resourceManager = local (const (toResourceManager resourceManager))
-
- askResourceManager = ask
-
- lockResourceManager action = do
- resourceManager <- askResourceManager
- lockResourceManagerImpl resourceManager action
-
- runInSTM action = liftIO $ atomically action
-
- maskIfRequired = mask_
-
-
--- Overlaps the ResourceManagerT/MonadIO-instance, because `MonadIO` _could_ be specified for `STM` (but that would be
--- _very_ incorrect, so this is safe).
-instance {-# OVERLAPS #-} MonadResourceManager (ResourceManagerT STM) where
- localResourceManager resourceManager = local (const (toResourceManager resourceManager))
-
- askResourceManager = ask
-
- -- | No-op, since STM is always executed atomically.
- lockResourceManager = id
-
- runInSTM action = lift action
-
- maskIfRequired = id
-
-
-instance {-# OVERLAPPABLE #-} MonadResourceManager m => MonadResourceManager (ReaderT r m) where
- askResourceManager = lift askResourceManager
-
- localResourceManager resourceManager action = do
- x <- ask
- lift $ localResourceManager resourceManager $ runReaderT action x
-
- lockResourceManager action = do
- x <- ask
- lift $ lockResourceManager $ runReaderT action x
-
- runInSTM action = lift $ runInSTM action
-
- maskIfRequired action = do
- x <- ask
- lift $ maskIfRequired $ runReaderT action x
-
--- TODO MonadResourceManager instances for StateT, WriterT, RWST, MaybeT, ...
-
-
-onResourceManager :: (IsResourceManager a, MonadIO m) => a -> ResourceManagerIO r -> m r
-onResourceManager target action = liftIO $ runReaderT action (toResourceManager target)
-
-onResourceManagerSTM :: (IsResourceManager a) => a -> ResourceManagerSTM r -> STM r
-onResourceManagerSTM target action = runReaderT action (toResourceManager target)
-
-liftResourceManagerIO :: (MonadResourceManager m, MonadIO m) => ResourceManagerIO r -> m r
-liftResourceManagerIO action = do
- resourceManager <- askResourceManager
- onResourceManager resourceManager action
-
-
-captureDisposable :: MonadResourceManager m => m a -> m (a, Disposable)
-captureDisposable action = do
- resourceManager <- newResourceManager
- result <- localResourceManager resourceManager action
- pure (result, toDisposable resourceManager)
-
-captureDisposable_ :: MonadResourceManager m => m () -> m Disposable
-captureDisposable_ = snd <<$>> captureDisposable
-
--- | Disposes all resources created by the computation if the computation throws an exception.
-disposeOnError :: (MonadResourceManager m, MonadIO m, MonadMask m) => m a -> m a
-disposeOnError action = do
- bracketOnError
- newResourceManager
- dispose
- \resourceManager -> localResourceManager resourceManager action
-
--- | Run a computation on a resource manager and throw any exception that occurs to the resource manager.
---
--- This can be used to run e.g. callbacks that belong to a different resource context.
---
--- Locks the resource manager, so the computation must not block for an unbounded time.
---
--- May throw an exception when the resource manager is disposing.
-enterResourceManager :: MonadIO m => ResourceManager -> ResourceManagerIO () -> m ()
-enterResourceManager resourceManager action = liftIO do
- onResourceManager resourceManager $ lockResourceManager do
- action `catchAll` \ex -> throwToResourceManager ex
-
--- | Run a computation on a resource manager and throw any exception that occurs to the resource manager.
---
--- This can be used to run e.g. callbacks that belong to a different resource context.
-enterResourceManagerSTM :: ResourceManager -> ResourceManagerSTM () -> STM ()
-enterResourceManagerSTM resourceManager action = do
- onResourceManagerSTM resourceManager do
- action `catchAll` \ex -> throwToResourceManager ex
-
-
--- | Create a new `Unique` in a `MonadResourceManager` monad.
-newUniqueRM :: MonadResourceManager m => m Unique
-newUniqueRM = runInSTM newUniqueSTM
-
-
-
--- * Resource manager implementations
-
--- ** Root resource manager
-
-data ResourceManager
- = NormalResourceManager ResourceManagerCore ResourceManager
- | RootResourceManager ResourceManagerCore (TVar Bool) (TMVar (Seq SomeException)) (AsyncVar [SomeException])
-
-
-instance IsResourceManager ResourceManager where
- toResourceManager = id
-
-resourceManagerCore :: ResourceManager -> ResourceManagerCore
-resourceManagerCore (RootResourceManager core _ _ _) = core
-resourceManagerCore (NormalResourceManager core _) = core
-
-throwToResourceManagerImpl :: ResourceManager -> SomeException -> STM ()
-throwToResourceManagerImpl (NormalResourceManager _ exceptionManager) ex = throwToResourceManagerImpl exceptionManager ex
-throwToResourceManagerImpl (RootResourceManager _ _ exceptionsVar _) ex = do
- tryTakeTMVar exceptionsVar >>= \case
- Just exceptions -> do
- putTMVar exceptionsVar (exceptions |> toException ex)
- Nothing -> do
- throwM $ userError "Could not throw to resource manager: RootResourceManager is already disposed"
-
-
-
-instance IsDisposable ResourceManager where
- beginDispose (NormalResourceManager core _) = beginDispose core
- beginDispose (RootResourceManager internal disposingVar _ _) = do
- defaultResourceManagerDisposeResult internal <$ atomically do
- disposing <- readTVar disposingVar
- unless disposing $ writeTVar disposingVar True
-
- isDisposed (resourceManagerCore -> core) = isDisposed core
-
- registerFinalizer (resourceManagerCore -> core) = registerFinalizer core
-
-newUnmanagedRootResourceManagerInternal :: MonadIO m => m ResourceManager
-newUnmanagedRootResourceManagerInternal = liftIO do
- disposingVar <- newTVarIO False
- exceptionsVar <- newTMVarIO Empty
- finalExceptionsVar <- newAsyncVar
- mfix \root -> do
- void $ forkIO (disposeWorker root)
- internal <- atomically $ newUnmanagedDefaultResourceManagerInternal (throwToResourceManagerImpl root)
- pure $ RootResourceManager internal disposingVar exceptionsVar finalExceptionsVar
- where
- disposeWorker :: ResourceManager -> IO ()
- disposeWorker (NormalResourceManager _ _) = unreachableCodePathM
- disposeWorker (RootResourceManager internal disposingVar exceptionsVar finalExceptionsVar) =
- handleAll
- do \ex -> fail $ "RootResourceManager thread failed unexpectedly: " <> displayException ex
- do
- -- Wait until disposing
- atomically do
- disposing <- readTVar disposingVar
- hasExceptions <- not . Seq.null <$> readTMVar exceptionsVar
- check $ disposing || hasExceptions
-
- -- Start a thread to report exceptions (or a potential hang) after a timeout
- reportThread <- unmanagedAsync reportTimeout
-
- -- Dispose resources
- dispose internal
-
- atomically do
- -- The var is set to `Nothing` to signal that no more exceptions can be received
- exceptions <- takeTMVar exceptionsVar
-
- putAsyncVarSTM_ finalExceptionsVar $ toList exceptions
-
- -- Clean up timeout/report thread
- dispose reportThread
-
- where
- timeoutSeconds :: Int
- timeoutSeconds = 5
- timeoutMicroseconds :: Int
- timeoutMicroseconds = timeoutSeconds * 1_000_000
-
- reportTimeout :: IO ()
- reportTimeout = do
- threadDelay timeoutMicroseconds
- atomically (tryReadTMVar exceptionsVar) >>= \case
- Nothing -> pure () -- Terminate
- Just Empty -> do
- traceIO $ mconcat ["Root resource manager did not dispose within ", show timeoutSeconds, " seconds"]
- reportExceptions 0 Empty
- Just exs -> do
- traceIO $ mconcat [ "Root resource manager did not dispose within ",
- show timeoutSeconds, " seconds (", show (length exs), " exception(s) queued)" ]
- reportExceptions 0 exs
-
- reportExceptions :: Int -> Seq SomeException -> IO ()
- reportExceptions alreadyReported Empty = join $ atomically do
- Seq.drop alreadyReported <<$>> tryReadTMVar exceptionsVar >>= \case
- Nothing -> pure $ pure () -- Terminate
- Just Empty -> retry
- Just exs -> pure $ reportExceptions alreadyReported exs
- reportExceptions alreadyReported (ex :<| exs) = do
- traceIO $ "Exception thrown to blocked root resource manager: " <> displayException ex
- reportExceptions (alreadyReported + 1) exs
-
-
-withRootResourceManager :: MonadIO m => ResourceManagerIO a -> m a
-withRootResourceManager action = liftIO $ uninterruptibleMask \unmask -> do
- resourceManager@(RootResourceManager _ _ _ finalExceptionsVar) <- newUnmanagedRootResourceManagerInternal
-
- result <- try $ unmask $ onResourceManager resourceManager action
-
- disposeEventually_ resourceManager
- exceptions <- await finalExceptionsVar
-
- case result of
- Left (ex :: SomeException) -> maybe (throwM ex) (throwM . CombinedException . (ex <|)) (nonEmpty exceptions)
- Right result' -> maybe (pure result') (throwM . CombinedException) $ nonEmpty exceptions
-
-
--- ** Default resource manager
-
-data ResourceManagerCore = ResourceManagerCore {
- resourceManagerKey :: Unique,
- throwToHandler :: SomeException -> STM (),
- stateVar :: TVar ResourceManagerState,
- disposablesVar :: TMVar (HashMap Unique Disposable),
- lockVar :: TVar Word64,
- resultVar :: AsyncVar (Awaitable [ResourceManagerResult]),
- finalizers :: DisposableFinalizers
-}
-
-data ResourceManagerState
- = ResourceManagerNormal
- | ResourceManagerDisposing
- | ResourceManagerDisposed
-
-
--- | Attaches an `Disposable` to a ResourceManager. It will automatically be disposed when the resource manager is disposed.
---
--- May throw an `FailedToRegisterResource` if the resource manager is disposing/disposed.
-attachDisposable :: (IsResourceManager a, IsDisposable b) => a -> b -> STM ()
-attachDisposable rm disposable = attachDisposableImpl (resourceManagerCore (toResourceManager rm)) (toDisposable disposable)
-
-attachDisposableImpl :: ResourceManagerCore -> Disposable -> STM ()
-attachDisposableImpl ResourceManagerCore{stateVar, disposablesVar} disposable = do
- key <- newUniqueSTM
- state <- readTVar stateVar
- case state of
- ResourceManagerNormal -> do
- disposables <- takeTMVar disposablesVar
- putTMVar disposablesVar (HM.insert key disposable disposables)
- void $ registerFinalizer disposable (finalizer key)
- _ -> throwM FailedToRegisterResource
- where
- finalizer :: Unique -> STM ()
- finalizer key =
- tryTakeTMVar disposablesVar >>= \case
- Just disposables ->
- putTMVar disposablesVar $ HM.delete key disposables
- Nothing -> pure ()
-
-lockResourceManagerImpl :: (MonadIO m, MonadMask m) => ResourceManager -> m b -> m b
-lockResourceManagerImpl (resourceManagerCore -> ResourceManagerCore{stateVar, lockVar}) =
- bracket_ (liftIO aquire) (liftIO release)
- where
- aquire :: IO ()
- aquire = atomically do
- readTVar stateVar >>= \case
- ResourceManagerNormal -> pure ()
- _ -> throwM FailedToLockResourceManager
- modifyTVar lockVar (+ 1)
- release :: IO ()
- release = atomically (modifyTVar lockVar (\x -> x - 1))
-
-instance IsDisposable ResourceManagerCore where
- beginDispose self@ResourceManagerCore{resourceManagerKey, throwToHandler, stateVar, disposablesVar, lockVar, resultVar, finalizers} = liftIO do
- uninterruptibleMask_ do
- join $ atomically do
- state <- readTVar stateVar
- case state of
- ResourceManagerNormal -> do
- writeTVar stateVar ResourceManagerDisposing
- readTVar lockVar >>= \case
- 0 -> do
- disposables <- takeDisposables
- pure (primaryBeginDispose disposables)
- _ -> pure primaryForkDisposeThread
- ResourceManagerDisposing -> pure $ pure $ defaultResourceManagerDisposeResult self
- ResourceManagerDisposed -> pure $ pure DisposeResultDisposed
- where
- primaryForkDisposeThread :: IO DisposeResult
- primaryForkDisposeThread = forkDisposeThread do
- disposables <- atomically do
- check =<< (== 0) <$> readTVar lockVar
- takeDisposables
- void $ primaryBeginDispose disposables
-
- -- Only one thread enters this function (in uninterruptible masked state)
- primaryBeginDispose :: [Disposable] -> IO DisposeResult
- primaryBeginDispose disposables = do
- (reportExceptionActions, resultAwaitables) <- unzip <$> mapM beginDisposeEntry disposables
- -- TODO cache was removed, has to be re-optimized later
- let cachedResultAwaitable = mconcat resultAwaitables
- putAsyncVar_ resultVar cachedResultAwaitable
-
- let
- isCompletedAwaitable :: Awaitable ()
- isCompletedAwaitable = awaitResourceManagerResult $ ResourceManagerResult resourceManagerKey cachedResultAwaitable
-
- alreadyCompleted <- isJust <$> peekAwaitable isCompletedAwaitable
- if alreadyCompleted
- then do
- completeDisposing
- pure DisposeResultDisposed
- else do
- -- Start thread to collect exceptions, await completion and run finalizers
- forkDisposeThread do
- -- Collect exceptions from directly attached disposables
- sequence_ reportExceptionActions
- -- Await completion attached resource managers
- await isCompletedAwaitable
-
- completeDisposing
-
- forkDisposeThread :: IO () -> IO DisposeResult
- forkDisposeThread action = do
- defaultResourceManagerDisposeResult self <$ forkIO do
- catchAll
- action
- \ex ->
- atomically $ throwToHandler $ toException $
- userError ("Dispose thread failed for ResourceManager: " <> displayException ex)
-
- takeDisposables :: STM [Disposable]
- takeDisposables = toList <$> takeTMVar disposablesVar
-
- beginDisposeEntry :: Disposable -> IO (IO (), (Awaitable [ResourceManagerResult]))
- beginDisposeEntry disposable =
- catchAll
- do
- result <- beginDispose disposable
- pure case result of
- DisposeResultDisposed -> (pure (), pure [])
- -- Moves error reporting from the awaitable to the finalizer thread
- DisposeResultAwait awaitable -> (processDisposeException awaitable, [] <$ awaitSuccessOrFailure awaitable)
- DisposeResultResourceManager resourceManagerResult -> (pure (), pure [resourceManagerResult])
- \ex -> do
- atomically $ throwToHandler $ toException $ DisposeException ex
- pure (pure (), pure [])
-
- processDisposeException :: Awaitable () -> IO ()
- processDisposeException awaitable =
- await awaitable
- `catchAll`
- \ex -> atomically $ throwToHandler $ toException $ DisposeException ex
-
- completeDisposing :: IO ()
- completeDisposing =
- atomically do
- writeTVar stateVar $ ResourceManagerDisposed
- defaultRunFinalizers finalizers
-
- isDisposed ResourceManagerCore{stateVar} =
- unsafeAwaitSTM do
- disposed <- stateIsDisposed <$> readTVar stateVar
- check disposed
- where
- stateIsDisposed :: ResourceManagerState -> Bool
- stateIsDisposed ResourceManagerDisposed = True
- stateIsDisposed _ = False
-
- registerFinalizer ResourceManagerCore{finalizers} = defaultRegisterFinalizer finalizers
-
-defaultResourceManagerDisposeResult :: ResourceManagerCore -> DisposeResult
-defaultResourceManagerDisposeResult ResourceManagerCore{resourceManagerKey, resultVar} =
- DisposeResultResourceManager $ ResourceManagerResult resourceManagerKey $ join $ toAwaitable resultVar
-
--- | Internal constructor. The resulting resource manager core is indirectly attached to it's parent by it's exception
--- handler.
-newUnmanagedDefaultResourceManagerInternal :: (SomeException -> STM ()) -> STM ResourceManagerCore
-newUnmanagedDefaultResourceManagerInternal throwToHandler = do
- resourceManagerKey <- newUniqueSTM
- stateVar <- newTVar ResourceManagerNormal
- disposablesVar <- newTMVar HM.empty
- lockVar <- newTVar 0
- finalizers <- newDisposableFinalizersSTM
- resultVar <- newAsyncVarSTM
-
- pure ResourceManagerCore {
- resourceManagerKey,
- throwToHandler,
- stateVar,
- disposablesVar,
- lockVar,
- finalizers,
- resultVar
- }
-
-newResourceManager :: MonadResourceManager m => m ResourceManager
-newResourceManager = do
- parent <- askResourceManager
- runInSTM $ newResourceManagerSTM parent
-
-newResourceManagerSTM :: ResourceManager -> STM ResourceManager
-newResourceManagerSTM parent = do
- -- Bind core exception handler to parent to tie exception handling to the parent
- resourceManager <- newUnmanagedDefaultResourceManagerInternal (throwToResourceManagerImpl parent)
- -- Attach disposable to parent to tie resource management to the parent
- attachDisposable parent resourceManager
- pure $ NormalResourceManager resourceManager parent
-
-
--- * Utilities
-
--- | Creates an `Disposable` that is bound to a ResourceManager. It will automatically be disposed when the resource manager is disposed.
-attachDisposeAction :: ResourceManager -> IO () -> STM Disposable
-attachDisposeAction resourceManager action = do
- disposable <- newDisposable action
- attachDisposable resourceManager disposable
- pure disposable
-
--- | Attaches a dispose action to a ResourceManager. It will automatically be run when the resource manager is disposed.
-attachDisposeAction_ :: ResourceManager -> IO () -> STM ()
-attachDisposeAction_ resourceManager action = void $ attachDisposeAction resourceManager action
-
-
--- ** Link execution to resource manager
-
--- | A computation bound to a resource manager with 'linkThread' should be canceled.
-data CancelLinkedExecution = CancelLinkedExecution Unique
- deriving anyclass Exception
-
-instance Show CancelLinkedExecution where
- show _ = "CancelLinkedExecution"
-
-
-data LinkState = LinkStateLinked ThreadId | LinkStateThrowing | LinkStateCompleted
- deriving stock Eq
-
-
--- | Links the execution of a computation to a resource manager.
---
--- The computation is executed on the current thread. When the resource manager is disposed before the computation
--- is completed, a `CancelLinkedExecution`-exception is thrown to the current thread.
-linkExecution :: (MonadResourceManager m, MonadIO m, MonadMask m) => m a -> m (Maybe a)
-linkExecution action = do
- key <- liftIO $ newUnique
- var <- liftIO $ newTVarIO =<< LinkStateLinked <$> myThreadId
- registerDisposeAction $ do
- atomically (swapTVar var LinkStateThrowing) >>= \case
- LinkStateLinked threadId -> throwTo threadId $ CancelLinkedExecution key
- LinkStateThrowing -> pure () -- Dispose called twice
- LinkStateCompleted -> pure () -- Thread has already left link
-
- catch
- do
- result <- action
- state <- liftIO $ atomically $ swapTVar var LinkStateCompleted
- when (state == LinkStateThrowing) $ sleepForever -- Wait for exception to arrive
- pure $ Just result
-
- \ex@(CancelLinkedExecution exceptionKey) ->
- if key == exceptionKey
- then return Nothing
- else throwM ex
diff --git a/test/Quasar/AsyncSpec.hs b/test/Quasar/AsyncSpec.hs
index 625e2c4..eb4374c 100644
--- a/test/Quasar/AsyncSpec.hs
+++ b/test/Quasar/AsyncSpec.hs
@@ -1,14 +1,14 @@
module Quasar.AsyncSpec (spec) where
-import Control.Concurrent
-import Control.Monad (void)
-import Control.Monad.IO.Class
+--import Control.Concurrent
+--import Control.Monad (void)
+--import Control.Monad.IO.Class
import Prelude
import Test.Hspec
--import Quasar.Async
-import Quasar.Awaitable
-import Quasar.ResourceManager
-import System.Timeout
+--import Quasar.Awaitable
+--import Quasar.ResourceManager
+--import System.Timeout
spec :: Spec
spec = describe "async" $ it "async" $ pendingWith "moving to new implementation..."
diff --git a/test/Quasar/DisposableSpec.hs b/test/Quasar/DisposableSpec.hs
deleted file mode 100644
index 087e61e..0000000
--- a/test/Quasar/DisposableSpec.hs
+++ /dev/null
@@ -1,36 +0,0 @@
-module Quasar.DisposableSpec (spec) where
-
-import Control.Concurrent
-import Control.Concurrent.STM
-import Quasar.Prelude
-import Test.Hspec
-import Quasar.Awaitable
-import Quasar.Disposable
-
-spec :: Spec
-spec = parallel $ do
- describe "Disposable" $ do
- describe "noDisposable" $ do
- it "can be disposed" $ io do
- dispose noDisposable
-
- it "can be awaited" $ io do
- await (isDisposed noDisposable)
-
- describe "newDisposable" $ do
- it "signals it's disposed state" $ io do
- disposable <- atomically $ newDisposable $ pure ()
- void $ forkIO $ threadDelay 100000 >> dispose disposable
- await (isDisposed disposable)
-
- it "can be disposed multiple times" $ io do
- disposable <- atomically $ newDisposable $ pure ()
- dispose disposable
- dispose disposable
- await (isDisposed disposable)
-
- it "can be disposed in parallel" $ do
- disposable <- atomically $ newDisposable $ threadDelay 100000
- void $ forkIO $ dispose disposable
- dispose disposable
- await (isDisposed disposable)
diff --git a/test/Quasar/Observable/ObservableHashMapSpec.hs b/test/Quasar/Observable/ObservableHashMapSpec.hs
index f3a5f35..041ac64 100644
--- a/test/Quasar/Observable/ObservableHashMapSpec.hs
+++ b/test/Quasar/Observable/ObservableHashMapSpec.hs
@@ -1,16 +1,16 @@
module Quasar.Observable.ObservableHashMapSpec (spec) where
-import Control.Monad (void)
-import Data.HashMap.Strict qualified as HM
-import Data.IORef
-import Quasar.Awaitable
-import Quasar.Disposable
-import Quasar.Observable
-import Quasar.Observable.Delta
-import Quasar.Observable.ObservableHashMap qualified as OM
+--import Control.Monad (void)
+--import Data.HashMap.Strict qualified as HM
+--import Data.IORef
+--import Quasar.Awaitable
+--import Quasar.Disposable
+--import Quasar.Observable
+--import Quasar.Observable.Delta
+--import Quasar.Observable.ObservableHashMap qualified as OM
import Quasar.Prelude
-import Quasar.ResourceManager
+--import Quasar.ResourceManager
import Test.Hspec
shouldReturnM :: (Eq a, Show a, MonadIO m) => m a -> a -> m ()
diff --git a/test/Quasar/ObservableSpec.hs b/test/Quasar/ObservableSpec.hs
index 97c0a95..38d2a61 100644
--- a/test/Quasar/ObservableSpec.hs
+++ b/test/Quasar/ObservableSpec.hs
@@ -1,10 +1,10 @@
module Quasar.ObservableSpec (spec) where
-import Data.IORef
+--import Data.IORef
import Quasar.Prelude
-import Quasar.Awaitable
-import Quasar.Observable
-import Quasar.ResourceManager
+--import Quasar.Awaitable
+--import Quasar.Observable
+--import Quasar.ResourceManager
import Test.Hspec
diff --git a/test/Quasar/ResourceManagerSpec.hs b/test/Quasar/ResourceManagerSpec.hs
deleted file mode 100644
index 1fe2530..0000000
--- a/test/Quasar/ResourceManagerSpec.hs
+++ /dev/null
@@ -1,147 +0,0 @@
-module Quasar.ResourceManagerSpec (spec) where
-
-import Control.Concurrent
-import Control.Concurrent.STM
-import Control.Exception
-import Control.Monad.Catch
-import Quasar.Prelude
-import Test.Hspec
-import Quasar.Awaitable
-import Quasar.Disposable
-import Quasar.ResourceManager
-
-data TestException = TestException
- deriving stock (Eq, Show)
-
-instance Exception TestException
-
-spec :: Spec
-spec = parallel $ do
- describe "ResourceManager" $ do
- it "can be created" $ io do
- withRootResourceManager $ pure ()
-
- it "can be created and disposed" $ io do
- withRootResourceManager do
- resourceManager <- askResourceManager
- disposeEventually_ resourceManager
-
- it "is disposed when exiting withRootResourceManager" $ io do
- resourceManager <- withRootResourceManager askResourceManager
-
- peekAwaitable (isDisposed resourceManager) `shouldReturn` Just ()
-
- it "can be created and disposed with a delay" $ io do
- withRootResourceManager $ liftIO $ threadDelay 100000
-
- it "can \"dispose\" a noDisposable" $ io do
- withRootResourceManager do
- registerDisposable noDisposable
-
- it "can attach a dispose action" $ io do
- var <- newTVarIO False
- withRootResourceManager do
- registerDisposeAction $ atomically $ writeTVar var True
-
- atomically (readTVar var) `shouldReturn` True
-
- it "can attach a slow dispose action" $ io do
- withRootResourceManager do
- registerDisposeAction $ threadDelay 100000
-
- it "re-throws an exception" $ do
- shouldThrow
- do
- withRootResourceManager do
- liftIO $ throwIO TestException
- \TestException -> True
-
- it "handles an exception while disposing" $ io do
- (`shouldThrow` \(_ :: CombinedException) -> True) do
- withRootResourceManager do
- registerDisposeAction $ throwIO TestException
- liftIO $ threadDelay 100000
-
- it "passes an exception to the root resource manager" $ io do
- (`shouldThrow` \(_ :: CombinedException) -> True) do
- withRootResourceManager do
- withScopedResourceManager do
- registerDisposeAction $ throwIO TestException
- liftIO $ threadDelay 100000
-
- it "passes an exception to the root resource manager when closing the inner resource manager first" $ io do
- (`shouldThrow` \(_ :: CombinedException) -> True) do
- withRootResourceManager do
- withScopedResourceManager do
- registerDisposeAction $ throwIO TestException
- liftIO $ threadDelay 100000
-
- it "can attach an disposable that is disposed asynchronously" $ io do
- withRootResourceManager do
- disposable <- captureDisposable_ $ registerDisposeAction $ threadDelay 100000
- liftIO $ void $ forkIO $ dispose disposable
-
- it "does not abort disposing when encountering an exception" $ do
- var1 <- newTVarIO False
- var2 <- newTVarIO False
- (`shouldThrow` \(_ :: CombinedException) -> True) do
- withRootResourceManager do
- registerDisposeAction $ atomically (writeTVar var1 True)
- registerDisposeAction $ throwIO TestException
- registerDisposeAction $ atomically (writeTVar var2 True)
- atomically (readTVar var1) `shouldReturn` True
- atomically (readTVar var2) `shouldReturn` True
-
- it "withRootResourceManager will start disposing when receiving an exception" $ io do
- (`shouldThrow` \(_ :: CombinedException) -> True) do
- withRootResourceManager do
- linkExecution do
- throwToResourceManager TestException
- sleepForever
-
- it "combines exceptions from resources with exceptions on the thread" $ io do
- (`shouldThrow` \(combinedExceptions -> exceptions) -> length exceptions == 2) do
- withRootResourceManager do
- throwToResourceManager TestException
- throwM TestException
-
- it "can dispose a resource manager loop" $ io do
- withRootResourceManager do
- rm1 <- newResourceManager
- rm2 <- newResourceManager
- liftIO $ atomically do
- attachDisposable rm1 rm2
- attachDisposable rm2 rm1
-
- it "can dispose a resource manager loop" $ io do
- withRootResourceManager do
- rm1 <- newResourceManager
- rm2 <- newResourceManager
- liftIO $ atomically do
- attachDisposable rm1 rm2
- attachDisposable rm2 rm1
- dispose rm1
-
- it "can dispose a resource manager loop with a shared disposable" $ io do
- var <- newTVarIO (0 :: Int)
- d <- atomically $ newDisposable $ atomically $ modifyTVar var (+ 1)
- withRootResourceManager do
- rm1 <- newResourceManager
- rm2 <- newResourceManager
- liftIO $ atomically do
- attachDisposable rm1 rm2
- attachDisposable rm2 rm1
- attachDisposable rm1 d
- attachDisposable rm2 d
-
- atomically (readTVar var) `shouldReturn` 1
-
-
- describe "linkExecution" do
- it "does not generate an exception after it is completed" $ io do
- (`shouldThrow` \(_ :: CombinedException) -> True) do
- withRootResourceManager do
- linkExecution do
- pure ()
- throwToResourceManager TestException
- liftIO $ threadDelay 100000
diff --git a/test/Quasar/ResourcesSpec.hs b/test/Quasar/ResourcesSpec.hs
new file mode 100644
index 0000000..e25884d
--- /dev/null
+++ b/test/Quasar/ResourcesSpec.hs
@@ -0,0 +1,178 @@
+module Quasar.ResourcesSpec (spec) where
+
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Exception
+import Control.Monad.Catch
+import Quasar.Prelude
+import Test.Hspec
+import Quasar.Awaitable
+import Quasar.Resources
+import Quasar.Monad
+
+data TestException = TestException
+ deriving stock (Eq, Show)
+
+instance Exception TestException
+
+spec :: Spec
+spec = pure ()
+--spec = parallel $ do
+-- describe "ResourceManager" $ do
+-- it "can be created" $ io do
+-- withRootResourceManager $ pure ()
+--
+-- it "can be created and disposed" $ io do
+-- withRootResourceManager do
+-- resourceManager <- askResourceManager
+-- disposeEventually_ resourceManager
+--
+-- it "is disposed when exiting withRootResourceManager" $ io do
+-- resourceManager <- withRootResourceManager askResourceManager
+--
+-- peekAwaitable (isDisposed resourceManager) `shouldReturn` Just ()
+--
+-- it "can be created and disposed with a delay" $ io do
+-- withRootResourceManager $ liftIO $ threadDelay 100000
+--
+-- it "can \"dispose\" a noDisposable" $ io do
+-- withRootResourceManager do
+-- registerDisposable noDisposable
+--
+-- it "can attach a dispose action" $ io do
+-- var <- newTVarIO False
+-- withRootResourceManager do
+-- registerDisposeAction $ atomically $ writeTVar var True
+--
+-- atomically (readTVar var) `shouldReturn` True
+--
+-- it "can attach a slow dispose action" $ io do
+-- withRootResourceManager do
+-- registerDisposeAction $ threadDelay 100000
+--
+-- it "re-throws an exception" $ do
+-- shouldThrow
+-- do
+-- withRootResourceManager do
+-- liftIO $ throwIO TestException
+-- \TestException -> True
+--
+-- it "handles an exception while disposing" $ io do
+-- (`shouldThrow` \(_ :: CombinedException) -> True) do
+-- withRootResourceManager do
+-- registerDisposeAction $ throwIO TestException
+-- liftIO $ threadDelay 100000
+--
+-- it "passes an exception to the root resource manager" $ io do
+-- (`shouldThrow` \(_ :: CombinedException) -> True) do
+-- withRootResourceManager do
+-- withScopedResourceManager do
+-- registerDisposeAction $ throwIO TestException
+-- liftIO $ threadDelay 100000
+--
+-- it "passes an exception to the root resource manager when closing the inner resource manager first" $ io do
+-- (`shouldThrow` \(_ :: CombinedException) -> True) do
+-- withRootResourceManager do
+-- withScopedResourceManager do
+-- registerDisposeAction $ throwIO TestException
+-- liftIO $ threadDelay 100000
+--
+-- it "can attach an disposable that is disposed asynchronously" $ io do
+-- withRootResourceManager do
+-- disposable <- captureDisposable_ $ registerDisposeAction $ threadDelay 100000
+-- liftIO $ void $ forkIO $ dispose disposable
+--
+-- it "does not abort disposing when encountering an exception" $ do
+-- var1 <- newTVarIO False
+-- var2 <- newTVarIO False
+-- (`shouldThrow` \(_ :: CombinedException) -> True) do
+-- withRootResourceManager do
+-- registerDisposeAction $ atomically (writeTVar var1 True)
+-- registerDisposeAction $ throwIO TestException
+-- registerDisposeAction $ atomically (writeTVar var2 True)
+-- atomically (readTVar var1) `shouldReturn` True
+-- atomically (readTVar var2) `shouldReturn` True
+--
+-- it "withRootResourceManager will start disposing when receiving an exception" $ io do
+-- (`shouldThrow` \(_ :: CombinedException) -> True) do
+-- withRootResourceManager do
+-- linkExecution do
+-- throwToResourceManager TestException
+-- sleepForever
+--
+-- it "combines exceptions from resources with exceptions on the thread" $ io do
+-- (`shouldThrow` \(combinedExceptions -> exceptions) -> length exceptions == 2) do
+-- withRootResourceManager do
+-- throwToResourceManager TestException
+-- throwM TestException
+--
+-- it "can dispose a resource manager loop" $ io do
+-- withRootResourceManager do
+-- rm1 <- newResourceManager
+-- rm2 <- newResourceManager
+-- liftIO $ atomically do
+-- attachDisposable rm1 rm2
+-- attachDisposable rm2 rm1
+--
+-- it "can dispose a resource manager loop" $ io do
+-- withRootResourceManager do
+-- rm1 <- newResourceManager
+-- rm2 <- newResourceManager
+-- liftIO $ atomically do
+-- attachDisposable rm1 rm2
+-- attachDisposable rm2 rm1
+-- dispose rm1
+--
+-- it "can dispose a resource manager loop with a shared disposable" $ io do
+-- var <- newTVarIO (0 :: Int)
+-- d <- atomically $ newDisposable $ atomically $ modifyTVar var (+ 1)
+-- withRootResourceManager do
+-- rm1 <- newResourceManager
+-- rm2 <- newResourceManager
+-- liftIO $ atomically do
+-- attachDisposable rm1 rm2
+-- attachDisposable rm2 rm1
+-- attachDisposable rm1 d
+-- attachDisposable rm2 d
+--
+-- atomically (readTVar var) `shouldReturn` 1
+--
+--
+-- describe "linkExecution" do
+-- it "does not generate an exception after it is completed" $ io do
+-- (`shouldThrow` \(_ :: CombinedException) -> True) do
+-- withRootResourceManager do
+-- linkExecution do
+-- pure ()
+-- throwToResourceManager TestException
+-- liftIO $ threadDelay 100000
+
+
+-- From DisposableSpec.hs:
+--spec :: Spec
+--spec = parallel $ do
+-- describe "Disposable" $ do
+-- describe "noDisposable" $ do
+-- it "can be disposed" $ io do
+-- dispose noDisposable
+--
+-- it "can be awaited" $ io do
+-- await (isDisposed noDisposable)
+--
+-- describe "newDisposable" $ do
+-- it "signals it's disposed state" $ io do
+-- disposable <- atomically $ newDisposable $ pure ()
+-- void $ forkIO $ threadDelay 100000 >> dispose disposable
+-- await (isDisposed disposable)
+--
+-- it "can be disposed multiple times" $ io do
+-- disposable <- atomically $ newDisposable $ pure ()
+-- dispose disposable
+-- dispose disposable
+-- await (isDisposed disposable)
+--
+-- it "can be disposed in parallel" $ do
+-- disposable <- atomically $ newDisposable $ threadDelay 100000
+-- void $ forkIO $ dispose disposable
+-- dispose disposable
+-- await (isDisposed disposable)
--
GitLab