From 887868b64465aeb1dbe0aef20ad756a3c24684ac Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Fri, 11 Feb 2022 16:15:26 +0100
Subject: [PATCH] Add constructor and accessors for Quasar fields
---
src/Quasar/Monad.hs | 51 +++++++++++++++++++++++++++++++++++++++++----
1 file changed, 47 insertions(+), 4 deletions(-)
diff --git a/src/Quasar/Monad.hs b/src/Quasar/Monad.hs
index 833f7b6..2d0ff67 100644
--- a/src/Quasar/Monad.hs
+++ b/src/Quasar/Monad.hs
@@ -3,25 +3,58 @@ module Quasar.Monad (
newQuasar,
MonadQuasar(..),
+ askIOWorker,
+ askExceptionChannel,
+ askResourceManager,
QuasarT,
QuasarIO,
QuasarSTM,
-
) where
import Control.Concurrent.STM
+import Control.Monad.Reader
+import GHC.Records (HasField(..))
import Quasar.Async.STMHelper
import Quasar.Exceptions
import Quasar.Prelude
-import Quasar.Resources
-import Control.Monad.Reader
+import Quasar.Resources.Disposer
+-- Invariant: the resource manager is disposed as soon as an exception is thrown to the channel
data Quasar = Quasar TIOWorker ExceptionChannel ResourceManager
+instance Resource Quasar where
+ getDisposer (Quasar _ _ rm) = getDisposer rm
+
+instance HasField "ioWorker" Quasar TIOWorker where
+ getField = quasarIOWorker
+
+instance HasField "exceptionChannel" Quasar ExceptionChannel where
+ getField = quasarExceptionChannel
+
+instance HasField "resourceManager" Quasar ResourceManager where
+ getField = quasarResourceManager
+
+quasarIOWorker :: Quasar -> TIOWorker
+quasarIOWorker (Quasar worker _ _) = worker
+
+quasarExceptionChannel :: Quasar -> ExceptionChannel
+quasarExceptionChannel (Quasar _ exChan _) = exChan
+
+quasarResourceManager :: Quasar -> ResourceManager
+quasarResourceManager (Quasar _ _ rm) = rm
+
newQuasar :: TIOWorker -> ExceptionChannel -> ResourceManager -> STM Quasar
-newQuasar = undefined
+newQuasar worker parentExChan parentRM = do
+ rm <- newResourceManagerSTM worker parentExChan
+ attachResource parentRM rm
+ pure $ Quasar worker (ExceptionChannel (disposeOnException rm)) rm
+ where
+ disposeOnException :: ResourceManager -> SomeException -> STM ()
+ disposeOnException rm ex = do
+ disposeEventuallySTM_ rm
+ throwToExceptionChannel parentExChan ex
class Monad m => MonadQuasar m where
@@ -49,3 +82,13 @@ instance {-# OVERLAPPABLE #-} MonadQuasar m => MonadQuasar (ReaderT r m) where
runSTM t = lift (runSTM t)
-- TODO MonadQuasar instances for StateT, WriterT, RWST, MaybeT, ...
+
+
+askIOWorker :: MonadQuasar m => m TIOWorker
+askIOWorker = quasarIOWorker <$> askQuasar
+
+askExceptionChannel :: MonadQuasar m => m ExceptionChannel
+askExceptionChannel = quasarExceptionChannel <$> askQuasar
+
+askResourceManager :: MonadQuasar m => m ResourceManager
+askResourceManager = quasarResourceManager <$> askQuasar
--
GitLab