diff --git a/src/Quasar/Monad.hs b/src/Quasar/Monad.hs index 5f2ad23ca9764f87ac8e3497b04445af808eb8ed..2f140bca685f2d182f95593fab55d67518e0bbdb 100644 --- a/src/Quasar/Monad.hs +++ b/src/Quasar/Monad.hs @@ -1,16 +1,15 @@ module Quasar.Monad ( + -- * Quasar Quasar, newQuasar, MonadQuasar(..), - askIOWorker, - askExceptionChannel, - askResourceManager, QuasarT, QuasarIO, QuasarSTM, + withQuasarGeneric, runQuasarIO, liftQuasarIO, quasarAtomically, @@ -19,18 +18,37 @@ module Quasar.Monad ( enterQuasarSTM, startShortIO_, + + -- ** High-level initialization + runQuasarAndExit, + runQuasarAndExitWith, + runQuasarCollectExceptions, + runQuasarCombineExceptions, + + -- ** Get quasar components + quasarIOWorker, + quasarExceptionChannel, + quasarResourceManager, + askIOWorker, + askExceptionChannel, + askResourceManager, ) where import Control.Concurrent.STM import Control.Monad.Catch import Control.Monad.Reader +import Data.List.NonEmpty import GHC.Records (HasField(..)) import Quasar.Async.STMHelper +import Quasar.Awaitable import Quasar.Exceptions +import Quasar.Exceptions.ExceptionChannel import Quasar.Prelude import Quasar.Resources.Disposer -import Quasar.Awaitable +import Quasar.Utils.Exceptions import Quasar.Utils.ShortIO +import System.Exit +import Data.Bifunctor (first) -- Invariant: the resource manager is disposed as soon as an exception is thrown to the channel @@ -76,6 +94,9 @@ newQuasar = do ensureSTM $ newQuasarSTM worker exChan parentRM +--withResourceScope :: MonadQuasar m => m a -> m a + + class (MonadCatch m, MonadFix m) => MonadQuasar m where askQuasar :: m Quasar maskIfRequired :: m a -> m a @@ -172,7 +193,69 @@ quasarAtomically (QuasarSTM fn) = do (result <$) <$> readTVar effectAwaitableVar enterQuasarIO :: MonadIO m => Quasar -> QuasarIO () -> m () -enterQuasarIO = undefined +enterQuasarIO quasar fn = runQuasarIO quasar $ redirectExceptionToSink_ fn enterQuasarSTM :: MonadQuasar m => Quasar -> QuasarSTM () -> m () -enterQuasarSTM = undefined +enterQuasarSTM quasar fn = ensureQuasarSTM $ localQuasar quasar $ redirectExceptionToSink_ fn + + +redirectExceptionToSink :: MonadQuasar m => m a -> m (Maybe a) +redirectExceptionToSink fn = do + exChan <- askExceptionChannel + (Just <$> fn) `catchAll` + \ex -> ensureSTM (Nothing <$ throwToExceptionChannel exChan ex) + +redirectExceptionToSink_ :: MonadQuasar m => m a -> m () +redirectExceptionToSink_ fn = void $ redirectExceptionToSink fn + + +-- * Quasar initialization + +withQuasarGeneric :: TIOWorker -> ExceptionChannel -> QuasarIO a -> IO a +withQuasarGeneric worker exChan fn = mask \unmask -> do + rm <- atomically $ newUnmanagedResourceManagerSTM worker exChan + let quasar = Quasar worker exChan rm + unmask (runQuasarIO quasar fn) `finally` dispose rm + + +-- * High-level entry helpers + +runQuasarAndExit :: QuasarIO () -> IO a +runQuasarAndExit = + runQuasarAndExitWith \case + QuasarExitSuccess () -> ExitSuccess + QuasarExitAsyncException () -> ExitFailure 1 + QuasarExitMainThreadFailed -> ExitFailure 1 + +data QuasarExitState a = QuasarExitSuccess a | QuasarExitAsyncException a | QuasarExitMainThreadFailed + +runQuasarAndExitWith :: (QuasarExitState a -> ExitCode) -> QuasarIO a -> IO b +runQuasarAndExitWith exitCodeFn fn = mask \unmask -> do + worker <- newTIOWorker + (exChan, exceptionWitness) <- atomically $ newExceptionChannelWitness (loggingExceptionChannel worker) + mResult <- unmask $ withQuasarGeneric worker exChan (redirectExceptionToSink fn) + failure <- atomically exceptionWitness + exitState <- case (mResult, failure) of + (Just result, False) -> pure $ QuasarExitSuccess result + (Just result, True) -> pure $ QuasarExitAsyncException result + (Nothing, True) -> pure QuasarExitMainThreadFailed + (Nothing, False) -> do + traceIO "Invalid code path reached: Main thread failed but no asynchronous exception was witnessed. This is a bug, please report it to the `quasar`-project." + pure QuasarExitMainThreadFailed + exitWith $ exitCodeFn exitState + + +runQuasarCollectExceptions :: QuasarIO a -> IO (Either SomeException a, [SomeException]) +runQuasarCollectExceptions fn = do + (exChan, collectExceptions) <- atomically $ newExceptionCollector panicChannel + worker <- newTIOWorker + result <- try $ withQuasarGeneric worker exChan fn + exceptions <- atomically collectExceptions + pure (result, exceptions) + +runQuasarCombineExceptions :: QuasarIO a -> IO a +runQuasarCombineExceptions fn = do + (result, exceptions) <- runQuasarCollectExceptions fn + case result of + Left (ex :: SomeException) -> maybe (throwM ex) (throwM . CombinedException . (ex <|)) (nonEmpty exceptions) + Right fnResult -> maybe (pure fnResult) (throwM . CombinedException) $ nonEmpty exceptions