Change Resource class return multiple disposers

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

src/Quasar/Async.hs

@@ -32,7 +32,7 @@ import Control.Exception (throwTo)
 data Async a = Async (Future a) Disposer
 
 instance Resource (Async a) where
-  getDisposer (Async _ disposer) = disposer
+  getDisposer (Async _ disposer) = [disposer]
 
 instance IsFuture a (Async a) where
   toFuture (Async awaitable _) = awaitable

src/Quasar/Resources.hs

@@ -116,14 +116,14 @@ disposeEventually_ :: (Resource r, MonadQuasar m) => r -> m ()
 disposeEventually_ res = ensureSTM $ disposeEventuallySTM_ res
 
 
-captureResources :: MonadQuasar m => m a -> m (a, Disposer)
+captureResources :: MonadQuasar m => m a -> m (a, [Disposer])
 captureResources fn = do
   quasar <- newResourceScope
   localQuasar quasar do
     result <- fn
     pure (result, getDisposer (quasarResourceManager quasar))
 
-captureResources_ :: MonadQuasar m => m () -> m Disposer
+captureResources_ :: MonadQuasar m => m () -> m [Disposer]
 captureResources_ fn = snd <$> captureResources fn
 
 

src/Quasar/Resources/Disposer.hs

@@ -6,8 +6,6 @@ module Quasar.Resources.Disposer (
   dispose,
   disposeEventuallySTM,
   disposeEventuallySTM_,
-  isDisposing,
-  isDisposed,
   newUnmanagedPrimitiveDisposer,
   trivialDisposer,
 
@@ -35,7 +33,13 @@ import GHC.IO (unsafePerformIO, unsafeDupablePerformIO)
 
 
 class Resource a where
-  getDisposer :: a -> Disposer
+  getDisposer :: a -> [Disposer]
+
+  isDisposed :: a -> Future ()
+  isDisposed r = foldMap isDisposed $ getDisposer r
+
+  isDisposing :: a -> Future ()
+  isDisposing r = awaitAny $ isDisposing <$> getDisposer r
 
 
 type DisposerState = TOnce DisposeFn (Future ())
@@ -46,6 +50,17 @@ data Disposer
   | ResourceManagerDisposer ResourceManager
 
 instance Resource Disposer where
+  getDisposer disposer = [disposer]
+
+  isDisposed TrivialDisposer = pure ()
+  isDisposed (FnDisposer _ _ _ state _) = join (toFuture state)
+  isDisposed (ResourceManagerDisposer resourceManager) = resourceManagerIsDisposed resourceManager
+
+  isDisposing TrivialDisposer = pure ()
+  isDisposing (FnDisposer _ _ _ state _) = unsafeAwaitSTM (check . isRight =<< readTOnceState state)
+  isDisposing (ResourceManagerDisposer resourceManager) = resourceManagerIsDisposing resourceManager
+
+instance Resource [Disposer] where
   getDisposer = id
 
 type DisposeFn = ShortIO (Future ())
@@ -65,32 +80,19 @@ dispose :: (MonadIO m, Resource r) => r -> m ()
 dispose resource = liftIO $ await =<< atomically (disposeEventuallySTM resource)
 
 disposeEventuallySTM :: Resource r => r -> STM (Future ())
-disposeEventuallySTM resource =
-  case getDisposer resource of
-    TrivialDisposer -> pure (pure ())
-    FnDisposer _ worker exChan state finalizers -> do
+disposeEventuallySTM resource = mconcat <$> mapM f (getDisposer resource)
+  where
+    f :: Disposer -> STM (Future ())
+    f TrivialDisposer = pure (pure ())
+    f (FnDisposer _ worker exChan state finalizers) =
       beginDisposeFnDisposer worker exChan state finalizers
-    ResourceManagerDisposer resourceManager ->
+    f (ResourceManagerDisposer resourceManager) =
       beginDisposeResourceManager resourceManager
 
 disposeEventuallySTM_ :: Resource r => r -> STM ()
 disposeEventuallySTM_ resource = void $ disposeEventuallySTM resource
 
 
-isDisposed :: Resource a => a -> Future ()
-isDisposed resource =
-  case getDisposer resource of
-    TrivialDisposer -> pure ()
-    FnDisposer _ _ _ state _ -> join (toFuture state)
-    ResourceManagerDisposer resourceManager -> resourceManagerIsDisposed resourceManager
-
-isDisposing :: Resource a => a -> Future ()
-isDisposing resource =
-  case getDisposer resource of
-    TrivialDisposer -> pure ()
-    FnDisposer _ _ _ state _ -> unsafeAwaitSTM (check . isRight =<< readTOnceState state)
-    ResourceManagerDisposer resourceManager -> resourceManagerIsDisposing resourceManager
-
 
 
 beginDisposeFnDisposer :: TIOWorker -> ExceptionSink -> DisposerState -> Finalizers -> STM (Future ())
@@ -132,7 +134,6 @@ disposerFinalizers (FnDisposer _ _ _ _ finalizers) = finalizers
 disposerFinalizers (ResourceManagerDisposer rm) = resourceManagerFinalizers rm
 
 
-
 data DisposeResult
   = DisposeResultAwait (Future ())
   | DisposeResultDependencies DisposeDependencies
@@ -154,7 +155,9 @@ data ResourceManagerState
   | ResourceManagerDisposed
 
 instance Resource ResourceManager where
-  getDisposer = ResourceManagerDisposer
+  getDisposer rm = [ResourceManagerDisposer rm]
+  isDisposed = resourceManagerIsDisposed
+  isDisposing = resourceManagerIsDisposing
 
 
 newUnmanagedResourceManagerSTM :: TIOWorker -> ExceptionSink -> STM ResourceManager
@@ -172,7 +175,7 @@ newUnmanagedResourceManagerSTM worker exChan = do
 
 attachResource :: Resource a => ResourceManager -> a -> STM ()
 attachResource resourceManager resource =
-  attachDisposer resourceManager (getDisposer resource)
+  mapM_ (attachDisposer resourceManager) (getDisposer resource)
 
 attachDisposer :: ResourceManager -> Disposer -> STM ()
 attachDisposer resourceManager disposer = do
@@ -183,7 +186,7 @@ attachDisposer resourceManager disposer = do
         -- Returns false if the disposer is already finalized
         attachedFinalizer <- registerFinalizer (disposerFinalizers disposer) finalizer
         when attachedFinalizer $ modifyTVar attachedResources (HM.insert key disposer)
-    _ -> undefined -- failed to attach resource; arguably this should just dispose?
+    _ -> throwM $ userError "failed to attach resource" -- TODO throw proper exception
   where
     key :: Unique
     key = disposerKey disposer

src/Quasar/Timer.hs

@@ -50,7 +50,7 @@ instance Ord Timer where
   x `compare` y = time x `compare` time y
 
 instance Resource Timer where
-  getDisposer Timer{disposer} = disposer
+  getDisposer Timer{disposer} = [disposer]
 
 instance IsFuture () Timer where
   toFuture Timer{completed} = toFuture completed
@@ -60,13 +60,13 @@ data TimerScheduler = TimerScheduler {
   heap :: TMVar (Heap Timer),
   activeCount :: TVar Int,
   cancelledCount :: TVar Int,
-  disposer :: Disposer,
+  thread :: Async (),
   ioWorker :: TIOWorker,
   exceptionSink :: ExceptionSink
 }
 
 instance Resource TimerScheduler where
-  getDisposer TimerScheduler{disposer} = disposer
+  getDisposer TimerScheduler{thread} = getDisposer thread
 
 data TimerSchedulerDisposed = TimerSchedulerDisposed
   deriving stock (Eq, Show)
@@ -81,18 +81,18 @@ newTimerScheduler = liftQuasarIO do
   ioWorker <- askIOWorker
   exceptionSink <- askExceptionSink
   mfix \scheduler -> do
-    disposer <- startSchedulerThread scheduler
+    thread <- startSchedulerThread scheduler
     pure TimerScheduler {
       heap,
       activeCount,
       cancelledCount,
-      disposer,
+      thread,
       ioWorker,
       exceptionSink
     }
 
-startSchedulerThread :: TimerScheduler -> QuasarIO Disposer
-startSchedulerThread scheduler = getDisposer <$> async (schedulerThread `finally` liftIO cancelAll)
+startSchedulerThread :: TimerScheduler -> QuasarIO (Async ())
+startSchedulerThread scheduler = async (schedulerThread `finally` liftIO cancelAll)
   where
     heap' :: TMVar (Heap Timer)
     heap' = heap scheduler

src/Quasar/Timer/PosixTimer.hsc

@@ -161,7 +161,7 @@ data PosixTimer = PosixTimer {
 }
 
 instance Resource PosixTimer where
-  getDisposer = disposer
+  getDisposer timer = [(disposer timer)]
 
 
 newPosixTimer :: (MonadQuasar m, MonadIO m) => ClockId -> IO () -> m PosixTimer