[typer] try out a different unification error style (#7547)

src/core/error.ml

@@ -68,19 +68,196 @@ let unify_error_msg ctx = function
 		cf.cf_name ^ " has no overload for " ^ s_type ctx t
 	| FinalInvariance ->
 		"Cannot unify final and non-final fields"
-	| Invalid_function_argument i ->
+	| Invalid_function_argument(i,_) ->
 		Printf.sprintf "Cannot unify argument %i" i
 	| Invalid_return_type ->
 		"Cannot unify return types"
 	| Unify_custom msg ->
 		msg
 
+module BetterErrors = struct
+	type access_kind =
+		| Field of string
+		| FunctionArgument of int * int
+		| FunctionReturn
+		| TypeParameter of int
+		| Root
+
+	type access = {
+		acc_kind : access_kind;
+		mutable acc_expected : Type.t;
+		mutable acc_actual : Type.t;
+		mutable acc_messages : unify_error list;
+		mutable acc_next : access option;
+	}
+
+	let s_access_kind = function
+		| Field s -> "Field " ^ s
+		| FunctionArgument(i,l) -> Printf.sprintf "FunctionArgument(%i, %i)" i l
+		| FunctionReturn -> "FunctionReturn"
+		| TypeParameter i -> Printf.sprintf "TypeParameter %i" i
+		| Root -> "Root"
+
+	let get_access_chain ctx l =
+		let make_acc kind actual expected = {
+			acc_kind = kind;
+			acc_expected = expected;
+			acc_actual = actual;
+			acc_messages = [];
+			acc_next = None;
+		} in
+		let root_acc = make_acc Root t_dynamic t_dynamic in
+		let current_acc = ref root_acc in
+		let add_message msg =
+			!current_acc.acc_messages <- msg :: !current_acc.acc_messages
+		in
+		let add_access kind =
+			let acc = make_acc kind t_dynamic t_dynamic in
+			!current_acc.acc_next <- Some acc;
+			current_acc := acc;
+		in
+		List.iter (fun err -> match err with
+			| Cannot_unify(t1,t2) ->
+				!current_acc.acc_actual <- t1;
+				!current_acc.acc_expected <- t2;
+				add_message err
+			| Invalid_field_type s ->
+				add_access (Field s);
+			| Invalid_function_argument(i,l) ->
+				add_access (FunctionArgument(i,l));
+			| Invalid_return_type ->
+				add_access FunctionReturn;
+			| Invariant_parameter i ->
+				add_access (TypeParameter i);
+			| _ ->
+				add_message err
+		) l;
+		root_acc
+
+	(* non-recursive s_type *)
+	let rec s_type ctx t =
+		match t with
+		| TMono r ->
+			(match !r with
+			| None -> Printf.sprintf "Unknown<%d>" (try List.assq t (!ctx) with Not_found -> let n = List.length !ctx in ctx := (t,n) :: !ctx; n)
+			| Some t -> s_type ctx t)
+		| TEnum (e,tl) ->
+			s_type_path e.e_path ^ s_type_params ctx tl
+		| TInst (c,tl) ->
+			(match c.cl_kind with
+			| KExpr e -> Ast.s_expr e
+			| _ -> s_type_path c.cl_path ^ s_type_params ctx tl)
+		| TType (t,tl) ->
+			s_type_path t.t_path ^ s_type_params ctx tl
+		| TAbstract (a,tl) ->
+			s_type_path a.a_path ^ s_type_params ctx tl
+		| TFun ([],_) ->
+			"Void -> ..."
+		| TFun (l,t) ->
+			let args = match l with
+				| [] -> "()"
+				| ["",b,t] -> ("...")
+				| _ ->
+					let args = String.concat ", " (List.map (fun (s,b,t) ->
+						(if b then "?" else "") ^ ("...")
+					) l) in
+					"(" ^ args ^ ")"
+			in
+			Printf.sprintf "%s -> ..." args
+		| TAnon a ->
+			begin
+				match !(a.a_status) with
+				| Statics c -> Printf.sprintf "{ Statics %s }" (s_type_path c.cl_path)
+				| EnumStatics e -> Printf.sprintf "{ EnumStatics %s }" (s_type_path e.e_path)
+				| AbstractStatics a -> Printf.sprintf "{ AbstractStatics %s }" (s_type_path a.a_path)
+				| _ ->
+					let fl = PMap.fold (fun f acc -> ((if Meta.has Meta.Optional f.cf_meta then " ?" else " ") ^ f.cf_name) :: acc) a.a_fields [] in
+					"{" ^ (if not (is_closed a) then "+" else "") ^  String.concat "," fl ^ " }"
+			end
+		| TDynamic t2 ->
+			"Dynamic" ^ s_type_params ctx (if t == t2 then [] else [t2])
+		| TLazy f ->
+			s_type ctx (lazy_type f)
+
+	and s_type_params ctx = function
+		| [] -> ""
+		| l -> "<" ^ String.concat ", " (List.map (fun _ -> "...") l) ^ ">"
+
+	let better_error_message l =
+		let ctx = print_context() in
+		let rec loop acc l = match l with
+			| (Cannot_unify _) as err1 :: (Cannot_unify _) :: l ->
+				loop acc (err1 :: l)
+			| x :: l ->
+				loop (x :: acc) l
+			| [] ->
+				List.rev acc
+		in
+		let l = loop [] l in
+		let access = get_access_chain ctx l in
+		let message_buffer = Buffer.create 0 in
+		let rec fill s i acc k l =
+			if l = 0 then
+				List.rev acc
+			else begin
+				if k = i then fill s i (s :: acc) (k + 1) (l - 1)
+				else fill s i ("..." :: acc) (k + 1) (l - 1)
+			end
+		in
+		let rec loop access access_prev =
+			let loop () = match access.acc_next with
+				| Some access' -> loop access' access
+				| None ->
+					begin match access.acc_messages with
+						| err :: _ ->
+							let msg = unify_error_msg ctx err in
+							Buffer.add_string message_buffer msg;
+						| [] ->
+							()
+					end;
+					s_type ctx access.acc_actual,s_type ctx access.acc_expected
+			in
+			begin match access.acc_kind with
+			| Field s ->
+				let s1,s2 = loop() in
+				Printf.sprintf "{ %s: %s }" s s1,Printf.sprintf "{ %s: %s }" s s2
+			| FunctionArgument(i,l) ->
+				let s1,s2 = loop() in
+				let sl1 = fill s1 i [] 1 l in
+				let sl2 = fill s2 i [] 1 l in
+				Printf.sprintf "(%s) -> ..." (String.concat ", " sl1),Printf.sprintf "(%s) -> ..." (String.concat ", " sl2)
+			| FunctionReturn ->
+				let s1,s2 = loop() in
+				Printf.sprintf "(...) -> %s" s1,Printf.sprintf "(...) -> %s" s2
+			| TypeParameter i ->
+				let rec get_params t = match t with
+					| TInst({cl_path = path},params) | TEnum({e_path = path},params) | TAbstract({a_path = path},params) | TType({t_path = path},params) ->
+						path,params
+					| _ ->
+						assert false
+				in
+				let s1,s2 = loop() in
+				let path1,params1 = get_params access_prev.acc_actual in
+				let path2,params2 = get_params access_prev.acc_expected in
+				let sl1 = fill s1 i [] 1 (List.length params1) in
+				let sl2 = fill s2 i [] 1 (List.length params2) in
+				Printf.sprintf "%s<%s>" (s_type_path path1) (String.concat ", " sl1),Printf.sprintf "%s<%s>" (s_type_path path2) (String.concat ", " sl2)
+			| Root ->
+				loop()
+			end;
+		in
+		match access.acc_next with
+		| None ->
+			String.concat "\n" (List.rev_map (unify_error_msg ctx) access.acc_messages)
+		| Some access_next ->
+			let slhs,srhs = loop access_next access  in
+			Printf.sprintf "error: %s\n have: %s\n want: %s" (Buffer.contents message_buffer) slhs srhs
+end
+
 let rec error_msg = function
 	| Module_not_found m -> "Type not found : " ^ s_type_path m
 	| Type_not_found (m,t) -> "Module " ^ s_type_path m ^ " does not define type " ^ t
-	| Unify l ->
-		let ctx = print_context() in
-		String.concat "\n" (List.map (unify_error_msg ctx) l)
+	| Unify l -> BetterErrors.better_error_message l
 	| Unknown_ident s -> "Unknown identifier : " ^ s
 	| Custom s -> s
 	| Stack (m1,m2) -> error_msg m1 ^ "\n" ^ error_msg m2

src/core/type.ml

@@ -1697,11 +1697,11 @@ type unify_error =
 	| Invalid_visibility of string
 	| Not_matching_optional of string
 	| Cant_force_optional
-	| Invariant_parameter of t * t
+	| Invariant_parameter of int
 	| Constraint_failure of string
 	| Missing_overload of tclass_field * t
 	| FinalInvariance (* nice band name *)
-	| Invalid_function_argument of int
+	| Invalid_function_argument of int (* index *) * int (* total *)
 	| Invalid_return_type
 	| Unify_custom of string
 
@@ -1827,7 +1827,7 @@ let rec type_eq param a b =
 		| None -> if param = EqCoreType || not (link t b a) then error [cannot_unify a b]
 		| Some t -> type_eq param a t)
 	| TType (t1,tl1), TType (t2,tl2) when (t1 == t2 || (param = EqCoreType && t1.t_path = t2.t_path)) && List.length tl1 = List.length tl2 ->
-		List.iter2 (type_eq param) tl1 tl2
+		type_eq_params param a b tl1 tl2
 	| TType (t,tl) , _ when can_follow a ->
 		type_eq param (apply_params t.t_params tl t.t_type) b
 	| _ , TType (t,tl) when can_follow b ->
@@ -1837,19 +1837,24 @@ let rec type_eq param a b =
 			(fun l -> error (cannot_unify a b :: l))
 	| TEnum (e1,tl1) , TEnum (e2,tl2) ->
 		if e1 != e2 && not (param = EqCoreType && e1.e_path = e2.e_path) then error [cannot_unify a b];
-		List.iter2 (type_eq param) tl1 tl2
+		type_eq_params param a b tl1 tl2
 	| TInst (c1,tl1) , TInst (c2,tl2) ->
 		if c1 != c2 && not (param = EqCoreType && c1.cl_path = c2.cl_path) && (match c1.cl_kind, c2.cl_kind with KExpr _, KExpr _ -> false | _ -> true) then error [cannot_unify a b];
-		List.iter2 (type_eq param) tl1 tl2
+		type_eq_params param a b tl1 tl2
 	| TFun (l1,r1) , TFun (l2,r2) when List.length l1 = List.length l2 ->
+		let i = ref 0 in
 		(try
 			type_eq param r1 r2;
 			List.iter2 (fun (n,o1,t1) (_,o2,t2) ->
+				incr i;
 				if o1 <> o2 then error [Not_matching_optional n];
 				type_eq param t1 t2
 			) l1 l2
 		with
-			Unify_error l -> error (cannot_unify a b :: l))
+			Unify_error l ->
+				let msg = if !i = 0 then Invalid_return_type else Invalid_function_argument(!i,List.length l1) in
+				error (cannot_unify a b :: msg :: l)
+		)
 	| TDynamic a , TDynamic b ->
 		type_eq param a b
 	| TAbstract ({a_path=[],"Null"},[t1]),TAbstract ({a_path=[],"Null"},[t2]) ->
@@ -1860,7 +1865,7 @@ let rec type_eq param a b =
 		type_eq param a t
 	| TAbstract (a1,tl1) , TAbstract (a2,tl2) ->
 		if a1 != a2 && not (param = EqCoreType && a1.a_path = a2.a_path) then error [cannot_unify a b];
-		List.iter2 (type_eq param) tl1 tl2
+		type_eq_params param a b tl1 tl2
 	| TAnon a1, TAnon a2 ->
 		(try
 			(match !(a2.a_status) with
@@ -1899,6 +1904,17 @@ let rec type_eq param a b =
 		else
 			error [cannot_unify a b]
 
+and type_eq_params param a b tl1 tl2 =
+	let i = ref 0 in
+	List.iter2 (fun t1 t2 ->
+		incr i;
+		try
+			type_eq param t1 t2
+		with Unify_error l ->
+			let err = cannot_unify a b in
+			error (err :: (Invariant_parameter !i) :: l)
+		) tl1 tl2
+
 let type_iseq a b =
 	try
 		type_eq EqStrict a b;
@@ -2011,7 +2027,7 @@ let rec unify a b =
 			) l2 l1 (* contravariance *)
 		with
 			Unify_error l ->
-				let msg = if !i = 0 then Invalid_return_type else Invalid_function_argument !i in
+				let msg = if !i = 0 then Invalid_return_type else Invalid_function_argument(!i,List.length l1) in
 				error (cannot_unify a b :: msg :: l))
 	| TInst (c,tl) , TAnon an ->
 		if PMap.is_empty an.a_fields then (match c.cl_kind with
@@ -2330,12 +2346,14 @@ and unify_with_variance f t1 t2 =
 		error [cannot_unify t1 t2]
 
 and unify_type_params a b tl1 tl2 =
+	let i = ref 0 in
 	List.iter2 (fun t1 t2 ->
+		incr i;
 		try
 			with_variance (type_eq EqRightDynamic) t1 t2
 		with Unify_error l ->
 			let err = cannot_unify a b in
-			error (err :: (Invariant_parameter (t1,t2)) :: l)
+			error (err :: (Invariant_parameter !i) :: l)
 	) tl1 tl2
 
 and with_variance f t1 t2 =

src/typing/typeloadCheck.ml

@@ -95,14 +95,17 @@ let valid_redefinition ctx f1 t1 f2 t2 = (* child, parent *)
 		begin match follow t1, follow t2 with
 		| TFun (args1,r1) , TFun (args2,r2) -> (
 			if not (List.length args1 = List.length args2) then raise (Unify_error [Unify_custom "Different number of function arguments"]);
+			let i = ref 0 in
 			try
+				valid r1 r2;
 				List.iter2 (fun (n,o1,a1) (_,o2,a2) ->
+					incr i;
 					if o1 <> o2 then raise (Unify_error [Not_matching_optional n]);
 					(try valid a2 a1 with Unify_error _ -> raise (Unify_error [Cannot_unify(a1,a2)]))
 				) args1 args2;
-				valid r1 r2
 			with Unify_error l ->
-				raise (Unify_error (Cannot_unify (t1,t2) :: l)))
+				let msg = if !i = 0 then Invalid_return_type else Invalid_function_argument(!i,List.length args1) in
+				raise (Unify_error (Cannot_unify (t1,t2) :: msg :: l)))
 		| _ ->
 			assert false
 		end

tests/misc/projects/Issue3361/compile1-fail.hxml.stderr

@@ -1,4 +1,5 @@
 Main.hx:5: lines 5-8 : Field v has different type than in I
 Main.hx:2: characters 2-29 : Interface field is defined here
-Main.hx:5: lines 5-8 : String -> Void should be Dynamic -> Void
-Main.hx:5: lines 5-8 : String should be Dynamic
+Main.hx:5: lines 5-8 : error: String should be Dynamic
+Main.hx:5: lines 5-8 :  have: (String) -> ...
+Main.hx:5: lines 5-8 :  want: (Dynamic) -> ...

tests/misc/projects/Issue3361/compile2-fail.hxml.stderr

@@ -1,4 +1,5 @@
 Main2.hx:6: characters 2-46 : Field f has different type than in I
 Main2.hx:2: characters 2-44 : Interface field is defined here
-Main2.hx:6: characters 2-46 : (s : String) -> Void should be (d : Dynamic) -> Void
-Main2.hx:6: characters 2-46 : String should be Dynamic
+Main2.hx:6: characters 2-46 : error: String should be Dynamic
+Main2.hx:6: characters 2-46 :  have: (String) -> ...
+Main2.hx:6: characters 2-46 :  want: (Dynamic) -> ...

tests/misc/projects/Issue4250/compile-fail.hxml.stderr

@@ -1,5 +1,3 @@
-Main.hx:11: characters 9-31 : SomeNode should be Node
-Main.hx:11: characters 9-31 : SomeNode should be { parent : Node }
-Main.hx:11: characters 9-31 : Invalid type for field parent :
-Main.hx:11: characters 9-31 : SomeNode should be Node
-Main.hx:11: characters 9-31 : SomeNode should be { parent : Node }
+Main.hx:11: characters 9-31 : error: SomeNode should be Node
+Main.hx:11: characters 9-31 :  have: { parent: SomeNode }
+Main.hx:11: characters 9-31 :  want: { parent: Node }

tests/misc/projects/Issue4378/compile-fail.hxml.stderr

@@ -1,4 +1,5 @@
 Main.hx:5: lines 5-7 : Field test has different type than in I
 Main.hx:16: characters 2-32 : Interface field is defined here
-Main.hx:5: lines 5-7 : (s : String) -> Void should be (s : Dynamic) -> Void
-Main.hx:5: lines 5-7 : String should be Dynamic
+Main.hx:5: lines 5-7 : error: String should be Dynamic
+Main.hx:5: lines 5-7 :  have: (String) -> ...
+Main.hx:5: lines 5-7 :  want: (Dynamic) -> ...

tests/misc/projects/Issue4540/compile-fail.hxml.stderr

@@ -1,4 +1,2 @@
 Main.hx:3: characters 36-55 : (c : { test : String }) -> Void should be Null<js.PromiseCallback<Int, Void>>
-Main.hx:3: characters 36-55 : (c : { test : String }) -> Void should be js.PromiseCallback<Int, Void>
-Main.hx:3: characters 36-55 : (c : { test : String }) -> Void should be haxe.extern.EitherType<Int -> Void, Int -> js.Promise<Void>>
-Main.hx:3: characters 36-55 : For function argument 'fulfillCallback'
+Main.hx:3: characters 36-55 : For function argument 'fulfillCallback'

tests/misc/projects/Issue5206/compile-fail.hxml.stderr

@@ -1,8 +1,4 @@
 Main.hx:14: characters 29-34 : A should be X
-Main.hx:14: characters 29-34 : { pos : Int, len : Int } should be X
-Main.hx:14: characters 29-34 : { pos : Int, len : Int } should be { ?y : Null<Int>, ?x : Null<Int> }
 Main.hx:14: characters 29-34 : { pos : Int, len : Int } has no field x
 Main.hx:14: characters 27-40 : Y should be Z
-Main.hx:14: characters 27-40 : { y : Int, x : Int } should be Z
-Main.hx:14: characters 27-40 : { y : Int, x : Int } should be { ?pos : Null<Array<String>>, ?len : Null<Array<Float>> }
 Main.hx:14: characters 27-40 : { y : Int, x : Int } has no field len

tests/misc/projects/Issue6757/compile-fail.hxml.stderr

@@ -1,4 +1,4 @@
-Test.hx:5: characters 27-37 : haxe.ds.Option<Bool> should be haxe.ds.Option<String>
-Test.hx:5: characters 27-37 : Type parameters are invariant
-Test.hx:5: characters 27-37 : Bool should be String
-Test.hx:9: characters 11-12 : Warning : haxe.ds.Option<String>
+Test.hx:5: characters 27-37 : error: Bool should be String
+Test.hx:5: characters 27-37 :  have: haxe.ds.Option<Bool>
+Test.hx:5: characters 27-37 :  want: haxe.ds.Option<String>
+Test.hx:9: characters 11-12 : Warning : haxe.ds.Option<String>

tests/misc/projects/Issue7039/compile-fail.hxml.stderr

@@ -1,3 +1,3 @@
-Main.hx:4: characters 3-33 : { foo : Int } should be { foo : Int }
-Main.hx:4: characters 3-33 : Invalid type for field foo :
-Main.hx:4: characters 3-33 : Cannot unify final and non-final fields
+Main.hx:4: characters 3-33 : error: Cannot unify final and non-final fields
+Main.hx:4: characters 3-33 :  have: { foo: Dynamic }
+Main.hx:4: characters 3-33 :  want: { foo: Dynamic }

tests/misc/projects/Issue7227/compile-fail.hxml.stderr

@@ -1,6 +1,3 @@
-Main.hx:4: characters 9-81 : Generic<{ url : Struct, method : String }> should be Generic<Struct>
-Main.hx:4: characters 9-81 : Type parameters are invariant
-Main.hx:4: characters 9-81 : { url : Struct, method : String } should be Struct
-Main.hx:4: characters 9-81 : { url : Struct, method : String } should be { url : String, method : String }
-Main.hx:4: characters 9-81 : Invalid type for field url :
-Main.hx:4: characters 9-81 : { url : String, method : String } should be String
+Main.hx:4: characters 9-81 : error: { url : String, method : String } should be String
+Main.hx:4: characters 9-81 :  have: Generic<{ url: { url, method } }>
+Main.hx:4: characters 9-81 :  want: Generic<{ url: String }>

tests/misc/projects/Issue7526/compile-fail.hxml.stderr

@@ -1,6 +1,4 @@
 Main.hx:16: characters 9-29 : Class<C> should be { member : Int }
-Main.hx:16: characters 9-29 : { Statics C } should be { member : Int }
 Main.hx:16: characters 9-29 : The field member is not public
 Main.hx:17: characters 9-29 : Class<_Main.A_Impl_> should be { member : Int }
-Main.hx:17: characters 9-29 : { Statics _Main.A_Impl_ } should be { member : Int }
 Main.hx:17: characters 9-29 : The field member is not public