{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

{- | A church-encoded carrier for 'Error'.

@since 1.1.0.0
-}
module Control.Carrier.Error.Church
( -- * Error carrier
  runError
, ErrorC(..)
  -- * Error effect
, module Control.Effect.Error
) where

import Control.Algebra
import Control.Applicative (Alternative(..), liftA2)
import Control.Effect.Error
import Control.Monad (MonadPlus)
import Control.Monad.Fail as Fail
import Control.Monad.Fix
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Data.Coerce (coerce)
import Data.Functor.Identity
import Prelude hiding (fail)

-- | Run an 'Error' effect, applying the first continuation to uncaught errors and the second continuation to successful computations’ results.
--
-- @
-- 'runError' j k ('pure' a) = k a
-- @
-- @
-- 'runError' j k ('throwError' e) = j e
-- @
-- @
-- 'runError' j k ('throwError' e \`'catchError'\` 'pure') = k e
-- @
--
-- @since 1.1.0.0
runError :: (e -> m b) -> (a -> m b) -> ErrorC e m a -> m b
runError :: forall e (m :: * -> *) b a.
(e -> m b) -> (a -> m b) -> ErrorC e m a -> m b
runError e -> m b
fail a -> m b
leaf ErrorC e m a
m = forall e (m :: * -> *) a.
ErrorC e m a -> forall b. (e -> m b) -> (a -> m b) -> m b
runErrorC ErrorC e m a
m e -> m b
fail a -> m b
leaf
{-# INLINE runError #-}

-- | @since 1.1.0.0
newtype ErrorC e m a = ErrorC { forall e (m :: * -> *) a.
ErrorC e m a -> forall b. (e -> m b) -> (a -> m b) -> m b
runErrorC :: forall b . (e -> m b) -> (a -> m b) -> m b }
  deriving (forall a b. a -> ErrorC e m b -> ErrorC e m a
forall a b. (a -> b) -> ErrorC e m a -> ErrorC e m b
forall e (m :: * -> *) a b. a -> ErrorC e m b -> ErrorC e m a
forall e (m :: * -> *) a b.
(a -> b) -> ErrorC e m a -> ErrorC e m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> ErrorC e m b -> ErrorC e m a
$c<$ :: forall e (m :: * -> *) a b. a -> ErrorC e m b -> ErrorC e m a
fmap :: forall a b. (a -> b) -> ErrorC e m a -> ErrorC e m b
$cfmap :: forall e (m :: * -> *) a b.
(a -> b) -> ErrorC e m a -> ErrorC e m b
Functor)

instance Applicative (ErrorC e m) where
  pure :: forall a. a -> ErrorC e m a
pure a
a = forall e (m :: * -> *) a.
(forall b. (e -> m b) -> (a -> m b) -> m b) -> ErrorC e m a
ErrorC forall a b. (a -> b) -> a -> b
$ \ e -> m b
_ a -> m b
leaf -> a -> m b
leaf a
a
  {-# INLINE pure #-}

  ErrorC forall b. (e -> m b) -> ((a -> b) -> m b) -> m b
f <*> :: forall a b. ErrorC e m (a -> b) -> ErrorC e m a -> ErrorC e m b
<*> ErrorC forall b. (e -> m b) -> (a -> m b) -> m b
a = forall e (m :: * -> *) a.
(forall b. (e -> m b) -> (a -> m b) -> m b) -> ErrorC e m a
ErrorC forall a b. (a -> b) -> a -> b
$ \ e -> m b
fail b -> m b
leaf -> forall b. (e -> m b) -> ((a -> b) -> m b) -> m b
f e -> m b
fail (\ a -> b
f' -> forall b. (e -> m b) -> (a -> m b) -> m b
a e -> m b
fail (b -> m b
leaf forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f'))
  {-# INLINE (<*>) #-}

  liftA2 :: forall a b c.
(a -> b -> c) -> ErrorC e m a -> ErrorC e m b -> ErrorC e m c
liftA2 a -> b -> c
f (ErrorC forall b. (e -> m b) -> (a -> m b) -> m b
a) (ErrorC forall b. (e -> m b) -> (b -> m b) -> m b
b) = forall e (m :: * -> *) a.
(forall b. (e -> m b) -> (a -> m b) -> m b) -> ErrorC e m a
ErrorC forall a b. (a -> b) -> a -> b
$ \ e -> m b
fail c -> m b
leaf ->
    forall b. (e -> m b) -> (a -> m b) -> m b
a e -> m b
fail (\ a
a' -> forall b. (e -> m b) -> (b -> m b) -> m b
b e -> m b
fail (c -> m b
leaf forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b -> c
f a
a'))
  {-# INLINE liftA2 #-}

  ErrorC forall b. (e -> m b) -> (a -> m b) -> m b
a1 *> :: forall a b. ErrorC e m a -> ErrorC e m b -> ErrorC e m b
*> ErrorC forall b. (e -> m b) -> (b -> m b) -> m b
a2 = forall e (m :: * -> *) a.
(forall b. (e -> m b) -> (a -> m b) -> m b) -> ErrorC e m a
ErrorC forall a b. (a -> b) -> a -> b
$ \ e -> m b
fail -> forall b. (e -> m b) -> (a -> m b) -> m b
a1 e -> m b
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. (e -> m b) -> (b -> m b) -> m b
a2 e -> m b
fail
  {-# INLINE (*>) #-}

  ErrorC forall b. (e -> m b) -> (a -> m b) -> m b
a1 <* :: forall a b. ErrorC e m a -> ErrorC e m b -> ErrorC e m a
<* ErrorC forall b. (e -> m b) -> (b -> m b) -> m b
a2 = forall e (m :: * -> *) a.
(forall b. (e -> m b) -> (a -> m b) -> m b) -> ErrorC e m a
ErrorC forall a b. (a -> b) -> a -> b
$ \ e -> m b
fail a -> m b
leaf -> forall b. (e -> m b) -> (a -> m b) -> m b
a1 e -> m b
fail (forall b. (e -> m b) -> (b -> m b) -> m b
a2 e -> m b
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m b
leaf)
  {-# INLINE (<*) #-}

instance Alternative m => Alternative (ErrorC e m) where
  empty :: forall a. ErrorC e m a
empty = forall e (m :: * -> *) a.
(forall b. (e -> m b) -> (a -> m b) -> m b) -> ErrorC e m a
ErrorC forall a b. (a -> b) -> a -> b
$ \ e -> m b
_ a -> m b
_ -> forall (f :: * -> *) a. Alternative f => f a
empty
  {-# INLINE empty #-}

  ErrorC forall b. (e -> m b) -> (a -> m b) -> m b
a <|> :: forall a. ErrorC e m a -> ErrorC e m a -> ErrorC e m a
<|> ErrorC forall b. (e -> m b) -> (a -> m b) -> m b
b = forall e (m :: * -> *) a.
(forall b. (e -> m b) -> (a -> m b) -> m b) -> ErrorC e m a
ErrorC forall a b. (a -> b) -> a -> b
$ \ e -> m b
fail a -> m b
leaf -> forall b. (e -> m b) -> (a -> m b) -> m b
a e -> m b
fail a -> m b
leaf forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall b. (e -> m b) -> (a -> m b) -> m b
b e -> m b
fail a -> m b
leaf
  {-# INLINE (<|>) #-}

instance Monad (ErrorC e m) where
  ErrorC forall b. (e -> m b) -> (a -> m b) -> m b
a >>= :: forall a b. ErrorC e m a -> (a -> ErrorC e m b) -> ErrorC e m b
>>= a -> ErrorC e m b
f = forall e (m :: * -> *) a.
(forall b. (e -> m b) -> (a -> m b) -> m b) -> ErrorC e m a
ErrorC forall a b. (a -> b) -> a -> b
$ \ e -> m b
fail b -> m b
leaf -> forall b. (e -> m b) -> (a -> m b) -> m b
a e -> m b
fail (forall e (m :: * -> *) b a.
(e -> m b) -> (a -> m b) -> ErrorC e m a -> m b
runError e -> m b
fail b -> m b
leaf forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ErrorC e m b
f)
  {-# INLINE (>>=) #-}

instance Fail.MonadFail m => Fail.MonadFail (ErrorC e m) where
  fail :: forall a. String -> ErrorC e m a
fail = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail
  {-# INLINE fail #-}

instance MonadFix m => MonadFix (ErrorC e m) where
  mfix :: forall a. (a -> ErrorC e m a) -> ErrorC e m a
mfix a -> ErrorC e m a
f = forall e (m :: * -> *) a.
(forall b. (e -> m b) -> (a -> m b) -> m b) -> ErrorC e m a
ErrorC forall a b. (a -> b) -> a -> b
$ \ e -> m b
fail a -> m b
leaf ->
    forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (forall {a}. ErrorC e m a -> m (ErrorC e Identity a)
toError forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ErrorC e m a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Identity a -> a
run forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {e} {b}. ErrorC e Identity b -> Identity b
fromError)
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Identity a -> a
run forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) b a.
(e -> m b) -> (a -> m b) -> ErrorC e m a -> m b
runError (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> m b
fail) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m b
leaf)
    where
    toError :: ErrorC e m a -> m (ErrorC e Identity a)
toError   = forall e (m :: * -> *) b a.
(e -> m b) -> (a -> m b) -> ErrorC e m a -> m b
runError (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure)
    fromError :: ErrorC e Identity b -> Identity b
fromError = forall e (m :: * -> *) b a.
(e -> m b) -> (a -> m b) -> ErrorC e m a -> m b
runError (forall a b. a -> b -> a
const (forall a. HasCallStack => String -> a
error String
"mfix (ErrorC): throwError")) forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE mfix #-}

instance MonadIO m => MonadIO (ErrorC e m) where
  liftIO :: forall a. IO a -> ErrorC e m a
liftIO = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
  {-# INLINE liftIO #-}

instance (Alternative m, Monad m) => MonadPlus (ErrorC e m)

instance MonadTrans (ErrorC e) where
  lift :: forall (m :: * -> *) a. Monad m => m a -> ErrorC e m a
lift m a
m = forall e (m :: * -> *) a.
(forall b. (e -> m b) -> (a -> m b) -> m b) -> ErrorC e m a
ErrorC forall a b. (a -> b) -> a -> b
$ \ e -> m b
_ a -> m b
leaf -> m a
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> m b
leaf
  {-# INLINE lift #-}

instance Algebra sig m => Algebra (Error e :+: sig) (ErrorC e m) where
  alg :: forall (ctx :: * -> *) (n :: * -> *) a.
Functor ctx =>
Handler ctx n (ErrorC e m)
-> (:+:) (Error e) sig n a -> ctx () -> ErrorC e m (ctx a)
alg Handler ctx n (ErrorC e m)
hdl (:+:) (Error e) sig n a
sig ctx ()
ctx = forall e (m :: * -> *) a.
(forall b. (e -> m b) -> (a -> m b) -> m b) -> ErrorC e m a
ErrorC forall a b. (a -> b) -> a -> b
$ \ e -> m b
fail ctx a -> m b
leaf -> case (:+:) (Error e) sig n a
sig of
    L (L (Throw e
e))   -> e -> m b
fail e
e
    L (R (Catch n a
m e -> n a
h)) -> forall e (m :: * -> *) b a.
(e -> m b) -> (a -> m b) -> ErrorC e m a -> m b
runError (forall e (m :: * -> *) b a.
(e -> m b) -> (a -> m b) -> ErrorC e m a -> m b
runError e -> m b
fail ctx a -> m b
leaf forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {x}. n x -> ErrorC e m (ctx x)
lower forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> n a
h) ctx a -> m b
leaf (forall {x}. n x -> ErrorC e m (ctx x)
lower n a
m)
    R sig n a
other           -> forall (ctx1 :: * -> *) (ctx2 :: * -> *)
       (sig :: (* -> *) -> * -> *) (m :: * -> *) (n :: * -> *) a.
(Functor ctx1, Functor ctx2, Algebra sig m) =>
Handler (Compose ctx1 ctx2) n m
-> sig n a -> ctx1 (ctx2 ()) -> m (ctx1 (ctx2 a))
thread (forall (m :: * -> *) e a.
Applicative m =>
ErrorC e Identity (ErrorC e m a) -> m (ErrorC e Identity a)
dst forall (n :: * -> *) (ctx1 :: * -> *) (m :: * -> *)
       (ctx2 :: * -> *) (l :: * -> *).
(Functor n, Functor ctx1) =>
Handler ctx1 m n
-> Handler ctx2 l m -> Handler (Compose ctx1 ctx2) l n
~<~ Handler ctx n (ErrorC e m)
hdl) sig n a
other (forall (f :: * -> *) a. Applicative f => a -> f a
pure ctx ()
ctx) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Identity a -> a
run forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) b a.
(e -> m b) -> (a -> m b) -> ErrorC e m a -> m b
runError (coerce :: forall a b. Coercible a b => a -> b
coerce e -> m b
fail) (coerce :: forall a b. Coercible a b => a -> b
coerce ctx a -> m b
leaf)
    where
    lower :: n x -> ErrorC e m (ctx x)
lower = Handler ctx n (ErrorC e m)
hdl forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ctx ()
ctx)
    dst :: Applicative m => ErrorC e Identity (ErrorC e m a) -> m (ErrorC e Identity a)
    dst :: forall (m :: * -> *) e a.
Applicative m =>
ErrorC e Identity (ErrorC e m a) -> m (ErrorC e Identity a)
dst = forall a. Identity a -> a
run forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) b a.
(e -> m b) -> (a -> m b) -> ErrorC e m a -> m b
runError (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) b a.
(e -> m b) -> (a -> m b) -> ErrorC e m a -> m b
runError (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure))
  {-# INLINE alg #-}