blob: 2b855d9271b3fc7046ef57a6a08b889a8f07d323 (
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
|
(;module:
lux
(lux (control [monad #+ do]
["ex" exception #+ exception:])
(data [text "text/" Eq<Text>]
text/format
["e" error]
(coll [list "list/" Fold<List> Functor<List>]))
[macro]
(macro [code]))
(luxc ["&" lang]
(lang ["&;" scope])))
(exception: #export Unknown-Module)
(exception: #export Cannot-Declare-Tag-Twice)
(exception: #export Cannot-Declare-Tags-For-Unnamed-Type)
(exception: #export Cannot-Declare-Tags-For-Foreign-Type)
(def: (new-module hash)
(-> Nat Module)
{#;module-hash hash
#;module-aliases (list)
#;defs (list)
#;imports (list)
#;tags (list)
#;types (list)
#;module-annotations (' {})
#;module-state #;Active})
(def: #export (define (^@ full-name [module-name def-name])
definition)
(-> Ident Def (Meta Unit))
(function [compiler]
(case (&;pl-get module-name (get@ #;modules compiler))
(#;Some module)
(case (&;pl-get def-name (get@ #;defs module))
#;None
(#e;Success [(update@ #;modules
(&;pl-put module-name
(update@ #;defs
(: (-> (List [Text Def]) (List [Text Def]))
(|>. (#;Cons [def-name definition])))
module))
compiler)
[]])
(#;Some already-existing)
(#e;Error (format "Cannot re-define definiton: " (%ident full-name))))
#;None
(#e;Error (format "Cannot define in unknown module: " module-name)))))
(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
(&scope;with-scope name action))
module (macro;find-module name)]
(wrap [module output])))
(do-template [<flagger> <asker> <tag>]
[(def: #export (<flagger> module-name)
(-> Text (Meta Unit))
(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)
[]])
(#e;Error "Can only change the state of a currently-active module.")))
#;None
(#e;Error (format "Module does not exist: " module-name)))))
(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
(#e;Error (format "Module does not exist: " module-name)))
))]
[flag-active! active? #;Active]
[flag-compiled! compiled? #;Compiled]
[flag-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
(macro;run compiler (&;throw Unknown-Module module-name)))
))]
[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 Unit))
(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 Unit))
(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
(macro;run compiler (&;throw Unknown-Module current-module))))))
|
