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

{- | A carrier for the 'State' effect that refrains from evaluating its state until necessary. This is less efficient than "Control.Carrier.State.Strict" but allows some cyclic computations to terminate that would loop infinitely in a strict state carrier.

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.Lazy
( -- * Lazy 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 lazy 'State' effect, yielding the result value and the final state. More programs terminate with lazy state than strict state, but injudicious use of lazy state may lead to thunk buildup.
--
-- @
-- '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 lazy '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 lazy '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 { StateC s m a -> s -> m (s, a)
runStateC :: s -> m (s, a) }

instance Functor m => Functor (StateC s m) where
  fmap :: (a -> b) -> StateC s m a -> StateC s m b
fmap f :: a -> b
f m :: StateC s m a
m = (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 -> (\ ~(s' :: s
s', a :: a
a) -> (s
s', a -> b
f a
a)) ((s, a) -> (s, b)) -> m (s, a) -> m (s, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
  {-# INLINE fmap #-}

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 -> m (s, a)) -> StateC s m a)
-> (s -> m (s, a)) -> StateC s m a
forall a b. (a -> b) -> a -> b
$ \ s :: s
s -> (s, a) -> m (s, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (s
s, a
a)
  {-# INLINE pure #-}
  StateC mf :: s -> m (s, a -> b)
mf <*> :: StateC s m (a -> b) -> StateC s m a -> StateC s m b
<*> StateC mx :: s -> m (s, a)
mx = (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)
mf s
s
    ~(s'' :: s
s'', x :: a
x) <- s -> m (s, a)
mx s
s'
    (s, b) -> m (s, b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (s
s'', a -> b
f a
x)
  {-# 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 -> a -> StateC s m b
forall a b. a -> b -> a
const StateC s m b
k
  {-# INLINE (*>) #-}

instance Monad m => Monad (StateC s m) where
  m :: StateC s m a
m >>= :: StateC s m a -> (a -> StateC s m b) -> StateC s m b
>>= k :: a -> StateC s m b
k = (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 -> 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 -> 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
k a
a)
  {-# 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 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 #-}