[MLton] cvs commit: improved type constructor names in type errors

sweeks@mlton.org sweeks@mlton.org
Fri, 26 Dec 2003 15:40:24 -0800


sweeks      03/12/26 15:40:23

  Modified:    mlton/atoms id.fun id.sig
               mlton/elaborate elaborate-core.fun elaborate-env.fun
                        elaborate-env.sig type-env.fun type-env.sig
               mlton/main compile.fun
  Log:
  MAIL improved type constructor names in type errors
  
  Display type constructor names based on the environment currently in
  scope.  Choose a shortest (in terms of dots) name for each type
  constructor.  So, when the type name is in scope, the short name will
  be used, as in
  
  	structure S =
  	   struct
  	      datatype t = T
  	      fun f T = ()
  	      val _ = f 13
  	   end
  
  	Error: z.sml 5.15: function applied to incorrect argument
  	   expects: [t]
  	   but got: [int]
  	   in: f 13
  
  However, once we are outside the structure S, then the full name will
  be used:
  
  	structure S =
  	   struct
  	      datatype t = T
  	      fun f T = ()
  	   end
  	val _ = S.f 13
  
  	Error: z.sml 6.9: function applied to incorrect argument
  	   expects: [S.t]
  	   but got: [int]
  	   in: S.f 13
  
  Also, use a "?." to prefix type constructors that are not currently
  accessible.  For example:
  
  	datatype t = T
  	fun f T = ()
  	type t = unit
  	val _ = f 13
  
  	Error: z.sml 4.9: function applied to incorrect argument
  	   expects: [?.t]
  	   but got: [int]
  	   in: f 13

Revision  Changes    Path
1.9       +2 -0      mlton/mlton/atoms/id.fun

Index: id.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/id.fun,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- id.fun	11 Dec 2003 03:20:51 -0000	1.8
+++ id.fun	26 Dec 2003 23:40:22 -0000	1.9
@@ -33,6 +33,8 @@
    val originalName = make #originalName
 end
 
+fun setPrintName (T {printName, ...}, s) = printName := SOME s
+
 fun toString (T {printName, originalName, ...}) =
    case !printName of
       NONE =>



1.6       +3 -2      mlton/mlton/atoms/id.sig

Index: id.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/id.sig,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- id.sig	11 Dec 2003 03:20:51 -0000	1.5
+++ id.sig	26 Dec 2003 23:40:22 -0000	1.6
@@ -21,12 +21,13 @@
       val equals: t * t -> bool
       val fromString: string -> t (* doesn't add uniquefying suffix *)
       val layout: t -> Layout.t
-      val new: t -> t            (* with the same prefix *)
-      val newNoname: unit -> t   (* prefix is "x" *)
+      val new: t -> t (* with the same prefix *)
+      val newNoname: unit -> t (* prefix is noname *)
       val newString: string -> t (* given prefix *)
       val originalName: t -> string (* raw destructor *)
       val plist: t -> PropertyList.t
       val sameName: t * t -> bool
+      val setPrintName: t * string -> unit
       val toString: t -> string
    end
 



1.53      +30 -17    mlton/mlton/elaborate/elaborate-core.fun

Index: elaborate-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.fun,v
retrieving revision 1.52
retrieving revision 1.53
diff -u -r1.52 -r1.53
--- elaborate-core.fun	30 Nov 2003 23:39:09 -0000	1.52
+++ elaborate-core.fun	26 Dec 2003 23:40:22 -0000	1.53
@@ -279,6 +279,7 @@
 val unify = Type.unify
    
 fun unifyList (trs: (Type.t * Region.t) vector,
+	       preError: unit -> unit,
 	       lay: unit -> Layout.t): Type.t =
    if 0 = Vector.length trs
       then Type.list (Type.new ())
@@ -288,7 +289,7 @@
 	 val _ =
 	    Vector.foreach
 	    (trs, fn (t', r) =>
-	     unify (t, t', fn (l, l') =>
+	     unify (t, t', preError, fn (l, l') =>
 		    (r,
 		     str "list elements of different types",
 		     align [seq [str "element:  ", l'],
@@ -334,7 +335,7 @@
        else concat [String.prefix (s, 35), "  ...  ", String.suffix (s, 25)])
    end
 
-fun elaboratePat (p: Apat.t, E: Env.t, amInRvb: bool)
+fun elaboratePat (p: Apat.t, E: Env.t, preError: unit -> unit, amInRvb: bool)
    : Cpat.t * (Avar.t * Var.t * Type.t) vector =
    let
       val region = Apat.region p
@@ -372,6 +373,7 @@
 	 (fn p: Apat.t =>
 	  let
 	     val region = Apat.region p
+	     val unify = fn (t, t', f) => unify (t, t', preError, f)
 	     fun unifyPatternConstraint (p, lay, c) =
 		unify
 		(p, c, fn (l1, l2) =>
@@ -393,7 +395,8 @@
 		      val resultType = Type.new ()
 		      val _ =
 			 unify
-			 (instance, Type.arrow (argType, resultType), fn _ =>
+			 (instance, Type.arrow (argType, resultType),
+			  fn _ =>
 			  (region,
 			   str "constant constructor applied to argument",
 			   seq [str "pattern: ", lay ()]))
@@ -459,6 +462,7 @@
 				 unifyList
 				 (Vector.map2 (ps, ps', fn (p, p') =>
 					       (Cpat.ty p', Apat.region p)),
+				  preError,
 				  fn () => seq [str "pattern:  ", lay ()]))
 		   end
 	      | Apat.Record {flexible, items} =>
@@ -992,6 +996,8 @@
 	  Layout.ignore, Trace.assertTrue)
 	 (fn (d, nest, isTop) =>
 	  let
+	     val preError = Promise.lazy (fn () => Env.setTyconNames E)
+	     val unify = fn (t, t', f) => unify (t, t', preError, f)
 	     fun lay () = seq [str "in: ", approximate (Adec.layout d)]
 	     val region = Adec.region d
 	     fun checkSchemes (v: (Var.t * Scheme.t) vector): unit =
@@ -1218,7 +1224,8 @@
 				     val pats =
 					Vector.map
 					(args, fn p =>
-					 {pat = #1 (elaboratePat (p, E, false)),
+					 {pat = #1 (elaboratePat
+						    (p, E, preError, false)),
 					  region = Apat.region p})
 				     val bodyRegion = Aexp.region body
 				     val body = elabExp (body, nest)
@@ -1466,7 +1473,8 @@
 			 (rvbs, fn {pat, match} =>
 			  let
 			     val region = Apat.region pat
-			     val (pat, bound) = elaboratePat (pat, E, true)
+			     val (pat, bound) =
+				elaboratePat (pat, E, preError, true)
 			     val (nest, var, ty) =
 				if 0 = Vector.length bound
 				   then ("anon" :: nest,
@@ -1500,7 +1508,7 @@
 			 (rvbs, fn {bound, match, nest, pat, region, var, ...} =>
 			  let
 			     val {argType, region, resultType, rules} =
-				elabMatch (match, nest)
+				elabMatch (match, preError, nest)
 			     val _ =
 				unify
 				(Cpat.ty pat,
@@ -1542,7 +1550,8 @@
 			 (vbs,
 			  fn {exp = e, expRegion, lay, pat, patRegion, ...} =>
 			  let
-			     val (p, bound) = elaboratePat (pat, E, false)
+			     val (p, bound) =
+				elaboratePat (pat, E, preError, false)
 			     val _ =
 				unify
 				(Cpat.ty p, Cexp.ty e, fn (p, e) =>
@@ -1596,6 +1605,8 @@
 			  Trace.assertTrue)
 	 (fn (e: Aexp.t, nest) =>
 	  let
+	     val preError = Promise.lazy (fn () => Env.setTyconNames E)
+	     val unify = fn (t, t', f) => unify (t, t', preError, f)
 	     fun lay () = seq [str "in: ", approximate (Aexp.layout e)]
 	     val unify =
 		fn (a, b, f) => unify (a, b, fn z =>
@@ -1662,7 +1673,7 @@
 		   let
 		      val e = elab e
 		      val {argType, resultType, rules, ...} =
-			 elabMatch (m, nest)
+			 elabMatch (m, preError, nest)
 		      val _ =
 			 unify
 			 (Cexp.ty e, argType, fn (l1, l2) =>
@@ -1695,7 +1706,8 @@
 	      | Aexp.Fn m =>
 		   let
 		      val {arg, argType, body} =
-			 elabMatchFn (m, nest, "function", lay, Cexp.RaiseMatch)
+			 elabMatchFn (m, preError, nest, "function", lay,
+				      Cexp.RaiseMatch)
 		      val body =
 			 Cexp.enterLeave
 			 (body, SourceInfo.function {name = nest,
@@ -1710,7 +1722,7 @@
 		   let
 		      val try = elab try
 		      val {arg, argType, body} =
-			 elabMatchFn (match, nest, "handler", lay,
+			 elabMatchFn (match, preError, nest, "handler", lay,
 				      Cexp.RaiseAgain)
 		      val _ =
 			 unify
@@ -1769,7 +1781,7 @@
 				 unifyList
 				 (Vector.map2 (es, es', fn (e, e') =>
 					       (Cexp.ty e', Aexp.region e)),
-				  lay))
+				  preError, lay))
 		   end
 	      | Aexp.Orelse (e, e') =>
 		   let
@@ -2001,10 +2013,11 @@
 		      Cexp.whilee {expr = expr, test = test'}
 		   end
 	  end) arg
-      and elabMatchFn (m: Amatch.t, nest, kind, lay, noMatch) =
+      and elabMatchFn (m: Amatch.t, preError, nest, kind, lay, noMatch) =
 	 let
 	    val arg = Var.newNoname ()
-	    val {argType, region, resultType, rules} = elabMatch (m, nest)
+	    val {argType, region, resultType, rules} =
+	       elabMatch (m, preError, nest)
 	    val body =
 	       Cexp.casee {kind = kind,
 			   lay = lay,
@@ -2017,7 +2030,7 @@
 	    argType = argType,
 	    body = body}
 	 end
-      and elabMatch (m: Amatch.t, nest: Nest.t) =
+      and elabMatch (m: Amatch.t, preError, nest: Nest.t) =
 	 let
 	    val region = Amatch.region m
 	    val Amatch.T rules = Amatch.node m
@@ -2036,10 +2049,10 @@
 			  approximate
 			  (seq [Apat.layout pat, str " => ", Aexp.layout exp])
 		       end
-		    val (p, xts) = elaboratePat (pat, E, false)
+		    val (p, xts) = elaboratePat (pat, E, preError, false)
 		    val _ =
 		       unify
-		       (Cpat.ty p, argType, fn (l1, l2) =>
+		       (Cpat.ty p, argType, preError, fn (l1, l2) =>
 			(Apat.region pat,
 			 str "rule patterns of different types",
 			 align [seq [str "pattern:  ", l1],
@@ -2048,7 +2061,7 @@
 		    val e = elabExp (exp, nest)
 		    val _ =
 		       unify
-		       (Cexp.ty e, resultType, fn (l1, l2) =>
+		       (Cexp.ty e, resultType, preError, fn (l1, l2) =>
 			(Aexp.region exp,
 			 str "rule results of different types",
 			 align [seq [str "result:   ", l1],



1.24      +68 -1     mlton/mlton/elaborate/elaborate-env.fun

Index: elaborate-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.fun,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -r1.23 -r1.24
--- elaborate-env.fun	19 Dec 2003 00:40:56 -0000	1.23
+++ elaborate-env.fun	26 Dec 2003 23:40:22 -0000	1.24
@@ -266,12 +266,14 @@
 	      values = values}))
    end
 
+val allTycons: Tycon.t list ref = ref []
 val newTycons: (Tycon.t * Kind.t) list ref = ref []
 
 val newTycon: string * Kind.t -> Tycon.t =
    fn (s, k) =>
    let
       val c = Tycon.fromString s
+      val _ = List.push (allTycons, c)
       val _ = List.push (newTycons, (c, k))
    in
       c
@@ -1083,6 +1085,64 @@
       ; doit (types, types')
    end
 
+fun setTyconNames (T {strs, types, ...}) =
+   let
+      val {get = seen: Tycon.t -> bool ref, ...} =
+	 Property.get (Tycon.plist, Property.initFun (fn _ => ref false))
+      fun doType (typeStr: TypeStr.t,
+		  name: Ast.Tycon.t,
+		  strids: Strid.t list): unit =
+	 case TypeStr.toTyconOpt typeStr of
+	    NONE => ()
+	  | SOME c => 
+	       let
+		  val r = seen c
+	       in
+		  if !r
+		     then ()
+		  else
+		     let
+			val _ = r := true
+			val name =
+			   Ast.Longtycon.toString
+			   (Ast.Longtycon.long (strids, name))
+		     in
+			Tycon.setPrintName (c, name)
+		     end
+	       end
+      fun foreach (NameSpace.T {table, ...}, f) =
+	 HashSet.foreach
+	 (table, fn Values.T {domain, ranges} =>
+	  case !ranges of
+	     [] => ()
+	   | {value, ...} :: _ => f (domain, value))
+      val _ = foreach (types, fn (name, typeStr) => doType (typeStr, name, []))
+      val {get = strSeen: Structure.t -> bool ref, ...} =
+	 Property.get (Structure.plist, Property.initFun (fn _ => ref false))
+      fun loopStr (s as Structure.T {strs, types, ...}, strids: Strid.t list)
+	 : unit =
+	 let
+	    val r = strSeen s
+	 in
+	    if !r
+	       then ()
+	    else
+	       (r := true
+		; Info.foreach (types, fn (name, typeStr) =>
+				doType (typeStr, name, strids))
+		; Info.foreach (strs, fn (strid, str) =>
+				loopStr (str, strids @ [strid])))
+	 end
+      val _ = foreach (strs, fn (strid, str) => loopStr (str, [strid]))
+      val _ =
+	 List.foreach
+	 (!allTycons, fn c =>
+	  if ! (seen c)
+	     then ()
+	  else Tycon.setPrintName (c, concat ["?.", Tycon.originalName c]))
+   in
+      ()
+   end
 
 val propertyFun:
    ('a -> PropertyList.t) * ('a * 'b * ('a * 'b -> 'c) -> 'c)
@@ -1183,6 +1243,12 @@
 	 {opaque: bool, prefix: string}, region)
    : Structure.t * Decs.t =
    let
+      val preError =
+	 Promise.lazy
+	 (fn () =>
+	  scope (E, fn () =>
+		 (openStructure (E, S)
+		  ; setTyconNames E)))
       val decs = ref []
       fun error (name, l) =
 	 let
@@ -1211,6 +1277,7 @@
 					ty = ty',
 					tyvars = tyvars'},
 			   tyvars),
+	     preError,
 	     fn (l1, l2) =>
 	     let
 		open Layout
@@ -1437,7 +1504,7 @@
 				 Scheme.instantiate s'
 			      val _ =
 				 Type.unify
-				 (t, t', fn (l, l') =>
+				 (t, t', preError, fn (l, l') =>
 				  let
 				     open Layout
 				  in



1.14      +1 -0      mlton/mlton/elaborate/elaborate-env.sig

Index: elaborate-env.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.sig,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- elaborate-env.sig	19 Dec 2003 00:40:56 -0000	1.13
+++ elaborate-env.sig	26 Dec 2003 23:40:22 -0000	1.14
@@ -134,6 +134,7 @@
       val scope: t * (unit -> 'a) -> 'a
       (* like scope, but works for signatures and functors as well *)
       val scopeAll: t * (unit -> 'a) -> 'a
+      val setTyconNames: t -> unit
       val sizeMessage: t -> Layout.t
    end
 



1.15      +119 -170  mlton/mlton/elaborate/type-env.fun

Index: type-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/type-env.fun,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- type-env.fun	20 Dec 2003 02:24:35 -0000	1.14
+++ type-env.fun	26 Dec 2003 23:40:22 -0000	1.15
@@ -845,7 +845,7 @@
 
       val traceUnify = Trace.trace2 ("unify", layout, layout, UnifyResult.layout)
 
-      fun unify (t, t'): UnifyResult.t =
+      fun unify (t, t', preError: unit -> unit): UnifyResult.t =
 	 let
 	    val {destroy, lay = layoutPretty} = makeLayoutPretty ()
 	    val dontCare' =
@@ -874,74 +874,41 @@
 			   needsParen = false})
 		      fun notUnifiableBracket (l, l') =
 			 notUnifiable (bracket l, bracket l')
+		      fun flexToRecord (fields, spine) =
+			 (Vector.fromList fields,
+			  Vector.fromList
+			  (List.fold
+			   (Spine.fields spine, [], fn (f, ac) =>
+			    if List.exists (fields, fn (f', _) =>
+					    Field.equals (f, f'))
+			       then ac
+			    else f :: ac)),
+			  fn f => Spine.ensureField (spine, f))
+		      fun rigidToRecord r =
+			 (Srecord.toVector r,
+			  Vector.new0 (),
+			  fn f => isSome (Srecord.peek (r, f)))
 		      fun oneFlex ({fields, spine, time}, r, outer, swap) =
 			 let
 			    val _ = minTime (outer, !time)
-			    val (ac, ac') =
-			       List.fold
-			       (fields, ([], []), fn ((f, t), (ac, ac')) =>
-				case Srecord.peek (r, f) of
-				   NONE => ((f, true, dontCare' t) :: ac, ac')
-				 | SOME t' =>
-				      case unify (t, t') of
-					 NotUnifiable (l, l') =>
-					    ((f, false, l) :: ac,
-					     (f, false, l') :: ac')
-				       | Unified =>
-					    (case !Control.typeError of
-						Control.Concise => (ac, ac')
-					      | Control.Full =>
-						   let
-						      val z =
-							 (f, false,
-							  layoutPretty t)
-						   in
-						      (z :: ac, z :: ac')
-						   end))
-			    val ac =
-			       List.fold
-			       (Spine.fields spine, ac,
-				fn (f, ac) =>
-				if List.exists (fields, fn (f', _) =>
-						Field.equals (f, f'))
-				   then ac
-				else
-				   case Srecord.peek (r, f) of
-				      NONE => (f, true, dontCare) :: ac
-				    | SOME _ => ac)
-			    val ac' =
-			       Srecord.foldi
-			       (r, ac', fn (f, t, ac') =>
-				if Spine.ensureField (spine, f)
-				   then ac'
-				else (f, true, dontCare' t) :: ac')
-			    val _ = Spine.noMoreFields spine
 			 in
-			    case (ac, ac') of
-			       ([], []) => (Unified, Record r)
-			     | _ =>
-				  let
-				     val ds = layoutRecord ac
-				     val ds' = layoutRecord ac'
-				  in
-				     notUnifiable (if swap then (ds', ds)
-						   else (ds, ds'))
-				  end
+			    unifyRecords
+			    (flexToRecord (fields, spine),
+			     rigidToRecord r,
+			     fn () => (Spine.noMoreFields spine
+				       ; (Unified, Record r)),
+			     fn (l, l') => notUnifiable (if swap
+							    then (l', l)
+							 else (l, l')))
 			 end
 		      fun genFlexError () =
 			 Error.bug "GenFlexRecord seen in unify"
 		      val {equality = e, ty = t, plist} = Set.value s
 		      val {equality = e', ty = t', ...} = Set.value s'
 		      fun not () =
-			 (* By choosing layoutTopLevel, when two types don't
-			  * unify, we only see the outermost bits.  On the other
-			  * hand, if we choose layoutPretty, then we see the
-			  * whole type that didn't unify.
-			  *)
-			 notUnifiableBracket
-			 (if true
-			     then (layoutPretty outer, layoutPretty outer')
-			  else (layoutTopLevel t, layoutTopLevel t'))
+			 (preError ()
+			  ; notUnifiableBracket (layoutPretty outer,
+						 layoutPretty outer'))
 		      fun unifys (ts, ts', yes, no) =
 			 let
 			    val us = Vector.map2 (ts, ts', unify)
@@ -989,6 +956,7 @@
 							       (Vector.length ts),
 							       " args> "]),
 						      Tycon.layout c])
+						 val _ = preError ()
 					      in
 						 notUnifiableBracket
 						 (maybe (lay ts, lay ts'))
@@ -1041,71 +1009,30 @@
 			  | (FlexRecord {fields = fields, spine = s, time = t},
 			     FlexRecord {fields = fields', spine = s',
 					 time = t', ...}) =>
-			       let
-				  fun subsetSpine (fields, spine, spine') =
-				     List.fold
-				     (Spine.fields spine, [], fn (f, ac) =>
-				      if List.exists (fields, fn (f', _) =>
-						      Field.equals (f, f'))
-					 orelse Spine.ensureField (spine', f)
-					 then ac
-				      else (f, true, dontCare) :: ac)
-				  val ac = subsetSpine (fields, s, s')
-				  val ac' = subsetSpine (fields', s', s)
-				  fun subset (fields, fields', spine', ac, ac',
-					      skipBoth) =
-				     List.fold
-				     (fields, (ac, ac'),
-				      fn ((f, t), (ac, ac')) =>
-				      case List.peek (fields', fn (f', _) =>
-						      Field.equals (f, f')) of
-					 NONE =>
-					    if Spine.ensureField (spine', f)
-					       then (ac, ac')
-					    else ((f, true, dontCare) :: ac, ac')
-				       | SOME (_, t') =>
-					    if skipBoth
-					       then (ac, ac')
-					    else
-					       case unify (t, t') of
-						  NotUnifiable (l, l') =>
-						     ((f, false, l) :: ac,
-						      (f, false, l) :: ac')
-						| Unified =>
-						     (case !Control.typeError of
-							 Control.Concise =>
-							    (ac, ac')
-						       | Control.Full =>
-							    let
-							       val z =
-								  (f, false,
-								   layoutPretty t)
-							    in
-							       (z :: ac, z :: ac')
-							    end))
-				  val (ac, ac') =
-				     subset (fields, fields', s', ac, ac', false)
-				  val (ac', ac) =
-				     subset (fields', fields, s, ac', ac, true)
-				  val _ = Spine.unify (s, s')
-				  val fields =
-				     List.fold
-				     (fields, fields', fn ((f, t), ac) =>
-				      if List.exists (fields', fn (f', _) =>
-						      Field.equals (f, f'))
-					 then ac
-				      else (f, t) :: ac)
-			       in
-				  case (ac, ac') of
-				     ([], []) =>
-					(Unified,
-					 FlexRecord
-					 {fields = fields,
-					  spine = s,
-					  time = ref (Time.min (!t, !t'))})
-				   | _ => notUnifiable (layoutRecord ac,
-							layoutRecord ac')
-			       end
+			    let
+			       fun yes () =
+				  let
+				     val _ = Spine.unify (s, s')
+				     val fields =
+					List.fold
+					(fields, fields', fn ((f, t), ac) =>
+					 if List.exists (fields', fn (f', _) =>
+							 Field.equals (f, f'))
+					    then ac
+					 else (f, t) :: ac)
+				  in
+				     (Unified,
+				      FlexRecord
+				      {fields = fields,
+				       spine = s,
+				       time = ref (Time.min (!t, !t'))})
+				  end
+			    in
+			       unifyRecords
+			       (flexToRecord (fields, s),
+				flexToRecord (fields', s'),
+				yes, notUnifiable)
+			    end
 			  | (GenFlexRecord _, _) => genFlexError ()
 			  | (_, GenFlexRecord _) => genFlexError ()
 			  | (Int, Int) => (Unified, Int)
@@ -1114,47 +1041,10 @@
 			       (case (Srecord.detupleOpt r,
 				      Srecord.detupleOpt r') of
 				   (NONE, NONE) =>
-				      let
-					 fun diffs (r, r', skipBoth, ac, ac') =
-					    Vector.fold
-					    (Srecord.toVector r, (ac, ac'),
-					     fn ((f, t), (ac, ac')) =>
-					     case Srecord.peek (r', f) of
-						NONE =>
-						   ((f, true, dontCare' t) :: ac,
-						    ac')
-					      | SOME t' =>
-						   if skipBoth
-						      then (ac, ac')
-						   else
-						      case unify (t, t') of
-							 NotUnifiable (l, l') =>
-							    ((f, false, l) :: ac,
-							     (f, false, l') :: ac')
-						       | Unified =>
-							    case !Control.typeError of
-							       Control.Concise => (ac, ac')
-							     | Control.Full =>
-								  let
-								     val z =
-									(f, false,
-									 layoutPretty t)
-								  in
-								     (z :: ac,
-								      z :: ac')
-								  end)
-					 val (ac, ac') =
-					    diffs (r, r', false, [], [])
-					 val (ac', ac) =
-					    diffs (r', r, true, ac', ac)
-				      in
-					 case (ac, ac') of
-					    ([], []) =>
-					       (Unified, Record r)
-					  | _ =>
-					       notUnifiable (layoutRecord ac,
-							     layoutRecord ac')
-				      end
+				      unifyRecords
+				      (rigidToRecord r, rigidToRecord r',
+				       fn () => (Unified, Record r),
+				       notUnifiable)
 				 | (SOME ts, SOME ts') =>
 				      if Vector.length ts = Vector.length ts'
 					 then
@@ -1192,6 +1082,65 @@
 		   in
 		      res
 		   end) arg
+	    and unifyRecords ((fields: (Field.t * t) vector,
+			       extra: Field.t vector,
+			       ensureField: Field.t -> bool),
+			      (fields': (Field.t * t) vector,
+			       extra': Field.t vector,
+			       ensureField': Field.t -> bool),
+			      yes, no) =
+	       let
+		  fun extras (extra, ensureField') =
+		     Vector.fold
+		     (extra, [], fn (f, ac) =>
+		      if ensureField' f
+			 then ac
+		      else (preError (); (f, true, dontCare) :: ac))
+		  val ac = extras (extra, ensureField')
+		  val ac' = extras (extra', ensureField)
+		  fun subset (fields, fields', ensureField', ac, ac',
+			      both, skipBoth) =
+		     Vector.fold
+		     (fields, (ac, ac', both), fn ((f, t), (ac, ac', both)) =>
+		      case Vector.peek (fields', fn (f', _) =>
+					Field.equals (f, f')) of
+			 NONE =>
+			    if ensureField' f
+			       then (ac, ac', both)
+			    else (preError ()
+				  ; ((f, true, dontCare' t) :: ac, ac', both))
+		       | SOME (_, t') =>
+			    if skipBoth
+			       then (ac, ac', both)
+			    else
+			       case unify (t, t') of
+				  NotUnifiable (l, l') =>
+				     ((f, false, l) :: ac,
+				      (f, false, l') :: ac',
+				      both)
+				| Unified =>
+				     (ac, ac',
+				      case !Control.typeError of
+					 Control.Concise => []
+				       | Control.Full => (f, t) :: both))
+		  val (ac, ac', both) =
+		     subset (fields, fields', ensureField', ac, ac', [], false)
+		  val (ac', ac, both) =
+		     subset (fields', fields, ensureField, ac', ac, both, true)
+	       in
+		  case (ac, ac') of
+		     ([], []) => yes ()
+		   | _ =>
+			let
+			   val _ = preError ()
+			   fun doit ac =
+			      layoutRecord (List.fold
+					    (both, ac, fn ((f, t), ac) =>
+					     (f, false, layoutPretty t) :: ac))
+			in
+			   no (doit ac, doit ac')
+			end
+	       end
 	    val _ = destroy ()
 	 in
 	    unify (t, t')
@@ -1215,8 +1164,8 @@
       datatype unifyResult = datatype UnifyResult'.t
 
       val unify =
-	 fn (t, t') =>
-	 case unify (t, t') of
+	 fn (t, t', preError) =>
+	 case unify (t, t', preError) of
 	    UnifyResult.NotUnifiable ((l, _), (l', _)) => NotUnifiable (l, l')
 	  | UnifyResult.Unified => Unified
 
@@ -1627,7 +1576,7 @@
 	 List.foreach
 	 (!Type.freeUnknowns, fn t =>
 	  case Type.toType t of
-	     Type.Unknown _ => (Type.unify (t, Type.unit)
+	     Type.Unknown _ => (Type.unify (t, Type.unit, fn () => ())
 				; ())
 	   | _ => ())
       val _ = Type.freeUnknowns := []
@@ -1728,9 +1677,9 @@
 	 expandOpaque
 
       val unify =
-	 fn (t1: t, t2: t,
+	 fn (t1: t, t2: t, preError: unit -> unit,
 	     f: Layout.t * Layout.t -> Region.t * Layout.t * Layout.t) =>
-	 case unify (t1, t2) of
+	 case unify (t1, t2, preError) of
 	    NotUnifiable z => Control.error (f z)
 	  | Unified => ()
    end



1.7       +4 -2      mlton/mlton/elaborate/type-env.sig

Index: type-env.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/type-env.sig,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- type-env.sig	14 Nov 2003 03:48:18 -0000	1.6
+++ type-env.sig	26 Dec 2003 23:40:22 -0000	1.7
@@ -47,8 +47,10 @@
 	    val string: t
 	    val toString: t -> string
 	    (* make two types identical (recursively).  side-effecting. *)
-	    val unify: t * t * (Layout.t * Layout.t
-				-> Region.t * Layout.t * Layout.t) -> unit 
+	    val unify:
+	       t * t * (unit -> unit)
+	       * (Layout.t * Layout.t -> Region.t * Layout.t * Layout.t)
+	       -> unit 
 	    val unresolvedInt: unit -> t
 	    val unresolvedReal: unit -> t
 	    val unresolvedWord: unit -> t



1.11      +5 -2      mlton/mlton/main/compile.fun

Index: compile.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/compile.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- compile.fun	14 Nov 2003 03:48:18 -0000	1.10
+++ compile.fun	26 Dec 2003 23:40:23 -0000	1.11
@@ -424,8 +424,11 @@
    end
 
 fun layoutBasisLibrary () = 
-   let val _ = selectBasisLibrary ()
-   in Env.layoutPretty basisEnv
+   let
+      val _ = selectBasisLibrary ()
+      val _ = Env.setTyconNames basisEnv
+   in
+      Env.layoutPretty basisEnv
    end
 
 (* ------------------------------------------------- *)