blob: 80ddeed3525d43ca1f906123dc1753622112c5aa (
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
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
|
(.module: {#.doc "Exception-handling functionality built on top of the Error type."}
lux
(lux (control [monad #+ do]
["p" parser])
(data ["/" error #+ Error]
[maybe]
[product]
[text "text/" Monoid<Text>]
(coll [list "list/" Functor<List> Fold<List>]))
[macro]
(macro [code]
["s" syntax #+ syntax: Syntax]
(syntax ["cs" common]
(common ["csr" reader]
["csw" writer])))))
## [Types]
(type: #export (Exception a)
{#.doc "An exception provides a way to decorate error messages."}
{#label Text
#constructor (-> a Text)})
## [Values]
(def: #export (match? exception error)
(All [e] (-> (Exception e) Text Bool))
(text.starts-with? (get@ #label exception) error))
(def: #export (catch exception then try)
{#.doc "If a particular exception is detected on a possibly-erroneous value, handle it.
If no exception was detected, or a different one from the one being checked, then pass along the original value."}
(All [e a]
(-> (Exception e) (-> Text a) (Error a)
(Error a)))
(case try
(#/.Success output)
(#/.Success output)
(#/.Error error)
(let [reference (get@ #label exception)]
(if (text.starts-with? reference error)
(#/.Success (|> error
(text.clip (text.size reference) (text.size error))
maybe.assume
then))
(#/.Error error)))))
(def: #export (otherwise to-do try)
{#.doc "If no handler could be found to catch the exception, then run a function as a last-resort measure."}
(All [a]
(-> (-> Text a) (Error a) a))
(case try
(#/.Success output)
output
(#/.Error error)
(to-do error)))
(def: #export (return value)
{#.doc "A way to lift normal values into the error-handling context."}
(All [a] (-> a (Error a)))
(#/.Success value))
(def: #export (construct exception message)
{#.doc "Constructs an exception."}
(All [e] (-> (Exception e) e Text))
((get@ #constructor exception) message))
(def: #export (throw exception message)
{#.doc "Decorate an error message with an Exception and lift it into the error-handling context."}
(All [e] (-> (Exception e) e Error))
(#/.Error (construct exception message)))
(def: #export (assert exception message test)
(All [e] (-> (Exception e) e Bool (Error Any)))
(if test
(#/.Success [])
(..throw exception message)))
(syntax: #export (exception: {export csr.export}
{t-vars (p.default (list) csr.type-variables)}
{[name inputs] (p.either (p.seq s.local-symbol (wrap (list)))
(s.form (p.seq s.local-symbol (p.some csr.typed-input))))}
{body (p.maybe s.any)})
{#.doc (doc "Define a new exception type."
"It moslty just serves as a way to tag error messages for later catching."
""
"Simple case:"
(exception: #export some-exception)
""
"Complex case:"
(exception: #export [optional type-vars] (some-exception [optional Text] {arguments Int})
optional-body))}
(macro.with-gensyms [g!descriptor]
(do @
[current-module macro.current-module-name
#let [descriptor ($_ text/compose "{" current-module "." name "}" "\n")
g!self (code.local-symbol name)]]
(wrap (list (` (def: (~+ (csw.export export))
(~ g!self)
(All [(~+ (csw.type-variables t-vars))]
(..Exception [(~+ (list/map (get@ #cs.input-type) inputs))]))
(let [(~ g!descriptor) (~ (code.text descriptor))]
{#..label (~ g!descriptor)
#..constructor (function ((~ g!self) [(~+ (list/map (get@ #cs.input-binding) inputs))])
((~! text/compose) (~ g!descriptor)
(~ (maybe.default (' "") body))))})))))
)))
(def: #export (report' entries)
(-> (List [Text Text]) Text)
(let [largest-header-size (|> entries
(list/map (|>> product.left text.size))
(list/fold n/max +0))]
(|> entries
(list/map (function (_ [header message])
(let [padding (|> " "
(list.repeat (n/- (text.size header)
largest-header-size))
(text.join-with ""))]
($_ text/compose padding header ": " message "\n"))))
(text.join-with ""))))
(syntax: #export (report {entries (p.many (s.tuple (p.seq s.any s.any)))})
(wrap (list (` (report' (list (~+ (|> entries
(list/map (function (_ [header message])
(` [(~ header) (~ message)])))))))))))
(def: separator
($_ "lux text concat"
"\n\n"
"-----------------------------------------"
"\n\n"))
(def: #export (with-stack exception message computation)
(All [e a] (-> (Exception e) e (Error a) (Error a)))
(case computation
(#/.Error error)
(#/.Error (case error
""
(..construct exception message)
_
($_ "lux text concat"
(..construct exception message)
..separator
error)))
success
success))
|
