{-# 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
import Control.Applicative (liftA2)
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 :: forall (m :: * -> *) b a. m b -> (a -> m b) -> EmptyC m a -> m b
runEmpty m b
nil a -> m b
leaf (EmptyC forall b. m b -> (a -> m b) -> m b
m) = forall b. m b -> (a -> m b) -> m b
m m b
nil a -> m b
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 :: forall (m :: * -> *) a. Applicative m => EmptyC m a -> m ()
evalEmpty = forall (m :: * -> *) b a. m b -> (a -> m b) -> EmptyC m a -> m b
runEmpty (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (forall a b. a -> b -> a
const (forall (f :: * -> *) a. Applicative f => a -> f a
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 :: forall (m :: * -> *) a. Applicative m => EmptyC m a -> m Bool
execEmpty = forall (m :: * -> *) b a. m b -> (a -> m b) -> EmptyC m a -> m b
runEmpty (forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False) (forall a b. a -> b -> a
const (forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True))
{-# INLINE execEmpty #-}

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

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

  EmptyC forall b. m b -> ((a -> b) -> m b) -> m b
f <*> :: forall a b. EmptyC m (a -> b) -> EmptyC m a -> EmptyC m b
<*> EmptyC forall b. m b -> (a -> m b) -> m b
a = forall (m :: * -> *) a.
(forall b. m b -> (a -> m b) -> m b) -> EmptyC m a
EmptyC forall a b. (a -> b) -> a -> b
$ \ m b
nil b -> m b
leaf ->
    forall b. m b -> ((a -> b) -> m b) -> m b
f m b
nil (\ a -> b
f' -> forall b. m b -> (a -> m b) -> m b
a m b
nil (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) -> EmptyC m a -> EmptyC m b -> EmptyC m c
liftA2 a -> b -> c
f (EmptyC forall b. m b -> (a -> m b) -> m b
a) (EmptyC forall b. m b -> (b -> m b) -> m b
b) = forall (m :: * -> *) a.
(forall b. m b -> (a -> m b) -> m b) -> EmptyC m a
EmptyC forall a b. (a -> b) -> a -> b
$ \ m b
nil c -> m b
leaf ->
    forall b. m b -> (a -> m b) -> m b
a m b
nil (\ a
a' -> forall b. m b -> (b -> m b) -> m b
b m b
nil (c -> m b
leaf forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b -> c
f a
a'))
  {-# INLINE liftA2 #-}

  EmptyC forall b. m b -> (a -> m b) -> m b
a *> :: forall a b. EmptyC m a -> EmptyC m b -> EmptyC m b
*> EmptyC forall b. m b -> (b -> m b) -> m b
b = forall (m :: * -> *) a.
(forall b. m b -> (a -> m b) -> m b) -> EmptyC m a
EmptyC forall a b. (a -> b) -> a -> b
$ \ m b
nil ->
    forall b. m b -> (a -> m b) -> m b
a m b
nil 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. m b -> (b -> m b) -> m b
b m b
nil
  {-# INLINE (*>) #-}

  EmptyC forall b. m b -> (a -> m b) -> m b
a <* :: forall a b. EmptyC m a -> EmptyC m b -> EmptyC m a
<* EmptyC forall b. m b -> (b -> m b) -> m b
b = forall (m :: * -> *) a.
(forall b. m b -> (a -> m b) -> m b) -> EmptyC m a
EmptyC forall a b. (a -> b) -> a -> b
$ \ m b
nil a -> m b
leaf ->
    forall b. m b -> (a -> m b) -> m b
a m b
nil (forall b. m b -> (b -> m b) -> m b
b m b
nil 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 Monad (EmptyC m) where
  EmptyC forall b. m b -> (a -> m b) -> m b
a >>= :: forall a b. EmptyC m a -> (a -> EmptyC m b) -> EmptyC m b
>>= a -> EmptyC m b
f = forall (m :: * -> *) a.
(forall b. m b -> (a -> m b) -> m b) -> EmptyC m a
EmptyC forall a b. (a -> b) -> a -> b
$ \ m b
nil b -> m b
leaf ->
    forall b. m b -> (a -> m b) -> m b
a m b
nil (forall (m :: * -> *) b a. m b -> (a -> m b) -> EmptyC m a -> m b
runEmpty m b
nil b -> m b
leaf forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> EmptyC m b
f)
  {-# INLINE (>>=) #-}

  >> :: forall a b. EmptyC m a -> EmptyC m b -> EmptyC m b
(>>) = forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)
  {-# INLINE (>>) #-}

instance Fail.MonadFail m => Fail.MonadFail (EmptyC m) where
  fail :: forall a. String -> EmptyC 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 (EmptyC m) where
  mfix :: forall a. (a -> EmptyC m a) -> EmptyC m a
mfix a -> EmptyC m a
f = forall (m :: * -> *) a.
(forall b. m b -> (a -> m b) -> m b) -> EmptyC m a
EmptyC forall a b. (a -> b) -> a -> b
$ \ m b
nil a -> m b
leaf ->
    forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (forall {a}. EmptyC m a -> m (EmptyC Identity a)
toEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> EmptyC 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 {b}. EmptyC Identity b -> Identity b
fromEmpty)
    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 (m :: * -> *) b a. m b -> (a -> m b) -> EmptyC m a -> m b
runEmpty (coerce :: forall a b. Coercible a b => a -> b
coerce m b
nil) (coerce :: forall a b. Coercible a b => a -> b
coerce a -> m b
leaf)
    where
    toEmpty :: EmptyC m a -> m (EmptyC Identity a)
toEmpty   = forall (m :: * -> *) b a. m b -> (a -> m b) -> EmptyC m a -> m b
runEmpty (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has Empty sig m =>
m a
empty) (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)
    fromEmpty :: EmptyC Identity b -> Identity b
fromEmpty = forall (m :: * -> *) b a. m b -> (a -> m b) -> EmptyC m a -> m b
runEmpty (forall a. HasCallStack => String -> a
error String
"mfix (EmptyC): empty") forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE mfix #-}

instance MonadIO m => MonadIO (EmptyC m) where
  liftIO :: forall a. IO a -> EmptyC 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 MonadTrans EmptyC where
  lift :: forall (m :: * -> *) a. Monad m => m a -> EmptyC m a
lift m a
m = forall (m :: * -> *) a.
(forall b. m b -> (a -> m b) -> m b) -> EmptyC m a
EmptyC forall a b. (a -> b) -> a -> b
$ \ 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 (Empty :+: sig) (EmptyC m) where
  alg :: forall (ctx :: * -> *) (n :: * -> *) a.
Functor ctx =>
Handler ctx n (EmptyC m)
-> (:+:) Empty sig n a -> ctx () -> EmptyC m (ctx a)
alg Handler ctx n (EmptyC m)
hdl (:+:) Empty sig n a
sig ctx ()
ctx = forall (m :: * -> *) a.
(forall b. m b -> (a -> m b) -> m b) -> EmptyC m a
EmptyC forall a b. (a -> b) -> a -> b
$ \ m b
nil ctx a -> m b
leaf -> case (:+:) Empty sig n a
sig of
    L Empty n a
Empty -> m b
nil
    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 :: * -> *) a.
Applicative m =>
EmptyC Identity (EmptyC m a) -> m (EmptyC 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 (EmptyC 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 (m :: * -> *) b a. m b -> (a -> m b) -> EmptyC m a -> m b
runEmpty (coerce :: forall a b. Coercible a b => a -> b
coerce m b
nil) (coerce :: forall a b. Coercible a b => a -> b
coerce ctx a -> m b
leaf)
    where
    dst :: Applicative m => EmptyC Identity (EmptyC m a) -> m (EmptyC Identity a)
    dst :: forall (m :: * -> *) a.
Applicative m =>
EmptyC Identity (EmptyC m a) -> m (EmptyC Identity a)
dst = forall a. Identity a -> a
run forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) b a. m b -> (a -> m b) -> EmptyC m a -> m b
runEmpty (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has Empty sig m =>
m a
empty)) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) b a. m b -> (a -> m b) -> EmptyC m a -> m b
runEmpty (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has Empty sig m =>
m a
empty) (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 #-}