content: {-# 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
  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 fail leaf m = runErrorC m fail leaf
  {-# INLINE runError #-}
  
  -- | @since 1.1.0.0
  newtype ErrorC e m a = ErrorC { runErrorC :: forall b . (e -> m b) -> (a -> m b) -> m b }
    deriving (Functor)
  
  instance Applicative (ErrorC e m) where
    pure a = ErrorC $ \ _ leaf -> leaf a
    {-# INLINE pure #-}
  
    ErrorC f <*> ErrorC a = ErrorC $ \ fail leaf -> f fail (\ f' -> a fail (leaf . f'))
    {-# INLINE (<*>) #-}
  
    liftA2 f (ErrorC a) (ErrorC b) = ErrorC $ \ fail leaf ->
      a fail (\ a' -> b fail (leaf . f a'))
    {-# INLINE liftA2 #-}
  
    ErrorC a1 *> ErrorC a2 = ErrorC $ \ fail -> a1 fail . const . a2 fail
    {-# INLINE (*>) #-}
  
    ErrorC a1 <* ErrorC a2 = ErrorC $ \ fail leaf -> a1 fail (a2 fail . const . leaf)
    {-# INLINE (<*) #-}
  
  instance Alternative m => Alternative (ErrorC e m) where
    empty = ErrorC $ \ _ _ -> empty
    {-# INLINE empty #-}
  
    ErrorC a <|> ErrorC b = ErrorC $ \ fail leaf -> a fail leaf <|> b fail leaf
    {-# INLINE (<|>) #-}
  
  instance Monad (ErrorC e m) where
    ErrorC a >>= f = ErrorC $ \ fail leaf -> a fail (runError fail leaf . f)
    {-# INLINE (>>=) #-}
  
  instance Fail.MonadFail m => Fail.MonadFail (ErrorC e m) where
    fail = lift . Fail.fail
    {-# INLINE fail #-}
  
  instance MonadFix m => MonadFix (ErrorC e m) where
    mfix f = ErrorC $ \ fail leaf ->
      mfix (toError . f . run . fromError)
      >>= run . runError (pure . fail) (pure . leaf)
      where
      toError   = runError (pure . throwError) (pure . pure)
      fromError = runError (const (error "mfix (ErrorC): throwError")) pure
    {-# INLINE mfix #-}
  
  instance MonadIO m => MonadIO (ErrorC e m) where
    liftIO = lift . liftIO
    {-# INLINE liftIO #-}
  
  instance (Alternative m, Monad m) => MonadPlus (ErrorC e m)
  
  instance MonadTrans (ErrorC e) where
    lift m = ErrorC $ \ _ leaf -> m >>= leaf
    {-# INLINE lift #-}
  
  instance Algebra sig m => Algebra (Error e :+: sig) (ErrorC e m) where
    alg hdl sig ctx = ErrorC $ \ fail leaf -> case sig of
      L (L (Throw e))   -> fail e
      L (R (Catch m h)) -> runError (runError fail leaf . lower . h) leaf (lower m)
      R other           -> thread (dst ~<~ hdl) other (pure ctx) >>= run . runError (coerce fail) (coerce leaf)
      where
      lower = hdl . (<$ ctx)
      dst :: Applicative m => ErrorC e Identity (ErrorC e m a) -> m (ErrorC e Identity a)
      dst = run . runError (pure . pure . throwError) (pure . runError (pure . throwError) (pure . pure))
    {-# INLINE alg #-}
  