module Ether.State
(
MonadState
, get
, put
, state
, modify
, gets
, State
, runState
, evalState
, execState
, StateT
, stateT
, runStateT
, evalStateT
, execStateT
, LazyState
, runLazyState
, evalLazyState
, execLazyState
, LazyStateT
, lazyStateT
, runLazyStateT
, evalLazyStateT
, execLazyStateT
, States
, runStates
, StatesT
, runStatesT
, MonadState'
, get'
, put'
, state'
, modify'
, gets'
, State'
, runState'
, evalState'
, execState'
, StateT'
, stateT'
, runStateT'
, evalStateT'
, execStateT'
, LazyState'
, runLazyState'
, evalLazyState'
, execLazyState'
, LazyStateT'
, lazyStateT'
, runLazyStateT'
, evalLazyStateT'
, execLazyStateT'
, ZoomT
, zoom
, TAGGED
, STATE
, STATES
, ZOOM
) where
import qualified Control.Monad.State.Class as T
import qualified Control.Monad.Trans as Lift
import Control.Monad.Trans.Identity
import qualified Control.Monad.Trans.State.Lazy as T.Lazy
import qualified Control.Monad.Trans.State.Strict as T.Strict
import Data.Coerce
import Data.Functor.Identity
import Data.Kind
import Data.Proxy
import Data.Reflection
import Ether.Internal
import Ether.TaggedTrans
class Monad m => MonadState tag s m | m tag -> s where
get :: m s
get = state @tag (\s -> (s, s))
put :: s -> m ()
put s = state @tag (\_ -> ((), s))
state :: (s -> (a, s)) -> m a
state f = do
s <- get @tag
let ~(a, s') = f s
put @tag s'
return a
instance
( Lift.MonadTrans t
, Monad (t m)
, MonadState tag s m
) => MonadState tag s (t m)
where
get = Lift.lift (get @tag)
put = Lift.lift . put @tag
state = Lift.lift . state @tag
instance
( Monad (trans m)
, MonadState tag s (TaggedTrans effs trans m)
) => MonadState tag s (TaggedTrans (eff ': effs) trans (m :: Type -> Type))
where
get =
(coerce ::
TaggedTrans effs trans m s ->
TaggedTrans (eff ': effs) trans m s)
(get @tag)
put =
(coerce ::
(s -> TaggedTrans effs trans m ()) ->
(s -> TaggedTrans (eff ': effs) trans m ()))
(put @tag)
state =
(coerce :: forall a .
((s -> (a, s)) -> TaggedTrans effs trans m a) ->
((s -> (a, s)) -> TaggedTrans (eff ': effs) trans m a))
(state @tag)
modify :: forall tag s m . MonadState tag s m => (s -> s) -> m ()
modify f = state @tag (\s -> ((), f s))
gets :: forall tag s m a . MonadState tag s m => (s -> a) -> m a
gets f = fmap f (get @tag)
data STATE
type instance HandleSuper STATE s trans = ()
type instance HandleConstraint STATE s trans m =
T.MonadState s (trans m)
instance Handle STATE s (T.Strict.StateT s) where
handling r = r
instance Handle STATE s (T.Lazy.StateT s) where
handling r = r
instance
( Handle STATE s trans
, Monad m, Monad (trans m)
) => MonadState tag s (TaggedTrans (TAGGED STATE tag) trans m)
where
get =
handling @STATE @s @trans @m $
coerce (T.get @s @(trans m))
put =
handling @STATE @s @trans @m $
coerce (T.put @s @(trans m))
state =
handling @STATE @s @trans @m $
coerce (T.state @s @(trans m) @a) ::
forall eff a . (s -> (a, s)) -> TaggedTrans eff trans m a
instance
( HasLens tag payload s
, Handle STATE payload trans
, Monad m, Monad (trans m)
) => MonadState tag s (TaggedTrans (TAGGED STATE tag ': effs) trans m)
where
get =
handling @STATE @payload @trans @m $
(coerce :: forall eff a .
trans m a ->
TaggedTrans eff trans m a)
(T.gets (view (lensOf @tag @payload @s)))
put s =
handling @STATE @payload @trans @m $
(coerce :: forall eff a .
trans m a ->
TaggedTrans eff trans m a)
(T.modify (over (lensOf @tag @payload @s) (const s)))
state f =
handling @STATE @payload @trans @m $
(coerce :: forall eff a .
trans m a ->
TaggedTrans eff trans m a)
(T.state (lensOf @tag @payload @s f))
type State tag r = StateT tag r Identity
type StateT tag s = TaggedTrans (TAGGED STATE tag) (T.Strict.StateT s)
stateT :: forall tag s m a . (s -> m (a, s)) -> StateT tag s m a
stateT = coerce (T.Strict.StateT @s @m @a)
runStateT :: forall tag s m a . StateT tag s m a -> s -> m (a, s)
runStateT = coerce (T.Strict.runStateT @s @m @a)
evalStateT :: forall tag s m a . Monad m => StateT tag s m a -> s -> m a
evalStateT = coerce (T.Strict.evalStateT @m @s @a)
execStateT :: forall tag s m a . Monad m => StateT tag s m a -> s -> m s
execStateT = coerce (T.Strict.execStateT @m @s @a)
runState :: forall tag s a . State tag s a -> s -> (a, s)
runState = coerce (T.Strict.runState @s @a)
evalState :: forall tag s a . State tag s a -> s -> a
evalState = coerce (T.Strict.evalState @s @a)
execState :: forall tag s a . State tag s a -> s -> s
execState = coerce (T.Strict.execState @s @a)
type LazyState tag r = LazyStateT tag r Identity
type LazyStateT tag s = TaggedTrans (TAGGED STATE tag) (T.Lazy.StateT s)
lazyStateT :: forall tag s m a . (s -> m (a, s)) -> LazyStateT tag s m a
lazyStateT = coerce (T.Lazy.StateT @s @m @a)
runLazyStateT :: forall tag s m a . LazyStateT tag s m a -> s -> m (a, s)
runLazyStateT = coerce (T.Lazy.runStateT @s @m @a)
evalLazyStateT :: forall tag s m a . Monad m => LazyStateT tag s m a -> s -> m a
evalLazyStateT = coerce (T.Lazy.evalStateT @m @s @a)
execLazyStateT :: forall tag s m a . Monad m => LazyStateT tag s m a -> s -> m s
execLazyStateT = coerce (T.Lazy.execStateT @m @s @a)
runLazyState :: forall tag s a . LazyState tag s a -> s -> (a, s)
runLazyState = coerce (T.Lazy.runState @s @a)
evalLazyState :: forall tag s a . LazyState tag s a -> s -> a
evalLazyState = coerce (T.Lazy.evalState @s @a)
execLazyState :: forall tag s a . LazyState tag s a -> s -> s
execLazyState = coerce (T.Lazy.execState @s @a)
type family STATES (ts :: HList xs) :: [Type] where
STATES 'HNil = '[]
STATES ('HCons t ts) = TAGGED STATE t ': STATES ts
type StatesT s = TaggedTrans (STATES (Tags s)) (T.Strict.StateT s)
type States s = StatesT s Identity
runStatesT :: forall p m a . StatesT p m a -> p -> m (a, p)
runStatesT = coerce (T.Strict.runStateT @p @m @a)
runStates :: forall p a . States p a -> p -> (a, p)
runStates = coerce (T.Strict.runState @p @a)
type StateT' s = StateT s s
stateT' :: (s -> m (a, s)) -> StateT' s m a
stateT' = stateT
runStateT' :: StateT' s m a -> s -> m (a, s)
runStateT' = runStateT
runState' :: State' s a -> s -> (a, s)
runState' = runState
evalStateT' :: Monad m => StateT' s m a -> s -> m a
evalStateT' = evalStateT
type State' s = State s s
evalState' :: State' s a -> s -> a
evalState' = evalState
execStateT' :: Monad m => StateT' s m a -> s -> m s
execStateT' = execStateT
execState' :: State' s a -> s -> s
execState' = execState
type LazyStateT' s = LazyStateT s s
lazyStateT' :: (s -> m (a, s)) -> LazyStateT' s m a
lazyStateT' = lazyStateT
runLazyStateT' :: LazyStateT' s m a -> s -> m (a, s)
runLazyStateT' = runLazyStateT
runLazyState' :: LazyState' s a -> s -> (a, s)
runLazyState' = runLazyState
evalLazyStateT' :: Monad m => LazyStateT' s m a -> s -> m a
evalLazyStateT' = evalLazyStateT
type LazyState' s = LazyState s s
evalLazyState' :: LazyState' s a -> s -> a
evalLazyState' = evalLazyState
execLazyStateT' :: Monad m => LazyStateT' s m a -> s -> m s
execLazyStateT' = execLazyStateT
execLazyState' :: LazyState' s a -> s -> s
execLazyState' = execLazyState
type MonadState' s = MonadState s s
get' :: forall s m . MonadState' s m => m s
get' = get @s
gets' :: forall s m a . MonadState' s m => (s -> a) -> m a
gets' = gets @s
put' :: forall s m . MonadState' s m => s -> m ()
put' = put @s
state' :: forall s m a . MonadState' s m => (s -> (a, s)) -> m a
state' = state @s
modify' :: forall s m . MonadState' s m => (s -> s) -> m ()
modify' = modify @s
data ZOOM t z
type ZoomT t (z :: Type) = TaggedTrans (ZOOM t z) IdentityT
zoom
:: forall tag sOuter sInner m a
. Lens' sOuter sInner
-> (forall z . Reifies z (ReifiedLens' sOuter sInner) => ZoomT tag z m a)
-> m a
zoom l m = reify (Lens l) (\(_ :: Proxy z) -> coerce (m @z))
instance
( MonadState tag sOuter m
, Reifies z (ReifiedLens' sOuter sInner)
, trans ~ IdentityT
) => MonadState tag sInner (TaggedTrans (ZOOM tag z) trans m)
where
state =
(coerce :: forall eff r a .
(r -> m a) ->
(r -> TaggedTrans eff trans m a))
(state @tag . l)
where
Lens l = reflect (Proxy :: Proxy z)