[MLton] cvs commit: -type-error {concise|full}

sweeks@mlton.org sweeks@mlton.org
Thu, 18 Dec 2003 21:03:13 -0800


sweeks      03/12/18 21:03:12

  Modified:    mlton/control control.sig control.sml
               mlton/elaborate type-env.fun
               mlton/main main.fun
  Log:
  MAIL -type-error {concise|full}
  
  Added a switch that controls the display of type error messages.  With
  -type-error concise, only the components that don't unify are shown.
  With -type-error full, all of the type is shown.  In both cases, to
  make it easier to visually spot the differences, brackets are placed
  around the parts that aren't unifiable.
  
  Consider this program
  
  	fun f {w: int, x: int, y: real} = 13
  	val _ = f {w = 13, x = 13.0, z = 14}
  	fun f (x: int, y: real) = 13
  	val _ = f (1, 2, 3)
  	fun f (x: int, y: real) = 13
  	val _ = f (1, 2)
  
  With -type-error concise, the error messages are:
  
  Error: z.sml 2.9: function applied to incorrect argument
     expects: {x: [int], [y]: _, ...}
     but got: {x: [real], [z]: _, ...}
     in: f {w = 13, x = 13.0, z = 14}
  Error: z.sml 4.9: function applied to incorrect argument
     expects: [int * real]
     but got: [int * int * int]
     in: f (1, 2, 3)
  Error: z.sml 6.9: function applied to incorrect argument
     expects: _ * [real]
     but got: _ * [int]
     in: f (1, 2)
  
  With -type-error full, the error messages are:
  
  Error: z.sml 2.9: function applied to incorrect argument
     expects: {w: int, x: [int], [y]: real}
     but got: {w: int, x: [real], [z]: int}
     in: f {w = 13, x = 13.0, z = 14}
  Error: z.sml 4.9: function applied to incorrect argument
     expects: [int * real]
     but got: [int * int * int]
     in: f (1, 2, 3)
  Error: z.sml 6.9: function applied to incorrect argument
     expects: int * [real]
     but got: int * [int]
     in: f (1, 2)
  
  For now, -type-error concise is the default.  Unlike some of our
  earlier ideas based on print-graph from Scheme, I chose to bracket the
  parts of the types that are different, instead of those that are the
  same.  I think that makes more sense since we care more about the
  differences when there is a unification error.  I decided to use
  brackets because {} and () are already taken and I want something that
  matches.
  
  I'd like people to try these out and send
  
  * bug reports
  * thoughts on which should be the default.  Do we even need both?
  * thoughts on other improvements
  
  Once we sort this out (soon), I'd like to make an experimental release
  and announce it on MLton-user to start getting more feedback on the
  front end (and all the other improvements).

Revision  Changes    Path
1.84      +3 -0      mlton/mlton/control/control.sig

Index: control.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sig,v
retrieving revision 1.83
retrieving revision 1.84
diff -u -r1.83 -r1.84
--- control.sig	22 Nov 2003 23:21:49 -0000	1.83
+++ control.sig	19 Dec 2003 05:03:10 -0000	1.84
@@ -237,6 +237,9 @@
 	 
       (* Type check ILs. *)
       val typeCheck: bool ref
+
+      datatype typeError = Concise | Full
+      val typeError: typeError ref
 	 
       (* Should the basis library be prefixed onto the program. *)
       val useBasisLibrary: bool ref



1.103     +15 -0     mlton/mlton/control/control.sml

Index: control.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sml,v
retrieving revision 1.102
retrieving revision 1.103
diff -u -r1.102 -r1.103
--- control.sml	22 Nov 2003 23:21:50 -0000	1.102
+++ control.sml	19 Dec 2003 05:03:10 -0000	1.103
@@ -450,6 +450,21 @@
 val typeCheck = control {name = "type check",
 			 default = false,
 			 toString = Bool.toString}
+
+structure TypeError =
+   struct
+      datatype t = Concise | Full
+
+      val toString =
+	 fn Concise => "concise"
+	  | Full => "full"
+   end
+
+datatype typeError = datatype TypeError.t
+
+val typeError = control {name = "type error",
+			 default = Concise,
+			 toString = TypeError.toString}
    
 val useBasisLibrary = control {name = "use basis library",
 			       default = true,



1.13      +143 -95   mlton/mlton/elaborate/type-env.fun

Index: type-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/type-env.fun,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- type-env.fun	19 Dec 2003 03:29:52 -0000	1.12
+++ type-env.fun	19 Dec 2003 05:03:11 -0000	1.13
@@ -357,7 +357,8 @@
    fun simple (l: Layout.t): z =
       (l, {isChar = false, needsParen = false})
    val dontCare: z = simple (str "_")
-   fun layoutRecord (ds: (Field.t * z) list, flexible: bool) =
+   fun bracket l = seq [str "[", l, str "]"]
+   fun layoutRecord (ds: (Field.t * bool * z) list, flexible: bool) =
       simple (case ds of
 		 [] => str "{...}"
 	       | _ => 
@@ -365,9 +366,15 @@
 			 mayAlign
 			 (separateRight
 			  (List.map
-			   (QuickSort.sortList (ds, fn ((f, _), (f', _)) =>
+			   (QuickSort.sortList (ds, fn ((f, _, _), (f', _, _)) =>
 						Field.<= (f, f')),
-			    fn (f, (l, _)) => seq [Field.layout f, str ": ", l]),
+			    fn (f, b, (l, _)) =>
+			    let
+			       val f = Field.layout f
+			       val f = if b then bracket f else f
+			    in
+			       seq [f, str ": ", l]
+			    end),
 			   ",")),
 			 str (if flexible
 				 then ", ...}"
@@ -564,23 +571,25 @@
 	       (List.fold
 		(fields,
 		 Spine.foldOverNew (spine, fields, [], fn (f, ac) =>
-				    (f, simple (str "unit"))
+				    (f, false, simple (str "unit"))
 				    :: ac),
-		 fn ((f, t), ac) => (f, t) :: ac),
+		 fn ((f, t), ac) => (f, false, t) :: ac),
 		Spine.canAddFields spine)
 	    fun genFlexRecord (_, {extra, fields, spine}) =
 	       layoutRecord
 	       (List.fold
 		(fields,
 		 List.revMap (extra (), fn {field, tyvar} =>
-			      (field, simple (Tyvar.layout tyvar))),
-		 fn ((f, t), ac) => (f, t) :: ac),
+			      (field, false, simple (Tyvar.layout tyvar))),
+		 fn ((f, t), ac) => (f, false, t) :: ac),
 		Spine.canAddFields spine)
 	    fun real _ = simple (str "real")
 	    fun record (_, r) =
 	       case Srecord.detupleOpt r of
 		  NONE =>
-		     layoutRecord (Vector.toList (Srecord.toVector r), false)
+		     layoutRecord (Vector.toListMap (Srecord.toVector r,
+						     fn (f, t) => (f, false, t)),
+				   false)
 		| SOME ts => Tycon.layoutApp (Tycon.tuple, ts)
 	    fun recursive _ = simple (str "<recur>")
 	    fun unknown (_, u) = simple (str "???")
@@ -839,7 +848,15 @@
       fun unify (t, t'): UnifyResult.t =
 	 let
 	    val {destroy, lay = layoutPretty} = makeLayoutPretty ()
-	    val layoutRecord = fn z => layoutRecord (z, true)
+	    val dontCare' =
+	       case !Control.typeError of
+		  Control.Concise => (fn _ => dontCare)
+		| Control.Full => layoutPretty
+	    val layoutRecord =
+	       fn z => layoutRecord (z,
+				     case !Control.typeError of
+					Control.Concise => true
+				      | Control.Full => false)
 	    fun unify arg =
 	       traceUnify
 	       (fn (outer as T s, outer' as T s') =>
@@ -850,44 +867,58 @@
 		      fun notUnifiable (l: Lay.t, l': Lay.t) =
 			 (NotUnifiable (l, l'),
 			  Unknown (Unknown.new {canGeneralize = true}))
+		      val bracket = fn (l, z) => (bracket l, z)
+		      fun notUnifiableBracket (l, l') =
+			 notUnifiable (bracket l, bracket l')
 		      fun oneFlex ({fields, spine, time}, r, outer, swap) =
 			 let
 			    val _ = minTime (outer, !time)
-			    val differences =
+			    val (ac, ac') =
 			       List.fold
 			       (fields, ([], []), fn ((f, t), (ac, ac')) =>
 				case Srecord.peek (r, f) of
-				   NONE => ((f, dontCare) :: ac, ac')
+				   NONE => ((f, true, dontCare' t) :: ac, ac')
 				 | SOME t' =>
 				      case unify (t, t') of
 					 NotUnifiable (l, l') =>
-					    ((f, l) :: ac, (f, l') :: ac')
-				       | Unified => (ac, ac'))
-			    val (ac, ac') =
+					    ((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, differences,
-				fn (f, (ac, ac')) =>
+			       (Spine.fields spine, ac,
+				fn (f, ac) =>
 				if List.exists (fields, fn (f', _) =>
 						Field.equals (f, f'))
-				   then (ac, ac')
+				   then ac
 				else
 				   case Srecord.peek (r, f) of
-				      NONE => ((f, dontCare) :: ac, ac')
-				    | SOME _ => (ac, ac'))
+				      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, dontCare) :: ac')
+				else (f, true, dontCare' t) :: ac')
 			    val _ = Spine.noMoreFields spine
 			 in
-			    case differences of
+			    case (ac, ac') of
 			       ([], []) => (Unified, Record r)
-			     | (ds, ds') =>
+			     | _ =>
 				  let
-				     val ds = layoutRecord ds
-				     val ds' = layoutRecord ds'
+				     val ds = layoutRecord ac
+				     val ds' = layoutRecord ac'
 				  in
 				     notUnifiable (if swap then (ds', ds)
 						   else (ds, ds'))
@@ -903,15 +934,41 @@
 			  * hand, if we choose layoutPretty, then we see the
 			  * whole type that didn't unify.
 			  *)
-			 notUnifiable
+			 notUnifiableBracket
 			 (if true
 			     then (layoutPretty outer, layoutPretty outer')
 			  else (layoutTopLevel t, layoutTopLevel t'))
+		      fun unifys (ts, ts', yes, no) =
+			 let
+			    val us = Vector.map2 (ts, ts', unify)
+			 in
+			    if Vector.forall
+			       (us, fn Unified => true | _ => false)
+			       then yes ()
+			    else
+			       let
+				  val (ls, ls') =
+				     Vector.unzip
+				     (Vector.mapi
+				      (us, fn (i, u) =>
+				       case u of
+					  Unified =>
+					     let
+						val z =
+						   dontCare' (Vector.sub (ts, i))
+					     in
+						(z, z)
+					     end
+					| NotUnifiable (l, l') => (l, l')))
+			       in
+				  no (ls, ls')
+			       end
+			 end
 		      fun conAnd (c, ts, t, t', swap) =
 			 let
-			    val notUnifiable =
-			       fn (z, z') =>
-			       notUnifiable (if swap then (z', z) else (z, z'))
+			    fun notUnifiable (z, z') =
+			       notUnifiableBracket
+			       (if swap then (z', z) else (z, z'))
 			 in
 			    case t of
 			       Con (c', ts') =>
@@ -933,33 +990,16 @@
 						 notUnifiable (lay ts, lay ts')
 					      end
 					else
-					   let
-					      val us =
-						 Vector.map2 (ts, ts', unify)
-					   in
-					      if Vector.forall
-						 (us,
-						  fn Unified => true
-						   | _ => false)
-						 then (Unified, t)
-					      else
-						 let
-						    val (ls, ls') =
-						       Vector.unzip
-						       (Vector.map
-							(us,
-							 fn Unified =>
-							    (dontCare,
-							     dontCare)
-							  | NotUnifiable (l, l') =>
-							       (l, l')))
-						    fun lay ls =
-						       Tycon.layoutApp (c, ls)
-						 in
-						    notUnifiable (lay ls,
-								  lay ls')
-						 end
-					   end
+					   unifys
+					   (ts, ts',
+					    fn () => (Unified, t),
+					    fn (ls, ls') =>
+					    let 
+					       fun lay ls =
+						  Tycon.layoutApp (c, ls)
+					    in
+					       notUnifiable (lay ls, lay ls')
+					    end)
 				  else not ()
 			     | Int =>
 				  if Tycon.isIntX c andalso Vector.isEmpty ts
@@ -1004,10 +1044,11 @@
 						      Field.equals (f, f'))
 					 orelse Spine.ensureField (spine', f)
 					 then ac
-				      else (f, dontCare) :: 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') =
+				  fun subset (fields, fields', spine', ac, ac',
+					      skipBoth) =
 				     List.fold
 				     (fields, (ac, ac'),
 				      fn ((f, t), (ac, ac')) =>
@@ -1016,16 +1057,31 @@
 					 NONE =>
 					    if Spine.ensureField (spine', f)
 					       then (ac, ac')
-					    else ((f, dontCare) :: ac, ac')
+					    else ((f, true, dontCare) :: ac, ac')
 				       | SOME (_, t') =>
-					    case unify (t, t') of
-					       NotUnifiable (l, l') =>
-						  ((f, l) :: ac, (f, l) :: ac')
-					     | Unified => (ac, ac'))
-				  val (ac, ac') =
-				     subset (fields, fields', s', ac, ac')
+					    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, [], [])
+				     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
@@ -1060,16 +1116,28 @@
 					     fn ((f, t), (ac, ac')) =>
 					     case Srecord.peek (r', f) of
 						NONE =>
-						   ((f, dontCare) :: ac, ac')
+						   ((f, true, dontCare' t) :: ac,
+						    ac')
 					      | SOME t' =>
 						   if skipBoth
 						      then (ac, ac')
 						   else
 						      case unify (t, t') of
 							 NotUnifiable (l, l') =>
-							    ((f, l) :: ac,
-							     (f, l') :: ac')
-						       | Unified => (ac, ac'))
+							    ((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) =
@@ -1085,32 +1153,12 @@
 				 | (SOME ts, SOME ts') =>
 				      if Vector.length ts = Vector.length ts'
 					 then
-					    let
-					       val us =
-						  Vector.map2 (ts, ts', unify)
-					    in
-					       if Vector.forall
-						  (us,
-						   fn Unified => true
-						    | _ => false)
-						  then (Unified, Record r)
-					       else
-						  let
-						     val (ls, ls') =
-							Vector.unzip
-							(Vector.map
-							 (us,
-							  fn Unified =>
-							        (dontCare,
-								 dontCare)
-							   | NotUnifiable (l, l') =>
-								(l, l')))
-						  in
-						     notUnifiable
-						     (layoutTuple ls,
-						      layoutTuple ls')
-						  end
-					    end
+					    unifys
+					    (ts, ts',
+					     fn () => (Unified, Record r),
+					     fn (ls, ls') =>
+					     notUnifiable (layoutTuple ls,
+							   layoutTuple ls'))
 				      else not ()
 				 | _ => not ())
 			  | (Var a, Var a') =>



1.11      +8 -0      mlton/mlton/main/main.fun

Index: main.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- main.fun	18 Dec 2003 03:14:25 -0000	1.10
+++ main.fun	19 Dec 2003 05:03:12 -0000	1.11
@@ -368,6 +368,14 @@
 	intRef textIOBufSize),
        (Expert, "type-check", " {false|true}", "type check ILs",
 	boolRef typeCheck),
+       (Normal, "type-error", " {concise|full}", "type error verbosity",
+	SpaceString
+	(fn s =>
+	 typeError := (case s of
+			  "concise" => Concise
+			| "full" => Full
+			| _ => usage (concat
+				      ["invalid -type-error arg: ", s])))),
        (Normal, "verbose", " {0|1|2|3}", "how verbose to be",
 	SpaceString
 	(fn s =>