Remove ensureSTM from MonadQuasar

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

src/Quasar/Async.hs

@@ -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)

src/Quasar/Exceptions.hs

 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

src/Quasar/MonadQuasar.hs

@@ -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
 

src/Quasar/MonadQuasar/Misc.hs

@@ -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

src/Quasar/Observable.hs

@@ -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 ()
 

src/Quasar/PreludeSTM.hs

@@ -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 #-}

src/Quasar/Resources.hs

@@ -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

src/Quasar/Timer.hs

@@ -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
 
 

src/Quasar/Timer/PosixTimer.hsc

@@ -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

src/Quasar/Timer/TimerFd.hs

@@ -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