diff --git a/src/Quasar/Async.hs b/src/Quasar/Async.hs
index 08e147e319463e8529c0da6a9b7ffe2c38fd6426..5f10464a845fa5565cd038c71e1513b189a8d05a 100644
--- a/src/Quasar/Async.hs
+++ b/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
diff --git a/src/Quasar/Resources.hs b/src/Quasar/Resources.hs
index 321351bb3724f680c46d3a0640756c720a527468..e3d8356fdf64243722c1c8dc0e19f30ef878b407 100644
--- a/src/Quasar/Resources.hs
+++ b/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
diff --git a/src/Quasar/Resources/Disposer.hs b/src/Quasar/Resources/Disposer.hs
index 71ed426d302442c0b53883433e7eee36ed94e33a..fec3fb8422882053763639b46dc752c3a4d1e647 100644
--- a/src/Quasar/Resources/Disposer.hs
+++ b/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
diff --git a/src/Quasar/Timer.hs b/src/Quasar/Timer.hs
index 8eb408cea6912c7fdcb0235811772805bcb82e93..7b45d09296461160554dc25dd66a5e6cfb483fc5 100644
--- a/src/Quasar/Timer.hs
+++ b/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
diff --git a/src/Quasar/Timer/PosixTimer.hsc b/src/Quasar/Timer/PosixTimer.hsc
index e578ed02bf13b13b8e2beced032a09d7f1988c63..18b42076e26d41bbdf949db08b4e9b6d39ba29a6 100644
--- a/src/Quasar/Timer/PosixTimer.hsc
+++ b/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