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.
6 * MLton is released under a BSD-style license.
7 * See the file MLton-LICENSE for details.
10 functor AstCore (S: AST_CORE_STRUCTS): AST_CORE =
15 structure Field = Record.Field
16 structure Wrap = Region.Wrap
22 | Infixr of int option
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
32 val layout = Layout.str o toString
37 datatype t = Op | None
44 fun mkCtxt (x, lay) () =
45 seq [str "in: ", lay x]
47 fun layoutConstraint (t, ty) =
48 mayAlign [seq [t, str ":"], Type.layout ty]
50 fun maybeConstrain (e, tyo) =
53 | SOME ty => layoutConstraint (e, ty)
56 str (let val s = Longvid.toString x
57 in if s = "*" then " * "
58 else if String.hasSuffix (s, {suffix = "*"})
63 (*---------------------------------------------------*)
65 (*---------------------------------------------------*)
73 | Constraint of t * Type.t
75 | Layered of {fixop: Fixop.t,
77 constraint: Type.t option,
82 | Record of {flexible: bool,
83 items: (Record.Field.t * Region.t * item) vector}
85 | Var of {fixop: Fixop.t, name: Longvid.t}
90 | Vid of Vid.t * Type.t option * t option
91 withtype t = node Wrap.t
98 datatype t = datatype item
101 fun make n = makeRegion (n, Region.bogus)
104 val constraint = make o Constraint
105 val layered = make o Layered
107 fun longvid x = make (Var {name = x, fixop = Fixop.None})
108 val var = longvid o Longvid.short o Vid.fromVar
111 if 1 = Vector.length ps
113 else makeRegion (Tuple ps,
115 (region (Vector.first ps),
116 region (Vector.last ps)))
118 fun layout (p, isDelimited) =
120 fun delimit t = if isDelimited then t else paren t
123 App (c, p) => delimit (mayAlign [Longcon.layout c,
125 | Const c => Const.layout c
126 | Constraint (p, t) => delimit (layoutConstraint (layoutF p, t))
128 if Vector.length ps = 1
129 then layout (Vector.first ps, isDelimited)
130 else delimit (layoutFlatApp ps)
131 | Layered {fixop, var, constraint, pat} =>
133 (mayAlign [maybeConstrain
134 (seq [Fixop.layout fixop, Var.layout var],
136 seq [str "as ", layoutT pat]])
137 | List ps => list (Vector.toListMap (ps, layoutT))
140 (mayAlign (separateLeft (Vector.toListMap (ps, layoutT), "| ")))
141 | Paren p => layout (p, isDelimited)
142 | Record {items, flexible} =>
144 mayAlign (separateRight
145 (Vector.toListMap (items, layoutItem), ",")),
147 then str (if Vector.isEmpty items
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))
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) =
163 Field p => seq [str " = ", layoutT p]
164 | Vid (_, tyo, po) =>
167 | SOME ty => seq [str ": ", Type.layout ty],
170 | SOME p => seq [str " as ", layoutT p]]]
174 fun checkSyntax (p: t): unit =
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)
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) =>
194 | Item.Vid (_, to, po) =>
195 (Option.app (to, Type.checkSyntax)
196 ; Option.app (po, c))))
197 | Tuple ps => Vector.foreach (ps, c)
199 | Vector ps => Vector.foreach (ps, c)
211 | Gen of Type.t option
218 Def c => seq [str " = ", Longcon.layout c]
219 | Gen to => Type.layoutOption to
221 fun checkSyntax (e: t): unit =
224 | Gen to => Option.app (to, Type.checkSyntax)
227 type t = Con.t * Rhs.t
229 fun layout (exn, rhs) =
230 seq [Con.layout exn, Rhs.layout rhs]
233 structure EbRhs = Eb.Rhs
237 structure ImportExportAttribute =
239 datatype t = Cdecl | External | Impure | Private | Public | Pure | Reentrant | Runtime | Stdcall
241 val toString: t -> string =
243 | External => "external"
245 | Private => "private"
248 | Reentrant => "reentrant"
249 | Runtime => "runtime"
250 | Stdcall => "stdcall"
252 val layout = Layout.str o toString
255 structure SymbolAttribute =
257 datatype t = Alloc | External | Private | Public
259 val toString: t -> string =
261 | External => "external"
262 | Private => "private"
265 val layout = Layout.str o toString
269 Address of {attributes: SymbolAttribute.t list,
272 | BuildConst of {name: string,
274 | CommandLineConst of {name: string,
277 | Const of {name: string,
279 | Export of {attributes: ImportExportAttribute.t list,
282 | IImport of {attributes: ImportExportAttribute.t list,
284 | Import of {attributes: ImportExportAttribute.t list,
287 | ISymbol of {ty: Type.t}
288 | Prim of {name: string,
290 | Symbol of {attributes: SymbolAttribute.t list,
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
310 datatype t = T of int option
311 val op <= = fn (T x, T y) =>
316 | (SOME x, SOME y) => Int.<= (x, y)
321 | SOME x => Int.layout x
327 | Case of exp * match
329 | Constraint of exp * Type.t
330 | FlatApp of exp vector
332 | Handle of exp * match
333 | If of exp * exp * exp
336 | Orelse of exp * exp
340 | Record of (Region.t * exp) Record.t
341 | Selector of Field.t
343 | Var of {name: Longvid.t, fixop: Fixop.t}
344 | Vector of exp vector
345 | While of {test: exp, expr: exp}
347 Abstype of {body: dec,
349 | Datatype of DatatypeRhs.t
351 | Exception of Eb.t vector
352 | Fix of {fixity: Fixity.t,
354 | Fun of {tyvars: Tyvar.t vector,
357 resultType: Type.t option} vector vector}
359 | Open of Longstrid.t vector
360 | Overload of Priority.t * Var.t *
361 Tyvar.t vector * Type.t *
363 | SeqDec of dec vector
365 | Val of {tyvars: Tyvar.t vector,
370 and matchNode = T of (Pat.t * exp) vector
373 and exp = expNode Wrap.t
374 and match = matchNode Wrap.t
382 datatype node = datatype matchNode
387 fun layoutTyvarsAndsSusp (prefix, (tyvars, xs), layoutX) =
389 (prefix, xs, fn (first, prefix, x) =>
390 if first andalso not (Vector.isEmpty tyvars)
392 case Vector.length tyvars of
393 1 => Tyvar.layout (Vector.sub (tyvars, 0))
394 | _ => Layout.tuple (Vector.toListMap (tyvars, Tyvar.layout)),
397 else seq [prefix, layoutX x])
401 Andalso _ => "Andalso"
405 | Constraint _ => "Constraint"
406 | FlatApp _ => "FlatApp"
408 | Handle _ => "Handle"
412 | Orelse _ => "Orelse"
416 | Record _ => "Record"
417 | Selector _ => "Selector"
420 | Vector _ => "Vector"
424 Trace.traceInfo' (Trace.info "AstCore.layoutExp",
425 fn (e, _: bool) => Layout.str (expNodeName e),
426 Layout.ignore: Layout.t -> Layout.t)
430 (fn (e, isDelimited) =>
432 fun delimit t = if isDelimited then t else paren t
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,
443 indent (layoutMatch match, 2)])
444 | Const c => Const.layout c
445 | Constraint (expr, constraint) =>
446 delimit (layoutConstraint (layoutExpF expr, constraint))
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))
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])
470 if 1 = Vector.length es
471 then layoutExp (Vector.first es, isDelimited)
472 else tuple (layoutExpsT es)
474 Record.layout {record = r,
477 layoutTuple = fn res => layoutTuple (Vector.map (res, #2)),
478 layoutElt = layoutExpT o #2}
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]])
488 and layoutExpsT es = Vector.toListMap (es, layoutExpT)
489 and layoutExpT e = layoutExp (e, true)
490 and layoutExpF e = layoutExp (e, false)
494 val Match.T rules = node m
496 alignPrefix (Vector.toListMap (rules, layoutRule), "| ")
499 and layoutRule (pat, exp) =
500 mayAlign [seq [Pat.layoutT pat, str " =>"],
505 Abstype {datBind, body} =>
506 align [DatBind.layout ("abstype", datBind),
507 seq [str "with ", layoutDec body],
509 | Datatype rhs => DatatypeRhs.layout rhs
510 | DoDec exp => seq [str "do ", layoutExpT exp]
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} =>
519 val fbs = layoutFun {tyvars = tyvars, fbs = fbs}
521 align (Vector.toListMap (fbs, fn th => th ()))
523 | Local (d, d') => Pretty.locall (layoutDec d, layoutDec d')
524 | Open ss => seq [str "open ",
525 seq (separate (Vector.toListMap (ss, Longstrid.layout),
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} =>
537 layoutVal {tyvars = tyvars, vbs = vbs, rvbs = rvbs}
539 align [align (Vector.toListMap (vbs, fn th => th ())),
540 align (Vector.toListMap (rvbs, fn th => th ()))]
543 and layoutFun {tyvars, fbs} =
544 layoutTyvarsAndsSusp ("fun", (tyvars, fbs), layoutFb)
546 and layoutFb clauses =
547 alignPrefix (Vector.toListMap (clauses, layoutClause), "| ")
549 and layoutClause ({pats, resultType, body}) =
550 mayAlign [seq [maybeConstrain (Pat.layoutFlatApp pats,
553 layoutExpF body] (* this has to be layoutExpF in case body
554 is a case expression *)
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)}
566 and layoutVb {pat, exp} =
567 bind (Pat.layoutT pat, layoutExpT exp)
569 and layoutRvb {pat, match, ...} =
570 bind (Pat.layout pat, seq [str "fn ", layoutMatch match])
572 fun checkSyntaxExp (e: exp): unit =
574 val c = checkSyntaxExp
577 Andalso (e1, e2) => (c e1; c e2)
578 | App (e1, e2) => (c e1; c e2)
579 | Case (e, m) => (c e; checkSyntaxMatch m)
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)
593 (reportDuplicateFields (Record.toVector r,
594 {ctxt = mkCtxt (e, layoutExpT)})
595 ; Record.foreach (r, c o #2))
597 | Seq es => Vector.foreach (es, c)
599 | Vector es => Vector.foreach (es, c)
600 | While {expr, test} => (c expr; c test)
603 and checkSyntaxMatch (m: match): unit =
607 Vector.foreach (v, fn (p, e) => (Pat.checkSyntax p; checkSyntaxExp e))
610 and checkSyntaxDec (d: dec): unit =
612 Abstype {datBind, body} =>
613 (DatBind.checkSyntaxDef datBind
614 ; checkSyntaxDec body)
615 | Datatype rhs => DatatypeRhs.checkSyntaxDef rhs
616 | DoDec exp => checkSyntaxExp exp
619 (v, fn (con, ebrhs) =>
620 (Vid.checkRedefineSpecial
623 ctxt = mkCtxt (d, layoutDec),
624 keyword = "exception"})
625 ; EbRhs.checkSyntax ebrhs))
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 =>
638 (clauses, fn {body, pats, resultType} =>
640 ; Vector.foreach (pats, Pat.checkSyntax)
641 ; Option.app (resultType, Type.checkSyntax)))))
642 | Local (d, d') => (checkSyntaxDec d; checkSyntaxDec d')
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} =>
655 ; Pat.checkSyntax pat)))
663 datatype node = datatype expNode
667 fun const c = makeRegion (Const c, Const.region c)
669 fun constraint (e, t) = makeRegion (Constraint (e, t), region e)
676 else Region.append (Pat.region (#1 (Vector.first rs)),
677 region (#2 (Vector.last rs)))
679 makeRegion (Fn (Match.makeRegion (Match.T rs, r)), r)
683 makeRegion (Var {name = name, fixop = Fixop.None},
686 val var = longvid o Longvid.short o Vid.fromVar
688 fun app (e1: t, e2: t): t =
689 makeRegion (App (e1, e2),
690 Region.append (region e1, region e2))
692 fun lett (ds: dec vector, e: t, r: Region.t): t =
693 makeRegion (Let (makeRegion (SeqDec ds, r), e), r)
695 fun tuple (es: t vector): t =
696 if 1 = Vector.length es
703 else Region.append (region (Vector.first es),
704 region (Vector.last es))
706 Vector.map (es, fn e => (Region.bogus, e))
708 makeRegion (Record (Record.tuple res), r)
711 val unit: t = tuple (Vector.new0 ())
713 val layout = layoutExpT
719 val layout = layoutMatch
720 val layoutRule = layoutRule
727 datatype node = datatype decNode
731 val checkSyntax = checkSyntaxDec
733 fun make n = makeRegion (n, Region.bogus)
735 val openn = make o Open
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 ()})
743 val it = Var.fromSymbol (Symbol.fromString "it", Region.bogus)
745 fun fromExp (e: Exp.t): t =
746 vall (Vector.new0 (), it, e)
749 val layout = layoutDec
750 val layoutFun = layoutFun
751 val layoutVal = layoutVal