{-# LANGUAGE BlockArguments #-}
module Control.Effect.State
  ( -- * Effect
    State(..)

    -- * Actions
  , state
  , state'
  , get
  , gets
  , put
  , modify
  , modify'

    -- * Interpretations
  , runState
  , evalState
  , execState

  , runStateLazy
  , evalStateLazy
  , execStateLazy

  , stateToIO
  , runStateIORef

    -- * Simple variants of interpretations
  , stateToIOSimple
  , runStateIORefSimple

    -- * Threading constraints
  , StateThreads
  , StateLazyThreads

    -- * Carriers
  , StateC
  , StateLazyC
  ) where

import Data.IORef
import Data.Tuple

import Control.Effect

import Control.Effect.Internal.State

import qualified Control.Monad.Trans.State.Strict as SSt
import qualified Control.Monad.Trans.State.Lazy as LSt

-- | Read and modify the state.
--
-- The resulting tuple of the computation is forced. You can
-- control what parts of the computation are evaluated by tying
-- their evaluation to the tuple.
state :: Eff (State s) m => (s -> (s, a)) -> m a
state :: (s -> (s, a)) -> m a
state s -> (s, a)
f = do
  (s
s, a
a) <- s -> (s, a)
f (s -> (s, a)) -> m s -> m (s, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m s
forall s (m :: * -> *). Eff (State s) m => m s
get
  s -> m ()
forall s (m :: * -> *). Eff (State s) m => s -> m ()
put s
s
  a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
{-# INLINE state #-}

-- | A variant of 'state' that forces the resulting state (but not the return value)
state' :: Eff (State s) m => (s -> (s, a)) -> m a
state' :: (s -> (s, a)) -> m a
state' s -> (s, a)
f = do
  (s
s, a
a) <- s -> (s, a)
f (s -> (s, a)) -> m s -> m (s, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m s
forall s (m :: * -> *). Eff (State s) m => m s
get
  s -> m ()
forall s (m :: * -> *). Eff (State s) m => s -> m ()
put (s -> m ()) -> s -> m ()
forall a b. (a -> b) -> a -> b
$! s
s
  a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
{-# INLINE state' #-}

get :: Eff (State s) m => m s
get :: m s
get = State s m s -> m s
forall (e :: Effect) (m :: * -> *) a.
(Member e (Derivs m), Carrier m) =>
e m a -> m a
send State s m s
forall s (m :: * -> *). State s m s
Get
{-# INLINE get #-}

gets :: Eff (State s) m => (s -> a) -> m a
gets :: (s -> a) -> m a
gets = ((s -> a) -> m s -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m s
forall s (m :: * -> *). Eff (State s) m => m s
get)
{-# INLINE gets #-}

put :: Eff (State s) m => s -> m ()
put :: s -> m ()
put = State s m () -> m ()
forall (e :: Effect) (m :: * -> *) a.
(Member e (Derivs m), Carrier m) =>
e m a -> m a
send (State s m () -> m ()) -> (s -> State s m ()) -> s -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> State s m ()
forall s (m :: * -> *). s -> State s m ()
Put
{-# INLINE put #-}

modify :: Eff (State s) m => (s -> s) -> m ()
modify :: (s -> s) -> m ()
modify s -> s
f = do
  s
s <- m s
forall s (m :: * -> *). Eff (State s) m => m s
get
  s -> m ()
forall s (m :: * -> *). Eff (State s) m => s -> m ()
put (s -> s
f s
s)

-- | A variant of 'modify' that forces the resulting state.
modify' :: Eff (State s) m => (s -> s) -> m ()
modify' :: (s -> s) -> m ()
modify' s -> s
f = do
  s
s <- m s
forall s (m :: * -> *). Eff (State s) m => m s
get
  s -> m ()
forall s (m :: * -> *). Eff (State s) m => s -> m ()
put (s -> m ()) -> s -> m ()
forall a b. (a -> b) -> a -> b
$! s -> s
f s
s

-- | Runs a @'State' s@ effect by transforming it into non-atomic
-- operations over an 'IORef'.
--
-- This has a higher-rank type, as it makes use of 'InterpretReifiedC'.
-- __This makes 'runStateIORef' very difficult to use partially applied.__
-- __In particular, it can't be composed using @'.'@.__
--
-- If performance is secondary, consider using the slower
-- 'runStateIORefSimple', which doesn't have a higher-rank type.
runStateIORef :: forall s m a
               . Eff (Embed IO) m
              => IORef s
              -> InterpretReifiedC (State s) m a
              -> m a
runStateIORef :: IORef s -> InterpretReifiedC (State s) m a -> m a
runStateIORef IORef s
ref = EffHandler (State s) m -> InterpretReifiedC (State s) m a -> m a
forall (e :: Effect) (m :: * -> *) a.
(RepresentationalEff e, Carrier m) =>
EffHandler e m -> InterpretReifiedC e m a -> m a
interpret (EffHandler (State s) m -> InterpretReifiedC (State s) m a -> m a)
-> EffHandler (State s) m -> InterpretReifiedC (State s) m a -> m a
forall a b. (a -> b) -> a -> b
$ \case
  State s (Effly z) x
Get   -> IO s -> Effly z s
forall (b :: * -> *) (m :: * -> *) a. Eff (Embed b) m => b a -> m a
embed (IO s -> Effly z s) -> IO s -> Effly z s
forall a b. (a -> b) -> a -> b
$ IORef s -> IO s
forall a. IORef a -> IO a
readIORef IORef s
ref
  Put s -> IO () -> Effly z ()
forall (b :: * -> *) (m :: * -> *) a. Eff (Embed b) m => b a -> m a
embed (IO () -> Effly z ()) -> IO () -> Effly z ()
forall a b. (a -> b) -> a -> b
$ IORef s -> s -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef s
ref s
s
{-# INLINE runStateIORef #-}

-- | Runs a @'State' s@ effect by transforming it into non-atomic
-- operations in IO.
--
-- This has a higher-rank type, as it makes use of 'InterpretReifiedC'.
-- __This makes 'stateToIO' very difficult to use partially applied.__
-- __In particular, it can't be composed using @'.'@.__
--
-- If performance is secondary, consider using the slower
-- 'stateToIOSimple', which doesn't have a higher-rank type.
stateToIO :: forall s m a
           . Eff (Embed IO) m
          => s
          -> InterpretReifiedC (State s) m a
          -> m (s, a)
stateToIO :: s -> InterpretReifiedC (State s) m a -> m (s, a)
stateToIO s
s InterpretReifiedC (State s) m a
main = do
  IORef s
ref <- IO (IORef s) -> m (IORef s)
forall (b :: * -> *) (m :: * -> *) a. Eff (Embed b) m => b a -> m a
embed (IO (IORef s) -> m (IORef s)) -> IO (IORef s) -> m (IORef s)
forall a b. (a -> b) -> a -> b
$ s -> IO (IORef s)
forall a. a -> IO (IORef a)
newIORef s
s
  a
a   <- IORef s -> InterpretReifiedC (State s) m a -> m a
forall s (m :: * -> *) a.
Eff (Embed IO) m =>
IORef s -> InterpretReifiedC (State s) m a -> m a
runStateIORef IORef s
ref InterpretReifiedC (State s) m a
main
  s
s'  <- IO s -> m s
forall (b :: * -> *) (m :: * -> *) a. Eff (Embed b) m => b a -> m a
embed (IO s -> m s) -> IO s -> m s
forall a b. (a -> b) -> a -> b
$ IORef s -> IO s
forall a. IORef a -> IO a
readIORef IORef s
ref
  (s, a) -> m (s, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (s
s', a
a)
{-# INLINE stateToIO #-}

-- | Runs a @'State' s@ effect by transforming it into non-atomic
-- operations over an 'IORef'.
--
-- This is a less performant version of 'runStateIORef' that doesn't have
-- a higher-rank type, making it much easier to use partially applied.
runStateIORefSimple :: forall s m a p
                     . ( Eff (Embed IO) m
                       , Threaders '[ReaderThreads] m p
                       )
                    => IORef s
                    -> InterpretSimpleC (State s) m a
                    -> m a
runStateIORefSimple :: IORef s -> InterpretSimpleC (State s) m a -> m a
runStateIORefSimple IORef s
ref = EffHandler (State s) m -> InterpretSimpleC (State s) m a -> m a
forall (e :: Effect) (m :: * -> *) a (p :: [Effect]).
(RepresentationalEff e, Threaders '[ReaderThreads] m p,
 Carrier m) =>
EffHandler e m -> InterpretSimpleC e m a -> m a
interpretSimple (EffHandler (State s) m -> InterpretSimpleC (State s) m a -> m a)
-> EffHandler (State s) m -> InterpretSimpleC (State s) m a -> m a
forall a b. (a -> b) -> a -> b
$ \case
  State s (Effly z) x
Get   -> IO s -> Effly z s
forall (b :: * -> *) (m :: * -> *) a. Eff (Embed b) m => b a -> m a
embed (IO s -> Effly z s) -> IO s -> Effly z s
forall a b. (a -> b) -> a -> b
$ IORef s -> IO s
forall a. IORef a -> IO a
readIORef IORef s
ref
  Put s -> IO () -> Effly z ()
forall (b :: * -> *) (m :: * -> *) a. Eff (Embed b) m => b a -> m a
embed (IO () -> Effly z ()) -> IO () -> Effly z ()
forall a b. (a -> b) -> a -> b
$ IORef s -> s -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef s
ref s
s
{-# INLINE runStateIORefSimple #-}

-- | Runs a @'State' s@ effect by transforming it into non-atomic
-- operations in IO.
--
-- This is a less performant version of 'stateToIO' that doesn't have
-- a higher-rank type, making it much easier to use partially applied.
stateToIOSimple :: forall s m a p
                 . ( Eff (Embed IO) m
                   , Threaders '[ReaderThreads] m p
                   )
                => s
                -> InterpretSimpleC (State s) m a
                -> m (s, a)
stateToIOSimple :: s -> InterpretSimpleC (State s) m a -> m (s, a)
stateToIOSimple s
s InterpretSimpleC (State s) m a
main = do
  IORef s
ref <- IO (IORef s) -> m (IORef s)
forall (b :: * -> *) (m :: * -> *) a. Eff (Embed b) m => b a -> m a
embed (IO (IORef s) -> m (IORef s)) -> IO (IORef s) -> m (IORef s)
forall a b. (a -> b) -> a -> b
$ s -> IO (IORef s)
forall a. a -> IO (IORef a)
newIORef s
s
  a
a   <- IORef s -> InterpretSimpleC (State s) m a -> m a
forall s (m :: * -> *) a (p :: [Effect]).
(Eff (Embed IO) m, Threaders '[ReaderThreads] m p) =>
IORef s -> InterpretSimpleC (State s) m a -> m a
runStateIORefSimple IORef s
ref InterpretSimpleC (State s) m a
main
  s
s'  <- IO s -> m s
forall (b :: * -> *) (m :: * -> *) a. Eff (Embed b) m => b a -> m a
embed (IO s -> m s) -> IO s -> m s
forall a b. (a -> b) -> a -> b
$ IORef s -> IO s
forall a. IORef a -> IO a
readIORef IORef s
ref
  (s, a) -> m (s, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (s
s', a
a)
{-# INLINE stateToIOSimple #-}

-- | Runs a @'State' s@ effect purely.
--
-- @'Derivs' ('StateC' s m) = 'State' s ': 'Derivs' m@
--
-- @'Control.Effect.Carrier.Prims'  ('StateC' e m) = 'Control.Effect.Carrier.Prims' m@
runState :: forall s m a p
          . ( Carrier m
            , Threaders '[StateThreads] m p
            )
         => s
         -> StateC s m a
         -> m (s, a)
runState :: s -> StateC s m a -> m (s, a)
runState s
sInit StateC s m a
m = do
  (a
a, s
sEnd) <- StateT s m a -> s -> m (a, s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
SSt.runStateT (StateC s m a -> StateT s m a
forall s (m :: * -> *) a. StateC s m a -> StateT s m a
unStateC StateC s m a
m) s
sInit
  (s, a) -> m (s, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (s
sEnd, a
a)
{-# INLINE runState #-}

-- | Runs a @'State' s@ effect purely, discarding
-- the end state.
evalState :: forall s m a p
           . ( Carrier m
             , Threaders '[StateThreads] m p
             )
          => s
          -> StateC s m a
          -> m a
evalState :: s -> StateC s m a -> m a
evalState s
sInit StateC s m a
m = do
  (a
a, s
_) <- StateT s m a -> s -> m (a, s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
SSt.runStateT (StateC s m a -> StateT s m a
forall s (m :: * -> *) a. StateC s m a -> StateT s m a
unStateC StateC s m a
m) s
sInit
  a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
{-# INLINE evalState #-}

-- | Runs a @'State' s@ effect purely, discarding
-- the end result.
execState :: forall s m a p
           . ( Carrier m
             , Threaders '[StateThreads] m p
             )
          => s
          -> StateC s m a
          -> m s
execState :: s -> StateC s m a -> m s
execState s
sInit StateC s m a
m = do
  (a
_, s
sEnd) <- StateT s m a -> s -> m (a, s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
SSt.runStateT (StateC s m a -> StateT s m a
forall s (m :: * -> *) a. StateC s m a -> StateT s m a
unStateC StateC s m a
m) s
sInit
  s -> m s
forall (m :: * -> *) a. Monad m => a -> m a
return s
sEnd
{-# INLINE execState #-}

-- | Runs a @'State' s@ effect purely and lazily.
--
-- @'Derivs' ('StateLazyC' s m) = 'State' s ': 'Derivs' m@
--
-- @'Control.Effect.Carrier.Prims'  ('StateLazyC' e m) = 'Control.Effect.Carrier.Prims' m@
runStateLazy :: forall s m a p
              . ( Carrier m
                , Threaders '[StateLazyThreads] m p
                )
             => s
             -> StateLazyC s m a
             -> m (s, a)
runStateLazy :: s -> StateLazyC s m a -> m (s, a)
runStateLazy s
sInit StateLazyC s m a
m = (a, s) -> (s, a)
forall a b. (a, b) -> (b, a)
swap ((a, s) -> (s, a)) -> m (a, s) -> m (s, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT s m a -> s -> m (a, s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
LSt.runStateT (StateLazyC s m a -> StateT s m a
forall s (m :: * -> *) a. StateLazyC s m a -> StateT s m a
unStateLazyC StateLazyC s m a
m) s
sInit
{-# INLINE runStateLazy #-}

-- | Runs a @'State' s@ effect purely and lazily,
-- discarding the final state.
evalStateLazy :: forall s m a p
               . ( Carrier m
                 , Threaders '[StateLazyThreads] m p
                 )
              => s
              -> StateLazyC s m a
              -> m a
evalStateLazy :: s -> StateLazyC s m a -> m a
evalStateLazy s
sInit StateLazyC s m a
m = (a, s) -> a
forall a b. (a, b) -> a
fst ((a, s) -> a) -> m (a, s) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT s m a -> s -> m (a, s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
LSt.runStateT (StateLazyC s m a -> StateT s m a
forall s (m :: * -> *) a. StateLazyC s m a -> StateT s m a
unStateLazyC StateLazyC s m a
m) s
sInit
{-# INLINE evalStateLazy #-}

-- | Runs a @'State' s@ effect purely and lazily,
-- discarding the end result.
execStateLazy :: forall s m a p
               . ( Carrier m
                 , Threaders '[StateLazyThreads] m p
                 )
              => s
              -> StateLazyC s m a
              -> m s
execStateLazy :: s -> StateLazyC s m a -> m s
execStateLazy s
sInit StateLazyC s m a
m = (a, s) -> s
forall a b. (a, b) -> b
snd ((a, s) -> s) -> m (a, s) -> m s
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT s m a -> s -> m (a, s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
LSt.runStateT (StateLazyC s m a -> StateT s m a
forall s (m :: * -> *) a. StateLazyC s m a -> StateT s m a
unStateLazyC StateLazyC s m a
m) s
sInit
{-# INLINE execStateLazy #-}