blob: edca1d81bca921087782520d7be97b61c58ed2ca (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
|
(;module:
lux
(lux (control functor
["A" applicative #*]
["M" monad #*])))
## [Types]
(type: #export (State s a)
{#;doc "Stateful computations."}
(-> s [s a]))
## [Structures]
(struct: #export Functor<State> (All [s] (Functor (State s)))
(def: (map f ma)
(lambda [state]
(let [[state' a] (ma state)]
[state' (f a)]))))
(struct: #export Applicative<State> (All [s] (Applicative (State s)))
(def: functor Functor<State>)
(def: (wrap a)
(lambda [state]
[state a]))
(def: (apply ff fa)
(lambda [state]
(let [[state' f] (ff state)
[state'' a] (fa state')]
[state'' (f a)]))))
(struct: #export Monad<State> (All [s] (Monad (State s)))
(def: applicative Applicative<State>)
(def: (join mma)
(lambda [state]
(let [[state' ma] (mma state)]
(ma state')))))
## [Values]
(def: #export get
{#;doc "Read the current state."}
(All [s] (State s s))
(lambda [state]
[state state]))
(def: #export (put new-state)
{#;doc "Set the new state."}
(All [s] (-> s (State s Unit)))
(lambda [state]
[new-state []]))
(def: #export (update change)
{#;doc "Compute the new state."}
(All [s] (-> (-> s s) (State s Unit)))
(lambda [state]
[(change state) []]))
(def: #export (use user)
{#;doc "Run function on current state."}
(All [s a] (-> (-> s a) (State s a)))
(lambda [state]
[state (user state)]))
(def: #export (local change action)
{#;doc "Run computation with a locally-modified state."}
(All [s a] (-> (-> s s) (State s a) (State s a)))
(lambda [state]
(let [[state' output] (action (change state))]
[state output])))
(def: #export (run state action)
{#;doc "Run a stateful computation."}
(All [s a] (-> s (State s a) [s a]))
(action state))
(struct: (Functor<StateT> Functor<M>)
(All [M s] (-> (Functor M) (Functor (All [a] (-> s (M [s a]))))))
(def: (map f sfa)
(lambda [state]
(:: Functor<M> map (lambda [[s a]] [s (f a)])
(sfa state)))))
(struct: (Applicative<StateT> Monad<M>)
(All [M s] (-> (Monad M) (Applicative (All [a] (-> s (M [s a]))))))
(def: functor (Functor<StateT> (:: Monad<M> functor)))
(def: (wrap a)
(lambda [state]
(:: Monad<M> wrap [state a])))
(def: (apply sFf sFa)
(lambda [state]
(do Monad<M>
[[state f] (sFf state)
[state a] (sFa state)]
(wrap [state (f a)])))))
(type: #export (State' M s a)
{#;doc "Stateful computations decorated by a monad."}
(-> s (M [s a])))
(def: #export (run' state action)
{#;doc "Run a stateful computation decorated by a monad."}
(All [M s a] (-> s (State' M s a) (M [s a])))
(action state))
(struct: #export (StateT Monad<M>)
{#;doc "A monad transformer to create composite stateful computations."}
(All [M s] (-> (Monad M) (Monad (State' M s))))
(def: applicative (Applicative<StateT> Monad<M>))
(def: (join sMsMa)
(lambda [state]
(do Monad<M>
[[state' sMa] (sMsMa state)]
(sMa state')))))
(def: #export (lift-state Monad<M> ma)
{#;doc "Lift monadic values to the State' wrapper."}
(All [M s a] (-> (Monad M) (M a) (State' M s a)))
(lambda [state]
(do Monad<M>
[a ma]
(wrap [state a]))))
|
