{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

{- | A church-encoded carrier for the 'State' effect.

Note that the parameter order in 'runState', 'evalState', and 'execState' is reversed compared the equivalent functions provided by @transformers@. This is an intentional decision made to enable the composition of effect handlers with '.' without invoking 'flip'.

@since 1.1.0.0
-}
module Control.Carrier.State.Church
( -- * State carrier
  runState
, evalState
, execState
, StateC(StateC)
  -- * State effect
, module Control.Effect.State
) where

import Control.Algebra
import Control.Applicative (Alternative(..), liftA2)
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

-- | Run a 'State' effect starting from the passed value, applying a continuation to the final state and result.
--
-- @
-- 'runState' k s ('pure' a) = k s a
-- @
-- @
-- 'runState' k s 'get' = k s s
-- @
-- @
-- 'runState' k s ('put' t) = k t ()
-- @
--
-- @since 1.1.0.0
runState :: forall s m a b . (s -> a -> m b) -> s -> StateC s m a -> m b
runState :: (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 #-}

-- | Run a 'State' effect, yielding the result value and discarding the final state.
--
-- @
-- 'evalState' = 'runState' ('const' 'pure')
-- @
--
-- @since 1.1.0.0
evalState :: forall s m a . Applicative m => s -> StateC s m a -> m a
evalState :: 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 (f :: * -> *) a. Applicative f => a -> f a
pure)
{-# INLINE evalState #-}

-- | Run a 'State' effect, yielding the final state and discarding the return value.
--
-- @
-- 'execState' = 'runState' ('const' '.' 'pure')
-- @
--
-- @since 1.1.0.0
execState :: forall s m a . Applicative m => s -> StateC s m a -> m s
execState :: 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 (f :: * -> *) a. Applicative f => a -> f a
pure)
{-# INLINE execState #-}

-- | @since 1.1.0.0
newtype StateC s m a = StateC (forall r . (s -> a -> m r) -> s -> m r)
  deriving (a -> StateC s m b -> StateC s m a
(a -> b) -> StateC s m a -> StateC s m b
(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
<$ :: a -> StateC s m b -> StateC s m a
$c<$ :: forall s (m :: * -> *) a b. a -> StateC s m b -> StateC s m a
fmap :: (a -> b) -> StateC s m a -> StateC s m b
$cfmap :: forall s (m :: * -> *) a b.
(a -> b) -> StateC s m a -> StateC s m b
Functor)

instance Applicative (StateC s m) where
  pure :: 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 <*> :: 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 :: (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 *> :: 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 <* :: 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 :: 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 (f :: * -> *) a. Alternative f => f a
empty
  {-# INLINE empty #-}

  StateC forall r. (s -> a -> m r) -> s -> m r
l <|> :: 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 (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 >>= :: 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 :: String -> StateC s m a
fail = 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 (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail
  {-# INLINE fail #-}

instance MonadFix m => MonadFix (StateC s m) where
  mfix :: (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 (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 (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 (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 :: IO a -> StateC s m a
liftIO = 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 (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 :: 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 (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 :: 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
s s -> ctx () -> ctx s
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 (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
~<~ 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 (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 #-}