Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 2012,2017 Matthew Fluet. |
2 | * Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh | |
3 | * Jagannathan, and Stephen Weeks. | |
4 | * Copyright (C) 1997-2000 NEC Research Institute. | |
5 | * | |
6 | * MLton is released under a BSD-style license. | |
7 | * See the file MLton-LICENSE for details. | |
8 | *) | |
9 | ||
10 | functor ElaborateModules (S: ELABORATE_MODULES_STRUCTS): ELABORATE_MODULES = | |
11 | struct | |
12 | ||
13 | open S | |
14 | ||
15 | local | |
16 | open Control.Elaborate | |
17 | in | |
18 | val resolveScope = fn () => current resolveScope | |
19 | end | |
20 | ||
21 | local | |
22 | open Ast | |
23 | in | |
24 | structure FctArg = FctArg | |
25 | structure Fctid = Fctid | |
26 | structure Longstrid = Longstrid | |
27 | structure SigConst = SigConst | |
28 | structure Sigid = Sigid | |
29 | structure Sigexp = Sigexp | |
30 | structure Strdec = Strdec | |
31 | structure Strexp = Strexp | |
32 | structure Strid = Strid | |
33 | structure Topdec = Topdec | |
34 | end | |
35 | ||
36 | local | |
37 | open Env | |
38 | in | |
39 | structure Decs = Decs | |
40 | structure FunctorClosure = FunctorClosure | |
41 | structure Structure = Structure | |
42 | end | |
43 | ||
44 | structure ElaborateSigexp = ElaborateSigexp (structure Ast = Ast | |
45 | structure Env = Env) | |
46 | ||
47 | structure ElaborateCore = ElaborateCore (structure Ast = Ast | |
48 | structure CoreML = CoreML | |
49 | structure Decs = Decs | |
50 | structure Env = Env) | |
51 | ||
52 | val elabStrdecInfo = Trace.info "ElaborateModules.elabStrdec" | |
53 | val elabStrexpInfo = Trace.info "ElaborateModules.elabStrexp" | |
54 | val elabTopdecInfo = Trace.info "ElaborateModules.elabTopdec" | |
55 | ||
56 | fun elaborateTopdec (topdec, {env = E: Env.t}) = | |
57 | let | |
58 | fun elabSigexp (s, no) = | |
59 | ElaborateSigexp.elaborateSigexp | |
60 | (s, {env = E, nest = case no of NONE => [] | SOME n => [n]}) | |
61 | fun elabSigexpConstraint (cons: SigConst.t, | |
62 | S: Structure.t option, | |
63 | nest: string list) | |
64 | : Decs.t * Structure.t option = | |
65 | let | |
66 | fun s (sigexp, opaque) = | |
67 | let | |
68 | val prefix = | |
69 | case nest of | |
70 | [] => "" | |
71 | | _ => concat (List.fold (nest, [], fn (s, ac) => | |
72 | s :: "." :: ac)) | |
73 | in | |
74 | case S of | |
75 | NONE => (Decs.empty, NONE) | |
76 | | SOME S => | |
77 | let | |
78 | val (S, decs) = | |
79 | case elabSigexp (sigexp, SOME (Strid.toString Strid.uSig)) of | |
80 | NONE => (S, Decs.empty) | |
81 | | SOME I => | |
82 | Env.cut (E, S, I, | |
83 | {isFunctor = false, | |
84 | opaque = opaque, | |
85 | prefix = prefix}, | |
86 | Sigexp.region sigexp) | |
87 | in | |
88 | (decs, SOME S) | |
89 | end | |
90 | end | |
91 | in | |
92 | case cons of | |
93 | SigConst.None => (Decs.empty, S) | |
94 | | SigConst.Opaque sigexp => s (sigexp, true) | |
95 | | SigConst.Transparent sigexp => s (sigexp, false) | |
96 | end | |
97 | fun elabStrdec (arg: Strdec.t * string list): Decs.t = | |
98 | Trace.traceInfo' (elabStrdecInfo, | |
99 | Layout.tuple2 (Strdec.layout, | |
100 | List.layout String.layout), | |
101 | Decs.layout) | |
102 | (fn (d: Strdec.t, nest: string list) => | |
103 | let | |
104 | val d = Strdec.coalesce d | |
105 | val elabStrdec = fn d => elabStrdec (d, nest) | |
106 | val decs = | |
107 | case Strdec.node d of | |
108 | Strdec.Core d => (* rule 56 *) | |
109 | ElaborateCore.elaborateDec | |
110 | (d, {env = E, nest = nest}) | |
111 | | Strdec.Local (d, d') => (* rule 58 *) | |
112 | Env.localModule (E, | |
113 | fn () => elabStrdec d, | |
114 | fn d => Decs.append (d, elabStrdec d')) | |
115 | | Strdec.Seq ds => (* rule 60 *) | |
116 | List.fold | |
117 | (ds, Decs.empty, fn (d, decs) => | |
118 | Decs.append (decs, elabStrdec d)) | |
119 | | Strdec.ShowBasis file => | |
120 | let | |
121 | open Layout | |
122 | val () = | |
123 | File.withOut | |
124 | (file, fn out => | |
125 | Env.output | |
126 | (E, out, | |
127 | {compact = !Control.showBasisCompact, | |
128 | def = !Control.showBasisDef, | |
129 | flat = !Control.showBasisFlat, | |
130 | onlyCurrent = false, | |
131 | prefixUnset = true})) | |
132 | handle exn => | |
133 | Control.warning | |
134 | (Strdec.region d, | |
135 | str "Exception raised processing #showBasis", | |
136 | align [seq [str "file: ", File.layout file], | |
137 | seq [str "exn: ", Exn.layout exn]]) | |
138 | in | |
139 | Decs.empty | |
140 | end | |
141 | | Strdec.Structure strbinds => (* rules 57, 61 *) | |
142 | let | |
143 | val strbinds = | |
144 | Vector.map | |
145 | (strbinds, fn {name, def, constraint} => | |
146 | let | |
147 | val nest = Strid.toString name :: nest | |
148 | val (decs', S) = elabStrexp (def, nest) | |
149 | val (decs'', S) = | |
150 | elabSigexpConstraint (constraint, S, nest) | |
151 | in | |
152 | {decs = Decs.append (decs', decs''), | |
153 | name = name, | |
154 | S = S} | |
155 | end) | |
156 | val () = | |
157 | Vector.foreach | |
158 | (strbinds, fn {name, S, ...} => | |
159 | Option.app (S, fn S => Env.extendStrid (E, name, S))) | |
160 | in | |
161 | Decs.appendsV (Vector.map (strbinds, #decs)) | |
162 | end | |
163 | val () = | |
164 | case resolveScope () of | |
165 | Control.Elaborate.ResolveScope.Strdec => | |
166 | (ElaborateCore.reportUnresolvedFlexRecords () | |
167 | ; ElaborateCore.resolveOverloads ()) | |
168 | | _ => () | |
169 | in | |
170 | decs | |
171 | end) arg | |
172 | and elabStrexp (arg: Strexp.t * string list): Decs.t * Structure.t option = | |
173 | Trace.traceInfo' (elabStrexpInfo, | |
174 | Layout.tuple2 (Strexp.layout, | |
175 | List.layout String.layout), | |
176 | Layout.tuple2 (Decs.layout, | |
177 | Option.layout Structure.layout)) | |
178 | (fn (e: Strexp.t, nest: string list) => | |
179 | let | |
180 | val elabStrexp = fn e => elabStrexp (e, nest) | |
181 | in | |
182 | case Strexp.node e of | |
183 | Strexp.App (fctid, strexp) => (* rules 54, 154 *) | |
184 | let | |
185 | val (decs, S) = elabStrexp strexp | |
186 | in | |
187 | case S of | |
188 | NONE => (decs, NONE) | |
189 | | SOME S => | |
190 | case Env.lookupFctid (E, fctid) of | |
191 | NONE => (decs, NONE) | |
192 | | SOME fct => | |
193 | let | |
194 | val (S, decs') = | |
195 | Env.cut | |
196 | (E, S, | |
197 | FunctorClosure.argInterface fct, | |
198 | {isFunctor = true, | |
199 | opaque = false, | |
200 | prefix = ""}, | |
201 | Region.append | |
202 | (Fctid.region fctid, | |
203 | Strexp.region strexp)) | |
204 | val resId = Strid.uRes (Fctid.toString fctid) | |
205 | val (decs'', S) = | |
206 | FunctorClosure.apply | |
207 | (fct, S, [Strid.toString resId]) | |
208 | in | |
209 | (Decs.appends [decs, decs', decs''], S) | |
210 | end | |
211 | end | |
212 | | Strexp.Constrained (e, c) => (* rules 52, 53 *) | |
213 | let | |
214 | val (decs, S) = elabStrexp e | |
215 | val (decs', S) = elabSigexpConstraint (c, S, nest) | |
216 | in | |
217 | (Decs.append (decs, decs'), S) | |
218 | end | |
219 | | Strexp.Let (d, e) => (* rule 55 *) | |
220 | Env.scope | |
221 | (E, fn () => | |
222 | let | |
223 | val decs = elabStrdec (d, nest) | |
224 | val (decs', S) = elabStrexp e | |
225 | in | |
226 | (Decs.append (decs, decs'), S) | |
227 | end) | |
228 | | Strexp.Struct d => (* rule 50 *) | |
229 | let | |
230 | val (decs, S) = | |
231 | Env.makeStructure (E, fn () => elabStrdec (d, nest)) | |
232 | in | |
233 | (decs, SOME S) | |
234 | end | |
235 | | Strexp.Var p => (* rule 51 *) | |
236 | (Decs.empty, Env.lookupLongstrid (E, p)) | |
237 | end) arg | |
238 | fun elabFunctor {arg, body, name, result}: FunctorClosure.t option = | |
239 | let | |
240 | val body = Strexp.constrained (body, result) | |
241 | val argId = Strid.uArg (Fctid.toString name) | |
242 | val (argSig, argDec) = | |
243 | case FctArg.node arg of | |
244 | FctArg.Structure (arg, argSig) => | |
245 | (argSig, | |
246 | Strdec.structuree | |
247 | {name = arg, | |
248 | def = Strexp.var (Longstrid.short argId), | |
249 | constraint = SigConst.None}) | |
250 | | FctArg.Spec spec => | |
251 | (Sigexp.spec spec, | |
252 | Strdec.openn (Vector.new1 (Longstrid.short argId))) | |
253 | val body = Strexp.lett (argDec, body) | |
254 | in | |
255 | Option.map (elabSigexp (argSig, SOME (Strid.toString argId)), fn argInt => | |
256 | Env.functorClosure | |
257 | (E, name, argInt, | |
258 | fn (formal, nest) => | |
259 | Env.scope | |
260 | (E, fn () => | |
261 | (Env.extendStrid (E, argId, formal) | |
262 | ; elabStrexp (body, nest))))) | |
263 | end | |
264 | fun elabTopdec arg: Decs.t = | |
265 | Trace.traceInfo' (elabTopdecInfo, | |
266 | Topdec.layout, | |
267 | Decs.layout) | |
268 | (fn (d: Topdec.t) => | |
269 | let | |
270 | val decs = | |
271 | case Topdec.node d of | |
272 | Topdec.Signature sigbinds => | |
273 | let | |
274 | val sigbinds = | |
275 | Vector.map | |
276 | (sigbinds, fn (sigid, sigexp) => | |
277 | (sigid, elabSigexp (sigexp, SOME (Sigid.toString sigid)))) | |
278 | val () = | |
279 | Vector.foreach | |
280 | (sigbinds, fn (sigid, I) => | |
281 | Option.app (I, fn I => Env.extendSigid (E, sigid, I))) | |
282 | in | |
283 | Decs.empty | |
284 | end | |
285 | | Topdec.Strdec d => elabStrdec (d, []) | |
286 | | Topdec.Functor funbinds => | |
287 | (* Rules 85, 86. Appendix A, p.58 *) | |
288 | let | |
289 | val funbinds = | |
290 | Vector.map | |
291 | (funbinds, fn {arg, body, name, result} => | |
292 | {closure = elabFunctor {arg = arg, | |
293 | body = body, | |
294 | name = name, | |
295 | result = result}, | |
296 | name = name}) | |
297 | val () = | |
298 | Vector.foreach (funbinds, fn {closure, name} => | |
299 | Option.app | |
300 | (closure, fn closure => | |
301 | Env.extendFctid (E, name, closure))) | |
302 | in | |
303 | Decs.empty | |
304 | end | |
305 | val () = | |
306 | case resolveScope () of | |
307 | Control.Elaborate.ResolveScope.Topdec => | |
308 | (ElaborateCore.reportUnresolvedFlexRecords () | |
309 | ; ElaborateCore.resolveOverloads ()) | |
310 | | _ => () | |
311 | val _ = ElaborateCore.reportUndeterminedTypes () | |
312 | val _ = ElaborateCore.reportSequenceNonUnit () | |
313 | in | |
314 | decs | |
315 | end) arg | |
316 | in | |
317 | elabTopdec topdec | |
318 | end | |
319 | ||
320 | val reportSequenceNonUnit = ElaborateCore.reportSequenceNonUnit | |
321 | val reportUndeterminedTypes = ElaborateCore.reportUndeterminedTypes | |
322 | val reportUnresolvedFlexRecords = ElaborateCore.reportUnresolvedFlexRecords | |
323 | val resolveOverloads = ElaborateCore.resolveOverloads | |
324 | ||
325 | end |