[MLton] cvs commit: improved choices of tycon names
Stephen Weeks
sweeks@mlton.org
Thu, 12 Feb 2004 14:21:08 -0800
sweeks 04/02/12 14:21:08
Modified: basis-library/libs/basis-2002/top-level top-level.sml
mlton/elaborate elaborate-env.fun
Log:
MAIL improved choices of tycon names
When choosing the tycon names, the rule had been to choose the
shortest name (in terms of fewest dots), breaking ties in favor of
earlier alphabetically. That had the annoying behavior of choosing
BinPrimIO.elem over Word8.word. So, I changed the tie breaker to be
choosing names defined more recently, and hence closer in scope.
Then, by judiciosly redefining various structures in top-level.sml, we
can control which names are used. This will help both -show-basis, as
well as improve the tycon names used in type errors.
Have a look at the latest basis produced by -show-basis, and if you
see any remaining tycon names where you think a better name exists,
let me know (or update top-level.sml).
Revision Changes Path
1.10 +42 -0 mlton/basis-library/libs/basis-2002/top-level/top-level.sml
Index: top-level.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/libs/basis-2002/top-level/top-level.sml,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- top-level.sml 29 Dec 2003 04:20:03 -0000 1.9
+++ top-level.sml 12 Feb 2004 22:21:08 -0000 1.10
@@ -41,3 +41,45 @@
open Basis2002
val op = = op =
+
+(* Rebind some structures so that their definitions appear later, so that they
+ * will be used for displaying tycon names.
+ *
+ * Order here matters! Do not alphabetize or otherwise reorder without thinking.
+ *)
+structure OS = OS
+structure BoolArray = BoolArray
+structure BoolVector = BoolVector
+structure CharArraySlice = CharArraySlice
+structure CharArray = CharArray
+structure Int8Array = Int8Array
+structure Int8Vector = Int8Vector
+structure Int16Array = Int16Array
+structure Int16Vector = Int16Vector
+structure Int32Array = Int32Array
+structure Int32Vector = Int32Vector
+structure Int64Array = Int64Array
+structure Int64Vector = Int64Vector
+structure LargeIntArray = LargeIntArray
+structure LargeIntVector = LargeIntVector
+structure LargeRealArray = LargeRealArray
+structure LargeRealVector = LargeRealVector
+structure LargeWordArray = LargeWordArray
+structure LargeWordVector = LargeWordVector
+structure Real32Array = Real32Array
+structure Real32Vector = Real32Vector
+structure Real64Array = Real64Array
+structure Real64Vector = Real64Vector
+structure Word8Array = Word8Array
+structure Word8Vector = Word8Vector
+structure Int8 = Int8
+structure Int16 = Int16
+structure Int32 = Int32
+structure Int64 = Int64
+structure IntInf = IntInf
+structure Real32 = Real32
+structure Real64 = Real64
+structure Word8 = Word8
+structure Word16 = Word16
+structure Word32 = Word32
+structure Word64 = Word64
1.65 +107 -53 mlton/mlton/elaborate/elaborate-env.fun
Index: elaborate-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.fun,v
retrieving revision 1.64
retrieving revision 1.65
diff -u -r1.64 -r1.65
--- elaborate-env.fun 12 Feb 2004 18:55:27 -0000 1.64
+++ elaborate-env.fun 12 Feb 2004 22:21:08 -0000 1.65
@@ -578,17 +578,45 @@
apply
end
+structure Time:>
+ sig
+ type t
+
+ val >= : t * t -> bool
+ val <= : t * t -> bool
+ val next: unit -> t
+ val now: unit -> t
+ val toString: t -> string
+ end =
+ struct
+ type t = int
+
+ val toString = Int.toString
+
+ val op >= : t * t -> bool = op >=
+
+ val op <= : t * t -> bool = op <=
+
+ val c = Counter.new 0
+
+ fun next () = Counter.next c
+
+ fun now () = Counter.value c
+ end
+
(* ------------------------------------------------- *)
(* NameSpace *)
(* ------------------------------------------------- *)
structure Values =
struct
+ type ('a, 'b) value = {domain: 'a,
+ isUsed: bool ref,
+ range: 'b,
+ scope: Scope.t,
+ time: Time.t}
(* The domains of all elements in a values list have the same symbol. *)
- datatype ('a, 'b) t = T of {domain: 'a,
- isUsed: bool ref,
- scope: Scope.t,
- range: 'b} list ref
+ datatype ('a, 'b) t = T of ('a, 'b) value list ref
fun new (): ('a, 'b) t = T (ref [])
@@ -760,7 +788,10 @@
List.foreach (!topSymbols, fn s => foreach (E, s, z))
end
-fun collect (E as T r, f: {isUsed: bool, scope: Scope.t} -> bool) =
+fun collect (E as T r,
+ keep: {isUsed: bool, scope: Scope.t} -> bool,
+ le: {domain: Symbol.t, time: Time.t}
+ * {domain: Symbol.t, time: Time.t} -> bool) =
let
val fcts = ref []
val sigs = ref []
@@ -770,9 +801,9 @@
fun doit ac vs =
case Values.! vs of
[] => ()
- | {domain, isUsed, range, scope, ...} :: _ =>
- if f {isUsed = !isUsed, scope = scope}
- then List.push (ac, (domain, range))
+ | (z as {isUsed, scope, ...}) :: _ =>
+ if keep {isUsed = !isUsed, scope = scope}
+ then List.push (ac, z)
else ()
val _ =
foreachDefinedSymbol (E, {fcts = doit fcts,
@@ -781,10 +812,13 @@
strs = doit strs,
types = doit types,
vals = doit vals})
- fun finish (r, toSymbol) =
+ fun ('a, 'b) finish (r, toSymbol: 'a -> Symbol.t) =
QuickSort.sortArray
- (Array.fromList (!r), fn ((d, _), (d', _)) =>
- Symbol.<= (toSymbol d, toSymbol d'))
+ (Array.fromList (!r),
+ fn ({domain = d, time = t, ...}: ('a, 'b) Values.value,
+ {domain = d', time = t',...}: ('a, 'b) Values.value) =>
+ le ({domain = toSymbol d, time = t},
+ {domain = toSymbol d', time = t'}))
in
{fcts = finish (fcts, Fctid.toSymbol),
sigs = finish (sigs, Sigid.toSymbol),
@@ -838,10 +872,17 @@
; Info.foreach (strs, fn (strid, str) =>
loopStr (str, 1 + length, strids @ [strid])))
end
- val {strs, types, ...} = collect (E, fn _ => true)
- val _ = Array.foreach (types, fn (name, typeStr) =>
+ (* Sort the declarations in decreasing order of definition time so that
+ * later declarations will be processed first, and hence will take
+ * precedence.
+ *)
+ val {strs, types, ...} =
+ collect (E, fn _ => true,
+ fn ({time = t, ...}, {time = t', ...}) => Time.>= (t, t'))
+ val _ = Array.foreach (types, fn {domain = name, range = typeStr, ...} =>
doType (typeStr, name, 0, []))
- val _ = Array.foreach (strs, fn (strid, str) => loopStr (str, 1, [strid]))
+ val _ = Array.foreach (strs, fn {domain = strid, range = str, ...} =>
+ loopStr (str, 1, [strid]))
val _ =
List.foreach
(!allTycons, fn c =>
@@ -934,23 +975,26 @@
Structure.layoutPretty o #1)
dummyStructure
-fun layout' (E: t, f, showUsed): Layout.t =
+fun layout' (E: t, keep, showUsed): Layout.t =
let
val _ = setTyconNames E
- val {fcts, sigs, strs, types, vals} = collect (E, f)
+ val {fcts, sigs, strs, types, vals} =
+ collect (E, keep,
+ fn ({domain = d, ...}, {domain = d', ...}) =>
+ Symbol.<= (d, d'))
open Layout
fun doit (a, layout) = align (Array.toListMap (a, layout))
val {get = shapeSigid: Shape.t -> (Sigid.t * Interface.t) option,
set = setShapeSigid, ...} =
Property.getSet (Shape.plist, Property.initConst NONE)
- val _ = Array.foreach (sigs, fn (s, I) =>
+ val _ = Array.foreach (sigs, fn {domain = s, range = I, ...} =>
setShapeSigid (Interface.shape I, SOME (s, I)))
val {strSpec, typeSpec, valSpec, ...} =
Structure.layouts (showUsed, shapeSigid)
val {layoutAbbrev, layoutStr, ...} =
Structure.layouts ({showUsed = false}, shapeSigid)
val sigs =
- doit (sigs, fn (sigid, I) =>
+ doit (sigs, fn {domain = sigid, range = I, ...} =>
let
val (S, _) = dummyStructure (E, I, {prefix = "?.",
tyconNewString = false})
@@ -959,23 +1003,24 @@
indent (layoutStr S, 3)]
end)
val fcts =
- doit (fcts, fn (s, FunctorClosure.T {formal, result, ...}) =>
- align [seq [str "functor ", Fctid.layout s, str " ",
+ doit (fcts,
+ fn {domain,
+ range = FunctorClosure.T {formal, result, ...}, ...} =>
+ align [seq [str "functor ", Fctid.layout domain, str " ",
paren (seq [str "S: ", #1 (layoutAbbrev formal)])],
case result of
NONE => empty
| SOME S =>
indent (seq [str ": ", #1 (layoutAbbrev S)], 3)])
- val vals = align (Array.foldr (vals, [], fn (vs, ac) =>
- case valSpec vs of
+ val vals = align (Array.foldr (vals, [], fn ({domain, range, ...}, ac) =>
+ case valSpec (domain, range) of
NONE => ac
| SOME l => l :: ac))
+ val types = doit (types, fn {domain, range, ...} =>
+ typeSpec (domain, range))
+ val strs = doit (strs, fn {domain, range, ...} => strSpec (domain, range))
in
- align [doit (types, typeSpec),
- vals,
- sigs,
- fcts,
- doit (strs, strSpec)]
+ align [types, vals, sigs, fcts, strs]
end
fun layout E = layout' (E, fn _ => true, {showUsed = false})
@@ -1167,21 +1212,19 @@
(* extend *)
(* ------------------------------------------------- *)
-val extend: t * ('a, 'b) NameSpace.t * Scope.t * {domain: 'a,
- isUsed: bool ref,
- range: 'b} -> unit =
+val extend: t * ('a, 'b) NameSpace.t * {domain: 'a,
+ isUsed: bool ref,
+ range: 'b,
+ scope: Scope.t,
+ time: Time.t} -> unit =
fn (T {maybeAddTop, ...},
NameSpace.T {current, lookup, toSymbol, ...},
- scope,
- {domain, isUsed, range}) =>
+ value as {domain, isUsed, range, scope, time}) =>
let
- val value = {domain = domain,
- isUsed = isUsed,
- range = range,
- scope = scope}
val values as Values.T r = lookup domain
- fun new () = (List.push (current, values)
- ; List.push (r, value))
+ fun new () =
+ (List.push (current, values)
+ ; List.push (r, value))
in
case !r of
[] =>
@@ -1205,9 +1248,11 @@
let
val ns = get fields
in
- extend (E, ns, !currentScope, {domain = domain,
- isUsed = ref false,
- range = range})
+ extend (E, ns, {domain = domain,
+ isUsed = ref false,
+ range = range,
+ scope = !currentScope,
+ time = Time.next ()})
end
in
val extendFctid = make #fcts
@@ -1258,10 +1303,12 @@
val _ = List.foreach (c1, fn v => (Values.pop v; ()))
val _ = current := old
val _ =
- List.foreach (lift, fn {domain, isUsed, range, ...} =>
- extend (E, ns, s0, {domain = domain,
- isUsed = isUsed,
- range = range}))
+ List.foreach (lift, fn {domain, isUsed, range, time, ...} =>
+ extend (E, ns, {domain = domain,
+ isUsed = isUsed,
+ range = range,
+ scope = s0,
+ time = time}))
in
()
end
@@ -1400,7 +1447,12 @@
let
val scope = !currentScope
fun doit (ns, Info.T a) =
- Array.foreach (a, fn z => extend (E, ns, scope, z))
+ Array.foreach (a, fn {domain, isUsed, range} =>
+ extend (E, ns, {domain = domain,
+ isUsed = isUsed,
+ range = range,
+ scope = scope,
+ time = Time.next ()}))
val _ = doit (strs, strs')
val _ = doit (vals, vals')
val _ = doit (types, types')
@@ -1986,7 +2038,8 @@
(List.push (vs, {domain = domain,
isUsed = isUsed,
range = range,
- scope = s0})
+ scope = s0,
+ time = Time.next ()})
; List.push (current, v)))
val _ =
foreachTopLevelSymbol (E, {fcts = doit fcts,
@@ -2238,20 +2291,21 @@
let
val scope = !currentScope
val NameSpace.T {current, lookup, toSymbol, ...} = ns fields
- val value = {domain = domain,
- isUsed = ref false,
- range = range,
- scope = scope}
+ fun value () = {domain = domain,
+ isUsed = ref false,
+ range = range,
+ scope = scope,
+ time = Time.next ()}
val values as Values.T r = lookup domain
fun new () = (List.push (current, values)
- ; List.push (r, value))
+ ; List.push (r, value ()))
in
case !r of
[] => new ()
| {scope = scope', ...} :: l =>
if Scope.equals (scope, scope')
then if !allowDuplicates
- then r := value :: l
+ then r := value () :: l
else
Control.error
(region,