diff --git a/quasar/src/Quasar/Exceptions.hs b/quasar/src/Quasar/Exceptions.hs index 3594df21fbc971f986a59a53184702c30876f2b2..b238b994c2a79d16f1f806f5bf6a3a28013b226e 100644 --- a/quasar/src/Quasar/Exceptions.hs +++ b/quasar/src/Quasar/Exceptions.hs @@ -24,26 +24,26 @@ import Control.Monad.Catch import Quasar.Prelude -newtype ExceptionSink = ExceptionSink (SomeException -> STM ()) +newtype ExceptionSink = ExceptionSink (SomeException -> STM' NoRetry NoThrow ()) -throwToExceptionSink :: (Exception e, MonadSTM m) => ExceptionSink -> e -> m () -throwToExceptionSink (ExceptionSink channelFn) ex = liftSTM $ channelFn (toException ex) +throwToExceptionSink :: (Exception e, MonadSTM' r t m) => ExceptionSink -> e -> m () +throwToExceptionSink (ExceptionSink channelFn) ex = noRetry $ noThrow $ channelFn (toException ex) throwToExceptionSinkIO :: (Exception e, MonadIO m) => ExceptionSink -> e -> m () throwToExceptionSinkIO sink ex = atomically $ throwToExceptionSink sink ex -catchSink :: forall e. Exception e => (e -> STM ()) -> ExceptionSink -> ExceptionSink +catchSink :: forall e. Exception e => (e -> STM' NoRetry CanThrow ()) -> ExceptionSink -> ExceptionSink catchSink handler parentSink = ExceptionSink \ex -> case fromException ex of Just matchedException -> wrappedHandler matchedException Nothing -> throwToExceptionSink parentSink ex where - wrappedHandler :: e -> STM () - wrappedHandler ex = catchAll (handler ex) (throwToExceptionSink parentSink) + wrappedHandler :: e -> STM' NoRetry NoThrow () + wrappedHandler ex = catchAllSTM' (handler ex) (throwToExceptionSink parentSink) -catchAllSink :: (SomeException -> STM ()) -> ExceptionSink -> ExceptionSink +catchAllSink :: (SomeException -> STM' NoRetry CanThrow ()) -> ExceptionSink -> ExceptionSink catchAllSink = catchSink diff --git a/quasar/src/Quasar/Exceptions/ExceptionSink.hs b/quasar/src/Quasar/Exceptions/ExceptionSink.hs index 826ac0fd33959f9d6adcc856a8ed6009133e387d..398620b2d6ff4a60a3579024ebce54666da12001 100644 --- a/quasar/src/Quasar/Exceptions/ExceptionSink.hs +++ b/quasar/src/Quasar/Exceptions/ExceptionSink.hs @@ -39,21 +39,21 @@ loggingExceptionSink worker = logFn :: SomeException -> ShortIO () logFn ex = unsafeShortIO $ Trace.traceIO $ displayException ex -newExceptionWitnessSink :: ExceptionSink -> STM (ExceptionSink, STM Bool) -newExceptionWitnessSink exChan = do +newExceptionWitnessSink :: MonadSTM' r t m => ExceptionSink -> m (ExceptionSink, STM' r2 t2 Bool) +newExceptionWitnessSink exChan = liftSTM' do var <- newTVar False let chan = ExceptionSink \ex -> lock var >> throwToExceptionSink exChan ex pure (chan, readTVar var) where - lock :: TVar Bool -> STM () + lock :: TVar Bool -> STM' r t () lock var = unlessM (readTVar var) (writeTVar var True) -newExceptionRedirector :: ExceptionSink -> STM (ExceptionSink, ExceptionSink -> STM ()) +newExceptionRedirector :: MonadSTM' r t m => ExceptionSink -> m (ExceptionSink, ExceptionSink -> STM' r2 t2 ()) newExceptionRedirector initialExceptionSink = do channelVar <- newTVar initialExceptionSink pure (ExceptionSink (channelFn channelVar), writeTVar channelVar) where - channelFn :: TVar ExceptionSink -> SomeException -> STM () + channelFn :: TVar ExceptionSink -> SomeException -> STM' r t () channelFn channelVar ex = do channel <- readTVar channelVar throwToExceptionSink channel ex @@ -61,17 +61,17 @@ newExceptionRedirector initialExceptionSink = do -- | Collects exceptions. After they have been collected (by using the resulting -- transaction), further exceptions are forwarded to the backup exception sink. -- The collection transaction may only be used once. -newExceptionCollector :: ExceptionSink -> STM (ExceptionSink, STM [SomeException]) +newExceptionCollector :: MonadSTM' r t m => ExceptionSink -> m (ExceptionSink, STM' r2 CanThrow [SomeException]) newExceptionCollector backupExceptionSink = do exceptionsVar <- newTVar (Just []) pure (ExceptionSink (channelFn exceptionsVar), gatherResult exceptionsVar) where - channelFn :: TVar (Maybe [SomeException]) -> SomeException -> STM () + channelFn :: TVar (Maybe [SomeException]) -> SomeException -> STM' r t () channelFn exceptionsVar ex = do readTVar exceptionsVar >>= \case Just exceptions -> writeTVar exceptionsVar (Just (ex : exceptions)) Nothing -> throwToExceptionSink backupExceptionSink ex - gatherResult :: TVar (Maybe [SomeException]) -> STM [SomeException] + gatherResult :: TVar (Maybe [SomeException]) -> STM' r CanThrow [SomeException] gatherResult exceptionsVar = swapTVar exceptionsVar Nothing >>= \case Just exceptions -> pure exceptions diff --git a/quasar/src/Quasar/MonadQuasar.hs b/quasar/src/Quasar/MonadQuasar.hs index badcbe743a31989274facbeffe4b4339b1edbdf7..f2c706e35028fc559b182c16b697e4e72e226fd0 100644 --- a/quasar/src/Quasar/MonadQuasar.hs +++ b/quasar/src/Quasar/MonadQuasar.hs @@ -97,7 +97,7 @@ newQuasar :: Logger -> TIOWorker -> ExceptionSink -> ResourceManager -> Quasar newQuasar logger worker parentExceptionSink resourceManager = do Quasar logger worker (ExceptionSink (disposeOnException resourceManager)) resourceManager where - disposeOnException :: ResourceManager -> SomeException -> STM () + disposeOnException :: ResourceManager -> SomeException -> STM' r t () disposeOnException rm ex = do disposeEventually_ rm throwToExceptionSink parentExceptionSink ex @@ -290,7 +290,7 @@ redirectExceptionToSinkIO_ fn = void $ redirectExceptionToSinkIO fn {-# SPECIALIZE redirectExceptionToSinkIO_ :: QuasarIO a -> QuasarIO () #-} -catchQuasar :: MonadQuasar m => forall e. Exception e => (e -> STM ()) -> m a -> m a +catchQuasar :: MonadQuasar m => forall e. Exception e => (e -> STM' NoRetry CanThrow ()) -> m a -> m a catchQuasar handler fn = do exSink <- catchSink handler <$> askExceptionSink replaceExceptionSink exSink fn diff --git a/quasar/src/Quasar/MonadQuasar/Misc.hs b/quasar/src/Quasar/MonadQuasar/Misc.hs index 1cd618defef6b2e673593a31615d4052ce97d204..416976a22e945e7038d8a4b5f8783469639f0b0e 100644 --- a/quasar/src/Quasar/MonadQuasar/Misc.hs +++ b/quasar/src/Quasar/MonadQuasar/Misc.hs @@ -55,7 +55,7 @@ runQuasarAndExitWith exitCodeFn logger fn = mask \unmask -> do worker <- newTIOWorker (exChan, exceptionWitness) <- atomically $ newExceptionWitnessSink (loggingExceptionSink worker) mResult <- unmask $ withQuasar logger worker exChan (redirectExceptionToSinkIO fn) - failure <- atomically exceptionWitness + failure <- atomically' exceptionWitness exitState <- case (mResult, failure) of (Just result, False) -> pure $ QuasarExitSuccess result (Just result, True) -> pure $ QuasarExitAsyncException result @@ -71,7 +71,7 @@ runQuasarCollectExceptions logger fn = do (exChan, collectExceptions) <- atomically $ newExceptionCollector panicSink worker <- newTIOWorker result <- try $ withQuasar logger worker exChan fn - exceptions <- atomically collectExceptions + exceptions <- atomically' collectExceptions pure (result, exceptions) runQuasarCombineExceptions :: Logger -> QuasarIO a -> IO a