blob: a81d5dfa77f19472923783f8a7b72e07cc53a810 (
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
|
(.module:
[lux #*
[control
["." state]
["ex" exception (#+ Exception exception:)]
[monad (#+ do)]]
[data
["." product]
["." error (#+ Error) ("error/." Functor<Error>)]
["." text
format]]
[time
["." instant]
["." duration]]
["." io]
[macro
["s" syntax (#+ syntax:)]]])
(type: #export (Operation s o)
(state.State' Error s o))
(def: #export Monad<Operation>
(state.Monad<State'> error.Monad<Error>))
(type: #export (Phase s i o)
(-> i (Operation s o)))
(def: #export (run' state operation)
(All [s o]
(-> s (Operation s o) (Error [s o])))
(operation state))
(def: #export (run state operation)
(All [s o]
(-> s (Operation s o) (Error o)))
(|> state
operation
(:: error.Monad<Error> map product.right)))
(def: #export get-state
(All [s o]
(Operation s s))
(function (_ state)
(#error.Success [state state])))
(def: #export (set-state state)
(All [s o]
(-> s (Operation s Any)))
(function (_ _)
(#error.Success [state []])))
(def: #export (sub [get set] operation)
(All [s s' o]
(-> [(-> s s') (-> s' s s)]
(Operation s' o)
(Operation s o)))
(function (_ state)
(do error.Monad<Error>
[[state' output] (operation (get state))]
(wrap [(set state' state) output]))))
(def: #export fail
(-> Text Operation)
(|>> error.fail (state.lift error.Monad<Error>)))
(def: #export (throw exception parameters)
(All [e] (-> (Exception e) e Operation))
(state.lift error.Monad<Error>
(ex.throw exception parameters)))
(def: #export (lift error)
(All [s a] (-> (Error a) (Operation s a)))
(function (_ state)
(error/map (|>> [state]) error)))
(syntax: #export (assert exception message test)
(wrap (list (` (if (~ test)
(:: ..Monad<Operation> (~' wrap) [])
(..throw (~ exception) (~ message)))))))
(def: #export (with-stack exception message action)
(All [e s o] (-> (Exception e) e (Operation s o) (Operation s o)))
(<<| (ex.with-stack exception message)
action))
(def: #export identity
(All [s a] (Phase s a a))
(function (_ input state)
(#error.Success [state input])))
(def: #export (compose pre post)
(All [s0 s1 i t o]
(-> (Phase s0 i t)
(Phase s1 t o)
(Phase [s0 s1] i o)))
(function (_ input [pre/state post/state])
(do error.Monad<Error>
[[pre/state' temp] (pre input pre/state)
[post/state' output] (post temp post/state)]
(wrap [[pre/state' post/state'] output]))))
(def: #export (timed definition description operation)
(All [s a]
(-> Name Text (Operation s a) (Operation s a)))
(do Monad<Operation>
[_ (wrap [])
#let [pre (io.run instant.now)]
output operation
#let [_ (log! (|> instant.now
io.run
instant.relative
(duration.difference (instant.relative pre))
%duration
(format (%name definition) " [" description "]: ")))]]
(wrap output)))
|
