{-# 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 :: 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) = 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 :: forall s (m :: * -> *) a. Applicative m => s -> StateC s m a -> m a
evalState = forall s (m :: * -> *) a b.
(s -> a -> m b) -> s -> StateC s m a -> m b
runState (forall a b. a -> b -> a
const 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 :: forall s (m :: * -> *) a. Applicative m => s -> StateC s m a -> m s
execState = forall s (m :: * -> *) a b.
(s -> a -> m b) -> s -> StateC s m a -> m b
runState (forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 (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
<$ :: forall a b. 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 :: forall a b. (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 :: forall a. a -> StateC s m a
pure a
a = forall s (m :: * -> *) a.
(forall r. (s -> a -> m r) -> s -> m r) -> StateC s m a
StateC 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 s (m :: * -> *) a.
(forall r. (s -> a -> m r) -> s -> m r) -> StateC s m a
StateC forall a b. (a -> b) -> a -> b
$ \ s -> b -> m r
k -> forall r. (s -> (a -> b) -> m r) -> s -> m r
f (\ s
s a -> b
f' -> forall r. (s -> a -> m r) -> s -> m r
a (\ s
s' -> s -> b -> m r
k s
s' 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 s (m :: * -> *) a.
(forall r. (s -> a -> m r) -> s -> m r) -> StateC s m a
StateC forall a b. (a -> b) -> a -> b
$ \ s -> c -> m r
k ->
    forall r. (s -> a -> m r) -> s -> m r
a (\ s
s' a
a' -> forall r. (s -> b -> m r) -> s -> m r
b (\ s
s'' -> s -> c -> m r
k s
s'' 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 s (m :: * -> *) a.
(forall r. (s -> a -> m r) -> s -> m r) -> StateC s m a
StateC forall a b. (a -> b) -> a -> b
$ \ s -> b -> m r
k -> forall r. (s -> a -> m r) -> s -> m r
a (forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 s (m :: * -> *) a.
(forall r. (s -> a -> m r) -> s -> m r) -> StateC s m a
StateC forall a b. (a -> b) -> a -> b
$ \ s -> a -> m r
k ->
    forall r. (s -> a -> m r) -> s -> m r
a (\ s
s' a
a' -> 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 s (m :: * -> *) a.
(forall r. (s -> a -> m r) -> s -> m r) -> StateC s m a
StateC forall a b. (a -> b) -> a -> b
$ \ s -> a -> m r
_ s
_ -> 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 s (m :: * -> *) a.
(forall r. (s -> a -> m r) -> s -> m r) -> StateC s m a
StateC forall a b. (a -> b) -> a -> b
$ \ s -> a -> m r
k s
s -> forall r. (s -> a -> m r) -> s -> m r
l s -> a -> m r
k s
s forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> 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 s (m :: * -> *) a.
(forall r. (s -> a -> m r) -> s -> m r) -> StateC s m a
StateC forall a b. (a -> b) -> a -> b
$ \ s -> b -> m r
k -> forall r. (s -> a -> m r) -> s -> m r
a (\ s
s -> forall s (m :: * -> *) a b.
(s -> a -> m b) -> s -> StateC s m a -> m b
runState s -> b -> m r
k s
s 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 = 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 (StateC s m) where
  mfix :: forall a. (a -> StateC s m a) -> StateC s m a
mfix a -> StateC s m a
f = forall s (m :: * -> *) a.
(forall r. (s -> a -> m r) -> s -> m r) -> StateC s m a
StateC forall a b. (a -> b) -> a -> b
$ \ s -> a -> m r
k s
s -> forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (forall s (m :: * -> *) a b.
(s -> a -> m b) -> s -> StateC s m a -> m b
runState (forall a b c. ((a, b) -> c) -> a -> b -> c
curry forall (f :: * -> *) a. Applicative f => a -> f a
pure) s
s forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> StateC s m a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 = 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 (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 s (m :: * -> *) a.
(forall r. (s -> a -> m r) -> s -> m r) -> StateC s m a
StateC forall a b. (a -> b) -> a -> b
$ \ s -> a -> m r
k s
s -> m a
m 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 s (m :: * -> *) a.
(forall r. (s -> a -> m r) -> s -> m r) -> StateC s m a
StateC 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 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 ()
ctx
    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 a b c. (a -> b -> c) -> (a, b) -> c
uncurry (forall s (m :: * -> *) a b.
(s -> a -> m b) -> s -> StateC s m a -> m b
runState (forall a b c. ((a, b) -> c) -> a -> b -> c
curry forall (f :: * -> *) a. Applicative f => a -> f a
pure)) 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) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry s -> ctx a -> m r
k
  {-# INLINE alg #-}