Add dedicated exceptions for linked resource manager threads

Co-authored-by: Jan Beinke <git@janbeinke.com>

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

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)
 

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
 

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
 
 
 

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

test/Quasar/ResourceManagerSpec.hs

+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