Skip to content
Snippets Groups Projects
Commit 778bfbec authored by Jens Nolte's avatar Jens Nolte
Browse files

Remove ensureSTM from MonadQuasar


Co-authored-by: default avatarJan Beinke <git@janbeinke.com>
parent d9c5d8ab
No related branches found
No related tags found
No related merge requests found
Pipeline #2771 passed
......@@ -71,7 +71,7 @@ asyncWithUnmask' fn = liftQuasarIO do
afixExtra \threadIdFuture -> mask_ do
-- Disposer is created first to ensure the resource can be safely attached
disposer <- registerDisposeAction (disposeFn key resultVar threadIdFuture)
disposer <- registerDisposeActionIO (disposeFn key resultVar threadIdFuture)
threadId <- liftIO $ forkWithUnmask (runAndPut exChan key resultVar disposer) exChan
......@@ -88,10 +88,10 @@ asyncWithUnmask' fn = liftQuasarIO do
atomically (throwToExceptionSink exChan ex)
`finally` do
breakPromise resultVar (AsyncException ex)
atomically $ disposeEventuallySTM_ disposer
disposeEventuallyIO_ disposer
Right retVal -> do
fulfillPromise resultVar retVal
atomically $ disposeEventuallySTM_ disposer
disposeEventuallyIO_ disposer
disposeFn :: Unique -> Promise a -> Future ThreadId -> IO ()
disposeFn key resultVar threadIdFuture = do
-- Should not block or fail (unless the TIOWorker is broken)
......
module Quasar.Exceptions (
ExceptionSink(..),
throwToExceptionSink,
throwToExceptionSinkIO,
catchSink,
catchAllSink,
......@@ -26,8 +27,11 @@ import Quasar.Prelude
newtype ExceptionSink = ExceptionSink (SomeException -> STM ())
throwToExceptionSink :: Exception e => ExceptionSink -> e -> STM ()
throwToExceptionSink (ExceptionSink channelFn) ex = channelFn (toException ex)
throwToExceptionSink :: (Exception e, MonadSTM m) => ExceptionSink -> e -> m ()
throwToExceptionSink (ExceptionSink channelFn) ex = liftSTM $ channelFn (toException ex)
throwToExceptionSinkIO :: (Exception e, MonadIO m) => ExceptionSink -> e -> m ()
throwToExceptionSinkIO sink ex = atomically $ throwToExceptionSink sink ex
catchSink :: forall e. Exception e => (e -> STM ()) -> ExceptionSink -> ExceptionSink
catchSink handler parentSink = ExceptionSink $ mapM_ wrappedHandler . fromException
......
......@@ -2,6 +2,7 @@ module Quasar.MonadQuasar (
-- * Quasar
Quasar,
newResourceScope,
newResourceScopeIO,
newResourceScopeSTM,
withResourceScope,
......@@ -15,11 +16,14 @@ module Quasar.MonadQuasar (
runQuasarIO,
runQuasarSTM,
liftQuasarIO,
liftQuasarSTM,
quasarAtomically,
-- ** Utils
redirectExceptionToSink,
redirectExceptionToSinkIO,
redirectExceptionToSink_,
redirectExceptionToSinkIO_,
-- ** Get quasar components
quasarIOWorker,
......@@ -84,22 +88,22 @@ newResourceScopeSTM parent = do
disposeEventuallySTM_ rm
throwToExceptionSink parentExceptionSink ex
newResourceScope :: MonadQuasar m => m Quasar
newResourceScope = ensureSTM . newResourceScopeSTM =<< askQuasar
{-# SPECIALIZE newResourceScope :: QuasarIO Quasar #-}
newResourceScope :: (MonadQuasar m, MonadSTM m) => m Quasar
newResourceScope = liftSTM . newResourceScopeSTM =<< askQuasar
{-# SPECIALIZE newResourceScope :: QuasarSTM Quasar #-}
newResourceScopeIO :: (MonadQuasar m, MonadIO m) => m Quasar
newResourceScopeIO = quasarAtomically newResourceScope
{-# SPECIALIZE newResourceScopeIO :: QuasarIO Quasar #-}
withResourceScope :: (MonadQuasar m, MonadIO m, MonadMask m) => m a -> m a
withResourceScope fn = bracket newResourceScope dispose (`localQuasar` fn)
withResourceScope fn = bracket newResourceScopeIO dispose (`localQuasar` fn)
{-# SPECIALIZE withResourceScope :: QuasarIO a -> QuasarIO a #-}
class (MonadCatch m, MonadFix m) => MonadQuasar m where
askQuasar :: m Quasar
maskIfRequired :: m a -> m a
ensureSTM :: STM a -> m a
ensureQuasarSTM :: QuasarSTM a -> m a
localQuasar :: Quasar -> m a -> m a
type QuasarT = ReaderT Quasar
......@@ -111,9 +115,6 @@ newtype QuasarSTM a = QuasarSTM (QuasarT STM a)
instance (MonadIO m, MonadMask m, MonadFix m) => MonadQuasar (QuasarT m) where
askQuasar = ask
ensureSTM t = liftIO (atomically t)
maskIfRequired = mask_
ensureQuasarSTM = quasarAtomically
localQuasar quasar = local (const quasar)
{-# SPECIALIZE instance MonadQuasar QuasarIO #-}
......@@ -126,20 +127,12 @@ instance (MonadIO m, MonadMask m, MonadFix m) => MonadLog (QuasarT m) where
instance MonadQuasar QuasarSTM where
askQuasar = QuasarSTM ask
ensureSTM fn = QuasarSTM (lift fn)
maskIfRequired = id
ensureQuasarSTM = id
localQuasar quasar (QuasarSTM fn) = QuasarSTM (local (const quasar) fn)
-- Overlappable so a QuasarT has priority over the base monad.
instance {-# OVERLAPPABLE #-} MonadQuasar m => MonadQuasar (ReaderT r m) where
askQuasar = lift askQuasar
ensureSTM t = lift (ensureSTM t)
maskIfRequired fn = do
x <- ask
lift $ maskIfRequired (runReaderT fn x)
ensureQuasarSTM t = lift (ensureQuasarSTM t)
localQuasar quasar fn = do
x <- ask
lift (localQuasar quasar (runReaderT fn x))
......@@ -163,36 +156,57 @@ askResourceManager = quasarResourceManager <$> askQuasar
liftQuasarIO :: (MonadIO m, MonadQuasar m) => QuasarIO a -> m a
liftQuasarIO fn = do
quasar <- askQuasar
liftIO $ runReaderT fn quasar
liftIO $ runQuasarIO quasar fn
{-# RULES "liftQuasarIO/id" liftQuasarIO = id #-}
{-# INLINABLE [1] liftQuasarIO #-}
liftQuasarSTM :: (MonadSTM m, MonadQuasar m) => QuasarSTM a -> m a
liftQuasarSTM fn = do
quasar <- askQuasar
liftSTM $ runQuasarSTM quasar fn
{-# RULES "liftQuasarSTM/id" liftQuasarSTM = id #-}
{-# INLINABLE [1] liftQuasarSTM #-}
runQuasarIO :: MonadIO m => Quasar -> QuasarIO a -> m a
runQuasarIO quasar fn = liftIO $ runReaderT fn quasar
{-# SPECIALIZE runQuasarIO :: Quasar -> QuasarIO a -> IO a #-}
{-# INLINABLE runQuasarIO #-}
runQuasarSTM :: MonadSTM m => Quasar -> QuasarSTM a -> m a
runQuasarSTM quasar (QuasarSTM fn) = liftSTM $ runReaderT fn quasar
{-# SPECIALIZE runQuasarSTM :: Quasar -> QuasarSTM a -> STM a #-}
{-# INLINABLE runQuasarSTM #-}
quasarAtomically :: (MonadQuasar m, MonadIO m) => QuasarSTM a -> m a
quasarAtomically (QuasarSTM fn) = do
quasar <- askQuasar
atomically $ runReaderT fn quasar
{-# SPECIALIZE quasarAtomically :: QuasarSTM a -> QuasarIO a #-}
{-# INLINABLE quasarAtomically #-}
redirectExceptionToSink :: MonadQuasar m => m a -> m (Maybe a)
redirectExceptionToSink :: (MonadQuasar m, MonadSTM m) => m a -> m (Maybe a)
redirectExceptionToSink fn = do
exChan <- askExceptionSink
(Just <$> fn) `catchAll`
\ex -> ensureSTM (Nothing <$ throwToExceptionSink exChan ex)
{-# SPECIALIZE redirectExceptionToSink :: QuasarIO a -> QuasarIO (Maybe a) #-}
\ex -> liftSTM (Nothing <$ throwToExceptionSink exChan ex)
{-# SPECIALIZE redirectExceptionToSink :: QuasarSTM a -> QuasarSTM (Maybe a) #-}
redirectExceptionToSink_ :: MonadQuasar m => m a -> m ()
redirectExceptionToSinkIO :: (MonadQuasar m, MonadIO m) => m a -> m (Maybe a)
redirectExceptionToSinkIO fn = do
exChan <- askExceptionSink
(Just <$> fn) `catchAll`
\ex -> atomically (Nothing <$ throwToExceptionSink exChan ex)
{-# SPECIALIZE redirectExceptionToSinkIO :: QuasarIO a -> QuasarIO (Maybe a) #-}
redirectExceptionToSink_ :: (MonadQuasar m, MonadSTM m) => m a -> m ()
redirectExceptionToSink_ fn = void $ redirectExceptionToSink fn
{-# SPECIALIZE redirectExceptionToSink_ :: QuasarIO a -> QuasarIO () #-}
{-# SPECIALIZE redirectExceptionToSink_ :: QuasarSTM a -> QuasarSTM () #-}
redirectExceptionToSinkIO_ :: (MonadQuasar m, MonadIO m) => m a -> m ()
redirectExceptionToSinkIO_ fn = void $ redirectExceptionToSinkIO fn
{-# SPECIALIZE redirectExceptionToSinkIO_ :: QuasarIO a -> QuasarIO () #-}
-- * Quasar initialization
......
......@@ -54,7 +54,7 @@ runQuasarAndExitWith :: (QuasarExitState a -> ExitCode) -> Logger -> QuasarIO a
runQuasarAndExitWith exitCodeFn logger fn = mask \unmask -> do
worker <- newTIOWorker
(exChan, exceptionWitness) <- atomically $ newExceptionWitnessSink (loggingExceptionSink worker)
mResult <- unmask $ withQuasarGeneric logger worker exChan (redirectExceptionToSink fn)
mResult <- unmask $ withQuasarGeneric logger worker exChan (redirectExceptionToSinkIO fn)
failure <- atomically exceptionWitness
exitState <- case (mResult, failure) of
(Just result, False) -> pure $ QuasarExitSuccess result
......
......@@ -77,7 +77,7 @@ class IsRetrievable r a => IsObservable r a | a -> r where
-- processed immediately, use `observeBlocking` instead or manually pass the value to a thread that processes the
-- data.
observe
:: (MonadQuasar m)
:: (MonadQuasar m, MonadSTM m)
=> a -- ^ observable
-> ObservableCallback r -- ^ callback
-> m [Disposer]
......@@ -99,11 +99,11 @@ class IsRetrievable r a => IsObservable r a | a -> r where
observe_
:: (IsObservable r a, MonadQuasar m)
:: (IsObservable r a, MonadQuasar m, MonadSTM m)
=> a -- ^ observable
-> ObservableCallback r -- ^ callback
-> m ()
observe_ observable callback = void $ observe observable callback
observe_ observable callback = liftQuasarSTM $ void $ observe observable callback
type ObservableCallback v = ObservableState v -> QuasarSTM ()
......@@ -163,7 +163,7 @@ observeBlocking observable handler = do
bracket
do
observe observable \msg -> liftSTM do
quasarAtomically $ observe observable \msg -> liftSTM do
void $ tryTakeTMVar var
putTMVar var msg
dispose
......@@ -215,7 +215,7 @@ newtype ConstObservable a = ConstObservable a
instance IsRetrievable a (ConstObservable a) where
retrieve (ConstObservable x) = pure x
instance IsObservable a (ConstObservable a) where
observe (ConstObservable x) callback = ensureQuasarSTM do
observe (ConstObservable x) callback = liftQuasarSTM do
callback $ ObservableValue x
pure []
pingObservable _ = pure ()
......@@ -225,7 +225,7 @@ newtype ThrowObservable a = ThrowObservable SomeException
instance IsRetrievable a (ThrowObservable a) where
retrieve (ThrowObservable ex) = throwM ex
instance IsObservable a (ThrowObservable a) where
observe (ThrowObservable ex) callback = ensureQuasarSTM do
observe (ThrowObservable ex) callback = liftQuasarSTM do
callback $ ObservableNotAvailable ex
pure []
pingObservable _ = pure ()
......@@ -253,7 +253,7 @@ instance IsRetrievable a (LiftA2Observable a) where
liftA2 fn (retrieve fx) (await future)
instance IsObservable a (LiftA2Observable a) where
observe (LiftA2Observable fn fx fy) callback = ensureQuasarSTM do
observe (LiftA2Observable fn fx fy) callback = liftQuasarSTM do
var0 <- liftSTM $ newTVar Nothing
var1 <- liftSTM $ newTVar Nothing
let callCallback = do
......@@ -281,7 +281,7 @@ instance IsRetrievable a (BindObservable a) where
retrieve $ fn x
instance IsObservable a (BindObservable a) where
observe (BindObservable fx fn) callback = ensureQuasarSTM do
observe (BindObservable fx fn) callback = liftQuasarSTM do
callback ObservableLoading
keyVar <- newTVar =<< newUniqueSTM
disposableVar <- liftSTM $ newTVar []
......@@ -317,7 +317,7 @@ instance IsRetrievable a (CatchObservable e a) where
retrieve (CatchObservable fx fn) = retrieve fx `catch` \ex -> retrieve (fn ex)
instance IsObservable a (CatchObservable e a) where
observe (CatchObservable fx fn) callback = ensureQuasarSTM do
observe (CatchObservable fx fn) callback = liftQuasarSTM do
callback ObservableLoading
keyVar <- newTVar =<< newUniqueSTM
disposableVar <- liftSTM $ newTVar []
......@@ -354,8 +354,8 @@ newObserverRegistryIO = liftIO $ ObserverRegistry <$> newTVarIO mempty
registerObserver :: ObserverRegistry a -> ObservableCallback a -> ObservableState a -> QuasarSTM [Disposer]
registerObserver (ObserverRegistry var) callback currentState = do
quasar <- askQuasar
key <- ensureSTM newUniqueSTM
ensureSTM $ modifyTVar var (HM.insert key (execForeignQuasarSTM quasar . callback))
key <- newUniqueSTM
modifyTVar var (HM.insert key (execForeignQuasarSTM quasar . callback))
disposer <- registerDisposeTransaction $ modifyTVar var (HM.delete key)
callback currentState
pure [disposer]
......@@ -371,8 +371,8 @@ instance IsRetrievable a (ObservableVar a) where
retrieve (ObservableVar var _registry) = liftIO $ readTVarIO var
instance IsObservable a (ObservableVar a) where
observe (ObservableVar var registry) callback = ensureQuasarSTM do
registerObserver registry callback . ObservableValue =<< ensureSTM (readTVar var)
observe (ObservableVar var registry) callback = liftQuasarSTM do
registerObserver registry callback . ObservableValue =<< readTVar var
pingObservable _ = pure ()
......
......@@ -38,36 +38,48 @@ type MonadSTM = MonadBase STM
liftSTM :: MonadSTM m => STM a -> m a
liftSTM = liftBase
{-# SPECIALIZE liftSTM :: STM a -> STM a #-}
atomically :: MonadIO m => STM a -> m a
atomically t = liftIO (STM.atomically t)
{-# SPECIALIZE atomically :: STM a -> IO a #-}
newUniqueSTM :: MonadSTM m => m Unique
newUniqueSTM = liftSTM (unsafeIOToSTM newUnique)
{-# SPECIALIZE newUniqueSTM :: STM Unique #-}
newTVar :: MonadSTM m => a -> m (TVar a)
newTVar = liftSTM . STM.newTVar
{-# SPECIALIZE newTVar :: a -> STM (TVar a) #-}
newTVarIO :: MonadIO m => a -> m (TVar a)
newTVarIO = liftIO . STM.newTVarIO
{-# SPECIALIZE newTVarIO :: a -> IO (TVar a) #-}
readTVar :: MonadSTM m => TVar a -> m a
readTVar = liftSTM . STM.readTVar
{-# SPECIALIZE readTVar :: TVar a -> STM a #-}
readTVarIO :: MonadIO m => TVar a -> m a
readTVarIO = liftIO . STM.readTVarIO
{-# SPECIALIZE readTVarIO :: TVar a -> IO a #-}
writeTVar :: MonadSTM m => TVar a -> a -> m ()
writeTVar var = liftSTM . STM.writeTVar var
{-# SPECIALIZE writeTVar :: TVar a -> a -> STM () #-}
modifyTVar :: MonadSTM m => TVar a -> (a -> a) -> m ()
modifyTVar var = liftSTM . STM.modifyTVar var
{-# SPECIALIZE modifyTVar :: TVar a -> (a -> a) -> STM () #-}
modifyTVar' :: MonadSTM m => TVar a -> (a -> a) -> m ()
modifyTVar' var = liftSTM . STM.modifyTVar' var
{-# SPECIALIZE modifyTVar' :: TVar a -> (a -> a) -> STM () #-}
stateTVar :: MonadSTM m => TVar s -> (s -> (a, s)) -> m a
stateTVar var = liftSTM . STM.stateTVar var
{-# SPECIALIZE stateTVar :: TVar s -> (s -> (a, s)) -> STM a #-}
swapTVar :: MonadSTM m => TVar a -> a -> m a
swapTVar var = liftSTM . STM.swapTVar var
{-# SPECIALIZE swapTVar :: TVar a -> a -> STM a #-}
......@@ -2,25 +2,30 @@ module Quasar.Resources (
-- * Resources
Resource(..),
dispose,
isDisposing,
isDisposed,
-- * Resource management in the `Quasar` monad
registerResource,
registerNewResource,
registerResourceIO,
registerDisposeAction,
registerDisposeAction_,
registerDisposeActionIO,
registerDisposeActionIO_,
registerDisposeTransaction,
registerDisposeTransaction_,
registerDisposeTransactionIO,
registerDisposeTransactionIO_,
disposeEventually,
disposeEventually_,
disposeEventuallyIO,
disposeEventuallyIO_,
captureResources,
captureResources_,
disposeOnError,
captureResourcesIO,
captureResourcesIO_,
-- * STM
disposeEventuallySTM,
disposeEventuallySTM_,
-- * IO
registerNewResource,
disposeOnError,
-- * Types to implement resources
-- ** Disposer
......@@ -60,75 +65,112 @@ newUnmanagedSTMDisposer fn worker exChan = newUnmanagedPrimitiveDisposer dispose
(pure <$> fn) `orElse` forkAsyncSTM (atomically fn) worker exChan
registerResource :: (Resource a, MonadQuasar m) => a -> m ()
registerResource :: (Resource a, MonadQuasar m, MonadSTM m) => a -> m ()
registerResource resource = do
rm <- askResourceManager
ensureSTM $ attachResource rm resource
liftSTM $ attachResource rm resource
{-# SPECIALIZE registerResource :: Resource a => a -> QuasarSTM () #-}
registerResourceIO :: (Resource a, MonadQuasar m, MonadIO m) => a -> m ()
registerResourceIO res = quasarAtomically $ registerResource res
{-# SPECIALIZE registerResourceIO :: Resource a => a -> QuasarIO () #-}
registerDisposeAction :: MonadQuasar m => IO () -> m Disposer
registerDisposeAction :: (MonadQuasar m, MonadSTM m) => IO () -> m Disposer
registerDisposeAction fn = do
worker <- askIOWorker
exChan <- askExceptionSink
rm <- askResourceManager
ensureSTM do
liftSTM do
disposer <- newUnmanagedIODisposer fn worker exChan
attachResource rm disposer
pure disposer
{-# SPECIALIZE registerDisposeAction :: IO () -> QuasarSTM Disposer #-}
registerDisposeAction_ :: MonadQuasar m => IO () -> m ()
registerDisposeAction_ fn = void $ registerDisposeAction fn
registerDisposeAction_ :: (MonadQuasar m, MonadSTM m) => IO () -> m ()
registerDisposeAction_ fn = liftQuasarSTM $ void $ registerDisposeAction fn
registerDisposeTransaction :: MonadQuasar m => STM () -> m Disposer
registerDisposeActionIO :: (MonadQuasar m, MonadIO m) => IO () -> m Disposer
registerDisposeActionIO fn = quasarAtomically $ registerDisposeAction fn
registerDisposeActionIO_ :: (MonadQuasar m, MonadIO m) => IO () -> m ()
registerDisposeActionIO_ fn = quasarAtomically $ void $ registerDisposeAction fn
registerDisposeTransaction :: (MonadQuasar m, MonadSTM m) => STM () -> m Disposer
registerDisposeTransaction fn = do
worker <- askIOWorker
exChan <- askExceptionSink
rm <- askResourceManager
ensureSTM do
liftSTM do
disposer <- newUnmanagedSTMDisposer fn worker exChan
attachResource rm disposer
pure disposer
{-# SPECIALIZE registerDisposeTransaction :: STM () -> QuasarSTM Disposer #-}
registerDisposeTransaction_ :: (MonadQuasar m, MonadSTM m) => STM () -> m ()
registerDisposeTransaction_ fn = liftQuasarSTM $ void $ registerDisposeTransaction fn
registerDisposeTransactionIO :: (MonadQuasar m, MonadIO m) => STM () -> m Disposer
registerDisposeTransactionIO fn = quasarAtomically $ registerDisposeTransaction fn
registerDisposeTransaction_ :: MonadQuasar m => STM () -> m ()
registerDisposeTransaction_ fn = void $ registerDisposeTransaction fn
registerDisposeTransactionIO_ :: (MonadQuasar m, MonadIO m) => STM () -> m ()
registerDisposeTransactionIO_ fn = quasarAtomically $ void $ registerDisposeTransaction fn
registerNewResource :: forall a m. (Resource a, MonadQuasar m) => m a -> m a
registerNewResource :: forall a m. (Resource a, MonadQuasar m, MonadIO m, MonadMask m) => m a -> m a
registerNewResource fn = do
rm <- askResourceManager
disposing <- isJust <$> ensureSTM (peekFutureSTM (isDisposing rm))
disposing <- isJust <$> peekFuture (isDisposing rm)
-- Bail out before creating the resource _if possible_
when disposing $ throwM AlreadyDisposing
maskIfRequired do
mask_ do
resource <- fn
registerResource resource `catchAll` \ex -> do
registerResourceIO resource `catchAll` \ex -> do
-- When the resource cannot be registered (because resource manager is now disposing), destroy it to prevent leaks
disposeEventually_ resource
atomically $ disposeEventually_ resource
case ex of
(fromException -> Just FailedToAttachResource) -> throwM AlreadyDisposing
_ -> throwM ex
pure resource
{-# SPECIALIZE registerNewResource :: Resource a => QuasarIO a -> QuasarIO a #-}
disposeEventually :: (Resource r, MonadQuasar m) => r -> m (Future ())
disposeEventually res = ensureSTM $ disposeEventuallySTM res
disposeEventually :: (Resource r, MonadSTM m) => r -> m (Future ())
disposeEventually res = liftSTM $ disposeEventuallySTM res
disposeEventually_ :: (Resource r, MonadQuasar m) => r -> m ()
disposeEventually_ res = ensureSTM $ disposeEventuallySTM_ res
disposeEventually_ :: (Resource r, MonadSTM m) => r -> m ()
disposeEventually_ res = liftSTM $ disposeEventuallySTM_ res
disposeEventuallyIO :: (Resource r, MonadIO m) => r -> m (Future ())
disposeEventuallyIO res = atomically $ disposeEventually res
captureResources :: MonadQuasar m => m a -> m (a, [Disposer])
disposeEventuallyIO_ :: (Resource r, MonadIO m) => r -> m ()
disposeEventuallyIO_ res = atomically $ void $ disposeEventually res
captureResources :: (MonadQuasar m, MonadSTM 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, MonadSTM m) => m () -> m [Disposer]
captureResources_ fn = snd <$> captureResources fn
captureResourcesIO :: (MonadQuasar m, MonadIO m) => m a -> m (a, [Disposer])
captureResourcesIO fn = do
quasar <- newResourceScopeIO
localQuasar quasar do
result <- fn
pure (result, getDisposer (quasarResourceManager quasar))
captureResourcesIO_ :: (MonadQuasar m, MonadIO m) => m () -> m [Disposer]
captureResourcesIO_ fn = snd <$> captureResourcesIO fn
-- | Runs the computation in a new resource scope, which is disposed when an exception happenes. When the computation succeeds, resources are kept.
disposeOnError :: (MonadQuasar m, MonadIO m, MonadMask m) => m a -> m a
disposeOnError fn = mask \unmask -> do
quasar <- newResourceScope
quasar <- newResourceScopeIO
unmask (localQuasar quasar fn) `onError` dispose quasar
......@@ -150,7 +150,7 @@ startSchedulerThread scheduler = async (schedulerThread `finally` liftIO cancelA
fireTimer Timer{completed, disposer} = do
result <- tryFulfillPromiseSTM completed ()
modifyTVar (if result then activeCount' else cancelledCount') (+ (-1))
disposeEventuallySTM_ disposer
disposeEventually_ disposer
cleanup :: STM ()
cleanup = putTMVar heap' . fromList =<< mapMaybeM cleanupTimer . toList =<< takeTMVar heap'
......@@ -170,7 +170,7 @@ startSchedulerThread scheduler = async (schedulerThread `finally` liftIO cancelA
mapM_ dispose timers
newTimer :: (MonadQuasar m, MonadIO m) => TimerScheduler -> UTCTime -> m Timer
newTimer :: (MonadQuasar m, MonadIO m, MonadMask m) => TimerScheduler -> UTCTime -> m Timer
newTimer scheduler time = registerNewResource $ newUnmanagedTimer scheduler time
......
......@@ -178,7 +178,7 @@ newPosixTimer clockId callback = do
pure (callbackPtr, ctimer)
disposer <- registerDisposeAction (delete ctimer callbackPtr)
disposer <- registerDisposeActionIO (delete ctimer callbackPtr)
pure $ PosixTimer { ctimer, disposer }
where
......
......@@ -40,14 +40,14 @@ newtype TimerFd = TimerFd Fd
deriving stock (Eq, Show)
deriving newtype Num
newTimerFd :: (MonadQuasar m, MonadIO m, MonadMask m) => ClockId -> IO () -> m TimerFd
newTimerFd clockId callback = mask_ do
newTimerFd :: (MonadQuasar m, MonadIO m) => ClockId -> IO () -> m TimerFd
newTimerFd clockId callback = liftQuasarIO $ mask_ do
timer <- liftIO $ runInBoundThread do
throwErrnoIfMinus1 "timerfd_create" do
c_timerfd_create (toCClockId clockId) c_TFD_CLOEXEC
workerTask <- async $ liftIO $ worker timer
registerDisposeAction_ do
registerDisposeActionIO_ do
await $ isDisposed workerTask
timerFdClose timer
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment