1 (* Copyright (C) 2009-2010,2015,2017 Matthew Fluet.
2 * Copyright (C) 1999-2007 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 ElaborateEnv (S: ELABORATE_ENV_STRUCTS): ELABORATE_ENV =
16 open Control.Elaborate
18 val warnUnused = fn () => current warnUnused
25 val alignPrefix = alignPrefix
26 (* val empty = empty *)
27 val mayAlign = mayAlign
31 seq [str "[", l, str "]"]
37 structure Basid = Basid
38 structure Fctid = Fctid
39 structure Strid = Strid
40 structure Longtycon = Longtycon
41 structure Priority = Priority
42 structure Sigid = Sigid
43 structure Strid = Strid
44 structure Symbol = Symbol
47 fun layoutLong (ids: Layout.t list) =
51 seq (separate (ids, "."))
54 fun layoutStrids (ss: Strid.t list): Layout.t =
55 layoutLong (List.map (ss, Strid.layout))
57 fun layoutLongRev (ss: Strid.t list, id: Layout.t) =
59 (ss, [id], fn (s, ls) =>
60 Strid.layout s :: str "." :: ls)
61 fun toStringLongRev (ss: Strid.t list, id: Layout.t) =
62 Layout.toString (layoutLongRev (ss, id))
71 structure Tycon = Tycon
72 structure Tyvar = Tyvar
79 structure AdmitsEquality = AdmitsEquality
81 structure Symbol = Symbol
87 structure Scheme = Scheme
91 structure Decs = Decs (structure CoreML = CoreML)
102 open TypeEnv.TyvarExt
104 makeString (Ast.Tyvar.toString a,
105 {equality = Ast.Tyvar.isEquality a})
110 datatype t = T of {cur: (Ast.Tyvar.t * Tyvar.t) list ref,
111 get: Ast.Tyvar.t -> Tyvar.t list ref}
114 val {get: Ast.Tyvar.t -> Tyvar.t list ref, ...} =
116 (Symbol.plist o Ast.Tyvar.toSymbol,
117 Property.initFun (fn _ => ref []))
120 T {get = get, cur = cur}
122 fun peekTyvar (T {get, ...}, a) =
126 fun lookupTyvar (env, a) =
127 case peekTyvar (env, a) of
133 seq [str "undefined type variable: ",
140 fun scope (T {cur, get, ...}, bs, th) =
142 val bs' = Vector.map (bs, Tyvar.fromAst)
145 (bs, bs', fn (b, b') =>
146 (List.push (cur, (b, b'))
147 ; List.push (get b, b')))
152 (ignore (List.pop cur)
153 ; ignore (List.pop (get b))))
159 val lookupTyvar = fn a =>
161 val scope = fn (bs, th) =>
164 val makeLayoutPretty = fn () =>
166 val {destroy, get = layoutPretty, set = setLayoutPretty, ...} =
168 (Tyvar.plist, Property.initFun Tyvar.layout)
173 setLayoutPretty (a', Ast.Tyvar.layout a))
174 val pre = ClearablePromise.delay pre
175 val destroy = fn () =>
176 (ClearablePromise.clear pre
178 val layoutPretty = fn a' =>
179 (ClearablePromise.force pre
183 layoutPretty = layoutPretty}
186 val makeLayoutPretty = fn () =>
188 fun layoutPretty a' =
192 case List.peek (!cur, fn (_, b') => Tyvar.equals (a', b')) of
193 NONE => Tyvar.layout a'
194 | SOME (a, _) => Ast.Tyvar.layout a
197 {destroy = fn () => (),
198 layoutPretty = layoutPretty}
202 val insideFunctor = ref false
204 fun amInsideFunctor () = !insideFunctor
208 structure Unique = UniqueId ()
209 datatype t = T of {unique: Unique.t}
212 fun make f (T r) = f r
214 val unique = make #unique
218 T {unique = Unique.new ()}
220 fun equals (s, s') = Unique.equals (unique s, unique s')
229 val new: {rebind: {domain: 'a, uses: 'a t} option} -> 'a t option
230 val old: 'a t -> {rebind: {domain: 'a, uses: 'a t} option} -> 'a t option
231 val fromIsRebind: {isRebind: bool} -> {rebind: {domain: 'a, uses: 'a t} option} -> 'a t option
234 val add: 'a t * 'a -> unit
235 val all: 'a t -> 'a list
236 val clear: 'a t -> unit
237 val forceUsed: 'a t -> unit
238 val hasUse: 'a t -> bool
239 val isUsed: 'a t -> bool
240 val new: unit -> 'a t
243 datatype 'a t = T of {direct: 'a list ref,
246 fun new () = T {direct = ref [],
247 forceUsed = ref false}
249 fun add (T {direct, ...}, a) = List.push (direct, a)
251 fun forceUsed (T {forceUsed = r, ...}) = r := true
253 fun clear (T {direct, ...}) = direct := []
255 fun all (T {direct, ...}) = !direct
257 fun hasUse (T {direct, ...}): bool =
258 not (List.isEmpty (!direct))
260 fun isUsed (u as T {forceUsed, ...}): bool =
261 !forceUsed orelse hasUse u
266 fun old uses _ = SOME uses
267 fun fromIsRebind {isRebind} =
272 Error.bug "ElaborateEnv.Uses.Extend.fromIsRebind"
273 | SOME {domain = _, uses} =>
281 datatype t = Bas | Con | Exn | Fix | Fct | Sig | Str | Typ | Var
285 | Con => "constructor"
300 | Overload of Priority.t * (Var.t * Scheme.t) vector
304 fn Con _ => "constructor"
305 | Exn _ => "exception"
306 | Overload _ => "overload"
307 | Var _ => "variable"
314 Con c => ("Con", Con.layout c)
315 | Exn c => ("Exn", Con.layout c)
316 | Overload (p,xts) =>
317 (concat ["Overload (",
318 Layout.toString (Priority.layout p),
320 Vector.layout (tuple2 (Var.layout, Scheme.layout))
322 | Var v => ("Var", Var.layout v)
324 paren (seq [str name, str " ", l])
341 fn Con _ => Class.Con
343 | Overload _ => Class.Var
352 val dest: t -> {con: Con.t,
355 uses: Ast.Vid.t Uses.t} vector
356 val fromSortedVector: {con: Con.t,
359 uses: Ast.Vid.t Uses.t} vector -> t
360 val fromVector: {con: Con.t,
363 uses: Ast.Vid.t Uses.t} vector -> t
364 val layout: t -> Layout.t
365 val map: t * ({con: Con.t,
368 uses: Ast.Vid.t Uses.t}
371 uses: Ast.Vid.t Uses.t}) -> t
374 datatype t = T of {con: Con.t,
377 uses: Ast.Vid.t Uses.t} vector
381 val fromSortedVector = T
384 (fromSortedVector o QuickSort.sortVector)
385 (v, fn ({name = name1, ...}, {name = name2, ...}) =>
386 case Ast.Con.compare (name1, name2) of
393 (v, fn elt as {name, ...} =>
395 val {con, scheme, uses} =
405 Vector.layout (fn {name, scheme, ...} =>
406 seq [Ast.Con.layout name,
407 str ": ", Scheme.layout scheme])
412 Datatype of {cons: Cons.t,
422 Datatype {tycon, ...} => Tycon.kind tycon
423 | Scheme s => Scheme.kind s
424 | Tycon c => Tycon.kind c
431 Datatype {tycon, cons} =>
432 seq [str "Datatype ",
433 record [("tycon", Tycon.layout tycon),
434 ("cons", Cons.layout cons)]]
435 | Scheme s => seq [str "Scheme ", Scheme.layout s]
436 | Tycon c => seq [str "Tycon ", Tycon.layout c]
439 fun admitsEquality (s: t): AdmitsEquality.t =
441 Datatype {tycon = c, ...} => Tycon.admitsEquality c
442 | Scheme s => if Scheme.admitsEquality s
443 then AdmitsEquality.Sometimes
444 else AdmitsEquality.Never
445 | Tycon c => Tycon.admitsEquality c
447 fun explainDoesNotAdmitEquality (s: t, {layoutPrettyTycon}): Layout.t =
450 case Scheme.checkEquality (s, {layoutPrettyTycon = layoutPrettyTycon}) of
452 | NONE => Error.bug "ElaborateEnv.TypeStr.explainDoesNotAdmitEquality.doitScheme: NONE"
455 Datatype {cons, ...} =>
457 val extra = ref false
461 (Cons.dest cons, fn {name, scheme, ...} =>
463 val (tyvars, ty) = Scheme.dest scheme
465 case Type.deArrowOpt ty of
466 NONE => (extra := true; NONE)
470 Scheme.make {canGeneralize = true,
474 case Scheme.checkEquality (argScheme, {layoutPrettyTycon = layoutPrettyTycon}) of
475 NONE => (extra := true; NONE)
476 | SOME l => SOME (seq [Ast.Con.layout name, str " of ", l])
481 then List.snoc (cons, str "...")
483 val cons = alignPrefix (cons, "| ")
487 | Scheme s => doitScheme s
488 | Tycon c => doitScheme (Scheme.fromTycon c)
491 fun apply (t: t, tys: Type.t vector): Type.t =
493 Datatype {tycon, ...} => Type.con (tycon, tys)
494 | Scheme s => Scheme.apply (s, tys)
495 | Tycon c => Type.con (c, tys)
499 Datatype {tycon, ...} => SOME tycon
502 val (tyvars, ty) = Scheme.dest s
504 case Type.deEta (ty, tyvars) of
507 if Tycon.equals (c, Tycon.arrow)
508 orelse Tycon.equals (c, Tycon.tuple)
514 fun data (tycon, cons) =
515 Datatype {tycon = tycon, cons = cons}
523 Datatype {tycon = c, ...} => tycon c
530 structure Cons = Cons
533 structure Interface = Interface (structure Ast = Ast
534 structure AdmitsEquality = AdmitsEquality
535 structure Kind = Kind
536 structure EnvTycon = Tycon
537 structure EnvTypeStr = TypeStr
538 structure Tyvar = Tyvar)
540 structure Interface =
542 structure Econs = Cons
543 structure Escheme = Scheme
544 structure Etycon = Tycon
545 structure Etype = Type
546 structure EtypeStr = TypeStr
547 structure Etyvar = Tyvar
550 fun flexibleTyconToEnv (fc: FlexibleTycon.t): EtypeStr.t =
552 datatype z = datatype FlexibleTycon.realization
554 case FlexibleTycon.realization fc of
555 SOME (ETypeStr s) => s
556 | SOME (TypeStr s) => typeStrToEnv s
559 (* A shadowed flexible tycon was not reported as
560 * a flexible tycon and was not realized. *)
563 ("ElaborateEnv.Interface.flexibleTyconToEnv",
564 fn () => !Control.numErrors > 0)
565 val {admitsEquality = ae, kind = k,
566 prettyDefault = pd, ...} =
567 FlexibleTycon.dest fc
570 Etycon.make {admitsEquality = ae,
574 region = Region.bogus}
575 val tyStr = EtypeStr.tycon c
576 val () = FlexibleTycon.realize (fc, tyStr)
581 and tyconToEnv (t: Tycon.t): EtypeStr.t =
586 Flexible c => flexibleTyconToEnv c
587 | Rigid c => EtypeStr.tycon c
589 and typeToEnv (t: Type.t): Etype.t =
590 Type.hom (t, {con = fn (c, ts) => EtypeStr.apply (tyconToEnv c, ts),
591 record = Etype.record,
593 and schemeToEnv (Scheme.T {ty, tyvars}): Escheme.t =
594 Escheme.make {canGeneralize = true,
597 and consToEnv cons: Econs.t =
598 (Econs.fromSortedVector o Vector.map)
599 (Cons.dest cons, fn {name, scheme} =>
600 {con = Con.newNoname (),
602 scheme = schemeToEnv scheme,
604 and typeStrToEnv (s: TypeStr.t): EtypeStr.t =
606 datatype z = datatype TypeStr.node
608 case TypeStr.node s of
609 Datatype {cons, tycon, ...} =>
612 EtypeStr.data (c, consToEnv cons)
617 val typeStr = flexibleTyconToEnv c
619 case EtypeStr.toTyconOpt typeStr of
623 (seq [str "ElaborateEnv.Interface.typeStrToEnv ",
626 str " realized with type structure ",
627 EtypeStr.layout typeStr]))
629 | Tycon.Rigid c => data c
632 EtypeStr.def (schemeToEnv s)
633 | Tycon {tycon, ...} =>
634 EtypeStr.abs (tyconToEnv tycon)
637 structure FlexibleTycon =
641 val toEnv = flexibleTyconToEnv
643 fun dummyTycon (fc, name, strids, {prefix}) =
645 val {admitsEquality = ae, kind = k, ...} =
646 FlexibleTycon.dest fc
647 val r = Ast.Tycon.region name
648 val n = Ast.Tycon.toString name
650 prefix ^ toStringLongRev (strids, Ast.Tycon.layout name)
652 Etycon.make {admitsEquality = ae,
673 fun fromEnv (t: Etype.t): t =
676 Type.con (Tycon.fromEnv c, ts)
678 Etype.hom (t, {con = con,
679 expandOpaque = false,
681 replaceSynonyms = false,
690 val toEnv = schemeToEnv
692 fun fromEnv (s: Escheme.t): t =
694 val (tyvars, ty) = Escheme.dest s
696 Scheme.T {ty = Type.fromEnv ty,
705 fun fromEnv (cons): t =
706 (fromSortedVector o Vector.map)
707 (Econs.dest cons, fn {name, scheme, ...} =>
709 scheme = Scheme.fromEnv scheme})
716 val toEnv = typeStrToEnv
718 fun fromEnv (s: EtypeStr.t) =
719 case EtypeStr.node s of
720 EtypeStr.Datatype {cons, tycon} =>
721 data (Tycon.fromEnv tycon,
724 | EtypeStr.Scheme s => def (Scheme.fromEnv s)
725 | EtypeStr.Tycon c => def (Scheme.fromTycon (Tycon.fromEnv c))
730 Datatype of {tycon: Etycon.t, cons: Econs.t, repl: bool}
731 | Scheme of Escheme.t
732 | Type of {admitsEquality: bool}
735 fun sort (sigStr, rlzStr, representative) =
736 case (representative, node sigStr, EtypeStr.node rlzStr) of
737 (false, Datatype _, EtypeStr.Datatype {tycon = rlzTycon, cons = rlzCons}) =>
738 Sort.Datatype {tycon = rlzTycon, cons = rlzCons, repl = true}
739 | (false, Datatype _, EtypeStr.Scheme _) =>
740 Error.bug "ElaborateEnv.Interface.TypeStr.sort: {repr = false, sigStr = Datatype _, rlzStr = Scheme _}"
741 | (false, Datatype _, EtypeStr.Tycon _) =>
742 Error.bug "ElaborateEnv.Interface.TypeStr.sort: {repr = false, sigStr = Datatype _, rlzStr = Tycon _}"
743 | (false, _, rlzStr) =>
744 Sort.Scheme (case rlzStr of
745 EtypeStr.Datatype {tycon, ...} =>
746 Escheme.fromTycon tycon
747 | EtypeStr.Scheme s => s
748 | EtypeStr.Tycon c =>
750 | (true, Datatype {repl = false, ...}, EtypeStr.Datatype {tycon = rlzTycon, cons = rlzCons}) =>
751 Sort.Datatype {tycon = rlzTycon, cons = rlzCons, repl = false}
752 | (true, Datatype {repl = false, ...}, EtypeStr.Scheme _) =>
753 Error.bug "ElaborateEnv.Interface.TypeStr.sort: {repr = true, sigStr = Datatype {repl = false, ...}, rlzStr = Scheme _}"
754 | (true, Datatype {repl = false, ...}, EtypeStr.Tycon _) =>
755 Error.bug "ElaborateEnv.Interface.TypeStr.sort: {repr = true, sigStr = Datatype {repl = false, ...}, rlzStr = Tycon _}"
756 | (true, Datatype {repl = true, ...}, _) =>
757 Error.bug "ElaborateEnv.Interface.TypeStr.sort: {repr = true, sigStr = Datatype {repl = true, ...}}"
758 | (true, Scheme _, _) =>
759 Error.bug "ElaborateEnv.Interface.TypeStr.sort: {repr = true, sigStr = Scheme _}"
760 | (true, Tycon _, _) =>
761 (case admitsEquality sigStr of
762 AdmitsEquality.Always => Sort.Type {admitsEquality = true}
763 | AdmitsEquality.Never => Sort.Type {admitsEquality = false}
764 | AdmitsEquality.Sometimes => Sort.Type {admitsEquality = true})
766 val sort = fn (name, sigStr, rlzStr,
767 flexTyconMap: FlexibleTycon.t TyconMap.t) =>
768 sort (sigStr, rlzStr,
769 Option.isSome (TyconMap.peekTycon (flexTyconMap, name)))
772 fun layouts {interfaceSigid, layoutPrettyTycon, setLayoutPrettyTycon} =
774 val empty = Layout.empty
775 val indent = fn l => Layout.indent (l, 3)
776 val isEmpty = Layout.isEmpty
777 val tuple = Layout.tuple
779 val {destroy = destroyLayoutPrettyTyvar,
780 layoutPretty = layoutPrettyTyvar,
781 localInit = localInitLayoutPrettyTyvar} =
782 Etyvar.makeLayoutPretty ()
783 val {destroy = destroyLayoutPrettyType,
784 layoutPretty = layoutPrettyType} =
785 Etype.makeLayoutPretty
786 {expandOpaque = false,
787 layoutPrettyTycon = layoutPrettyTycon,
788 layoutPrettyTyvar = layoutPrettyTyvar}
789 fun layoutPrettyScheme s =
791 val (bs, t) = Escheme.dest s
792 val () = localInitLayoutPrettyTyvar bs
794 #1 (layoutPrettyType t)
797 fun layoutValSpec (strids, name, (sigStatus, sigScheme), {compact, con, def}) =
799 val rlzScheme = Scheme.toEnv sigScheme
804 [seq [str kw, str " ",
805 layoutLongRev (strids, Ast.Vid.layout name),
806 str (if Ast.Vid.isSymbolic name then " : " else ": "),
807 layoutPrettyScheme rlzScheme],
809 then seq [str "(* @ ",
810 Region.layout (Ast.Vid.region name),
815 then Layout.compact lay
832 [seq [str "exception ",
833 layoutLongRev (strids, Ast.Vid.layout name),
834 case Etype.deArrowOpt (Escheme.ty rlzScheme) of
836 | SOME (ty, _) => seq [str " of ",
837 #1 (layoutPrettyType ty)]],
839 then seq [str "(* @ ",
840 Region.layout (Ast.Vid.region name),
845 then Layout.compact lay
853 fun layoutTypeSpec (strids, name, sigStr,
854 {compact, def, flexTyconMap}) =
856 val lay = #1 o layoutPrettyType
857 val rlzStr = TypeStr.toEnv sigStr
858 val sort = TypeStr.sort (name, sigStr, rlzStr, flexTyconMap)
860 case Interface.TypeStr.kind sigStr of
861 Kind.Arity sigArity => sigArity
862 | _ => Error.bug "ElaborateEnv.transparentCut.layouts.layoutTypeSpec: sigArity"
866 Etyvar.makeNoname {equality = false})
867 val () = localInitLayoutPrettyTyvar tyvars
868 val tyargs = Vector.map (tyvars, Etype.var)
869 val tyvars = Vector.map (tyvars, layoutPrettyTyvar)
871 case Vector.length tyvars of
873 | 1 => Vector.first tyvars
874 | _ => tuple (Vector.toList tyvars)
875 datatype sort = datatype TypeStr.Sort.t
878 Datatype {repl, cons, ...} =>
882 (Econs.dest cons, fn {name, scheme, ...} =>
884 val ty = Escheme.apply (scheme, tyargs)
886 seq [Ast.Con.layout name,
887 case Etype.deArrowOpt ty of
889 | SOME (ty, _) => seq [str " of ", lay ty]]
896 else Layout.indent (seq [str "| ", l], ~2))
901 seq [str "(* = datatype ",
902 lay (EtypeStr.apply (rlzStr, tyargs)),
905 List.snoc (cons, Layout.indent (repl, ~2))
910 SOME (mayAlign rest))
914 SOME (lay (Escheme.apply (scheme, tyargs))))
915 | Type {admitsEquality} =>
916 (if admitsEquality then "eqtype" else "type",
920 [seq [str kw, str " ",
922 if isEmpty tyvars then empty else str " ",
923 layoutLongRev (strids, Ast.Tycon.layout name),
926 | SOME rest => seq [str " = ", rest]],
928 then seq [str "(* @ ",
929 Region.layout (Ast.Tycon.region name),
934 then Layout.compact lay
939 fun layoutStrSpec (strids, name, I,
940 {compact, def, elide, flexTyconMap}) =
942 val bind = seq [str "structure ",
943 layoutLongRev (strids, Ast.Strid.layout name),
947 (TyconMap.peekStrid (flexTyconMap, name),
949 fn (flexTyconMap, _) => flexTyconMap)
954 flexTyconMap = flexTyconMap})
957 then seq [str "(* @ ",
958 Region.layout (Ast.Strid.region name),
962 align [bind, indent (full ()), indent def]
970 [seq [bind, str " ", sigg],
974 then Layout.compact lay
980 and layoutSigFlex (I,
983 fun realize (TyconMap.T {strs, types}, strids) =
987 (strs, fn (name, tm) =>
988 realize (tm, name :: strids))
991 (types, fn (name, fc) =>
994 FlexibleTycon.dummyTycon
995 (fc, name, strids, {prefix = "_sig."})
998 (c, Etycon.layoutPrettyDefault c)
1000 FlexibleTycon.realize
1001 (fc, EtypeStr.tycon c)
1009 val flexTyconMap = flexibleTycons rlzI
1010 val () = realize (flexTyconMap, [])
1015 flexTyconMap = flexTyconMap})
1017 and layoutSigRlz (I,
1018 {compact, elide, flexTyconMap}) =
1021 case interfaceSigid (Interface.original I) of
1024 SOME (layoutSigRlzAbbrev (s, I', I,
1026 flexTyconMap = flexTyconMap}))
1028 layoutSigRlzFull (I,
1031 flexTyconMap = flexTyconMap})
1036 and layoutSigRlzFull (I,
1038 elide: {strs: (int * int) option,
1039 types: (int * int) option,
1040 vals: (int * int) option},
1043 val {strs, types, vals} = Interface.dest I
1044 fun doit (a, layout, elide) =
1048 (a, [], fn ((name, range), ls) =>
1049 case layout (name, range) of
1051 | SOME l => l :: ls)
1057 val l = List.length specs
1060 then align [align (List.dropSuffix (specs, l - n)),
1062 align (List.dropPrefix (specs, l - m))]
1066 val layoutTypeSpec =
1067 fn (name, sigStr) =>
1072 flexTyconMap = flexTyconMap})
1074 fn (name, (sigStatus, sigScheme)) =>
1076 ([], name, (sigStatus, sigScheme),
1087 flexTyconMap = flexTyconMap})
1090 indent (align [doit (types, SOME o layoutTypeSpec, #types elide),
1091 doit (vals, layoutValSpec, #vals elide),
1092 doit (strs, SOME o layoutStrSpec, #strs elide)]),
1095 and layoutSigRlzAbbrev (s, I', I, {compact, flexTyconMap}) =
1098 Interface.flexibleTycons I'
1100 fun loop (strids, flexTyconMap', I, flexTyconMap) =
1102 val TyconMap.T {strs = strs', types = types'} =
1106 (strs', fn (name, flexTyconMap') =>
1109 valOf (Interface.peekStrid (I, name))
1112 (TyconMap.peekStrid (flexTyconMap, name),
1114 fn (flexTyconMap, _) => flexTyconMap)
1116 loop (name::strids, flexTyconMap', I, flexTyconMap)
1120 (types', fn (name, _) =>
1122 val (_, sigStr) = valOf (Interface.peekTycon (I, name))
1123 val flexTycon = TyconMap.peekTycon (flexTyconMap, name)
1130 layoutTypeSpec (strids,
1132 Interface.TypeStr.abs sigStr,
1135 flexTyconMap = flexTyconMap})])
1141 val () = loop ([], flexTyconMap', I, flexTyconMap)
1142 val wheres = rev (!wheres)
1144 align (Ast.Sigid.layout s :: wheres)
1148 fun layoutSigDefn (name, I, {compact, def}) =
1150 val bind = seq [str "signature ", Ast.Sigid.layout name, str " ="]
1151 val {abbrev, full} = layoutSigFlex (I,
1153 elide = {strs = NONE,
1156 val origI = Interface.original I
1159 then seq [str "(* @ ",
1160 Region.layout (Ast.Sigid.region name),
1164 align [bind, indent (full ()), indent def]
1166 if Interface.equals (I, origI)
1168 else (case abbrev () of
1174 [seq [bind, str " ", sigg],
1178 then Layout.compact lay
1185 {destroy = fn () => (destroyLayoutPrettyType ()
1186 ; destroyLayoutPrettyTyvar ()),
1187 destroyLayoutPrettyType = destroyLayoutPrettyType,
1188 destroyLayoutPrettyTyvar = destroyLayoutPrettyTyvar,
1189 localInitLayoutPrettyTyvar = localInitLayoutPrettyTyvar,
1190 layoutPrettyScheme = layoutPrettyScheme,
1191 layoutPrettyType = layoutPrettyType,
1192 layoutPrettyTyvar = layoutPrettyTyvar,
1193 layoutSigDefn = layoutSigDefn,
1194 layoutSigFlex = layoutSigFlex,
1195 layoutSigRlz = layoutSigRlz,
1196 layoutStrSpec = layoutStrSpec,
1197 layoutTypeSpec = layoutTypeSpec,
1198 layoutValSpec = layoutValSpec}
1201 fun layoutPretty I =
1203 val {destroy, layoutSigFlex, ...} =
1204 layouts {interfaceSigid = fn _ => NONE,
1205 layoutPrettyTycon = Etycon.layoutPrettyDefault,
1206 setLayoutPrettyTycon = fn _ => ()}
1211 elide = {strs = NONE,
1224 structure FlexibleTycon = FlexibleTycon
1225 structure Status = Status
1226 structure TyconMap = TyconMap
1241 | Vid.Overload _ => Var
1244 val kw: t -> string =
1249 val pretty: t -> string =
1250 fn Con => "constructor"
1251 | Exn => "exception"
1259 val >= : t * t -> bool
1265 val layout = Int.layout
1267 val op >= : t * t -> bool = op >=
1269 val c = Counter.new 0
1271 fun next () = Counter.next c
1275 ("ElaborateEnv.Time.next", Unit.layout, layout)
1281 (* The array is sorted by domain element. *)
1282 datatype ('a, 'b) t = T of {domain: 'a,
1285 uses: 'a Uses.t} array
1287 fun layout (layoutDomain, layoutRange) (T a) =
1288 Array.layout (fn {domain, range, ...} =>
1289 Layout.tuple [layoutDomain domain, layoutRange range])
1292 fun isEmpty (T a) = Array.isEmpty a
1294 fun foreach (T a, f) =
1295 Array.foreach (a, fn {domain, range, ...} => f (domain, range))
1297 fun foreachByTime (T a, f) =
1299 val a = Array.copy a
1302 (a, fn ({time = t, ...}, {time = t', ...}) =>
1308 fun peek (T a, domain: 'a, toSymbol: 'a -> Symbol.t) =
1310 (BinarySearch.search (a, fn {domain = d, ...} =>
1311 Symbol.compare (toSymbol domain, toSymbol d)),
1312 fn i => Array.sub (a, i))
1314 fun keepAll (T a, f) = T (Array.keepAll (a, f))
1316 val map: ('a, 'b) t * ('b -> 'b) -> ('a, 'b) t =
1318 T (Array.map (a, fn {domain, range, time, uses} =>
1324 val map2: ('a, 'b) t * ('a, 'b) t * ('b * 'b -> 'b) -> ('a, 'b) t =
1325 fn (T a, T a', f) =>
1327 (a, a', fn ({domain, range = r, time, uses}, {range = r', ...}) =>
1334 fun foreach2Sorted (abs: ('a * 'b) array,
1335 info: ('a, 'c) Info.t,
1336 equals: ('a * 'a -> bool),
1337 f: ('a * 'b * (int * 'c) option -> unit)): unit =
1339 val Info.T acs = info
1342 (abs, 0, fn ((a, b), i) =>
1345 if j = Array.length acs
1349 val {domain = a', range = c, ...} = Array.sub (acs, j)
1352 then (j + 1, SOME (j, c))
1355 val (i, co) = find i
1356 val () = f (a, b, co)
1364 (* ------------------------------------------------- *)
1366 (* ------------------------------------------------- *)
1368 structure Structure =
1370 datatype t = T of {interface: Interface.t option,
1371 plist: PropertyList.t,
1372 strs: (Ast.Strid.t, t) Info.t,
1373 types: (Ast.Tycon.t, TypeStr.t) Info.t,
1374 vals: (Ast.Vid.t, Vid.t * Scheme.t) Info.t}
1376 val ffi: t option ref = ref NONE
1379 fun make f (T r) = f r
1381 val interface = make #interface
1382 val plist = make #plist
1385 fun layout (T {interface, strs, vals, types, ...}) =
1387 [("interface", Option.layout Interface.layout interface),
1388 ("types", Info.layout (Ast.Tycon.layout, TypeStr.layout) types),
1389 ("vals", (Info.layout (Ast.Vid.layout,
1390 Layout.tuple2 (Vid.layout, Scheme.layout))
1392 ("strs", Info.layout (Strid.layout, layout) strs)]
1394 fun eq (s: t, s': t): bool = PropertyList.equals (plist s, plist s')
1396 (* ------------------------------------------------- *)
1398 (* ------------------------------------------------- *)
1401 fun make (field, toSymbol) (T fields, domain) =
1403 (Info.peek (field fields, domain, toSymbol),
1404 fn v as {uses, ...} =>
1405 (Uses.add (uses, domain); v))
1407 val peekStrid' = make (#strs, Ast.Strid.toSymbol)
1408 val peekVid' = make (#vals, Ast.Vid.toSymbol)
1409 val peekTycon' = make (#types, Ast.Tycon.toSymbol)
1412 fun peekStrid z = Option.map (peekStrid' z, #range)
1413 fun peekTycon z = Option.map (peekTycon' z, #range)
1414 fun peekVid z = Option.map (peekVid' z, #range)
1417 fun make (from, de) (S, x) =
1418 case peekVid (S, from x) of
1420 | SOME (vid, s) => Option.map (de vid, fn z => (z, s))
1422 val peekCon = make (Ast.Vid.fromCon, Vid.deCon)
1423 val peekExn = make (Ast.Vid.fromCon, Vid.deExn)
1424 val peekVar = make (Ast.Vid.fromVar, Vid.deVar)
1427 structure PeekResult =
1431 | UndefinedStructure of Strid.t list
1434 fun peekStrids (S, strids) =
1436 fun loop (S, strids, ac) =
1438 [] => PeekResult.Found S
1439 | strid :: strids =>
1440 case peekStrid (S, strid) of
1441 NONE => PeekResult.UndefinedStructure (rev (strid :: ac))
1442 | SOME S => loop (S, strids, strid :: ac)
1444 loop (S, strids, [])
1447 (* ------------------------------------------------- *)
1449 (* ------------------------------------------------- *)
1451 fun layouts {interfaceSigid, layoutPrettyTycon, setLayoutPrettyTycon} =
1453 val elide = {strs = NONE, types = NONE, vals = NONE}
1454 val flexTyconMap = TyconMap.empty ()
1456 val {destroy, destroyLayoutPrettyType, destroyLayoutPrettyTyvar,
1458 layoutPrettyType, layoutPrettyTyvar,
1459 layoutSigDefn, layoutSigFlex, layoutSigRlz,
1460 layoutStrSpec, layoutTypeSpec, layoutValSpec, ...} =
1461 Interface.layouts {interfaceSigid = interfaceSigid,
1462 layoutPrettyTycon = layoutPrettyTycon,
1463 setLayoutPrettyTycon = setLayoutPrettyTycon}
1465 fun layoutTypeDefn (strids, name, strStr, {compact, def}) =
1468 Interface.TypeStr.fromEnv strStr,
1471 flexTyconMap = flexTyconMap})
1472 fun layoutValDefn (strids, name, (strVid, strScheme), {compact, con, def}) =
1475 (Status.fromVid strVid, Interface.Scheme.fromEnv strScheme),
1476 {compact = compact, con = con, def = def})
1478 fun toInterface (T {interface, strs, types, vals, ...}) =
1482 fun doit (Info.T a, f) =
1486 (types, fn {domain = name, range = strStr, ...} =>
1487 (name, Interface.TypeStr.fromEnv strStr))
1490 (vals, fn {domain = name, range = (strVid, strScheme), ...} =>
1491 (name, (Status.fromVid strVid, Interface.Scheme.fromEnv strScheme)))
1494 (strs, fn {domain = name, range = S, ...} =>
1495 (name, toInterface S))
1506 fun layoutStrDefn (strids, name, S, {compact, def}) =
1508 (strids, name, toInterface S,
1512 flexTyconMap = flexTyconMap})
1513 fun layoutStr (S, {compact}) =
1518 flexTyconMap = flexTyconMap})
1522 destroyLayoutPrettyType = destroyLayoutPrettyType,
1523 destroyLayoutPrettyTyvar = destroyLayoutPrettyTyvar,
1524 layoutPrettyScheme = layoutPrettyScheme,
1525 layoutPrettyType = layoutPrettyType,
1526 layoutPrettyTyvar = layoutPrettyTyvar,
1527 layoutSigDefn = layoutSigDefn,
1528 layoutSigFlex = layoutSigFlex,
1529 layoutSigRlz = layoutSigRlz,
1530 layoutStr = layoutStr,
1531 layoutStrDefn = layoutStrDefn,
1532 layoutStrSpec = layoutStrSpec,
1533 layoutTypeDefn = layoutTypeDefn,
1534 layoutTypeSpec = layoutTypeSpec,
1535 layoutValDefn = layoutValDefn,
1536 layoutValSpec = layoutValSpec}
1539 fun layoutPretty S =
1541 val {destroy, layoutStr, ...} =
1542 layouts {interfaceSigid = fn _ => NONE,
1543 layoutPrettyTycon = Tycon.layoutPrettyDefault,
1544 setLayoutPrettyTycon = fn _ => ()}
1545 val res = #full (layoutStr (S, {compact = false})) ()
1551 (* ------------------------------------------------- *)
1553 (* ------------------------------------------------- *)
1556 datatype handleUses = Clear | Force
1557 fun make handleUses =
1561 fun doit (sel, forceRange) =
1563 val Info.T a = sel f
1566 (a, fn {range, uses, ...} =>
1570 Clear => Uses.clear uses
1571 | Force => Uses.forceUsed uses
1572 val _ = forceRange range
1577 val _ = doit (#strs, loop)
1578 val _ = doit (#types, ignore)
1579 val _ = doit (#vals, ignore)
1587 val forceUsed = make Force
1590 (* ------------------------------------------------- *)
1592 (* ------------------------------------------------- *)
1594 fun realize (S: t, tm: 'a TyconMap.t,
1598 * {nest: Strid.t list}) -> unit): unit =
1600 fun allNone (TyconMap.T {strs, types}, nest) =
1601 (Array.foreach (strs, fn (name, tm) => allNone (tm, name :: nest))
1602 ; Array.foreach (types, fn (name, flex) =>
1603 f (name, flex, NONE, {nest = nest})))
1604 fun loop (TyconMap.T {strs, types},
1605 T {strs = strs', types = types', ...},
1606 nest: Strid.t list) =
1610 (strs, strs', Ast.Strid.equals,
1613 NONE => allNone (tm, name :: nest)
1614 | SOME (_, S) => loop (tm, S, name :: nest))
1617 (types, types', Ast.Tycon.equals,
1618 fn (name, flex, opt) =>
1619 f (name, flex, Option.map (opt, #2), {nest = nest}))
1627 (* ------------------------------------------------- *)
1629 (* ------------------------------------------------- *)
1631 fun dummy (I: Interface.t, {prefix: string})
1632 : t * (t * (Tycon.t * TypeStr.t -> unit) -> unit) =
1634 val time = Time.next ()
1635 val I = Interface.copy I
1636 fun realizeLoop (TyconMap.T {strs, types}, strids) =
1640 (strs, fn (name, tm) =>
1641 (name, realizeLoop (tm, name :: strids)))
1644 (types, fn (name, flex) =>
1647 FlexibleTycon.dummyTycon
1648 (flex, name, strids,
1651 FlexibleTycon.realize
1652 (flex, TypeStr.tycon c)
1657 TyconMap.T {strs = strs, types = types}
1659 val flexible = realizeLoop (Interface.flexibleTycons I, [])
1666 val {strs, types, vals} = Interface.dest I
1668 Array.map (strs, fn (name, I) =>
1672 uses = Uses.new ()})
1674 Array.map (types, fn (name, s) =>
1676 range = Interface.TypeStr.toEnv s,
1678 uses = Uses.new ()})
1681 (vals, fn (name, (status, scheme)) =>
1683 val con = CoreML.Con.newString o Ast.Vid.toString
1684 val var = CoreML.Var.newString o Ast.Vid.toString
1687 Status.Con => Vid.Con (con name)
1688 | Status.Exn => Vid.Exn (con name)
1689 | Status.Var => Vid.Var (var name)
1692 range = (vid, Interface.Scheme.toEnv scheme),
1697 T {interface = SOME I,
1698 plist = PropertyList.new (),
1700 types = Info.T types,
1704 fun instantiate (S, f) =
1705 realize (S, flexible, fn (_, c, so, _) =>
1707 NONE => Error.bug "ElaborateEnv.Structure.dummy.instantiate"
1708 | SOME s => f (c, s))
1714 Trace.trace ("ElaborateEnv.Structure.dummy",
1715 Interface.layoutPretty o #1,
1721 (* ------------------------------------------------- *)
1722 (* FunctorClosure *)
1723 (* ------------------------------------------------- *)
1725 structure FunctorClosure =
1728 T of {apply: Structure.t * string list -> Decs.t * Structure.t option,
1729 argInterface: Interface.t,
1730 resultStructure: Structure.t option,
1731 summary: Structure.t -> Structure.t option}
1734 fun make f (T r) = f r
1736 val argInterface = make #argInterface
1739 fun layout _ = Layout.str "<functor closure>"
1741 fun apply (T {apply, ...}, S, nest) = apply (S, nest)
1744 Trace.trace3 ("ElaborateEnv.FunctorClosure.apply",
1747 List.layout String.layout,
1748 (Option.layout Structure.layout) o #2)
1751 fun forceUsed (T {resultStructure, ...}) =
1752 Option.app (resultStructure, Structure.forceUsed)
1755 (* ------------------------------------------------- *)
1757 (* ------------------------------------------------- *)
1761 datatype t = T of {plist: PropertyList.t,
1762 bass: (Ast.Basid.t, t) Info.t,
1763 fcts: (Ast.Fctid.t, FunctorClosure.t) Info.t,
1764 fixs: (Ast.Vid.t, Ast.Fixity.t) Info.t,
1765 sigs: (Ast.Sigid.t, Interface.t) Info.t,
1766 strs: (Ast.Strid.t, Structure.t) Info.t,
1767 types: (Ast.Tycon.t, TypeStr.t) Info.t,
1768 vals: (Ast.Vid.t, Vid.t * Scheme.t) Info.t}
1770 fun layout (T {bass, fcts, sigs, strs, types, vals, ...}) =
1772 [("bass", Info.layout (Ast.Basid.layout, layout) bass),
1773 ("fcts", Info.layout (Ast.Fctid.layout, FunctorClosure.layout) fcts),
1774 ("sigs", Info.layout (Ast.Sigid.layout, Interface.layout) sigs),
1775 ("strs", Info.layout (Ast.Strid.layout, Structure.layout) strs),
1776 ("types", Info.layout (Ast.Tycon.layout, TypeStr.layout) types),
1777 ("vals", (Info.layout (Ast.Vid.layout, Layout.tuple2 (Vid.layout, Scheme.layout)) vals))]
1780 (* ------------------------------------------------- *)
1782 (* ------------------------------------------------- *)
1786 type ('a, 'b) value = {domain: 'a,
1791 (* The domains of all elements in a values list have the same symbol. *)
1792 datatype ('a, 'b) t = T of ('a, 'b) value list ref
1794 fun new (): ('a, 'b) t = T (ref [])
1796 fun ! (T r) = Ref.! r
1798 fun pop (T r) = List.pop r
1801 structure NameSpace =
1803 datatype ('a, 'b) t =
1804 T of {class: 'b -> Class.t,
1805 current: ('a, 'b) Values.t list ref,
1806 defUses: {class: Class.t,
1809 uses: 'a Uses.t} list ref option,
1810 lookup: 'a -> ('a, 'b) Values.t,
1811 region: 'a -> Region.t,
1812 toSymbol: 'a -> Symbol.t}
1814 fun values (T {lookup, ...}, a) = lookup a
1816 (* ------------------------------------------------- *)
1818 (* ------------------------------------------------- *)
1820 fun empty {class, defUses, lookup, region, toSymbol} =
1823 defUses = if defUses then SOME (ref []) else NONE,
1826 toSymbol = toSymbol}
1828 (* ------------------------------------------------- *)
1830 (* ------------------------------------------------- *)
1832 fun newUses (T {class, defUses, ...}, {def, forceUsed, range}) =
1836 if not (warnUnused ()) orelse forceUsed
1837 then Uses.forceUsed u
1844 val class = class range
1846 if isSome (!Control.showDefUse)
1856 List.push (defUses, {class = class,
1865 (* ------------------------------------------------- *)
1867 (* ------------------------------------------------- *)
1869 fun ('a, 'b) peek (ns, a: 'a, {markUse: 'b -> bool})
1871 case Values.! (values (ns, a)) of
1873 | {range, uses, ...} :: _ =>
1874 (if markUse range then Uses.add (uses, a) else ()
1877 (* ------------------------------------------------- *)
1879 (* ------------------------------------------------- *)
1881 fun extend (ns as T {current, lookup, ...},
1882 {domain, forceUsed, range, scope, time, uses}) =
1884 val newUses = fn () =>
1889 forceUsed = forceUsed})
1890 val values as Values.T r = lookup domain
1899 val _ = List.push (current, values)
1901 case uses {rebind = NONE} of
1910 | all as ({domain = domain', scope = scope', uses = uses', ...} :: rest) =>
1911 if Scope.equals (scope, scope')
1913 val rebind = SOME {domain = domain', uses = uses'}
1915 case uses {rebind = rebind} of
1919 r := (make uses) :: rest
1921 else r := new () :: all
1924 (* ------------------------------------------------- *)
1926 (* ------------------------------------------------- *)
1928 fun scope (T {current, ...}: ('a, 'b) t)
1932 val _ = current := []
1937 val _ = List.foreach (c, ignore o Values.pop)
1938 val _ = current := old
1944 (* ------------------------------------------------- *)
1946 (* ------------------------------------------------- *)
1948 fun locall (T {current, ...}: ('a, 'b) t) =
1951 val _ = current := []
1956 val _ = current := []
1961 val elts = List.revMap (c2, fn values =>
1963 val {domain, range, time, uses, ...} =
1971 val _ = List.foreach (c1, ignore o Values.pop)
1972 val _ = current := old
1979 (* ------------------------------------------------- *)
1981 (* ------------------------------------------------- *)
1983 fun collect (T {current, toSymbol, ...}: ('a, 'b) t)
1984 : unit -> ('a, 'b) Info.t =
1987 val _ = current := []
1992 List.revMap (!current, fn values =>
1994 val {domain, range, time, uses, ...} =
2002 val _ = current := old
2003 val a = Array.fromList elts
2006 (a, fn ({domain = d, ...}, {domain = d', ...}) =>
2007 Symbol.<= (toSymbol d, toSymbol d'))
2014 (* ------------------------------------------------- *)
2015 (* Main Env Datatype *)
2016 (* ------------------------------------------------- *)
2021 Bas of (Basid.t, Basis.t) Values.t
2022 | Fct of (Fctid.t, FunctorClosure.t) Values.t
2023 | Fix of (Ast.Vid.t, Ast.Fixity.t) Values.t
2024 | IfcStr of (Strid.t, Interface.t) Values.t
2025 | IfcTyc of (Ast.Tycon.t, Interface.TypeStr.t) Values.t
2026 | IfcVal of (Ast.Vid.t, Interface.Status.t * Interface.Scheme.t) Values.t
2027 | Sig of (Sigid.t, Interface.t) Values.t
2028 | Str of (Strid.t, Structure.t) Values.t
2029 | Tyc of (Ast.Tycon.t, TypeStr.t) Values.t
2030 | Val of (Ast.Vid.t, Vid.t * Scheme.t) Values.t
2032 val basOpt = fn Bas z => SOME z | _ => NONE
2033 val fctOpt = fn Fct z => SOME z | _ => NONE
2034 val fixOpt = fn Fix z => SOME z | _ => NONE
2035 val ifcStrOpt = fn IfcStr z => SOME z | _ => NONE
2036 val ifcTycOpt = fn IfcTyc z => SOME z | _ => NONE
2037 val ifcValOpt = fn IfcVal z => SOME z | _ => NONE
2038 val sigOpt = fn Sig z => SOME z | _ => NONE
2039 val strOpt = fn Str z => SOME z | _ => NONE
2040 val tycOpt = fn Tyc z => SOME z | _ => NONE
2041 val valOpt = fn Val z => SOME z | _ => NONE
2045 T of {currentScope: Scope.t ref,
2046 bass: (Ast.Basid.t, Basis.t) NameSpace.t,
2047 fcts: (Ast.Fctid.t, FunctorClosure.t) NameSpace.t,
2048 fixs: (Ast.Vid.t, Ast.Fixity.t) NameSpace.t,
2049 interface: {strs: (Ast.Strid.t, Interface.t) NameSpace.t,
2050 types: (Ast.Tycon.t, Interface.TypeStr.t) NameSpace.t,
2051 vals: (Ast.Vid.t, Interface.Status.t * Interface.Scheme.t) NameSpace.t},
2052 lookup: Symbol.t -> All.t list ref,
2053 sigs: (Ast.Sigid.t, Interface.t) NameSpace.t,
2054 strs: (Ast.Strid.t, Structure.t) NameSpace.t,
2055 types: (Ast.Tycon.t, TypeStr.t) NameSpace.t,
2056 vals: (Ast.Vid.t, Vid.t * Scheme.t) NameSpace.t}
2058 fun sizeMessage (E: t): Layout.t =
2060 val size = MLton.size
2063 record [("total", Int.layout (size E))]
2065 (* quell unused warning *)
2068 (* ------------------------------------------------- *)
2070 (* ------------------------------------------------- *)
2074 val {get = lookupAll: Symbol.t -> All.t list ref, ...} =
2075 Property.get (Symbol.plist, Property.initFun (fn _ => ref []))
2076 fun ('a, 'b) make (class: 'b -> Class.t,
2077 region: 'a -> Region.t,
2078 toSymbol: 'a -> Symbol.t,
2080 extract: All.t -> ('a, 'b) Values.t option,
2081 make: ('a, 'b) Values.t -> All.t)
2082 : ('a, 'b) NameSpace.t =
2084 fun lookup (a: 'a): ('a, 'b) Values.t =
2086 val r = lookupAll (toSymbol a)
2088 case List.peekMap (!r, extract) of
2091 val v = Values.new ()
2092 val _ = List.push (r, make v)
2099 NameSpace.empty {class = class,
2103 toSymbol = toSymbol}
2105 val bass = make (fn _ => Class.Bas, Basid.region, Basid.toSymbol,
2106 false, All.basOpt, All.Bas)
2107 val fcts = make (fn _ => Class.Fct, Fctid.region, Fctid.toSymbol,
2108 !Control.keepDefUse, All.fctOpt, All.Fct)
2109 val fixs = make (fn _ => Class.Fix, Ast.Vid.region, Ast.Vid.toSymbol,
2110 false, All.fixOpt, All.Fix)
2111 val sigs = make (fn _ => Class.Sig, Sigid.region, Sigid.toSymbol,
2112 !Control.keepDefUse, All.sigOpt, All.Sig)
2113 val strs = make (fn _ => Class.Str, Strid.region, Strid.toSymbol,
2114 !Control.keepDefUse, All.strOpt, All.Str)
2115 val types = make (fn _ => Class.Typ, Ast.Tycon.region, Ast.Tycon.toSymbol,
2116 !Control.keepDefUse, All.tycOpt, All.Tyc)
2117 val vals = make (Vid.class o #1, Ast.Vid.region, Ast.Vid.toSymbol,
2118 !Control.keepDefUse, All.valOpt, All.Val)
2121 val strs = make (fn _ => Class.Str, Strid.region, Strid.toSymbol,
2122 false, All.ifcStrOpt, All.IfcStr)
2123 val types = make (fn _ => Class.Typ, Ast.Tycon.region, Ast.Tycon.toSymbol,
2124 false, All.ifcTycOpt, All.IfcTyc)
2125 val vals = make (Status.class o #1, Ast.Vid.region, Ast.Vid.toSymbol,
2126 false, All.ifcValOpt, All.IfcVal)
2128 val interface = {strs = strs, types = types, vals = vals}
2131 T {currentScope = ref (Scope.new ()),
2135 interface = interface,
2143 (* ------------------------------------------------- *)
2145 (* ------------------------------------------------- *)
2148 fun foreach (T {lookup, ...}, s,
2150 interface = {strs = ifcStrs, types = ifcTypes, vals = ifcVals},
2151 sigs, strs, types, vals}) =
2153 (! (lookup s), fn a =>
2155 datatype z = datatype All.t
2161 | IfcStr vs => ifcStrs vs
2162 | IfcTyc vs => ifcTypes vs
2163 | IfcVal vs => ifcVals vs
2166 | Tyc vs => types vs
2170 fun foreachDefinedSymbol (E, z) =
2171 Symbol.foreach (fn s => foreach (E, s, z))
2174 (* ------------------------------------------------- *)
2176 (* ------------------------------------------------- *)
2178 fun current (E, keep: {hasUse: bool, scope: Scope.t} -> bool) =
2182 val ifcStrs = ref []
2183 val ifcTypes = ref []
2184 val ifcVals = ref []
2192 | (z as {scope, uses, ...}) :: _ =>
2193 if keep {hasUse = Uses.hasUse uses, scope = scope}
2194 then List.push (ac, z)
2197 foreachDefinedSymbol (E, {bass = doit bass,
2200 interface = {strs = doit ifcStrs,
2201 types = doit ifcTypes,
2202 vals = doit ifcVals},
2207 fun ('a, 'b) finish (r: ('a, 'b) Values.value list ref, toSymbol: 'a -> Symbol.t) () =
2211 (!r, fn {domain, range, time, uses, ...} =>
2212 {domain = domain, range = range,
2213 time = time, uses = uses})
2216 (a, fn ({domain = d, ...}, {domain = d', ...}) =>
2217 Symbol.<= (toSymbol d, toSymbol d'))
2222 {bass = finish (bass, Basid.toSymbol),
2223 fcts = finish (fcts, Fctid.toSymbol),
2224 interface = {strs = finish (ifcStrs, Strid.toSymbol),
2225 types = finish (ifcTypes, Ast.Tycon.toSymbol),
2226 vals = finish (ifcVals, Ast.Vid.toSymbol)},
2227 sigs = finish (sigs, Sigid.toSymbol),
2228 strs = finish (strs, Strid.toSymbol),
2229 types = finish (types, Ast.Tycon.toSymbol),
2230 vals = finish (vals, Ast.Vid.toSymbol)}
2233 (* ------------------------------------------------- *)
2235 (* ------------------------------------------------- *)
2237 fun snapshot (E as T {currentScope, bass, fcts, fixs, sigs, strs, types, vals, ...})
2238 : (unit -> 'a) -> 'a =
2240 val add: (Scope.t -> unit) list ref = ref []
2241 (* Push onto add everything currently in scope. *)
2242 fun doit (NameSpace.T {current, ...}) (v as Values.T vs) =
2245 | {domain, range, uses, ...} :: _ =>
2248 (List.push (vs, {domain = domain,
2251 time = Time.next (),
2253 ; List.push (current, v)))
2255 foreachDefinedSymbol (E, {bass = doit bass,
2258 interface = {strs = ignore,
2268 val s0 = Scope.new ()
2269 val restore: (unit -> unit) list ref = ref []
2270 fun doit (NameSpace.T {current, ...}) =
2272 val current0 = !current
2273 val _ = current := []
2275 List.push (restore, fn () =>
2276 (List.foreach (!current, fn v => ignore (Values.pop v))
2277 ; current := current0))
2279 val _ = (doit bass; doit fcts; doit fixs; doit sigs
2280 ; doit strs; doit types; doit vals)
2281 val _ = List.foreach (!add, fn f => f s0)
2282 (* Clear out any symbols that weren't available in the old scope. *)
2283 fun doit (Values.T vs) =
2289 | {scope, ...} :: _ =>
2290 if Scope.equals (s0, scope)
2293 ; List.push (restore, fn () => vs := cur))
2296 (* Can't use foreachToplevelSymbol here, because a constructor C may
2297 * have been defined in a local scope but may not have been defined
2298 * at the snapshot point. This will make the identifier C, which
2299 * originally would have elaborated as a variable instead elaborate
2302 foreachDefinedSymbol (E, {bass = doit,
2305 interface = {strs = ignore,
2312 val s1 = !currentScope
2313 val _ = currentScope := s0
2315 val _ = currentScope := s1
2316 val _ = List.foreach (!restore, fn f => f ())
2322 (* ------------------------------------------------- *)
2324 (* ------------------------------------------------- *)
2327 fun make sel (T r, a) = NameSpace.peek (sel r, a, {markUse = fn _ => true})
2329 val peekBasid = make #bass
2330 val peekFctid = make #fcts
2331 val peekFix = make #fixs
2332 val peekIfcStrid = make (#strs o #interface)
2333 val peekIfcTycon= make (#types o #interface)
2334 val peekSigid = make #sigs
2335 val peekStrid = make #strs
2336 val peekTycon = make #types
2337 val peekVid = make #vals
2338 fun peekVar (E, x) =
2339 case peekVid (E, Ast.Vid.fromVar x) of
2341 | SOME (vid, s) => Option.map (Vid.deVar vid, fn x => (x, s))
2344 fun peekCon (T {vals, ...}, c: Ast.Con.t): (Con.t * Scheme.t) option =
2345 case NameSpace.peek (vals, Ast.Vid.fromCon c,
2346 {markUse = fn (vid, _) => isSome (Vid.deCon vid)}) of
2348 | SOME (vid, s) => Option.map (Vid.deCon vid, fn c => (c, s))
2350 fun peekExn (T {vals, ...}, c: Ast.Con.t): (Con.t * Scheme.t) option =
2351 case NameSpace.peek (vals, Ast.Vid.fromCon c,
2352 {markUse = fn (vid, _) => isSome (Vid.deExn vid)}) of
2354 | SOME (vid, s) => Option.map (Vid.deExn vid, fn c => (c, s))
2356 structure PeekResult =
2360 | UndefinedStructure of Strid.t list
2363 val toOption: 'a t -> 'a option =
2364 fn Found z => SOME z
2369 fun make (split: 'a -> Strid.t list * 'b,
2370 peek: t * 'b -> 'c option,
2371 strPeek: Structure.t * 'b -> 'c option) (E, x) =
2373 val (strids, x) = split x
2376 [] => (case peek (E, x) of
2377 NONE => PeekResult.Undefined
2378 | SOME z => PeekResult.Found z)
2379 | strid :: strids =>
2380 case peekStrid (E, strid) of
2381 NONE => PeekResult.UndefinedStructure [strid]
2383 case Structure.peekStrids (S, strids) of
2384 Structure.PeekResult.Found S =>
2385 (case strPeek (S, x) of
2386 NONE => PeekResult.Undefined
2387 | SOME z => PeekResult.Found z)
2388 | Structure.PeekResult.UndefinedStructure ss =>
2389 PeekResult.UndefinedStructure (strid :: ss)
2393 make (Ast.Longstrid.split, peekStrid, Structure.peekStrid)
2395 make (Longtycon.split, peekTycon, Structure.peekTycon)
2396 val peekLongvar = make (Ast.Longvar.split, peekVar, Structure.peekVar)
2397 val peekLongvid = make (Ast.Longvid.split, peekVid, Structure.peekVid)
2398 val peekLongcon = make (Ast.Longcon.split, peekCon, Structure.peekCon)
2399 val peekLongexn = make (Ast.Longcon.split, peekExn, Structure.peekExn)
2402 (* ------------------------------------------------- *)
2404 (* ------------------------------------------------- *)
2406 fun unbound (r: Region.t, className, x: Layout.t): unit =
2409 seq [str "undefined ", str className, str ": ", x],
2412 fun lookupBasid (E, x) =
2413 case peekBasid (E, x) of
2414 NONE => (unbound (Ast.Basid.region x, "basis", Ast.Basid.layout x)
2418 fun lookupFctid (E, x) =
2419 case peekFctid (E, x) of
2420 NONE => (unbound (Ast.Fctid.region x, "functor", Ast.Fctid.layout x)
2424 fun lookupSigid (E, x) =
2425 case peekSigid (E, x) of
2426 NONE => (unbound (Ast.Sigid.region x, "signature", Ast.Sigid.layout x)
2430 fun lookupStrid (E, x) =
2431 case peekStrid (E, x) of
2432 NONE => (unbound (Ast.Strid.region x, "structure", Ast.Strid.layout x)
2437 fun make (peek: t * 'a -> 'b PeekResult.t,
2439 region: 'a -> Region.t,
2440 layout: 'a -> Layout.t)
2441 (E: t, x: 'a): 'b option =
2443 datatype z = datatype PeekResult.t
2447 | UndefinedStructure ss =>
2448 (unbound (region x, "structure", layoutStrids ss); NONE)
2450 (unbound (region x, className, layout x); NONE)
2463 val lookupLongstrid =
2464 make (peekLongstrid,
2466 Ast.Longstrid.region,
2467 Ast.Longstrid.layout)
2468 val lookupLongtycon =
2469 make (peekLongtycon,
2471 Ast.Longtycon.region,
2472 Ast.Longtycon.layout)
2485 val peekLongcon = PeekResult.toOption o peekLongcon
2487 (* ------------------------------------------------- *)
2489 (* ------------------------------------------------- *)
2492 fun extend (T (r as {currentScope, ...}), sel,
2493 domain: 'a, range: 'b, forceUsed: bool, uses) =
2497 forceUsed = forceUsed,
2499 scope = !currentScope,
2500 time = Time.next (),
2503 fun extendBasid (E, d, r) = extend (E, #bass, d, r, false, Uses.Extend.new)
2504 fun extendFctid (E, d, r) = extend (E, #fcts, d, r, false, Uses.Extend.new)
2505 fun extendFix (E, d, r) = extend (E, #fixs, d, r, false, Uses.Extend.new)
2506 fun extendSigid (E, d, r) = extend (E, #sigs, d, r, false, Uses.Extend.new)
2507 fun extendStrid (E, d, r) = extend (E, #strs, d, r, false, Uses.Extend.new)
2508 fun extendVals (E, d, r, eu) = extend (E, #vals, d, r, false, eu)
2509 fun extendTycon (E, d, s, {forceUsed, isRebind}) =
2513 datatype z = datatype TypeStr.node
2515 case TypeStr.node s of
2516 Datatype {cons, ...} =>
2518 (Cons.dest cons, fn {con, name, scheme, uses} =>
2519 extendVals (E, Ast.Vid.fromCon name,
2520 (Vid.Con con, scheme),
2521 Uses.Extend.old uses))
2525 extend (E, #types, d, s, forceUsed,
2526 Uses.Extend.fromIsRebind {isRebind = isRebind})
2532 fun extendExn (E, c, c', s) =
2533 extendVals (E, Ast.Vid.fromCon c, (Vid.Exn c', s), Uses.Extend.new)
2535 fun extendVar (E, x, x', s, ir) =
2536 extendVals (E, Ast.Vid.fromVar x, (Vid.Var x', s),
2537 Uses.Extend.fromIsRebind ir)
2541 ("ElaborateEnv.extendVar",
2542 fn (_, x, x', s, _) =>
2543 Layout.tuple [Ast.Var.layout x, Var.layout x', Scheme.layout s],
2547 fun extendOverload (E, p, x, yts, s) =
2548 extendVals (E, Ast.Vid.fromVar x, (Vid.Overload (p, yts), s),
2551 (* ------------------------------------------------- *)
2553 (* ------------------------------------------------- *)
2555 fun scopeAll (T {currentScope, bass, fcts, fixs, sigs, strs, types, vals, ...}, th) =
2557 val b = NameSpace.scope bass
2558 val fc = NameSpace.scope fcts
2559 val f = NameSpace.scope fixs
2560 val si = NameSpace.scope sigs
2561 val s = NameSpace.scope strs
2562 val t = NameSpace.scope types
2563 val v = NameSpace.scope vals
2564 val s0 = !currentScope
2565 val _ = currentScope := Scope.new ()
2567 val _ = (b (); fc (); f (); si (); s (); t (); v ())
2568 val _ = currentScope := s0
2573 fun scope (T {currentScope, fixs, strs, types, vals, ...}, th) =
2575 val f = NameSpace.scope fixs
2576 val s = NameSpace.scope strs
2577 val t = NameSpace.scope types
2578 val v = NameSpace.scope vals
2579 val s0 = !currentScope
2580 val _ = currentScope := Scope.new ()
2582 val _ = (f (); s (); t (); v ())
2583 val _ = currentScope := s0
2588 (* ------------------------------------------------- *)
2590 (* ------------------------------------------------- *)
2593 fun locall (ns, s0) =
2595 val f = NameSpace.locall ns
2605 List.foreach (elts, fn {domain, range, time, uses} =>
2607 (ns, {domain = domain,
2612 uses = Uses.Extend.old uses}))
2619 fun localAll (T {currentScope, bass, fcts, fixs, sigs, strs, types, vals, ...},
2622 val s0 = !currentScope
2623 val bass = locall (bass, s0)
2624 val fcts = locall (fcts, s0)
2625 val fixs = locall (fixs, s0)
2626 val sigs = locall (sigs, s0)
2627 val strs = locall (strs, s0)
2628 val types = locall (types, s0)
2629 val vals = locall (vals, s0)
2630 val _ = currentScope := Scope.new ()
2637 val types = types ()
2639 val _ = currentScope := Scope.new ()
2641 val _ = (bass (); fcts (); fixs (); sigs (); strs (); types (); vals ())
2642 val _ = currentScope := s0
2647 fun localModule (T {currentScope, fixs, strs, types, vals, ...},
2650 val s0 = !currentScope
2651 val fixs = locall (fixs, s0)
2652 val strs = locall (strs, s0)
2653 val types = locall (types, s0)
2654 val vals = locall (vals, s0)
2655 val _ = currentScope := Scope.new ()
2659 val types = types ()
2661 val _ = currentScope := Scope.new ()
2663 val _ = (fixs (); strs (); types (); vals ())
2664 val _ = currentScope := s0
2669 (* Can't eliminate the use of strs in localCore, because openn still modifies
2670 * module level constructs.
2672 val localCore = localModule
2675 (* ------------------------------------------------- *)
2676 (* makeBasis / makeStructure *)
2677 (* ------------------------------------------------- *)
2679 fun makeBasis (T {currentScope, bass, fcts, fixs, sigs, strs, types, vals, ...}, make) =
2681 val bass = NameSpace.collect bass
2682 val fcts = NameSpace.collect fcts
2683 val fixs = NameSpace.collect fixs
2684 val sigs = NameSpace.collect sigs
2685 val strs = NameSpace.collect strs
2686 val types = NameSpace.collect types
2687 val vals = NameSpace.collect vals
2688 val s0 = !currentScope
2689 val _ = currentScope := Scope.new ()
2691 val B = Basis.T {plist = PropertyList.new (),
2699 val _ = currentScope := s0
2704 fun makeStructure (T {currentScope, fixs, strs, types, vals, ...}, make) =
2706 val f = NameSpace.collect fixs
2707 val s = NameSpace.collect strs
2708 val t = NameSpace.collect types
2709 val v = NameSpace.collect vals
2710 val s0 = !currentScope
2711 val _ = currentScope := Scope.new ()
2714 val S = Structure.T {interface = NONE,
2715 plist = PropertyList.new (),
2719 val _ = currentScope := s0
2724 (* ------------------------------------------------- *)
2726 (* ------------------------------------------------- *)
2729 fun openn (ns, Info.T a, s) =
2730 Array.foreach (a, fn {domain, range, time, uses} =>
2731 NameSpace.extend (ns, {domain = domain,
2736 uses = Uses.Extend.old uses}))
2738 fun openBasis (T {currentScope, bass, fcts, fixs, sigs, strs, vals, types, ...},
2739 Basis.T {bass = bass',
2745 types = types', ...}): unit =
2747 val s0 = !currentScope
2748 val _ = openn (bass, bass', s0)
2749 val _ = openn (fcts, fcts', s0)
2750 val _ = openn (fixs, fixs', s0)
2751 val _ = openn (sigs, sigs', s0)
2752 val _ = openn (strs, strs', s0)
2753 val _ = openn (vals, vals', s0)
2754 val _ = openn (types, types', s0)
2759 fun openStructure (T {currentScope, strs, vals, types, ...},
2760 Structure.T {strs = strs',
2762 types = types', ...}): unit =
2764 val s0 = !currentScope
2765 val _ = openn (strs, strs', s0)
2766 val _ = openn (vals, vals', s0)
2767 val _ = openn (types, types', s0)
2773 (* ------------------------------------------------- *)
2775 (* ------------------------------------------------- *)
2777 (* Force everything that is currently in scope to be marked as used. *)
2780 fun doit forceRange (Values.T r) =
2783 | {uses, range, ...} :: _ =>
2784 (Uses.forceUsed uses
2787 foreachDefinedSymbol
2788 (E, {bass = doit ignore,
2789 fcts = doit FunctorClosure.forceUsed,
2791 interface = {strs = doit ignore,
2792 types = doit ignore,
2793 vals = doit ignore},
2795 strs = doit Structure.forceUsed,
2796 types = doit ignore,
2797 vals = doit ignore})
2802 fun forceUsedLocal (T {currentScope, bass, fcts, fixs, sigs, strs, types, vals, ...},
2805 fun doit (forceRange: 'b -> unit, ns as NameSpace.T {current, ...}, s0) =
2808 val _ = current := []
2813 val lift = List.revMap (c, Values.pop)
2814 val _ = current := old
2817 (lift, fn {domain, range, time, uses, ...} =>
2818 (Uses.forceUsed uses
2820 ; NameSpace.extend (ns, {domain = domain,
2825 uses = Uses.Extend.old uses})))
2830 val s0 = !currentScope
2831 val bass = doit (ignore, bass, s0)
2832 val fcts = doit (FunctorClosure.forceUsed, fcts, s0)
2833 val fixs = doit (ignore, fixs, s0)
2834 val sigs = doit (ignore, sigs, s0)
2835 val strs = doit (Structure.forceUsed, strs, s0)
2836 val types = doit (ignore, types, s0)
2837 val vals = doit (ignore, vals, s0)
2838 val _ = currentScope := Scope.new ()
2840 val _ = (bass(); fcts (); fixs (); sigs (); strs (); types (); vals ())
2841 val _ = currentScope := s0
2846 (* ------------------------------------------------- *)
2848 (* ------------------------------------------------- *)
2850 structure InterfaceEnv =
2854 val lookupLongtycon = lookupLongtycon
2855 val peekIfcStrid = peekIfcStrid
2856 val peekIfcTycon = peekIfcTycon
2857 val lookupSigid = lookupSigid
2863 structure FlexibleTycon = FlexibleTycon
2864 structure Scheme = Scheme
2865 structure Status = Status
2866 structure TypeStr = TypeStr
2871 (* ------------------------------------------------- *)
2873 (* ------------------------------------------------- *)
2875 val peekStrid = Env.peekIfcStrid
2876 val peekTycon = Env.peekIfcTycon
2878 (* ------------------------------------------------- *)
2880 (* ------------------------------------------------- *)
2882 val lookupSigid = Env.lookupSigid
2884 fun lookupLongtycon (E: t, long: Longtycon.t): TypeStr.t option =
2887 Option.map (Env.lookupLongtycon (E, long), TypeStr.fromEnv)
2888 val (strids, c) = Longtycon.split long
2892 (case peekTycon (E, c) of
2893 NONE => lookupEnv ()
2896 case peekStrid (E, s) of
2897 NONE => lookupEnv ()
2899 ((fn opt => Option.map (opt, #2)) o Interface.lookupLongtycon)
2900 (I, Longtycon.long (ss, c), Longtycon.region long,
2904 (* ------------------------------------------------- *)
2906 (* ------------------------------------------------- *)
2908 datatype z = MustExtend of Region.t | MustRebind
2910 fun extend (T {currentScope, interface, ...}, sel,
2911 domain, range, kind, must) =
2917 scope = !currentScope,
2918 time = Time.next (),
2919 uses = (case must of
2920 MustExtend extendRegion =>
2923 val NameSpace.T {region, toSymbol, ...} = sel interface
2926 SOME {domain = domain', ...} =>
2932 seq [str "duplicate ",
2934 str " specification: ",
2935 Symbol.layout (toSymbol domain)],
2937 (if Region.equals (extendRegion,
2940 else [domain', domain],
2941 fn d => seq [str "spec at: ",
2942 Region.layout (region d)]))
2952 Error.bug "ElaborateEnv.InterfaceEnv.extend: MustRebind"
2953 | SOME {uses, ...} =>
2956 fun extendStrid (E, s, I, r) =
2957 extend (E, #strs, s, I, "structure", MustExtend r)
2959 fun extendTycon (E, c, s, r) =
2960 extend (E, #types, c, s, "type", MustExtend r)
2962 fun extendVid (E, v, st, s, r) =
2963 extend (E, #vals, v, (st, s), "value", MustExtend r)
2965 fun rebindTycon (E, c, s) =
2966 extend (E, #types, c, s, "type", MustRebind)
2968 (* ------------------------------------------------- *)
2970 (* ------------------------------------------------- *)
2972 fun makeInterface (T {currentScope, interface = {strs, types, vals}, ...},
2975 val s = NameSpace.collect strs
2976 val t = NameSpace.collect types
2977 val v = NameSpace.collect vals
2978 val s0 = !currentScope
2979 val _ = currentScope := Scope.new ()
2982 val s = Array.map (s, fn {domain, range, ...} => (domain, range))
2984 val t = Array.map (t, fn {domain, range, ...} => (domain, range))
2986 val v = Array.map (v, fn {domain, range = (status, scheme), ...} =>
2987 (domain, (status, scheme)))
2988 val I = Interface.new {isClosed = isTop,
2990 strs = s, types = t, vals = v}
2991 val _ = currentScope := s0
2996 (* ------------------------------------------------- *)
2998 (* ------------------------------------------------- *)
3000 fun openInterface (E, I, r: Region.t) =
3002 val {strs, vals, types} = Interface.dest I
3003 val _ = Array.foreach (strs, fn (s, I) => extendStrid (E, s, I, r))
3004 val _ = Array.foreach (types, fn (c, s) => extendTycon (E, c, s, r))
3005 val _ = Array.foreach (vals, fn (x, (s, sc)) =>
3006 extendVid (E, x, s, sc, r))
3011 (* ------------------------------------------------- *)
3013 (* ------------------------------------------------- *)
3015 val extendStrid = fn (E, s, I) => extendStrid (E, s, I, Strid.region s)
3017 val extendTycon = fn (E, c, s) => extendTycon (E, c, s, Ast.Tycon.region c)
3019 val extendVid = fn (E, v, st, s) => extendVid (E, v, st, s, Ast.Vid.region v)
3021 fun extendCon (E, c, s) =
3022 extendVid (E, Ast.Vid.fromCon c, Status.Con, s)
3024 fun extendExn (E, c, s) =
3025 extendVid (E, Ast.Vid.fromCon c, Status.Exn, s)
3027 (* ------------------------------------------------- *)
3028 (* makeLayoutPrettyFlexTycon *)
3029 (* ------------------------------------------------- *)
3031 fun genLayoutPrettyFlexTycon {prefixUnset} =
3033 val {destroy = destroyLayoutPrettyFlexTycon: unit -> unit,
3034 get = layoutPrettyFlexTycon: FlexibleTycon.t -> Layout.t,
3035 set = setLayoutPrettyFlexTycon: FlexibleTycon.t * Layout.t -> unit} =
3037 (FlexibleTycon.plist,
3040 let val l = FlexibleTycon.layoutPrettyDefault f
3041 in if prefixUnset then seq [str "??.", l] else l
3043 fun doFlexTycon (flex, name, strids: Strid.t list) =
3045 val name = layoutLongRev (strids, Ast.Tycon.layout name)
3047 setLayoutPrettyFlexTycon (flex, name)
3049 fun loopFlexTyconMap (TyconMap.T {strs, types}, strids) =
3053 (types, fn (name, flex) =>
3054 doFlexTycon (flex, name, strids))
3057 (strs, fn (name, flexTyconMap) =>
3058 loopFlexTyconMap (flexTyconMap, name::strids))
3063 {destroy = destroyLayoutPrettyFlexTycon,
3064 layoutPrettyFlexTycon = layoutPrettyFlexTycon,
3065 loopFlexTyconMap = loopFlexTyconMap}
3070 val makeInterfaceEnv = fn E => E
3072 (* ------------------------------------------------- *)
3073 (* makeLayoutPrettyTycon *)
3074 (* ------------------------------------------------- *)
3076 fun genLayoutPrettyTycon {prefixUnset} =
3078 val {destroy = destroyLayoutPrettyTycon: unit -> unit,
3079 get = layoutPrettyTycon: Tycon.t -> Layout.t,
3080 set = setLayoutPrettyTycon: Tycon.t * Layout.t -> unit} =
3085 let val l = Tycon.layoutPrettyDefault c
3086 in if prefixUnset then seq [str "?.", l] else l
3088 val {destroy = destroyTyconShortest,
3089 get = tyconShortest: Tycon.t -> (int * int) option ref, ...} =
3090 Property.destGet (Tycon.plist, Property.initFun (fn _ => ref NONE))
3091 fun doType (typeStr: TypeStr.t,
3095 strids: Strid.t list): unit =
3096 case TypeStr.toTyconOpt typeStr of
3100 val r = tyconShortest c
3103 val _ = r := SOME (priority, length)
3104 val name = layoutLongRev (strids, Ast.Tycon.layout name)
3106 setLayoutPrettyTycon (c, name)
3111 | SOME (priority', length') =>
3112 (case Int.compare (priority, priority') of
3114 | EQUAL => if length >= length'
3119 val {destroy = destroyStrShortest,
3120 get = strShortest: Structure.t -> (int * int) option ref, ...} =
3121 Property.destGet (Structure.plist, Property.initFun (fn _ => ref NONE))
3122 fun loopStr (s as Structure.T {strs, types, ...},
3125 strids: Strid.t list): unit =
3127 val r = strShortest s
3130 val _ = r := SOME (priority, length)
3131 (* Process the declarations in decreasing order of
3132 * definition time so that later declarations will be
3133 * processed first, and hence will take precedence.
3137 (types, fn (name, typeStr) =>
3138 doType (typeStr, name, priority, length, strids))
3141 (strs, fn (strid, str) =>
3142 loopStr (str, priority, 1 + length, strid::strids))
3149 | SOME (priority', length') =>
3150 (case Int.compare (priority, priority') of
3152 | EQUAL => if length >= length'
3157 fun loopFlexTyconMap (tm: FlexibleTycon.t TyconMap.t, priority, length: int, strids: Strid.t list): unit =
3159 val TyconMap.T {strs, types} = tm
3162 (types, fn (name, flex) =>
3163 doType (FlexibleTycon.toEnv flex, name, priority, length, strids))
3166 (strs, fn (strid, tm) =>
3167 loopFlexTyconMap (tm, priority, 1 + length, strid::strids))
3171 fun mk loop (z, priority, strids) =
3172 loop (z, priority, length strids, strids)
3174 {destroy = fn () => (destroyStrShortest ()
3175 ; destroyTyconShortest ()
3176 ; destroyLayoutPrettyTycon ()),
3177 layoutPrettyTycon = layoutPrettyTycon,
3178 setLayoutPrettyTycon = setLayoutPrettyTycon,
3179 loopStr = mk loopStr,
3180 loopFlexTyconMap = mk loopFlexTyconMap}
3183 fun makeLayoutPrettyTycon (E, {prefixUnset}) =
3185 val {destroy = destroyLayoutPrettyTycon,
3186 layoutPrettyTycon, setLayoutPrettyTycon,
3188 genLayoutPrettyTycon {prefixUnset = prefixUnset}
3191 val {strs, types, ...} = current (E, fn _ => true)
3193 loopStr (Structure.T {interface = NONE,
3194 plist = PropertyList.new (),
3197 vals = Info.T (Array.new0 ())},
3200 val pre = ClearablePromise.delay pre
3202 {destroy = fn () => (ClearablePromise.clear pre
3203 ; destroyLayoutPrettyTycon ()),
3204 layoutPrettyTycon = fn c => (ClearablePromise.force pre
3205 ; layoutPrettyTycon c),
3206 setLayoutPrettyTycon = setLayoutPrettyTycon,
3210 fun makeLayoutPrettyTyconAndFlexTycon (E, _, Io, {prefixUnset}) =
3212 val {destroy = destroyLayoutPrettyFlexTycon,
3213 layoutPrettyFlexTycon, loopFlexTyconMap, ...} =
3214 InterfaceEnv.genLayoutPrettyFlexTycon {prefixUnset = prefixUnset}
3215 val {destroy = destroyLayoutPrettyTycon,
3216 layoutPrettyTycon, setLayoutPrettyTycon,
3218 genLayoutPrettyTycon {prefixUnset = prefixUnset}
3221 val {strs, types, interface = {strs = ifcStrs, types = ifcTypes, ...}, ...} =
3222 current (E, fn _ => true)
3224 val types = types ()
3225 val ifcStrs = ifcStrs ()
3226 val ifcTypes = ifcTypes ()
3228 fun doit (env, ifc, toSymbol) =
3232 (env, fn {domain, ...} =>
3233 case Info.peek (ifc, domain, toSymbol) of
3237 val () = loopStr (Structure.T {interface = NONE,
3238 plist = PropertyList.new (),
3239 strs = doit (strs, ifcStrs, Ast.Strid.toSymbol),
3240 types = doit (types, ifcTypes, Ast.Tycon.toSymbol),
3241 vals = Info.T (Array.new0 ())},
3246 let val Info.T a = ifc
3247 in Array.map (a, fn {domain, range, ...} => (domain, range))
3249 val I = Interface.new {isClosed = true,
3251 strs = doit ifcStrs,
3252 types = doit ifcTypes,
3253 vals = Array.new0 ()}
3255 val () = loopFlexTyconMap (Interface.flexibleTycons I, [])
3257 val () = Option.foreach
3259 loopFlexTyconMap (Interface.flexibleTycons I,
3264 val pre = ClearablePromise.delay pre
3266 {destroy = fn () => (ClearablePromise.clear pre
3267 ; destroyLayoutPrettyFlexTycon ()
3268 ; destroyLayoutPrettyTycon ()),
3269 layoutPrettyTycon = fn c => (ClearablePromise.force pre
3270 ; layoutPrettyTycon c),
3271 layoutPrettyFlexTycon = fn f => (ClearablePromise.force pre
3272 ; layoutPrettyFlexTycon f),
3273 setLayoutPrettyTycon = setLayoutPrettyTycon}
3276 fun output (E: t, out, {compact, def, flat, onlyCurrent, prefixUnset}): unit =
3281 val T {currentScope, ...} = E
3282 val currentScope = !currentScope
3285 Scope.equals (scope, currentScope)
3288 val {bass, fcts, sigs, strs, types, vals, ...} = current (E, keep)
3293 val types = types ()
3296 val {get = interfaceSigid: Interface.t -> (Sigid.t * Interface.t) option,
3297 set = setInterfaceSigid, ...} =
3298 Property.getSet (Interface.plist, Property.initConst NONE)
3299 val _ = Array.foreach (let val Info.T sigs = sigs in sigs end,
3300 fn {domain = s, range = I, ...} =>
3301 setInterfaceSigid (I, SOME (s, I)))
3302 val {destroy = destroyLayoutPrettyTycon,
3303 layoutPrettyTycon, setLayoutPrettyTycon,
3305 makeLayoutPrettyTycon (E, {prefixUnset = prefixUnset})
3307 val empty = Layout.empty
3308 val indent = fn l => Layout.indent (l, 3)
3309 val paren = Layout.paren
3311 val {destroy, layoutSigDefn, layoutSigFlex,
3312 layoutStr, layoutStrDefn,
3313 layoutTypeDefn, layoutValDefn, ...} =
3314 Structure.layouts {interfaceSigid = interfaceSigid,
3315 layoutPrettyTycon = layoutPrettyTycon,
3316 setLayoutPrettyTycon = setLayoutPrettyTycon}
3317 val destroy = fn () =>
3318 (destroy (); destroyLayoutPrettyTycon ())
3320 fun layoutFctDefn (name, FunctorClosure.T {argInterface, summary, ...},
3324 seq [str "functor ", Fctid.layout name]
3325 val argId = Strid.uArg (Fctid.toString name)
3326 val {abbrev = argAbbrev, full = argFull} =
3329 seq [Strid.layout argId, str ":"]
3330 val {abbrev, full} =
3331 layoutSigFlex (argInterface,
3333 elide = {strs = NONE, types = NONE, vals = NONE}})
3337 | SOME sigg => SOME (seq [bind, str " ", sigg])
3339 align [bind, indent (full ())]
3341 {abbrev = abbrev, full = full}
3343 val arg = #1 (Structure.dummy (argInterface, {prefix = Strid.toString argId ^ "."}))
3344 val () = loopStr (arg, 1, [argId])
3345 val {abbrev = resAbbrev, full = resFull} =
3347 NONE => {abbrev = SOME (str "???"), full = fn () => str "???"}
3349 val resId = Strid.uRes (Fctid.toString name)
3350 val () = loopStr (res, 2, [resId])
3351 val {abbrev, full} = layoutStr (res, {compact = compact})
3357 then Layout.compact sigg
3360 {abbrev = abbrev, full = full}
3364 then seq [str "(* @ ",
3365 Region.layout (Fctid.region name),
3368 val full = fn (arg, res) =>
3371 indent (seq [paren arg, str ":"]),
3375 case (argAbbrev, resAbbrev) of
3376 (NONE, NONE) => full (argFull (), resFull ())
3377 | (NONE, SOME resAbbrev) => full (argFull (), resAbbrev)
3378 | (SOME argAbbrev, NONE) => full (argAbbrev, resFull ())
3379 | (SOME argAbbrev, SOME resAbbrev) =>
3383 [seq [bind, str " ",
3384 paren argAbbrev, str ": ",
3389 then Layout.compact lay
3395 fun layoutBasDefn (name, _, {compact, def}) =
3399 [seq [str "basis ", Basid.layout name],
3401 then seq [str "(* @ ",
3402 Region.layout (Basid.region name),
3407 then Layout.compact lay
3413 val outputl = fn l => Layout.outputl (l, out)
3414 val maybeOutputl = fn lo =>
3417 | SOME l => outputl l
3418 val outputTypeDefn =
3419 fn (strids, name, tyStr) =>
3420 (outputl o layoutTypeDefn)
3421 (strids, name, tyStr,
3422 {compact = compact, def = def})
3424 fn (strids, name, (vid, scheme)) =>
3425 (maybeOutputl o layoutValDefn)
3426 (strids, name, (vid, scheme),
3427 {compact = compact, con = flat, def = def})
3430 (outputl o layoutSigDefn)
3432 {compact = compact, def = def})
3434 fn (strids, name, S) =>
3435 (outputl o layoutStrDefn)
3437 {compact = compact, def = def})
3438 fun outputStrDefnFlat (strids, name, S) =
3440 val () = outputStrDefn (strids, name, S)
3441 val strids = name::strids
3442 val Structure.T {strs, types, vals, ...} = S
3443 fun doit (Info.T a, output) =
3445 (a, fn {domain, range, ...} =>
3446 output (strids, domain, range))
3447 val () = doit (types, outputTypeDefn)
3448 val () = doit (vals, outputValDefn)
3449 val () = doit (strs, outputStrDefnFlat)
3454 fn (name, fctCls) =>
3455 (outputl o layoutFctDefn)
3457 {compact = compact, def = def})
3460 (outputl o layoutBasDefn)
3462 {compact = compact, def = def})
3464 fun doit (Info.T a, output) =
3466 (a, fn {domain, range, ...} =>
3467 output (domain, range))
3468 val () = doit (types, fn (name, tyStr) =>
3469 outputTypeDefn ([], name, tyStr))
3470 val () = doit (vals, fn (name, (vid, scheme)) =>
3471 outputValDefn ([], name, (vid, scheme)))
3472 val () = doit (sigs, outputSigDefn)
3473 val () = doit (strs, fn (name, S) =>
3475 then outputStrDefnFlat ([], name, S)
3476 else outputStrDefn ([], name, S))
3477 val () = doit (fcts, outputFctDefn)
3478 val () = doit (bass, outputBasDefn)
3484 (* ------------------------------------------------- *)
3486 (* ------------------------------------------------- *)
3488 fun processDefUse (E as T f) =
3490 val {destroy = destroyLayoutPrettyTycon,
3491 layoutPrettyTycon, ...} =
3492 makeLayoutPrettyTycon (E, {prefixUnset = false})
3493 val {destroy = destroyLayoutPrettyTyvar,
3494 layoutPretty = layoutPrettyTyvar,
3495 reset = resetLayoutPrettyTyvar} =
3496 Tyvar.makeLayoutPrettyLocal ()
3497 fun layoutPrettyScheme s =
3499 val () = resetLayoutPrettyTyvar ()
3501 (#1 o Type.layoutPretty)
3503 {expandOpaque = false,
3504 layoutPrettyTycon = layoutPrettyTycon,
3505 layoutPrettyTyvar = layoutPrettyTyvar})
3507 val destroy = fn () =>
3508 (destroyLayoutPrettyTyvar ()
3509 ; destroyLayoutPrettyTycon ())
3512 val all: {class: Class.t,
3514 extra: Layout.t list,
3517 uses: Region.t list} list ref = ref []
3518 fun doit (sel, mkExtra) =
3520 val NameSpace.T {defUses, region, toSymbol, ...} = sel f
3523 (Option.fold (defUses, [], ! o #1),
3524 fn {class, def, uses, range, ...} =>
3526 (all, {class = class,
3527 def = Symbol.layout (toSymbol def),
3528 extra = mkExtra range,
3529 isUsed = Uses.isUsed uses,
3530 region = region def,
3531 uses = List.fold (Uses.all uses, [], fn (u, ac) =>
3534 val _ = doit (#fcts, fn _ => [])
3535 val _ = doit (#sigs, fn _ => [])
3536 val _ = doit (#strs, fn _ => [])
3537 val _ = doit (#types, fn _ => [])
3539 fun mkExtraFromScheme so =
3542 | SOME (_, s) => [layoutPrettyScheme s]
3544 val _ = doit (#vals, mkExtraFromScheme)
3546 val a = Array.fromList (!all)
3548 QuickSort.sortArray (a, fn ({region = r, ...}, {region = r', ...}) =>
3552 (a, [], fn (z as {class, def, extra, isUsed, region, uses}, ac) =>
3555 | {extra = e', isUsed = i', region = r', uses = u', ...} :: ac' =>
3556 if Region.equals (region, r')
3557 then {class = class,
3560 isUsed = isUsed orelse i',
3562 uses = uses @ u'} :: ac'
3566 (l, fn {class, def, isUsed, region, ...} =>
3567 if isUsed orelse Option.isNone (Region.left region)
3572 seq [str (concat ["unused ", Class.toString class, ": "]), def],
3575 case !Control.showDefUse of
3581 (l, fn {class, def, extra, region, uses, ...} =>
3582 case Region.left region of
3586 val uses = Array.fromList uses
3587 val _ = QuickSort.sortArray (uses, Region.<=)
3590 (uses, [], fn (r, ac) =>
3594 if Region.equals (r, r')
3600 (align [seq [str (Class.toString class),
3604 str (SourcePos.toString p),
3612 List.map (List.equivalence
3613 (ts, String.equals),
3620 orelse size l = size r
3626 (sts, " andalso ") @ ["\""]))
3632 str (case Region.left r of
3635 SourcePos.toString p))),
3644 (* ------------------------------------------------- *)
3646 (* ------------------------------------------------- *)
3648 fun newCons (T {vals, ...}, v) =
3650 val forceUsed = 1 = Vector.length v
3652 (Cons.fromVector o Vector.map)
3653 (v, fn {con, name, scheme} =>
3658 {def = Ast.Vid.fromCon name,
3659 range = (Vid.Con con, scheme),
3660 forceUsed = forceUsed})
3669 (* ------------------------------------------------- *)
3671 (* ------------------------------------------------- *)
3675 fun makeOpaque (S: Structure.t, I: Interface.t, {prefix: string}) =
3677 fun fixCons (cs, cs') =
3679 (cs', fn {name, scheme, ...} =>
3682 case Vector.peek (Cons.dest cs, fn {name = n, ...} =>
3683 Ast.Con.equals (n, name)) of
3684 NONE => (Con.bogus, Uses.new ())
3685 | SOME {con, uses, ...} => (con, uses)
3687 {con = con, scheme = scheme, uses = uses}
3689 val (S', instantiate) = Structure.dummy (I, {prefix = prefix})
3690 val _ = instantiate (S, fn (c, s) =>
3691 Tycon.setOpaqueExpansion
3692 (c, fn ts => TypeStr.apply (s, ts)))
3694 get : Structure.t -> {formal: Structure.t, new: Structure.t} list ref,
3696 Property.destGet (Structure.plist, Property.initFun (fn _ => ref []))
3698 fun replace (S, S'): Structure.t =
3699 reallyReplace (S, S')
3701 fun replace (S, S'): Structure.t =
3705 case List.peek (!seen, fn {formal, ...} =>
3706 Structure.eq (S', formal)) of
3708 val new = reallyReplace (S, S')
3709 val _ = List.push (seen, {formal = S', new = new})
3713 | SOME {new, ...} => new
3715 and reallyReplace (S, S'): Structure.t =
3717 val Structure.T {strs,
3720 val Structure.T {strs = strs',
3722 vals = vals', ...} = S'
3723 val strs = Info.map2 (strs, strs', replace)
3726 (types, types', fn (s, s') =>
3728 datatype z = datatype TypeStr.node
3730 case TypeStr.node s' of
3731 Datatype {cons = cs', tycon} =>
3732 (case TypeStr.node s of
3733 Datatype {cons = cs, ...} =>
3735 (tycon, fixCons (cs, cs'))
3742 (vals, vals', fn ((v, _), (_, s')) =>
3745 Structure.T {interface = Structure.interface S',
3746 plist = PropertyList.new (),
3751 val S'' = replace (S, S')
3757 fun transparentCut (E: t, S: Structure.t, I: Interface.t,
3758 {isFunctor: bool, prefix: string},
3759 region: Region.t): Structure.t * Decs.t =
3761 val I = Interface.copy I
3762 val flexTyconMap = Interface.flexibleTycons I
3766 fn (name, flex, typeStr, {nest = strids}) =>
3768 val {admitsEquality = a, hasCons, kind = k, ...} =
3769 FlexibleTycon.dest flex
3772 (FlexibleTycon.dummyTycon
3773 (flex, name, strids, {prefix = prefix}))
3778 (* Only realize a plausible candidate for typeStr. *)
3779 if Kind.equals (k, TypeStr.kind typeStr)
3780 andalso AdmitsEquality.<= (a, TypeStr.admitsEquality typeStr)
3781 andalso (not hasCons orelse Option.isSome (TypeStr.toTyconOpt typeStr))
3784 val () = FlexibleTycon.realize (flex, typeStr)
3788 (* This tick is so that the type schemes for any values that need to be
3789 * instantiated and then re-generalized will be at a new time, so we can
3790 * check if something should not be generalized.
3792 val () = TypeEnv.Time.tick {region = region}
3795 then "argument signature"
3798 val {destroy = destroyInterfaceSigid,
3799 get = interfaceSigid: Interface.t -> (Sigid.t * Interface.t) option,
3800 set = setInterfaceSigid, ...} =
3801 Property.destGetSet (Interface.plist, Property.initConst NONE)
3802 val {destroy = destroyLayoutPrettyTycon,
3803 layoutPrettyTycon, setLayoutPrettyTycon,
3804 loopStr, loopFlexTyconMap, ...} =
3805 genLayoutPrettyTycon {prefixUnset = true}
3810 val {sigs, strs, types, ...} = current (E, fn _ => true)
3813 (sigs (), fn (s, I) =>
3814 setInterfaceSigid (I, SOME (s, I)))
3815 val _ = loopFlexTyconMap (flexTyconMap, 2, [Strid.uSig])
3816 val _ = loopStr (S, 1, [Strid.uStr])
3818 loopStr (Structure.T {interface = NONE,
3819 plist = PropertyList.new (),
3822 vals = Info.T (Array.new0 ())},
3827 val interfaceSigid = fn I =>
3828 (Promise.force pre; interfaceSigid I)
3829 val layoutPrettyTycon = fn c =>
3830 (Promise.force pre; layoutPrettyTycon c)
3831 val {destroy = destroyLayouts,
3832 layoutPrettyType, layoutPrettyTyvar,
3833 layoutStrSpec, layoutTypeSpec, layoutValSpec,
3834 localInitLayoutPrettyTyvar, ...} =
3835 Interface.layouts {interfaceSigid = interfaceSigid,
3836 layoutPrettyTycon = layoutPrettyTycon,
3837 setLayoutPrettyTycon = setLayoutPrettyTycon}
3839 datatype sort = datatype Interface.TypeStr.Sort.t
3840 val sort = Interface.TypeStr.sort
3843 fun map {strInfo: ('name, 'strRange) Info.t,
3844 ifcArray: ('name * 'ifcRange) array,
3845 strids: Strid.t list,
3846 nameEquals: 'name * 'name -> bool,
3847 nameLayout: 'name -> Layout.t,
3848 specs: 'name * 'ifcRange -> Region.t list,
3849 notFound: 'name * 'ifcRange -> {diag: {spec: Layout.t option,
3850 thing: string} option,
3852 doit: 'name * 'strRange * 'name * 'ifcRange -> 'range}: ('name, 'range) Info.t =
3854 val Info.T strArray = strInfo
3855 val n = Array.length strArray
3859 (ifcArray, fn (ifcName, ifcRange) =>
3865 val {diag, range} = notFound (ifcName, ifcRange)
3868 (diag, fn {thing, spec} =>
3874 str " but not in structure: ",
3875 layoutLongRev (strids, nameLayout ifcName)],
3876 align ((case spec of
3877 NONE => Layout.empty
3878 | SOME spec => seq [str "signature: ", spec])::
3880 (specs (ifcName, ifcRange), fn r =>
3881 seq [str "spec at: ", Region.layout r])))))
3885 time = Time.next (),
3890 val {domain = strName, range = strRange, time, uses} =
3891 Array.sub (strArray, i)
3893 if nameEquals (strName, ifcName)
3895 ; {domain = strName,
3896 range = doit (strName, strRange, ifcName, ifcRange),
3907 val {destroy, get: Structure.t -> (Interface.t * Structure.t) list ref,
3909 Property.destGet (Structure.plist, Property.initFun (fn _ => ref []))
3911 fun cut (S, I, strids): Structure.t =
3912 reallyCut (S, I, strids)
3914 fun cut (S, I, flexTyconMap, strids): Structure.t =
3918 case List.peek (!seen, fn (I', _) => Interface.equals (I, I')) of
3921 fun really () = reallyCut (S, I, flexTyconMap, strids)
3923 case Structure.interface S of
3926 if Interface.equals (I, I')
3929 val _ = List.push (seen, (I, S))
3935 and reallyCut (S, I, flexTyconMap, strids) =
3937 val Structure.T {strs = strStrs, types = strTypes, vals = strVals, ...} = S
3938 val {strs = sigStrs, types = sigTypes, vals = sigVals} = Interface.dest I
3940 map {strInfo = strTypes,
3941 ifcArray = sigTypes,
3943 nameEquals = Ast.Tycon.equals,
3944 nameLayout = Ast.Tycon.layout,
3945 specs = fn (name, sigStr) =>
3946 Interface.TypeStr.specs (sigStr, Ast.Tycon.region name),
3947 notFound = fn (name, sigStr) =>
3951 (strids, name, sigStr,
3954 flexTyconMap = flexTyconMap})
3957 val rlzStr = Interface.TypeStr.toEnv sigStr
3959 {diag = SOME {spec = SOME spec,
3963 doit = fn (strName, strStr, sigName, sigStr) =>
3965 val rlzStr = Interface.TypeStr.toEnv sigStr
3966 val error: (Layout.t list * Layout.t * Layout.t) option ref = ref NONE
3967 fun reportError () =
3970 | SOME (msgs, strError, sigError) =>
3973 seq [str "type in structure disagrees with signature (",
3974 (seq o List.separate) (List.rev msgs, str ", "),
3976 layoutLongRev (strids, Ast.Tycon.layout sigName)],
3977 align ((seq [str "structure: ", strError]) ::
3978 (seq [str "defn at: ",
3979 Region.layout (Ast.Tycon.region strName)]) ::
3980 (seq [str "signature: ", sigError]) ::
3982 (Interface.TypeStr.specs
3983 (sigStr, Ast.Tycon.region sigName),
3984 fn r => seq [str "spec at: ", Region.layout r]))))
3985 val error = fn (msg, strError, sigError) =>
3990 | SOME (msgs, _, _) => (str msg)::msgs
3992 error := SOME (msgs, strError, sigError)
3995 val strKind = TypeStr.kind strStr
3998 Kind.Arity strArity => strArity
3999 | _ => Error.bug "ElaborateEnv.transparentCut.reallyCut.<anon>: strArity"
4000 val sigKind = Interface.TypeStr.kind sigStr
4003 Kind.Arity sigArity => sigArity
4004 | _ => Error.bug "ElaborateEnv.transparentCut.reallyCut.<anon>: sigArity"
4008 (Int.max (strArity, sigArity), fn _ =>
4009 Tyvar.makeNoname {equality = false})
4010 val () = localInitLayoutPrettyTyvar tyvars
4012 val strTyvars = Vector.prefix (tyvars, strArity)
4013 val strTyargs = Vector.map (strTyvars, Type.var)
4014 val sigTyvars = Vector.prefix (tyvars, sigArity)
4015 val sigTyargs = Vector.map (sigTyvars, Type.var)
4017 fun layoutTyvars tyvars =
4021 case Vector.length tyvars of
4023 | 1 => layoutPrettyTyvar (Vector.first tyvars)
4024 | _ => tuple (Vector.toListMap (tyvars, layoutPrettyTyvar))
4026 if strArity = sigArity
4032 else seq [str " ", tyvars, str " "]
4035 val sort = sort (sigName, sigStr, rlzStr, flexTyconMap)
4037 fun sigMsg (b, rest) =
4039 val empty = Layout.empty
4040 val indent = fn l => Layout.indent (l, 3)
4043 NONE => SOME (str "...")
4047 Datatype _ => ("datatype", rest)
4048 | Scheme _ => ("type", rest)
4049 | Type {admitsEquality} =>
4050 (if admitsEquality then "eqtype" else "type",
4053 mayAlign [seq [if b then bracket (str kw) else str kw,
4054 layoutTyvars sigTyvars,
4055 layoutLongRev (strids, Ast.Tycon.layout sigName),
4056 if Option.isSome rest then str " =" else empty],
4057 indent (case rest of
4059 | SOME rest => rest)]
4061 fun strMsg (b, rest) =
4063 val empty = Layout.empty
4064 val indent = fn l => Layout.indent (l, 3)
4067 NONE => SOME (str "...")
4070 case TypeStr.node strStr of
4071 TypeStr.Datatype _ => "datatype"
4072 | TypeStr.Scheme _ => "type"
4073 | TypeStr.Tycon _ => "type"
4075 mayAlign [seq [if b then bracket (str kw) else str kw,
4076 layoutTyvars strTyvars,
4077 layoutLongRev (strids, Ast.Tycon.layout strName),
4078 if Option.isSome rest then str " =" else empty],
4079 indent (case rest of
4081 | SOME rest => rest)]
4084 val lay = #1 o layoutPrettyType
4086 fun unify (t, t', error) =
4088 val error = fn (l, l', _) =>
4092 (t, t', {error = error,
4093 layoutPretty = layoutPrettyType,
4094 layoutPrettyTycon = layoutPrettyTycon,
4095 layoutPrettyTyvar = layoutPrettyTyvar})
4099 if Kind.equals (strKind, sigKind)
4101 else error ("arity",
4102 strMsg (false, NONE),
4103 sigMsg (false, NONE))
4108 val sigEq = Interface.TypeStr.admitsEquality sigStr
4109 val strEq = TypeStr.admitsEquality strStr
4111 if AdmitsEquality.<= (sigEq, strEq)
4113 else error ("admits equality",
4114 strMsg (false, SOME (TypeStr.explainDoesNotAdmitEquality
4116 {layoutPrettyTycon = layoutPrettyTycon}))),
4117 sigMsg (true, NONE))
4121 | Scheme sigScheme =>
4123 fun chkScheme strScheme =
4125 (Scheme.apply (strScheme, strTyargs),
4126 Scheme.apply (sigScheme, sigTyargs),
4127 fn (l, l') => error ("type definition",
4128 strMsg (false, SOME l),
4129 sigMsg (false, SOME l')))
4131 case TypeStr.node strStr of
4132 TypeStr.Datatype {tycon = strTycon, ...} =>
4134 val strScheme = Scheme.fromTycon strTycon
4137 (Scheme.apply (strScheme, strTyargs),
4138 Scheme.apply (sigScheme, sigTyargs),
4140 error ("type structure",
4141 strMsg (true, NONE),
4142 sigMsg (false, SOME (bracket (lay (Scheme.apply (sigScheme, sigTyargs)))))))
4144 | TypeStr.Scheme s =>
4146 | TypeStr.Tycon c =>
4147 chkScheme (Scheme.fromTycon c)
4151 | Datatype {repl = true, tycon = sigTycon, ...} =>
4153 val sigScheme = Scheme.fromTycon sigTycon
4154 fun nonDatatype strScheme =
4155 (error ("type structure",
4156 strMsg (false, SOME (bracket (lay (Scheme.apply (strScheme, strTyargs))))),
4157 sigMsg (false, SOME (bracket (seq [str "datatype ",
4158 lay (Scheme.apply (sigScheme, sigTyargs))]))))
4161 case TypeStr.node strStr of
4162 TypeStr.Datatype {tycon = strTycon, ...} =>
4164 val strScheme = Scheme.fromTycon strTycon
4169 (Scheme.apply (strScheme, strTyargs),
4170 Scheme.apply (sigScheme, sigTyargs),
4172 (error ("type structure",
4173 strMsg (true, NONE),
4174 sigMsg (false, SOME (bracket (seq [str "datatype ",
4175 lay (Scheme.apply (sigScheme, sigTyargs))]))))
4179 | TypeStr.Scheme strScheme =>
4180 nonDatatype strScheme
4181 | TypeStr.Tycon strTycon =>
4182 nonDatatype (Scheme.fromTycon strTycon)
4184 | Datatype {repl = false, cons = sigCons, ...} =>
4186 fun nonDatatype strScheme =
4187 (error ("type structure",
4188 strMsg (false, SOME (bracket (lay (Scheme.apply (strScheme, strTyargs))))),
4189 sigMsg (true, NONE))
4192 case TypeStr.node strStr of
4193 TypeStr.Datatype {cons = strCons, ...} =>
4195 val extra: bool ref = ref false
4196 fun conScheme (scheme, tyvars) =
4197 case Type.deArrowOpt (Scheme.apply (scheme, tyvars)) of
4199 | SOME (ty, _) => SOME ty
4200 fun layCon (name, scheme, tyvars) =
4202 [Ast.Con.layout name,
4203 case conScheme (scheme, tyvars) of
4204 NONE => Layout.empty
4205 | SOME _ => str " of _"]
4206 fun loop (sigCons, strCons, sigConsAcc, strConsAcc) =
4207 case (sigCons, strCons) of
4208 ([], []) => (List.rev sigConsAcc, List.rev strConsAcc)
4209 | ({name, scheme = sigScheme}::sigCons, []) =>
4212 (layCon (name, sigScheme, sigTyargs))::sigConsAcc,
4214 | ([], {name, scheme = strScheme}::strCons) =>
4218 (layCon (name, strScheme, strTyargs))::strConsAcc)
4219 | (sigCons as {name = sigName, scheme = sigScheme}::sigCons',
4220 strCons as {name = strName, scheme = strScheme}::strCons') =>
4221 (case Ast.Con.compare (sigName, strName) of
4225 (layCon (sigName, sigScheme, sigTyargs))::sigConsAcc,
4228 (case (conScheme (sigScheme, sigTyargs), conScheme (strScheme, strTyargs)) of
4229 (NONE, NONE) => (extra := true
4230 ; loop (sigCons', strCons',
4231 sigConsAcc, strConsAcc))
4233 loop (sigCons', strCons',
4234 (Ast.Con.layout sigName)::sigConsAcc,
4235 (seq [Ast.Con.layout strName, str " [of _]"])::strConsAcc)
4237 loop (sigCons', strCons',
4238 (seq [Ast.Con.layout sigName, str " [of _]"])::sigConsAcc,
4239 (Ast.Con.layout strName)::strConsAcc)
4240 | (SOME sigTy, SOME strTy) =>
4245 fn (sigLay, strLay) =>
4247 (sigCons', strCons',
4248 (seq [Ast.Con.layout sigName, str " of ", sigLay])::sigConsAcc,
4249 (seq [Ast.Con.layout strName, str " of ", strLay])::strConsAcc))
4251 ; loop (sigCons', strCons',
4252 sigConsAcc, strConsAcc))))
4257 (layCon (strName, strScheme, strTyargs))::strConsAcc))
4258 val (sigCons, strCons) =
4259 loop (Vector.toListMap
4260 (Cons.dest sigCons, fn {name, scheme, ...} =>
4261 {name = name, scheme = scheme}),
4263 (Cons.dest strCons, fn {name, scheme, ...} =>
4264 {name = name, scheme = scheme}),
4268 if List.isEmpty sigCons
4269 andalso List.isEmpty strCons
4276 then List.snoc (cons, str "...")
4278 val cons = alignPrefix (cons, "| ")
4283 error ("constructors",
4284 strMsg (false, layCons strCons),
4285 sigMsg (false, layCons sigCons))
4291 | TypeStr.Scheme strScheme =>
4292 nonDatatype strScheme
4293 | TypeStr.Tycon strTycon =>
4294 nonDatatype (Scheme.fromTycon strTycon)
4296 val () = reportError ()
4305 nameEquals = Ast.Vid.equals,
4306 nameLayout = Ast.Vid.layout,
4307 specs = fn (name, _) => [Ast.Vid.region name],
4308 notFound = fn (name, (sigStatus, sigScheme)) =>
4312 (strids, name, (sigStatus, sigScheme),
4313 {compact = false, con = false, def = false})
4314 val thing = Status.pretty sigStatus
4316 val con = Con.newString o Ast.Vid.toString
4317 val var = Var.newString o Ast.Vid.toString
4320 Status.Con => Vid.Con (con name)
4321 | Status.Exn => Vid.Exn (con name)
4322 | Status.Var => Vid.Var (var name)
4323 val rlzScheme = Interface.Scheme.toEnv sigScheme
4325 {diag = Option.map (spec, fn spec =>
4328 range = (vid, rlzScheme)}
4330 doit = fn (strName, (strVid, strScheme), sigName, (sigStatus, sigScheme)) =>
4332 val rlzScheme = Interface.Scheme.toEnv sigScheme
4333 val unifyError = ref NONE
4334 val statusError = ref false
4335 val (rlzTyvars, rlzType) = Scheme.fresh rlzScheme
4336 val () = localInitLayoutPrettyTyvar rlzTyvars
4337 val {args = strTyargs, instance = strType} =
4338 Scheme.instantiate strScheme
4342 {error = fn (l, l', {notes, ...}) =>
4343 unifyError := SOME (l, l', notes),
4344 layoutPretty = layoutPrettyType,
4345 layoutPrettyTycon = layoutPrettyTycon,
4346 layoutPrettyTyvar = layoutPrettyTyvar})
4347 val strTyargs = strTyargs ()
4348 fun addDec (name: string, n: Exp.node): Vid.t =
4350 val x = Var.newString name
4351 val e = Exp.make (n, strType)
4355 Dec.Val {matchDiags = {nonexhaustiveExn = Control.Elaborate.DiagDI.Default,
4356 nonexhaustive = Control.Elaborate.DiagEIW.Ignore,
4357 redundant = Control.Elaborate.DiagEIW.Ignore},
4358 rvbs = Vector.new0 (),
4359 tyvars = fn () => rlzTyvars,
4361 {ctxt = fn _ => Layout.empty,
4363 layPat = fn _ => Layout.empty,
4365 pat = Pat.var (x, strType),
4366 regionPat = Region.bogus})})
4370 fun con (c: Con.t): Vid.t =
4371 addDec (Con.originalName c, Exp.Con (c, strTyargs))
4372 val strStatus = Status.fromVid strVid
4374 case (strVid, sigStatus) of
4375 (Vid.Con c, Status.Var) => con c
4376 | (Vid.Exn c, Status.Var) => con c
4377 | (Vid.Var x, Status.Var) =>
4378 if 0 < Vector.length rlzTyvars
4379 orelse 0 < Vector.length strTyargs
4380 then addDec (Var.originalName x,
4381 Exp.Var (fn () => x, fn () => strTyargs))
4383 | (Vid.Con _, Status.Con) => strVid
4384 | (Vid.Exn _, Status.Exn) => strVid
4385 | _ => (statusError := true; strVid)
4387 if Option.isNone (!unifyError) andalso not (!statusError)
4392 if Option.isSome (!unifyError)
4393 then str "type" :: errors
4397 then str "status" :: errors
4400 layoutLongRev (strids, Ast.Vid.layout sigName)
4401 val (strTy, sigTy, notes) =
4405 val lay = #1 (layoutPrettyType rlzType)
4407 (lay, lay, Layout.empty)
4409 | SOME (strLay, sigLay, notes) =>
4410 (strLay, sigLay, notes ())
4411 fun doit (space, status, ty, kind, vid) =
4413 val indent = fn l => Layout.indent (l, 3)
4414 val kw = str (Status.kw status)
4416 if !statusError then bracket kw else kw
4418 align [seq [str space, str ": ",
4422 str (if Ast.Vid.isSymbolic sigName
4426 seq [str kind, str " at: ",
4427 Region.layout (Ast.Vid.region vid)]]
4432 seq [if !statusError
4433 then str "value identifier"
4434 else str (Vid.statusPretty strVid),
4435 str " in structure disagrees with ",
4438 (seq o List.separate)
4442 align [doit ("structure", strStatus, strTy,
4444 doit ("signature", sigStatus, sigTy,
4452 map {strInfo = strStrs,
4455 nameEquals = Strid.equals,
4456 nameLayout = Strid.layout,
4457 specs = fn (name, _) => [Strid.region name],
4458 notFound = fn (name, I) =>
4465 elide = {strs = SOME (2, 0),
4467 vals = SOME (3, 2)},
4468 flexTyconMap = flexTyconMap})
4469 val thing = "structure"
4471 val (S, _) = Structure.dummy (I, {prefix = ""})
4473 {diag = SOME {spec = SOME spec,
4477 doit = fn (_, S, name, I) =>
4481 (TyconMap.peekStrid (flexTyconMap, name),
4483 fn (flexTyconMap, _) => flexTyconMap)
4485 cut (S, I, flexTyconMap, name :: strids)
4488 Structure.T {interface = SOME I,
4489 plist = PropertyList.new (),
4494 val S = cut (S, I, flexTyconMap, [])
4496 val () = destroyLayouts ()
4497 val () = destroyLayoutPrettyTycon ()
4498 val () = destroyInterfaceSigid ()
4500 (S, Decs.fromList (!decs))
4505 (* section 5.3, 5.5, 5.6 and rules 52, 53 *)
4506 fun cut (E: t, S: Structure.t, I: Interface.t,
4507 {isFunctor: bool, opaque: bool, prefix: string}, region)
4508 : Structure.t * Decs.t =
4510 val (S, decs) = transparentCut (E, S, I, {isFunctor = isFunctor, prefix = prefix}, region)
4513 then makeOpaque (S, I, {prefix = prefix})
4520 Trace.trace ("ElaborateEnv.cut",
4521 fn (_, S, I, _, _) =>
4522 Layout.tuple [Structure.layout S,
4523 Interface.layout I],
4524 Structure.layout o #1)
4529 (* ------------------------------------------------- *)
4530 (* functorClosure *)
4531 (* ------------------------------------------------- *)
4536 argInterface: Interface.t,
4537 makeBody: Structure.t * string list -> Decs.t * Structure.t option) =
4539 val argId = Strid.uArg (Fctid.toString name)
4540 val resId = Strid.uRes (Fctid.toString name)
4541 val _ = insideFunctor := true
4542 (* Need to tick here so that any tycons created in the dummy structure
4543 * for the functor formal have a new time, and will therefore report an
4544 * error if they occur before the functor declaration.
4546 val _ = TypeEnv.Time.tick {region = Fctid.region name}
4547 val (formal, instantiate) =
4548 Structure.dummy (argInterface, {prefix = Strid.toString argId ^ "."})
4549 (* Keep track of all tycons created during the instantiation of the
4550 * functor. These will later become the generative tycons that will need
4551 * to be recreated for each functor application.
4553 val (resultStructure, generativeTycons) =
4557 val nest = [Strid.toString resId]
4558 val (_, resultStructure) = makeBody (formal, nest)
4559 val _ = Option.app (resultStructure, Structure.forceUsed)
4563 val _ = insideFunctor := false
4565 if !Control.elaborateOnly
4568 val withSaved = Control.Elaborate.snapshot ()
4569 val snapshot = snapshot E
4571 fn f => snapshot (fn () => withSaved f)
4573 fun summary actual =
4575 val _ = Structure.forceUsed actual
4576 val {destroy = destroy1,
4577 get = tyconTypeStr: Tycon.t -> TypeStr.t option,
4578 set = setTyconTypeStr, ...} =
4579 Property.destGetSet (Tycon.plist, Property.initConst NONE)
4580 (* Match the actual against the formal, to set the tycons.
4581 * Then duplicate the result, replacing tycons. Want to generate
4582 * new tycons just like the functor body did.
4585 instantiate (actual, fn (c, s) => setTyconTypeStr (c, SOME s))
4588 (generativeTycons, fn c =>
4590 (c, SOME (TypeStr.tycon (Tycon.makeLike c))))
4591 fun replaceType (t: Type.t): Type.t =
4594 case tyconTypeStr c of
4595 NONE => Type.con (c, ts)
4596 | SOME s => TypeStr.apply (s, ts)
4598 Type.hom (t, {con = con,
4599 expandOpaque = false,
4600 record = Type.record,
4601 replaceSynonyms = false,
4604 fun replaceScheme (s: Scheme.t): Scheme.t =
4606 val (tyvars, ty) = Scheme.dest s
4608 Scheme.make {canGeneralize = true,
4609 ty = replaceType ty,
4612 fun replaceCons cons: Cons.t =
4614 (cons, fn {con, scheme, uses, ...} =>
4616 scheme = replaceScheme scheme,
4618 fun replaceTypeStr (s: TypeStr.t): TypeStr.t =
4620 datatype z = datatype TypeStr.node
4622 case TypeStr.node s of
4623 Datatype {cons, tycon} =>
4626 case tyconTypeStr tycon of
4629 (case TypeStr.toTyconOpt s of
4630 NONE => Error.bug "ElaborateEnv.functorClosure.apply: bad datatype"
4633 TypeStr.data (tycon, replaceCons cons)
4635 | Scheme s => TypeStr.def (replaceScheme s)
4636 | Tycon c => (case tyconTypeStr c of
4640 val {destroy = destroy2,
4641 get = replaceInterface: Interface.t -> Interface.t, ...} =
4645 (fn (I, replaceInterface) =>
4647 val {strs, types, vals} = Interface.dest I
4648 val replaceIScheme =
4649 Interface.Scheme.fromEnv
4651 o Interface.Scheme.toEnv
4652 val replaceITypeStr =
4653 Interface.TypeStr.fromEnv
4655 o Interface.TypeStr.toEnv
4659 original = SOME (Interface.original I),
4660 strs = Array.map (strs, fn (strid, I) =>
4661 (strid, replaceInterface I)),
4662 types = Array.map (types, fn (tycon, s) =>
4663 (tycon, replaceITypeStr s)),
4664 vals = Array.map (vals, fn (vid, (status, scheme)) =>
4665 (vid, (status, replaceIScheme scheme)))}
4667 val {destroy = destroy3,
4668 get = replaceStructure: Structure.t -> Structure.t, ...} =
4672 (fn (Structure.T {interface, strs, types, vals, ... },
4673 replaceStructure) =>
4675 {interface = Option.map (interface, replaceInterface),
4676 plist = PropertyList.new (),
4677 strs = Info.map (strs, replaceStructure),
4678 types = Info.map (types, replaceTypeStr),
4679 vals = Info.map (vals, fn (status, s) =>
4680 (status, replaceScheme s))}))
4681 val resultStructure = Option.map (resultStructure, replaceStructure)
4690 ("ElaborateEnv.functorClosure.summary",
4692 Layout.record [("argInterface", Interface.layout argInterface),
4693 ("formal", Structure.layout formal),
4694 ("resultStructure", Option.layout Structure.layout resultStructure),
4695 ("actual", Structure.layout actual)],
4696 Option.layout Structure.layout)
4698 fun apply (actual, nest) =
4699 if not (!insideFunctor)
4700 andalso not (!Control.elaborateOnly)
4701 andalso !Control.numErrors = 0
4702 then restore (fn () => makeBody (actual, nest))
4703 else (Decs.empty, summary actual)
4705 FunctorClosure.T {apply = apply,
4706 argInterface = argInterface,
4707 resultStructure = resultStructure,