blob: 8e24d0cf41e6aa96ce657ad74b91fc88042d597b (
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
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
|
(.module:
lux
(lux (control [monad #+ do]
["ex" exception #+ exception:]
pipe)
(data [text "text/" Eq<Text>]
text/format
["e" error]
(coll [list "list/" Fold<List> Functor<List>]))
[macro]
(macro [code]))
(luxc ["&" lang]
(lang ["&." scope])))
(do-template [<name>]
[(exception: #export (<name> {message Text})
message)]
[Unknown-Module]
[Cannot-Declare-Tag-Twice]
[Cannot-Declare-Tags-For-Unnamed-Type]
[Cannot-Declare-Tags-For-Foreign-Type]
[Cannot-Define-More-Than-Once]
[Cannot-Define-In-Unknown-Module]
[Can-Only-Change-State-Of-Active-Module]
[Cannot-Set-Module-Annotations-More-Than-Once]
)
(def: (new-module hash)
(-> Nat Module)
{#.module-hash hash
#.module-aliases (list)
#.definitions (list)
#.imports (list)
#.tags (list)
#.types (list)
#.module-annotations #.None
#.module-state #.Active})
(def: #export (set-annotations annotations)
(-> Code (Meta Top))
(do macro.Monad<Meta>
[self-name macro.current-module-name
self macro.current-module]
(case (get@ #.module-annotations self)
#.None
(function (_ compiler)
(#e.Success [(update@ #.modules
(&.pl-put self-name (set@ #.module-annotations (#.Some annotations) self))
compiler)
[]]))
(#.Some old)
(&.throw Cannot-Set-Module-Annotations-More-Than-Once
(format " Module: " self-name "\n"
"Old annotations: " (%code old) "\n"
"New annotations: " (%code annotations) "\n")))))
(def: #export (import module)
(-> Text (Meta Top))
(do macro.Monad<Meta>
[self macro.current-module-name]
(function (_ compiler)
(#e.Success [(update@ #.modules
(&.pl-update self (update@ #.imports (|>> (#.Cons module))))
compiler)
[]]))))
(def: #export (alias alias module)
(-> Text Text (Meta Top))
(do macro.Monad<Meta>
[self macro.current-module-name]
(function (_ compiler)
(#e.Success [(update@ #.modules
(&.pl-update self (update@ #.module-aliases (: (-> (List [Text Text]) (List [Text Text]))
(|>> (#.Cons [alias module])))))
compiler)
[]]))))
(def: #export (exists? module)
(-> Text (Meta Bool))
(function (_ compiler)
(|> (get@ #.modules compiler)
(&.pl-get module)
(case> (#.Some _) true #.None false)
[compiler] #e.Success)))
(def: #export (define (^@ full-name [module-name def-name])
definition)
(-> Ident Definition (Meta Top))
(function (_ compiler)
(case (&.pl-get module-name (get@ #.modules compiler))
(#.Some module)
(case (&.pl-get def-name (get@ #.definitions module))
#.None
(#e.Success [(update@ #.modules
(&.pl-put module-name
(update@ #.definitions
(: (-> (List [Text Definition]) (List [Text Definition]))
(|>> (#.Cons [def-name definition])))
module))
compiler)
[]])
(#.Some already-existing)
((&.throw Cannot-Define-More-Than-Once (%ident full-name)) compiler))
#.None
((&.throw Cannot-Define-In-Unknown-Module (%ident full-name)) compiler))))
(def: #export (create hash name)
(-> Nat Text (Meta Module))
(function (_ compiler)
(let [module (new-module hash)]
(#e.Success [(update@ #.modules
(&.pl-put name module)
compiler)
module]))))
(def: #export (with-module hash name action)
(All [a] (-> Nat Text (Meta a) (Meta [Module a])))
(do macro.Monad<Meta>
[_ (create hash name)
output (&.with-current-module name
action)
module (macro.find-module name)]
(wrap [module output])))
(do-template [<flagger> <asker> <tag> <description>]
[(def: #export (<flagger> module-name)
(-> Text (Meta Top))
(function (_ compiler)
(case (|> compiler (get@ #.modules) (&.pl-get module-name))
(#.Some module)
(let [active? (case (get@ #.module-state module)
#.Active true
_ false)]
(if active?
(#e.Success [(update@ #.modules
(&.pl-put module-name (set@ #.module-state <tag> module))
compiler)
[]])
((&.throw Can-Only-Change-State-Of-Active-Module
(format " Module: " module-name "\n"
"Desired state: " <description>))
compiler)))
#.None
((&.throw Unknown-Module module-name) compiler))))
(def: #export (<asker> module-name)
(-> Text (Meta Bool))
(function (_ compiler)
(case (|> compiler (get@ #.modules) (&.pl-get module-name))
(#.Some module)
(#e.Success [compiler
(case (get@ #.module-state module)
<tag> true
_ false)])
#.None
((&.throw Unknown-Module module-name) compiler))
))]
[flag-active! active? #.Active "Active"]
[flag-compiled! compiled? #.Compiled "Compiled"]
[flag-cached! cached? #.Cached "Cached"]
)
(do-template [<name> <tag> <type>]
[(def: (<name> module-name)
(-> Text (Meta <type>))
(function (_ compiler)
(case (|> compiler (get@ #.modules) (&.pl-get module-name))
(#.Some module)
(#e.Success [compiler (get@ <tag> module)])
#.None
((&.throw Unknown-Module module-name) compiler))
))]
[tags-by-module #.tags (List [Text [Nat (List Ident) Bool Type]])]
[types-by-module #.types (List [Text [(List Ident) Bool Type]])]
[module-hash #.module-hash Nat]
)
(def: (ensure-undeclared-tags module-name tags)
(-> Text (List Text) (Meta Top))
(do macro.Monad<Meta>
[bindings (tags-by-module module-name)
_ (monad.map @
(function (_ tag)
(case (&.pl-get tag bindings)
#.None
(wrap [])
(#.Some _)
(&.throw Cannot-Declare-Tag-Twice (format "Module: " module-name "\n"
" Tag: " tag))))
tags)]
(wrap [])))
(def: #export (declare-tags tags exported? type)
(-> (List Text) Bool Type (Meta Top))
(do macro.Monad<Meta>
[current-module macro.current-module-name
[type-module type-name] (case type
(#.Named type-ident _)
(wrap type-ident)
_
(&.throw Cannot-Declare-Tags-For-Unnamed-Type
(format "Tags: " (|> tags (list/map code.text) code.tuple %code) "\n"
"Type: " (%type type))))
_ (ensure-undeclared-tags current-module tags)
_ (&.assert Cannot-Declare-Tags-For-Foreign-Type
(format "Tags: " (|> tags (list/map code.text) code.tuple %code) "\n"
"Type: " (%type type))
(text/= current-module type-module))]
(function (_ compiler)
(case (|> compiler (get@ #.modules) (&.pl-get current-module))
(#.Some module)
(let [namespaced-tags (list/map (|>> [current-module]) tags)]
(#e.Success [(update@ #.modules
(&.pl-update current-module
(|>> (update@ #.tags (function (_ tag-bindings)
(list/fold (function (_ [idx tag] table)
(&.pl-put tag [idx namespaced-tags exported? type] table))
tag-bindings
(list.enumerate tags))))
(update@ #.types (&.pl-put type-name [namespaced-tags exported? type]))))
compiler)
[]]))
#.None
((&.throw Unknown-Module current-module) compiler)))))
|
