From 32aef8d3fa0e430a9b543837837acdbca36a7394 Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Thu, 10 Feb 2022 22:15:22 +0100
Subject: [PATCH] Add draft for MonadQuasar types
---
quasar.cabal | 1 +
src/Quasar/Monad.hs | 51 +++++++++++++++++++++++++++++++++++++++++++++
2 files changed, 52 insertions(+)
create mode 100644 src/Quasar/Monad.hs
diff --git a/quasar.cabal b/quasar.cabal
index afea5a0..6e2b05d 100644
--- a/quasar.cabal
+++ b/quasar.cabal
@@ -91,6 +91,7 @@ library
Quasar.Awaitable
Quasar.Disposable
Quasar.Exceptions
+ Quasar.Monad
Quasar.Observable
Quasar.Observable.Delta
Quasar.Observable.ObservableHashMap
diff --git a/src/Quasar/Monad.hs b/src/Quasar/Monad.hs
new file mode 100644
index 0000000..833f7b6
--- /dev/null
+++ b/src/Quasar/Monad.hs
@@ -0,0 +1,51 @@
+module Quasar.Monad (
+ Quasar,
+ newQuasar,
+
+ MonadQuasar(..),
+
+ QuasarT,
+ QuasarIO,
+ QuasarSTM,
+
+) where
+
+import Control.Concurrent.STM
+import Quasar.Async.STMHelper
+import Quasar.Exceptions
+import Quasar.Prelude
+import Quasar.Resources
+import Control.Monad.Reader
+
+
+data Quasar = Quasar TIOWorker ExceptionChannel ResourceManager
+
+newQuasar :: TIOWorker -> ExceptionChannel -> ResourceManager -> STM Quasar
+newQuasar = undefined
+
+
+class Monad m => MonadQuasar m where
+ askQuasar :: m Quasar
+ runSTM :: STM a -> m a
+
+type QuasarT = ReaderT Quasar
+type QuasarIO = QuasarT IO
+type QuasarSTM = QuasarT STM
+
+
+instance MonadIO m => MonadQuasar (QuasarT m) where
+ askQuasar = ask
+ runSTM t = liftIO (atomically t)
+
+-- Overlaps the QuasartT/MonadIO-instance, because `MonadIO` _could_ be specified for `STM` (but that would be _very_ incorrect, so this is safe).
+instance {-# OVERLAPS #-} MonadQuasar (QuasarT STM) where
+ askQuasar = ask
+ runSTM = lift
+
+
+-- Overlappable so a QuasarT has priority over the base monad.
+instance {-# OVERLAPPABLE #-} MonadQuasar m => MonadQuasar (ReaderT r m) where
+ askQuasar = lift askQuasar
+ runSTM t = lift (runSTM t)
+
+-- TODO MonadQuasar instances for StateT, WriterT, RWST, MaybeT, ...
--
GitLab