Import Upstream version 20180207

[hcoop/debian/mlton.git] / mlton / elaborate / elaborate-sigexp.fun

(* Copyright (C) 2010,2012,2015,2017 Matthew Fluet.
 * Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
 *    Jagannathan, and Stephen Weeks.
 * Copyright (C) 1997-2000 NEC Research Institute.
 *
 * MLton is released under a BSD-style license.
 * See the file MLton-LICENSE for details.
 *)

functor ElaborateSigexp (S: ELABORATE_SIGEXP_STRUCTS): ELABORATE_SIGEXP = 
struct

open S

local
   open Ast
in
   structure Atype = Type
   structure DatBind = DatBind
   structure DatatypeRhs = DatatypeRhs
   structure SharingEquation = SharingEquation
   structure Longstrid = Longstrid
   structure Longtycon = Longtycon
   structure Record = Record
   structure Sigexp = Sigexp
   structure Sigid = Sigid
   structure SortedRecord = SortedRecord
   structure Spec = Spec
   structure TypBind = TypBind
   structure Atyvar = Tyvar
   structure WhereEquation = WhereEquation
end

local
   open Env
in
   structure Interface = Interface
   structure StructureTycon =
      struct
         open Tycon
         open TypeEnv.TyconExt
      end
   structure TyvarEnv = TyvarEnv
end
structure StructureEnv = Env
structure Env = StructureEnv.InterfaceEnv

local
   open Interface
in
   structure AdmitsEquality = AdmitsEquality
   structure Cons = Cons
   structure Kind = Kind
   structure FlexibleTycon = FlexibleTycon
   structure Scheme = Scheme
   structure Status = Status
   structure Tycon = Tycon
   structure Type = Type
   structure TypeStr = TypeStr
   structure Tyvar = Tyvar
end

local
   open Control.Elaborate
in
   fun check (c: (bool,bool) t, keyword: string, region) =
      if current c
         then ()
      else
         let
            open Layout
         in
            Control.error
            (region,
             str (concat (if expert c
                             then [keyword, " disallowed"]
                             else [keyword, " disallowed, compile with -default-ann '",
                                   name c, " true'"])),
             empty)
         end
end

fun elaborateType (ty: Atype.t, E: Env.t): Type.t =
   let
      fun makeBogus (mc, ts) =
         let
            val arity = Vector.length ts
            val (name, region) =
               Option.fold
               (mc, ("t", NONE), fn (c, _) =>
                (Longtycon.toString c,
                 SOME (Longtycon.region c)))
            val c =
               StructureTycon.makeBogus
               {name = name,
                kind = Kind.Arity arity,
                region = region}
         in
            Type.con (Tycon.Rigid c, ts)
         end
      fun loop (ty: Atype.t): Type.t =
         case Atype.node ty of
            Atype.Var a => (* rule 44 *)
               (case TyvarEnv.lookupTyvar a of
                   NONE => makeBogus (NONE, Vector.new0 ())
                 | SOME a => Type.var a)
          | Atype.Con (c, ts) => (* rules 46, 47 *)
               let
                  val ts = Vector.map (ts, loop)
                  fun normal () =
                     case Env.lookupLongtycon (E, c) of
                        NONE => makeBogus (SOME c, ts)
                      | SOME s =>
                           let
                              val kind = TypeStr.kind s
                              val numArgs = Vector.length ts
                              val ts =
                                 case kind of
                                    Kind.Arity n =>
                                       let
                                          fun error () =
                                             let
                                                open Layout
                                                fun doit n =
                                                   seq [str "[",
                                                        case n of
                                                           0 => empty
                                                         | 1 => str "_"
                                                         | _ => seq [str "(",
                                                                     (seq o separate)
                                                                     (List.tabulate (n, fn _ => str "_"),
                                                                      ", "),
                                                                     str ")"],
                                                        str "] ",
                                                        Ast.Longtycon.layout c]
                                             in
                                                Control.error
                                                (Atype.region ty,
                                                 seq [str "type constructor applied to incorrect number of type arguments: ",
                                                      Ast.Longtycon.layout c],
                                                 align [seq [str "expects: ", doit n],
                                                        seq [str "but got: ", doit numArgs],
                                                        seq [str "in: ", Atype.layout ty]])
                                             end
                                       in
                                          case Int.compare (n, numArgs) of
                                             LESS =>
                                                (error (); Vector.prefix (ts, n))
                                           | EQUAL => ts
                                           | GREATER =>
                                                (error ()
                                                 ; Vector.concat
                                                   [ts,
                                                    Vector.tabulate
                                                    (n - numArgs, fn _ =>
                                                     makeBogus
                                                     (NONE,
                                                      Vector.new0 ()))])
                                       end
                                  | Kind.Nary => ts
                           in
                              TypeStr.apply (s, ts)
                           end
               in
                  case (Ast.Longtycon.split c, Vector.length ts) of
                     (([], c), 2) =>
                        if Ast.Tycon.equals (c, Ast.Tycon.arrow)
                           then Type.arrow (Vector.sub (ts, 0),
                                            Vector.sub (ts, 1))
                        else normal ()
                   | _ => normal ()
               end
          | Atype.Paren t => loop t
          | Atype.Record r => (* rules 45, 49 *)
               Type.record
               (SortedRecord.fromVector
                (Vector.map
                 (Record.toVector r,
                  fn (f, (_, t)) => (f, loop t))))
      val ty = loop ty
   in
      ty
   end

val elaborateType =
   Trace.trace ("ElaborateSigexp.elaborateType", Atype.layout o #1, Type.layout)
   elaborateType

fun elaborateScheme (tyvars: Tyvar.t vector, ty: Atype.t, E): Scheme.t =
   let
      val ty = elaborateType (ty, E)
   in
      Scheme.make (tyvars, ty)
   end

fun elaborateTypedescs (typedescs: {tycon: Ast.Tycon.t,
                                    tyvars: Ast.Tyvar.t vector} vector,
                        {equality: bool},
                        E,
                        nest): unit =
   Vector.foreach
   (typedescs, fn {tycon = name, tyvars} =>
    let
       val admitsEquality =
          if equality
             then AdmitsEquality.Sometimes
             else AdmitsEquality.Never
       val kind = Kind.Arity (Vector.length tyvars)
       val prettyDefault =
          concat (List.separate (rev (Ast.Tycon.toString name :: nest), "."))
       val flex = FlexibleTycon.new {admitsEquality = admitsEquality,
                                     hasCons = false,
                                     kind = kind,
                                     prettyDefault = prettyDefault,
                                     region = Ast.Tycon.region name}
       val tycon = Tycon.Flexible flex
    in
       Env.extendTycon (E, name, TypeStr.tycon (tycon, equality))
    end)

fun elabTypBind (typBind: TypBind.t, E, {sequential}) =
   let
      fun mkDef {def, tycon = _, tyvars} =
         TyvarEnv.scope
         (tyvars, fn tyvars =>
          let
             val realization =
                TypeStr.def (elaborateScheme (tyvars, def, E))
             val _ =
                TypeStr.pushSpec (realization, Ast.Type.region def)
          in
             realization
          end)
      val TypBind.T bs = TypBind.node typBind
   in
      if sequential
         then Vector.foreach
              (bs, fn b as {tycon, ...} =>
               Env.extendTycon (E, tycon, mkDef b))
         else Vector.foreach2
              (bs, Vector.map (bs, mkDef), fn ({tycon, ...}, str) =>
               Env.extendTycon (E, tycon, str))
   end

fun elaborateDatBind (datBind: DatBind.t, E, nest): unit =
   let
      val DatBind.T {datatypes, withtypes} = DatBind.node datBind
      (* Build enough of an interface so that that the constructor argument
       * types can be elaborated.
       *)
      val datatypes =
         Vector.map
         (datatypes, fn {cons, tycon = name, tyvars} =>
          let
             val arity = Vector.length tyvars
             val kind = Kind.Arity arity
             val prettyDefault =
                concat (List.separate (rev (Ast.Tycon.toString name :: nest), "."))
             val flex = FlexibleTycon.new {admitsEquality = AdmitsEquality.Sometimes,
                                           hasCons = true,
                                           kind = kind,
                                           prettyDefault = prettyDefault,
                                           region = Ast.Tycon.region name}
             val tycon = Tycon.Flexible flex
             val _ = Env.extendTycon (E, name, TypeStr.tycon (tycon, false))
          in
             {cons = cons,
              flex = flex,
              name = name,
              tycon = tycon,
              tyvars = tyvars}
          end)
      val _ = if TypBind.isEmpty withtypes
                 then ()
                 else check (Control.Elaborate.allowSigWithtype,
                             "withtype in signatures",
                             TypBind.region withtypes)
      (* To match semantics of withtype in Core,
       * type binds are elaborated simultaneously.
       *)
      val _ = elabTypBind (withtypes, E, {sequential = false})
      val datatypes =
         Vector.map
         (datatypes, fn {cons, flex, name, tycon, tyvars} =>
          let
             val cons =
                Vector.map
                (cons, fn (name, arg) =>
                 TyvarEnv.scope
                 (tyvars, fn tyvars =>
                  {arg = Option.map (arg, fn t => elaborateType (t, E)),
                   name = name,
                   tyvars = tyvars}))
          in
             {cons = cons,
              flex = flex,
              name = name,
              tycon = tycon}
          end)
      (* Maximize equality *)
      val change = ref false
      fun loop () =
          let
             val _ =
                Vector.foreach
                (datatypes, fn {cons, flex, ...} =>
                 let
                    val isEquality = ref true
                    val () =
                       Vector.foreach
                       (cons, fn {arg, tyvars, ...} =>
                        Option.foreach
                        (arg, fn arg =>
                         let
                            val argScheme =
                               Scheme.make (tyvars, arg)
                         in
                            if Scheme.admitsEquality argScheme
                               then ()
                               else isEquality := false
                         end))
                    datatype z = datatype AdmitsEquality.t
                 in
                    case FlexibleTycon.admitsEquality flex of
                       Always => Error.bug "ElaborateSigexp.elaborateDatBind: Always"
                     | Never => ()
                     | Sometimes =>
                          if !isEquality
                             then ()
                             else (FlexibleTycon.setAdmitsEquality (flex, Never)
                                   ; change := true)
                 end)
          in
             if !change
                then (change := false; loop ())
                else ()
          end
      val () = loop ()
      val () =
         Vector.foreach
         (datatypes, fn {cons, name, tycon, ...} =>
          let
             val cons =
                Vector.map
                (cons, fn {arg, name, tyvars} =>
                 let
                    val res =
                       Type.con (tycon, Vector.map (tyvars, Type.var))
                    val ty =
                       case arg of
                          NONE => res
                        | SOME arg => Type.arrow (arg, res)
                    val scheme =
                       Scheme.make (tyvars, ty)
                    val () =
                       Env.extendCon (E, name, scheme)
                 in
                    {name = name,
                     scheme = scheme}
                 end)
             val () =
                Env.rebindTycon
                (E, name, TypeStr.data (tycon, Cons.fromVector cons, false))
          in
             ()
          end)
   in
      ()
   end

val traceElaborateSigexp =
   Trace.trace2 ("ElaborateSigexp.elaborateSigexp",
                 Sigexp.layout,
                 fn {isTop, nest} => Layout.record [("isTop", Bool.layout isTop),
                                                    ("nest", List.layout Layout.str nest)],
                 Option.layout Interface.layout)
val traceElaborateSpec =
   Trace.trace2 ("ElaborateSigexp.elaborateSpec",
                 Spec.layout,
                 fn {nest} => Layout.record [("nest", List.layout Layout.str nest)],
                 Unit.layout)

(* rule 65 *)
fun elaborateSigexp (sigexp: Sigexp.t, {env = E: StructureEnv.t, nest: string list}): Interface.t option =
   let
      val strE = E
      val E = StructureEnv.makeInterfaceEnv E
      fun elaborateSigexp arg : Interface.t option =
         traceElaborateSigexp
         (fn (sigexp: Sigexp.t, {isTop, nest}) =>
          case Sigexp.node sigexp of
             Sigexp.Spec spec =>
                (* rule 62 *)
                SOME (#1 (Env.makeInterface (E, {isTop = isTop},
                                             fn () => elaborateSpec (spec, {nest = nest}))))
           | Sigexp.Var x =>
                (* rule 63 *)
                Option.map (Env.lookupSigid (E, x), Interface.copy)
           | Sigexp.Where {sigexp, equations} =>
                (* rule 64 *)
                let
                   val time = Interface.Time.tick ()
                in
                   Option.map
                   (elaborateSigexp (sigexp, {isTop = false, nest = nest}), fn I =>
                    let
                       val {layoutPrettyTycon = layoutPrettyEnvTycon,
                            layoutPrettyFlexTycon, ...} =
                          StructureEnv.makeLayoutPrettyTyconAndFlexTycon
                          (strE, E, SOME I, {prefixUnset = true})
                       val _ = 
                          Vector.foreach
                          (equations, fn eqn =>
                           case WhereEquation.node eqn of
                              WhereEquation.Type {longtycon, ty, tyvars} =>
                                 Option.app
                                 (Interface.lookupLongtycon
                                  (I, longtycon, Longtycon.region longtycon,
                                   {prefix = []}),
                                  fn (name, s) =>
                                  let
                                     val realization =
                                        TyvarEnv.scope
                                        (tyvars, fn tyvars =>
                                         TypeStr.def (elaborateScheme (tyvars, ty, E)))
                                  in
                                     TypeStr.wheree
                                     {layoutPrettyEnvTycon = layoutPrettyEnvTycon,
                                      layoutPrettyFlexTycon = layoutPrettyFlexTycon,
                                      realization = realization,
                                      region = WhereEquation.region eqn,
                                      time = time,
                                      ty = {name = fn () => Longtycon.layout longtycon,
                                            region = Longtycon.region longtycon,
                                            spec = Ast.Tycon.region name,
                                            tyStr = s}}
                                  end))
                    in
                       I
                    end)
                end) arg
      and elaborateSpec arg : unit =
         traceElaborateSpec
         (fn (spec: Spec.t, {nest}) =>
          case Spec.node spec of
             Spec.Datatype rhs =>
                (* rules 71, 72 *)
                (case DatatypeRhs.node rhs of
                    DatatypeRhs.DatBind b => elaborateDatBind (b, E, nest)
                  | DatatypeRhs.Repl {lhs, rhs} =>
                       Option.app
                       (Env.lookupLongtycon (E, rhs), fn s =>
                        let
                           val _ = TypeStr.pushSpec (s, Longtycon.region rhs)
                           val _ = Env.extendTycon (E, lhs, TypeStr.repl s)
                           val _ =
                              Vector.foreach
                              (Cons.dest (TypeStr.cons s), fn {name, scheme} =>
                               Env.extendCon (E, name, scheme))
                        in
                           ()
                        end))
           | Spec.Empty =>
                (* rule 76 *)
                ()
           | Spec.Eqtype typedescs =>
                (* rule 70 *)
                elaborateTypedescs (typedescs, {equality = true}, E, nest)
           | Spec.Exception cons =>
                (* rule 73 *)
                Vector.foreach
                (cons, fn (name: Ast.Con.t, arg: Ast.Type.t option) =>
                 let
                    val ty =
                       case arg of
                          NONE => Type.exn
                        | SOME t =>
                             let
                                val t = elaborateType (t, E)
                             in
                                Type.arrow (t, Type.exn)
                             end
                    val scheme = Scheme.make (Vector.new0 (), ty)
                    val _ = Env.extendExn (E, name, scheme)
                 in
                    ()
                 end)
           | Spec.IncludeSigexp sigexp =>
                (* rule 75 *)
                Option.app (elaborateSigexp (sigexp, {isTop = false, nest = nest}), fn I =>
                            Env.openInterface (E, I, Sigexp.region sigexp))
           | Spec.IncludeSigids sigids =>
                (* Appendix A, p.59 *)
                Vector.foreach (sigids, fn x =>
                                Option.app
                                (Env.lookupSigid (E, x), fn I =>
                                 Env.openInterface
                                 (E, Interface.copy I, Sigid.region x)))
           | Spec.Seq (s, s') =>
                (* rule 77 *)
                (elaborateSpec (s, {nest = nest})
                 ; elaborateSpec (s', {nest = nest}))
           | Spec.Sharing {equation, spec} =>
                (* rule 78 and section G.3.3 *)
                let
                   val time = Interface.Time.tick ()
                   (* Reifying the interface of spec is expensive,
                    * so collect all `sharing` equations that
                    * constrain the same spec.
                    *)
                   val (spec, equations) =
                      let
                         fun loop (spec, equations) =
                            case Spec.node spec of
                               Spec.Sharing {equation, spec} =>
                                  loop (spec, equation::equations)
                             | _ => (spec, equations)
                      in
                         loop (spec, [equation])
                      end
                   val (I, _) =
                      Env.makeInterface
                      (E, {isTop = false},
                       fn () => elaborateSpec (spec, {nest = nest}))
                   val () = Env.openInterface (E, I, Spec.region spec)
                   val {layoutPrettyTycon = layoutPrettyEnvTycon,
                        layoutPrettyFlexTycon, ...} =
                      StructureEnv.makeLayoutPrettyTyconAndFlexTycon
                      (strE, E, NONE, {prefixUnset = true})
                   val () =
                      List.foreach
                      (equations, fn eqn =>
                       case SharingEquation.node eqn of
                          SharingEquation.Structure ss =>
                             let
                                (* The following implements the "all
                                 * pairs" sharing as specified in
                                 * Appendix A (and described in
                                 * Appendix G.3.3).
                                 *)
                                fun loop Is =
                                   case Is of
                                      [] => ()
                                    | (long1, I1) :: Is =>
                                         (List.foreach
                                          (Is, fn (long2, I2) =>
                                           Interface.share
                                           {layoutPrettyEnvTycon = layoutPrettyEnvTycon,
                                            layoutPrettyFlexTycon = layoutPrettyFlexTycon,
                                            I1 = I1, long1 = long1,
                                            I2 = I2, long2 = long2,
                                            region = SharingEquation.region eqn,
                                            time = time})
                                          ; loop Is)
                                val Is =
                                   List.keepAllMap
                                   (ss, fn s =>
                                    Option.map
                                    (Interface.lookupLongstrid
                                     (I, s, Longstrid.region s, {prefix = []}),
                                     fn I => (s, I)))
                             in
                                loop Is
                             end
                        | SharingEquation.Type cs =>
                             ignore
                             (List.fold
                              (cs, NONE, fn (c', so) =>
                               case (so, Interface.lookupLongtycon (I, c', Longtycon.region c', {prefix = []})) of
                                  (NONE, NONE) => NONE
                                | (SOME _, NONE) => so
                                | (NONE, SOME (n', s')) => SOME (c', n', s')
                                | (SOME (c, n, s), SOME (n', s')) =>
                                     let
                                        fun mkTy (c, n, s) =
                                           {name = fn () => Longtycon.layout c,
                                            region = Longtycon.region c,
                                            spec = Ast.Tycon.region n,
                                            tyStr = s}
                                        val _ =
                                           TypeStr.share
                                           {layoutPrettyEnvTycon = layoutPrettyEnvTycon,
                                            layoutPrettyFlexTycon = layoutPrettyFlexTycon,
                                            region = SharingEquation.region eqn,
                                            time = time,
                                            ty1 = mkTy (c, n, s),
                                            ty2 = mkTy (c', n', s')}
                                     in
                                        SOME (c', n', s')
                                     end)))
                in
                   ()
                end
           | Spec.Structure ss =>
                (* rules 74, 84 *)
                let
                   val ss =
                      Vector.map
                      (ss, fn (strid, sigexp) =>
                       (strid,
                        case elaborateSigexp
                             (sigexp,
                              {isTop = false,
                               nest = (Ast.Strid.toString strid)::nest}) of
                           NONE => Interface.empty
                         | SOME I => I))
                in
                   Vector.foreach
                   (ss, fn (strid, I) =>
                    Env.extendStrid
                    (E, strid, I))
                end
           | Spec.Type typedescs =>
                (* rule 69 *)
                elaborateTypedescs (typedescs, {equality = false}, E, nest)
           | Spec.TypeDefs typBind =>
                (* Abbreviation on page 59 combined with rules 77 and 80. *)
                elabTypBind (typBind, E, {sequential = true})
           | Spec.Val xts =>
                (* rules 68, 79 *)
                Vector.foreach
                (xts, fn (x, t) =>
                 Env.extendVid
                 (E, Ast.Vid.fromVar x, Status.Var,
                  let
                     val tyvars =
                        let
                           val tyvars = ref []
                           fun loop t =
                              case Ast.Type.node t of
                                 Atype.Var a =>
                                    if List.contains (!tyvars, a, Atyvar.equals)
                                       then ()
                                       else List.push (tyvars, a)
                               | Atype.Con (_, ts) =>
                                    Vector.foreach (ts, loop)
                               | Atype.Paren t => loop t
                               | Atype.Record r => Record.foreach (r, loop o #2)
                           val () = loop t
                        in
                           Vector.fromListRev (!tyvars)
                        end
                  in
                     TyvarEnv.scope
                     (tyvars, fn tyvars =>
                      elaborateScheme (tyvars, t, E))
                  end))) arg
   in
      elaborateSigexp (sigexp, {isTop = true, nest = nest})
   end

val elaborateSigexp =
   fn (sigexp, {env = E, nest}) =>
   case Sigexp.node sigexp of
      Sigexp.Var x => StructureEnv.lookupSigid (E, x)
    | _ => elaborateSigexp (sigexp, {env = E, nest = nest})

val elaborateSigexp = 
   Trace.trace2 ("ElaborateSigexp.elaborateSigexp",
                 Sigexp.layout,
                 Layout.ignore,
                 Layout.ignore)
   elaborateSigexp

structure Env = StructureEnv

end