module DeepControl.Monad.State (
MonadState(..),
modify, gets,
State(..), evalState, execState, mapState, withState,
StateT(..), evalStateT, execStateT, mapStateT, withStateT, liftCatch,
StateT2(..), evalStateT2, execStateT2, mapStateT2, withStateT2,
StateT3(..), evalStateT3, execStateT3, mapStateT3, withStateT3,
) where
import DeepControl.Applicative
import DeepControl.Monad
import DeepControl.MonadTrans
import Control.Monad.State (MonadState(..))
import Control.Monad.Signatures
modify :: MonadState s m => (s -> s) -> m ()
modify f = state $ \s -> ((), f s)
gets :: MonadState s m => (s -> a) -> m a
gets f = state $ \s -> (f s, s)
newtype State s a = State { runState :: s -> (a, s) }
instance Functor (State s) where
fmap f v = State $ \s ->
(\(a, s') -> (f a, s')) $ runState v s
instance Applicative (State s) where
pure a = State $ \s -> (a,s)
(<*>) = ap
instance Monad (State s) where
return = (*:)
(State v) >>= f =
State $ \s ->
v s >- \(a, s') ->
runState (f a) s'
instance MonadState s (State s) where
get = State $ \s -> (s, s)
put s = State $ \_ -> ((), s)
evalState :: State s a -> s -> a
evalState m s =
let (a, _) = runState m s
in a
execState :: State s a -> s -> s
execState m s =
let (_, s') = runState m s
in s'
mapState :: ((a, s) -> (b, s)) -> State s a -> State s b
mapState f m = State $ f . runState m
withState :: (s -> s) -> State s a -> State s a
withState f m = State $ runState m . f
newtype StateT s m a = StateT { runStateT :: (s -> m (a,s)) }
instance (Functor m) => Functor (StateT s m) where
fmap f v = StateT $ \s ->
(\(a, s') -> (f a, s')) |$> runStateT v s
instance (Monad m) => Applicative (StateT s m) where
pure a = StateT $ \s -> (*:) (a,s)
(<*>) = ap
instance (Monad m) => Monad (StateT s m) where
return = pure
(StateT v) >>= f =
StateT $ \s ->
v s >>= \(a, s') ->
runStateT (f a) s'
instance (Monad m) => MonadState s (StateT s m) where
get = StateT $ \s -> (*:) (s, s)
put s = StateT $ \_ -> (*:) ((), s)
instance MonadTrans (StateT s) where
trans m = StateT $ \s ->
m >>= \a ->
(*:) (a, s)
instance (MonadIO m, Monad m) => MonadIO (StateT s m) where
liftIO = trans . liftIO
evalStateT :: (Monad m) => StateT s m a -> s -> m a
evalStateT m s =
runStateT m s >>= \(a, _) ->
(*:) a
execStateT :: (Monad m) => StateT s m a -> s -> m s
execStateT m s =
runStateT m s >>= \(_, s') ->
(*:) s'
mapStateT :: (m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b
mapStateT f m = StateT $ f . runStateT m
withStateT :: (s -> s) -> StateT s m a -> StateT s m a
withStateT f m = StateT $ runStateT m . f
liftCatch :: Catch e m (a,s) -> Catch e (StateT s m) a
liftCatch catch m h =
StateT $ \ s -> runStateT m s `catch` \ e -> runStateT (h e) s
newtype StateT2 s m1 m2 a = StateT2 { runStateT2 :: (s -> m1 (m2 (a,s))) }
instance (Functor m1, Functor m2) => Functor (StateT2 s m1 m2) where
fmap f v = StateT2 $ \s ->
(\(a, s') -> (f a, s')) |$>> runStateT2 v s
instance (Monad m1, Monad2 m2) => Applicative (StateT2 s m1 m2) where
pure a = StateT2 $ \s -> (**:) (a,s)
(<*>) = ap
instance (Monad m1, Monad2 m2) => Monad (StateT2 s m1 m2) where
return = pure
(StateT2 v) >>= f =
StateT2 $ \s ->
v s >>== \(a, s') ->
runStateT2 (f a) s'
instance (Monad m1, Monad2 m2) => MonadState s (StateT2 s m1 m2) where
get = StateT2 $ \s -> (**:) (s, s)
put s = StateT2 $ \_ -> (**:) ((), s)
instance MonadTrans2 (StateT2 s) where
trans2 m = StateT2 $ \s ->
m >>== \a ->
(**:) (a, s)
instance (MonadIO m1, Monad m1, Monad2 m2) => MonadIO (StateT2 s m1 m2) where
liftIO = trans2 . (-*) . liftIO
evalStateT2 :: (Monad m1, Monad2 m2) => StateT2 s m1 m2 a -> s -> m1 (m2 a)
evalStateT2 m s =
runStateT2 m s >>== \(a, _) ->
(**:) a
execStateT2 :: (Monad m1, Monad2 m2) => StateT2 s m1 m2 a -> s -> m1 (m2 s)
execStateT2 m s =
runStateT2 m s >>== \(_, s') ->
(**:) s'
mapStateT2 :: (m1 (m2 (a, s)) -> n1 (n2 (b, s))) -> StateT2 s m1 m2 a -> StateT2 s n1 n2 b
mapStateT2 f m = StateT2 $ f . runStateT2 m
withStateT2 :: (s -> s) -> StateT2 s m1 m2 a -> StateT2 s m1 m2 a
withStateT2 f m = StateT2 $ runStateT2 m . f
newtype StateT3 s m1 m2 m3 a = StateT3 { runStateT3 :: (s -> m1 (m2 (m3 (a,s)))) }
instance (Functor m1, Functor m2, Functor m3) => Functor (StateT3 s m1 m2 m3) where
fmap f v = StateT3 $ \s ->
(\(a, s') -> (f a, s')) |$>>> runStateT3 v s
instance (Monad m1, Monad2 m2, Monad3 m3) => Applicative (StateT3 s m1 m2 m3) where
pure a = StateT3 $ \s -> (***:) (a,s)
(<*>) = ap
instance (Monad m1, Monad2 m2, Monad3 m3) => Monad (StateT3 s m1 m2 m3) where
return = pure
(StateT3 v) >>= f =
StateT3 $ \s ->
v s >>>== \(a, s') ->
runStateT3 (f a) s'
instance (Monad m1, Monad2 m2, Monad3 m3) => MonadState s (StateT3 s m1 m2 m3) where
get = StateT3 $ \s -> (***:) (s, s)
put s = StateT3 $ \_ -> (***:) ((), s)
instance MonadTrans3 (StateT3 s) where
trans3 m = StateT3 $ \s ->
m >>>== \a ->
(***:) (a, s)
instance (MonadIO m1, Monad m1, Monad2 m2, Monad3 m3) => MonadIO (StateT3 s m1 m2 m3) where
liftIO = trans3 . (-**) . liftIO
evalStateT3 :: (Monad m1, Monad2 m2, Monad3 m3) => StateT3 s m1 m2 m3 a -> s -> m1 (m2 (m3 a))
evalStateT3 m s =
runStateT3 m s >>>== \(a, _) ->
(***:) a
execStateT3 :: (Monad m1, Monad2 m2, Monad3 m3) => StateT3 s m1 m2 m3 a -> s -> m1 (m2 (m3 s))
execStateT3 m s =
runStateT3 m s >>>== \(_, s') ->
(***:) s'
mapStateT3 :: (m1 (m2 (m3 (a, s))) -> n1 (n2 (n3 (b, s)))) -> StateT3 s m1 m2 m3 a -> StateT3 s n1 n2 n3 b
mapStateT3 f m = StateT3 $ f . runStateT3 m
withStateT3 :: (s -> s) -> StateT3 s m1 m2 m3 a -> StateT3 s m1 m2 m3 a
withStateT3 f m = StateT3 $ runStateT3 m . f