{-# LANGUAGE DeriveFunctor, ExplicitForAll, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
module Control.Effect.State.Lazy
( -- * State effect
  module State
  -- * Lazy state carrier
, runState
, evalState
, execState
, StateC(..)
  -- * Re-exports
, Carrier
, run
) where

import Control.Applicative (Alternative(..))
import Control.Effect.Carrier
import Control.Effect.State.Internal as 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

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

instance (Functor m, 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 (m :: * -> *) a. Monad m => a -> m a
return (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
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) <- StateC s m a -> s -> m (s, a)
forall s (m :: * -> *) a. StateC s m a -> s -> m (s, a)
runStateC StateC s m a
m s
s
    StateC s m b -> s -> m (s, b)
forall s (m :: * -> *) a. StateC s m a -> s -> m (s, a)
runStateC (a -> StateC s m b
k a
a) s
s'
  {-# 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 (Carrier sig m, Effect sig) => Carrier (State s :+: sig) (StateC s m) where
  eff :: (:+:) (State s) sig (StateC s m) a -> StateC s m a
eff (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))
  eff (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)
  eff (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.
Carrier sig m =>
sig m a -> m a
eff ((s, ())
-> (forall x. (s, StateC s m x) -> m (s, x))
-> sig (StateC s m) a
-> sig m (s, a)
forall (sig :: (* -> *) -> * -> *) (f :: * -> *) (m :: * -> *)
       (n :: * -> *) a.
(Effect sig, Functor f, Monad m) =>
f () -> (forall x. f (m x) -> n (f x)) -> sig m a -> sig n (f a)
handle (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 eff #-}

-- | 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.
--
--   prop> run (runState a (pure b)) === (a, b)
--   prop> take 5 . snd . run $ runState () (traverse pure [1..]) === [1,2,3,4,5]
runState :: s -> StateC s m a -> m (s, a)
runState :: s -> StateC s m a -> m (s, a)
runState s :: s
s c :: StateC s m a
c = StateC s m a -> s -> m (s, a)
forall s (m :: * -> *) a. StateC s m a -> s -> m (s, a)
runStateC StateC s m a
c s
s
{-# INLINE[3] runState #-}

-- | Run a lazy 'State' effect, yielding the result value and discarding the final state.
--
--   prop> run (evalState a (pure b)) === b
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.
--
--   prop> run (execState a (pure b)) === a
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 #-}

-- $setup
-- >>> :seti -XFlexibleContexts
-- >>> import Test.QuickCheck
-- >>> import Control.Effect.Pure