{-# LANGUAGE DeriveFunctor, ExplicitForAll, FlexibleInstances, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}

{- | A carrier for the 'State' effect. It evaluates its inner state strictly, which is the correct choice for the majority of use cases.

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.0.0.0
-}
module Control.Carrier.State.Strict
( -- * Strict state carrier
  runState
, evalState
, execState
, StateC(..)
  -- * State effect
, module Control.Effect.State
) where

import Control.Algebra
import Control.Applicative (Alternative(..))
import Control.Effect.State
import Control.Monad (MonadPlus(..))
import qualified 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.
--
-- @
-- 'runState' s ('pure' a) = 'pure' (s, a)
-- @
-- @
-- 'runState' s 'get' = 'pure' (s, s)
-- @
-- @
-- 'runState' s ('put' t) = 'pure' (t, ())
-- @
--
-- @since 1.0.0.0
runState :: s -> StateC s m a -> m (s, a)
runState :: s -> StateC s m a -> m (s, a)
runState s :: s
s (StateC runStateC :: s -> m (s, a)
runStateC) = s -> m (s, a)
runStateC s
s
{-# INLINE[3] runState #-}

-- | Run a 'State' effect, yielding the result value and discarding the final state.
--
-- @
-- 'evalState' s m = 'fmap' 'snd' ('runState' s m)
-- @
--
-- @since 1.0.0.0
evalState :: forall s m a . Functor m => s -> StateC s m a -> m a
evalState :: s -> StateC s m a -> m a
evalState s :: s
s = ((s, a) -> a) -> m (s, a) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (s, a) -> a
forall a b. (a, b) -> b
snd (m (s, a) -> m a)
-> (StateC s m a -> m (s, a)) -> StateC s m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> StateC s m a -> m (s, a)
forall s (m :: * -> *) a. s -> StateC s m a -> m (s, a)
runState s
s
{-# INLINE[3] evalState #-}

-- | Run a 'State' effect, yielding the final state and discarding the return value.
--
-- @
-- 'execState' s m = 'fmap' 'fst' ('runState' s m)
-- @
--
-- @since 1.0.0.0
execState :: forall s m a . Functor m => s -> StateC s m a -> m s
execState :: s -> StateC s m a -> m s
execState s :: s
s = ((s, a) -> s) -> m (s, a) -> m s
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (s, a) -> s
forall a b. (a, b) -> a
fst (m (s, a) -> m s)
-> (StateC s m a -> m (s, a)) -> StateC s m a -> m s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> StateC s m a -> m (s, a)
forall s (m :: * -> *) a. s -> StateC s m a -> m (s, a)
runState s
s
{-# INLINE[3] execState #-}


-- | @since 1.0.0.0
newtype StateC s m a = StateC (s -> m (s, a))
  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.
Functor m =>
a -> StateC s m b -> StateC s m a
forall s (m :: * -> *) a b.
Functor m =>
(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.
Functor m =>
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.
Functor m =>
(a -> b) -> StateC s m a -> StateC s m b
Functor)

instance Monad m => Applicative (StateC s m) where
  pure :: a -> StateC s m a
pure a :: a
a = (s -> m (s, a)) -> StateC s m a
forall s (m :: * -> *) a. (s -> m (s, a)) -> StateC s m a
StateC (\ s :: s
s -> (s, a) -> m (s, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (s
s, a
a))
  {-# INLINE pure #-}
  StateC f :: s -> m (s, a -> b)
f <*> :: StateC s m (a -> b) -> StateC s m a -> StateC s m b
<*> StateC a :: s -> m (s, a)
a = (s -> m (s, b)) -> StateC s m b
forall s (m :: * -> *) a. (s -> m (s, a)) -> StateC s m a
StateC ((s -> m (s, b)) -> StateC s m b)
-> (s -> m (s, b)) -> StateC s m b
forall a b. (a -> b) -> a -> b
$ \ s :: s
s -> do
    (s' :: s
s', f' :: a -> b
f') <- s -> m (s, a -> b)
f s
s
    (s'' :: s
s'', a' :: a
a') <- s -> m (s, a)
a s
s'
    (s, b) -> m (s, b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (s
s'', a -> b
f' a
a')
  {-# INLINE (<*>) #-}
  m :: StateC s m a
m *> :: StateC s m a -> StateC s m b -> StateC s m b
*> k :: StateC s m b
k = StateC s m a
m StateC s m a -> (a -> StateC s m b) -> StateC s m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \_ -> StateC s m b
k
  {-# INLINE (*>) #-}

instance (Alternative m, Monad m) => Alternative (StateC s m) where
  empty :: StateC s m a
empty = (s -> m (s, a)) -> StateC s m a
forall s (m :: * -> *) a. (s -> m (s, a)) -> StateC s m a
StateC (m (s, a) -> s -> m (s, a)
forall a b. a -> b -> a
const m (s, a)
forall (f :: * -> *) a. Alternative f => f a
empty)
  {-# INLINE empty #-}
  StateC l :: s -> m (s, a)
l <|> :: StateC s m a -> StateC s m a -> StateC s m a
<|> StateC r :: s -> m (s, a)
r = (s -> m (s, a)) -> StateC s m a
forall s (m :: * -> *) a. (s -> m (s, a)) -> StateC s m a
StateC (\ s :: s
s -> s -> m (s, a)
l s
s m (s, a) -> m (s, a) -> m (s, a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> s -> m (s, a)
r s
s)
  {-# INLINE (<|>) #-}

instance Monad m => Monad (StateC s m) where
  StateC m :: s -> m (s, a)
m >>= :: StateC s m a -> (a -> StateC s m b) -> StateC s m b
>>= f :: a -> StateC s m b
f = (s -> m (s, b)) -> StateC s m b
forall s (m :: * -> *) a. (s -> m (s, a)) -> StateC s m a
StateC ((s -> m (s, b)) -> StateC s m b)
-> (s -> m (s, b)) -> StateC s m b
forall a b. (a -> b) -> a -> b
$ \ s :: s
s -> do
    (s' :: s
s', a :: a
a) <- s -> m (s, a)
m s
s
    s -> StateC s m b -> m (s, b)
forall s (m :: * -> *) a. s -> StateC s m a -> m (s, a)
runState s
s' (a -> StateC s m b
f a
a)
  {-# INLINE (>>=) #-}

instance Fail.MonadFail m => Fail.MonadFail (StateC s m) where
  fail :: String -> StateC s m a
fail s :: String
s = (s -> m (s, a)) -> StateC s m a
forall s (m :: * -> *) a. (s -> m (s, a)) -> StateC s m a
StateC (m (s, a) -> s -> m (s, a)
forall a b. a -> b -> a
const (String -> m (s, a)
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
s))
  {-# INLINE fail #-}

instance MonadFix m => MonadFix (StateC s m) where
  mfix :: (a -> StateC s m a) -> StateC s m a
mfix f :: a -> StateC s m a
f = (s -> m (s, a)) -> StateC s m a
forall s (m :: * -> *) a. (s -> m (s, a)) -> StateC s m a
StateC (\ s :: s
s -> ((s, a) -> m (s, a)) -> m (s, a)
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (s -> StateC s m a -> m (s, a)
forall s (m :: * -> *) a. s -> StateC s m a -> m (s, a)
runState 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))
  {-# INLINE mfix #-}

instance MonadIO m => MonadIO (StateC s m) where
  liftIO :: IO a -> StateC s m a
liftIO io :: IO a
io = (s -> m (s, a)) -> StateC s m a
forall s (m :: * -> *) a. (s -> m (s, a)) -> StateC s m a
StateC (\ s :: s
s -> (,) s
s (a -> (s, a)) -> m a -> m (s, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
io)
  {-# 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 :: m a
m = (s -> m (s, a)) -> StateC s m a
forall s (m :: * -> *) a. (s -> m (s, a)) -> StateC s m a
StateC (\ s :: s
s -> (,) s
s (a -> (s, a)) -> m a -> m (s, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
m)
  {-# INLINE lift #-}

instance (Algebra sig m, Effect sig) => Algebra (State s :+: sig) (StateC s m) where
  alg :: (:+:) (State s) sig (StateC s m) a -> StateC s m a
alg (L (Get   k :: s -> StateC s m a
k)) = (s -> m (s, a)) -> StateC s m a
forall s (m :: * -> *) a. (s -> m (s, a)) -> StateC s m a
StateC (\ s :: s
s -> s -> StateC s m a -> m (s, a)
forall s (m :: * -> *) a. s -> StateC s m a -> m (s, a)
runState s
s (s -> StateC s m a
k s
s))
  alg (L (Put s :: s
s k :: StateC s m a
k)) = (s -> m (s, a)) -> StateC s m a
forall s (m :: * -> *) a. (s -> m (s, a)) -> StateC s m a
StateC (\ _ -> s -> StateC s m a -> m (s, a)
forall s (m :: * -> *) a. s -> StateC s m a -> m (s, a)
runState s
s StateC s m a
k)
  alg (R other :: sig (StateC s m) a
other)     = (s -> m (s, a)) -> StateC s m a
forall s (m :: * -> *) a. (s -> m (s, a)) -> StateC s m a
StateC (\ s :: s
s -> sig m (s, a) -> m (s, a)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Algebra sig m =>
sig m a -> m a
alg ((s, ())
-> (forall x. (s, StateC s m x) -> m (s, x))
-> sig (StateC s m) a
-> sig m (s, a)
forall (sig :: (* -> *) -> * -> *) (ctx :: * -> *) (m :: * -> *)
       (n :: * -> *) a.
(Effect sig, Functor ctx, Monad m) =>
ctx ()
-> (forall x. ctx (m x) -> n (ctx x)) -> sig m a -> sig n (ctx a)
thread (s
s, ()) ((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 -> StateC s m x -> m (s, x)
forall s (m :: * -> *) a. s -> StateC s m a -> m (s, a)
runState) sig (StateC s m) a
other))
  {-# INLINE alg #-}