[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,