From 9cdd243b9c49cc636d0d7056ac01abc5e3c5701a Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Mon, 10 Oct 2022 00:20:11 +0200
Subject: [PATCH] Add TSimpleDisposer
Co-authored-by: Jan Beinke <git@janbeinke.com>
---
quasar/src/Quasar/Resources.hs | 26 +++++++
quasar/src/Quasar/Resources/Disposer.hs | 92 ++++++++++++++++++++-----
2 files changed, 101 insertions(+), 17 deletions(-)
diff --git a/quasar/src/Quasar/Resources.hs b/quasar/src/Quasar/Resources.hs
index b6d43ca..f391261 100644
--- a/quasar/src/Quasar/Resources.hs
+++ b/quasar/src/Quasar/Resources.hs
@@ -14,6 +14,10 @@ module Quasar.Resources (
registerDisposeTransaction_,
registerDisposeTransactionIO,
registerDisposeTransactionIO_,
+ registerSimpleDisposeTransaction,
+ registerSimpleDisposeTransaction_,
+ registerSimpleDisposeTransactionIO,
+ registerSimpleDisposeTransactionIO_,
disposeEventually,
disposeEventually_,
disposeEventuallyIO,
@@ -31,15 +35,19 @@ module Quasar.Resources (
-- ** Disposer
Disposer,
TDisposer,
+ TSimpleDisposer,
disposeTDisposer,
+ disposeTSimpleDisposer,
newUnmanagedIODisposer,
newUnmanagedSTMDisposer,
+ newUnmanagedTSimpleDisposer,
trivialDisposer,
-- ** Resource manager
ResourceManager,
newUnmanagedResourceManagerSTM,
attachResource,
+ tryAttachResource,
) where
@@ -101,6 +109,24 @@ registerDisposeTransactionIO fn = quasarAtomically $ registerDisposeTransaction
registerDisposeTransactionIO_ :: (MonadQuasar m, MonadIO m) => STM () -> m ()
registerDisposeTransactionIO_ fn = quasarAtomically $ void $ registerDisposeTransaction fn
+registerSimpleDisposeTransaction :: (MonadQuasar m, MonadSTM' r CanThrow m) => STM' NoRetry NoThrow () -> m TSimpleDisposer
+registerSimpleDisposeTransaction fn = do
+ rm <- askResourceManager
+ liftSTM' do
+ disposer <- newUnmanagedTSimpleDisposer fn
+ attachResource rm disposer
+ pure disposer
+{-# SPECIALIZE registerSimpleDisposeTransaction :: STM' NoRetry NoThrow () -> QuasarSTM TSimpleDisposer #-}
+
+registerSimpleDisposeTransaction_ :: (MonadQuasar m, MonadSTM' r CanThrow m) => STM' NoRetry NoThrow () -> m ()
+registerSimpleDisposeTransaction_ fn = liftQuasarSTM' $ void $ registerSimpleDisposeTransaction fn
+
+registerSimpleDisposeTransactionIO :: (MonadQuasar m, MonadIO m) => STM' NoRetry NoThrow () -> m TSimpleDisposer
+registerSimpleDisposeTransactionIO fn = quasarAtomically $ registerSimpleDisposeTransaction fn
+
+registerSimpleDisposeTransactionIO_ :: (MonadQuasar m, MonadIO m) => STM' NoRetry NoThrow () -> m ()
+registerSimpleDisposeTransactionIO_ fn = quasarAtomically $ void $ registerSimpleDisposeTransaction fn
+
registerNewResource :: forall a m. (Resource a, MonadQuasar m, MonadIO m, MonadMask m) => m a -> m a
registerNewResource fn = do
rm <- askResourceManager
diff --git a/quasar/src/Quasar/Resources/Disposer.hs b/quasar/src/Quasar/Resources/Disposer.hs
index d2e58ba..6b1a0d5 100644
--- a/quasar/src/Quasar/Resources/Disposer.hs
+++ b/quasar/src/Quasar/Resources/Disposer.hs
@@ -14,10 +14,15 @@ module Quasar.Resources.Disposer (
TDisposer,
disposeTDisposer,
+ TSimpleDisposer,
+ newUnmanagedTSimpleDisposer,
+ disposeTSimpleDisposer,
+
-- * Resource manager
ResourceManager,
newUnmanagedResourceManagerSTM,
attachResource,
+ tryAttachResource,
) where
@@ -67,6 +72,7 @@ type DisposerState = TOnce DisposeFn (Future ())
data DisposerElement
= IODisposer Unique TIOWorker ExceptionSink DisposerState Finalizers
| STMDisposer TDisposerElement
+ | STMSimpleDisposer TSimpleDisposerElement
| ResourceManagerDisposer ResourceManager
instance Resource DisposerElement where
@@ -74,10 +80,12 @@ instance Resource DisposerElement where
isDisposed (IODisposer _ _ _ state _) = join (toFuture state)
isDisposed (STMDisposer tdisposer) = isDisposed tdisposer
+ isDisposed (STMSimpleDisposer tdisposer) = isDisposed tdisposer
isDisposed (ResourceManagerDisposer resourceManager) = resourceManagerIsDisposed resourceManager
isDisposing (IODisposer _ _ _ state _) = void (toFuture state)
isDisposing (STMDisposer tdisposer) = isDisposing tdisposer
+ isDisposing (STMSimpleDisposer tdisposer) = isDisposing tdisposer
isDisposing (ResourceManagerDisposer resourceManager) = resourceManagerIsDisposing resourceManager
@@ -88,12 +96,6 @@ type STMDisposerState = TOnce (STM ()) (Future ())
data TDisposerElement = TDisposerElement Unique TIOWorker ExceptionSink STMDisposerState Finalizers
-newUnmanagedSTMDisposer :: MonadSTM' r t m => STM () -> TIOWorker -> ExceptionSink -> m TDisposer
-newUnmanagedSTMDisposer fn worker sink = do
- key <- newUniqueSTM
- element <- TDisposerElement key worker sink <$> newTOnce fn <*> newFinalizers
- pure $ TDisposer [element]
-
instance Resource TDisposerElement where
toDisposer disposer = Disposer [STMDisposer disposer]
isDisposed (TDisposerElement _ _ _ state _) = join (toFuture state)
@@ -104,6 +106,12 @@ instance Resource [TDisposerElement] where
isDisposed tds = isDisposed (toDisposer tds)
isDisposing tds = isDisposing (toDisposer tds)
+newUnmanagedSTMDisposer :: MonadSTM' r t m => STM () -> TIOWorker -> ExceptionSink -> m TDisposer
+newUnmanagedSTMDisposer fn worker sink = do
+ key <- newUniqueSTM
+ element <- TDisposerElement key worker sink <$> newTOnce fn <*> newFinalizers
+ pure $ TDisposer [element]
+
disposeTDisposer :: MonadSTM m => TDisposer -> m ()
disposeTDisposer (TDisposer elements) = liftSTM $ mapM_ go elements
where
@@ -116,7 +124,7 @@ disposeTDisposer (TDisposer elements) = liftSTM $ mapM_ go elements
startDisposeFn :: STM () -> STM (Future ())
startDisposeFn disposeFn = do
disposeFn `catchAll` throwToExceptionSink sink
- runFinalizers finalizers
+ liftSTM' $ runFinalizers finalizers
pure $ pure ()
beginDisposeSTMDisposer :: MonadSTM' r t m => TDisposerElement -> m (Future ())
@@ -149,6 +157,46 @@ beginDisposeSTMDisposer (TDisposerElement _ worker sink state finalizers) = lift
+type STMSimpleDisposerState = TOnce (STM' NoRetry NoThrow ()) ()
+
+data TSimpleDisposerElement = TSimpleDisposerElement Unique STMSimpleDisposerState Finalizers
+
+newtype TSimpleDisposer = TSimpleDisposer [TSimpleDisposerElement]
+ deriving newtype (Semigroup, Monoid)
+
+instance Resource TSimpleDisposer where
+ toDisposer (TSimpleDisposer ds) = toDisposer ds
+
+instance Resource TSimpleDisposerElement where
+ toDisposer disposer = Disposer [STMSimpleDisposer disposer]
+ isDisposed (TSimpleDisposerElement _ state _) = toFuture state
+ isDisposing = isDisposed
+
+instance Resource [TSimpleDisposerElement] where
+ toDisposer tds = Disposer (STMSimpleDisposer <$> tds)
+ isDisposed tds = isDisposed (toDisposer tds)
+ isDisposing tds = isDisposing (toDisposer tds)
+
+newUnmanagedTSimpleDisposer :: MonadSTM' r t m => STM' NoRetry NoThrow () -> m TSimpleDisposer
+newUnmanagedTSimpleDisposer fn = do
+ key <- newUniqueSTM
+ element <- TSimpleDisposerElement key <$> newTOnce fn <*> newFinalizers
+ pure $ TSimpleDisposer [element]
+
+disposeTSimpleDisposer :: MonadSTM' r t m => TSimpleDisposer -> m ()
+disposeTSimpleDisposer (TSimpleDisposer elements) = liftSTM' do
+ mapM_ disposeTSimpleDisposerElement elements
+
+disposeTSimpleDisposerElement :: TSimpleDisposerElement -> STM' r t ()
+disposeTSimpleDisposerElement (TSimpleDisposerElement _ state finalizers) =
+ mapFinalizeTOnce state startDisposeFn
+ where
+ startDisposeFn :: STM' NoRetry NoThrow () -> STM' r t ()
+ startDisposeFn disposeFn = do
+ noRetry $ noThrow disposeFn
+ runFinalizers finalizers
+
+
-- | A trivial disposer that does not perform any action when disposed.
trivialDisposer :: Disposer
trivialDisposer = mempty
@@ -175,6 +223,7 @@ disposeEventually (toDisposer -> Disposer ds) = liftSTM' do
f (IODisposer _ worker exChan state finalizers) =
beginDisposeFnDisposer worker exChan state finalizers
f (STMDisposer disposer) = beginDisposeSTMDisposer disposer
+ f (STMSimpleDisposer disposer) = pure () <$ disposeTSimpleDisposerElement disposer
f (ResourceManagerDisposer resourceManager) =
beginDisposeResourceManager resourceManager
@@ -210,12 +259,14 @@ beginDisposeFnDisposer worker exChan disposeState finalizers = liftSTM' do
disposerKey :: DisposerElement -> Unique
disposerKey (IODisposer key _ _ _ _) = key
disposerKey (STMDisposer (TDisposerElement key _ _ _ _)) = key
+disposerKey (STMSimpleDisposer (TSimpleDisposerElement key _ _)) = key
disposerKey (ResourceManagerDisposer resourceManager) = resourceManagerKey resourceManager
disposerFinalizers :: DisposerElement -> Finalizers
disposerFinalizers (IODisposer _ _ _ _ finalizers) = finalizers
disposerFinalizers (STMDisposer (TDisposerElement _ _ _ _ finalizers)) = finalizers
+disposerFinalizers (STMSimpleDisposer (TSimpleDisposerElement _ _ finalizers)) = finalizers
disposerFinalizers (ResourceManagerDisposer rm) = resourceManagerFinalizers rm
@@ -259,11 +310,15 @@ newUnmanagedResourceManagerSTM worker exChan = do
attachResource :: (MonadSTM' r CanThrow m, Resource a) => ResourceManager -> a -> m ()
-attachResource resourceManager (toDisposer -> Disposer ds) = liftSTM' do
- mapM_ (attachDisposer resourceManager) ds
+attachResource resourceManager disposer = liftSTM' do
+ either throwM pure =<< tryAttachResource resourceManager disposer
+
+tryAttachResource :: (MonadSTM' r t m, Resource a) => ResourceManager -> a -> m (Either FailedToAttachResource ())
+tryAttachResource resourceManager (toDisposer -> Disposer ds) = liftSTM' do
+ sequence_ <$> mapM (tryAttachDisposer resourceManager) ds
-attachDisposer :: ResourceManager -> DisposerElement -> STM' r CanThrow ()
-attachDisposer resourceManager disposer = do
+tryAttachDisposer :: ResourceManager -> DisposerElement -> STM' r t (Either FailedToAttachResource ())
+tryAttachDisposer resourceManager disposer = do
readTVar (resourceManagerState resourceManager) >>= \case
ResourceManagerNormal attachedResources _ _ -> do
alreadyAttached <- isJust . HM.lookup key <$> readTVar attachedResources
@@ -271,7 +326,8 @@ 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)
- _ -> throwM $ userError "failed to attach resource" -- TODO throw proper exception
+ pure $ Right ()
+ _ -> pure $ Left FailedToAttachResource
where
key :: Unique
key = disposerKey disposer
@@ -311,7 +367,7 @@ beginDisposeResourceManagerInternal rm = do
-- Await indirect dependencies
awaitDisposeDependencies $ DisposeDependencies rmKey (pure dependencies)
-- Set state to disposed and run finalizers
- atomically do
+ atomically' do
writeTVar (resourceManagerState rm) ResourceManagerDisposed
runFinalizers (resourceManagerFinalizers rm)
@@ -323,6 +379,8 @@ beginDisposeResourceManagerInternal rm = do
DisposeResultAwait <$> beginDisposeFnDisposer worker exChan state finalizers
resourceManagerBeginDispose (STMDisposer disposer) =
DisposeResultAwait <$> beginDisposeSTMDisposer disposer
+ resourceManagerBeginDispose (STMSimpleDisposer disposer) =
+ DisposeResultAwait (pure ()) <$ disposeTSimpleDisposerElement disposer
resourceManagerBeginDispose (ResourceManagerDisposer resourceManager) =
DisposeResultDependencies <$> beginDisposeResourceManagerInternal resourceManager
@@ -371,16 +429,16 @@ registerFinalizer (Finalizers finalizerVar) finalizer =
pure True
Nothing -> pure False
-runFinalizers :: Finalizers -> STM ()
+runFinalizers :: Finalizers -> STM' r t ()
runFinalizers (Finalizers finalizerVar) = do
readTVar finalizerVar >>= \case
Just finalizers -> do
noRetry $ noThrow $ sequence_ finalizers
writeTVar finalizerVar Nothing
- Nothing -> throwM $ userError "runFinalizers was called multiple times (it must only be run once)"
+ Nothing -> traceM "runFinalizers was called multiple times (it must only be run once)"
runFinalizersShortIO :: Finalizers -> ShortIO ()
-runFinalizersShortIO finalizers = unsafeShortIO $ atomically $ runFinalizers finalizers
+runFinalizersShortIO finalizers = unsafeShortIO $ atomically' $ runFinalizers finalizers
runFinalizersAfter :: Finalizers -> Future () -> ShortIO ()
runFinalizersAfter finalizers awaitable = do
@@ -392,4 +450,4 @@ runFinalizersAfter finalizers awaitable = do
else
void $ forkIOShortIO do
await awaitable
- atomically $ runFinalizers finalizers
+ atomically' $ runFinalizers finalizers
--
GitLab