Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 2017 Matthew Fluet. |
2 | * Copyright (C) 1999-2007 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 AstModules (S: AST_MODULES_STRUCTS): AST_MODULES = | |
11 | struct | |
12 | ||
13 | open S | |
14 | ||
15 | structure AstCore = AstCore (AstAtoms (S)) | |
16 | ||
17 | open AstCore Layout | |
18 | ||
19 | fun mkCtxt (x, lay) () = | |
20 | seq [str "in: ", lay x] | |
21 | ||
22 | val layouts = List.map | |
23 | structure Wrap = Region.Wrap | |
24 | val node = Wrap.node | |
25 | ||
26 | structure WhereEquation = | |
27 | struct | |
28 | open Wrap | |
29 | datatype node = | |
30 | Type of {tyvars: Tyvar.t vector, | |
31 | longtycon: Longtycon.t, | |
32 | ty: Type.t} | |
33 | type t = node Wrap.t | |
34 | type node' = node | |
35 | type obj = t | |
36 | ||
37 | fun layout eq = | |
38 | case node eq of | |
39 | Type {tyvars, longtycon, ty} => | |
40 | seq [str "where type ", | |
41 | Type.layoutApp (Longtycon.layout longtycon, tyvars, Tyvar.layout), | |
42 | str " = ", | |
43 | Type.layout ty] | |
44 | ||
45 | fun checkSyntax eq = | |
46 | case node eq of | |
47 | Type {tyvars, longtycon, ty} => | |
48 | (reportDuplicateTyvars | |
49 | (tyvars, {ctxt = fn () => | |
50 | seq [str "in: ", | |
51 | Type.layoutApp | |
52 | (Longtycon.layout longtycon, | |
53 | tyvars, Tyvar.layout)]}) | |
54 | ; Type.checkSyntax ty) | |
55 | ||
56 | end | |
57 | ||
58 | structure SharingEquation = | |
59 | struct | |
60 | open Wrap | |
61 | datatype node = | |
62 | Type of Longtycon.t list | |
63 | | Structure of Longstrid.t list | |
64 | type t = node Wrap.t | |
65 | type node' = node | |
66 | type obj = t | |
67 | ||
68 | fun layout eq = | |
69 | case node eq of | |
70 | Type longtycons => | |
71 | seq (str "sharing type " | |
72 | :: separate (List.map (longtycons, Longtycon.layout), " = ")) | |
73 | | Structure longstrids => | |
74 | seq (str "sharing " | |
75 | :: separate (List.map (longstrids, Longstrid.layout), " = ")) | |
76 | end | |
77 | ||
78 | type typedescs = {tyvars: Tyvar.t vector, | |
79 | tycon: Tycon.t} vector | |
80 | ||
81 | datatype sigexpNode = | |
82 | Var of Sigid.t | |
83 | | Where of {equations: WhereEquation.t vector, | |
84 | sigexp: sigexp} | |
85 | | Spec of spec | |
86 | and sigConst = | |
87 | None | |
88 | | Transparent of sigexp | |
89 | | Opaque of sigexp | |
90 | and specNode = | |
91 | Datatype of DatatypeRhs.t | |
92 | | Empty | |
93 | | Eqtype of typedescs | |
94 | | Exception of (Con.t * Type.t option) vector | |
95 | | IncludeSigexp of sigexp | |
96 | | IncludeSigids of Sigid.t vector | |
97 | | Seq of spec * spec | |
98 | | Sharing of {equation: SharingEquation.t, | |
99 | spec: spec} | |
100 | | Structure of (Strid.t * sigexp) vector | |
101 | | Type of typedescs | |
102 | | TypeDefs of TypBind.t | |
103 | | Val of (Var.t * Type.t) vector | |
104 | withtype spec = specNode Wrap.t | |
105 | and sigexp = sigexpNode Wrap.t | |
106 | ||
107 | fun layoutTypedescs (prefix, typedescs) = | |
108 | layoutAnds (prefix, typedescs, fn (prefix, {tyvars, tycon}) => | |
109 | seq [prefix, | |
110 | Type.layoutApp (Tycon.layout tycon, tyvars, Tyvar.layout)]) | |
111 | ||
112 | fun layoutTypedefs (prefix, typBind) = | |
113 | let | |
114 | val TypBind.T ds = TypBind.node typBind | |
115 | in | |
116 | layoutAnds (prefix, ds, fn (prefix, {def, tycon, tyvars}) => | |
117 | seq [prefix, | |
118 | Type.layoutApp (Tycon.layout tycon, tyvars, Tyvar.layout), | |
119 | str " = ", Type.layout def]) | |
120 | end | |
121 | ||
122 | fun layoutSigexp (e: sigexp): Layout.t = | |
123 | case node e of | |
124 | Var s => Sigid.layout s | |
125 | | Where {sigexp, equations} => | |
126 | let | |
127 | val sigexp = layoutSigexp sigexp | |
128 | in | |
129 | if Vector.isEmpty equations | |
130 | then sigexp | |
131 | else mayAlign | |
132 | [sigexp, | |
133 | align (Vector.toListMap (equations, WhereEquation.layout))] | |
134 | end | |
135 | | Spec s => align [str "sig", | |
136 | indent (layoutSpec s, 3), | |
137 | str "end"] | |
138 | ||
139 | and layoutSigConst sigConst = | |
140 | case sigConst of | |
141 | None => empty | |
142 | | Transparent s => seq [str ": ", layoutSigexp s] | |
143 | | Opaque s => seq [str " :> ", layoutSigexp s] | |
144 | ||
145 | and layoutSpec (s: spec): t = | |
146 | case node s of | |
147 | Datatype rhs => DatatypeRhs.layout rhs | |
148 | | Empty => empty | |
149 | | Eqtype typedescs => layoutTypedescs ("eqtype", typedescs) | |
150 | | Exception sts => | |
151 | layoutAnds | |
152 | ("exception", sts, fn (prefix, (c, to)) => seq [prefix, | |
153 | Con.layout c, | |
154 | Type.layoutOption to]) | |
155 | | IncludeSigexp s => seq [str "include ", layoutSigexp s] | |
156 | | IncludeSigids sigids => | |
157 | seq (str "include " | |
158 | :: separate (Vector.toListMap (sigids, Sigid.layout), " ")) | |
159 | | Seq (s, s') => align [layoutSpec s, layoutSpec s'] | |
160 | | Sharing {spec, equation} => | |
161 | align [layoutSpec spec, | |
162 | SharingEquation.layout equation] | |
163 | | Structure l => | |
164 | layoutAndsBind ("structure", ":", l, fn (strid, sigexp) => | |
165 | (case node sigexp of | |
166 | Var _ => OneLine | |
167 | | _ => Split 3, | |
168 | Strid.layout strid, | |
169 | layoutSigexp sigexp)) | |
170 | | Type typedescs => layoutTypedescs ("type", typedescs) | |
171 | | TypeDefs typedefs => layoutTypedefs ("type", typedefs) | |
172 | | Val sts => | |
173 | layoutAndsBind | |
174 | ("val", ":", sts, fn (x, t) => (OneLine, Var.layout x, Type.layout t)) | |
175 | ||
176 | fun checkSyntaxSigexp (e: sigexp): unit = | |
177 | case node e of | |
178 | Spec s => checkSyntaxSpec s | |
179 | | Var _ => () | |
180 | | Where {sigexp, equations} => | |
181 | (checkSyntaxSigexp sigexp | |
182 | ; Vector.foreach | |
183 | (equations, WhereEquation.checkSyntax)) | |
184 | ||
185 | and checkSyntaxSigConst (s: sigConst): unit = | |
186 | case s of | |
187 | None => () | |
188 | | Opaque e => checkSyntaxSigexp e | |
189 | | Transparent e => checkSyntaxSigexp e | |
190 | ||
191 | and checkSyntaxTypedescs (typedescs, {ctxt}) = | |
192 | (Vector.foreach | |
193 | (typedescs, fn {tyvars, tycon, ...} => | |
194 | reportDuplicateTyvars | |
195 | (tyvars, {ctxt = fn () => | |
196 | seq [str "in: ", | |
197 | Type.layoutApp | |
198 | (Tycon.layout tycon, | |
199 | tyvars, Tyvar.layout)]})) | |
200 | ; reportDuplicates | |
201 | (typedescs, {ctxt = ctxt, | |
202 | equals = (fn ({tycon = c, ...}, {tycon = c', ...}) => | |
203 | Tycon.equals (c, c')), | |
204 | layout = Tycon.layout o #tycon, | |
205 | name = "type specification", | |
206 | region = Tycon.region o #tycon})) | |
207 | ||
208 | and checkSyntaxSpec (s: spec): unit = | |
209 | let | |
210 | val ctxt = mkCtxt (s, layoutSpec) | |
211 | in | |
212 | case node s of | |
213 | Datatype d => DatatypeRhs.checkSyntaxSpec d | |
214 | | Eqtype typedescs => checkSyntaxTypedescs (typedescs, {ctxt = ctxt}) | |
215 | | Empty => () | |
216 | | Exception v => | |
217 | (Vector.foreach | |
218 | (v, fn (con, to) => | |
219 | (Vid.checkSpecifySpecial | |
220 | (Vid.fromCon con, | |
221 | {allowIt = false, | |
222 | ctxt = ctxt, | |
223 | keyword = "exception"}) | |
224 | ; Option.app (to, Type.checkSyntax))) | |
225 | ; (reportDuplicates | |
226 | (v, {ctxt = ctxt, | |
227 | equals = fn ((c, _), (c', _)) => Con.equals (c, c'), | |
228 | layout = Con.layout o #1, | |
229 | name = "exception specification", | |
230 | region = Con.region o #1}))) | |
231 | | IncludeSigexp e => checkSyntaxSigexp e | |
232 | | IncludeSigids _ => () | |
233 | | Seq (s, s') => (checkSyntaxSpec s; checkSyntaxSpec s') | |
234 | | Sharing {spec, ...} => checkSyntaxSpec spec | |
235 | | Structure v => | |
236 | (Vector.foreach (v, checkSyntaxSigexp o #2) | |
237 | ; (reportDuplicates | |
238 | (v, {ctxt = ctxt, | |
239 | equals = fn ((s, _), (s', _)) => Strid.equals (s, s'), | |
240 | layout = Strid.layout o #1, | |
241 | name = "structure specification", | |
242 | region = Strid.region o #1}))) | |
243 | | Type typedescs => checkSyntaxTypedescs (typedescs, {ctxt = ctxt}) | |
244 | | TypeDefs b => TypBind.checkSyntaxSpec b | |
245 | | Val v => | |
246 | (Vector.foreach | |
247 | (v, fn (v, t) => | |
248 | (Vid.checkSpecifySpecial | |
249 | (Vid.fromVar v, | |
250 | {allowIt = true, | |
251 | ctxt = ctxt, | |
252 | keyword = "val"}) | |
253 | ; Type.checkSyntax t)) | |
254 | ; (reportDuplicates | |
255 | (v, {ctxt = ctxt, | |
256 | equals = fn ((x, _), (x', _)) => Var.equals (x, x'), | |
257 | layout = Var.layout o #1, | |
258 | name = "value specification", | |
259 | region = Var.region o #1}))) | |
260 | end | |
261 | ||
262 | structure Sigexp = | |
263 | struct | |
264 | open Wrap | |
265 | type spec = spec | |
266 | type t = sigexp | |
267 | datatype node = datatype sigexpNode | |
268 | type node' = node | |
269 | type obj = t | |
270 | ||
271 | val checkSyntax = checkSyntaxSigexp | |
272 | ||
273 | fun wheree (sigexp: t, equations): t = | |
274 | if Vector.isEmpty equations | |
275 | then sigexp | |
276 | else makeRegion (Where {sigexp = sigexp, | |
277 | equations = equations}, | |
278 | Region.append | |
279 | (region sigexp, | |
280 | WhereEquation.region | |
281 | (Vector.last equations))) | |
282 | ||
283 | fun make n = makeRegion (n, Region.bogus) | |
284 | ||
285 | val spec = make o Spec | |
286 | ||
287 | val layout = layoutSigexp | |
288 | end | |
289 | ||
290 | structure SigConst = | |
291 | struct | |
292 | datatype t = datatype sigConst | |
293 | ||
294 | val checkSyntax = checkSyntaxSigConst | |
295 | val layout = layoutSigConst | |
296 | end | |
297 | ||
298 | structure Spec = | |
299 | struct | |
300 | open Wrap | |
301 | datatype node = datatype specNode | |
302 | type t = spec | |
303 | type node' = node | |
304 | type obj = t | |
305 | ||
306 | val checkSyntax = checkSyntaxSpec | |
307 | val layout = layoutSpec | |
308 | end | |
309 | ||
310 | (*---------------------------------------------------*) | |
311 | (* Strdecs and Strexps *) | |
312 | (*---------------------------------------------------*) | |
313 | ||
314 | datatype strdecNode = | |
315 | Core of Dec.t | |
316 | | Local of strdec * strdec | |
317 | | Seq of strdec list | |
318 | | ShowBasis of File.t | |
319 | | Structure of {constraint: SigConst.t, | |
320 | def: strexp, | |
321 | name: Strid.t} vector | |
322 | ||
323 | and strexpNode = | |
324 | App of Fctid.t * strexp | |
325 | | Constrained of strexp * SigConst.t | |
326 | | Let of strdec * strexp | |
327 | | Struct of strdec | |
328 | | Var of Longstrid.t | |
329 | withtype strexp = strexpNode Wrap.t | |
330 | and strdec = strdecNode Wrap.t | |
331 | ||
332 | fun layoutStrdec d = | |
333 | case node d of | |
334 | Core d => Dec.layout d | |
335 | | Local (d, d') => Pretty.locall (layoutStrdec d, layoutStrdec d') | |
336 | | Seq ds => align (layoutStrdecs ds) | |
337 | | ShowBasis file => seq [str "(*#showBasis \"", | |
338 | File.layout file, | |
339 | str "\"*)"] | |
340 | | Structure strbs => | |
341 | layoutAndsBind ("structure", "=", strbs, | |
342 | fn {name, def, constraint} => | |
343 | (case node def of | |
344 | Var _ => OneLine | |
345 | | _ => Split 3, | |
346 | seq [Strid.layout name, SigConst.layout constraint], | |
347 | layoutStrexp def)) | |
348 | ||
349 | and layoutStrdecs ds = layouts (ds, layoutStrdec) | |
350 | ||
351 | and layoutStrexp exp = | |
352 | case node exp of | |
353 | App (f, e) => seq [Fctid.layout f, str " ", paren (layoutStrexp e)] | |
354 | | Constrained (e, c) => mayAlign [layoutStrexp e, SigConst.layout c] | |
355 | | Let (dec, strexp) => Pretty.lett (layoutStrdec dec, layoutStrexp strexp) | |
356 | | Struct d => align [str "struct", | |
357 | indent (layoutStrdec d, 3), | |
358 | str "end"] | |
359 | | Var s => Longstrid.layout s | |
360 | ||
361 | fun checkSyntaxStrdec (d: strdec): unit = | |
362 | case node d of | |
363 | Core d => Dec.checkSyntax d | |
364 | | Local (d, d') => (checkSyntaxStrdec d; checkSyntaxStrdec d') | |
365 | | Seq ds => List.foreach (ds, checkSyntaxStrdec) | |
366 | | ShowBasis _ => () | |
367 | | Structure v => | |
368 | (Vector.foreach (v, fn {constraint, def, ...} => | |
369 | (SigConst.checkSyntax constraint | |
370 | ; checkSyntaxStrexp def)) | |
371 | ; (reportDuplicates | |
372 | (v, {ctxt = mkCtxt (d, layoutStrdec), | |
373 | equals = (fn ({name = n, ...}, {name = n', ...}) => | |
374 | Strid.equals (n, n')), | |
375 | layout = Strid.layout o #name, | |
376 | name = "structure definition", | |
377 | region = Strid.region o #name}))) | |
378 | and checkSyntaxStrexp (e: strexp): unit = | |
379 | case node e of | |
380 | App (_, e) => checkSyntaxStrexp e | |
381 | | Constrained (e, c) => (checkSyntaxStrexp e | |
382 | ; SigConst.checkSyntax c) | |
383 | | Let (d, e) => (checkSyntaxStrdec d | |
384 | ; checkSyntaxStrexp e) | |
385 | | Struct d => checkSyntaxStrdec d | |
386 | | Var _ => () | |
387 | ||
388 | structure Strexp = | |
389 | struct | |
390 | open Wrap | |
391 | type strdec = strdec | |
392 | type t = strexp | |
393 | datatype node = datatype strexpNode | |
394 | type node' = node | |
395 | type obj = t | |
396 | ||
397 | val checkSyntax = checkSyntaxStrexp | |
398 | fun make n = makeRegion (n, Region.bogus) | |
399 | val constrained = make o Constrained | |
400 | val lett = make o Let | |
401 | val var = make o Var | |
402 | val layout = layoutStrexp | |
403 | end | |
404 | ||
405 | structure Strdec = | |
406 | struct | |
407 | open Wrap | |
408 | type t = strdec | |
409 | datatype node = datatype strdecNode | |
410 | type node' = node | |
411 | type obj = t | |
412 | ||
413 | val checkSyntax = checkSyntaxStrdec | |
414 | fun make n = makeRegion (n, Region.bogus) | |
415 | ||
416 | val core = make o Core | |
417 | ||
418 | val openn = core o Dec.openn | |
419 | ||
420 | val structuree = make o Structure o Vector.new1 | |
421 | ||
422 | val layout = layoutStrdec | |
423 | ||
424 | val fromExp = core o Dec.fromExp | |
425 | ||
426 | val trace = Trace.trace ("AstModules.Strdec.coalesce", layout, layout) | |
427 | fun coalesce (d: t): t = | |
428 | trace | |
429 | (fn d => | |
430 | case node d of | |
431 | Core _ => d | |
432 | | Local (d1, d2) => | |
433 | let | |
434 | val d1 = coalesce d1 | |
435 | val d2 = coalesce d2 | |
436 | val node = | |
437 | case (node d1, node d2) of | |
438 | (Core d1', Core d2') => | |
439 | Core (Dec.makeRegion | |
440 | (Dec.Local (d1', d2'), | |
441 | Region.append (region d1, region d2))) | |
442 | | _ => Local (d1, d2) | |
443 | in | |
444 | makeRegion (node, region d) | |
445 | end | |
446 | | Seq ds => | |
447 | let | |
448 | fun finish (ds: Dec.t list, ac: t list): t list = | |
449 | case ds of | |
450 | [] => ac | |
451 | | _ => | |
452 | let | |
453 | val d = | |
454 | makeRegion (Core (Dec.makeRegion | |
455 | (Dec.SeqDec (Vector.fromListRev ds), | |
456 | Region.bogus)), | |
457 | Region.bogus) | |
458 | in | |
459 | d :: ac | |
460 | end | |
461 | fun loop (ds, cores, ac) = | |
462 | case ds of | |
463 | [] => finish (cores, ac) | |
464 | | d :: ds => | |
465 | let | |
466 | val d = coalesce d | |
467 | in | |
468 | case node d of | |
469 | Core d => loop (ds, d :: cores, ac) | |
470 | | Seq ds' => loop (ds' @ ds, cores, ac) | |
471 | | _ => loop (ds, [], d :: finish (cores, ac)) | |
472 | end | |
473 | val r = region d | |
474 | in | |
475 | case loop (ds, [], []) of | |
476 | [] => makeRegion (Core (Dec.makeRegion | |
477 | (Dec.SeqDec (Vector.new0 ()), r)), | |
478 | r) | |
479 | | [d] => d | |
480 | | ds => makeRegion (Seq (rev ds), r) | |
481 | end | |
482 | | ShowBasis _ => d | |
483 | | Structure _ => d) d | |
484 | end | |
485 | ||
486 | structure FctArg = | |
487 | struct | |
488 | open Wrap | |
489 | datatype node = | |
490 | Structure of Strid.t * Sigexp.t | |
491 | | Spec of Spec.t | |
492 | type t = node Wrap.t | |
493 | type node' = node | |
494 | type obj = t | |
495 | ||
496 | fun layout a = | |
497 | case node a of | |
498 | Structure (strid, sigexp) => | |
499 | seq [Strid.layout strid, str ": ", Sigexp.layout sigexp] | |
500 | | Spec spec => Spec.layout spec | |
501 | ||
502 | fun checkSyntax (fa: t): unit = | |
503 | case node fa of | |
504 | Structure (_, e) => Sigexp.checkSyntax e | |
505 | | Spec s => Spec.checkSyntax s | |
506 | end | |
507 | ||
508 | structure Topdec = | |
509 | struct | |
510 | open Wrap | |
511 | datatype node = | |
512 | Functor of {arg: FctArg.t, | |
513 | body: Strexp.t, | |
514 | name: Fctid.t, | |
515 | result: SigConst.t} vector | |
516 | | Signature of (Sigid.t * Sigexp.t) vector | |
517 | | Strdec of Strdec.t | |
518 | type t = node Wrap.t | |
519 | type node' = node | |
520 | type obj = t | |
521 | ||
522 | fun layout d = | |
523 | case node d of | |
524 | Functor fctbs => | |
525 | layoutAndsBind ("functor", "=", fctbs, | |
526 | fn {name, arg, result, body} => | |
527 | (Split 3, | |
528 | seq [Fctid.layout name, str " ", | |
529 | paren (FctArg.layout arg), | |
530 | layoutSigConst result], | |
531 | layoutStrexp body)) | |
532 | | Signature sigbs => | |
533 | layoutAndsBind ("signature", "=", sigbs, | |
534 | fn (name, def) => | |
535 | (case Sigexp.node def of | |
536 | Sigexp.Var _ => OneLine | |
537 | | _ => Split 3, | |
538 | Sigid.layout name, | |
539 | Sigexp.layout def)) | |
540 | | Strdec d => Strdec.layout d | |
541 | ||
542 | ||
543 | fun make n = makeRegion (n, Region.bogus) | |
544 | val fromExp = make o Strdec o Strdec.fromExp | |
545 | ||
546 | fun checkSyntax (d: t): unit = | |
547 | case node d of | |
548 | Functor v => | |
549 | (Vector.foreach | |
550 | (v, fn {arg, body, result, ...} => | |
551 | (FctArg.checkSyntax arg | |
552 | ; Strexp.checkSyntax body | |
553 | ; SigConst.checkSyntax result)) | |
554 | ; (reportDuplicates | |
555 | (v, {ctxt = mkCtxt (d, layout), | |
556 | equals = (fn ({name = n, ...}, {name = n', ...}) => | |
557 | Fctid.equals (n, n')), | |
558 | layout = Fctid.layout o #name, | |
559 | name = "functor definition", | |
560 | region = Fctid.region o #name}))) | |
561 | | Signature bs => | |
562 | (Vector.foreach (bs, Sigexp.checkSyntax o #2) | |
563 | ; (reportDuplicates | |
564 | (bs, | |
565 | {ctxt = mkCtxt (d, layout), | |
566 | equals = fn ((s, _), (s', _)) => Sigid.equals (s, s'), | |
567 | layout = Sigid.layout o #1, | |
568 | name = "signature definition", | |
569 | region = Sigid.region o #1}))) | |
570 | | Strdec d => Strdec.checkSyntax d | |
571 | end | |
572 | ||
573 | end |