Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 2009,2012,2015,2017 Matthew Fluet. |
2 | * Copyright (C) 1999-2008 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 AstCore (S: AST_CORE_STRUCTS): AST_CORE = | |
11 | struct | |
12 | ||
13 | open S Layout | |
14 | ||
15 | structure Field = Record.Field | |
16 | structure Wrap = Region.Wrap | |
17 | ||
18 | structure Fixity = | |
19 | struct | |
20 | datatype t = | |
21 | Infix of int option | |
22 | | Infixr of int option | |
23 | | Nonfix | |
24 | ||
25 | val toString = | |
26 | fn Infix NONE => "infix" | |
27 | | Infix (SOME n) => "infix " ^ Int.toString n | |
28 | | Infixr NONE => "infixr" | |
29 | | Infixr (SOME n) => "infixr " ^ Int.toString n | |
30 | | Nonfix => "nonfix" | |
31 | ||
32 | val layout = Layout.str o toString | |
33 | end | |
34 | ||
35 | structure Fixop = | |
36 | struct | |
37 | datatype t = Op | None | |
38 | ||
39 | val layout = | |
40 | fn Op => str "op " | |
41 | | None => empty | |
42 | end | |
43 | ||
44 | fun mkCtxt (x, lay) () = | |
45 | seq [str "in: ", lay x] | |
46 | ||
47 | fun layoutConstraint (t, ty) = | |
48 | mayAlign [seq [t, str ":"], Type.layout ty] | |
49 | ||
50 | fun maybeConstrain (e, tyo) = | |
51 | case tyo of | |
52 | NONE => e | |
53 | | SOME ty => layoutConstraint (e, ty) | |
54 | ||
55 | fun layoutLongvid x = | |
56 | str (let val s = Longvid.toString x | |
57 | in if s = "*" then " * " | |
58 | else if String.hasSuffix (s, {suffix = "*"}) | |
59 | then s ^ " " | |
60 | else s | |
61 | end) | |
62 | ||
63 | (*---------------------------------------------------*) | |
64 | (* Patterns *) | |
65 | (*---------------------------------------------------*) | |
66 | ||
67 | structure Pat = | |
68 | struct | |
69 | open Wrap | |
70 | datatype node = | |
71 | App of Longcon.t * t | |
72 | | Const of Const.t | |
73 | | Constraint of t * Type.t | |
74 | | FlatApp of t vector | |
75 | | Layered of {fixop: Fixop.t, | |
76 | var: Var.t, | |
77 | constraint: Type.t option, | |
78 | pat: t} | |
79 | | List of t vector | |
80 | | Or of t vector | |
81 | | Paren of t | |
82 | | Record of {flexible: bool, | |
83 | items: (Record.Field.t * Region.t * item) vector} | |
84 | | Tuple of t vector | |
85 | | Var of {fixop: Fixop.t, name: Longvid.t} | |
86 | | Vector of t vector | |
87 | | Wild | |
88 | and item = | |
89 | Field of t | |
90 | | Vid of Vid.t * Type.t option * t option | |
91 | withtype t = node Wrap.t | |
92 | type node' = node | |
93 | type obj = t | |
94 | ||
95 | structure Item = | |
96 | struct | |
97 | type pat = t | |
98 | datatype t = datatype item | |
99 | end | |
100 | ||
101 | fun make n = makeRegion (n, Region.bogus) | |
102 | ||
103 | val wild = make Wild | |
104 | val constraint = make o Constraint | |
105 | val layered = make o Layered | |
106 | ||
107 | fun longvid x = make (Var {name = x, fixop = Fixop.None}) | |
108 | val var = longvid o Longvid.short o Vid.fromVar | |
109 | ||
110 | fun tuple ps = | |
111 | if 1 = Vector.length ps | |
112 | then Vector.first ps | |
113 | else makeRegion (Tuple ps, | |
114 | Region.append | |
115 | (region (Vector.first ps), | |
116 | region (Vector.last ps))) | |
117 | ||
118 | fun layout (p, isDelimited) = | |
119 | let | |
120 | fun delimit t = if isDelimited then t else paren t | |
121 | in | |
122 | case node p of | |
123 | App (c, p) => delimit (mayAlign [Longcon.layout c, | |
124 | layoutF p]) | |
125 | | Const c => Const.layout c | |
126 | | Constraint (p, t) => delimit (layoutConstraint (layoutF p, t)) | |
127 | | FlatApp ps => | |
128 | if Vector.length ps = 1 | |
129 | then layout (Vector.first ps, isDelimited) | |
130 | else delimit (layoutFlatApp ps) | |
131 | | Layered {fixop, var, constraint, pat} => | |
132 | delimit | |
133 | (mayAlign [maybeConstrain | |
134 | (seq [Fixop.layout fixop, Var.layout var], | |
135 | constraint), | |
136 | seq [str "as ", layoutT pat]]) | |
137 | | List ps => list (Vector.toListMap (ps, layoutT)) | |
138 | | Or ps => | |
139 | delimit | |
140 | (mayAlign (separateLeft (Vector.toListMap (ps, layoutT), "| "))) | |
141 | | Paren p => layout (p, isDelimited) | |
142 | | Record {items, flexible} => | |
143 | seq [str "{", | |
144 | mayAlign (separateRight | |
145 | (Vector.toListMap (items, layoutItem), ",")), | |
146 | if flexible | |
147 | then str (if Vector.isEmpty items | |
148 | then "..." | |
149 | else ", ...") | |
150 | else empty, | |
151 | str "}"] | |
152 | | Tuple ps => Layout.tuple (Vector.toListMap (ps, layoutT)) | |
153 | | Var {name, fixop} => seq [Fixop.layout fixop, layoutLongvid name] | |
154 | | Vector ps => vector (Vector.map (ps, layoutT)) | |
155 | | Wild => str "_" | |
156 | end | |
157 | and layoutF p = layout (p, false) | |
158 | and layoutT p = layout (p, true) | |
159 | and layoutFlatApp ps = seq (separate (Vector.toListMap (ps, layoutF), " ")) | |
160 | and layoutItem (f, _, i) = | |
161 | seq [Field.layout f, | |
162 | case i of | |
163 | Field p => seq [str " = ", layoutT p] | |
164 | | Vid (_, tyo, po) => | |
165 | seq [case tyo of | |
166 | NONE => empty | |
167 | | SOME ty => seq [str ": ", Type.layout ty], | |
168 | case po of | |
169 | NONE => empty | |
170 | | SOME p => seq [str " as ", layoutT p]]] | |
171 | ||
172 | val layout = layoutT | |
173 | ||
174 | fun checkSyntax (p: t): unit = | |
175 | let | |
176 | val c = checkSyntax | |
177 | in | |
178 | case node p of | |
179 | App (_, p) => c p | |
180 | | Const _ => () | |
181 | | Constraint (p, t) => (c p; Type.checkSyntax t) | |
182 | | FlatApp ps => Vector.foreach (ps, c) | |
183 | | Layered {constraint, pat, ...} => | |
184 | (c pat; Option.app (constraint, Type.checkSyntax)) | |
185 | | List ps => Vector.foreach (ps, c) | |
186 | | Paren p => c p | |
187 | | Or ps => Vector.foreach (ps, c) | |
188 | | Record {items, ...} => | |
189 | (reportDuplicateFields (Vector.map (items, fn (f, r, i) => (f, (r, i))), | |
190 | {ctxt = mkCtxt (p, layout)}) | |
191 | ; Vector.foreach (items, fn (_, _, i) => | |
192 | case i of | |
193 | Item.Field p => c p | |
194 | | Item.Vid (_, to, po) => | |
195 | (Option.app (to, Type.checkSyntax) | |
196 | ; Option.app (po, c)))) | |
197 | | Tuple ps => Vector.foreach (ps, c) | |
198 | | Var _ => () | |
199 | | Vector ps => Vector.foreach (ps, c) | |
200 | | Wild => () | |
201 | end | |
202 | end | |
203 | ||
204 | structure Eb = | |
205 | struct | |
206 | structure Rhs = | |
207 | struct | |
208 | open Wrap | |
209 | datatype node = | |
210 | Def of Longcon.t | |
211 | | Gen of Type.t option | |
212 | type t = node Wrap.t | |
213 | type node' = node | |
214 | type obj = t | |
215 | ||
216 | fun layout rhs = | |
217 | case node rhs of | |
218 | Def c => seq [str " = ", Longcon.layout c] | |
219 | | Gen to => Type.layoutOption to | |
220 | ||
221 | fun checkSyntax (e: t): unit = | |
222 | case node e of | |
223 | Def _ => () | |
224 | | Gen to => Option.app (to, Type.checkSyntax) | |
225 | end | |
226 | ||
227 | type t = Con.t * Rhs.t | |
228 | ||
229 | fun layout (exn, rhs) = | |
230 | seq [Con.layout exn, Rhs.layout rhs] | |
231 | end | |
232 | ||
233 | structure EbRhs = Eb.Rhs | |
234 | ||
235 | structure PrimKind = | |
236 | struct | |
237 | structure ImportExportAttribute = | |
238 | struct | |
239 | datatype t = Cdecl | External | Impure | Private | Public | Pure | Reentrant | Runtime | Stdcall | |
240 | ||
241 | val toString: t -> string = | |
242 | fn Cdecl => "cdecl" | |
243 | | External => "external" | |
244 | | Impure => "impure" | |
245 | | Private => "private" | |
246 | | Public => "public" | |
247 | | Pure => "pure" | |
248 | | Reentrant => "reentrant" | |
249 | | Runtime => "runtime" | |
250 | | Stdcall => "stdcall" | |
251 | ||
252 | val layout = Layout.str o toString | |
253 | end | |
254 | ||
255 | structure SymbolAttribute = | |
256 | struct | |
257 | datatype t = Alloc | External | Private | Public | |
258 | ||
259 | val toString: t -> string = | |
260 | fn Alloc => "alloc" | |
261 | | External => "external" | |
262 | | Private => "private" | |
263 | | Public => "public" | |
264 | ||
265 | val layout = Layout.str o toString | |
266 | end | |
267 | ||
268 | datatype t = | |
269 | Address of {attributes: SymbolAttribute.t list, | |
270 | name: string, | |
271 | ty: Type.t} | |
272 | | BuildConst of {name: string, | |
273 | ty: Type.t} | |
274 | | CommandLineConst of {name: string, | |
275 | ty: Type.t, | |
276 | value: Const.t} | |
277 | | Const of {name: string, | |
278 | ty: Type.t} | |
279 | | Export of {attributes: ImportExportAttribute.t list, | |
280 | name: string, | |
281 | ty: Type.t} | |
282 | | IImport of {attributes: ImportExportAttribute.t list, | |
283 | ty: Type.t} | |
284 | | Import of {attributes: ImportExportAttribute.t list, | |
285 | name: string, | |
286 | ty: Type.t} | |
287 | | ISymbol of {ty: Type.t} | |
288 | | Prim of {name: string, | |
289 | ty: Type.t} | |
290 | | Symbol of {attributes: SymbolAttribute.t list, | |
291 | name: string, | |
292 | ty: Type.t} | |
293 | ||
294 | fun name pk = | |
295 | case pk of | |
296 | Address {name, ...} => name | |
297 | | BuildConst {name, ...} => name | |
298 | | CommandLineConst {name, ...} => name | |
299 | | Const {name, ...} => name | |
300 | | Export {name, ...} => name | |
301 | | IImport {...} => "<iimport>" | |
302 | | Import {name, ...} => name | |
303 | | ISymbol {...} => "<isymbol>" | |
304 | | Prim {name, ...} => name | |
305 | | Symbol {name, ...} => name | |
306 | end | |
307 | ||
308 | structure Priority = | |
309 | struct | |
310 | datatype t = T of int option | |
311 | val op <= = fn (T x, T y) => | |
312 | case (x, y) of | |
313 | (NONE, NONE) => true | |
314 | | (NONE, _) => true | |
315 | | (_, NONE) => false | |
316 | | (SOME x, SOME y) => Int.<= (x, y) | |
317 | val default = T NONE | |
318 | fun layout (T x) = | |
319 | case x of | |
320 | NONE => Layout.empty | |
321 | | SOME x => Int.layout x | |
322 | end | |
323 | ||
324 | datatype expNode = | |
325 | Andalso of exp * exp | |
326 | | App of exp * exp | |
327 | | Case of exp * match | |
328 | | Const of Const.t | |
329 | | Constraint of exp * Type.t | |
330 | | FlatApp of exp vector | |
331 | | Fn of match | |
332 | | Handle of exp * match | |
333 | | If of exp * exp * exp | |
334 | | Let of dec * exp | |
335 | | List of exp vector | |
336 | | Orelse of exp * exp | |
337 | | Paren of exp | |
338 | | Prim of PrimKind.t | |
339 | | Raise of exp | |
340 | | Record of (Region.t * exp) Record.t | |
341 | | Selector of Field.t | |
342 | | Seq of exp vector | |
343 | | Var of {name: Longvid.t, fixop: Fixop.t} | |
344 | | Vector of exp vector | |
345 | | While of {test: exp, expr: exp} | |
346 | and decNode = | |
347 | Abstype of {body: dec, | |
348 | datBind: DatBind.t} | |
349 | | Datatype of DatatypeRhs.t | |
350 | | DoDec of exp | |
351 | | Exception of Eb.t vector | |
352 | | Fix of {fixity: Fixity.t, | |
353 | ops: Vid.t vector} | |
354 | | Fun of {tyvars: Tyvar.t vector, | |
355 | fbs: {body: exp, | |
356 | pats: Pat.t vector, | |
357 | resultType: Type.t option} vector vector} | |
358 | | Local of dec * dec | |
359 | | Open of Longstrid.t vector | |
360 | | Overload of Priority.t * Var.t * | |
361 | Tyvar.t vector * Type.t * | |
362 | Longvid.t vector | |
363 | | SeqDec of dec vector | |
364 | | Type of TypBind.t | |
365 | | Val of {tyvars: Tyvar.t vector, | |
366 | vbs: {exp: exp, | |
367 | pat: Pat.t} vector, | |
368 | rvbs: {match: match, | |
369 | pat: Pat.t} vector} | |
370 | and matchNode = T of (Pat.t * exp) vector | |
371 | withtype | |
372 | dec = decNode Wrap.t | |
373 | and exp = expNode Wrap.t | |
374 | and match = matchNode Wrap.t | |
375 | ||
376 | open Wrap | |
377 | ||
378 | structure Match = | |
379 | struct | |
380 | open Wrap | |
381 | type t = match | |
382 | datatype node = datatype matchNode | |
383 | type node' = node | |
384 | type obj = t | |
385 | end | |
386 | ||
387 | fun layoutTyvarsAndsSusp (prefix, (tyvars, xs), layoutX) = | |
388 | layoutAndsSusp | |
389 | (prefix, xs, fn (first, prefix, x) => | |
390 | if first andalso not (Vector.isEmpty tyvars) | |
391 | then seq [prefix, | |
392 | case Vector.length tyvars of | |
393 | 1 => Tyvar.layout (Vector.sub (tyvars, 0)) | |
394 | | _ => Layout.tuple (Vector.toListMap (tyvars, Tyvar.layout)), | |
395 | str " ", | |
396 | layoutX x] | |
397 | else seq [prefix, layoutX x]) | |
398 | ||
399 | fun expNodeName e = | |
400 | case node e of | |
401 | Andalso _ => "Andalso" | |
402 | | App _ => "App" | |
403 | | Case _ => "Case" | |
404 | | Const _ => "Const" | |
405 | | Constraint _ => "Constraint" | |
406 | | FlatApp _ => "FlatApp" | |
407 | | Fn _ => "Fn" | |
408 | | Handle _ => "Handle" | |
409 | | If _ => "If" | |
410 | | Let _ => "Let" | |
411 | | List _ => "List" | |
412 | | Orelse _ => "Orelse" | |
413 | | Paren _ => "Paren" | |
414 | | Prim _ => "Prim" | |
415 | | Raise _ => "Raise" | |
416 | | Record _ => "Record" | |
417 | | Selector _ => "Selector" | |
418 | | Seq _ => "Seq" | |
419 | | Var _ => "Var" | |
420 | | Vector _ => "Vector" | |
421 | | While _ => "While" | |
422 | ||
423 | val traceLayoutExp = | |
424 | Trace.traceInfo' (Trace.info "AstCore.layoutExp", | |
425 | fn (e, _: bool) => Layout.str (expNodeName e), | |
426 | Layout.ignore: Layout.t -> Layout.t) | |
427 | ||
428 | fun layoutExp arg = | |
429 | traceLayoutExp | |
430 | (fn (e, isDelimited) => | |
431 | let | |
432 | fun delimit t = if isDelimited then t else paren t | |
433 | in | |
434 | case node e of | |
435 | Andalso (e, e') => | |
436 | delimit (mayAlign [layoutExpF e, | |
437 | seq [str "andalso ", layoutExpF e']]) | |
438 | | App (function, argument) => | |
439 | delimit (mayAlign [layoutExpF function, layoutExpF argument]) | |
440 | | Case (expr, match) => | |
441 | delimit (align [seq [str "case ", layoutExpT expr, | |
442 | str " of"], | |
443 | indent (layoutMatch match, 2)]) | |
444 | | Const c => Const.layout c | |
445 | | Constraint (expr, constraint) => | |
446 | delimit (layoutConstraint (layoutExpF expr, constraint)) | |
447 | | FlatApp es => | |
448 | if Vector.length es = 1 | |
449 | then layoutExp (Vector.first es, isDelimited) | |
450 | else delimit (seq (separate (Vector.toListMap (es, layoutExpF), " "))) | |
451 | | Fn m => delimit (seq [str "fn ", layoutMatch m]) | |
452 | | Handle (try, match) => | |
453 | delimit (align [layoutExpF try, | |
454 | seq [str "handle ", layoutMatch match]]) | |
455 | | If (test, thenCase, elseCase) => | |
456 | delimit (mayAlign [seq [str "if ", layoutExpT test], | |
457 | seq [str "then ", layoutExpT thenCase], | |
458 | seq [str "else ", layoutExpT elseCase]]) | |
459 | | Let (dec, expr) => Pretty.lett (layoutDec dec, layoutExpT expr) | |
460 | | List es => list (Vector.toListMap (es, layoutExpT)) | |
461 | | Orelse (e, e') => | |
462 | delimit (mayAlign [layoutExpF e, | |
463 | seq [str "orelse ", layoutExpF e']]) | |
464 | | Paren e => layoutExp (e, isDelimited) | |
465 | | Prim kind => str (PrimKind.name kind) | |
466 | | Raise exn => delimit (seq [str "raise ", layoutExpF exn]) | |
467 | | Record r => | |
468 | let | |
469 | fun layoutTuple es = | |
470 | if 1 = Vector.length es | |
471 | then layoutExp (Vector.first es, isDelimited) | |
472 | else tuple (layoutExpsT es) | |
473 | in | |
474 | Record.layout {record = r, | |
475 | separator = " = ", | |
476 | extra = "", | |
477 | layoutTuple = fn res => layoutTuple (Vector.map (res, #2)), | |
478 | layoutElt = layoutExpT o #2} | |
479 | end | |
480 | | Selector f => seq [str "#", Field.layout f] | |
481 | | Seq es => paren (align (separateRight (layoutExpsT es, " ;"))) | |
482 | | Var {name, fixop} => seq [Fixop.layout fixop, layoutLongvid name] | |
483 | | Vector es => vector (Vector.map (es, layoutExpT)) | |
484 | | While {test, expr} => | |
485 | delimit (align [seq [str "while ", layoutExpT test], | |
486 | seq [str "do ", layoutExpT expr]]) | |
487 | end) arg | |
488 | and layoutExpsT es = Vector.toListMap (es, layoutExpT) | |
489 | and layoutExpT e = layoutExp (e, true) | |
490 | and layoutExpF e = layoutExp (e, false) | |
491 | ||
492 | and layoutMatch m = | |
493 | let | |
494 | val Match.T rules = node m | |
495 | in | |
496 | alignPrefix (Vector.toListMap (rules, layoutRule), "| ") | |
497 | end | |
498 | ||
499 | and layoutRule (pat, exp) = | |
500 | mayAlign [seq [Pat.layoutT pat, str " =>"], | |
501 | layoutExpF exp] | |
502 | ||
503 | and layoutDec d = | |
504 | case node d of | |
505 | Abstype {datBind, body} => | |
506 | align [DatBind.layout ("abstype", datBind), | |
507 | seq [str "with ", layoutDec body], | |
508 | str "end"] | |
509 | | Datatype rhs => DatatypeRhs.layout rhs | |
510 | | DoDec exp => seq [str "do ", layoutExpT exp] | |
511 | | Exception ebs => | |
512 | layoutAnds ("exception", ebs, | |
513 | fn (prefix, eb) => seq [prefix, Eb.layout eb]) | |
514 | | Fix {fixity, ops} => | |
515 | seq [Fixity.layout fixity, str " ", | |
516 | seq (separate (Vector.toListMap (ops, Vid.layout), " "))] | |
517 | | Fun {tyvars, fbs} => | |
518 | let | |
519 | val fbs = layoutFun {tyvars = tyvars, fbs = fbs} | |
520 | in | |
521 | align (Vector.toListMap (fbs, fn th => th ())) | |
522 | end | |
523 | | Local (d, d') => Pretty.locall (layoutDec d, layoutDec d') | |
524 | | Open ss => seq [str "open ", | |
525 | seq (separate (Vector.toListMap (ss, Longstrid.layout), | |
526 | " "))] | |
527 | | Overload (p, x, _, t, xs) => | |
528 | seq [str "_overload ", Priority.layout p, str " ", | |
529 | align [layoutConstraint (Var.layout x, t), | |
530 | layoutAnds ("as", xs, fn (prefix, x) => | |
531 | seq [prefix, Longvid.layout x])]] | |
532 | | SeqDec ds => align (Vector.toListMap (ds, layoutDec)) | |
533 | | Type typBind => TypBind.layout typBind | |
534 | | Val {tyvars, vbs, rvbs} => | |
535 | let | |
536 | val {vbs, rvbs} = | |
537 | layoutVal {tyvars = tyvars, vbs = vbs, rvbs = rvbs} | |
538 | in | |
539 | align [align (Vector.toListMap (vbs, fn th => th ())), | |
540 | align (Vector.toListMap (rvbs, fn th => th ()))] | |
541 | end | |
542 | ||
543 | and layoutFun {tyvars, fbs} = | |
544 | layoutTyvarsAndsSusp ("fun", (tyvars, fbs), layoutFb) | |
545 | ||
546 | and layoutFb clauses = | |
547 | alignPrefix (Vector.toListMap (clauses, layoutClause), "| ") | |
548 | ||
549 | and layoutClause ({pats, resultType, body}) = | |
550 | mayAlign [seq [maybeConstrain (Pat.layoutFlatApp pats, | |
551 | resultType), | |
552 | str " ="], | |
553 | layoutExpF body] (* this has to be layoutExpF in case body | |
554 | is a case expression *) | |
555 | ||
556 | and layoutVal {tyvars, vbs, rvbs} = | |
557 | if Vector.isEmpty rvbs | |
558 | then {vbs = layoutTyvarsAndsSusp ("val", (tyvars, vbs), layoutVb), | |
559 | rvbs = Vector.new0 ()} | |
560 | else if Vector.isEmpty vbs | |
561 | then {vbs = Vector.new0 (), | |
562 | rvbs = layoutTyvarsAndsSusp ("val rec", (tyvars, rvbs), layoutRvb)} | |
563 | else {vbs = layoutTyvarsAndsSusp ("val", (tyvars, vbs), layoutVb), | |
564 | rvbs = layoutTyvarsAndsSusp ("and rec", (Vector.new0 (), rvbs), layoutRvb)} | |
565 | ||
566 | and layoutVb {pat, exp} = | |
567 | bind (Pat.layoutT pat, layoutExpT exp) | |
568 | ||
569 | and layoutRvb {pat, match, ...} = | |
570 | bind (Pat.layout pat, seq [str "fn ", layoutMatch match]) | |
571 | ||
572 | fun checkSyntaxExp (e: exp): unit = | |
573 | let | |
574 | val c = checkSyntaxExp | |
575 | in | |
576 | case node e of | |
577 | Andalso (e1, e2) => (c e1; c e2) | |
578 | | App (e1, e2) => (c e1; c e2) | |
579 | | Case (e, m) => (c e; checkSyntaxMatch m) | |
580 | | Const _ => () | |
581 | | Constraint (e, t) => (c e; Type.checkSyntax t) | |
582 | | FlatApp es => Vector.foreach (es, c) | |
583 | | Fn m => checkSyntaxMatch m | |
584 | | Handle (e, m) => (c e; checkSyntaxMatch m) | |
585 | | If (e1, e2, e3) => (c e1; c e2; c e3) | |
586 | | Let (d, e) => (checkSyntaxDec d; c e) | |
587 | | List es => Vector.foreach (es, c) | |
588 | | Orelse (e1, e2) => (c e1; c e2) | |
589 | | Paren e => c e | |
590 | | Prim _ => () | |
591 | | Raise e => c e | |
592 | | Record r => | |
593 | (reportDuplicateFields (Record.toVector r, | |
594 | {ctxt = mkCtxt (e, layoutExpT)}) | |
595 | ; Record.foreach (r, c o #2)) | |
596 | | Selector _ => () | |
597 | | Seq es => Vector.foreach (es, c) | |
598 | | Var _ => () | |
599 | | Vector es => Vector.foreach (es, c) | |
600 | | While {expr, test} => (c expr; c test) | |
601 | end | |
602 | ||
603 | and checkSyntaxMatch (m: match): unit = | |
604 | let | |
605 | val T v = node m | |
606 | in | |
607 | Vector.foreach (v, fn (p, e) => (Pat.checkSyntax p; checkSyntaxExp e)) | |
608 | end | |
609 | ||
610 | and checkSyntaxDec (d: dec): unit = | |
611 | case node d of | |
612 | Abstype {datBind, body} => | |
613 | (DatBind.checkSyntaxDef datBind | |
614 | ; checkSyntaxDec body) | |
615 | | Datatype rhs => DatatypeRhs.checkSyntaxDef rhs | |
616 | | DoDec exp => checkSyntaxExp exp | |
617 | | Exception v => | |
618 | (Vector.foreach | |
619 | (v, fn (con, ebrhs) => | |
620 | (Vid.checkRedefineSpecial | |
621 | (Vid.fromCon con, | |
622 | {allowIt = false, | |
623 | ctxt = mkCtxt (d, layoutDec), | |
624 | keyword = "exception"}) | |
625 | ; EbRhs.checkSyntax ebrhs)) | |
626 | ; (reportDuplicates | |
627 | (v, {ctxt = mkCtxt (d, layoutDec), | |
628 | equals = fn ((c, _), (c', _)) => Con.equals (c, c'), | |
629 | layout = Con.layout o #1, | |
630 | name = "exception definition", | |
631 | region = Con.region o #1}))) | |
632 | | Fix _ => () (* The Definition allows, e.g., "infix + +". *) | |
633 | | Fun {tyvars, fbs, ...} => | |
634 | (reportDuplicateTyvars (tyvars, | |
635 | {ctxt = mkCtxt (d, layoutDec)}) | |
636 | ; Vector.foreach (fbs, fn clauses => | |
637 | Vector.foreach | |
638 | (clauses, fn {body, pats, resultType} => | |
639 | (checkSyntaxExp body | |
640 | ; Vector.foreach (pats, Pat.checkSyntax) | |
641 | ; Option.app (resultType, Type.checkSyntax))))) | |
642 | | Local (d, d') => (checkSyntaxDec d; checkSyntaxDec d') | |
643 | | Open _ => () | |
644 | | Overload (_, _, _, ty, _) => Type.checkSyntax ty | |
645 | | SeqDec v => Vector.foreach (v, checkSyntaxDec) | |
646 | | Type b => TypBind.checkSyntaxDef b | |
647 | | Val {tyvars, rvbs, vbs, ...} => | |
648 | (reportDuplicateTyvars (tyvars, | |
649 | {ctxt = mkCtxt (d, layoutDec)}) | |
650 | ; Vector.foreach (rvbs, fn {match, pat} => | |
651 | (checkSyntaxMatch match | |
652 | ; Pat.checkSyntax pat)) | |
653 | ; Vector.foreach (vbs, fn {exp, pat} => | |
654 | (checkSyntaxExp exp | |
655 | ; Pat.checkSyntax pat))) | |
656 | ||
657 | structure Exp = | |
658 | struct | |
659 | open Wrap | |
660 | type dec = dec | |
661 | type match = match | |
662 | type t = exp | |
663 | datatype node = datatype expNode | |
664 | type node' = node | |
665 | type obj = t | |
666 | ||
667 | fun const c = makeRegion (Const c, Const.region c) | |
668 | ||
669 | fun constraint (e, t) = makeRegion (Constraint (e, t), region e) | |
670 | ||
671 | fun fnn rs = | |
672 | let | |
673 | val r = | |
674 | if Vector.isEmpty rs | |
675 | then Region.bogus | |
676 | else Region.append (Pat.region (#1 (Vector.first rs)), | |
677 | region (#2 (Vector.last rs))) | |
678 | in | |
679 | makeRegion (Fn (Match.makeRegion (Match.T rs, r)), r) | |
680 | end | |
681 | ||
682 | fun longvid name = | |
683 | makeRegion (Var {name = name, fixop = Fixop.None}, | |
684 | Longvid.region name) | |
685 | ||
686 | val var = longvid o Longvid.short o Vid.fromVar | |
687 | ||
688 | fun app (e1: t, e2: t): t = | |
689 | makeRegion (App (e1, e2), | |
690 | Region.append (region e1, region e2)) | |
691 | ||
692 | fun lett (ds: dec vector, e: t, r: Region.t): t = | |
693 | makeRegion (Let (makeRegion (SeqDec ds, r), e), r) | |
694 | ||
695 | fun tuple (es: t vector): t = | |
696 | if 1 = Vector.length es | |
697 | then Vector.first es | |
698 | else | |
699 | let | |
700 | val r = | |
701 | if Vector.isEmpty es | |
702 | then Region.bogus | |
703 | else Region.append (region (Vector.first es), | |
704 | region (Vector.last es)) | |
705 | val res = | |
706 | Vector.map (es, fn e => (Region.bogus, e)) | |
707 | in | |
708 | makeRegion (Record (Record.tuple res), r) | |
709 | end | |
710 | ||
711 | val unit: t = tuple (Vector.new0 ()) | |
712 | ||
713 | val layout = layoutExpT | |
714 | end | |
715 | ||
716 | structure Match = | |
717 | struct | |
718 | open Match | |
719 | val layout = layoutMatch | |
720 | val layoutRule = layoutRule | |
721 | end | |
722 | ||
723 | structure Dec = | |
724 | struct | |
725 | open Wrap | |
726 | type t = dec | |
727 | datatype node = datatype decNode | |
728 | type node' = node | |
729 | type obj = t | |
730 | ||
731 | val checkSyntax = checkSyntaxDec | |
732 | ||
733 | fun make n = makeRegion (n, Region.bogus) | |
734 | ||
735 | val openn = make o Open | |
736 | ||
737 | fun vall (tyvars, var, exp): t = | |
738 | make (Val {tyvars = tyvars, | |
739 | vbs = Vector.new1 {exp = exp, pat = Pat.var var}, | |
740 | rvbs = Vector.new0 ()}) | |
741 | ||
742 | local | |
743 | val it = Var.fromSymbol (Symbol.fromString "it", Region.bogus) | |
744 | in | |
745 | fun fromExp (e: Exp.t): t = | |
746 | vall (Vector.new0 (), it, e) | |
747 | end | |
748 | ||
749 | val layout = layoutDec | |
750 | val layoutFun = layoutFun | |
751 | val layoutVal = layoutVal | |
752 | end | |
753 | ||
754 | end |