{-# LANGUAGE BlockArguments #-}
module Control.Effect.Error
(
Throw(..)
, Catch(..)
, Error
, throw
, catch
, try
, catchJust
, tryJust
, note
, fromEither
, runThrow
, runError
, errorToIO
, errorToErrorIO
, throwToThrow
, catchToError
, errorToError
, errorToIOSimple
, errorToErrorIOSimple
, throwToThrowSimple
, catchToErrorSimple
, errorToErrorSimple
, ErrorThreads
, C.MonadCatch
, ThrowC
, ErrorC
, ErrorToIOC
, ErrorToIOC'
, ReifiesErrorHandler
, InterpretErrorC
, InterpretErrorC'
, ErrorToIOSimpleC
, InterpretErrorSimpleC
) where
import Data.Function
import Data.Coerce
import Control.Effect
import Control.Effect.ErrorIO
import Control.Effect.Type.Throw
import Control.Effect.Type.Catch
import Control.Effect.Internal.Error
import qualified Control.Exception as X
import qualified Control.Monad.Catch as C
import Control.Effect.Internal.Utils
import Control.Monad.Trans.Except
import Control.Effect.Carrier.Internal.Interpret
import Control.Effect.Carrier.Internal.Intro
import Control.Effect.Carrier.Internal.Compose
import Control.Monad.Trans.Identity
import Data.Unique
import GHC.Exts (Any)
import Unsafe.Coerce
throw :: Eff (Throw e) m => e -> m a
throw :: e -> m a
throw = Throw e m a -> m a
forall (e :: Effect) (m :: * -> *) a.
(Member e (Derivs m), Carrier m) =>
e m a -> m a
send (Throw e m a -> m a) -> (e -> Throw e m a) -> e -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Throw e m a
forall e (m :: * -> *) a. e -> Throw e m a
Throw
{-# INLINE throw #-}
catch :: Eff (Catch e) m => m a -> (e -> m a) -> m a
catch :: m a -> (e -> m a) -> m a
catch m a
m e -> m a
h = Catch e m a -> m a
forall (e :: Effect) (m :: * -> *) a.
(Member e (Derivs m), Carrier m) =>
e m a -> m a
send (m a -> (e -> m a) -> Catch e m a
forall (m :: * -> *) a e. m a -> (e -> m a) -> Catch e m a
Catch m a
m e -> m a
h)
{-# INLINE catch #-}
try :: Eff (Catch e) m => m a -> m (Either e a)
try :: m a -> m (Either e a)
try m a
m = (a -> Either e a) -> m a -> m (Either e a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either e a
forall a b. b -> Either a b
Right m a
m m (Either e a) -> (e -> m (Either e a)) -> m (Either e a)
forall e (m :: * -> *) a.
Eff (Catch e) m =>
m a -> (e -> m a) -> m a
`catch` (Either e a -> m (Either e a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either e a -> m (Either e a))
-> (e -> Either e a) -> e -> m (Either e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Either e a
forall a b. a -> Either a b
Left)
{-# INLINE try #-}
catchJust :: forall smallExc bigExc m a
. Eff (Error bigExc) m
=> (bigExc -> Maybe smallExc)
-> m a
-> (smallExc -> m a)
-> m a
catchJust :: (bigExc -> Maybe smallExc) -> m a -> (smallExc -> m a) -> m a
catchJust bigExc -> Maybe smallExc
f m a
m smallExc -> m a
h = m a
m m a -> (bigExc -> m a) -> m a
forall e (m :: * -> *) a.
Eff (Catch e) m =>
m a -> (e -> m a) -> m a
`catch` \bigExc
e -> m a -> (smallExc -> m a) -> Maybe smallExc -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (bigExc -> m a
forall e (m :: * -> *) a. Eff (Throw e) m => e -> m a
throw bigExc
e) smallExc -> m a
h (bigExc -> Maybe smallExc
f bigExc
e)
{-# INLINE catchJust #-}
tryJust :: forall smallExc bigExc m a
. Eff (Error bigExc) m
=> (bigExc -> Maybe smallExc)
-> m a
-> m (Either smallExc a)
tryJust :: (bigExc -> Maybe smallExc) -> m a -> m (Either smallExc a)
tryJust bigExc -> Maybe smallExc
f m a
m = (a -> Either smallExc a) -> m a -> m (Either smallExc a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either smallExc a
forall a b. b -> Either a b
Right m a
m m (Either smallExc a)
-> (m (Either smallExc a)
-> (smallExc -> m (Either smallExc a)) -> m (Either smallExc a))
-> (smallExc -> m (Either smallExc a))
-> m (Either smallExc a)
forall a b. a -> (a -> b) -> b
&((bigExc -> Maybe smallExc)
-> m (Either smallExc a)
-> (smallExc -> m (Either smallExc a))
-> m (Either smallExc a)
forall smallExc bigExc (m :: * -> *) a.
Eff (Error bigExc) m =>
(bigExc -> Maybe smallExc) -> m a -> (smallExc -> m a) -> m a
catchJust bigExc -> Maybe smallExc
f)((smallExc -> m (Either smallExc a)) -> m (Either smallExc a))
-> (smallExc -> m (Either smallExc a)) -> m (Either smallExc a)
forall a b. (a -> b) -> a -> b
$ (Either smallExc a -> m (Either smallExc a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either smallExc a -> m (Either smallExc a))
-> (smallExc -> Either smallExc a)
-> smallExc
-> m (Either smallExc a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. smallExc -> Either smallExc a
forall a b. a -> Either a b
Left)
{-# INLINE tryJust #-}
note :: Eff (Throw e) m => e -> Maybe a -> m a
note :: e -> Maybe a -> m a
note e
_ (Just a
a) = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
note e
e Maybe a
Nothing = e -> m a
forall e (m :: * -> *) a. Eff (Throw e) m => e -> m a
throw e
e
{-# INLINE note #-}
fromEither :: Eff (Throw e) m => Either e a -> m a
fromEither :: Either e a -> m a
fromEither = (e -> m a) -> (a -> m a) -> Either e a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> m a
forall e (m :: * -> *) a. Eff (Throw e) m => e -> m a
throw a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINE fromEither #-}
runThrow :: forall e m a p
. ( Carrier m
, Threaders '[ErrorThreads] m p
)
=> ThrowC e m a
-> m (Either e a)
runThrow :: ThrowC e m a -> m (Either e a)
runThrow = ThrowC e m a -> m (Either e a)
coerce
{-# INLINE runThrow #-}
runError :: forall e m a p
. ( Carrier m
, Threaders '[ErrorThreads] m p
)
=> ErrorC e m a
-> m (Either e a)
runError :: ErrorC e m a -> m (Either e a)
runError = ErrorC e m a -> m (Either e a)
coerce
{-# INLINE runError #-}
throwToThrow :: forall smallExc bigExc m a
. Eff (Throw bigExc) m
=> (smallExc -> bigExc)
-> InterpretReifiedC (Throw smallExc) m a
-> m a
throwToThrow :: (smallExc -> bigExc)
-> InterpretReifiedC (Throw smallExc) m a -> m a
throwToThrow smallExc -> bigExc
to = EffHandler (Throw smallExc) m
-> InterpretReifiedC (Throw smallExc) m a -> m a
forall (e :: Effect) (m :: * -> *) a.
(RepresentationalEff e, Carrier m) =>
EffHandler e m -> InterpretReifiedC e m a -> m a
interpret (EffHandler (Throw smallExc) m
-> InterpretReifiedC (Throw smallExc) m a -> m a)
-> EffHandler (Throw smallExc) m
-> InterpretReifiedC (Throw smallExc) m a
-> m a
forall a b. (a -> b) -> a -> b
$ \case
Throw e -> bigExc -> Effly z x
forall e (m :: * -> *) a. Eff (Throw e) m => e -> m a
throw (smallExc -> bigExc
to smallExc
e)
{-# INLINE throwToThrow #-}
catchToError :: forall smallExc bigExc m a
. Eff (Error bigExc) m
=> (bigExc -> Maybe smallExc)
-> InterpretReifiedC (Catch smallExc) m a
-> m a
catchToError :: (bigExc -> Maybe smallExc)
-> InterpretReifiedC (Catch smallExc) m a -> m a
catchToError bigExc -> Maybe smallExc
from = EffHandler (Catch smallExc) m
-> InterpretReifiedC (Catch smallExc) m a -> m a
forall (e :: Effect) (m :: * -> *) a.
(RepresentationalEff e, Carrier m) =>
EffHandler e m -> InterpretReifiedC e m a -> m a
interpret (EffHandler (Catch smallExc) m
-> InterpretReifiedC (Catch smallExc) m a -> m a)
-> EffHandler (Catch smallExc) m
-> InterpretReifiedC (Catch smallExc) m a
-> m a
forall a b. (a -> b) -> a -> b
$ \case
Catch m h -> Effly z x
m Effly z x
-> (Effly z x -> (smallExc -> Effly z x) -> Effly z x)
-> (smallExc -> Effly z x)
-> Effly z x
forall a b. a -> (a -> b) -> b
&((bigExc -> Maybe smallExc)
-> Effly z x -> (smallExc -> Effly z x) -> Effly z x
forall smallExc bigExc (m :: * -> *) a.
Eff (Error bigExc) m =>
(bigExc -> Maybe smallExc) -> m a -> (smallExc -> m a) -> m a
catchJust bigExc -> Maybe smallExc
from)((smallExc -> Effly z x) -> Effly z x)
-> (smallExc -> Effly z x) -> Effly z x
forall a b. (a -> b) -> a -> b
$ smallExc -> Effly z x
h
{-# INLINE catchToError #-}
type ReifiesErrorHandler s s' e m =
( ReifiesHandler s (Catch e) (InterpretC (ViaReifiedH s') (Throw e) m)
, ReifiesHandler s' (Throw e) m
)
type InterpretErrorC' s s' smallExc = CompositionC
'[ InterpretC (ViaReifiedH s) (Catch smallExc)
, InterpretC (ViaReifiedH s') (Throw smallExc)
]
type InterpretErrorC e m a =
forall s s'
. ReifiesErrorHandler s s' e m
=> InterpretErrorC' s s' e m a
errorToError :: forall smallExc bigExc m a
. Eff (Error bigExc) m
=> (smallExc -> bigExc)
-> (bigExc -> Maybe smallExc)
-> InterpretErrorC smallExc m a
-> m a
errorToError :: (smallExc -> bigExc)
-> (bigExc -> Maybe smallExc)
-> InterpretErrorC smallExc m a
-> m a
errorToError smallExc -> bigExc
to bigExc -> Maybe smallExc
from InterpretErrorC smallExc m a
m0 =
(smallExc -> bigExc)
-> InterpretReifiedC (Throw smallExc) m a -> m a
forall smallExc bigExc (m :: * -> *) a.
Eff (Throw bigExc) m =>
(smallExc -> bigExc)
-> InterpretReifiedC (Throw smallExc) m a -> m a
throwToThrow smallExc -> bigExc
to
(InterpretReifiedC (Throw smallExc) m a -> m a)
-> InterpretReifiedC (Throw smallExc) m a -> m a
forall a b. (a -> b) -> a -> b
$ EffHandler
(Catch smallExc) (InterpretC (ViaReifiedH s) (Throw smallExc) m)
-> InterpretReifiedC
(Catch smallExc) (InterpretC (ViaReifiedH s) (Throw smallExc) m) a
-> InterpretC (ViaReifiedH s) (Throw smallExc) m a
forall (e :: Effect) (m :: * -> *) a.
(RepresentationalEff e, Carrier m) =>
EffHandler e m -> InterpretReifiedC e m a -> m a
interpret \case
Catch m h -> Effly z x
m Effly z x -> (bigExc -> Effly z x) -> Effly z x
forall e (m :: * -> *) a.
Eff (Catch e) m =>
m a -> (e -> m a) -> m a
`catch` \bigExc
e -> case bigExc -> Maybe smallExc
from bigExc
e of
Just smallExc
e' -> smallExc -> Effly z x
h smallExc
e'
Maybe smallExc
Nothing -> IntroTopC '[Throw smallExc] (Effly z) x -> Effly z x
forall (e :: Effect) (m :: * -> *) a.
IntroConsistent '[] '[e] m =>
IntroTopC '[e] m a -> m a
intro1 (IntroTopC '[Throw smallExc] (Effly z) x -> Effly z x)
-> IntroTopC '[Throw smallExc] (Effly z) x -> Effly z x
forall a b. (a -> b) -> a -> b
$ bigExc -> IntroTopC '[Throw smallExc] (Effly z) x
forall e (m :: * -> *) a. Eff (Throw e) m => e -> m a
throw bigExc
e
(InterpretReifiedC
(Catch smallExc) (InterpretC (ViaReifiedH s) (Throw smallExc) m) a
-> InterpretC (ViaReifiedH s) (Throw smallExc) m a)
-> InterpretReifiedC
(Catch smallExc) (InterpretC (ViaReifiedH s) (Throw smallExc) m) a
-> InterpretC (ViaReifiedH s) (Throw smallExc) m a
forall a b. (a -> b) -> a -> b
$ CompositionC
'[InterpretC (ViaReifiedH s) (Catch smallExc),
InterpretC (ViaReifiedH s) (Throw smallExc)]
m
a
-> CompositionBaseM
'[InterpretC (ViaReifiedH s) (Catch smallExc),
InterpretC (ViaReifiedH s) (Throw smallExc)]
m
a
forall (ts :: [Effect]) (m :: * -> *) a.
CompositionC ts m a -> CompositionBaseM ts m a
runComposition
(CompositionC
'[InterpretC (ViaReifiedH s) (Catch smallExc),
InterpretC (ViaReifiedH s) (Throw smallExc)]
m
a
-> CompositionBaseM
'[InterpretC (ViaReifiedH s) (Catch smallExc),
InterpretC (ViaReifiedH s) (Throw smallExc)]
m
a)
-> CompositionC
'[InterpretC (ViaReifiedH s) (Catch smallExc),
InterpretC (ViaReifiedH s) (Throw smallExc)]
m
a
-> CompositionBaseM
'[InterpretC (ViaReifiedH s) (Catch smallExc),
InterpretC (ViaReifiedH s) (Throw smallExc)]
m
a
forall a b. (a -> b) -> a -> b
$ CompositionC
'[InterpretC (ViaReifiedH s) (Catch smallExc),
InterpretC (ViaReifiedH s) (Throw smallExc)]
m
a
InterpretErrorC smallExc m a
m0
{-# INLINE errorToError #-}
data OpaqueExc = OpaqueExc Unique Any
instance Show OpaqueExc where
showsPrec :: Int -> OpaqueExc -> ShowS
showsPrec Int
_ (OpaqueExc Unique
uniq Any
_) =
String -> ShowS
showString String
"errorToIO/errorToErrorIO: Escaped opaque exception. \
\Unique hash is: " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Show a => a -> ShowS
shows (Unique -> Int
hashUnique Unique
uniq) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
". \
\This should only happen if the computation that threw the \
\exception was somehow invoked outside of the argument of \
\'errorToIO'; for example, if you 'async' an exceptional \
\computation inside of the argument provided to 'errorToIO', \
\and then 'await' on it *outside* of the argument provided to \
\'errorToIO'. \
\If that or any similar shenanigans seems unlikely, then \
\please open an issue on the GitHub repository."
instance X.Exception OpaqueExc
errorToErrorIO :: forall e m a
. Effs '[ErrorIO, Embed IO] m
=> InterpretErrorC e m a
-> m (Either e a)
errorToErrorIO :: InterpretErrorC e m a -> m (Either e a)
errorToErrorIO InterpretErrorC e m a
main = do
!Unique
uniq <- IO Unique -> m Unique
forall (b :: * -> *) (m :: * -> *) a. Eff (Embed b) m => b a -> m a
embed IO Unique
newUnique
let
main' :: m a
main' =
EffHandler (Throw e) m -> InterpretReifiedC (Throw e) m a -> m a
forall (e :: Effect) (m :: * -> *) a.
(RepresentationalEff e, Carrier m) =>
EffHandler e m -> InterpretReifiedC e m a -> m a
interpret \case
Throw e -> OpaqueExc -> Effly z x
forall e (m :: * -> *) a. (Exception e, Eff ErrorIO m) => e -> m a
throwIO (Unique -> Any -> OpaqueExc
OpaqueExc Unique
uniq (e -> Any
forall a b. a -> b
unsafeCoerce e
e))
(InterpretReifiedC (Throw e) m a -> m a)
-> InterpretReifiedC (Throw e) m a -> m a
forall a b. (a -> b) -> a -> b
$ EffHandler (Catch e) (InterpretC (ViaReifiedH s) (Throw e) m)
-> InterpretReifiedC
(Catch e) (InterpretC (ViaReifiedH s) (Throw e) m) a
-> InterpretC (ViaReifiedH s) (Throw e) m a
forall (e :: Effect) (m :: * -> *) a.
(RepresentationalEff e, Carrier m) =>
EffHandler e m -> InterpretReifiedC e m a -> m a
interpret \case
Catch m h -> Effly z x
m Effly z x -> (OpaqueExc -> Effly z x) -> Effly z x
forall e (m :: * -> *) a.
(Exception e, Eff ErrorIO m) =>
m a -> (e -> m a) -> m a
`catchIO` \exc :: OpaqueExc
exc@(OpaqueExc Unique
uniq' Any
e) ->
if Unique
uniq Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
uniq' then
e -> Effly z x
h (Any -> e
forall a b. a -> b
unsafeCoerce Any
e)
else
OpaqueExc -> Effly z x
forall e (m :: * -> *) a. (Exception e, Eff ErrorIO m) => e -> m a
throwIO OpaqueExc
exc
(InterpretReifiedC
(Catch e) (InterpretC (ViaReifiedH s) (Throw e) m) a
-> InterpretC (ViaReifiedH s) (Throw e) m a)
-> InterpretReifiedC
(Catch e) (InterpretC (ViaReifiedH s) (Throw e) m) a
-> InterpretC (ViaReifiedH s) (Throw e) m a
forall a b. (a -> b) -> a -> b
$ CompositionC
'[InterpretC (ViaReifiedH s) (Catch e),
InterpretC (ViaReifiedH s) (Throw e)]
m
a
-> CompositionBaseM
'[InterpretC (ViaReifiedH s) (Catch e),
InterpretC (ViaReifiedH s) (Throw e)]
m
a
forall (ts :: [Effect]) (m :: * -> *) a.
CompositionC ts m a -> CompositionBaseM ts m a
runComposition
(CompositionC
'[InterpretC (ViaReifiedH s) (Catch e),
InterpretC (ViaReifiedH s) (Throw e)]
m
a
-> CompositionBaseM
'[InterpretC (ViaReifiedH s) (Catch e),
InterpretC (ViaReifiedH s) (Throw e)]
m
a)
-> CompositionC
'[InterpretC (ViaReifiedH s) (Catch e),
InterpretC (ViaReifiedH s) (Throw e)]
m
a
-> CompositionBaseM
'[InterpretC (ViaReifiedH s) (Catch e),
InterpretC (ViaReifiedH s) (Throw e)]
m
a
forall a b. (a -> b) -> a -> b
$ CompositionC
'[InterpretC (ViaReifiedH s) (Catch e),
InterpretC (ViaReifiedH s) (Throw e)]
m
a
InterpretErrorC e m a
main
(a -> Either e a) -> m a -> m (Either e a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either e a
forall a b. b -> Either a b
Right m a
main' m (Either e a) -> (OpaqueExc -> m (Either e a)) -> m (Either e a)
forall e (m :: * -> *) a.
(Exception e, Eff ErrorIO m) =>
m a -> (e -> m a) -> m a
`catchIO` \exc :: OpaqueExc
exc@(OpaqueExc Unique
uniq' Any
e) ->
if Unique
uniq Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
uniq' then
Either e a -> m (Either e a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either e a -> m (Either e a)) -> Either e a -> m (Either e a)
forall a b. (a -> b) -> a -> b
$ e -> Either e a
forall a b. a -> Either a b
Left (Any -> e
forall a b. a -> b
unsafeCoerce Any
e)
else
OpaqueExc -> m (Either e a)
forall e (m :: * -> *) a. (Exception e, Eff ErrorIO m) => e -> m a
throwIO OpaqueExc
exc
type ErrorToIOC' s s' e = CompositionC
'[ IntroC '[Catch e, Throw e] '[ErrorIO]
, InterpretErrorC' s s' e
, ErrorIOToIOC
]
type ErrorToIOC e m a =
forall s s'
. ReifiesErrorHandler s s' e (ErrorIOToIOC m)
=> ErrorToIOC' s s' e m a
errorToIO :: forall e m a
. ( C.MonadCatch m
, Eff (Embed IO) m
)
=> ErrorToIOC e m a
-> m (Either e a)
errorToIO :: ErrorToIOC e m a -> m (Either e a)
errorToIO ErrorToIOC e m a
m =
ErrorIOToIOC m (Either e a) -> m (Either e a)
forall (m :: * -> *) a.
(Carrier m, MonadCatch m) =>
ErrorIOToIOC m a -> m a
errorIOToIO
(ErrorIOToIOC m (Either e a) -> m (Either e a))
-> ErrorIOToIOC m (Either e a) -> m (Either e a)
forall a b. (a -> b) -> a -> b
$ InterpretErrorC
e
(CompositionC
'[ReinterpretC
ErrorIOFinalH ErrorIO '[Optional ((->) SomeException)],
InterpretPrimC ErrorIOFinalH (Optional ((->) SomeException))]
m)
a
-> ErrorIOToIOC m (Either e a)
forall e (m :: * -> *) a.
Effs '[ErrorIO, Embed IO] m =>
InterpretErrorC e m a -> m (Either e a)
errorToErrorIO
(InterpretErrorC
e
(CompositionC
'[ReinterpretC
ErrorIOFinalH ErrorIO '[Optional ((->) SomeException)],
InterpretPrimC ErrorIOFinalH (Optional ((->) SomeException))]
m)
a
-> ErrorIOToIOC m (Either e a))
-> InterpretErrorC
e
(CompositionC
'[ReinterpretC
ErrorIOFinalH ErrorIO '[Optional ((->) SomeException)],
InterpretPrimC ErrorIOFinalH (Optional ((->) SomeException))]
m)
a
-> ErrorIOToIOC m (Either e a)
forall a b. (a -> b) -> a -> b
$ IntroUnderManyC
'[Catch e, Throw e]
'[ErrorIO]
(CompositionC
'[InterpretC (ViaReifiedH s) (Catch e),
InterpretC (ViaReifiedH s') (Throw e)]
(CompositionC
'[ReinterpretC
ErrorIOFinalH ErrorIO '[Optional ((->) SomeException)],
InterpretPrimC ErrorIOFinalH (Optional ((->) SomeException))]
m))
a
-> CompositionC
'[InterpretC (ViaReifiedH s) (Catch e),
InterpretC (ViaReifiedH s') (Throw e)]
(CompositionC
'[ReinterpretC
ErrorIOFinalH ErrorIO '[Optional ((->) SomeException)],
InterpretPrimC ErrorIOFinalH (Optional ((->) SomeException))]
m)
a
forall (top :: [Effect]) (new :: [Effect]) (m :: * -> *) a.
(KnownList top, KnownList new, IntroConsistent top new m) =>
IntroUnderManyC top new m a -> m a
introUnderMany
(IntroUnderManyC
'[Catch e, Throw e]
'[ErrorIO]
(CompositionC
'[InterpretC (ViaReifiedH s) (Catch e),
InterpretC (ViaReifiedH s') (Throw e)]
(CompositionC
'[ReinterpretC
ErrorIOFinalH ErrorIO '[Optional ((->) SomeException)],
InterpretPrimC ErrorIOFinalH (Optional ((->) SomeException))]
m))
a
-> CompositionC
'[InterpretC (ViaReifiedH s) (Catch e),
InterpretC (ViaReifiedH s') (Throw e)]
(CompositionC
'[ReinterpretC
ErrorIOFinalH ErrorIO '[Optional ((->) SomeException)],
InterpretPrimC ErrorIOFinalH (Optional ((->) SomeException))]
m)
a)
-> IntroUnderManyC
'[Catch e, Throw e]
'[ErrorIO]
(CompositionC
'[InterpretC (ViaReifiedH s) (Catch e),
InterpretC (ViaReifiedH s') (Throw e)]
(CompositionC
'[ReinterpretC
ErrorIOFinalH ErrorIO '[Optional ((->) SomeException)],
InterpretPrimC ErrorIOFinalH (Optional ((->) SomeException))]
m))
a
-> CompositionC
'[InterpretC (ViaReifiedH s) (Catch e),
InterpretC (ViaReifiedH s') (Throw e)]
(CompositionC
'[ReinterpretC
ErrorIOFinalH ErrorIO '[Optional ((->) SomeException)],
InterpretPrimC ErrorIOFinalH (Optional ((->) SomeException))]
m)
a
forall a b. (a -> b) -> a -> b
$ CompositionC
'[IntroC '[Catch e, Throw e] '[ErrorIO], InterpretErrorC' s s' e,
ErrorIOToIOC]
m
a
-> CompositionBaseM
'[IntroC '[Catch e, Throw e] '[ErrorIO], InterpretErrorC' s s' e,
ErrorIOToIOC]
m
a
forall (ts :: [Effect]) (m :: * -> *) a.
CompositionC ts m a -> CompositionBaseM ts m a
runComposition
(CompositionC
'[IntroC '[Catch e, Throw e] '[ErrorIO], InterpretErrorC' s s' e,
ErrorIOToIOC]
m
a
-> CompositionBaseM
'[IntroC '[Catch e, Throw e] '[ErrorIO], InterpretErrorC' s s' e,
ErrorIOToIOC]
m
a)
-> CompositionC
'[IntroC '[Catch e, Throw e] '[ErrorIO], InterpretErrorC' s s' e,
ErrorIOToIOC]
m
a
-> CompositionBaseM
'[IntroC '[Catch e, Throw e] '[ErrorIO], InterpretErrorC' s s' e,
ErrorIOToIOC]
m
a
forall a b. (a -> b) -> a -> b
$ CompositionC
'[IntroC '[Catch e, Throw e] '[ErrorIO], InterpretErrorC' s s' e,
ErrorIOToIOC]
m
a
ErrorToIOC e m a
m
{-# INLINE errorToIO #-}
throwToThrowSimple :: forall smallExc bigExc m a p
. ( Eff (Throw bigExc) m
, Threaders '[ReaderThreads] m p
)
=> (smallExc -> bigExc)
-> InterpretSimpleC (Throw smallExc) m a
-> m a
throwToThrowSimple :: (smallExc -> bigExc)
-> InterpretSimpleC (Throw smallExc) m a -> m a
throwToThrowSimple smallExc -> bigExc
to = EffHandler (Throw smallExc) m
-> InterpretSimpleC (Throw smallExc) m a -> m a
forall (e :: Effect) (m :: * -> *) a (p :: [Effect]).
(RepresentationalEff e, Threaders '[ReaderThreads] m p,
Carrier m) =>
EffHandler e m -> InterpretSimpleC e m a -> m a
interpretSimple (EffHandler (Throw smallExc) m
-> InterpretSimpleC (Throw smallExc) m a -> m a)
-> EffHandler (Throw smallExc) m
-> InterpretSimpleC (Throw smallExc) m a
-> m a
forall a b. (a -> b) -> a -> b
$ \case
Throw e -> bigExc -> Effly z x
forall e (m :: * -> *) a. Eff (Throw e) m => e -> m a
throw (smallExc -> bigExc
to smallExc
e)
{-# INLINE throwToThrowSimple #-}
catchToErrorSimple :: forall smallExc bigExc m a p
. ( Eff (Error bigExc) m
, Threaders '[ReaderThreads] m p
)
=> (bigExc -> Maybe smallExc)
-> InterpretSimpleC (Catch smallExc) m a
-> m a
catchToErrorSimple :: (bigExc -> Maybe smallExc)
-> InterpretSimpleC (Catch smallExc) m a -> m a
catchToErrorSimple bigExc -> Maybe smallExc
from = EffHandler (Catch smallExc) m
-> InterpretSimpleC (Catch smallExc) m a -> m a
forall (e :: Effect) (m :: * -> *) a (p :: [Effect]).
(RepresentationalEff e, Threaders '[ReaderThreads] m p,
Carrier m) =>
EffHandler e m -> InterpretSimpleC e m a -> m a
interpretSimple (EffHandler (Catch smallExc) m
-> InterpretSimpleC (Catch smallExc) m a -> m a)
-> EffHandler (Catch smallExc) m
-> InterpretSimpleC (Catch smallExc) m a
-> m a
forall a b. (a -> b) -> a -> b
$ \case
Catch m h -> (bigExc -> Maybe smallExc)
-> Effly z x -> (smallExc -> Effly z x) -> Effly z x
forall smallExc bigExc (m :: * -> *) a.
Eff (Error bigExc) m =>
(bigExc -> Maybe smallExc) -> m a -> (smallExc -> m a) -> m a
catchJust bigExc -> Maybe smallExc
from Effly z x
m smallExc -> Effly z x
h
{-# INLINE catchToErrorSimple #-}
type InterpretErrorSimpleC e = CompositionC
'[ InterpretSimpleC (Catch e)
, InterpretSimpleC (Throw e)
]
errorToErrorSimple :: forall smallExc bigExc m a p
. ( Eff (Error bigExc) m
, Threaders '[ReaderThreads] m p
)
=> (smallExc -> bigExc)
-> (bigExc -> Maybe smallExc)
-> InterpretErrorSimpleC smallExc m a
-> m a
errorToErrorSimple :: (smallExc -> bigExc)
-> (bigExc -> Maybe smallExc)
-> InterpretErrorSimpleC smallExc m a
-> m a
errorToErrorSimple smallExc -> bigExc
to bigExc -> Maybe smallExc
from =
(smallExc -> bigExc)
-> InterpretSimpleC (Throw smallExc) m a -> m a
forall smallExc bigExc (m :: * -> *) a (p :: [Effect]).
(Eff (Throw bigExc) m, Threaders '[ReaderThreads] m p) =>
(smallExc -> bigExc)
-> InterpretSimpleC (Throw smallExc) m a -> m a
throwToThrowSimple smallExc -> bigExc
to
(InterpretSimpleC (Throw smallExc) m a -> m a)
-> (InterpretSimpleC
(Catch smallExc) (InterpretSimpleC (Throw smallExc) m) a
-> InterpretSimpleC (Throw smallExc) m a)
-> InterpretSimpleC
(Catch smallExc) (InterpretSimpleC (Throw smallExc) m) a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EffHandler (Catch smallExc) (InterpretSimpleC (Throw smallExc) m)
-> InterpretSimpleC
(Catch smallExc) (InterpretSimpleC (Throw smallExc) m) a
-> InterpretSimpleC (Throw smallExc) m a
forall (e :: Effect) (m :: * -> *) a (p :: [Effect]).
(RepresentationalEff e, Threaders '[ReaderThreads] m p,
Carrier m) =>
EffHandler e m -> InterpretSimpleC e m a -> m a
interpretSimple \case
Catch m h -> IntroTopC '[Throw smallExc] (Effly z) x -> Effly z x
forall (e :: Effect) (m :: * -> *) a.
IntroConsistent '[] '[e] m =>
IntroTopC '[e] m a -> m a
intro1 (IntroTopC '[Throw smallExc] (Effly z) x -> Effly z x)
-> IntroTopC '[Throw smallExc] (Effly z) x -> Effly z x
forall a b. (a -> b) -> a -> b
$ (bigExc -> Maybe smallExc)
-> IntroTopC '[Throw smallExc] (Effly z) x
-> (smallExc -> IntroTopC '[Throw smallExc] (Effly z) x)
-> IntroTopC '[Throw smallExc] (Effly z) x
forall smallExc bigExc (m :: * -> *) a.
Eff (Error bigExc) m =>
(bigExc -> Maybe smallExc) -> m a -> (smallExc -> m a) -> m a
catchJust bigExc -> Maybe smallExc
from (Effly z x -> IntroTopC '[Throw smallExc] (Effly z) x
forall (t :: Effect) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Effly z x
m) (Effly z x -> IntroTopC '[Throw smallExc] (Effly z) x
forall (t :: Effect) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Effly z x -> IntroTopC '[Throw smallExc] (Effly z) x)
-> (smallExc -> Effly z x)
-> smallExc
-> IntroTopC '[Throw smallExc] (Effly z) x
forall c b a. Coercible c b => (b -> c) -> (a -> b) -> a -> c
#. smallExc -> Effly z x
h)
(InterpretSimpleC
(Catch smallExc) (InterpretSimpleC (Throw smallExc) m) a
-> m a)
-> (InterpretErrorSimpleC smallExc m a
-> InterpretSimpleC
(Catch smallExc) (InterpretSimpleC (Throw smallExc) m) a)
-> InterpretErrorSimpleC smallExc m a
-> m a
forall b a c. Coercible b a => (b -> c) -> (a -> b) -> a -> c
.# InterpretErrorSimpleC smallExc m a
-> InterpretSimpleC
(Catch smallExc) (InterpretSimpleC (Throw smallExc) m) a
forall (ts :: [Effect]) (m :: * -> *) a.
CompositionC ts m a -> CompositionBaseM ts m a
runComposition
{-# INLINE errorToErrorSimple #-}
type ErrorToIOSimpleC e = CompositionC
'[ IntroC '[Catch e, Throw e] '[ErrorIO]
, InterpretErrorSimpleC e
, ErrorIOToIOC
]
errorToErrorIOSimple :: forall e m a p
. ( Effs '[ErrorIO, Embed IO] m
, Threaders '[ReaderThreads] m p
)
=> InterpretErrorSimpleC e m a
-> m (Either e a)
errorToErrorIOSimple :: InterpretErrorSimpleC e m a -> m (Either e a)
errorToErrorIOSimple InterpretErrorSimpleC e m a
main = do
!Unique
uniq <- IO Unique -> m Unique
forall (b :: * -> *) (m :: * -> *) a. Eff (Embed b) m => b a -> m a
embed IO Unique
newUnique
let
main' :: m a
main' =
EffHandler (Throw e) m -> InterpretSimpleC (Throw e) m a -> m a
forall (e :: Effect) (m :: * -> *) a (p :: [Effect]).
(RepresentationalEff e, Threaders '[ReaderThreads] m p,
Carrier m) =>
EffHandler e m -> InterpretSimpleC e m a -> m a
interpretSimple \case
Throw e -> OpaqueExc -> Effly z x
forall e (m :: * -> *) a. (Exception e, Eff ErrorIO m) => e -> m a
throwIO (Unique -> Any -> OpaqueExc
OpaqueExc Unique
uniq (e -> Any
forall a b. a -> b
unsafeCoerce e
e))
(InterpretSimpleC (Throw e) m a -> m a)
-> InterpretSimpleC (Throw e) m a -> m a
forall a b. (a -> b) -> a -> b
$ EffHandler (Catch e) (InterpretSimpleC (Throw e) m)
-> InterpretSimpleC (Catch e) (InterpretSimpleC (Throw e) m) a
-> InterpretSimpleC (Throw e) m a
forall (e :: Effect) (m :: * -> *) a (p :: [Effect]).
(RepresentationalEff e, Threaders '[ReaderThreads] m p,
Carrier m) =>
EffHandler e m -> InterpretSimpleC e m a -> m a
interpretSimple \case
Catch m h -> Effly z x
m Effly z x -> (OpaqueExc -> Effly z x) -> Effly z x
forall e (m :: * -> *) a.
(Exception e, Eff ErrorIO m) =>
m a -> (e -> m a) -> m a
`catchIO` \exc :: OpaqueExc
exc@(OpaqueExc Unique
uniq' Any
e) ->
if Unique
uniq Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
uniq' then
e -> Effly z x
h (Any -> e
forall a b. a -> b
unsafeCoerce Any
e)
else
OpaqueExc -> Effly z x
forall e (m :: * -> *) a. (Exception e, Eff ErrorIO m) => e -> m a
throwIO OpaqueExc
exc
(InterpretSimpleC (Catch e) (InterpretSimpleC (Throw e) m) a
-> InterpretSimpleC (Throw e) m a)
-> InterpretSimpleC (Catch e) (InterpretSimpleC (Throw e) m) a
-> InterpretSimpleC (Throw e) m a
forall a b. (a -> b) -> a -> b
$ InterpretErrorSimpleC e m a
-> CompositionBaseM
'[InterpretSimpleC (Catch e), InterpretSimpleC (Throw e)] m a
forall (ts :: [Effect]) (m :: * -> *) a.
CompositionC ts m a -> CompositionBaseM ts m a
runComposition
(InterpretErrorSimpleC e m a
-> CompositionBaseM
'[InterpretSimpleC (Catch e), InterpretSimpleC (Throw e)] m a)
-> InterpretErrorSimpleC e m a
-> CompositionBaseM
'[InterpretSimpleC (Catch e), InterpretSimpleC (Throw e)] m a
forall a b. (a -> b) -> a -> b
$ InterpretErrorSimpleC e m a
main
(a -> Either e a) -> m a -> m (Either e a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either e a
forall a b. b -> Either a b
Right m a
main' m (Either e a) -> (OpaqueExc -> m (Either e a)) -> m (Either e a)
forall e (m :: * -> *) a.
(Exception e, Eff ErrorIO m) =>
m a -> (e -> m a) -> m a
`catchIO` \exc :: OpaqueExc
exc@(OpaqueExc Unique
uniq' Any
e) ->
if Unique
uniq Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
uniq' then
Either e a -> m (Either e a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either e a -> m (Either e a)) -> Either e a -> m (Either e a)
forall a b. (a -> b) -> a -> b
$ e -> Either e a
forall a b. a -> Either a b
Left (Any -> e
forall a b. a -> b
unsafeCoerce Any
e)
else
OpaqueExc -> m (Either e a)
forall e (m :: * -> *) a. (Exception e, Eff ErrorIO m) => e -> m a
throwIO OpaqueExc
exc
errorToIOSimple :: forall e m a p
. ( Eff (Embed IO) m
, MonadCatch m
, Threaders '[ReaderThreads] m p
)
=> ErrorToIOSimpleC e m a
-> m (Either e a)
errorToIOSimple :: ErrorToIOSimpleC e m a -> m (Either e a)
errorToIOSimple =
ErrorIOToIOC m (Either e a) -> m (Either e a)
forall (m :: * -> *) a.
(Carrier m, MonadCatch m) =>
ErrorIOToIOC m a -> m a
errorIOToIO
#. errorToErrorIOSimple
(InterpretErrorSimpleC
e
(CompositionC
'[ReinterpretC
ErrorIOFinalH ErrorIO '[Optional ((->) SomeException)],
InterpretPrimC ErrorIOFinalH (Optional ((->) SomeException))]
m)
a
-> m (Either e a))
-> (IntroUnderManyC
'[Catch e, Throw e]
'[ErrorIO]
(CompositionC
'[InterpretSimpleC (Catch e), InterpretSimpleC (Throw e)]
(CompositionC
'[ReinterpretC
ErrorIOFinalH ErrorIO '[Optional ((->) SomeException)],
InterpretPrimC ErrorIOFinalH (Optional ((->) SomeException))]
m))
a
-> InterpretErrorSimpleC
e
(CompositionC
'[ReinterpretC
ErrorIOFinalH ErrorIO '[Optional ((->) SomeException)],
InterpretPrimC ErrorIOFinalH (Optional ((->) SomeException))]
m)
a)
-> IntroUnderManyC
'[Catch e, Throw e]
'[ErrorIO]
(CompositionC
'[InterpretSimpleC (Catch e), InterpretSimpleC (Throw e)]
(CompositionC
'[ReinterpretC
ErrorIOFinalH ErrorIO '[Optional ((->) SomeException)],
InterpretPrimC ErrorIOFinalH (Optional ((->) SomeException))]
m))
a
-> m (Either e a)
forall b a c. Coercible b a => (b -> c) -> (a -> b) -> a -> c
.# IntroUnderManyC
'[Catch e, Throw e]
'[ErrorIO]
(CompositionC
'[InterpretSimpleC (Catch e), InterpretSimpleC (Throw e)]
(CompositionC
'[ReinterpretC
ErrorIOFinalH ErrorIO '[Optional ((->) SomeException)],
InterpretPrimC ErrorIOFinalH (Optional ((->) SomeException))]
m))
a
-> InterpretErrorSimpleC
e
(CompositionC
'[ReinterpretC
ErrorIOFinalH ErrorIO '[Optional ((->) SomeException)],
InterpretPrimC ErrorIOFinalH (Optional ((->) SomeException))]
m)
a
forall (top :: [Effect]) (new :: [Effect]) (m :: * -> *) a.
(KnownList top, KnownList new, IntroConsistent top new m) =>
IntroUnderManyC top new m a -> m a
introUnderMany
(IntroUnderManyC
'[Catch e, Throw e]
'[ErrorIO]
(CompositionC
'[InterpretSimpleC (Catch e), InterpretSimpleC (Throw e)]
(CompositionC
'[ReinterpretC
ErrorIOFinalH ErrorIO '[Optional ((->) SomeException)],
InterpretPrimC ErrorIOFinalH (Optional ((->) SomeException))]
m))
a
-> m (Either e a))
-> (ErrorToIOSimpleC e m a
-> IntroUnderManyC
'[Catch e, Throw e]
'[ErrorIO]
(CompositionC
'[InterpretSimpleC (Catch e), InterpretSimpleC (Throw e)]
(CompositionC
'[ReinterpretC
ErrorIOFinalH ErrorIO '[Optional ((->) SomeException)],
InterpretPrimC ErrorIOFinalH (Optional ((->) SomeException))]
m))
a)
-> ErrorToIOSimpleC e m a
-> m (Either e a)
forall b a c. Coercible b a => (b -> c) -> (a -> b) -> a -> c
.# ErrorToIOSimpleC e m a
-> IntroUnderManyC
'[Catch e, Throw e]
'[ErrorIO]
(CompositionC
'[InterpretSimpleC (Catch e), InterpretSimpleC (Throw e)]
(CompositionC
'[ReinterpretC
ErrorIOFinalH ErrorIO '[Optional ((->) SomeException)],
InterpretPrimC ErrorIOFinalH (Optional ((->) SomeException))]
m))
a
forall (ts :: [Effect]) (m :: * -> *) a.
CompositionC ts m a -> CompositionBaseM ts m a
runComposition
{-# INLINE errorToIOSimple #-}