mlton/ast/ast-core.fun

   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