1 (* Copyright (C) 2010,2012,2015,2017 Matthew Fluet.
2 * Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
3 * Jagannathan, and Stephen Weeks.
4 * Copyright (C) 1997-2000 NEC Research Institute.
6 * MLton is released under a BSD-style license.
7 * See the file MLton-LICENSE for details.
10 functor ElaborateSigexp (S: ELABORATE_SIGEXP_STRUCTS): ELABORATE_SIGEXP =
18 structure Atype = Type
19 structure DatBind = DatBind
20 structure DatatypeRhs = DatatypeRhs
21 structure SharingEquation = SharingEquation
22 structure Longstrid = Longstrid
23 structure Longtycon = Longtycon
24 structure Record = Record
25 structure Sigexp = Sigexp
26 structure Sigid = Sigid
27 structure SortedRecord = SortedRecord
29 structure TypBind = TypBind
30 structure Atyvar = Tyvar
31 structure WhereEquation = WhereEquation
37 structure Interface = Interface
38 structure StructureTycon =
43 structure TyvarEnv = TyvarEnv
45 structure StructureEnv = Env
46 structure Env = StructureEnv.InterfaceEnv
51 structure AdmitsEquality = AdmitsEquality
54 structure FlexibleTycon = FlexibleTycon
55 structure Scheme = Scheme
56 structure Status = Status
57 structure Tycon = Tycon
59 structure TypeStr = TypeStr
60 structure Tyvar = Tyvar
64 open Control.Elaborate
66 fun check (c: (bool,bool) t, keyword: string, region) =
75 str (concat (if expert c
76 then [keyword, " disallowed"]
77 else [keyword, " disallowed, compile with -default-ann '",
83 fun elaborateType (ty: Atype.t, E: Env.t): Type.t =
85 fun makeBogus (mc, ts) =
87 val arity = Vector.length ts
90 (mc, ("t", NONE), fn (c, _) =>
91 (Longtycon.toString c,
92 SOME (Longtycon.region c)))
94 StructureTycon.makeBogus
96 kind = Kind.Arity arity,
99 Type.con (Tycon.Rigid c, ts)
101 fun loop (ty: Atype.t): Type.t =
102 case Atype.node ty of
103 Atype.Var a => (* rule 44 *)
104 (case TyvarEnv.lookupTyvar a of
105 NONE => makeBogus (NONE, Vector.new0 ())
106 | SOME a => Type.var a)
107 | Atype.Con (c, ts) => (* rules 46, 47 *)
109 val ts = Vector.map (ts, loop)
111 case Env.lookupLongtycon (E, c) of
112 NONE => makeBogus (SOME c, ts)
115 val kind = TypeStr.kind s
116 val numArgs = Vector.length ts
131 (List.tabulate (n, fn _ => str "_"),
135 Ast.Longtycon.layout c]
139 seq [str "type constructor applied to incorrect number of type arguments: ",
140 Ast.Longtycon.layout c],
141 align [seq [str "expects: ", doit n],
142 seq [str "but got: ", doit numArgs],
143 seq [str "in: ", Atype.layout ty]])
146 case Int.compare (n, numArgs) of
148 (error (); Vector.prefix (ts, n))
155 (n - numArgs, fn _ =>
162 TypeStr.apply (s, ts)
165 case (Ast.Longtycon.split c, Vector.length ts) of
167 if Ast.Tycon.equals (c, Ast.Tycon.arrow)
168 then Type.arrow (Vector.sub (ts, 0),
173 | Atype.Paren t => loop t
174 | Atype.Record r => (* rules 45, 49 *)
176 (SortedRecord.fromVector
179 fn (f, (_, t)) => (f, loop t))))
186 Trace.trace ("ElaborateSigexp.elaborateType", Atype.layout o #1, Type.layout)
189 fun elaborateScheme (tyvars: Tyvar.t vector, ty: Atype.t, E): Scheme.t =
191 val ty = elaborateType (ty, E)
193 Scheme.make (tyvars, ty)
196 fun elaborateTypedescs (typedescs: {tycon: Ast.Tycon.t,
197 tyvars: Ast.Tyvar.t vector} vector,
202 (typedescs, fn {tycon = name, tyvars} =>
206 then AdmitsEquality.Sometimes
207 else AdmitsEquality.Never
208 val kind = Kind.Arity (Vector.length tyvars)
210 concat (List.separate (rev (Ast.Tycon.toString name :: nest), "."))
211 val flex = FlexibleTycon.new {admitsEquality = admitsEquality,
214 prettyDefault = prettyDefault,
215 region = Ast.Tycon.region name}
216 val tycon = Tycon.Flexible flex
218 Env.extendTycon (E, name, TypeStr.tycon (tycon, equality))
221 fun elabTypBind (typBind: TypBind.t, E, {sequential}) =
223 fun mkDef {def, tycon = _, tyvars} =
225 (tyvars, fn tyvars =>
228 TypeStr.def (elaborateScheme (tyvars, def, E))
230 TypeStr.pushSpec (realization, Ast.Type.region def)
234 val TypBind.T bs = TypBind.node typBind
238 (bs, fn b as {tycon, ...} =>
239 Env.extendTycon (E, tycon, mkDef b))
241 (bs, Vector.map (bs, mkDef), fn ({tycon, ...}, str) =>
242 Env.extendTycon (E, tycon, str))
245 fun elaborateDatBind (datBind: DatBind.t, E, nest): unit =
247 val DatBind.T {datatypes, withtypes} = DatBind.node datBind
248 (* Build enough of an interface so that that the constructor argument
249 * types can be elaborated.
253 (datatypes, fn {cons, tycon = name, tyvars} =>
255 val arity = Vector.length tyvars
256 val kind = Kind.Arity arity
258 concat (List.separate (rev (Ast.Tycon.toString name :: nest), "."))
259 val flex = FlexibleTycon.new {admitsEquality = AdmitsEquality.Sometimes,
262 prettyDefault = prettyDefault,
263 region = Ast.Tycon.region name}
264 val tycon = Tycon.Flexible flex
265 val _ = Env.extendTycon (E, name, TypeStr.tycon (tycon, false))
273 val _ = if TypBind.isEmpty withtypes
275 else check (Control.Elaborate.allowSigWithtype,
276 "withtype in signatures",
277 TypBind.region withtypes)
278 (* To match semantics of withtype in Core,
279 * type binds are elaborated simultaneously.
281 val _ = elabTypBind (withtypes, E, {sequential = false})
284 (datatypes, fn {cons, flex, name, tycon, tyvars} =>
288 (cons, fn (name, arg) =>
290 (tyvars, fn tyvars =>
291 {arg = Option.map (arg, fn t => elaborateType (t, E)),
300 (* Maximize equality *)
301 val change = ref false
306 (datatypes, fn {cons, flex, ...} =>
308 val isEquality = ref true
311 (cons, fn {arg, tyvars, ...} =>
316 Scheme.make (tyvars, arg)
318 if Scheme.admitsEquality argScheme
320 else isEquality := false
322 datatype z = datatype AdmitsEquality.t
324 case FlexibleTycon.admitsEquality flex of
325 Always => Error.bug "ElaborateSigexp.elaborateDatBind: Always"
330 else (FlexibleTycon.setAdmitsEquality (flex, Never)
335 then (change := false; loop ())
341 (datatypes, fn {cons, name, tycon, ...} =>
345 (cons, fn {arg, name, tyvars} =>
348 Type.con (tycon, Vector.map (tyvars, Type.var))
352 | SOME arg => Type.arrow (arg, res)
354 Scheme.make (tyvars, ty)
356 Env.extendCon (E, name, scheme)
363 (E, name, TypeStr.data (tycon, Cons.fromVector cons, false))
371 val traceElaborateSigexp =
372 Trace.trace2 ("ElaborateSigexp.elaborateSigexp",
374 fn {isTop, nest} => Layout.record [("isTop", Bool.layout isTop),
375 ("nest", List.layout Layout.str nest)],
376 Option.layout Interface.layout)
377 val traceElaborateSpec =
378 Trace.trace2 ("ElaborateSigexp.elaborateSpec",
380 fn {nest} => Layout.record [("nest", List.layout Layout.str nest)],
384 fun elaborateSigexp (sigexp: Sigexp.t, {env = E: StructureEnv.t, nest: string list}): Interface.t option =
387 val E = StructureEnv.makeInterfaceEnv E
388 fun elaborateSigexp arg : Interface.t option =
390 (fn (sigexp: Sigexp.t, {isTop, nest}) =>
391 case Sigexp.node sigexp of
394 SOME (#1 (Env.makeInterface (E, {isTop = isTop},
395 fn () => elaborateSpec (spec, {nest = nest}))))
398 Option.map (Env.lookupSigid (E, x), Interface.copy)
399 | Sigexp.Where {sigexp, equations} =>
402 val time = Interface.Time.tick ()
405 (elaborateSigexp (sigexp, {isTop = false, nest = nest}), fn I =>
407 val {layoutPrettyTycon = layoutPrettyEnvTycon,
408 layoutPrettyFlexTycon, ...} =
409 StructureEnv.makeLayoutPrettyTyconAndFlexTycon
410 (strE, E, SOME I, {prefixUnset = true})
413 (equations, fn eqn =>
414 case WhereEquation.node eqn of
415 WhereEquation.Type {longtycon, ty, tyvars} =>
417 (Interface.lookupLongtycon
418 (I, longtycon, Longtycon.region longtycon,
424 (tyvars, fn tyvars =>
425 TypeStr.def (elaborateScheme (tyvars, ty, E)))
428 {layoutPrettyEnvTycon = layoutPrettyEnvTycon,
429 layoutPrettyFlexTycon = layoutPrettyFlexTycon,
430 realization = realization,
431 region = WhereEquation.region eqn,
433 ty = {name = fn () => Longtycon.layout longtycon,
434 region = Longtycon.region longtycon,
435 spec = Ast.Tycon.region name,
442 and elaborateSpec arg : unit =
444 (fn (spec: Spec.t, {nest}) =>
445 case Spec.node spec of
448 (case DatatypeRhs.node rhs of
449 DatatypeRhs.DatBind b => elaborateDatBind (b, E, nest)
450 | DatatypeRhs.Repl {lhs, rhs} =>
452 (Env.lookupLongtycon (E, rhs), fn s =>
454 val _ = TypeStr.pushSpec (s, Longtycon.region rhs)
455 val _ = Env.extendTycon (E, lhs, TypeStr.repl s)
458 (Cons.dest (TypeStr.cons s), fn {name, scheme} =>
459 Env.extendCon (E, name, scheme))
466 | Spec.Eqtype typedescs =>
468 elaborateTypedescs (typedescs, {equality = true}, E, nest)
469 | Spec.Exception cons =>
472 (cons, fn (name: Ast.Con.t, arg: Ast.Type.t option) =>
479 val t = elaborateType (t, E)
481 Type.arrow (t, Type.exn)
483 val scheme = Scheme.make (Vector.new0 (), ty)
484 val _ = Env.extendExn (E, name, scheme)
488 | Spec.IncludeSigexp sigexp =>
490 Option.app (elaborateSigexp (sigexp, {isTop = false, nest = nest}), fn I =>
491 Env.openInterface (E, I, Sigexp.region sigexp))
492 | Spec.IncludeSigids sigids =>
493 (* Appendix A, p.59 *)
494 Vector.foreach (sigids, fn x =>
496 (Env.lookupSigid (E, x), fn I =>
498 (E, Interface.copy I, Sigid.region x)))
499 | Spec.Seq (s, s') =>
501 (elaborateSpec (s, {nest = nest})
502 ; elaborateSpec (s', {nest = nest}))
503 | Spec.Sharing {equation, spec} =>
504 (* rule 78 and section G.3.3 *)
506 val time = Interface.Time.tick ()
507 (* Reifying the interface of spec is expensive,
508 * so collect all `sharing` equations that
509 * constrain the same spec.
511 val (spec, equations) =
513 fun loop (spec, equations) =
514 case Spec.node spec of
515 Spec.Sharing {equation, spec} =>
516 loop (spec, equation::equations)
517 | _ => (spec, equations)
519 loop (spec, [equation])
524 fn () => elaborateSpec (spec, {nest = nest}))
525 val () = Env.openInterface (E, I, Spec.region spec)
526 val {layoutPrettyTycon = layoutPrettyEnvTycon,
527 layoutPrettyFlexTycon, ...} =
528 StructureEnv.makeLayoutPrettyTyconAndFlexTycon
529 (strE, E, NONE, {prefixUnset = true})
532 (equations, fn eqn =>
533 case SharingEquation.node eqn of
534 SharingEquation.Structure ss =>
536 (* The following implements the "all
537 * pairs" sharing as specified in
538 * Appendix A (and described in
544 | (long1, I1) :: Is =>
546 (Is, fn (long2, I2) =>
548 {layoutPrettyEnvTycon = layoutPrettyEnvTycon,
549 layoutPrettyFlexTycon = layoutPrettyFlexTycon,
550 I1 = I1, long1 = long1,
551 I2 = I2, long2 = long2,
552 region = SharingEquation.region eqn,
559 (Interface.lookupLongstrid
560 (I, s, Longstrid.region s, {prefix = []}),
565 | SharingEquation.Type cs =>
568 (cs, NONE, fn (c', so) =>
569 case (so, Interface.lookupLongtycon (I, c', Longtycon.region c', {prefix = []})) of
571 | (SOME _, NONE) => so
572 | (NONE, SOME (n', s')) => SOME (c', n', s')
573 | (SOME (c, n, s), SOME (n', s')) =>
576 {name = fn () => Longtycon.layout c,
577 region = Longtycon.region c,
578 spec = Ast.Tycon.region n,
582 {layoutPrettyEnvTycon = layoutPrettyEnvTycon,
583 layoutPrettyFlexTycon = layoutPrettyFlexTycon,
584 region = SharingEquation.region eqn,
586 ty1 = mkTy (c, n, s),
587 ty2 = mkTy (c', n', s')}
594 | Spec.Structure ss =>
599 (ss, fn (strid, sigexp) =>
604 nest = (Ast.Strid.toString strid)::nest}) of
605 NONE => Interface.empty
609 (ss, fn (strid, I) =>
613 | Spec.Type typedescs =>
615 elaborateTypedescs (typedescs, {equality = false}, E, nest)
616 | Spec.TypeDefs typBind =>
617 (* Abbreviation on page 59 combined with rules 77 and 80. *)
618 elabTypBind (typBind, E, {sequential = true})
624 (E, Ast.Vid.fromVar x, Status.Var,
630 case Ast.Type.node t of
632 if List.contains (!tyvars, a, Atyvar.equals)
634 else List.push (tyvars, a)
635 | Atype.Con (_, ts) =>
636 Vector.foreach (ts, loop)
637 | Atype.Paren t => loop t
638 | Atype.Record r => Record.foreach (r, loop o #2)
641 Vector.fromListRev (!tyvars)
645 (tyvars, fn tyvars =>
646 elaborateScheme (tyvars, t, E))
649 elaborateSigexp (sigexp, {isTop = true, nest = nest})
652 val elaborateSigexp =
653 fn (sigexp, {env = E, nest}) =>
654 case Sigexp.node sigexp of
655 Sigexp.Var x => StructureEnv.lookupSigid (E, x)
656 | _ => elaborateSigexp (sigexp, {env = E, nest = nest})
658 val elaborateSigexp =
659 Trace.trace2 ("ElaborateSigexp.elaborateSigexp",
665 structure Env = StructureEnv