{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Carrier.Empty.Church
(
runEmpty
, evalEmpty
, execEmpty
, EmptyC(..)
, 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
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) = m b -> (a -> m b) -> m b
forall b. m b -> (a -> m b) -> m b
m m b
nil a -> m b
leaf
{-# INLINE runEmpty #-}
evalEmpty :: Applicative m => EmptyC m a -> m ()
evalEmpty :: forall (m :: * -> *) a. Applicative m => EmptyC m a -> m ()
evalEmpty = m () -> (a -> m ()) -> EmptyC m a -> m ()
forall (m :: * -> *) b a. m b -> (a -> m b) -> EmptyC m a -> m b
runEmpty (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (m () -> a -> m ()
forall a b. a -> b -> a
const (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()))
{-# INLINE evalEmpty #-}
execEmpty :: Applicative m => EmptyC m a -> m Bool
execEmpty :: forall (m :: * -> *) a. Applicative m => EmptyC m a -> m Bool
execEmpty = m Bool -> (a -> m Bool) -> EmptyC m a -> m Bool
forall (m :: * -> *) b a. m b -> (a -> m b) -> EmptyC m a -> m b
runEmpty (Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False) (m Bool -> a -> m Bool
forall a b. a -> b -> a
const (Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True))
{-# INLINE execEmpty #-}
newtype EmptyC m a = EmptyC (forall b . m b -> (a -> m b) -> m b)
deriving ((forall a b. (a -> b) -> EmptyC m a -> EmptyC m b)
-> (forall a b. a -> EmptyC m b -> EmptyC m a)
-> Functor (EmptyC m)
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
$cfmap :: forall (m :: * -> *) a b. (a -> b) -> EmptyC m a -> EmptyC m b
fmap :: forall a b. (a -> b) -> EmptyC m a -> EmptyC m b
$c<$ :: forall (m :: * -> *) a b. a -> EmptyC m b -> EmptyC m a
<$ :: forall a b. a -> EmptyC m b -> EmptyC m a
Functor)
instance Applicative (EmptyC m) where
pure :: forall a. a -> EmptyC m a
pure a
a = (forall b. m b -> (a -> m b) -> m b) -> EmptyC m a
forall (m :: * -> *) a.
(forall b. m b -> (a -> m b) -> m b) -> EmptyC m a
EmptyC ((forall b. m b -> (a -> m b) -> m b) -> EmptyC m a)
-> (forall b. m b -> (a -> m b) -> m b) -> EmptyC m a
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 b. m b -> (b -> m b) -> m b) -> EmptyC m b
forall (m :: * -> *) a.
(forall b. m b -> (a -> m b) -> m b) -> EmptyC m a
EmptyC ((forall b. m b -> (b -> m b) -> m b) -> EmptyC m b)
-> (forall b. m b -> (b -> m b) -> m b) -> EmptyC m b
forall a b. (a -> b) -> a -> b
$ \ m b
nil b -> m b
leaf ->
m b -> ((a -> b) -> m b) -> m b
forall b. m b -> ((a -> b) -> m b) -> m b
f m b
nil (\ a -> b
f' -> m b -> (a -> m b) -> m b
forall b. m b -> (a -> m b) -> m b
a m b
nil (b -> m b
leaf (b -> m b) -> (a -> b) -> a -> m b
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 b. m b -> (c -> m b) -> m b) -> EmptyC m c
forall (m :: * -> *) a.
(forall b. m b -> (a -> m b) -> m b) -> EmptyC m a
EmptyC ((forall b. m b -> (c -> m b) -> m b) -> EmptyC m c)
-> (forall b. m b -> (c -> m b) -> m b) -> EmptyC m c
forall a b. (a -> b) -> a -> b
$ \ m b
nil c -> m b
leaf ->
m b -> (a -> m b) -> m b
forall b. m b -> (a -> m b) -> m b
a m b
nil (\ a
a' -> m b -> (b -> m b) -> m b
forall b. m b -> (b -> m b) -> m b
b m b
nil (c -> m b
leaf (c -> m b) -> (b -> c) -> b -> m b
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 b. m b -> (b -> m b) -> m b) -> EmptyC m b
forall (m :: * -> *) a.
(forall b. m b -> (a -> m b) -> m b) -> EmptyC m a
EmptyC ((forall b. m b -> (b -> m b) -> m b) -> EmptyC m b)
-> (forall b. m b -> (b -> m b) -> m b) -> EmptyC m b
forall a b. (a -> b) -> a -> b
$ \ m b
nil ->
m b -> (a -> m b) -> m b
forall b. m b -> (a -> m b) -> m b
a m b
nil ((a -> m b) -> m b)
-> ((b -> m b) -> a -> m b) -> (b -> m b) -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m b -> a -> m b
forall a b. a -> b -> a
const (m b -> a -> m b) -> ((b -> m b) -> m b) -> (b -> m b) -> a -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m b -> (b -> m b) -> m b
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 b. m b -> (a -> m b) -> m b) -> EmptyC m a
forall (m :: * -> *) a.
(forall b. m b -> (a -> m b) -> m b) -> EmptyC m a
EmptyC ((forall b. m b -> (a -> m b) -> m b) -> EmptyC m a)
-> (forall b. m b -> (a -> m b) -> m b) -> EmptyC m a
forall a b. (a -> b) -> a -> b
$ \ m b
nil a -> m b
leaf ->
m b -> (a -> m b) -> m b
forall b. m b -> (a -> m b) -> m b
a m b
nil (m b -> (b -> m b) -> m b
forall b. m b -> (b -> m b) -> m b
b m b
nil ((b -> m b) -> m b) -> (a -> b -> m b) -> a -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m b -> b -> m b
forall a b. a -> b -> a
const (m b -> b -> m b) -> (a -> m b) -> a -> b -> m b
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 b. m b -> (b -> m b) -> m b) -> EmptyC m b
forall (m :: * -> *) a.
(forall b. m b -> (a -> m b) -> m b) -> EmptyC m a
EmptyC ((forall b. m b -> (b -> m b) -> m b) -> EmptyC m b)
-> (forall b. m b -> (b -> m b) -> m b) -> EmptyC m b
forall a b. (a -> b) -> a -> b
$ \ m b
nil b -> m b
leaf ->
m b -> (a -> m b) -> m b
forall b. m b -> (a -> m b) -> m b
a m b
nil (m b -> (b -> m b) -> EmptyC m b -> m b
forall (m :: * -> *) b a. m b -> (a -> m b) -> EmptyC m a -> m b
runEmpty m b
nil b -> m b
leaf (EmptyC m b -> m b) -> (a -> EmptyC m b) -> a -> m b
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
(>>) = EmptyC m a -> EmptyC m b -> EmptyC m b
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 = m a -> EmptyC m a
forall (m :: * -> *) a. Monad m => m a -> EmptyC m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> EmptyC m a) -> (String -> m a) -> String -> EmptyC m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m a
forall a. String -> m a
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 b. m b -> (a -> m b) -> m b) -> EmptyC m a
forall (m :: * -> *) a.
(forall b. m b -> (a -> m b) -> m b) -> EmptyC m a
EmptyC ((forall b. m b -> (a -> m b) -> m b) -> EmptyC m a)
-> (forall b. m b -> (a -> m b) -> m b) -> EmptyC m a
forall a b. (a -> b) -> a -> b
$ \ m b
nil a -> m b
leaf ->
(EmptyC Identity a -> m (EmptyC Identity a))
-> m (EmptyC Identity a)
forall a. (a -> m a) -> m a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (EmptyC m a -> m (EmptyC Identity a)
forall {a}. EmptyC m a -> m (EmptyC Identity a)
toEmpty (EmptyC m a -> m (EmptyC Identity a))
-> (EmptyC Identity a -> EmptyC m a)
-> EmptyC Identity a
-> m (EmptyC Identity a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> EmptyC m a
f (a -> EmptyC m a)
-> (EmptyC Identity a -> a) -> EmptyC Identity a -> EmptyC m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity a -> a
forall a. Identity a -> a
run (Identity a -> a)
-> (EmptyC Identity a -> Identity a) -> EmptyC Identity a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EmptyC Identity a -> Identity a
forall {b}. EmptyC Identity b -> Identity b
fromEmpty)
m (EmptyC Identity a) -> (EmptyC Identity a -> m b) -> m b
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Identity (m b) -> m b
forall a. Identity a -> a
run (Identity (m b) -> m b)
-> (EmptyC Identity a -> Identity (m b))
-> EmptyC Identity a
-> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity (m b)
-> (a -> Identity (m b)) -> EmptyC Identity a -> Identity (m b)
forall (m :: * -> *) b a. m b -> (a -> m b) -> EmptyC m a -> m b
runEmpty (m b -> Identity (m b)
forall a b. Coercible a b => a -> b
coerce m b
nil) ((a -> m b) -> a -> Identity (m b)
forall a b. Coercible a b => a -> b
coerce a -> m b
leaf)
where
toEmpty :: EmptyC m a -> m (EmptyC Identity a)
toEmpty = m (EmptyC Identity a)
-> (a -> m (EmptyC Identity a))
-> EmptyC m a
-> m (EmptyC Identity a)
forall (m :: * -> *) b a. m b -> (a -> m b) -> EmptyC m a -> m b
runEmpty (EmptyC Identity a -> m (EmptyC Identity a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EmptyC Identity a
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has Empty sig m =>
m a
empty) (EmptyC Identity a -> m (EmptyC Identity a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EmptyC Identity a -> m (EmptyC Identity a))
-> (a -> EmptyC Identity a) -> a -> m (EmptyC Identity a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> EmptyC Identity a
forall a. a -> EmptyC Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure)
fromEmpty :: EmptyC Identity b -> Identity b
fromEmpty = Identity b -> (b -> Identity b) -> EmptyC Identity b -> Identity b
forall (m :: * -> *) b a. m b -> (a -> m b) -> EmptyC m a -> m b
runEmpty (String -> Identity b
forall a. HasCallStack => String -> a
error String
"mfix (EmptyC): empty") b -> Identity b
forall a. a -> Identity a
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 = m a -> EmptyC m a
forall (m :: * -> *) a. Monad m => m a -> EmptyC m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> EmptyC m a) -> (IO a -> m a) -> IO a -> EmptyC m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall a. IO a -> m a
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 b. m b -> (a -> m b) -> m b) -> EmptyC m a
forall (m :: * -> *) a.
(forall b. m b -> (a -> m b) -> m b) -> EmptyC m a
EmptyC ((forall b. m b -> (a -> m b) -> m b) -> EmptyC m a)
-> (forall b. m b -> (a -> m b) -> m b) -> EmptyC m a
forall a b. (a -> b) -> a -> b
$ \ m b
_ a -> m b
leaf -> m a
m m a -> (a -> m b) -> m b
forall a b. m a -> (a -> m b) -> m b
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 b. m b -> (ctx a -> m b) -> m b) -> EmptyC m (ctx a)
forall (m :: * -> *) a.
(forall b. m b -> (a -> m b) -> m b) -> EmptyC m a
EmptyC ((forall b. m b -> (ctx a -> m b) -> m b) -> EmptyC m (ctx a))
-> (forall b. m b -> (ctx a -> m b) -> m b) -> EmptyC m (ctx a)
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 -> Handler (Compose (EmptyC Identity) ctx) n m
-> sig n a
-> EmptyC Identity (ctx ())
-> m (EmptyC Identity (ctx a))
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 (EmptyC Identity (EmptyC m x) -> m (EmptyC Identity x)
forall {x}. EmptyC Identity (EmptyC m x) -> m (EmptyC Identity x)
forall (m :: * -> *) a.
Applicative m =>
EmptyC Identity (EmptyC m a) -> m (EmptyC Identity a)
dst (forall {x}. EmptyC Identity (EmptyC m x) -> m (EmptyC Identity x))
-> Handler ctx n (EmptyC m)
-> Handler (Compose (EmptyC Identity) ctx) n m
forall (n :: * -> *) (ctx1 :: * -> *) (m :: * -> *)
(ctx2 :: * -> *) (l :: * -> *).
(Functor n, Functor ctx1) =>
Handler ctx1 m n
-> Handler ctx2 l m -> Handler (Compose ctx1 ctx2) l n
~<~ ctx (n x) -> EmptyC m (ctx x)
Handler ctx n (EmptyC m)
hdl) sig n a
other (ctx () -> EmptyC Identity (ctx ())
forall a. a -> EmptyC Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ctx ()
ctx) m (EmptyC Identity (ctx a))
-> (EmptyC Identity (ctx a) -> m b) -> m b
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Identity (m b) -> m b
forall a. Identity a -> a
run (Identity (m b) -> m b)
-> (EmptyC Identity (ctx a) -> Identity (m b))
-> EmptyC Identity (ctx a)
-> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity (m b)
-> (ctx a -> Identity (m b))
-> EmptyC Identity (ctx a)
-> Identity (m b)
forall (m :: * -> *) b a. m b -> (a -> m b) -> EmptyC m a -> m b
runEmpty (m b -> Identity (m b)
forall a b. Coercible a b => a -> b
coerce m b
nil) ((ctx a -> m b) -> ctx a -> Identity (m b)
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 = Identity (m (EmptyC Identity a)) -> m (EmptyC Identity a)
forall a. Identity a -> a
run (Identity (m (EmptyC Identity a)) -> m (EmptyC Identity a))
-> (EmptyC Identity (EmptyC m a)
-> Identity (m (EmptyC Identity a)))
-> EmptyC Identity (EmptyC m a)
-> m (EmptyC Identity a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity (m (EmptyC Identity a))
-> (EmptyC m a -> Identity (m (EmptyC Identity a)))
-> EmptyC Identity (EmptyC m a)
-> Identity (m (EmptyC Identity a))
forall (m :: * -> *) b a. m b -> (a -> m b) -> EmptyC m a -> m b
runEmpty (m (EmptyC Identity a) -> Identity (m (EmptyC Identity a))
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EmptyC Identity a -> m (EmptyC Identity a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EmptyC Identity a
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has Empty sig m =>
m a
empty)) (m (EmptyC Identity a) -> Identity (m (EmptyC Identity a))
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m (EmptyC Identity a) -> Identity (m (EmptyC Identity a)))
-> (EmptyC m a -> m (EmptyC Identity a))
-> EmptyC m a
-> Identity (m (EmptyC Identity a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (EmptyC Identity a)
-> (a -> m (EmptyC Identity a))
-> EmptyC m a
-> m (EmptyC Identity a)
forall (m :: * -> *) b a. m b -> (a -> m b) -> EmptyC m a -> m b
runEmpty (EmptyC Identity a -> m (EmptyC Identity a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EmptyC Identity a
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has Empty sig m =>
m a
empty) (EmptyC Identity a -> m (EmptyC Identity a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EmptyC Identity a -> m (EmptyC Identity a))
-> (a -> EmptyC Identity a) -> a -> m (EmptyC Identity a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> EmptyC Identity a
forall a. a -> EmptyC Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure))
{-# INLINE alg #-}