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 Control.Effect
import Control.Effect.Error
import Control.Effect.ErrorIO
import Control.Effect.Union

import Control.Effect.Carrier

import Control.Effect.Internal.Exceptional
import Control.Effect.Internal.Utils

-- 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

-- | 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' \@SomeEffect uncaringProgram (\\(exc :: SomeEffectExc) -> handlerForSomeEffectExc exc)
-- @
--
-- It's possible the @'Catch' exc@ effect @'catching'@ gives you access to
-- would override another, identical @'Catch' exc@ effect that you want to use
-- inside the region. To avoid this, use 'catching' together with 'intro1':
--
-- @'catching' \@SomeEffect ('intro1' uncaringProgram) ...@
--
-- If you do this, then @'catching'@ will only introduce @eff@ to be used
-- in @uncaringProgram@, and not @'Catch' 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@ and @'Catch' exc@ 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@ and @'Catch' exc@ 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 #-}

-- | 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 #-}

-- | 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 =
    (>>= either (\_ -> bombPure) return)
  .# runError
  .# safeErrorToError
  .# introUnder
  .# unSafeErrorC
{-# 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."


-- | 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 =
    (>>= either (\_ -> bombIO "safeErrorToIO") return)
  $ errorToIO
  $ safeErrorToError
  $ introUnder
  $ unSafeErrorToIOC'
  $ m
{-# INLINE safeErrorToIO #-}


-- | 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 =
    (>>= either (\_ -> bombIO "safeErrorToErrorIO") return)
  $ errorToErrorIO
  $ safeErrorToError
  $ introUnder
  $ unSafeErrorToErrorIOC'
  $ m
{-# INLINE safeErrorToErrorIO #-}

-- | 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 =
     (>>= either (\_ -> bombIO "safeErrorToIOSimple") return)
  .  errorToIOSimple
  .# safeErrorToError
  .# introUnder
  .# unSafeErrorToIOSimpleC
{-# INLINE safeErrorToIOSimple #-}

-- | 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 =
     (>>= either (\_ -> bombIO "safeErrorToErrorIOSimple") return)
  .  errorToErrorIOSimple
  .# safeErrorToError
  .# introUnder
  .# unSafeErrorToErrorIOSimpleC
{-# INLINE safeErrorToErrorIOSimple #-}