blob: f0712794d4fbfb3e0b87e6f95ea140534ef0d695 (
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
181
182
183
184
|
(;module:
lux
(lux (control [monad #+ do]
["ex" exception #+ exception:])
(data ["e" error]
[product]
text/format)
[meta]
(meta [type]
(type ["tc" check]))
[host #+ do-to])
(luxc ["&" base]
[";L" host]
(lang ["la" analysis])
["&;" module]
(generator [";G" common]))
(. ["&&;" common]
["&&;" function]
["&&;" primitive]
["&&;" reference]
["&&;" type]
["&&;" structure]
["&&;" case]
["&&;" procedure]))
(for {"JVM" (as-is (host;import java.lang.reflect.Method
(invoke [Object (Array Object)] #try Object))
(host;import (java.lang.Class c)
(getMethod [String (Array (Class Object))] #try Method))
(host;import java.lang.Object
(getClass [] (Class Object))
(toString [] String))
(def: _object-class (Class Object) (host;class-for Object))
(def: _apply-args
(Array (Class Object))
(|> (host;array (Class Object) +2)
(host;array-write +0 _object-class)
(host;array-write +1 _object-class)))
(def: (call-macro macro inputs)
(-> Macro (List Code) (Meta (List Code)))
(do meta;Monad<Meta>
[class (commonG;load-class hostL;function-class)]
(function [compiler]
(do e;Monad<Error>
[apply-method (Class.getMethod ["apply" _apply-args] class)
output (Method.invoke [(:! Object macro)
(|> (host;array Object +2)
(host;array-write +0 (:! Object inputs))
(host;array-write +1 (:! Object compiler)))]
apply-method)]
(:! (e;Error [Compiler (List Code)])
output))))))
})
(exception: #export Macro-Expression-Must-Have-Single-Expansion)
(def: (to-branches raw)
(-> (List Code) (Meta (List [Code Code])))
(case raw
(^ (list))
(:: meta;Monad<Meta> wrap (list))
(^ (list& patternH bodyH inputT))
(do meta;Monad<Meta>
[outputT (to-branches inputT)]
(wrap (list& [patternH bodyH] outputT)))
_
(&;fail "Uneven expressions for pattern-matching.")))
(def: #export (analyser eval)
(-> &;Eval &;Analyser)
(: (-> Code (Meta la;Analysis))
(function analyse [ast]
(do meta;Monad<Meta>
[expectedT meta;expected-type]
(let [[cursor ast'] ast]
## The cursor must be set in the compiler for the sake
## of having useful error messages.
(&;with-cursor cursor
(case ast'
(^template [<tag> <analyser>]
(<tag> value)
(<analyser> value))
([#;Bool &&primitive;analyse-bool]
[#;Nat &&primitive;analyse-nat]
[#;Int &&primitive;analyse-int]
[#;Deg &&primitive;analyse-deg]
[#;Frac &&primitive;analyse-frac]
[#;Text &&primitive;analyse-text])
(^ (#;Tuple (list)))
&&primitive;analyse-unit
## Singleton tuples are equivalent to the element they contain.
(^ (#;Tuple (list singleton)))
(analyse singleton)
(^ (#;Tuple elems))
(&&structure;analyse-product analyse elems)
(^ (#;Record pairs))
(&&structure;analyse-record analyse pairs)
(#;Symbol reference)
(&&reference;analyse-reference reference)
(^ (#;Form (list [_ (#;Text "lux function")]
[_ (#;Symbol ["" func-name])]
[_ (#;Symbol ["" arg-name])]
body)))
(&&function;analyse-function analyse func-name arg-name body)
(^template [<special> <analyser>]
(^ (#;Form (list [_ (#;Text <special>)] type value)))
(<analyser> analyse eval type value))
(["lux check" &&type;analyse-check]
["lux coerce" &&type;analyse-coerce])
(^ (#;Form (list [_ (#;Text "lux check type")] valueC)))
(do meta;Monad<Meta>
[valueA (&;with-expected-type Type
(analyse valueC))
expected meta;expected-type
_ (&;with-type-env
(tc;check expected Type))]
(wrap valueA))
(^ (#;Form (list& [_ (#;Text "lux case")]
input
branches)))
(do meta;Monad<Meta>
[paired (to-branches branches)]
(&&case;analyse-case analyse input paired))
(^ (#;Form (list& [_ (#;Text proc-name)] proc-args)))
(&&procedure;analyse-procedure analyse proc-name proc-args)
(^template [<tag> <analyser>]
(^ (#;Form (list& [_ (<tag> tag)]
values)))
(case values
(#;Cons value #;Nil)
(<analyser> analyse tag value)
_
(<analyser> analyse tag (` [(~@ values)]))))
([#;Nat &&structure;analyse-sum]
[#;Tag &&structure;analyse-tagged-sum])
(#;Tag tag)
(&&structure;analyse-tagged-sum analyse tag (' []))
(^ (#;Form (list& func args)))
(do meta;Monad<Meta>
[[funcT =func] (&&common;with-unknown-type
(analyse func))]
(case =func
(#la;Definition def-name)
(do @
[[def-type def-anns def-value] (meta;find-def def-name)]
(if (meta;macro? def-anns)
(do @
[expansion (function [compiler]
(case (call-macro (:! Macro def-value) args compiler)
(#e;Success [compiler' output])
(#e;Success [compiler' output])
(#e;Error error)
((&;fail error) compiler)))]
(case expansion
(^ (list single))
(analyse single)
_
(&;throw Macro-Expression-Must-Have-Single-Expansion (%code ast))))
(&&function;analyse-apply analyse funcT =func args)))
_
(&&function;analyse-apply analyse funcT =func args)))
_
(&;fail (format "Unrecognized syntax: " (%code ast)))
)))))))
|
