From 5aeedb739f94fdb9f3dcecf192ab2cee75a1b2c8 Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Tue, 22 Feb 2022 02:22:10 +0100
Subject: [PATCH] Add localQuasar to MonadQuasar
---
src/Quasar/Monad.hs | 6 ++++++
1 file changed, 6 insertions(+)
diff --git a/src/Quasar/Monad.hs b/src/Quasar/Monad.hs
index 2894462..5f2ad23 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, ...
--
GitLab