[MLton] cvs commit: more detail in type errors

[sweeks@mlton.org]

sweeks      03/12/18 19:29:52

  Modified:    mlton/elaborate type-env.fun
  Log:
  MAIL more detail in type errors
  
  Changed type error messages so that the entire type is shown for the
  parts that don't unify.  So, for this program
  
  	fun f (x: int, y: real) = 13
  	val _ = f (1, 2, 3)
  
  we now get
  
  Error: z.sml 2.9: function applied to incorrect argument
     expects: int * real
     but got: int * int * int
     in: f (1, 2, 3)
  
  instead of
  
  Error: z.sml 2.9: function applied to incorrect argument
     expects: _ * _
     but got: _ * _ * _
     in: f (1, 2, 3)
  
  The _ is still used for showing places that do unify (and hence we
  "don't care" about them).  So, for this program
  
  	fun f (x: int, y: real) = 13
  	val _ = f (1, 2)
  
  we get the same error as before:
  
  Error: z.sml 2.9: function applied to incorrect argument
     expects: _ * real
     but got: _ * int
     in: f (1, 2)

Revision  Changes    Path
1.12      +24 -4     mlton/mlton/elaborate/type-env.fun

Index: type-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/type-env.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- type-env.fun	14 Nov 2003 03:48:18 -0000	1.11
+++ type-env.fun	19 Dec 2003 03:29:52 -0000	1.12
@@ -551,7 +551,9 @@
 	    res
 	 end
 
-      fun layoutPretty (t: t): Layout.t =
+      fun makeLayoutPretty (): {destroy: unit -> unit,
+				lay: t -> Layout.t * {isChar: bool,
+						      needsParen: bool}} =
 	 let
 	    val str = Layout.str
 	    fun maybeParen (b, t) = if b then Layout.paren t else t
@@ -602,7 +604,7 @@
 		 end))
 	    fun var (_, a) = prettyTyvar a
 	    fun word _ = simple (str "word")
-	    val (res, _) =
+	    fun lay t =
 	       hom (t, {con = con,
 			expandOpaque = Never,
 			flexRecord = flexRecord,
@@ -614,6 +616,15 @@
 			unknown = unknown,
 			var = var,
 			word = word})
+	 in
+	    {destroy = destroy,
+	     lay = lay}
+	 end
+
+      fun layoutPretty t =
+	 let
+	    val {destroy, lay} = makeLayoutPretty ()
+	    val res = #1 (lay t)
 	    val _ = destroy ()
 	 in
 	    res
@@ -827,6 +838,7 @@
 
       fun unify (t, t'): UnifyResult.t =
 	 let
+	    val {destroy, lay = layoutPretty} = makeLayoutPretty ()
 	    val layoutRecord = fn z => layoutRecord (z, true)
 	    fun unify arg =
 	       traceUnify
@@ -886,10 +898,17 @@
 		      val {equality = e, ty = t, plist} = Set.value s
 		      val {equality = e', ty = t', ...} = Set.value s'
 		      fun not () =
-			 notUnifiable (layoutTopLevel t, layoutTopLevel t')
+			 (* 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.
+			  *)
+			 notUnifiable
+			 (if true
+			     then (layoutPretty outer, layoutPretty outer')
+			  else (layoutTopLevel t, layoutTopLevel t'))
 		      fun conAnd (c, ts, t, t', swap) =
 			 let
-			    fun lay () = layoutTopLevel (Con (c, ts))
 			    val notUnifiable =
 			       fn (z, z') =>
 			       notUnifiable (if swap then (z', z) else (z, z'))
@@ -1120,6 +1139,7 @@
 		   in
 		      res
 		   end) arg
+	    val _ = destroy ()
 	 in
 	    unify (t, t')
 	 end