Change QuasarIO to newtype; add more instances to QuasarIO and QuasarSTM

src/Quasar/Async.hs

@@ -52,12 +52,12 @@ async_ fn = void $ asyncWithUnmask (\unmask -> unmask fn)
 asyncWithUnmask :: (MonadQuasar m, MonadIO m) => ((forall b. QuasarIO b -> QuasarIO b) -> QuasarIO a) -> m (Async a)
 asyncWithUnmask fn = do
   quasar <- askQuasar
-  asyncWithUnmask' (\unmask -> runReaderT (fn (liftUnmask unmask)) quasar)
+  asyncWithUnmask' (\unmask -> runQuasarIO quasar (fn (liftUnmask unmask)))
   where
     liftUnmask :: (forall b. IO b -> IO b) -> QuasarIO a -> QuasarIO a
     liftUnmask unmask innerAction = do
       quasar <- askQuasar
-      liftIO $ unmask $ runReaderT innerAction quasar
+      liftIO $ unmask $ runQuasarIO quasar innerAction
 
 asyncWithUnmask_ :: (MonadQuasar m, MonadIO m) => ((forall b. QuasarIO b -> QuasarIO b) -> QuasarIO ()) -> m ()
 asyncWithUnmask_ fn = void $ asyncWithUnmask fn

src/Quasar/MonadQuasar.hs

@@ -41,9 +41,11 @@ import Control.Monad.Reader
 import GHC.Records (HasField(..))
 import Quasar.Async.STMHelper
 import Quasar.Exceptions
+import Quasar.Future
 import Quasar.Logger
 import Quasar.Prelude
 import Quasar.Resources.Disposer
+import Control.Monad.Base (MonadBase)
 
 
 -- Invariant: the resource manager is disposed as soon as an exception is thrown to the channel
@@ -115,22 +117,47 @@ class (MonadCatch m, MonadFix m) => MonadQuasar m where
   localQuasar :: Quasar -> m a -> m a
 
 type QuasarT = ReaderT Quasar
-type QuasarIO = QuasarT IO
+
+newtype QuasarIO a = QuasarIO (QuasarT IO a)
+  deriving newtype (Functor, Applicative, Monad, MonadThrow, MonadCatch, MonadMask, MonadFail, MonadFix, Alternative, MonadPlus, MonadBase IO, MonadIO)
+
+instance Semigroup a => Semigroup (QuasarIO a) where
+  fx <> fy = liftA2 (<>) fx fy
+
+instance Monoid a => Monoid (QuasarIO a) where
+  mempty = pure mempty
+
+instance MonadAwait QuasarIO where
+  await awaitable = liftIO (await awaitable)
+
 
 newtype QuasarSTM a = QuasarSTM (QuasarT STM a)
-  deriving newtype (Functor, Applicative, Monad, MonadThrow, MonadCatch, MonadFix, Alternative, MonadSTM)
+  deriving newtype (Functor, Applicative, Monad, MonadThrow, MonadCatch, MonadFix, Alternative, MonadPlus, MonadSTM)
+
+instance Semigroup a => Semigroup (QuasarSTM a) where
+  fx <> fy = liftA2 (<>) fx fy
+
+instance Monoid a => Monoid (QuasarSTM a) where
+  mempty = pure mempty
+
+instance MonadFail QuasarSTM where
+  fail msg = throwM (userError msg)
+
 
+instance MonadQuasar QuasarIO where
+  askQuasar = QuasarIO ask
+  localQuasar quasar (QuasarIO fn) = QuasarIO (local (const quasar) fn)
 
 instance (MonadIO m, MonadMask m, MonadFix m) => MonadQuasar (QuasarT m) where
   askQuasar = ask
   localQuasar quasar = local (const quasar)
-  {-# SPECIALIZE instance MonadQuasar QuasarIO #-}
+  {-# SPECIALIZE instance MonadQuasar (QuasarT IO) #-}
 
 instance (MonadIO m, MonadMask m, MonadFix m) => MonadLog (QuasarT m) where
   logMessage msg = do
     logger <- askLogger
     liftIO $ logger msg
-  {-# SPECIALIZE instance MonadLog QuasarIO #-}
+  {-# SPECIALIZE instance MonadLog (QuasarT IO) #-}
 
 
 instance MonadQuasar QuasarSTM where
@@ -176,7 +203,7 @@ liftQuasarSTM fn = do
 {-# INLINABLE [1] liftQuasarSTM #-}
 
 runQuasarIO :: MonadIO m => Quasar -> QuasarIO a -> m a
-runQuasarIO quasar fn = liftIO $ runReaderT fn quasar
+runQuasarIO quasar (QuasarIO fn) = liftIO $ runReaderT fn quasar
 {-# SPECIALIZE runQuasarIO :: Quasar -> QuasarIO a -> IO a #-}
 {-# INLINABLE runQuasarIO #-}