Merge pull request #4683 from Simn/improved_resume

Improved resume

codegen.ml

@@ -819,8 +819,8 @@ module AbstractCast = struct
 	let cast_or_unify ctx tleft eright p =
 		try
 			cast_or_unify_raise ctx tleft eright p
-		with Error (Unify _ as err,_) ->
-			if not ctx.untyped then display_error ctx (error_msg err) p;
+		with Error (Unify l,p) ->
+			raise_or_display ctx l p;
 			eright
 
 	let find_array_access_raise ctx a pl e1 e2o p =

matcher.ml

@@ -1148,7 +1148,7 @@ let extractor_depth = ref 0
 let match_expr ctx e cases def with_type p =
 	let need_val,with_type,tmono = match with_type with
 		| NoValue -> false,NoValue,None
-		| WithType t | WithTypeResume t when (match follow t with TMono _ -> true | _ -> false) ->
+		| WithType t when (match follow t with TMono _ -> true | _ -> false) ->
 			(* we don't want to unify with each case individually, but instead at the end after unify_min *)
 			true,Value,Some with_type
 		| t -> true,t,None
@@ -1257,7 +1257,6 @@ let match_expr ctx e cases def with_type p =
 				List.iter2 (fun m (_,t) -> match follow m with TMono _ -> Type.unify m t | _ -> ()) monos ctx.type_params;
 				pl,restore,(match with_type with
 					| WithType t -> WithType (apply_params ctx.type_params monos t)
-					| WithTypeResume t -> WithTypeResume (apply_params ctx.type_params monos t)
 					| _ -> with_type);
 			with Unrecognized_pattern (e,p) ->
 				error "Case expression must be a constant value or a pattern, not an arbitrary expression" p
@@ -1276,8 +1275,6 @@ let match_expr ctx e cases def with_type p =
 		let e = match with_type with
 			| WithType t ->
 				Codegen.AbstractCast.cast_or_unify ctx t e e.epos;
-			| WithTypeResume t ->
-				(try Codegen.AbstractCast.cast_or_unify_raise ctx t e e.epos with Error (Unify l,p) -> raise (Typer.WithTypeError (l,p)));
 			| _ -> e
 		in
 		(* type case guard *)
@@ -1395,14 +1392,13 @@ let match_expr ctx e cases def with_type p =
 	let t = if not need_val then
 		mk_mono()
 	else match with_type with
-		| WithType t | WithTypeResume t -> t
+		| WithType t -> t
 		| _ -> try Typer.unify_min_raise ctx (List.rev_map (fun (_,out) -> get_expr mctx out.o_id) (List.rev pl)) with Error (Unify l,p) -> error (error_msg (Unify l)) p
 	in
 	(* unify with expected type if necessary *)
 	begin match tmono with
 		| None -> ()
 		| Some (WithType t2) -> unify ctx t2 t p
-		| Some (WithTypeResume t2) -> (try unify_raise ctx t2 t p with Error (Unify l,p) -> raise (Typer.WithTypeError (l,p)))
 		| _ -> assert false
 	end;
 	(* count usage *)

typecore.ml

@@ -24,7 +24,6 @@ type with_type =
 	| NoValue
 	| Value
 	| WithType of t
-	| WithTypeResume of t
 
 type type_patch = {
 	mutable tp_type : Ast.complex_type option;
@@ -117,6 +116,7 @@ and typer = {
 	mutable locals : (string, tvar) PMap.t;
 	mutable opened : anon_status ref list;
 	mutable vthis : tvar option;
+	mutable in_call_args : bool;
 	(* events *)
 	mutable on_error : typer -> string -> pos -> unit;
 }
@@ -146,6 +146,8 @@ exception DisplayTypes of t list
 
 exception DisplayPosition of Ast.pos list
 
+exception WithTypeError of unify_error list * pos
+
 let make_call_ref : (typer -> texpr -> texpr list -> t -> pos -> texpr) ref = ref (fun _ _ _ _ _ -> assert false)
 let type_expr_ref : (typer -> Ast.expr -> with_type -> texpr) ref = ref (fun _ _ _ -> assert false)
 let type_module_type_ref : (typer -> module_type -> t list option -> pos -> texpr) ref = ref (fun _ _ _ _ -> assert false)
@@ -298,12 +300,21 @@ let make_static_call ctx c cf map args t p =
 	let ef = mk (TField (ethis,(FStatic (c,cf)))) (map cf.cf_type) p in
 	make_call ctx ef args (map t) p
 
+let raise_or_display ctx l p =
+	if ctx.untyped then ()
+	else if ctx.in_call_args then raise (WithTypeError(l,p))
+	else display_error ctx (error_msg (Unify l)) p
+
+let raise_or_display_message ctx msg p =
+	if ctx.in_call_args then raise (WithTypeError ([Unify_custom msg],p))
+	else display_error ctx msg p
+
 let unify ctx t1 t2 p =
 	try
 		Type.unify t1 t2
 	with
 		Unify_error l ->
-			if not ctx.untyped then display_error ctx (error_msg (Unify l)) p
+			raise_or_display ctx l p
 
 let unify_raise ctx t1 t2 p =
 	try

typeload.ml

@@ -3256,6 +3256,7 @@ let type_types_into_module ctx m tdecls p =
 		in_display = false;
 		in_loop = false;
 		opened = [];
+		in_call_args = false;
 		vthis = None;
 	} in
 	if ctx.g.std != null_module then begin

typer.ml

@@ -53,8 +53,6 @@ type display_field_kind =
 exception DisplayFields of (string * t * display_field_kind option * documentation) list
 exception DisplayToplevel of identifier_type list
 
-exception WithTypeError of unify_error list * pos
-
 type access_kind =
 	| AKNo of string
 	| AKExpr of texpr
@@ -670,7 +668,10 @@ let is_forced_inline c cf =
 	| _ -> false
 
 let rec unify_call_args' ctx el args r callp inline force_inline =
+	let in_call_args = ctx.in_call_args in
+	ctx.in_call_args <- true;
 	let call_error err p =
+		ctx.in_call_args <- in_call_args;
 		raise (Error (Call_error err,p))
 	in
 	let arg_error ul name opt p =
@@ -696,8 +697,8 @@ let rec unify_call_args' ctx el args r callp inline force_inline =
 	in
 	(* let force_inline, is_extern = match cf with Some(TInst(c,_),f) -> is_forced_inline (Some c) f, c.cl_extern | _ -> false, false in *)
 	let type_against t e =
-		let e = type_expr ctx e (WithTypeResume t) in
-		(try Codegen.AbstractCast.cast_or_unify_raise ctx t e e.epos with Error (Unify l,p) -> raise (WithTypeError (l,p)));
+		let e = type_expr ctx e (WithType t) in
+		(try Codegen.AbstractCast.cast_or_unify_raise ctx t e e.epos with Error (Unify l,p) -> ctx.in_call_args <- in_call_args; raise (WithTypeError (l,p)))
 	in
 	let rec loop el args = match el,args with
 		| [],[] ->
@@ -739,6 +740,7 @@ let rec unify_call_args' ctx el args r callp inline force_inline =
 			end
 	in
 	let el = loop el args in
+	ctx.in_call_args <- in_call_args;
 	el,TFun(args,r)
 
 let unify_call_args ctx el args r p inline force_inline =
@@ -807,9 +809,9 @@ let unify_field_call ctx fa el args ret p inline =
 					candidate :: candidates,failures
 				end else
 					[candidate],[]
-			with Error (Call_error _,_) as err ->
+			with Error ((Call_error _ as err),p) ->
 				let candidates,failures = loop candidates in
-				candidates,err :: failures
+				candidates,(cf,err,p) :: failures
 			end
 	in
 	match candidates with
@@ -818,9 +820,19 @@ let unify_field_call ctx fa el args ret p inline =
 		List.map fst el,tf,mk_call
 	| _ ->
 		let candidates,failures = loop candidates in
-		let fail () = match List.rev failures with
-			| err :: _ -> raise err
-			| _ -> assert false
+		let fail () =
+			let failures = List.map (fun (cf,err,p) -> cf,error_msg err,p) failures in
+			begin match failures with
+			| (_,msg,p) :: failures when List.for_all (fun (_,msg2,_) -> msg = msg2) failures ->
+				error msg p
+			| _ ->
+				display_error ctx "Could not find a suitable overload, reasons follow" p;
+				List.iter (fun (cf,msg,p2) ->
+					display_error ctx ("Overload resolution failed for " ^ (s_type (print_context()) cf.cf_type)) p;
+					display_error ctx msg p2;
+				) failures;
+				error "End of overload failure reasons" p
+			end
 		in
 		if is_overload && ctx.com.config.pf_overload then begin match Codegen.Overloads.reduce_compatible candidates with
 			| [] -> fail()
@@ -1829,7 +1841,6 @@ let unify_int ctx e k =
 	in
 	begin match with_type with
 		| WithType t -> unify ctx ret t p
-		| WithTypeResume t -> (try unify_raise ctx ret t p with Error (Unify l,_) -> raise (WithTypeError(l,p)))
 		| _ -> ()
 	end;
 	let el,_ = unify_call_args ctx el args ret p false false in
@@ -2072,7 +2083,7 @@ let rec type_binop ctx op e1 e2 is_assign_op with_type p =
 		(* If the with_type is an abstract which has exactly one applicable @:op method, we can promote it
 		   to the individual arguments (issue #2786). *)
 		let wt = match with_type with
-			| WithType t | WithTypeResume t ->
+			| WithType t ->
 				begin match follow t with
 					| TAbstract(a,_) ->
 						begin match List.filter (fun (o,_) -> o = OpAssignOp(op) || o == op) a.a_ops with
@@ -2807,11 +2818,6 @@ and type_vars ctx vl p in_block =
 		let e = mk (TBlock (List.map (fun (v,e) -> (mk (TVar (v,e)) ctx.t.tvoid p)) vl)) ctx.t.tvoid p in
 		mk (TMeta((Meta.MergeBlock,[],p), e)) e.etype e.epos
 
-and with_type_error ctx with_type msg p =
-	match with_type with
-	| WithTypeResume _ -> raise (WithTypeError ([Unify_custom msg],p))
-	| _ -> display_error ctx msg p
-
 and format_string ctx s p =
 	let e = ref None in
 	let pmin = ref p.pmin in
@@ -2947,7 +2953,7 @@ and type_expr ctx (e,p) (with_type:with_type) =
 			acc_get ctx (type_ident_raise ~imported_enums:false ctx s p MGet) p
 		with Not_found -> try
 			(match with_type with
-			| WithType t | WithTypeResume t ->
+			| WithType t ->
 				(match follow t with
 				| TEnum (e,pl) ->
 					(try
@@ -2956,7 +2962,7 @@ and type_expr ctx (e,p) (with_type:with_type) =
 						mk (fast_enum_field e ef p) (enum_field_type ctx e ef pl monos p) p
 					with Not_found ->
 						if ctx.untyped then raise Not_found;
-						with_type_error ctx with_type (string_error s e.e_names ("Identifier '" ^ s ^ "' is not part of enum " ^ s_type_path e.e_path)) p;
+						raise_or_display_message ctx (string_error s e.e_names ("Identifier '" ^ s ^ "' is not part of enum " ^ s_type_path e.e_path)) p;
 						mk (TConst TNull) t p)
 				| TAbstract (a,pl) when has_meta Meta.Enum a.a_meta ->
 					let cimpl = (match a.a_impl with None -> assert false | Some c -> c) in
@@ -2965,7 +2971,7 @@ and type_expr ctx (e,p) (with_type:with_type) =
 						acc_get ctx (type_field ctx (mk (TTypeExpr (TClassDecl cimpl)) (TAnon { a_fields = PMap.add cf.cf_name cf PMap.empty; a_status = ref (Statics cimpl) }) p) s p MGet) p
 					with Not_found ->
 						if ctx.untyped then raise Not_found;
-						with_type_error ctx with_type (string_error s (List.map (fun f -> f.cf_name) cimpl.cl_ordered_statics) ("Identifier '" ^ s ^ "' is not part of enum " ^ s_type_path a.a_path)) p;
+						raise_or_display_message ctx (string_error s (List.map (fun f -> f.cf_name) cimpl.cl_ordered_statics) ("Identifier '" ^ s ^ "' is not part of enum " ^ s_type_path a.a_path)) p;
 						mk (TConst TNull) t p)
 				| _ -> raise Not_found)
 			| _ ->
@@ -2999,7 +3005,7 @@ and type_expr ctx (e,p) (with_type:with_type) =
 	| EObjectDecl fl ->
 		let dynamic_parameter = ref None in
 		let a = (match with_type with
-		| WithType t | WithTypeResume t ->
+		| WithType t ->
 			(match follow t with
 			| TAnon a when not (PMap.is_empty a.a_fields) -> Some a
 			(* issues with https://github.com/HaxeFoundation/haxe/issues/3437 *)
@@ -3046,7 +3052,7 @@ and type_expr ctx (e,p) (with_type:with_type) =
 				if PMap.mem n !fields then error ("Duplicate field in object declaration : " ^ n) p;
 				let e = try
 					let t = (match !dynamic_parameter with Some t -> t | None -> (PMap.find n a.a_fields).cf_type) in
-					let e = type_expr ctx e (match with_type with WithTypeResume _ -> WithTypeResume t | _ -> WithType t) in
+					let e = type_expr ctx e (WithType t) in
 					let e = Codegen.AbstractCast.cast_or_unify ctx t e p in
 					(try type_eq EqStrict e.etype t; e with Unify_error _ -> mk (TCast (e,None)) t e.epos)
 				with Not_found ->
@@ -3064,18 +3070,13 @@ and type_expr ctx (e,p) (with_type:with_type) =
 			) fl in
 			let t = (TAnon { a_fields = !fields; a_status = ref Const }) in
 			if not ctx.untyped then begin
-				let unify_error l p =
-					match with_type with
-					| WithTypeResume _ -> raise (WithTypeError (l,p))
-					| _ -> raise (Error (Unify l,p))
-				in
 				(match PMap.foldi (fun n cf acc -> if not (Meta.has Meta.Optional cf.cf_meta) && not (PMap.mem n !fields) then n :: acc else acc) a.a_fields [] with
 					| [] -> ()
-					| [n] -> unify_error [Unify_custom ("Object requires field " ^ n)] p
-					| nl -> unify_error [Unify_custom ("Object requires fields: " ^ (String.concat ", " nl))] p);
+					| [n] -> raise_or_display ctx [Unify_custom ("Object requires field " ^ n)] p
+					| nl -> raise_or_display ctx [Unify_custom ("Object requires fields: " ^ (String.concat ", " nl))] p);
 				(match !extra_fields with
 				| [] -> ()
-				| _ -> unify_error (List.map (fun n -> has_extra_field t n) !extra_fields) p);
+				| _ -> raise_or_display ctx (List.map (fun n -> has_extra_field t n) !extra_fields) p);
 			end;
 			if !(a.a_status) <> Const then a.a_status := Closed;
 			mk (TObjectDecl fl) t p)
@@ -3106,7 +3107,7 @@ and type_expr ctx (e,p) (with_type:with_type) =
 			mk (TLocal v) v.v_type p;
 		]) v.v_type p
 	| EArrayDecl ((EBinop(OpArrow,_,_),_) as e1 :: el) ->
-		let (tkey,tval,has_type),resume =
+		let (tkey,tval,has_type) =
 			let get_map_params t = match follow t with
 				| TAbstract({a_path=[],"Map"},[tk;tv]) -> tk,tv,true
 				| TInst({cl_path=["haxe";"ds"],"IntMap"},[tv]) -> ctx.t.tint,tv,true
@@ -3115,15 +3116,10 @@ and type_expr ctx (e,p) (with_type:with_type) =
 				| _ -> mk_mono(),mk_mono(),false
 			in
 			match with_type with
-			| WithType t -> get_map_params t,false
-			| WithTypeResume t -> get_map_params t,true
-			| _ -> (mk_mono(),mk_mono(),false),false
+			| WithType t -> get_map_params t
+			| _ -> (mk_mono(),mk_mono(),false)
 		in
 		let keys = Hashtbl.create 0 in
-		let unify_with_resume ctx e t p =
-			if resume then try Codegen.AbstractCast.cast_or_unify_raise ctx t e p with Error (Unify l,p) -> raise (WithTypeError(l,p))
-			else Codegen.AbstractCast.cast_or_unify ctx t e p
-		in
 		let check_key e_key =
 			try
 				let p = Hashtbl.find keys e_key.eexpr in
@@ -3141,9 +3137,9 @@ and type_expr ctx (e,p) (with_type:with_type) =
 			let el_k,el_v = List.fold_left (fun (el_k,el_v) (e1,e2) ->
 				let e1 = type_expr ctx e1 (WithType tkey) in
 				check_key e1;
-				let e1 = unify_with_resume ctx e1 tkey e1.epos in
+				let e1 = Codegen.AbstractCast.cast_or_unify ctx tkey e1 e1.epos in
 				let e2 = type_expr ctx e2 (WithType tval) in
-				let e2 = unify_with_resume ctx e2 tval e2.epos in
+				let e2 = Codegen.AbstractCast.cast_or_unify ctx tval e2 e2.epos in
 				(e1 :: el_k,e2 :: el_v)
 			) ([],[]) el_kv in
 			el_k,el_v,tkey,tval
@@ -3156,7 +3152,7 @@ and type_expr ctx (e,p) (with_type:with_type) =
 			) ([],[]) el_kv in
 			let unify_min_resume el = try
 				unify_min_raise ctx el
-			with Error (Unify l,p) when resume ->
+			with Error (Unify l,p) when ctx.in_call_args ->
 				 raise (WithTypeError(l,p))
 			in
 			let tkey = unify_min_resume el_k in
@@ -3180,7 +3176,7 @@ and type_expr ctx (e,p) (with_type:with_type) =
 		mk (TBlock el) tmap p
 	| EArrayDecl el ->
 		let tp = (match with_type with
-		| WithType t | WithTypeResume t ->
+		| WithType t ->
 			(match follow t with
 			| TInst ({ cl_path = [],"Array" },[tp]) ->
 				(match follow tp with
@@ -3210,10 +3206,8 @@ and type_expr ctx (e,p) (with_type:with_type) =
 			mk (TArrayDecl el) (ctx.t.tarray t) p
 		| Some t ->
 			let el = List.map (fun e ->
-				let e = type_expr ctx e (match with_type with WithTypeResume _ -> WithTypeResume t | _ -> WithType t) in
-				(match with_type with
-				| WithTypeResume _ -> (try Codegen.AbstractCast.cast_or_unify_raise ctx t e p with Error (Unify l,p) -> raise (WithTypeError (l,p)))
-				| _ -> Codegen.AbstractCast.cast_or_unify ctx t e p);
+				let e = type_expr ctx e (WithType t) in
+				Codegen.AbstractCast.cast_or_unify ctx t e p;
 			) el in
 			mk (TArrayDecl el) (ctx.t.tarray t) p)
 	| EVars vl ->
@@ -3275,18 +3269,11 @@ and type_expr ctx (e,p) (with_type:with_type) =
 			let e1,e2,t = match with_type with
 				| NoValue -> e1,e2,ctx.t.tvoid
 				| Value -> e1,e2,unify_min ctx [e1; e2]
-				| WithType t | WithTypeResume t when (match follow t with TMono _ -> true | _ -> false) -> e1,e2,unify_min ctx [e1; e2]
-				| WithType t | WithTypeResume t ->
-					begin try
-					let e1 = Codegen.AbstractCast.cast_or_unify_raise ctx t e1 e1.epos in
-					let e2 = Codegen.AbstractCast.cast_or_unify_raise ctx t e2 e2.epos in
+				| WithType t when (match follow t with TMono _ -> true | _ -> false) -> e1,e2,unify_min ctx [e1; e2]
+				| WithType t ->
+					let e1 = Codegen.AbstractCast.cast_or_unify ctx t e1 e1.epos in
+					let e2 = Codegen.AbstractCast.cast_or_unify ctx t e2 e2.epos in
 					e1,e2,t
-					with Error (Unify l,p) -> match with_type with
-						| WithTypeResume _ -> raise (WithTypeError (l,p))
-						| _ ->
-							display_error ctx (error_msg (Unify l)) p;
-							e1,e2,t
-					end;
 			in
 			mk (TIf (e,e1,Some e2)) t p)
 	| EWhile (cond,e,NormalWhile) ->
@@ -3408,7 +3395,7 @@ and type_expr ctx (e,p) (with_type:with_type) =
 	| ECall (((EConst (Ident s),pc) as e),el) ->
 		(try
 			let en,t = (match with_type with
-				| WithType t | WithTypeResume t ->
+				| WithType t ->
 					(match follow t with
 					| TEnum (e,pl) -> e,t
 					| _ -> raise Exit)
@@ -3436,7 +3423,7 @@ and type_expr ctx (e,p) (with_type:with_type) =
 			with Not_found ->
 				restore();
 				if ctx.untyped then raise Exit; (* __js__, etc. *)
-				with_type_error ctx with_type (string_error s en.e_names ("Identifier '" ^ s ^ "' is not part of enum " ^ s_type_path en.e_path)) p;
+				raise_or_display_message ctx (string_error s en.e_names ("Identifier '" ^ s ^ "' is not part of enum " ^ s_type_path en.e_path)) p;
 				mk (TConst TNull) t p
 			| err ->
 				restore();
@@ -3481,7 +3468,7 @@ and type_expr ctx (e,p) (with_type:with_type) =
 				with Codegen.Generic_Exception _ as exc ->
 					(* If we have an expected type, just use that (issue #3804) *)
 					begin match with_type with
-						| WithType t | WithTypeResume t ->
+						| WithType t ->
 							begin match follow t with
 								| TMono _ -> raise exc
 								| t -> t
@@ -3556,7 +3543,7 @@ and type_expr ctx (e,p) (with_type:with_type) =
 			s , c, t
 		) f.f_args in
 		(match with_type with
-		| WithType t | WithTypeResume t ->
+		| WithType t ->
 			let rec loop t =
 				(match follow t with
 				| TFun (args2,tr) when List.length args2 = List.length args ->
@@ -3915,7 +3902,7 @@ and handle_display ctx e_ast iscall with_type p =
 				) c.cl_statics fields
 			| TAnon a when PMap.is_empty a.a_fields ->
 				begin match with_type with
-				| WithType t | WithTypeResume t -> get_fields t
+				| WithType t -> get_fields t
 				| _ -> a.a_fields
 				end
 			| TAnon a ->
@@ -4639,7 +4626,7 @@ let make_macro_api ctx p =
 		);
 		Interp.get_expected_type = (fun() ->
 			match ctx.with_type_stack with
-				| (WithType t | WithTypeResume t) :: _ -> Some t
+				| (WithType t) :: _ -> Some t
 				| _ -> None
 		);
 		Interp.get_call_arguments = (fun() ->
@@ -5154,6 +5141,7 @@ let rec create com =
 		tthis = mk_mono();
 		opened = [];
 		vthis = None;
+		in_call_args = false;
 		on_error = (fun ctx msg p -> ctx.com.error msg p);
 	} in
 	ctx.g.std <- (try