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 AstAtoms (S: AST_ATOMS_STRUCTS): AST_ATOMS = | |
11 | struct | |
12 | ||
13 | open S | |
14 | ||
15 | structure Wrap = Region.Wrap | |
16 | structure Field = Record.Field | |
17 | ||
18 | structure Const = AstConst () | |
19 | ||
20 | structure Tyvar = | |
21 | struct | |
22 | structure Id = AstId (structure Symbol = Symbol) | |
23 | open Id | |
24 | fun isEquality t = | |
25 | let | |
26 | val s = toString t | |
27 | in | |
28 | String.length s > 1 andalso String.sub (s, 1) = #"'" | |
29 | end | |
30 | end | |
31 | ||
32 | structure Tycon = | |
33 | struct | |
34 | structure Id = AstId (structure Symbol = Symbol) | |
35 | open Id | |
36 | ||
37 | structure P = | |
38 | PrimTycons (structure AdmitsEquality = AdmitsEquality | |
39 | structure CharSize = CharSize | |
40 | structure IntSize = IntSize | |
41 | structure Kind = TyconKind | |
42 | structure RealSize = RealSize | |
43 | structure WordSize = WordSize | |
44 | open Id | |
45 | fun fromString s = | |
46 | Id.fromSymbol (Symbol.fromString s, Region.bogus)) | |
47 | open P | |
48 | end | |
49 | ||
50 | structure Var = AstId (structure Symbol = Symbol) | |
51 | ||
52 | structure Con = | |
53 | struct | |
54 | structure Id = AstId (structure Symbol = Symbol) | |
55 | open Id | |
56 | ||
57 | structure P = | |
58 | PrimCons (open Id | |
59 | fun fromString s = fromSymbol (Symbol.fromString s, | |
60 | Region.bogus)) | |
61 | ||
62 | open P | |
63 | ||
64 | val special = | |
65 | [cons, falsee, nill, reff, truee] | |
66 | end | |
67 | ||
68 | structure Basid = AstId (structure Symbol = Symbol) | |
69 | structure Sigid = AstId (structure Symbol = Symbol) | |
70 | structure Strid = AstId (structure Symbol = Symbol) | |
71 | structure Strid = | |
72 | struct | |
73 | open Strid | |
74 | local | |
75 | fun make s = fromSymbol (Symbol.fromString s, Region.bogus) | |
76 | in | |
77 | val uArg = fn s => make ("_arg_" ^ s) | |
78 | val uRes = fn s => make ("_res_" ^ s) | |
79 | val uStr = make "_str" | |
80 | val uSig = make "_sig" | |
81 | end | |
82 | end | |
83 | structure Fctid = AstId (structure Symbol = Symbol) | |
84 | ||
85 | structure Vid = | |
86 | struct | |
87 | structure I = AstId (structure Symbol = Symbol) | |
88 | open I | |
89 | ||
90 | fun fromCon c = fromSymbol (Con.toSymbol c, Con.region c) | |
91 | fun fromVar x = fromSymbol (Var.toSymbol x, Var.region x) | |
92 | local | |
93 | fun make f v = f (toSymbol v, region v) | |
94 | in | |
95 | val toCon = make Con.fromSymbol | |
96 | val toVar = make Var.fromSymbol | |
97 | end | |
98 | ||
99 | val it = fromSymbol (Symbol.itt, Region.bogus) | |
100 | val equal = fromSymbol (Symbol.equal, Region.bogus) | |
101 | val specialCons = List.map (Con.special, fromCon) | |
102 | ||
103 | fun checkSpecial (oper, ctrl) (vid, {allowIt, ctxt, keyword}) = | |
104 | if not (Control.Elaborate.current ctrl) | |
105 | andalso | |
106 | ((not allowIt andalso equals (vid, it)) | |
107 | orelse | |
108 | equals (vid, equal) | |
109 | orelse | |
110 | List.exists (specialCons, fn vid' => equals (vid, vid'))) | |
111 | then | |
112 | let | |
113 | open Layout | |
114 | in | |
115 | Control.error (region vid, | |
116 | seq [str "special identifier cannot be ", | |
117 | str oper, | |
118 | str " by ", | |
119 | str keyword, | |
120 | str ": ", | |
121 | layout vid], | |
122 | ctxt ()) | |
123 | end | |
124 | else () | |
125 | ||
126 | val checkRedefineSpecial = | |
127 | checkSpecial ("redefined", Control.Elaborate.allowRedefineSpecialIds) | |
128 | ||
129 | val checkSpecifySpecial = | |
130 | checkSpecial ("specified", Control.Elaborate.allowSpecifySpecialIds) | |
131 | end | |
132 | ||
133 | structure Longtycon = | |
134 | struct | |
135 | structure T = Longid (structure Id = Tycon | |
136 | structure Strid = Strid | |
137 | structure Symbol = Symbol) | |
138 | ||
139 | open T | |
140 | ||
141 | val arrow = short Tycon.arrow | |
142 | end | |
143 | ||
144 | structure Longvar = Longid (structure Id = Var | |
145 | structure Strid = Strid | |
146 | structure Symbol = Symbol) | |
147 | ||
148 | structure Longcon = | |
149 | struct | |
150 | structure L = Longid (structure Id = Con | |
151 | structure Strid = Strid | |
152 | structure Symbol = Symbol) | |
153 | ||
154 | open L | |
155 | end | |
156 | ||
157 | structure Longstrid = Longid (structure Id = Strid | |
158 | structure Strid = Strid | |
159 | structure Symbol = Symbol) | |
160 | ||
161 | ||
162 | structure Longvid = | |
163 | struct | |
164 | structure L = Longid (structure Id = Vid | |
165 | structure Strid = Strid | |
166 | structure Symbol = Symbol) | |
167 | ||
168 | open L | |
169 | local | |
170 | fun to (make,node, conv) x = | |
171 | let val (T {strids, id}, region) = dest x | |
172 | in make (node {strids = strids, id = conv id}, region) | |
173 | end | |
174 | in | |
175 | val toLongcon = to (Longcon.makeRegion, Longcon.T, Vid.toCon) | |
176 | end | |
177 | end | |
178 | ||
179 | open Layout | |
180 | ||
181 | fun mkCtxt (x, lay) () = | |
182 | seq [str "in: ", lay x] | |
183 | ||
184 | fun reportDuplicates (v: 'a vector, | |
185 | {ctxt: unit -> Layout.t, | |
186 | equals: 'a * 'a -> bool, | |
187 | layout: 'a -> Layout.t, | |
188 | name: string, | |
189 | region: 'a -> Region.t}) = | |
190 | Vector.foreachi | |
191 | (v, fn (i, a) => | |
192 | let | |
193 | fun loop i' = | |
194 | if i = i' | |
195 | then () | |
196 | else | |
197 | if not (equals (a, Vector.sub (v, i'))) | |
198 | then loop (i' + 1) | |
199 | else | |
200 | let | |
201 | open Layout | |
202 | in | |
203 | Control.error | |
204 | (region a, | |
205 | seq [str (concat ["duplicate ", name, ": "]), layout a], | |
206 | ctxt ()) | |
207 | end | |
208 | in | |
209 | loop 0 | |
210 | end) | |
211 | ||
212 | fun reportDuplicateFields (v: (Field.t * (Region.t * 'a)) vector, | |
213 | {ctxt: unit -> Layout.t}): unit = | |
214 | reportDuplicates (v, | |
215 | {ctxt = ctxt, | |
216 | equals = fn ((f, _), (f', _)) => Field.equals (f, f'), | |
217 | layout = Field.layout o #1, | |
218 | name = "label", | |
219 | region = #1 o #2}) | |
220 | ||
221 | fun reportDuplicateTyvars (v: Tyvar.t vector, | |
222 | {ctxt: unit -> Layout.t}): unit = | |
223 | reportDuplicates (v, | |
224 | {ctxt = ctxt, | |
225 | equals = Tyvar.equals, | |
226 | layout = Tyvar.layout, | |
227 | name = "type variable", | |
228 | region = Tyvar.region}) | |
229 | ||
230 | structure Type = | |
231 | struct | |
232 | open Wrap | |
233 | datatype node = | |
234 | Con of Longtycon.t * t vector | |
235 | | Paren of t | |
236 | | Record of (Region.t * t) Record.t | |
237 | | Var of Tyvar.t | |
238 | withtype t = node Wrap.t | |
239 | type node' = node | |
240 | type obj = t | |
241 | ||
242 | fun make n = makeRegion (n, Region.bogus) | |
243 | val var = make o Var | |
244 | val record = make o Record | |
245 | val tuple = record o Record.tuple o (fn tys => Vector.map (tys, fn ty => (Region.bogus, ty))) | |
246 | val unit = tuple (Vector.new0 ()) | |
247 | ||
248 | fun con (c: Tycon.t, ts: t vector): t = | |
249 | if Tycon.equals (c, Tycon.tuple) | |
250 | then tuple ts | |
251 | else make (Con (Longtycon.short c, ts)) | |
252 | ||
253 | fun arrow (t1, t2) = con (Tycon.arrow, Vector.new2 (t1, t2)) | |
254 | ||
255 | fun layoutApp (tycon, args: 'a vector, layoutArg) = | |
256 | case Vector.length args of | |
257 | 0 => tycon | |
258 | | 1 => seq [layoutArg (Vector.first args), str " ", tycon] | |
259 | | _ => seq [Vector.layout layoutArg args, str " ", tycon] | |
260 | ||
261 | fun layout ty = | |
262 | case node ty of | |
263 | Var v => Tyvar.layout v | |
264 | | Con (c, tys) => | |
265 | if Longtycon.equals (c, Longtycon.arrow) | |
266 | then if 2 = Vector.length tys | |
267 | then | |
268 | paren (mayAlign | |
269 | [layout (Vector.first tys), | |
270 | seq [str "-> ", | |
271 | layout (Vector.sub (tys, 1))]]) | |
272 | else Error.bug "AstAtoms.Type.layout: non-binary -> tyc" | |
273 | else layoutApp (Longtycon.layout c, tys, layout) | |
274 | | Paren t => layout t | |
275 | | Record r => Record.layout {record = r, | |
276 | separator = ": ", extra = "", | |
277 | layoutElt = layout o #2, | |
278 | layoutTuple = fn rtys => layoutTupleTy (Vector.map (rtys, #2))} | |
279 | and layoutTupleTy tys = | |
280 | case Vector.length tys of | |
281 | 0 => str "unit" | |
282 | | 1 => layout (Vector.first tys) | |
283 | | _ => paren (mayAlign (separateLeft (Vector.toListMap (tys, layout), | |
284 | "* "))) | |
285 | ||
286 | fun layoutOption ty = | |
287 | case ty of | |
288 | NONE => empty | |
289 | | SOME ty => seq [str " of ", layout ty] | |
290 | ||
291 | fun checkSyntax (t: t): unit = | |
292 | case node t of | |
293 | Con (_, ts) => Vector.foreach (ts, checkSyntax) | |
294 | | Paren t => checkSyntax t | |
295 | | Record r => | |
296 | (reportDuplicateFields (Record.toVector r, | |
297 | {ctxt = mkCtxt (t, layout)}) | |
298 | ; Record.foreach (r, checkSyntax o #2)) | |
299 | | Var _ => () | |
300 | end | |
301 | ||
302 | fun bind (x, y) = mayAlign [seq [x, str " ="], y] | |
303 | ||
304 | fun 'a layoutAndsSusp (prefix: string, | |
305 | xs: 'a vector, | |
306 | layoutX: bool * Layout.t * 'a -> Layout.t): (unit -> Layout.t) vector = | |
307 | Vector.mapi | |
308 | (xs, fn (i, x) => fn () => | |
309 | layoutX (i = 0, if i = 0 then str (concat [prefix, " "]) else str "and ", x)) | |
310 | ||
311 | fun 'a layoutAnds (prefix: string, | |
312 | xs: 'a vector, | |
313 | layoutX: Layout.t * 'a -> Layout.t): Layout.t = | |
314 | align (Vector.toListMap (layoutAndsSusp (prefix, xs, fn (_, prefix, x) => layoutX (prefix, x)), fn th => th ())) | |
315 | ||
316 | datatype bindStyle = OneLine | Split of int | |
317 | ||
318 | fun 'a layoutBind (bind: string, | |
319 | layout: 'a -> bindStyle * Layout.t * Layout.t) | |
320 | (prefix: Layout.t, x: 'a): Layout.t = | |
321 | let | |
322 | val (style, lhs, rhs) = layout x | |
323 | val lhs = seq [prefix, lhs, str " " , str bind] | |
324 | in | |
325 | case style of | |
326 | OneLine => seq [lhs, str " ", rhs] | |
327 | | Split indentation => align [lhs, indent (rhs, indentation)] | |
328 | end | |
329 | ||
330 | fun layoutAndsBind (prefix, bind, xs, layout) = | |
331 | layoutAnds (prefix, xs, layoutBind (bind, layout)) | |
332 | ||
333 | (*---------------------------------------------------*) | |
334 | (* TypBind *) | |
335 | (*---------------------------------------------------*) | |
336 | ||
337 | structure TypBind = | |
338 | struct | |
339 | datatype node = | |
340 | T of {tycon: Tycon.t, | |
341 | def: Type.t, | |
342 | tyvars: Tyvar.t vector} vector | |
343 | open Wrap | |
344 | type t = node Wrap.t | |
345 | type node' = node | |
346 | type obj = t | |
347 | ||
348 | fun layout t = | |
349 | let | |
350 | val T ds = node t | |
351 | in | |
352 | layoutAndsBind | |
353 | ("type", "=", ds, fn {tycon, def, tyvars} => | |
354 | (OneLine, | |
355 | Type.layoutApp (Tycon.layout tycon, | |
356 | tyvars, | |
357 | Tyvar.layout), | |
358 | Type.layout def)) | |
359 | end | |
360 | ||
361 | val empty = makeRegion (T (Vector.new0 ()), Region.bogus) | |
362 | ||
363 | fun isEmpty (b: t) = | |
364 | let | |
365 | val T ds = node b | |
366 | in | |
367 | Vector.isEmpty ds | |
368 | end | |
369 | ||
370 | fun checkSyntax (b: t, kind: string): unit = | |
371 | let | |
372 | val T v = node b | |
373 | val () = | |
374 | Vector.foreach | |
375 | (v, fn {tyvars, tycon, def} => | |
376 | (reportDuplicateTyvars | |
377 | (tyvars, {ctxt = fn () => | |
378 | seq [str "in: ", | |
379 | Type.layoutApp | |
380 | (Tycon.layout tycon, | |
381 | tyvars, Tyvar.layout)]}) | |
382 | ; Type.checkSyntax def)) | |
383 | in | |
384 | reportDuplicates | |
385 | (v, {ctxt = mkCtxt (b, layout), | |
386 | equals = (fn ({tycon = t, ...}, {tycon = t', ...}) => | |
387 | Tycon.equals (t, t')), | |
388 | layout = Tycon.layout o #tycon, | |
389 | name = "type " ^ kind, | |
390 | region = Tycon.region o #tycon}) | |
391 | end | |
392 | fun checkSyntaxDef b = checkSyntax (b, "definition") | |
393 | fun checkSyntaxSpec b = checkSyntax (b, "specification") | |
394 | end | |
395 | ||
396 | (*---------------------------------------------------*) | |
397 | (* DatBind *) | |
398 | (*---------------------------------------------------*) | |
399 | ||
400 | structure DatBind = | |
401 | struct | |
402 | datatype node = | |
403 | T of {datatypes: {cons: (Con.t * Type.t option) vector, | |
404 | tycon: Tycon.t, | |
405 | tyvars: Tyvar.t vector} vector, | |
406 | withtypes: TypBind.t} | |
407 | ||
408 | open Wrap | |
409 | type t = node Wrap.t | |
410 | type node' = node | |
411 | type obj = t | |
412 | ||
413 | fun layout (prefix, d) = | |
414 | let | |
415 | val T {datatypes, withtypes} = node d | |
416 | in | |
417 | align | |
418 | [layoutAndsBind | |
419 | (prefix, "=", datatypes, fn {tyvars, tycon, cons} => | |
420 | (OneLine, | |
421 | Type.layoutApp (Tycon.layout tycon, tyvars, Tyvar.layout), | |
422 | alignPrefix (Vector.toListMap (cons, fn (c, to) => | |
423 | seq [Con.layout c, | |
424 | Type.layoutOption to]), | |
425 | "| "))), | |
426 | case TypBind.node withtypes of | |
427 | TypBind.T v => | |
428 | if Vector.isEmpty v | |
429 | then empty | |
430 | else seq [str "with", TypBind.layout withtypes]] | |
431 | end | |
432 | ||
433 | fun checkSyntax (b: t, kind: string, | |
434 | vidCheckSpecial: Vid.t * {allowIt: bool, | |
435 | ctxt: unit -> Layout.t, | |
436 | keyword: string} -> unit): unit = | |
437 | let | |
438 | val T {datatypes, withtypes} = node b | |
439 | val TypBind.T withtypes = TypBind.node withtypes | |
440 | val ctxt = mkCtxt ((), fn () => layout ("datatype", b)) | |
441 | val () = | |
442 | Vector.foreach | |
443 | (datatypes, fn {tyvars, tycon, cons} => | |
444 | (reportDuplicateTyvars | |
445 | (tyvars, {ctxt = fn () => | |
446 | seq [str "in: ", | |
447 | Type.layoutApp | |
448 | (Tycon.layout tycon, | |
449 | tyvars, Tyvar.layout)]}) | |
450 | ; Vector.foreach | |
451 | (cons, fn (c, to) => | |
452 | (vidCheckSpecial | |
453 | (Vid.fromCon c, | |
454 | {allowIt = false, | |
455 | ctxt = ctxt, | |
456 | keyword = "datatype"}) | |
457 | ; Option.app (to, Type.checkSyntax))))) | |
458 | val () = | |
459 | reportDuplicates | |
460 | (Vector.concatV (Vector.map (datatypes, #cons)), | |
461 | {ctxt = ctxt, | |
462 | equals = fn ((c, _), (c', _)) => Con.equals (c, c'), | |
463 | layout = Con.layout o #1, | |
464 | name = "constructor " ^ kind, | |
465 | region = Con.region o #1}) | |
466 | val () = | |
467 | Vector.foreach | |
468 | (withtypes, fn {tyvars, tycon, def} => | |
469 | (reportDuplicateTyvars | |
470 | (tyvars, {ctxt = fn () => | |
471 | seq [str "in: ", | |
472 | Type.layoutApp | |
473 | (Tycon.layout tycon, | |
474 | tyvars, Tyvar.layout)]}) | |
475 | ; Type.checkSyntax def)) | |
476 | val () = | |
477 | reportDuplicates | |
478 | (Vector.concat [Vector.map (datatypes, #tycon), | |
479 | Vector.map (withtypes, #tycon)], | |
480 | {ctxt = ctxt, | |
481 | equals = Tycon.equals, | |
482 | layout = Tycon.layout, | |
483 | name = "type " ^ kind, | |
484 | region = Tycon.region}) | |
485 | in | |
486 | () | |
487 | end | |
488 | fun checkSyntaxDef b = | |
489 | checkSyntax (b, "definition", Vid.checkRedefineSpecial) | |
490 | fun checkSyntaxSpec b = | |
491 | checkSyntax (b, "specification", Vid.checkSpecifySpecial) | |
492 | end | |
493 | ||
494 | structure DatatypeRhs = | |
495 | struct | |
496 | datatype node = | |
497 | DatBind of DatBind.t | |
498 | | Repl of {lhs: Tycon.t, rhs: Longtycon.t} | |
499 | ||
500 | open Wrap | |
501 | type t = node Wrap.t | |
502 | type node' = node | |
503 | type obj = t | |
504 | ||
505 | fun layout d = | |
506 | case node d of | |
507 | DatBind d => DatBind.layout ("datatype", d) | |
508 | | Repl {lhs, rhs} => | |
509 | seq [str "datatype ", Tycon.layout lhs, | |
510 | str " = datatype ", Longtycon.layout rhs] | |
511 | ||
512 | fun checkSyntax (rhs: t, datBindCheckSyntax) = | |
513 | case node rhs of | |
514 | DatBind b => datBindCheckSyntax b | |
515 | | Repl _ => () | |
516 | fun checkSyntaxDef rhs = checkSyntax (rhs, DatBind.checkSyntaxDef) | |
517 | fun checkSyntaxSpec rhs = checkSyntax (rhs, DatBind.checkSyntaxSpec) | |
518 | end | |
519 | ||
520 | (*---------------------------------------------------*) | |
521 | (* ModIdBind *) | |
522 | (*---------------------------------------------------*) | |
523 | ||
524 | structure ModIdBind = | |
525 | struct | |
526 | datatype node = | |
527 | Fct of {lhs: Fctid.t, rhs: Fctid.t} vector | |
528 | | Sig of {lhs: Sigid.t, rhs: Sigid.t} vector | |
529 | | Str of {lhs: Strid.t, rhs: Strid.t} vector | |
530 | ||
531 | open Wrap | |
532 | type t = node Wrap.t | |
533 | type node' = node | |
534 | type obj = t | |
535 | ||
536 | fun layout d = | |
537 | let | |
538 | fun doit (prefix, l, bds) = | |
539 | layoutAndsBind | |
540 | (prefix, "=", bds, fn {lhs, rhs} => (OneLine, l lhs, l rhs)) | |
541 | in | |
542 | case node d of | |
543 | Fct bds => doit ("functor", Fctid.layout, bds) | |
544 | | Sig bds => doit ("signature", Sigid.layout, bds) | |
545 | | Str bds => doit ("structure", Strid.layout, bds) | |
546 | end | |
547 | ||
548 | fun checkSyntax d = | |
549 | let | |
550 | fun doit (bds : {lhs: 'a, rhs: 'a} Vector.t, | |
551 | {equalsId, layoutId, regionId, name}) = | |
552 | reportDuplicates | |
553 | (bds, {ctxt = mkCtxt (d, layout), | |
554 | equals = (fn ({lhs = id, ...}, {lhs = id', ...}) => | |
555 | equalsId (id, id')), | |
556 | layout = layoutId o #lhs, | |
557 | name = concat [name, " definition"], | |
558 | region = regionId o #lhs}) | |
559 | in | |
560 | case node d of | |
561 | Fct bds => doit (bds, {equalsId = Fctid.equals, | |
562 | layoutId = Fctid.layout, | |
563 | regionId = Fctid.region, | |
564 | name = "functor"}) | |
565 | | Sig bds => doit (bds, {equalsId = Sigid.equals, | |
566 | layoutId = Sigid.layout, | |
567 | regionId = Sigid.region, | |
568 | name = "signature"}) | |
569 | | Str bds => doit (bds, {equalsId = Strid.equals, | |
570 | layoutId = Strid.layout, | |
571 | regionId = Strid.region, | |
572 | name = "structure"}) | |
573 | end | |
574 | end | |
575 | ||
576 | end |