content: {-# LANGUAGE CPP #-}
  {-# LANGUAGE DeriveFunctor #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  {-# LANGUAGE RankNTypes #-}
  {-# LANGUAGE TypeOperators #-}
  {-# LANGUAGE UndecidableInstances #-}
  
  {- | A church-encoded carrier for 'Empty'.
  
  @since 1.1.0.0
  -}
  module Control.Carrier.Empty.Church
  ( -- * Empty carrier
    runEmpty
  , evalEmpty
  , execEmpty
  , EmptyC(..)
    -- * Empty effect
  , module Control.Effect.Empty
  ) where
  
  import Control.Algebra
  #if !MIN_VERSION_base(4,18,0)
  import Control.Applicative (liftA2)
  #endif
  import Control.Effect.Empty
  import Control.Monad.Fix
  import Control.Monad.Fail as Fail
  import Control.Monad.IO.Class
  import Control.Monad.Trans.Class
  import Data.Coerce (coerce)
  import Data.Functor.Identity
  
  -- | Run an 'Empty' effect, returning the first continuation for 'empty' programs and applying the second to successful results.
  --
  -- @
  -- 'runEmpty' j k 'empty' = j
  -- @
  -- @
  -- 'runEmpty' j k ('pure' a) = k a
  -- @
  --
  -- @since 1.1.0.0
  runEmpty :: m b -> (a -> m b) -> EmptyC m a -> m b
  runEmpty nil leaf (EmptyC m) = m nil leaf
  {-# INLINE runEmpty #-}
  
  -- | Run an 'Empty' effect, discarding its result.
  --
  -- This is convenient for using 'empty' to signal early returns without needing to know whether control exited normally or not.
  --
  -- @
  -- 'evalEmpty' = 'runEmpty' ('pure' ()) ('const' ('pure' ()))
  -- @
  --
  -- @since 1.1.0.0
  evalEmpty :: Applicative m => EmptyC m a -> m ()
  evalEmpty = runEmpty (pure ()) (const (pure ()))
  {-# INLINE evalEmpty #-}
  
  -- | Run an 'Empty' effect, replacing its result with a 'Bool' indicating whether control exited normally.
  --
  -- This is convenient for using 'empty' to signal early returns when all you need to know is whether control exited normally or not, and not what value it exited with.
  --
  -- @
  -- 'execEmpty' = 'runEmpty' ('pure' 'False') ('const' ('pure' 'True'))
  -- @
  -- @
  -- 'execEmpty' ('pure' a) = 'pure' 'True'
  -- @
  -- @
  -- 'execEmpty' 'empty' = 'pure' 'False'
  -- @
  --
  -- @since 1.1.0.0
  execEmpty :: Applicative m => EmptyC m a -> m Bool
  execEmpty = runEmpty (pure False) (const (pure True))
  {-# INLINE execEmpty #-}
  
  -- | @since 1.1.0.0
  newtype EmptyC m a = EmptyC (forall b . m b -> (a -> m b) -> m b)
    deriving (Functor)
  
  instance Applicative (EmptyC m) where
    pure a = EmptyC $ \ _ leaf -> leaf a
    {-# INLINE pure #-}
  
    EmptyC f <*> EmptyC a = EmptyC $ \ nil leaf ->
      f nil (\ f' -> a nil (leaf . f'))
    {-# INLINE (<*>) #-}
  
    liftA2 f (EmptyC a) (EmptyC b) = EmptyC $ \ nil leaf ->
      a nil (\ a' -> b nil (leaf . f a'))
    {-# INLINE liftA2 #-}
  
    EmptyC a *> EmptyC b = EmptyC $ \ nil ->
      a nil . const . b nil
    {-# INLINE (*>) #-}
  
    EmptyC a <* EmptyC b = EmptyC $ \ nil leaf ->
      a nil (b nil . const . leaf)
    {-# INLINE (<*) #-}
  
  instance Monad (EmptyC m) where
    EmptyC a >>= f = EmptyC $ \ nil leaf ->
      a nil (runEmpty nil leaf . f)
    {-# INLINE (>>=) #-}
  
    (>>) = (*>)
    {-# INLINE (>>) #-}
  
  instance Fail.MonadFail m => Fail.MonadFail (EmptyC m) where
    fail = lift . Fail.fail
    {-# INLINE fail #-}
  
  instance MonadFix m => MonadFix (EmptyC m) where
    mfix f = EmptyC $ \ nil leaf ->
      mfix (toEmpty . f . run . fromEmpty)
      >>= run . runEmpty (coerce nil) (coerce leaf)
      where
      toEmpty   = runEmpty (pure empty) (pure . pure)
      fromEmpty = runEmpty (error "mfix (EmptyC): empty") pure
    {-# INLINE mfix #-}
  
  instance MonadIO m => MonadIO (EmptyC m) where
    liftIO = lift . liftIO
    {-# INLINE liftIO #-}
  
  instance MonadTrans EmptyC where
    lift m = EmptyC $ \ _ leaf -> m >>= leaf
    {-# INLINE lift #-}
  
  instance Algebra sig m => Algebra (Empty :+: sig) (EmptyC m) where
    alg hdl sig ctx = EmptyC $ \ nil leaf -> case sig of
      L Empty -> nil
      R other -> thread (dst ~<~ hdl) other (pure ctx) >>= run . runEmpty (coerce nil) (coerce leaf)
      where
      dst :: Applicative m => EmptyC Identity (EmptyC m a) -> m (EmptyC Identity a)
      dst = run . runEmpty (pure (pure empty)) (pure . runEmpty (pure empty) (pure . pure))
    {-# INLINE alg #-}
  