{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Carrier.State.Church
(
runState
, evalState
, execState
, StateC(StateC)
, module Control.Effect.State
) where
import Control.Algebra
import Control.Applicative
import Control.Effect.State
import Control.Monad (MonadPlus)
import Control.Monad.Fail as Fail
import Control.Monad.Fix
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
runState :: forall s m a b . (s -> a -> m b) -> s -> StateC s m a -> m b
runState :: forall s (m :: * -> *) a b.
(s -> a -> m b) -> s -> StateC s m a -> m b
runState s -> a -> m b
f s
s (StateC forall r. (s -> a -> m r) -> s -> m r
m) = (s -> a -> m b) -> s -> m b
forall r. (s -> a -> m r) -> s -> m r
m s -> a -> m b
f s
s
{-# INLINE runState #-}
evalState :: forall s m a . Applicative m => s -> StateC s m a -> m a
evalState :: forall s (m :: * -> *) a. Applicative m => s -> StateC s m a -> m a
evalState = (s -> a -> m a) -> s -> StateC s m a -> m a
forall s (m :: * -> *) a b.
(s -> a -> m b) -> s -> StateC s m a -> m b
runState ((a -> m a) -> s -> a -> m a
forall a b. a -> b -> a
const a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure)
{-# INLINE evalState #-}
execState :: forall s m a . Applicative m => s -> StateC s m a -> m s
execState :: forall s (m :: * -> *) a. Applicative m => s -> StateC s m a -> m s
execState = (s -> a -> m s) -> s -> StateC s m a -> m s
forall s (m :: * -> *) a b.
(s -> a -> m b) -> s -> StateC s m a -> m b
runState (m s -> a -> m s
forall a b. a -> b -> a
const (m s -> a -> m s) -> (s -> m s) -> s -> a -> m s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> m s
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure)
{-# INLINE execState #-}
newtype StateC s m a = StateC (forall r . (s -> a -> m r) -> s -> m r)
deriving ((forall a b. (a -> b) -> StateC s m a -> StateC s m b)
-> (forall a b. a -> StateC s m b -> StateC s m a)
-> Functor (StateC s m)
forall a b. a -> StateC s m b -> StateC s m a
forall a b. (a -> b) -> StateC s m a -> StateC s m b
forall s (m :: * -> *) a b. a -> StateC s m b -> StateC s m a
forall s (m :: * -> *) a b.
(a -> b) -> StateC s m a -> StateC s m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall s (m :: * -> *) a b.
(a -> b) -> StateC s m a -> StateC s m b
fmap :: forall a b. (a -> b) -> StateC s m a -> StateC s m b
$c<$ :: forall s (m :: * -> *) a b. a -> StateC s m b -> StateC s m a
<$ :: forall a b. a -> StateC s m b -> StateC s m a
Functor)
instance Applicative (StateC s m) where
pure :: forall a. a -> StateC s m a
pure a
a = (forall r. (s -> a -> m r) -> s -> m r) -> StateC s m a
forall s (m :: * -> *) a.
(forall r. (s -> a -> m r) -> s -> m r) -> StateC s m a
StateC ((forall r. (s -> a -> m r) -> s -> m r) -> StateC s m a)
-> (forall r. (s -> a -> m r) -> s -> m r) -> StateC s m a
forall a b. (a -> b) -> a -> b
$ \ s -> a -> m r
k s
s -> s -> a -> m r
k s
s a
a
{-# INLINE pure #-}
StateC forall r. (s -> (a -> b) -> m r) -> s -> m r
f <*> :: forall a b. StateC s m (a -> b) -> StateC s m a -> StateC s m b
<*> StateC forall r. (s -> a -> m r) -> s -> m r
a = (forall r. (s -> b -> m r) -> s -> m r) -> StateC s m b
forall s (m :: * -> *) a.
(forall r. (s -> a -> m r) -> s -> m r) -> StateC s m a
StateC ((forall r. (s -> b -> m r) -> s -> m r) -> StateC s m b)
-> (forall r. (s -> b -> m r) -> s -> m r) -> StateC s m b
forall a b. (a -> b) -> a -> b
$ \ s -> b -> m r
k -> (s -> (a -> b) -> m r) -> s -> m r
forall r. (s -> (a -> b) -> m r) -> s -> m r
f (\ s
s a -> b
f' -> (s -> a -> m r) -> s -> m r
forall r. (s -> a -> m r) -> s -> m r
a (\ s
s' -> s -> b -> m r
k s
s' (b -> m r) -> (a -> b) -> a -> m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f') s
s)
{-# INLINE (<*>) #-}
liftA2 :: forall a b c.
(a -> b -> c) -> StateC s m a -> StateC s m b -> StateC s m c
liftA2 a -> b -> c
f (StateC forall r. (s -> a -> m r) -> s -> m r
a) (StateC forall r. (s -> b -> m r) -> s -> m r
b) = (forall r. (s -> c -> m r) -> s -> m r) -> StateC s m c
forall s (m :: * -> *) a.
(forall r. (s -> a -> m r) -> s -> m r) -> StateC s m a
StateC ((forall r. (s -> c -> m r) -> s -> m r) -> StateC s m c)
-> (forall r. (s -> c -> m r) -> s -> m r) -> StateC s m c
forall a b. (a -> b) -> a -> b
$ \ s -> c -> m r
k ->
(s -> a -> m r) -> s -> m r
forall r. (s -> a -> m r) -> s -> m r
a (\ s
s' a
a' -> (s -> b -> m r) -> s -> m r
forall r. (s -> b -> m r) -> s -> m r
b (\ s
s'' -> s -> c -> m r
k s
s'' (c -> m r) -> (b -> c) -> b -> m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b -> c
f a
a') s
s')
{-# INLINE liftA2 #-}
StateC forall r. (s -> a -> m r) -> s -> m r
a *> :: forall a b. StateC s m a -> StateC s m b -> StateC s m b
*> StateC forall r. (s -> b -> m r) -> s -> m r
b = (forall r. (s -> b -> m r) -> s -> m r) -> StateC s m b
forall s (m :: * -> *) a.
(forall r. (s -> a -> m r) -> s -> m r) -> StateC s m a
StateC ((forall r. (s -> b -> m r) -> s -> m r) -> StateC s m b)
-> (forall r. (s -> b -> m r) -> s -> m r) -> StateC s m b
forall a b. (a -> b) -> a -> b
$ \ s -> b -> m r
k -> (s -> a -> m r) -> s -> m r
forall r. (s -> a -> m r) -> s -> m r
a (m r -> a -> m r
forall a b. a -> b -> a
const (m r -> a -> m r) -> (s -> m r) -> s -> a -> m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s -> b -> m r) -> s -> m r
forall r. (s -> b -> m r) -> s -> m r
b s -> b -> m r
k)
{-# INLINE (*>) #-}
StateC forall r. (s -> a -> m r) -> s -> m r
a <* :: forall a b. StateC s m a -> StateC s m b -> StateC s m a
<* StateC forall r. (s -> b -> m r) -> s -> m r
b = (forall r. (s -> a -> m r) -> s -> m r) -> StateC s m a
forall s (m :: * -> *) a.
(forall r. (s -> a -> m r) -> s -> m r) -> StateC s m a
StateC ((forall r. (s -> a -> m r) -> s -> m r) -> StateC s m a)
-> (forall r. (s -> a -> m r) -> s -> m r) -> StateC s m a
forall a b. (a -> b) -> a -> b
$ \ s -> a -> m r
k ->
(s -> a -> m r) -> s -> m r
forall r. (s -> a -> m r) -> s -> m r
a (\ s
s' a
a' -> (s -> b -> m r) -> s -> m r
forall r. (s -> b -> m r) -> s -> m r
b (\ s
s'' b
_ -> s -> a -> m r
k s
s'' a
a') s
s')
{-# INLINE (<*) #-}
instance Alternative m => Alternative (StateC s m) where
empty :: forall a. StateC s m a
empty = (forall r. (s -> a -> m r) -> s -> m r) -> StateC s m a
forall s (m :: * -> *) a.
(forall r. (s -> a -> m r) -> s -> m r) -> StateC s m a
StateC ((forall r. (s -> a -> m r) -> s -> m r) -> StateC s m a)
-> (forall r. (s -> a -> m r) -> s -> m r) -> StateC s m a
forall a b. (a -> b) -> a -> b
$ \ s -> a -> m r
_ s
_ -> m r
forall a. m a
forall (f :: * -> *) a. Alternative f => f a
empty
{-# INLINE empty #-}
StateC forall r. (s -> a -> m r) -> s -> m r
l <|> :: forall a. StateC s m a -> StateC s m a -> StateC s m a
<|> StateC forall r. (s -> a -> m r) -> s -> m r
r = (forall r. (s -> a -> m r) -> s -> m r) -> StateC s m a
forall s (m :: * -> *) a.
(forall r. (s -> a -> m r) -> s -> m r) -> StateC s m a
StateC ((forall r. (s -> a -> m r) -> s -> m r) -> StateC s m a)
-> (forall r. (s -> a -> m r) -> s -> m r) -> StateC s m a
forall a b. (a -> b) -> a -> b
$ \ s -> a -> m r
k s
s -> (s -> a -> m r) -> s -> m r
forall r. (s -> a -> m r) -> s -> m r
l s -> a -> m r
k s
s m r -> m r -> m r
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (s -> a -> m r) -> s -> m r
forall r. (s -> a -> m r) -> s -> m r
r s -> a -> m r
k s
s
{-# INLINE (<|>) #-}
instance Monad (StateC s m) where
StateC forall r. (s -> a -> m r) -> s -> m r
a >>= :: forall a b. StateC s m a -> (a -> StateC s m b) -> StateC s m b
>>= a -> StateC s m b
f = (forall r. (s -> b -> m r) -> s -> m r) -> StateC s m b
forall s (m :: * -> *) a.
(forall r. (s -> a -> m r) -> s -> m r) -> StateC s m a
StateC ((forall r. (s -> b -> m r) -> s -> m r) -> StateC s m b)
-> (forall r. (s -> b -> m r) -> s -> m r) -> StateC s m b
forall a b. (a -> b) -> a -> b
$ \ s -> b -> m r
k -> (s -> a -> m r) -> s -> m r
forall r. (s -> a -> m r) -> s -> m r
a (\ s
s -> (s -> b -> m r) -> s -> StateC s m b -> m r
forall s (m :: * -> *) a b.
(s -> a -> m b) -> s -> StateC s m a -> m b
runState s -> b -> m r
k s
s (StateC s m b -> m r) -> (a -> StateC s m b) -> a -> m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> StateC s m b
f)
{-# INLINE (>>=) #-}
instance Fail.MonadFail m => Fail.MonadFail (StateC s m) where
fail :: forall a. String -> StateC s m a
fail = m a -> StateC s m a
forall (m :: * -> *) a. Monad m => m a -> StateC s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> StateC s m a) -> (String -> m a) -> String -> StateC s 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 (StateC s m) where
mfix :: forall a. (a -> StateC s m a) -> StateC s m a
mfix a -> StateC s m a
f = (forall r. (s -> a -> m r) -> s -> m r) -> StateC s m a
forall s (m :: * -> *) a.
(forall r. (s -> a -> m r) -> s -> m r) -> StateC s m a
StateC ((forall r. (s -> a -> m r) -> s -> m r) -> StateC s m a)
-> (forall r. (s -> a -> m r) -> s -> m r) -> StateC s m a
forall a b. (a -> b) -> a -> b
$ \ s -> a -> m r
k s
s -> ((s, a) -> m (s, a)) -> m (s, a)
forall a. (a -> m a) -> m a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix ((s -> a -> m (s, a)) -> s -> StateC s m a -> m (s, a)
forall s (m :: * -> *) a b.
(s -> a -> m b) -> s -> StateC s m a -> m b
runState (((s, a) -> m (s, a)) -> s -> a -> m (s, a)
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (s, a) -> m (s, a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure) s
s (StateC s m a -> m (s, a))
-> ((s, a) -> StateC s m a) -> (s, a) -> m (s, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> StateC s m a
f (a -> StateC s m a) -> ((s, a) -> a) -> (s, a) -> StateC s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s, a) -> a
forall a b. (a, b) -> b
snd) m (s, a) -> ((s, a) -> m r) -> m r
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (s -> a -> m r) -> (s, a) -> m r
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry s -> a -> m r
k
{-# INLINE mfix #-}
instance MonadIO m => MonadIO (StateC s m) where
liftIO :: forall a. IO a -> StateC s m a
liftIO = m a -> StateC s m a
forall (m :: * -> *) a. Monad m => m a -> StateC s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> StateC s m a) -> (IO a -> m a) -> IO a -> StateC s 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 (Alternative m, Monad m) => MonadPlus (StateC s m)
instance MonadTrans (StateC s) where
lift :: forall (m :: * -> *) a. Monad m => m a -> StateC s m a
lift m a
m = (forall r. (s -> a -> m r) -> s -> m r) -> StateC s m a
forall s (m :: * -> *) a.
(forall r. (s -> a -> m r) -> s -> m r) -> StateC s m a
StateC ((forall r. (s -> a -> m r) -> s -> m r) -> StateC s m a)
-> (forall r. (s -> a -> m r) -> s -> m r) -> StateC s m a
forall a b. (a -> b) -> a -> b
$ \ s -> a -> m r
k s
s -> m a
m m a -> (a -> m r) -> m r
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= s -> a -> m r
k s
s
{-# INLINE lift #-}
instance Algebra sig m => Algebra (State s :+: sig) (StateC s m) where
alg :: forall (ctx :: * -> *) (n :: * -> *) a.
Functor ctx =>
Handler ctx n (StateC s m)
-> (:+:) (State s) sig n a -> ctx () -> StateC s m (ctx a)
alg Handler ctx n (StateC s m)
hdl (:+:) (State s) sig n a
sig ctx ()
ctx = (forall r. (s -> ctx a -> m r) -> s -> m r) -> StateC s m (ctx a)
forall s (m :: * -> *) a.
(forall r. (s -> a -> m r) -> s -> m r) -> StateC s m a
StateC ((forall r. (s -> ctx a -> m r) -> s -> m r) -> StateC s m (ctx a))
-> (forall r. (s -> ctx a -> m r) -> s -> m r)
-> StateC s m (ctx a)
forall a b. (a -> b) -> a -> b
$ \ s -> ctx a -> m r
k s
s -> case (:+:) (State s) sig n a
sig of
L State s n a
Get -> s -> ctx a -> m r
k s
s (s
a
s a -> ctx () -> ctx a
forall a b. a -> ctx b -> ctx a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ctx ()
ctx)
L (Put s
s) -> s -> ctx a -> m r
k s
s ctx a
ctx ()
ctx
R sig n a
other -> Handler (Compose ((,) s) ctx) n m
-> sig n a -> (s, ctx ()) -> m (s, 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 ((s -> StateC s m x -> m (s, x)) -> (s, StateC s m x) -> m (s, x)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((s -> x -> m (s, x)) -> s -> StateC s m x -> m (s, x)
forall s (m :: * -> *) a b.
(s -> a -> m b) -> s -> StateC s m a -> m b
runState (((s, x) -> m (s, x)) -> s -> x -> m (s, x)
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (s, x) -> m (s, x)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure)) (forall {x}. (s, StateC s m x) -> m (s, x))
-> Handler ctx n (StateC s m) -> Handler (Compose ((,) s) 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) -> StateC s m (ctx x)
Handler ctx n (StateC s m)
hdl) sig n a
other (s
s, ctx ()
ctx) m (s, ctx a) -> ((s, ctx a) -> m r) -> m r
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (s -> ctx a -> m r) -> (s, ctx a) -> m r
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry s -> ctx a -> m r
k
{-# INLINE alg #-}