mlton/core-ml/core-ml.fun

   1 (* Copyright (C) 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 CoreML (S: CORE_ML_STRUCTS): CORE_ML =
  11 struct
  12
  13 open S
  14
  15 structure Field = Record.Field
  16
  17 fun maybeConstrain (x, t) =
  18    let
  19       open Layout
  20    in
  21       if !Control.showTypes
  22          then seq [x, str ": ", Type.layout t]
  23       else x
  24    end
  25
  26 fun layoutTargs (ts: Type.t vector) =
  27    let
  28       open Layout
  29    in
  30       if !Control.showTypes
  31          andalso 0 < Vector.length ts
  32          then list (Vector.toListMap (ts, Type.layout))
  33       else empty
  34    end
  35
  36 structure Pat =
  37    struct
  38       datatype t = T of {node: node,
  39                          ty: Type.t}
  40       and node =
  41          Con of {arg: t option,
  42                  con: Con.t,
  43                  targs: Type.t vector}
  44        | Const of unit -> Const.t
  45        | Layered of Var.t * t
  46        | List of t vector
  47        | Or of t vector
  48        | Record of t Record.t
  49        | Var of Var.t
  50        | Vector of t vector
  51        | Wild
  52
  53       local
  54          fun make f (T r) = f r
  55       in
  56          val dest = make (fn {node, ty} => (node, ty))
  57          val node = make #node
  58          val ty = make #ty
  59       end
  60
  61       fun make (n, t) = T {node = n, ty = t}
  62
  63       fun layout p =
  64          let
  65             val t = ty p
  66             open Layout
  67          in
  68             case node p of
  69                Con {arg, con, targs} =>
  70                   seq [Con.layout con,
  71                        layoutTargs targs,
  72                        case arg of
  73                           NONE => empty
  74                         | SOME p => seq [str " ", layout p]]
  75              | Const f => Const.layout (f ())
  76              | Layered (x, p) =>
  77                   seq [maybeConstrain (Var.layout x, t), str " as ", layout p]
  78              | List ps => list (Vector.toListMap (ps, layout))
  79              | Or ps => list (Vector.toListMap (ps, layout))
  80              | Record r =>
  81                   let
  82                      val extra =
  83                         Vector.exists
  84                         (Type.deRecord t, fn (f, _) =>
  85                          Option.isNone (Record.peek (r, f)))
  86                   in
  87                      Record.layout
  88                      {extra = if extra then ", ..." else "",
  89                       layoutElt = layout,
  90                       layoutTuple = fn ps => tuple (Vector.toListMap (ps, layout)),
  91                       record = r,
  92                       separator = " = "}
  93                   end
  94              | Var x => maybeConstrain (Var.layout x, t)
  95              | Vector ps => vector (Vector.map (ps, layout))
  96              | Wild => str "_"
  97          end
  98
  99       fun wild t = make (Wild, t)
 100
 101       fun var (x, t) = make (Var x, t)
 102
 103       fun tuple ps =
 104          if 1 = Vector.length ps
 105             then Vector.first ps
 106             else make (Record (Record.tuple ps), Type.tuple (Vector.map (ps, ty)))
 107
 108       local
 109          fun bool c = make (Con {arg = NONE, con = c, targs = Vector.new0 ()},
 110                             Type.bool)
 111       in
 112          val falsee: t = bool Con.falsee
 113          val truee: t = bool Con.truee
 114       end
 115
 116       fun isUnit (p: t): bool =
 117          case node p of
 118             Record r => Record.forall (r, fn _ => false)
 119           | _ => false
 120
 121       fun isWild (p: t): bool =
 122          case node p of
 123             Wild => true
 124           | _ => false
 125
 126       fun isRefutable (p: t): bool =
 127          case node p of
 128             Con _ => true
 129           | Const _ => true
 130           | Layered (_, p) => isRefutable p
 131           | List _ => true
 132           | Or ps => Vector.exists (ps, isRefutable)
 133           | Record r => Record.exists (r, isRefutable)
 134           | Var _ => false
 135           | Vector _ => true
 136           | Wild => false
 137
 138       fun foreachVar (p: t, f: Var.t -> unit): unit =
 139          let
 140             fun loop (p: t): unit =
 141                case node p of
 142                   Con _ => ()
 143                 | Const _ => ()
 144                 | Layered (x, p) => (f x; loop p)
 145                 | List ps => Vector.foreach (ps, loop)
 146                 | Or ps => Vector.foreach (ps, loop)
 147                 | Record r => Record.foreach (r, loop)
 148                 | Var x => f x
 149                 | Vector ps => Vector.foreach (ps, loop)
 150                 | Wild => ()
 151          in
 152             loop p
 153          end
 154    end
 155
 156 structure NoMatch =
 157    struct
 158       datatype t = Impossible | RaiseAgain | RaiseBind | RaiseMatch
 159    end
 160
 161 datatype noMatch = datatype NoMatch.t
 162
 163 datatype dec =
 164    Datatype of {cons: {arg: Type.t option,
 165                        con: Con.t} vector,
 166                 tycon: Tycon.t,
 167                 tyvars: Tyvar.t vector} vector
 168  | Exception of {arg: Type.t option,
 169                  con: Con.t}
 170  | Fun of {decs: {lambda: lambda,
 171                   var: Var.t} vector,
 172            tyvars: unit -> Tyvar.t vector}
 173  | Val of {matchDiags: {nonexhaustiveExn: Control.Elaborate.DiagDI.t,
 174                         nonexhaustive: Control.Elaborate.DiagEIW.t,
 175                         redundant: Control.Elaborate.DiagEIW.t},
 176            rvbs: {lambda: lambda,
 177                   var: Var.t} vector,
 178            tyvars: unit -> Tyvar.t vector,
 179            vbs: {ctxt: unit -> Layout.t,
 180                  exp: exp,
 181                  layPat: unit -> Layout.t,
 182                  nest: string list,
 183                  pat: Pat.t,
 184                  regionPat: Region.t} vector}
 185 and exp = Exp of {node: expNode,
 186                   ty: Type.t}
 187 and expNode =
 188    App of exp * exp
 189   | Case of {ctxt: unit -> Layout.t,
 190              kind: string * string,
 191              nest: string list,
 192              matchDiags: {nonexhaustiveExn: Control.Elaborate.DiagDI.t,
 193                           nonexhaustive: Control.Elaborate.DiagEIW.t,
 194                           redundant: Control.Elaborate.DiagEIW.t},
 195              noMatch: noMatch,
 196              region: Region.t,
 197              rules: {exp: exp,
 198                      layPat: (unit -> Layout.t) option,
 199                      pat: Pat.t,
 200                      regionPat: Region.t} vector,
 201              test: exp}
 202   | Con of Con.t * Type.t vector
 203   | Const of unit -> Const.t
 204   | EnterLeave of exp * SourceInfo.t
 205   | Handle of {catch: Var.t * Type.t,
 206                handler: exp,
 207                try: exp}
 208   | Lambda of lambda
 209   | Let of dec vector * exp
 210   | List of exp vector
 211   | PrimApp of {args: exp vector,
 212                 prim: Type.t Prim.t,
 213                 targs: Type.t vector}
 214   | Raise of exp
 215   | Record of exp Record.t
 216   | Seq of exp vector
 217   | Var of (unit -> Var.t) * (unit -> Type.t vector)
 218   | Vector of exp vector
 219 and lambda = Lam of {arg: Var.t,
 220                      argType: Type.t,
 221                      body: exp,
 222                      mayInline: bool}
 223
 224 local
 225    open Layout
 226 in
 227    fun layoutTyvars (ts: Tyvar.t vector) =
 228       case Vector.length ts of
 229          0 => empty
 230        | 1 => seq [str " ", Tyvar.layout (Vector.sub (ts, 0))]
 231        | _ => seq [str " ", tuple (Vector.toListMap (ts, Tyvar.layout))]
 232
 233    fun layoutConArg {arg, con} =
 234       seq [Con.layout con,
 235            case arg of
 236               NONE => empty
 237             | SOME t => seq [str " of ", Type.layout t]]
 238
 239    fun layoutDec d =
 240       case d of
 241          Datatype v =>
 242             seq [str "datatype",
 243                  align
 244                  (Vector.toListMap
 245                   (v, fn {cons, tycon, tyvars} =>
 246                    seq [layoutTyvars tyvars,
 247                         str " ", Tycon.layout tycon, str " = ",
 248                         align
 249                         (separateLeft (Vector.toListMap (cons, layoutConArg),
 250                                        "| "))]))]
 251        | Exception ca =>
 252             seq [str "exception ", layoutConArg ca]
 253        | Fun {decs, tyvars, ...} => layoutFuns (tyvars, decs)
 254        | Val {rvbs, tyvars, vbs, ...} =>
 255             align [layoutFuns (tyvars, rvbs),
 256                    align (Vector.toListMap
 257                           (vbs, fn {exp, pat, ...} =>
 258                            seq [str "val",
 259                                 mayAlign [seq [layoutTyvars (tyvars ()),
 260                                                str " ", Pat.layout pat,
 261                                                str " ="],
 262                                           layoutExp exp]]))]
 263    and layoutExp (Exp {node, ...}) =
 264       case node of
 265          App (e1, e2) => paren (seq [layoutExp e1, str " ", layoutExp e2])
 266        | Case {rules, test, ...} =>
 267             Pretty.casee {default = NONE,
 268                           rules = Vector.map (rules, fn {exp, pat, ...} =>
 269                                               (Pat.layout pat, layoutExp exp)),
 270                           test = layoutExp test}
 271        | Con (c, targs) => seq [Con.layout c, layoutTargs targs]
 272        | Const f => Const.layout (f ())
 273        | EnterLeave (e, si) =>
 274             seq [str "EnterLeave ",
 275                  tuple [layoutExp e, SourceInfo.layout si]]
 276        | Handle {catch, handler, try} =>
 277             Pretty.handlee {catch = Var.layout (#1 catch),
 278                             handler = layoutExp handler,
 279                             try = layoutExp try}
 280        | Lambda l => layoutLambda l
 281        | Let (ds, e) =>
 282             Pretty.lett (align (Vector.toListMap (ds, layoutDec)),
 283                          layoutExp e)
 284        | List es => list (Vector.toListMap (es, layoutExp))
 285        | PrimApp {args, prim, targs} =>
 286             Pretty.primApp {args = Vector.map (args, layoutExp),
 287                             prim = Prim.layout prim,
 288                             targs = Vector.map (targs, Type.layout)}
 289        | Raise e => Pretty.raisee (layoutExp e)
 290        | Record r =>
 291             Record.layout
 292             {extra = "",
 293              layoutElt = layoutExp,
 294              layoutTuple = fn es => tuple (Vector.toListMap (es, layoutExp)),
 295              record = r,
 296              separator = " = "}
 297        | Seq es => Pretty.seq (Vector.map (es, layoutExp))
 298        | Var (var, targs) =>
 299             if !Control.showTypes
 300                then let
 301                        open Layout
 302                        val targs = targs ()
 303                     in
 304                        if Vector.isEmpty targs
 305                           then Var.layout (var ())
 306                        else seq [Var.layout (var ()), str " ",
 307                                  Vector.layout Type.layout targs]
 308                     end
 309             else Var.layout (var ())
 310        | Vector es => vector (Vector.map (es, layoutExp))
 311    and layoutFuns (tyvars, decs)  =
 312       if Vector.isEmpty decs
 313          then empty
 314       else
 315          align [seq [str "val rec", layoutTyvars (tyvars ())],
 316                 indent (align (Vector.toListMap
 317                                (decs, fn {lambda as Lam {argType, body = Exp {ty = bodyType, ...}, ...}, var} =>
 318                                 align [seq [maybeConstrain (Var.layout var, Type.arrow (argType, bodyType)), str " = "],
 319                                        indent (layoutLambda lambda, 3)])),
 320                         3)]
 321    and layoutLambda (Lam {arg, argType, body, ...}) =
 322       paren (align [seq [str "fn ",
 323                          maybeConstrain (Var.layout arg, argType),
 324                          str " =>"],
 325                     layoutExp body])
 326
 327    fun layoutExpWithType (exp as Exp {ty, ...}) =
 328       let
 329          val node = layoutExp exp
 330       in
 331          if !Control.showTypes
 332             then seq [node, str " : ", Type.layout ty]
 333          else node
 334       end
 335 end
 336
 337 structure Lambda =
 338    struct
 339       datatype t = datatype lambda
 340
 341       val make = Lam
 342
 343       fun dest (Lam r) = r
 344
 345       val bogus = make {arg = Var.newNoname (),
 346                         argType = Type.unit,
 347                         body = Exp {node = Seq (Vector.new0 ()),
 348                                     ty = Type.unit},
 349                         mayInline = true}
 350    end
 351
 352 structure Exp =
 353    struct
 354       type dec = dec
 355       type lambda = lambda
 356       datatype t = datatype exp
 357       datatype node = datatype expNode
 358
 359       datatype noMatch = datatype noMatch
 360
 361       val layout = layoutExp
 362       val layoutWithType = layoutExpWithType
 363
 364       local
 365          fun make f (Exp r) = f r
 366       in
 367          val dest = make (fn {node, ty} => (node, ty))
 368          val node = make #node
 369          val ty = make #ty
 370       end
 371
 372       fun make (n, t) = Exp {node = n,
 373                              ty = t}
 374
 375       fun var (x: Var.t, ty: Type.t): t =
 376          make (Var (fn () => x, fn () => Vector.new0 ()), ty)
 377
 378       fun isExpansive (e: t): bool =
 379          case node e of
 380             App (e1, e2) =>
 381                (case node e1 of
 382                    Con (c, _) => Con.equals (c, Con.reff) orelse isExpansive e2
 383                  | _ => true)
 384           | Case _ => true
 385           | Con _ => false
 386           | Const _ => false
 387           | EnterLeave _ => true
 388           | Handle _ => true
 389           | Lambda _ => false
 390           | Let _ => true
 391           | List es => Vector.exists (es, isExpansive)
 392           | PrimApp _ => true
 393           | Raise _ => true
 394           | Record r => Record.exists (r, isExpansive)
 395           | Seq _ => true
 396           | Var _ => false
 397           | Vector es => Vector.exists (es, isExpansive)
 398
 399       fun tuple es =
 400          if 1 = Vector.length es
 401             then Vector.first es
 402          else make (Record (Record.tuple es),
 403                     Type.tuple (Vector.map (es, ty)))
 404
 405       val unit = tuple (Vector.new0 ())
 406
 407       local
 408          fun bool c = make (Con (c, Vector.new0 ()), Type.bool)
 409       in
 410          val falsee: t = bool Con.falsee
 411          val truee: t = bool Con.truee
 412       end
 413
 414       fun lambda (l as Lam {argType, body, ...}) =
 415          make (Lambda l, Type.arrow (argType, ty body))
 416
 417       fun casee (z as {rules, ...}) =
 418          if Vector.isEmpty rules
 419             then Error.bug "CoreML.Exp.casee"
 420          else make (Case z, ty (#exp (Vector.first rules)))
 421
 422       fun iff (test, thenCase, elseCase): t =
 423          casee {ctxt = fn () => Layout.empty,
 424                 kind = ("if", "branch"),
 425                 nest = [],
 426                 matchDiags = {nonexhaustiveExn = Control.Elaborate.DiagDI.Default,
 427                               nonexhaustive = Control.Elaborate.DiagEIW.Ignore,
 428                               redundant = Control.Elaborate.DiagEIW.Ignore},
 429                 noMatch = Impossible,
 430                 region = Region.bogus,
 431                 rules = Vector.new2 ({exp = thenCase,
 432                                       layPat = NONE,
 433                                       pat = Pat.truee,
 434                                       regionPat = Region.bogus},
 435                                      {exp = elseCase,
 436                                       layPat = NONE,
 437                                       pat = Pat.falsee,
 438                                       regionPat = Region.bogus}),
 439                 test = test}
 440
 441       fun andAlso (e1, e2) = iff (e1, e2, falsee)
 442
 443       fun orElse (e1, e2) = iff (e1, truee, e2)
 444
 445       fun whilee {expr, test} =
 446          let
 447             val loop = Var.newNoname ()
 448             val loopTy = Type.arrow (Type.unit, Type.unit)
 449             val call = make (App (var (loop, loopTy), unit), Type.unit)
 450             val lambda =
 451                Lambda.make
 452                {arg = Var.newNoname (),
 453                 argType = Type.unit,
 454                 body = iff (test,
 455                             make (Seq (Vector.new2 (expr, call)),
 456                                   Type.unit),
 457                             unit),
 458                 mayInline = true}
 459          in
 460             make
 461             (Let (Vector.new1 (Fun {decs = Vector.new1 {lambda = lambda,
 462                                                         var = loop},
 463                                     tyvars = fn () => Vector.new0 ()}),
 464                   call),
 465              Type.unit)
 466          end
 467
 468       fun foreachVar (e: t, f: Var.t -> unit): unit =
 469          let
 470             fun loop (e: t): unit =
 471                case node e of
 472                   App (e1, e2) => (loop e1; loop e2)
 473                 | Case {rules, test, ...} =>
 474                      (loop test
 475                       ; Vector.foreach (rules, loop o #exp))
 476                 | Con _ => ()
 477                 | Const _ => ()
 478                 | EnterLeave (e, _) => loop e
 479                 | Handle {handler, try, ...} => (loop handler; loop try)
 480                 | Lambda l => loopLambda l
 481                 | Let (ds, e) =>
 482                      (Vector.foreach (ds, loopDec)
 483                       ; loop e)
 484                 | List es => Vector.foreach (es, loop)
 485                 | PrimApp {args, ...} => Vector.foreach (args, loop)
 486                 | Raise e => loop e
 487                 | Record r => Record.foreach (r, loop)
 488                 | Seq es => Vector.foreach (es, loop)
 489                 | Var (x, _) => f (x ())
 490                 | Vector es => Vector.foreach (es, loop)
 491             and loopDec d =
 492                case d of
 493                   Datatype _ => ()
 494                 | Exception _ => ()
 495                 | Fun {decs, ...} => Vector.foreach (decs, loopLambda o #lambda)
 496                 | Val {rvbs, vbs, ...} =>
 497                      (Vector.foreach (rvbs, loopLambda o #lambda)
 498                       ; Vector.foreach (vbs, loop o #exp))
 499             and loopLambda (Lam {body, ...}) = loop body
 500          in
 501             loop e
 502          end
 503    end
 504
 505 structure Dec =
 506    struct
 507       datatype t = datatype dec
 508
 509       val layout = layoutDec
 510    end
 511
 512 structure Program =
 513    struct
 514       datatype t = T of {decs: Dec.t vector}
 515
 516       fun layouts (T {decs, ...}, output') =
 517          let
 518             open Layout
 519             (* Layout includes an output function, so we need to rebind output
 520              * to the one above.
 521              *)
 522             val output = output'
 523          in
 524             output (Layout.str "\n\nDecs:")
 525             ; Vector.foreach (decs, output o Dec.layout)
 526          end
 527
 528 (*       fun typeCheck (T {decs, ...}) =
 529  *       let
 530  *          fun checkExp (e: Exp.t): Ty.t =
 531  *             let
 532  *                val (n, t) = Exp.dest e
 533  *                val
 534  *                datatype z = datatype Exp.t
 535  *                val t' =
 536  *                   case n of
 537  *                      App (e1, e2) =>
 538  *                         let
 539  *                            val t1 = checkExp e1
 540  *                            val t2 = checkExp e2
 541  *                         in
 542  *                            case Type.deArrowOpt t1 of
 543  *                               NONE => error "application of non-function"
 544  *                             | SOME (u1, u2) =>
 545  *                                  if Type.equals (u1, t2)
 546  *                                     then t2
 547  *                                  else error "function/argument mismatch"
 548  *                         end
 549  *                    | Case {rules, test} =>
 550  *                         let
 551  *                            val {pat, exp} = Vector.first rules
 552  *                         in
 553  *                            Vector.foreach (rules, fn {pat, exp} =>
 554  *                                            Type.equals
 555  *                                            (checkPat pat,
 556  *                         end
 557  *             in
 558  *
 559  *             end
 560  *       in
 561  *       end
 562  *)
 563    end
 564
 565 end