blob: b53ceefede9cdd9e414c2481463c99005f99f187 (
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
|
(;module:
lux
(lux (control monad)
(data [text "T/" Eq<Text>]
text/format
["R" result]
(coll [list "L/" Fold<List> Functor<List>]))
[macro #+ Monad<Lux>])
(luxc ["&" base]
["&;" env]))
(def: (new-module hash)
(-> Nat Module)
{#;module-hash hash
#;module-aliases (list)
#;defs (list)
#;imports (list)
#;tags (list)
#;types (list)
#;module-anns (list)
#;module-state #;Active})
(def: #export (define (^@ full-name [module-name def-name])
definition)
(-> Ident Def (Lux Unit))
(function [compiler]
(case (&;pl-get module-name (get@ #;modules compiler))
(#;Some module)
(case (&;pl-get def-name (get@ #;defs module))
#;None
(#R;Success [(update@ #;modules
(&;pl-put module-name
(update@ #;defs
(: (-> (List [Text Def]) (List [Text Def]))
(|>. (#;Cons [def-name definition])))
module))
compiler)
[]])
(#;Some already-existing)
(#R;Error (format "Cannot re-define definiton: " (%ident full-name))))
#;None
(#R;Error (format "Cannot define in unknown module: " module-name)))))
(def: #export (create hash name)
(-> Nat Text (Lux Module))
(function [compiler]
(let [module (new-module hash)]
(#R;Success [(update@ #;modules
(&;pl-put name module)
compiler)
module]))))
(def: #export (with-module hash name action)
(All [a] (-> Nat Text (Lux a) (Lux [Module a])))
(do Monad<Lux>
[_ (create hash name)
output (&env;with-scope name action)
module (macro;find-module name)]
(wrap [module output])))
(do-template [<flagger> <asker> <tag>]
[(def: #export (<flagger> module-name)
(-> Text (Lux 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?
(#R;Success [(update@ #;modules
(&;pl-put module-name (set@ #;module-state <tag> module))
compiler)
[]])
(#R;Error "Can only change the state of a currently-active module.")))
#;None
(#R;Error (format "Module does not exist: " module-name)))))
(def: #export (<asker> module-name)
(-> Text (Lux Bool))
(function [compiler]
(case (|> compiler (get@ #;modules) (&;pl-get module-name))
(#;Some module)
(#R;Success [compiler
(case (get@ #;module-state module)
<tag> true
_ false)])
#;None
(#R;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 (Lux <type>))
(function [compiler]
(case (|> compiler (get@ #;modules) (&;pl-get module-name))
(#;Some module)
(#R;Success [compiler (get@ <tag> module)])
#;None
(macro;run compiler (&;fail (format "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) (Lux Unit))
(do Monad<Lux>
[bindings (tags-by-module module-name)
_ (mapM @
(function [tag]
(case (&;pl-get tag bindings)
#;None
(wrap [])
(#;Some _)
(&;fail (format "Cannot re-declare tag: " tag))))
tags)]
(wrap [])))
(def: #export (declare-tags tags exported? type)
(-> (List Text) Bool Type (Lux Unit))
(do Monad<Lux>
[current-module macro;current-module-name
[type-module type-name] (case type
(#;Named type-ident _)
(wrap type-ident)
_
(&;fail (format "Cannot define tags for an unnamed type: " (%type type))))
_ (ensure-undeclared-tags current-module tags)
_ (macro;assert (format "Cannot define tags for a type belonging to a foreign module: " (%type type))
(T/= current-module type-module))]
(function [compiler]
(case (|> compiler (get@ #;modules) (&;pl-get current-module))
(#;Some module)
(let [namespaced-tags (L/map (|>. [current-module]) tags)]
(#R;Success [(update@ #;modules
(&;pl-update current-module
(|>. (update@ #;tags (function [tag-bindings]
(L/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 (&;fail (format "Unknown module: " current-module)))))))
|
