blob: d866c153e0f8ad79e9ad5aca5761e49cad33425e (
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
|
(.module: {#.doc "Exception-handling functionality built on top of the Error type."}
lux
(lux (control [monad #+ do]
["p" parser])
(data ["e" 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) (e.Error a)
(e.Error a)))
(case try
(#e.Success output)
(#e.Success output)
(#e.Error error)
(let [reference (get@ #label exception)]
(if (text.starts-with? reference error)
(#e.Success (|> error
(text.clip (text.size reference) (text.size error))
maybe.assume
then))
(#e.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) (e.Error a) a))
(case try
(#e.Success output)
output
(#e.Error error)
(to-do error)))
(def: #export (return value)
{#.doc "A way to lift normal values into the error-handling context."}
(All [a] (-> a (e.Error a)))
(#e.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 e.Error))
(#e.Error (construct 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))))
(text.join-with "\n"))))
(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)])))))))))))
|
