mlton/elaborate/elaborate-modules.fun

   1 (* Copyright (C) 2012,2017 Matthew Fluet.
   2  * Copyright (C) 1999-2005 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 ElaborateModules (S: ELABORATE_MODULES_STRUCTS): ELABORATE_MODULES =
  11 struct
  12
  13 open S
  14
  15 local
  16    open Control.Elaborate
  17 in
  18    val resolveScope = fn () => current resolveScope
  19 end
  20
  21 local
  22    open Ast
  23 in
  24    structure FctArg = FctArg
  25    structure Fctid = Fctid
  26    structure Longstrid = Longstrid
  27    structure SigConst = SigConst
  28    structure Sigid = Sigid
  29    structure Sigexp = Sigexp
  30    structure Strdec = Strdec
  31    structure Strexp = Strexp
  32    structure Strid = Strid
  33    structure Topdec = Topdec
  34 end
  35
  36 local
  37    open Env
  38 in
  39    structure Decs = Decs
  40    structure FunctorClosure = FunctorClosure
  41    structure Structure = Structure
  42 end
  43
  44 structure ElaborateSigexp = ElaborateSigexp (structure Ast = Ast
  45                                              structure Env = Env)
  46
  47 structure ElaborateCore = ElaborateCore (structure Ast = Ast
  48                                          structure CoreML = CoreML
  49                                          structure Decs = Decs
  50                                          structure Env = Env)
  51
  52 val elabStrdecInfo = Trace.info "ElaborateModules.elabStrdec"
  53 val elabStrexpInfo = Trace.info "ElaborateModules.elabStrexp"
  54 val elabTopdecInfo = Trace.info "ElaborateModules.elabTopdec"
  55
  56 fun elaborateTopdec (topdec, {env = E: Env.t}) =
  57    let
  58       fun elabSigexp (s, no) =
  59          ElaborateSigexp.elaborateSigexp
  60          (s, {env = E, nest = case no of NONE => [] | SOME n => [n]})
  61       fun elabSigexpConstraint (cons: SigConst.t,
  62                                 S: Structure.t option,
  63                                 nest: string list)
  64          : Decs.t * Structure.t option =
  65          let
  66             fun s (sigexp, opaque) =
  67                let
  68                   val prefix =
  69                      case nest of
  70                         [] => ""
  71                       | _ => concat (List.fold (nest, [], fn (s, ac) =>
  72                                                 s :: "." :: ac))
  73                in
  74                   case S of
  75                      NONE => (Decs.empty, NONE)
  76                    | SOME S =>
  77                         let
  78                            val (S, decs) =
  79                               case elabSigexp (sigexp, SOME (Strid.toString Strid.uSig)) of
  80                                  NONE => (S, Decs.empty)
  81                                | SOME I =>
  82                                     Env.cut (E, S, I,
  83                                              {isFunctor = false,
  84                                               opaque = opaque,
  85                                               prefix = prefix},
  86                                              Sigexp.region sigexp)
  87                         in
  88                            (decs, SOME S)
  89                         end
  90                end
  91          in
  92             case cons of
  93                SigConst.None => (Decs.empty, S)
  94              | SigConst.Opaque sigexp => s (sigexp, true)
  95              | SigConst.Transparent sigexp => s (sigexp, false)
  96          end
  97       fun elabStrdec (arg: Strdec.t * string list): Decs.t =
  98          Trace.traceInfo' (elabStrdecInfo,
  99                            Layout.tuple2 (Strdec.layout,
 100                                           List.layout String.layout),
 101                            Decs.layout)
 102          (fn (d: Strdec.t, nest: string list) =>
 103           let
 104              val d = Strdec.coalesce d
 105              val elabStrdec = fn d => elabStrdec (d, nest)
 106              val decs =
 107                 case Strdec.node d of
 108                    Strdec.Core d => (* rule 56 *)
 109                       ElaborateCore.elaborateDec
 110                       (d, {env = E, nest = nest})
 111                  | Strdec.Local (d, d') => (* rule 58 *)
 112                       Env.localModule (E,
 113                                        fn () => elabStrdec d,
 114                                        fn d => Decs.append (d, elabStrdec d'))
 115                  | Strdec.Seq ds => (* rule 60 *)
 116                       List.fold
 117                       (ds, Decs.empty, fn (d, decs) =>
 118                        Decs.append (decs, elabStrdec d))
 119                  | Strdec.ShowBasis file =>
 120                       let
 121                          open Layout
 122                          val () =
 123                             File.withOut
 124                             (file, fn out =>
 125                              Env.output
 126                              (E, out,
 127                               {compact = !Control.showBasisCompact,
 128                                def = !Control.showBasisDef,
 129                                flat = !Control.showBasisFlat,
 130                                onlyCurrent = false,
 131                                prefixUnset = true}))
 132                             handle exn =>
 133                             Control.warning
 134                             (Strdec.region d,
 135                              str "Exception raised processing #showBasis",
 136                              align [seq [str "file: ", File.layout file],
 137                                     seq [str "exn:  ", Exn.layout exn]])
 138                       in
 139                          Decs.empty
 140                       end
 141                  | Strdec.Structure strbinds => (* rules 57, 61 *)
 142                       let
 143                          val strbinds =
 144                             Vector.map
 145                             (strbinds, fn {name, def, constraint} =>
 146                              let
 147                                 val nest = Strid.toString name :: nest
 148                                 val (decs', S) = elabStrexp (def, nest)
 149                                 val (decs'', S) =
 150                                    elabSigexpConstraint (constraint, S, nest)
 151                              in
 152                                 {decs = Decs.append (decs', decs''),
 153                                  name = name,
 154                                  S = S}
 155                              end)
 156                          val () =
 157                             Vector.foreach
 158                             (strbinds, fn {name, S, ...} =>
 159                              Option.app (S, fn S => Env.extendStrid (E, name, S)))
 160                        in
 161                           Decs.appendsV (Vector.map (strbinds, #decs))
 162                        end
 163              val () =
 164                 case resolveScope () of
 165                    Control.Elaborate.ResolveScope.Strdec =>
 166                       (ElaborateCore.reportUnresolvedFlexRecords ()
 167                        ; ElaborateCore.resolveOverloads ())
 168                  | _ => ()
 169           in
 170              decs
 171           end) arg
 172       and elabStrexp (arg: Strexp.t * string list): Decs.t * Structure.t option =
 173          Trace.traceInfo' (elabStrexpInfo,
 174                            Layout.tuple2 (Strexp.layout,
 175                                           List.layout String.layout),
 176                            Layout.tuple2 (Decs.layout,
 177                                           Option.layout Structure.layout))
 178          (fn (e: Strexp.t, nest: string list) =>
 179           let
 180              val elabStrexp = fn e => elabStrexp (e, nest)
 181           in
 182              case Strexp.node e of
 183                 Strexp.App (fctid, strexp) => (* rules 54, 154 *)
 184                    let
 185                       val (decs, S) = elabStrexp strexp
 186                    in
 187                       case S of
 188                          NONE => (decs, NONE)
 189                        | SOME S =>
 190                             case Env.lookupFctid (E, fctid) of
 191                                NONE => (decs, NONE)
 192                              | SOME fct  =>
 193                                   let
 194                                      val (S, decs') =
 195                                         Env.cut
 196                                         (E, S,
 197                                          FunctorClosure.argInterface fct,
 198                                          {isFunctor = true,
 199                                           opaque = false,
 200                                           prefix = ""},
 201                                          Region.append
 202                                          (Fctid.region fctid,
 203                                           Strexp.region strexp))
 204                                      val resId = Strid.uRes (Fctid.toString fctid)
 205                                      val (decs'', S) =
 206                                         FunctorClosure.apply
 207                                         (fct, S, [Strid.toString resId])
 208                                   in
 209                                      (Decs.appends [decs, decs', decs''], S)
 210                                   end
 211                    end
 212               | Strexp.Constrained (e, c) => (* rules 52, 53 *)
 213                    let
 214                       val (decs, S) = elabStrexp e
 215                       val (decs', S) = elabSigexpConstraint (c, S, nest)
 216                    in
 217                       (Decs.append (decs, decs'), S)
 218                    end
 219               | Strexp.Let (d, e) => (* rule 55 *)
 220                    Env.scope
 221                    (E, fn () =>
 222                     let
 223                        val decs = elabStrdec (d, nest)
 224                        val (decs', S) = elabStrexp e
 225                     in
 226                        (Decs.append (decs, decs'), S)
 227                     end)
 228               | Strexp.Struct d => (* rule 50 *)
 229                    let
 230                       val (decs, S) =
 231                          Env.makeStructure (E, fn () => elabStrdec (d, nest))
 232                    in
 233                       (decs, SOME S)
 234                    end
 235               | Strexp.Var p => (* rule 51 *)
 236                    (Decs.empty, Env.lookupLongstrid (E, p))
 237           end) arg
 238       fun elabFunctor {arg, body, name, result}: FunctorClosure.t option =
 239          let
 240             val body = Strexp.constrained (body, result)
 241             val argId = Strid.uArg (Fctid.toString name)
 242             val (argSig, argDec) =
 243                case FctArg.node arg of
 244                   FctArg.Structure (arg, argSig) =>
 245                      (argSig,
 246                       Strdec.structuree
 247                       {name = arg,
 248                        def = Strexp.var (Longstrid.short argId),
 249                        constraint = SigConst.None})
 250                 | FctArg.Spec spec =>
 251                      (Sigexp.spec spec,
 252                       Strdec.openn (Vector.new1 (Longstrid.short argId)))
 253             val body = Strexp.lett (argDec, body)
 254          in
 255             Option.map (elabSigexp (argSig, SOME (Strid.toString argId)), fn argInt =>
 256                         Env.functorClosure
 257                         (E, name, argInt,
 258                          fn (formal, nest) =>
 259                          Env.scope
 260                          (E, fn () =>
 261                           (Env.extendStrid (E, argId, formal)
 262                            ; elabStrexp (body, nest)))))
 263          end
 264       fun elabTopdec arg: Decs.t =
 265          Trace.traceInfo' (elabTopdecInfo,
 266                            Topdec.layout,
 267                            Decs.layout)
 268          (fn (d: Topdec.t) =>
 269           let
 270              val decs =
 271                 case Topdec.node d of
 272                    Topdec.Signature sigbinds =>
 273                       let
 274                          val sigbinds =
 275                             Vector.map
 276                             (sigbinds, fn (sigid, sigexp) =>
 277                              (sigid, elabSigexp (sigexp, SOME (Sigid.toString sigid))))
 278                          val () =
 279                             Vector.foreach
 280                             (sigbinds, fn (sigid, I) =>
 281                              Option.app (I, fn I => Env.extendSigid (E, sigid, I)))
 282                       in
 283                          Decs.empty
 284                       end
 285                  | Topdec.Strdec d => elabStrdec (d, [])
 286                  | Topdec.Functor funbinds =>
 287                       (* Rules 85, 86. Appendix A, p.58 *)
 288                       let
 289                          val funbinds =
 290                             Vector.map
 291                             (funbinds, fn {arg, body, name, result} =>
 292                              {closure = elabFunctor {arg = arg,
 293                                                      body = body,
 294                                                      name = name,
 295                                                      result = result},
 296                               name = name})
 297                          val () =
 298                             Vector.foreach (funbinds, fn {closure, name} =>
 299                                             Option.app
 300                                             (closure, fn closure =>
 301                                              Env.extendFctid (E, name, closure)))
 302                       in
 303                          Decs.empty
 304                       end
 305             val () =
 306                case resolveScope () of
 307                   Control.Elaborate.ResolveScope.Topdec =>
 308                      (ElaborateCore.reportUnresolvedFlexRecords ()
 309                       ; ElaborateCore.resolveOverloads ())
 310                 | _ => ()
 311             val _ = ElaborateCore.reportUndeterminedTypes ()
 312             val _ = ElaborateCore.reportSequenceNonUnit ()
 313           in
 314              decs
 315           end) arg
 316    in
 317       elabTopdec topdec
 318    end
 319
 320 val reportSequenceNonUnit = ElaborateCore.reportSequenceNonUnit
 321 val reportUndeterminedTypes = ElaborateCore.reportUndeterminedTypes
 322 val reportUnresolvedFlexRecords = ElaborateCore.reportUnresolvedFlexRecords
 323 val resolveOverloads = ElaborateCore.resolveOverloads
 324
 325 end