blob: 5d0a04ea9405c7e83ab97bf5923a73b7031ef9a9 (
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
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
|
(.module: {#.doc "Exception-handling functionality."}
[lux #*
[abstract
[monad (#+ do)]]
[control
["p" parser
["s" code (#+ Parser)]]]
[data
["." maybe]
["." product]
["." text ("#@." monoid)]
[number
["n" nat ("#@." decimal)]]
[collection
["." list ("#@." functor fold)]]]
["." meta]
[macro
["." code]
[syntax (#+ syntax:)
["sc" common
["scr" reader]
["scw" writer]]]]]
[//
["//" try (#+ Try)]])
(type: #export (Exception a)
{#.doc "An exception provides a way to decorate error messages."}
{#label Text
#constructor (-> a Text)})
(def: #export (match? exception error)
(All [e] (-> (Exception e) Text Bit))
(text.starts-with? (get@ #label exception) error))
(def: #export (catch exception then try)
{#.doc (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) (Try a)
(Try a)))
(case try
(#//.Success output)
(#//.Success output)
(#//.Failure 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))
(#//.Failure 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) (Try a) a))
(case try
(#//.Success output)
output
(#//.Failure error)
(to-do error)))
(def: #export (return value)
{#.doc "A way to lift normal values into the error-handling context."}
(All [a] (-> a (Try 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 a] (-> (Exception e) e (Try a)))
(#//.Failure (construct exception message)))
(def: #export (assert exception message test)
(All [e] (-> (Exception e) e Bit (Try Any)))
(if test
(#//.Success [])
(..throw exception message)))
(syntax: #export (exception: {export scr.export}
{t-vars (p.default (list) (s.tuple scr.type-variables))}
{[name inputs] (p.either (p.and s.local-identifier (wrap (list)))
(s.form (p.and s.local-identifier (p.some scr.typed-input))))}
{body (p.maybe s.any)})
{#.doc (doc "Define a new exception type."
"It mostly just serves as a way to tag error messages for later catching."
""
"Simple case:"
(exception: #export some-exception)
""
"Complex case:"
(exception: #export [optional type variables] (some-exception {optional Text} {arguments Int})
optional-body))}
(meta.with-gensyms [g!descriptor]
(do meta.monad
[current-module meta.current-module-name
#let [descriptor ($_ text@compose "{" current-module "." name "}" text.new-line)
g!self (code.local-identifier name)]]
(wrap (list (` (def: (~+ (scw.export export))
(~ g!self)
(All [(~+ (scw.type-variables t-vars))]
(..Exception [(~+ (list@map (get@ #sc.input-type) inputs))]))
(let [(~ g!descriptor) (~ (code.text descriptor))]
{#..label (~ g!descriptor)
#..constructor (function ((~ g!self) [(~+ (list@map (get@ #sc.input-binding) inputs))])
((~! text@compose) (~ g!descriptor)
(~ (maybe.default (' "") body))))})))))
)))
(def: (report' entries)
(-> (List [Text Text]) Text)
(let [header-separator ": "
largest-header-size (list@fold (function (_ [header _] max)
(n.max (text.size header) max))
0
entries)
on-new-line (|> " "
(list.repeat (n.+ (text.size header-separator)
largest-header-size))
(text.join-with "")
(text@compose text.new-line))]
(|> entries
(list@map (function (_ [header message])
(let [padding (|> " "
(list.repeat (n.- (text.size header)
largest-header-size))
(text.join-with ""))]
(|> message
(text.replace-all text.new-line on-new-line)
($_ text@compose padding header header-separator)))))
(text.join-with text.new-line))))
(syntax: #export (report {entries (p.many (s.tuple (p.and s.any s.any)))})
(wrap (list (` ((~! report') (list (~+ (|> entries
(list@map (function (_ [header message])
(` [(~ header) (~ message)])))))))))))
(def: #export (enumerate format entries)
(All [a]
(-> (-> a Text) (List a) Text))
(|> entries
list.enumerate
(list@map (function (_ [index entry])
[(n@encode index) (format entry)]))
report'))
(def: separator
(let [gap ($_ "lux text concat" text.new-line text.new-line)
horizontal-line (|> "-" (list.repeat 64) (text.join-with ""))]
($_ "lux text concat"
gap
horizontal-line
gap)))
(def: (decorate prelude error)
(-> Text Text Text)
($_ "lux text concat"
prelude
..separator
error))
(def: #export (with exception message computation)
(All [e a] (-> (Exception e) e (Try a) (Try a)))
(case computation
(#//.Failure error)
(#//.Failure (case error
""
(..construct exception message)
_
(..decorate (..construct exception message) error)))
success
success))
|
