Hold error/warning messages while trying to unify call arguments

src/compiler/haxe.ml

@@ -75,10 +75,23 @@ let limit_string s offset =
 	in
 	String.concat "" (loop 0 words)
 
-let error ctx msg p =
-	let msg = try List.assoc msg deprecated with Not_found -> msg in
-	message ctx (CMError(msg,p));
-	ctx.has_error <- true
+let rec error ctx msg p =
+	match ctx.com.pending_messages with
+	| Some add -> add (fun() -> error ctx msg p)
+	| None ->
+		let msg = try List.assoc msg deprecated with Not_found -> msg in
+		message ctx (CMError(msg,p));
+		ctx.has_error <- true
+
+let rec warning ctx msg p =
+	match ctx.com.pending_messages with
+	| Some add -> add (fun() -> warning ctx msg p)
+	| None -> message ctx (CMWarning(msg,p))
+
+let rec info ctx msg p =
+	match ctx.com.pending_messages with
+	| Some add -> add (fun() -> info ctx msg p)
+	| None -> message ctx (CMInfo(msg,p))
 
 let reserved_flags = [
 	"true";"false";"null";"cross";"js";"lua";"neko";"flash";"php";"cpp";"cs";"java";"python";
@@ -384,8 +397,8 @@ let setup_common_context ctx com =
 	Common.raw_define com "haxe4";
 	Common.define_value com Define.Haxe (s_version false);
 	Common.define_value com Define.Dce "std";
-	com.info <- (fun msg p -> message ctx (CMInfo(msg,p)));
-	com.warning <- (fun msg p -> message ctx (CMWarning(msg,p)));
+	com.info <- info ctx;
+	com.warning <- warning ctx;
 	com.error <- error ctx;
 	let filter_messages = (fun keep_errors predicate -> (List.filter (fun msg ->
 		(match msg with
@@ -442,7 +455,7 @@ let process_display_configuration ctx =
 			if com.display.dms_error_policy = EPCollect then
 				(fun s p -> add_diagnostics_message com s p DKCompilerError DisplayTypes.DiagnosticsSeverity.Warning)
 			else
-				(fun msg p -> message ctx (CMWarning(msg,p)));
+				warning ctx;
 		com.error <- error ctx;
 	end;
 	Lexer.old_format := Common.defined com Define.OldErrorFormat;

src/context/common.ml

@@ -212,6 +212,7 @@ type context = {
 	mutable error : string -> pos -> unit;
 	mutable info : string -> pos -> unit;
 	mutable warning : string -> pos -> unit;
+	mutable pending_messages : ((unit->unit)->unit) option;
 	mutable get_messages : unit -> compiler_message list;
 	mutable filter_messages : (compiler_message -> bool) -> unit;
 	mutable load_extern_type : (string * (path -> pos -> Ast.package option)) list; (* allow finding types which are not in sources *)
@@ -496,8 +497,25 @@ let create version s_version args =
 		memory_marker = memory_marker;
 		parser_cache = Hashtbl.create 0;
 		json_out = None;
+		pending_messages = None;
 	}
 
+exception HoldMessages of exn * (unit->unit)
+
+let hold_messages com action =
+	let old_pending = com.pending_messages in
+	let messages = ref [] in
+	com.pending_messages <- Some (fun submit -> messages := submit :: !messages);
+	let submit_all() = List.iter (fun f -> f()) (List.rev !messages) in
+	let restore() = com.pending_messages <- old_pending; in
+	try
+		let result = action() in
+		restore();
+		result,submit_all
+	with err ->
+		restore();
+		raise (HoldMessages (err,submit_all))
+
 let log com str =
 	if com.verbose then com.print (str ^ "\n")
 
@@ -817,9 +835,12 @@ let utf16_to_utf8 str =
 	loop 0;
 	Buffer.contents b
 
-let add_diagnostics_message com s p kind sev =
-	let di = com.shared.shared_display_information in
-	di.diagnostics_messages <- (s,p,kind,sev) :: di.diagnostics_messages
+let rec add_diagnostics_message com s p kind sev =
+	match com.pending_messages with
+	| Some add -> add (fun() -> add_diagnostics_message com s p kind sev)
+	| None ->
+		let di = com.shared.shared_display_information in
+		di.diagnostics_messages <- (s,p,kind,sev) :: di.diagnostics_messages
 
 open Printer
 

src/typing/calls.ml

@@ -208,19 +208,24 @@ let rec unify_call_args' ctx el args r callp inline force_inline =
 				| (s,ul,p) :: _ -> arg_error ul s true p
 			end
 		| e :: el,(name,opt,t) :: args ->
-			begin try
-				let e = type_against name t e in
+			try
+				let e,submit_messages = hold_messages ctx.com (fun() -> type_against name t e) in
+				submit_messages();
 				(e,opt) :: loop el args
-			with
-				WithTypeError (ul,p)->
+			with HoldMessages (err,submit_messages) ->
+				match err with
+				| WithTypeError (ul,p)->
 					if opt && List.length el < List.length args then
 						let e_def = skip name ul t p in
 						(e_def,true) :: loop (e :: el) args
 					else
-						match List.rev !skipped with
+						(match List.rev !skipped with
 						| [] -> arg_error ul name opt p
 						| (s,ul,p) :: _ -> arg_error ul s true p
-			end
+						)
+				| _ ->
+					submit_messages();
+					raise err
 	in
 	let el = try loop el args with exc -> ctx.in_call_args <- in_call_args; raise exc; in
 	ctx.in_call_args <- in_call_args;

src/typing/typer.ml

@@ -2201,8 +2201,8 @@ and type_array_decl ctx el with_type p =
 			if !allow_array_dynamic || ctx.untyped || ctx.com.display.dms_error_policy = EPIgnore then
 				t_dynamic
 			else begin
-				display_error ctx "Arrays of mixed types are only allowed if the type is forced to Array<Dynamic>" p;
-				raise (Error (Unify l, p))
+				let msg = "Arrays of mixed types are only allowed if the type is forced to Array<Dynamic>" in
+				raise (Error (Stack (Custom msg, Unify l), p))
 			end
 		in
 		mk (TArrayDecl el) (ctx.t.tarray t) p

tests/misc/projects/Issue5522/Main.hx

@@ -0,0 +1,10 @@
+class Main {
+	static function f(?i:Int, fn:Array<Dynamic>->Void){}
+
+	static function main() {
+		f(function(res){
+			$type(res);
+			for (a in res){}
+		});
+	}
+} 

tests/misc/projects/Issue5522/compile.hxml

@@ -0,0 +1 @@
+--main Main

tests/misc/projects/Issue5522/compile.hxml.stderr

@@ -0,0 +1 @@
+Main.hx:6: characters 10-13 : Warning : Array<Dynamic> 

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

@@ -1,4 +1,3 @@
 Main.hx:9: characters 35-48 : Arrays of mixed types are only allowed if the type is forced to Array<Dynamic>
-Main.hx:9: characters 35-48 : Arrays of mixed types are only allowed if the type is forced to Array<Dynamic>
 Main.hx:9: characters 35-48 : String should be Int
 Main.hx:9: characters 35-48 : For optional function argument 'arr'