diff --git a/quasar.cabal b/quasar.cabal
index ddd224566a0ab1b3f24b1c0ac654a2d155952d55..e0c9da8fda0f6cfea2faa5c847b6f5c98fea961d 100644
--- a/quasar.cabal
+++ b/quasar.cabal
@@ -117,6 +117,7 @@ test-suite quasar-test
Quasar.ObservableSpec
Quasar.Observable.ObservableHashMapSpec
Quasar.Observable.ObservablePrioritySpec
+ Quasar.ResourceManagerSpec
Quasar.SubscribableSpec
hs-source-dirs:
test
diff --git a/src/Quasar/Disposable.hs b/src/Quasar/Disposable.hs
index 8a6e3d42d4aa4921aba4d8658266c948a446edbf..3e0329e2bd3a2397fe629daa186db7b6f3336fa4 100644
--- a/src/Quasar/Disposable.hs
+++ b/src/Quasar/Disposable.hs
@@ -47,6 +47,7 @@ class IsDisposable a where
{-# MINIMAL toDisposable | (dispose, isDisposed) #-}
+-- TODO remove
disposeAndAwait :: (MonadAwait m, MonadIO m) => IsDisposable a => a -> m ()
disposeAndAwait disposable = await =<< liftIO (dispose disposable)
diff --git a/src/Quasar/Observable.hs b/src/Quasar/Observable.hs
index 16a44afd267203dd49cecec736e1aadf7e91e9be..cac15b30db5dcf1f9d94969832e3d17cbbf904d7 100644
--- a/src/Quasar/Observable.hs
+++ b/src/Quasar/Observable.hs
@@ -76,6 +76,7 @@ toObservableUpdate (ObservableNotAvailable ex) = throwM ex
class IsRetrievable v a | a -> v where
retrieve :: MonadResourceManager m => a -> m (Awaitable v)
+-- TODO remove
retrieveIO :: IsRetrievable v a => a -> IO v
retrieveIO x = withResourceManagerM $ await =<< retrieve x
diff --git a/src/Quasar/ResourceManager.hs b/src/Quasar/ResourceManager.hs
index 554219fb5d7833dc723d41d7a7ba2b4ae9b4fc06..7ba907b3e5b314e2773da73d8fa1fb3ebe57bfae 100644
--- a/src/Quasar/ResourceManager.hs
+++ b/src/Quasar/ResourceManager.hs
@@ -3,6 +3,7 @@ module Quasar.ResourceManager (
MonadResourceManager(..),
registerDisposable,
registerDisposeAction,
+ registerSimpleDisposeAction,
disposeEventually,
withSubResourceManagerM,
onResourceManager,
@@ -21,6 +22,9 @@ module Quasar.ResourceManager (
withRootResourceManager,
withRootResourceManagerM,
+ CancelLinkedThread(..),
+ LinkedThreadDisposed(..),
+
-- ** Resource manager implementations
newUnmanagedRootResourceManager,
--newUnmanagedDefaultResourceManager,
@@ -122,10 +126,11 @@ registerDisposable disposable = do
registerDisposeAction :: MonadResourceManager m => IO (Awaitable ()) -> m ()
registerDisposeAction disposeAction = mask_ $ registerDisposable =<< newDisposable disposeAction
-registerDisposeAction' :: MonadResourceManager m => IO () -> m ()
-registerDisposeAction' disposeAction = registerDisposeAction (pure () <$ disposeAction)
+registerSimpleDisposeAction :: MonadResourceManager m => IO () -> m ()
+registerSimpleDisposeAction disposeAction = registerDisposeAction (pure () <$ disposeAction)
+-- TODO rename to withResourceScope?
withSubResourceManagerM :: MonadResourceManager m => m a -> m a
withSubResourceManagerM action =
bracket newResourceManager (await <=< dispose) \scope -> localResourceManager scope action
@@ -173,7 +178,16 @@ captureTask action = do
type ExceptionHandler = SomeException -> IO ()
loggingExceptionHandler :: ExceptionHandler
-loggingExceptionHandler ex = hPutStrLn stderr $ displayException ex
+loggingExceptionHandler ex = traceIO $ displayException ex
+
+
+data CancelLinkedThread = CancelLinkedThread
+ deriving stock Show
+ deriving anyclass Exception
+
+data LinkedThreadDisposed = LinkedThreadDisposed
+ deriving stock Show
+ deriving anyclass Exception
data CancelHelper = CancelHelper
@@ -194,7 +208,7 @@ withLinkedExceptionHandler parentExceptionHandler action = do
do
unmask do
atomically $ check =<< readTVar shouldCancelVar
- throwTo mainThreadId CancelTask
+ throwTo mainThreadId CancelLinkedThread
`catch`
\CancelHelper -> pure ()
@@ -206,7 +220,7 @@ withLinkedExceptionHandler parentExceptionHandler action = do
do \cancelThreadId -> liftIO $ throwTo cancelThreadId CancelHelper
do \_ -> unmask $ action exceptionHandler
`catch`
- \CancelTask -> throwM TaskDisposed
+ \CancelLinkedThread -> throwM LinkedThreadDisposed
diff --git a/test/Quasar/DisposableSpec.hs b/test/Quasar/DisposableSpec.hs
index 9651659c5668ff32f45f1bcf0687c2f2c5f2d606..7ccd88545f206d2fce525cdd50304cd41f0d62b1 100644
--- a/test/Quasar/DisposableSpec.hs
+++ b/test/Quasar/DisposableSpec.hs
@@ -8,11 +8,6 @@ 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 "Disposable" $ do
@@ -40,71 +35,3 @@ spec = parallel $ do
void $ forkIO $ disposeAndAwait disposable
disposeAndAwait disposable
await (isDisposed disposable)
-
-
- describe "ResourceManager" $ do
- it "can be created" $ io do
- void newUnmanagedResourceManager
-
- it "can be created and disposed" $ io do
- resourceManager <- newUnmanagedResourceManager
- await =<< dispose resourceManager
-
- it "can be created and disposed" $ io do
- withResourceManager \_ -> pure ()
-
- it "can be created and disposed with a delay" $ do
- withResourceManager \_ -> threadDelay 100000
-
- it "can \"dispose\" a noDisposable" $ io do
- withResourceManager \resourceManager -> do
- attachDisposable resourceManager noDisposable
-
- it "can attach an disposable" $ do
- withResourceManager \resourceManager -> do
- avar <- newAsyncVar :: IO (AsyncVar ())
- attachDisposable resourceManager $ alreadyDisposing avar
- putAsyncVar_ avar ()
- pure () :: IO ()
-
- it "can dispose an awaitable that is completed asynchronously" $ do
- avar <- newAsyncVar :: IO (AsyncVar ())
- void $ forkIO $ do
- threadDelay 100000
- putAsyncVar_ avar ()
-
- withResourceManager \resourceManager -> do
- attachDisposable resourceManager (alreadyDisposing avar)
-
- it "can call a trivial dispose action" $ do
- withResourceManager \resourceManager ->
- attachDisposeAction_ resourceManager $ pure $ pure ()
- pure () :: IO ()
-
- it "can call a dispose action" $ do
- withResourceManager \resourceManager -> do
- avar <- newAsyncVar :: IO (AsyncVar ())
- attachDisposeAction_ resourceManager $ toAwaitable avar <$ putAsyncVar_ avar ()
- pure () :: IO ()
-
- it "re-throws an exception" $ do
- shouldThrow
- do
- withResourceManager \_ ->
- throwIO TestException
- \TestException -> True
-
- it "cancels the main thread when a dispose action fails" $ do
- shouldThrow
- do
- withRootResourceManagerM do
- withSubResourceManagerM do
- registerDisposeAction $ throwIO TestException
- liftIO $ threadDelay 100000
- fail "Did not stop main thread on failing dispose action"
- \TaskDisposed -> True
-
- it "can attach an disposable that is disposed asynchronously" $ do
- withResourceManager \resourceManager -> do
- disposable <- attachDisposeAction resourceManager $ pure () <$ threadDelay 100000
- void $ forkIO $ disposeAndAwait disposable
diff --git a/test/Quasar/ResourceManagerSpec.hs b/test/Quasar/ResourceManagerSpec.hs
new file mode 100644
index 0000000000000000000000000000000000000000..640fcee6ba09e5f72aa6fd4202d60206cf3eacb7
--- /dev/null
+++ b/test/Quasar/ResourceManagerSpec.hs
@@ -0,0 +1,97 @@
+module Quasar.ResourceManagerSpec (spec) where
+
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Exception
+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
+ void newUnmanagedResourceManager
+
+ it "can be created and disposed" $ io do
+ resourceManager <- newUnmanagedResourceManager
+ await =<< dispose resourceManager
+
+ it "can be created and disposed" $ io do
+ withResourceManager \_ -> pure ()
+
+ it "can be created and disposed with a delay" $ do
+ withResourceManager \_ -> threadDelay 100000
+
+ it "can \"dispose\" a noDisposable" $ io do
+ withResourceManager \resourceManager -> do
+ attachDisposable resourceManager noDisposable
+
+ it "can attach an disposable" $ do
+ withResourceManager \resourceManager -> do
+ avar <- newAsyncVar :: IO (AsyncVar ())
+ attachDisposable resourceManager $ alreadyDisposing avar
+ putAsyncVar_ avar ()
+ pure () :: IO ()
+
+ it "can dispose an awaitable that is completed asynchronously" $ do
+ avar <- newAsyncVar :: IO (AsyncVar ())
+ void $ forkIO $ do
+ threadDelay 100000
+ putAsyncVar_ avar ()
+
+ withResourceManager \resourceManager -> do
+ attachDisposable resourceManager (alreadyDisposing avar)
+
+ it "can call a trivial dispose action" $ do
+ withResourceManager \resourceManager ->
+ attachDisposeAction_ resourceManager $ pure $ pure ()
+ pure () :: IO ()
+
+ it "can call a dispose action" $ do
+ withResourceManager \resourceManager -> do
+ avar <- newAsyncVar :: IO (AsyncVar ())
+ attachDisposeAction_ resourceManager $ toAwaitable avar <$ putAsyncVar_ avar ()
+ pure () :: IO ()
+
+ it "re-throws an exception" $ do
+ shouldThrow
+ do
+ withResourceManager \_ ->
+ throwIO TestException
+ \TestException -> True
+
+ it "cancels the main thread when a dispose action fails" $ do
+ shouldThrow
+ do
+ withRootResourceManagerM do
+ withSubResourceManagerM do
+ registerDisposeAction $ throwIO TestException
+ liftIO $ threadDelay 100000
+ fail "Did not stop main thread on failing dispose action"
+ \LinkedThreadDisposed -> True
+
+ it "can attach an disposable that is disposed asynchronously" $ do
+ withResourceManager \resourceManager -> do
+ disposable <- attachDisposeAction resourceManager $ pure () <$ threadDelay 100000
+ void $ forkIO $ disposeAndAwait disposable
+
+ it "does not abort when encountering an exception" $ do
+ var1 <- newTVarIO False
+ var2 <- newTVarIO False
+ shouldThrow
+ do
+ withRootResourceManagerM do
+ registerDisposeAction $ pure () <$ (atomically (writeTVar var1 True))
+ registerDisposeAction $ pure () <$ throwIO TestException
+ registerDisposeAction $ pure () <$ (atomically (writeTVar var2 True))
+ \LinkedThreadDisposed -> True
+ atomically (readTVar var1) `shouldReturn` True
+ atomically (readTVar var2) `shouldReturn` True