diff --git a/src/Quasar/Monad.hs b/src/Quasar/Monad.hs index 2894462e1b5b613356d49f4460b6c18838c75d20..5f2ad23ca9764f87ac8e3497b04445af808eb8ed 100644 --- a/src/Quasar/Monad.hs +++ b/src/Quasar/Monad.hs @@ -82,6 +82,7 @@ class (MonadCatch m, MonadFix m) => MonadQuasar m where startShortIO :: ShortIO a -> m (Awaitable a) ensureSTM :: STM a -> m a ensureQuasarSTM :: QuasarSTM a -> m a + localQuasar :: Quasar -> m a -> m a type QuasarT = ReaderT Quasar type QuasarIO = QuasarT IO @@ -102,6 +103,7 @@ instance (MonadIO m, MonadMask m, MonadFix m) => MonadQuasar (QuasarT m) where pure $ throwM $ toException $ AsyncException ex Right result -> pure $ pure result ensureQuasarSTM = quasarAtomically + localQuasar quasar = local (const quasar) instance MonadQuasar QuasarSTM where @@ -120,6 +122,7 @@ instance MonadQuasar QuasarSTM where modifyTVar effectAwaitableVar (awaitSuccessOrFailure awaitable *>) pure awaitable ensureQuasarSTM = id + localQuasar quasar (QuasarSTM fn) = QuasarSTM (local (first (const quasar)) fn) -- Overlappable so a QuasarT has priority over the base monad. @@ -131,6 +134,9 @@ instance {-# OVERLAPPABLE #-} MonadQuasar m => MonadQuasar (ReaderT r m) where lift $ maskIfRequired (runReaderT fn x) startShortIO t = lift (startShortIO t) ensureQuasarSTM t = lift (ensureQuasarSTM t) + localQuasar quasar fn = do + x <- ask + lift (localQuasar quasar (runReaderT fn x)) -- TODO MonadQuasar instances for StateT, WriterT, RWST, MaybeT, ...