quasar: Remove ExceptionSink requirement from ResourceManager

Co-authored-by: Jan Beinke <[email protected]>

quasar/src/Quasar/MonadQuasar.hs

@@ -54,7 +54,7 @@ import Quasar.Prelude
 import Quasar.Resources.Disposer
 
 
--- Invariant: the resource manager is disposed as soon as an exception is thrown to the channel
+-- Invariant: the resource manager is disposed as soon as an exception is thrown to the sink
 data Quasar = Quasar ExceptionSink ResourceManager
 
 instance Disposable Quasar where
@@ -67,14 +67,14 @@ instance HasField "resourceManager" Quasar ResourceManager where
   getField = quasarResourceManager
 
 quasarExceptionSink :: Quasar -> ExceptionSink
-quasarExceptionSink (Quasar exChan _) = exChan
+quasarExceptionSink (Quasar sink _) = sink
 
 quasarResourceManager :: Quasar -> ResourceManager
 quasarResourceManager (Quasar _ rm) = rm
 
 newResourceScopeSTM :: (MonadSTMc NoRetry '[FailedToAttachResource] m, HasCallStack) => Quasar -> m Quasar
 newResourceScopeSTM parent = do
-  rm <- newUnmanagedResourceManagerSTM parentExceptionSink
+  rm <- newUnmanagedResourceManagerSTM
   attachResource (quasarResourceManager parent) rm
   pure $ newQuasar parentExceptionSink rm
   where
@@ -262,15 +262,15 @@ quasarAtomicallyC (QuasarSTMc fn) = do
 
 redirectExceptionToSink :: (MonadCatch m, MonadQuasar m, MonadSTM m) => m a -> m (Maybe a)
 redirectExceptionToSink fn = do
-  exChan <- askExceptionSink
+  sink <- askExceptionSink
   (Just <$> fn) `catchAll`
-    \ex -> liftSTM (Nothing <$ throwToExceptionSink exChan ex)
+    \ex -> liftSTM (Nothing <$ throwToExceptionSink sink ex)
 
 redirectExceptionToSinkIO :: (MonadCatch m, MonadQuasar m, MonadIO m) => m a -> m (Maybe a)
 redirectExceptionToSinkIO fn = do
-  exChan <- askExceptionSink
+  sink <- askExceptionSink
   (Just <$> fn) `catchAll`
-    \ex -> atomically (Nothing <$ throwToExceptionSink exChan ex)
+    \ex -> atomically (Nothing <$ throwToExceptionSink sink ex)
 {-# SPECIALIZE redirectExceptionToSinkIO :: QuasarIO a -> QuasarIO (Maybe a) #-}
 
 redirectExceptionToSink_ :: (MonadCatch m, MonadQuasar m, MonadSTM m) => m a -> m ()
@@ -286,19 +286,19 @@ redirectExceptionToSinkIO_ fn = void $ redirectExceptionToSinkIO fn
 -- Current behavior: exceptions on the current thread are not handled.
 catchQuasar :: forall e m a. (MonadQuasar m, Exception e) => (e -> STMc NoRetry '[SomeException] ()) -> m a -> m a
 catchQuasar handler fn = do
-  exSink <- catchSink handler <$> askExceptionSink
-  replaceExceptionSink exSink fn
+  sink <- catchSink handler <$> askExceptionSink
+  replaceExceptionSink sink fn
 
 replaceExceptionSink :: MonadQuasar m => ExceptionSink -> m a -> m a
-replaceExceptionSink exSink fn = do
+replaceExceptionSink sink fn = do
   quasar <- askQuasar
-  let q = newQuasar exSink (quasarResourceManager quasar)
+  let q = newQuasar sink (quasarResourceManager quasar)
   localQuasar q fn
 
 -- * Quasar initialization
 
 withQuasar :: ExceptionSink -> QuasarIO a -> IO a
-withQuasar exChan fn = mask \unmask -> do
-  rm <- atomically $ newUnmanagedResourceManagerSTM exChan
-  let quasar = newQuasar exChan rm
+withQuasar sink fn = mask \unmask -> do
+  rm <- atomically $ newUnmanagedResourceManagerSTM
+  let quasar = newQuasar sink rm
   unmask (runQuasarIO quasar fn) `finally` dispose rm

quasar/src/Quasar/Resources/Disposer.hs

@@ -57,6 +57,7 @@ import Quasar.Future
 import Quasar.Prelude
 import Quasar.Utils.CallbackRegistry
 import Quasar.Utils.TOnce
+import Quasar.Exceptions.ExceptionSink (loggingExceptionSink)
 
 class Disposable a where
   getDisposer :: a -> Disposer
@@ -331,7 +332,7 @@ isDisposing :: ResourceManager -> Future ()
 isDisposing rm = toFuture (resourceManagerIsDisposing rm)
 
 data ResourceManagerState
-  = ResourceManagerNormal (TVar (HashMap Unique DisposerElement)) ExceptionSink
+  = ResourceManagerNormal (TVar (HashMap Unique DisposerElement))
   | ResourceManagerDisposing (Future [DisposeDependencies])
   | ResourceManagerDisposed
 
@@ -350,11 +351,11 @@ instance IsDisposerElement ResourceManager where
     DisposeResultDependencies <$> beginDisposeResourceManagerInternal resourceManager
 
 
-newUnmanagedResourceManagerSTM :: MonadSTMc NoRetry '[] m => ExceptionSink -> m ResourceManager
-newUnmanagedResourceManagerSTM exChan = do
+newUnmanagedResourceManagerSTM :: MonadSTMc NoRetry '[] m => m ResourceManager
+newUnmanagedResourceManagerSTM = do
   resourceManagerKey <- newUniqueSTM
   attachedResources <- newTVar mempty
-  resourceManagerState <- newTVar (ResourceManagerNormal attachedResources exChan)
+  resourceManagerState <- newTVar (ResourceManagerNormal attachedResources)
   resourceManagerIsDisposing <- newPromise
   resourceManagerIsDisposed <- newPromise
   pure ResourceManager {
@@ -376,7 +377,7 @@ tryAttachResource resourceManager (getDisposer -> Disposer ds) = liftSTMc do
 tryAttachDisposer :: HasCallStack => ResourceManager -> DisposerElement -> STMc NoRetry '[] (Either FailedToAttachResource ())
 tryAttachDisposer resourceManager disposer = do
   readTVar (resourceManagerState resourceManager) >>= \case
-    ResourceManagerNormal attachedResources _ -> do
+    ResourceManagerNormal attachedResources -> do
       alreadyAttached <- isJust . HM.lookup key <$> readTVar attachedResources
       unless alreadyAttached do
         attachedResult <- readOrAttachToFuture_ disposer \() -> finalizerCallback
@@ -390,7 +391,7 @@ tryAttachDisposer resourceManager disposer = do
     key = disposerElementKey disposer
     finalizerCallback :: STMc NoRetry '[] ()
     finalizerCallback = readTVar (resourceManagerState resourceManager) >>= \case
-      ResourceManagerNormal attachedResources _ -> modifyTVar attachedResources (HM.delete key)
+      ResourceManagerNormal attachedResources -> modifyTVar attachedResources (HM.delete key)
       -- No resource detach is required in other states, since all resources are disposed soon
       -- (awaiting each resource should be cheaper than modifying the HashMap until it is empty).
       _ -> pure ()
@@ -399,19 +400,22 @@ tryAttachDisposer resourceManager disposer = do
 beginDisposeResourceManagerInternal :: ResourceManager -> STMc NoRetry '[] DisposeDependencies
 beginDisposeResourceManagerInternal rm = do
   readTVar (resourceManagerState rm) >>= \case
-    ResourceManagerNormal attachedResources exChan -> do
+    ResourceManagerNormal attachedResources -> do
       dependenciesVar <- newPromise
 
       -- write before fulfilling the promise since the promise has callbacks
       writeTVar (resourceManagerState rm) (ResourceManagerDisposing (toFuture dependenciesVar))
       tryFulfillPromise_ (resourceManagerIsDisposing rm) ()
 
       attachedDisposers <- HM.elems <$> readTVar attachedResources
-      forkSTM_ (disposeThread dependenciesVar attachedDisposers) exChan
+      forkSTM_ (disposeThread dependenciesVar attachedDisposers) brokenDisposerExceptionSink
       pure $ DisposeDependencies rmKey (toFuture dependenciesVar)
     ResourceManagerDisposing deps -> pure $ DisposeDependencies rmKey deps
     ResourceManagerDisposed -> pure $ DisposeDependencies rmKey mempty
   where
+    -- TODO prefix with message
+    brokenDisposerExceptionSink = loggingExceptionSink
+
     disposeThread :: Promise [DisposeDependencies] -> [DisposerElement] -> IO ()
     disposeThread dependenciesVar attachedDisposers = do
       -- Begin to dispose all attached resources