git.iko.soy/typeable/ether
on b7372d2 help sign in
typeable/ether/src/Ether/State.hs
471 lines 13 kB history raw
1module Ether.State
2 (
3 -- * MonadState class
4 MonadState
5 , get
6 , put
7 , state
8 , modify
9 , gets
10 -- * The State monad
11 , State
12 , runState
13 , evalState
14 , execState
15 -- * The StateT monad transformer
16 , StateT
17 , stateT
18 , runStateT
19 , evalStateT
20 , execStateT
21 -- * The State monad (lazy)
22 , LazyState
23 , runLazyState
24 , evalLazyState
25 , execLazyState
26 -- * The StateT monad transformer (lazy)
27 , LazyStateT
28 , lazyStateT
29 , runLazyStateT
30 , evalLazyStateT
31 , execLazyStateT
32 -- * The State monad (flattened)
33 , States
34 , runStates
35 -- * The StateT monad transformer (flattened)
36 , StatesT
37 , runStatesT
38 -- * MonadState class (implicit)
39 , MonadState'
40 , get'
41 , put'
42 , state'
43 , modify'
44 , gets'
45 -- * The State monad (implicit)
46 , State'
47 , runState'
48 , evalState'
49 , execState'
50 -- * The StateT monad transformer (implicit)
51 , StateT'
52 , stateT'
53 , runStateT'
54 , evalStateT'
55 , execStateT'
56 -- * The State monad (lazy, implicit)
57 , LazyState'
58 , runLazyState'
59 , evalLazyState'
60 , execLazyState'
61 -- * The StateT monad transformer (lazy, implicit)
62 , LazyStateT'
63 , lazyStateT'
64 , runLazyStateT'
65 , evalLazyStateT'
66 , execLazyStateT'
67 -- * Zoom
68 , ZoomT
69 , zoom
70 -- * Internal labels
71 , TAGGED
72 , STATE
73 , STATES
74 , ZOOM
75 ) where
77import qualified Control.Monad.State.Class as T
78import qualified Control.Monad.Trans as Lift
79import Control.Monad.Trans.Identity
80import qualified Control.Monad.Trans.State.Lazy as T.Lazy
81import qualified Control.Monad.Trans.State.Strict as T.Strict
82import Data.Coerce
83import Data.Functor.Identity
84import Data.Kind
85import Data.Proxy
86import Data.Reflection
88import Ether.Internal
89import Ether.TaggedTrans
91class Monad m => MonadState tag s m | m tag -> s where
93 {-# MINIMAL state | get, put #-}
95 -- | Return the state from the internals of the monad.
96 get :: m s
97 get = state @tag (\s -> (s, s))
99 -- | Replace the state inside the monad.
100 put :: s -> m ()
101 put s = state @tag (\_ -> ((), s))
103 -- | Embed a simple state action into the monad.
104 state :: (s -> (a, s)) -> m a
105 state f = do
106 s <- get @tag
107 let ~(a, s') = f s
108 put @tag s'
109 return a
111instance {-# OVERLAPPABLE #-}
112 ( Lift.MonadTrans t
113 , Monad (t m)
114 , MonadState tag s m
115 ) => MonadState tag s (t m)
116 where
118 get = Lift.lift (get @tag)
119 {-# INLINE get #-}
121 put = Lift.lift . put @tag
122 {-# INLINE put #-}
124 state = Lift.lift . state @tag
125 {-# INLINE state #-}
127instance {-# OVERLAPPABLE #-}
128 ( Monad (trans m)
129 , MonadState tag s (TaggedTrans effs trans m)
130 ) => MonadState tag s (TaggedTrans (eff ': effs) trans (m :: Type -> Type))
131 where
133 get =
134 (coerce ::
135 TaggedTrans effs trans m s ->
136 TaggedTrans (eff ': effs) trans m s)
137 (get @tag)
138 {-# INLINE get #-}
140 put =
141 (coerce ::
142 (s -> TaggedTrans effs trans m ()) ->
143 (s -> TaggedTrans (eff ': effs) trans m ()))
144 (put @tag)
145 {-# INLINE put #-}
147 state =
148 (coerce :: forall a .
149 ((s -> (a, s)) -> TaggedTrans effs trans m a) ->
150 ((s -> (a, s)) -> TaggedTrans (eff ': effs) trans m a))
151 (state @tag)
152 {-# INLINE state #-}
154-- | Modifies the state inside a state monad.
155modify :: forall tag s m . MonadState tag s m => (s -> s) -> m ()
156modify f = state @tag (\s -> ((), f s))
157{-# INLINABLE modify #-}
159-- | Gets specific component of the state, using a projection function supplied.
160gets :: forall tag s m a . MonadState tag s m => (s -> a) -> m a
161gets f = fmap f (get @tag)
162{-# INLINABLE gets #-}
164-- | Encode type-level information for 'StateT'.
165data STATE
167type instance HandleSuper STATE s trans = ()
168type instance HandleConstraint STATE s trans m =
169 T.MonadState s (trans m)
171instance Handle STATE s (T.Strict.StateT s) where
172 handling r = r
173 {-# INLINE handling #-}
175instance Handle STATE s (T.Lazy.StateT s) where
176 handling r = r
177 {-# INLINE handling #-}
179instance
180 ( Handle STATE s trans
181 , Monad m, Monad (trans m)
182 ) => MonadState tag s (TaggedTrans (TAGGED STATE tag) trans m)
183 where
185 get =
186 handling @STATE @s @trans @m $
187 coerce (T.get @s @(trans m))
188 {-# INLINE get #-}
190 put =
191 handling @STATE @s @trans @m $
192 coerce (T.put @s @(trans m))
193 {-# INLINE put #-}
195 state =
196 handling @STATE @s @trans @m $
197 coerce (T.state @s @(trans m) @a) ::
198 forall eff a . (s -> (a, s)) -> TaggedTrans eff trans m a
199 {-# INLINE state #-}
201instance
202 ( HasLens tag payload s
203 , Handle STATE payload trans
204 , Monad m, Monad (trans m)
205 ) => MonadState tag s (TaggedTrans (TAGGED STATE tag ': effs) trans m)
206 where
208 get =
209 handling @STATE @payload @trans @m $
210 (coerce :: forall eff a .
211 trans m a ->
212 TaggedTrans eff trans m a)
213 (T.gets (view (lensOf @tag @payload @s)))
214 {-# INLINE get #-}
216 put s =
217 handling @STATE @payload @trans @m $
218 (coerce :: forall eff a .
219 trans m a ->
220 TaggedTrans eff trans m a)
221 (T.modify (over (lensOf @tag @payload @s) (const s)))
222 {-# INLINE put #-}
224 state f =
225 handling @STATE @payload @trans @m $
226 (coerce :: forall eff a .
227 trans m a ->
228 TaggedTrans eff trans m a)
229 (T.state (lensOf @tag @payload @s f))
230 {-# INLINE state #-}
232-- | The parametrizable state monad.
233--
234-- Computations have access to a mutable state.
235--
236-- The 'return' function leaves the state unchanged, while '>>=' uses
237-- the final state of the first computation as the initial state of the second.
238type State tag r = StateT tag r Identity
240-- | The state monad transformer.
241--
242-- The 'return' function leaves the state unchanged, while '>>=' uses
243-- the final state of the first computation as the initial state of the second.
244type StateT tag s = TaggedTrans (TAGGED STATE tag) (T.Strict.StateT s)
246-- | Constructor for computations in the state monad transformer.
247stateT :: forall tag s m a . (s -> m (a, s)) -> StateT tag s m a
248stateT = coerce (T.Strict.StateT @s @m @a)
249{-# INLINE stateT #-}
251-- | Runs a 'StateT' with the given initial state
252-- and returns both the final value and the final state.
253runStateT :: forall tag s m a . StateT tag s m a -> s -> m (a, s)
254runStateT = coerce (T.Strict.runStateT @s @m @a)
255{-# INLINE runStateT #-}
257-- | Runs a 'StateT' with the given initial state
258-- and returns the final value, discarding the final state.
259evalStateT :: forall tag s m a . Monad m => StateT tag s m a -> s -> m a
260evalStateT = coerce (T.Strict.evalStateT @m @s @a)
261{-# INLINE evalStateT #-}
263-- | Runs a 'StateT' with the given initial state
264-- and returns the final state, discarding the final value.
265execStateT :: forall tag s m a . Monad m => StateT tag s m a -> s -> m s
266execStateT = coerce (T.Strict.execStateT @m @s @a)
267{-# INLINE execStateT #-}
269-- | Runs a 'State' with the given initial state
270-- and returns both the final value and the final state.
271runState :: forall tag s a . State tag s a -> s -> (a, s)
272runState = coerce (T.Strict.runState @s @a)
273{-# INLINE runState #-}
275-- | Runs a 'State' with the given initial state
276-- and returns the final value, discarding the final state.
277evalState :: forall tag s a . State tag s a -> s -> a
278evalState = coerce (T.Strict.evalState @s @a)
279{-# INLINE evalState #-}
281-- | Runs a 'State' with the given initial state
282-- and returns the final state, discarding the final value.
283execState :: forall tag s a . State tag s a -> s -> s
284execState = coerce (T.Strict.execState @s @a)
285{-# INLINE execState #-}
287-- | The parametrizable state monad.
288--
289-- Computations have access to a mutable state.
290--
291-- The 'return' function leaves the state unchanged, while '>>=' uses
292-- the final state of the first computation as the initial state of the second.
293type LazyState tag r = LazyStateT tag r Identity
295-- | The state monad transformer.
296--
297-- The 'return' function leaves the state unchanged, while '>>=' uses
298-- the final state of the first computation as the initial state of the second.
299type LazyStateT tag s = TaggedTrans (TAGGED STATE tag) (T.Lazy.StateT s)
301-- | Constructor for computations in the state monad transformer.
302lazyStateT :: forall tag s m a . (s -> m (a, s)) -> LazyStateT tag s m a
303lazyStateT = coerce (T.Lazy.StateT @s @m @a)
304{-# INLINE lazyStateT #-}
306-- | Runs a 'StateT' with the given initial state
307-- and returns both the final value and the final state.
308runLazyStateT :: forall tag s m a . LazyStateT tag s m a -> s -> m (a, s)
309runLazyStateT = coerce (T.Lazy.runStateT @s @m @a)
310{-# INLINE runLazyStateT #-}
312-- | Runs a 'StateT' with the given initial state
313-- and returns the final value, discarding the final state.
314evalLazyStateT :: forall tag s m a . Monad m => LazyStateT tag s m a -> s -> m a
315evalLazyStateT = coerce (T.Lazy.evalStateT @m @s @a)
316{-# INLINE evalLazyStateT #-}
318-- | Runs a 'StateT' with the given initial state
319-- and returns the final state, discarding the final value.
320execLazyStateT :: forall tag s m a . Monad m => LazyStateT tag s m a -> s -> m s
321execLazyStateT = coerce (T.Lazy.execStateT @m @s @a)
322{-# INLINE execLazyStateT #-}
324-- | Runs a 'State' with the given initial state
325-- and returns both the final value and the final state.
326runLazyState :: forall tag s a . LazyState tag s a -> s -> (a, s)
327runLazyState = coerce (T.Lazy.runState @s @a)
328{-# INLINE runLazyState #-}
330-- | Runs a 'State' with the given initial state
331-- and returns the final value, discarding the final state.
332evalLazyState :: forall tag s a . LazyState tag s a -> s -> a
333evalLazyState = coerce (T.Lazy.evalState @s @a)
334{-# INLINE evalLazyState #-}
336-- | Runs a 'State' with the given initial state
337-- and returns the final state, discarding the final value.
338execLazyState :: forall tag s a . LazyState tag s a -> s -> s
339execLazyState = coerce (T.Lazy.execState @s @a)
340{-# INLINE execLazyState #-}
342type family STATES (ts :: HList xs) :: [Type] where
343 STATES 'HNil = '[]
344 STATES ('HCons t ts) = TAGGED STATE t ': STATES ts
346type StatesT s = TaggedTrans (STATES (Tags s)) (T.Strict.StateT s)
348type States s = StatesT s Identity
350runStatesT :: forall p m a . StatesT p m a -> p -> m (a, p)
351runStatesT = coerce (T.Strict.runStateT @p @m @a)
352{-# INLINE runStatesT #-}
354runStates :: forall p a . States p a -> p -> (a, p)
355runStates = coerce (T.Strict.runState @p @a)
356{-# INLINE runStates #-}
358type StateT' s = StateT s s
360stateT' :: (s -> m (a, s)) -> StateT' s m a
361stateT' = stateT
362{-# INLINE stateT' #-}
364runStateT' :: StateT' s m a -> s -> m (a, s)
365runStateT' = runStateT
366{-# INLINE runStateT' #-}
368runState' :: State' s a -> s -> (a, s)
369runState' = runState
370{-# INLINE runState' #-}
372evalStateT' :: Monad m => StateT' s m a -> s -> m a
373evalStateT' = evalStateT
374{-# INLINE evalStateT' #-}
376type State' s = State s s
378evalState' :: State' s a -> s -> a
379evalState' = evalState
380{-# INLINE evalState' #-}
382execStateT' :: Monad m => StateT' s m a -> s -> m s
383execStateT' = execStateT
384{-# INLINE execStateT' #-}
386execState' :: State' s a -> s -> s
387execState' = execState
388{-# INLINE execState' #-}
390type LazyStateT' s = LazyStateT s s
392lazyStateT' :: (s -> m (a, s)) -> LazyStateT' s m a
393lazyStateT' = lazyStateT
394{-# INLINE lazyStateT' #-}
396runLazyStateT' :: LazyStateT' s m a -> s -> m (a, s)
397runLazyStateT' = runLazyStateT
398{-# INLINE runLazyStateT' #-}
400runLazyState' :: LazyState' s a -> s -> (a, s)
401runLazyState' = runLazyState
402{-# INLINE runLazyState' #-}
404evalLazyStateT' :: Monad m => LazyStateT' s m a -> s -> m a
405evalLazyStateT' = evalLazyStateT
406{-# INLINE evalLazyStateT' #-}
408type LazyState' s = LazyState s s
410evalLazyState' :: LazyState' s a -> s -> a
411evalLazyState' = evalLazyState
412{-# INLINE evalLazyState' #-}
414execLazyStateT' :: Monad m => LazyStateT' s m a -> s -> m s
415execLazyStateT' = execLazyStateT
416{-# INLINE execLazyStateT' #-}
418execLazyState' :: LazyState' s a -> s -> s
419execLazyState' = execLazyState
420{-# INLINE execLazyState' #-}
422type MonadState' s = MonadState s s
424get' :: forall s m . MonadState' s m => m s
425get' = get @s
426{-# INLINE get' #-}
428gets' :: forall s m a . MonadState' s m => (s -> a) -> m a
429gets' = gets @s
430{-# INLINE gets' #-}
432put' :: forall s m . MonadState' s m => s -> m ()
433put' = put @s
434{-# INLINE put' #-}
436state' :: forall s m a . MonadState' s m => (s -> (a, s)) -> m a
437state' = state @s
438{-# INLINE state' #-}
440modify' :: forall s m . MonadState' s m => (s -> s) -> m ()
441modify' = modify @s
442{-# INLINE modify' #-}
444-- | Encode type-level information for 'zoom'.
445data ZOOM t z
447type ZoomT t (z :: Type) = TaggedTrans (ZOOM t z) IdentityT
449-- | Zoom into a part of a state using a lens.
450zoom
451 :: forall tag sOuter sInner m a
452 . Lens' sOuter sInner
453 -> (forall z . Reifies z (ReifiedLens' sOuter sInner) => ZoomT tag z m a)
454 -> m a
455zoom l m = reify (Lens l) (\(_ :: Proxy z) -> coerce (m @z))
456{-# INLINE zoom #-}
458instance
459 ( MonadState tag sOuter m
460 , Reifies z (ReifiedLens' sOuter sInner)
461 , trans ~ IdentityT
462 ) => MonadState tag sInner (TaggedTrans (ZOOM tag z) trans m)
463 where
464 state =
465 (coerce :: forall eff r a .
466 (r -> m a) ->
467 (r -> TaggedTrans eff trans m a))
468 (state @tag . l)
469 where
470 Lens l = reflect (Proxy :: Proxy z)
471 {-# INLINE state #-}