in-other-words-0.1.1.0: src/Control/Effect/Exceptional.hs
{-# LANGUAGE DerivingVia #-}
module Control.Effect.Exceptional
( -- * Effects
Exceptional
, SafeError
-- * Actions
, catching
, trying
, throwing
, catchSafe
, trySafe
-- * Interpretations
, runExceptional
, runExceptionalJust
, safeErrorToError
, runSafeError
, safeErrorToIO
, safeErrorToErrorIO
-- * Simple variants of interpretations
, runExceptionalJustSimple
, safeErrorToIOSimple
, safeErrorToErrorIOSimple
-- * Threading constraints
, ErrorThreads
-- * MonadCatch
, MonadCatch
-- * Carriers
, ExceptionallyC
, ExceptionalC
, SafeErrorToErrorC
, SafeErrorC
, SafeErrorToIOC'
, SafeErrorToIOC
, SafeErrorToErrorIOC'
, SafeErrorToErrorIOC
, SafeErrorToIOSimpleC
, SafeErrorToErrorIOSimpleC
) where
import Data.Coerce
import Data.Either
import Control.Effect
import Control.Effect.Error
import Control.Effect.ErrorIO
import Control.Effect.Union
import Control.Effect.Carrier
import Control.Effect.Internal.Utils
import Control.Monad.Trans.Identity
-- For coercion purposes
import Control.Monad.Trans.Except
import Control.Effect.Internal.Error
import Control.Effect.Carrier.Internal.Interpret
import Control.Effect.Carrier.Internal.Intro
import Control.Effect.Carrier.Internal.Compose
-- | An effect that allows for the safe use of an effect @eff@ that may
-- throw exceptions of the type @exc@ by forcing the user to eventually
-- catch those exceptions at some point of the program.
--
-- The main combinator of 'Exceptional' is 'catching'.
--
-- __This could be unsafe in the presence of 'Control.Effect.Conc.Conc'__.
-- If you use 'catching' on a computation that:
--
-- * Spawns an asynchronous computation
-- * Throws an exception inside the asynchronous computation from a use of @eff@
-- * Returns the 'Control.Effect.Conc.Async' of that asynchronous computation
--
-- Then 'Control.Effect.Conc.wait'ing on that 'Control.Effect.Conc.Async'
-- outside of the 'catching' will throw that exception without it being caught.
newtype Exceptional eff exc m a = Exceptional (Union '[eff, Catch exc] m a)
-- | A particularly useful specialization of 'Exceptional', for gaining
-- restricted access to an @'Error' exc@ effect.
-- Main combinators are 'catchSafe' and 'trySafe'.
type SafeError exc = Exceptional (Throw exc) exc
{-
"ExceptionallyC" can easily be implemented using Handler:
data ExceptionallyH exc
instance ( Eff (Exceptional eff exc) m
, RepresentationalEff eff
)
=> Handler (ExceptionallH exc) eff m where where
effHandler e = send $ Exceptionally $ inj e
type ExceptionallyC eff exc = InterpretC (ExceptionallH exc) eff
catching :: forall eff exc m a
. ( Eff (Exceptional eff exc) m
, RepresentationalEff eff
)
=> ExceptionallyC exc eff m a
-> (exc -> m a)
-> m a
catching m h =
send $ Exceptional @eff @exc $
inj (Catch @exc (interpretViaHandler m) h)
We use a standalone carrier to hide the RepresentationalEff constraint,
which is just noise in this case.
-}
newtype ExceptionallyC (eff :: Effect) (exc :: *) m a = ExceptionallyC {
unExceptionallyC :: m a
}
deriving ( Functor, Applicative, Monad
, Alternative, MonadPlus
, MonadFix, MonadFail, MonadIO
, MonadThrow, MonadCatch, MonadMask
, MonadBase b, MonadBaseControl b
)
deriving (MonadTrans, MonadTransControl) via IdentityT
instance Eff (Exceptional eff exc) m
=> Carrier (ExceptionallyC eff exc m) where
type Derivs (ExceptionallyC eff exc m) = eff ': Catch exc ': Derivs m
type Prims (ExceptionallyC eff exc m) = Prims m
algPrims = coerce (algPrims @m)
{-# INLINEABLE algPrims #-}
reformulate n alg =
powerAlg' (
powerAlg (
reformulate (n .# lift) alg
) $ \e ->
reformulate (n .# lift) alg $ inj $
Exceptional @eff @exc (Union (There Here) e)
) $ \e ->
reformulate (n .# lift) alg $ inj $
Exceptional @eff @exc (Union Here e)
{-# INLINEABLE reformulate #-}
algDerivs =
powerAlg' (
powerAlg (
coerce (algDerivs @m)
) $ \e ->
coerceAlg (algDerivs @m) $ inj $ Exceptional @eff @exc (Union (There Here) e)
) $ \e ->
coerceAlg (algDerivs @m) $ inj $ Exceptional @eff @exc (Union Here e)
{-# INLINEABLE algDerivs #-}
-- | Gain access to @eff@ and @'Catch' exc@ within a region,
-- but only if you're ready to handle any unhandled exception @e :: exc@
-- that may arise from the use of @eff@ within that region.
--
-- For example:
--
-- @
-- -- A part of the program unknowing and uncaring that the use of SomeEffect
-- -- may throw exceptions.
-- uncaringProgram :: 'Eff' SomeEffect m => m String
-- uncaringProgram = do
-- doSomeThing
-- doSomeOtherThing
--
-- caringProgram :: 'Eff' ('Exceptional' SomeEffect SomeEffectExc) m => m String
-- caringProgram =
-- 'catching' \@eff uncaringProgram (\\(exc :: SomeEffectExc) -> handlerForSomeEffectExc exc)
-- @
--
catching :: forall eff exc m a
. Eff (Exceptional eff exc) m
=> ExceptionallyC eff exc m a
-> (exc -> m a)
-> m a
catching m h =
send $ Exceptional @eff @exc $
Union (There Here) (Catch (unExceptionallyC m) h)
{-# INLINE catching #-}
-- | Gain access to @'Error' exc@ within a region,
-- but only if you're ready to handle any unhandled exception @e :: exc@
-- that may arise from within that region.
catchSafe :: forall exc m a
. Eff (SafeError exc) m
=> ExceptionallyC (Throw exc) exc m a
-> (exc -> m a)
-> m a
catchSafe = catching
{-# INLINE catchSafe #-}
-- | Gain access to @eff@ within a region. If any use of @eff@
-- within that region 'throw's an unhandled exception @e :: exc@,
-- then this returns @Left e@.
trying :: forall eff exc m a
. Eff (Exceptional eff exc) m
=> ExceptionallyC eff exc m a
-> m (Either exc a)
trying m = fmap Right m `catching` (return . Left)
{-# INLINE trying #-}
-- | Gain access to @'Error' exc@ within a region. If any unhandled exception
-- @e :: exc@ is 'throw'n within that region, then this returns @Left e@.
trySafe :: forall exc m a
. Eff (SafeError exc) m
=> ExceptionallyC (Throw exc) exc m a
-> m (Either exc a)
trySafe = trying
{-# INLINE trySafe #-}
-- | Gain access to @eff@ within a region, rethrowing
-- any exception @e :: exc@ that may occur from the use of
-- @eff@ within that region.
throwing :: forall eff exc m a
. Effs [Exceptional eff exc, Throw exc] m
=> ExceptionallyC eff exc m a
-> m a
throwing m = m `catching` throw
{-# INLINE throwing #-}
data ExceptionalH
instance ( Member eff (Derivs m)
, Eff (Catch exc) m
)
=> Handler ExceptionalH (Exceptional eff exc) m where
-- Explicit pattern mathing and use of 'algDerivs' instead of using
-- 'decomp' and 'send' so that we don't introduce the
-- RepresentationalEff constraint.
effHandler (Exceptional e) = case e of
Union Here eff -> algDerivs (Union membership eff)
Union (There Here) eff -> algDerivs (Union membership eff)
Union (There (There pr)) _ -> absurdMember pr
{-# INLINEABLE effHandler #-}
type ExceptionalC eff exc = InterpretC ExceptionalH (Exceptional eff exc)
type SafeErrorToErrorC exc = ExceptionalC (Throw exc) exc
-- | Run an @'Exceptional' eff exc@ effect if both @eff@ and @'Catch' exc@
-- are part of the effect stack.
--
-- In order for this to be safe, you must ensure that the @'Catch' exc@
-- catches all exceptions that arise from the use of @eff@ and that
-- only uses of @eff@ throws those exceptions.
-- Otherwise, the use of 'catching' is liable to catch
-- exceptions not arising from uses of @eff@, or fail to catch
-- exceptions that do arise from uses of @eff@.
runExceptional :: forall eff exc m a
. ( Member eff (Derivs m)
, Eff (Catch exc) m
)
=> ExceptionalC eff exc m a
-> m a
runExceptional = interpretViaHandler
{-# INLINE runExceptional #-}
-- | Run an @'Exceptional' eff exc@ effect if @eff@ is part of the
-- effect stack, provided a function that identifies the kind of exceptions
-- that may arise from the use of @eff@.
--
-- In order for this to be safe, you must ensure that the function
-- identifies all exceptions that arise from the use of @eff@ and that
-- only uses of @eff@ throws those exceptions.
-- Otherwise, the use of 'catching' is liable to catch
-- other exceptions not arising from uses of @eff@, or fail to catch
-- exceptions that do arise from uses of @eff@.
--
-- The type of this interpreter is higher-rank, as it makes use of
-- 'InterpretReifiedC'. __This makes 'runExceptionalJust' difficult to__
-- __use partially applied; for example, you can't compose it using @'.'@.__
-- You may prefer the simpler, but less performant, 'runExceptionalJustSimple'.
runExceptionalJust :: forall eff smallExc bigExc m a
. ( Member eff (Derivs m)
, Eff (Error bigExc) m
)
=> (bigExc -> Maybe smallExc)
-> InterpretReifiedC (Exceptional eff smallExc) m a
-> m a
runExceptionalJust from = interpret $ \(Exceptional e) -> case e of
Union Here eff -> algDerivs (Union membership eff)
Union (There pr) eff -> case extract (Union pr eff) of
Catch m h -> catchJust from m h
{-# INLINE runExceptionalJust #-}
-- | Run an @'Exceptional' eff exc@ effect if @eff@ is part of the
-- effect stack, provided a function that identifies the kind of exceptions
-- that may arise from the use of @eff@.
--
-- In order for this to be safe, you must ensure that the function
-- identifies all exceptions that arise from the use of @eff@ and that
-- only uses of @eff@ throws those exceptions.
-- Otherwise, the use of 'catching' is liable to catch
-- exceptions not arising from uses of @eff@, or fail to catch
-- exceptions that do arise from uses of @eff@.
--
-- This is a less performant version of 'runExceptionalJust', but doesn't have
-- a higher-rank type. This makes 'runExceptionalJustSimple' much easier to use
-- partially applied.
runExceptionalJustSimple :: forall eff smallExc bigExc m a p
. ( Member eff (Derivs m)
, Eff (Error bigExc) m
, Threaders '[ReaderThreads] m p
)
=> (bigExc -> Maybe smallExc)
-> InterpretSimpleC (Exceptional eff smallExc) m a
-> m a
runExceptionalJustSimple from = interpretSimple $ \(Exceptional e) -> case e of
Union Here eff -> algDerivs (Union membership eff)
Union (There pr) eff -> case extract (Union pr eff) of
Catch m h -> catchJust from m h
{-# INLINE runExceptionalJustSimple #-}
-- | Run a @'SafeError' exc@ effect by transforming it into an @'Error' exc@
-- effect.
safeErrorToError :: forall exc m a
. Eff (Error exc) m
=> SafeErrorToErrorC exc m a
-> m a
safeErrorToError = runExceptional
{-# INLINE safeErrorToError #-}
type SafeErrorC exc = CompositionC
'[ IntroUnderC (SafeError exc) '[Catch exc, Throw exc]
, SafeErrorToErrorC exc
, ErrorC exc
]
-- | Run a @'SafeError' e@ effect purely.
--
-- @'Derivs' ('SafeErrorC' e m) = 'SafeError' e ': 'Prims' m@
--
-- @'Prims' ('SafeErrorC' e m) = 'Control.Effect.Optional.Optional' ((->) e) ': 'Prims' m@
runSafeError :: forall e m a p
. ( Carrier m
, Threaders '[ErrorThreads] m p
)
=> SafeErrorC e m a
-> m a
runSafeError =
fmap (fromRight bombPure)
.# runError
.# safeErrorToError
.# introUnder
.# runComposition
{-# INLINE runSafeError #-}
bombPure :: a
bombPure = errorWithoutStackTrace
"runSafeError: Escaped exception! Unless you've imported some internal \
\modules and did something REALLY stupid, this is a bug. Make an issue about \
\it on the GitHub repository for in-other-words."
bombIO :: String -> a
bombIO str = errorWithoutStackTrace $
str ++ ": Escaped exception! This is likely because an `async`ed exceptional \
\computation escaped a `catching` through an `Async`. See \
\Control.Effect.Exceptional.Exceptional. If that sounds unlikely, and you \
\didn't import any internal modules and do something really stupid, \
\then this could be a bug. If so, make an issue about \
\it on the GitHub repository for in-other-words."
type SafeErrorToIOC' s s' exc = CompositionC
'[ IntroUnderC (SafeError exc) '[Catch exc, Throw exc]
, SafeErrorToErrorC exc
, ErrorToIOC' s s' exc
]
type SafeErrorToIOC e m a =
forall s s'
. ReifiesErrorHandler s s' e (ErrorIOToIOC m)
=> SafeErrorToIOC' s s' e m a
-- | Runs a @'SafeError' e@ effect by making use of 'IO' exceptions.
--
-- @'Derivs' ('SafeErrorToIOC' e m) = 'SafeError' e ': 'Derivs' m@
--
-- @'Prims' ('SafeErrorToIOC' e m) = 'Control.Effect.Optional.Optional' ((->) 'Control.Exception.SomeException') ': 'Prims' m@
--
-- This has a higher-rank type, as it makes use of 'SafeErrorToIOC'.
-- __This makes 'safeErrorToIO' very difficult to use partially applied.__
-- __In particular, it can't be composed using @'.'@.__
--
-- If performance is secondary, consider using the slower
-- 'safeErrorToIOSimple', which doesn't have a higher-rank type.
safeErrorToIO :: forall e m a
. ( Eff (Embed IO) m
, MonadCatch m
)
=> SafeErrorToIOC e m a
-> m a
safeErrorToIO m =
fmap (fromRight (bombIO "safeErrorToIO"))
$ errorToIO
$ safeErrorToError
$ introUnder
$ runComposition
$ m
{-# INLINE safeErrorToIO #-}
type SafeErrorToErrorIOC' s s' exc = CompositionC
'[ IntroUnderC (SafeError exc) '[Catch exc, Throw exc]
, SafeErrorToErrorC exc
, InterpretErrorC' s s' exc
]
type SafeErrorToErrorIOC e m a =
forall s s'
. ReifiesErrorHandler s s' e m
=> SafeErrorToErrorIOC' s s' e m a
-- | Runs a @'SafeError' e@ effect by transforming it into 'ErrorIO'
-- and @'Embed' IO@.
--
-- This has a higher-rank type, as it makes use of 'SafeErrorToErrorIOC'.
-- __This makes 'safeErrorToErrorIO' very difficult to use partially applied.__
-- __In particular, it can't be composed using @'.'@.__
--
-- If performance is secondary, consider using the slower
-- 'safeErrorToErrorIOSimple', which doesn't have a higher-rank type.
safeErrorToErrorIO :: forall e m a
. Effs '[Embed IO, ErrorIO] m
=> SafeErrorToErrorIOC e m a
-> m a
safeErrorToErrorIO m =
fmap (fromRight (bombIO "safeErrorToErrorIO"))
$ errorToErrorIO
$ safeErrorToError
$ introUnder
$ runComposition
$ m
{-# INLINE safeErrorToErrorIO #-}
type SafeErrorToIOSimpleC exc = CompositionC
'[ IntroUnderC (SafeError exc) '[Catch exc, Throw exc]
, SafeErrorToErrorC exc
, ErrorToIOSimpleC exc
]
-- | Runs a @'SafeError' e@ effect by making use of 'IO' exceptions.
--
-- @'Derivs' ('SafeErrorToIOSimpleC' e m) = 'SafeError' e ': 'Derivs' m@
--
-- @'Prims' ('SafeErrorToIOSimpleC' e m) = 'Control.Effect.Optional.Optional' ((->) 'Control.Exception.SomeException') ': 'Prims' m@
--
-- This is a less performant version of 'safeErrorToIO' that doesn't have
-- a higher-rank type, making it much easier to use partially applied.
safeErrorToIOSimple :: forall e m a p
. ( Eff (Embed IO) m
, MonadCatch m
, Threaders '[ReaderThreads] m p
)
=> SafeErrorToIOSimpleC e m a
-> m a
safeErrorToIOSimple =
fmap (fromRight (bombIO "safeErrorToIOSimple"))
. errorToIOSimple
.# safeErrorToError
.# introUnder
.# runComposition
{-# INLINE safeErrorToIOSimple #-}
type SafeErrorToErrorIOSimpleC exc = CompositionC
'[ IntroUnderC (SafeError exc) '[Catch exc, Throw exc]
, SafeErrorToErrorC exc
, InterpretErrorSimpleC exc
]
-- | Runs a @'SafeError' e@ effect by transforming it into 'ErrorIO'
-- and @'Embed' IO@.
--
-- This is a less performant version of 'safeErrorToErrorIO' that doesn't have
-- a higher-rank type, making it much easier to use partially applied.
safeErrorToErrorIOSimple :: forall e m a p
. ( Effs '[ErrorIO, Embed IO] m
, Threaders '[ReaderThreads] m p
)
=> SafeErrorToErrorIOSimpleC e m a
-> m a
safeErrorToErrorIOSimple =
fmap (fromRight (bombIO "safeErrorToErrorIOSimple"))
. errorToErrorIOSimple
.# safeErrorToError
.# introUnder
.# runComposition
{-# INLINE safeErrorToErrorIOSimple #-}