[4.3.5] Backport Json RPC diagnostics

src/compiler/compiler.ml

@@ -2,15 +2,18 @@ open Globals
 open Common
 open CompilationContext
 
-let run_or_diagnose ctx f arg =
+let run_or_diagnose ctx f =
 	let com = ctx.com in
 	let handle_diagnostics ?(depth = 0) msg kind =
 		ctx.has_error <- true;
 		add_diagnostics_message ~depth com msg kind Error;
-		DisplayOutput.emit_diagnostics ctx.com
+		match com.report_mode with
+		| RMLegacyDiagnostics _ -> DisplayOutput.emit_legacy_diagnostics ctx.com
+		| RMDiagnostics _ -> DisplayOutput.emit_diagnostics ctx.com
+		| _ -> die "" __LOC__
 	in
 	if is_diagnostics com then begin try
-			f arg
+			f ()
 		with
 		| Error.Error(msg,p,depth) ->
 			handle_diagnostics ~depth (Error.error_msg p msg) DKCompilerMessage
@@ -20,7 +23,7 @@ let run_or_diagnose ctx f arg =
 			handle_diagnostics (located (Lexer.error_msg msg) p) DKParserError
 		end
 	else
-		f arg
+		f ()
 
 let run_command ctx cmd =
 	let t = Timer.timer ["command";cmd] in
@@ -279,7 +282,7 @@ let do_type ctx tctx actx =
 		if com.display.dms_kind <> DMNone then DisplayTexpr.check_display_file tctx cs;
 		List.iter (fun cpath -> ignore(tctx.Typecore.g.Typecore.do_load_module tctx cpath null_pos)) (List.rev actx.classes);
 		Finalization.finalize tctx;
-	) ();
+	);
 	com.stage <- CTypingDone;
 	(* If we are trying to find references, let's syntax-explore everything we know to check for the
 		identifier we are interested in. We then type only those modules that contain the identifier. *)
@@ -293,23 +296,25 @@ let finalize_typing ctx tctx =
 	let t = Timer.timer ["finalize"] in
 	let com = ctx.com in
 	com.stage <- CFilteringStart;
-	let main, types, modules = run_or_diagnose ctx Finalization.generate tctx in
+	let main, types, modules = run_or_diagnose ctx (fun () -> Finalization.generate tctx) in
 	com.main <- main;
 	com.types <- types;
 	com.modules <- modules;
 	t()
 
-let filter ctx tctx =
+let filter ctx tctx before_destruction =
 	let t = Timer.timer ["filters"] in
 	DeprecationCheck.run ctx.com;
-	Filters.run ctx.com tctx ctx.com.main;
+	run_or_diagnose ctx (fun () -> Filters.run tctx ctx.com.main before_destruction);
 	t()
 
 let compile ctx actx =
 	let com = ctx.com in
 	(* Set up display configuration *)
 	DisplayProcessing.process_display_configuration ctx;
+	let restore = disable_report_mode com in
 	let display_file_dot_path = DisplayProcessing.process_display_file com actx in
+	restore ();
 	(* Initialize target: This allows access to the appropriate std packages and sets the -D defines. *)
 	let ext = Setup.initialize_target ctx com actx in
 	com.config <- get_config com; (* make sure to adapt all flags changes defined after platform *)
@@ -331,8 +336,12 @@ let compile ctx actx =
 		end;
 		DisplayProcessing.handle_display_after_typing ctx tctx display_file_dot_path;
 		finalize_typing ctx tctx;
-		DisplayProcessing.handle_display_after_finalization ctx tctx display_file_dot_path;
-		filter ctx tctx;
+		if is_diagnostics com then
+			filter ctx tctx (fun () -> DisplayProcessing.handle_display_after_finalization ctx tctx display_file_dot_path)
+		else begin
+			DisplayProcessing.handle_display_after_finalization ctx tctx display_file_dot_path;
+			filter ctx tctx (fun () -> ());
+		end;
 		if ctx.has_error then raise Abort;
 		Generate.check_auxiliary_output com actx;
 		com.stage <- CGenerationStart;

src/compiler/displayOutput.ml

@@ -372,12 +372,22 @@ let handle_type_path_exception ctx p c is_import pos =
 		api.send_result (DisplayException.fields_to_json ctx fields kind (DisplayTypes.make_subject None pos));
 	end
 
-let emit_diagnostics com =
+let emit_legacy_diagnostics com =
 	let dctx = Diagnostics.run com in
 	let s = Json.string_of_json (DiagnosticsPrinter.json_of_diagnostics com dctx) in
 	DisplayPosition.display_position#reset;
 	raise (Completion s)
 
+let emit_diagnostics com =
+	(match com.Common.json_out with
+	| None -> die "" __LOC__
+	| Some api ->
+		let dctx = Diagnostics.run com in
+		let diagnostics = DiagnosticsPrinter.json_of_diagnostics com dctx in
+		DisplayPosition.display_position#reset;
+		api.send_result diagnostics;
+		raise Abort (* not reached because send_result always raises *))
+
 let emit_statistics tctx =
 	let stats = Statistics.collect_statistics tctx [SFFile (DisplayPosition.display_position#get).pfile] true in
 	let s = Statistics.Printer.print_statistics stats in

src/compiler/displayProcessing.ml

@@ -22,7 +22,7 @@ let handle_display_argument_old com file_pos actx =
 		actx.did_something <- true;
 		(try Memory.display_memory com with e -> prerr_endline (Printexc.get_backtrace ()));
 	| "diagnostics" ->
-		com.report_mode <- RMDiagnostics []
+		com.report_mode <- RMLegacyDiagnostics []
 	| _ ->
 		let file, pos = try ExtString.String.split file_pos "@" with _ -> failwith ("Invalid format: " ^ file_pos) in
 		let file = Helper.unquote file in
@@ -46,9 +46,9 @@ let handle_display_argument_old com file_pos actx =
 			| "module-symbols" ->
 				create (DMModuleSymbols None)
 			| "diagnostics" ->
-				com.report_mode <- RMDiagnostics [file_unique];
+				com.report_mode <- RMLegacyDiagnostics [file_unique];
 				let dm = create DMNone in
-				{dm with dms_display_file_policy = DFPAlso; dms_per_file = true; dms_populate_cache = !ServerConfig.populate_cache_from_display}
+				{dm with dms_display_file_policy = DFPAlso; dms_per_file = true}
 			| "statistics" ->
 				com.report_mode <- RMStatistics;
 				let dm = create DMNone in
@@ -142,48 +142,53 @@ let process_display_file com actx =
 		| DFPOnly when (DisplayPosition.display_position#get).pfile = file_input_marker ->
 			actx.classes <- [];
 			com.main_class <- None;
-			begin match !TypeloadParse.current_stdin with
-			| Some input ->
-				TypeloadParse.current_stdin := None;
+			begin match com.file_contents with
+			| [_, Some input] ->
+				com.file_contents <- [];
 				DPKInput input
-			| None ->
+			| _ ->
 				DPKNone
 			end
 		| dfp ->
 			if dfp = DFPOnly then begin
 				actx.classes <- [];
 				com.main_class <- None;
 			end;
-			let real = Path.get_real_path (DisplayPosition.display_position#get).pfile in
-			let path = match get_module_path_from_file_path com real with
-			| Some path ->
-				if com.display.dms_kind = DMPackage then DisplayException.raise_package (fst path);
-				let path = match ExtString.String.nsplit (snd path) "." with
-					| [name;"macro"] ->
-						(* If we have a .macro.hx path, don't add the file to classes because the compiler won't find it.
-						   This can happen if we're completing in such a file. *)
-						DPKMacro (fst path,name)
-					| [name] ->
-						actx.classes <- path :: actx.classes;
-						DPKNormal path
-					| [name;target] ->
-						let path = fst path, name in
-						actx.classes <- path :: actx.classes;
-						DPKNormal path
-					| e ->
-						die "" __LOC__
+			let dpk = List.map (fun file_key ->
+				let real = Path.get_real_path (Path.UniqueKey.to_string file_key) in
+				let dpk = match get_module_path_from_file_path com real with
+				| Some path ->
+					if com.display.dms_kind = DMPackage then DisplayException.raise_package (fst path);
+					let dpk = match ExtString.String.nsplit (snd path) "." with
+						| [name;"macro"] ->
+							(* If we have a .macro.hx path, don't add the file to classes because the compiler won't find it.
+								 This can happen if we're completing in such a file. *)
+							DPKMacro (fst path,name)
+						| [name] ->
+							actx.classes <- path :: actx.classes;
+							DPKNormal path
+						| [name;target] ->
+							let path = fst path, name in
+							actx.classes <- path :: actx.classes;
+							DPKNormal path
+						| _ ->
+							failwith ("Invalid display file '" ^ real ^ "'")
+					in
+					dpk
+				| None ->
+					if not (Sys.file_exists real) then failwith "Display file does not exist";
+					(match List.rev (ExtString.String.nsplit real Path.path_sep) with
+					| file :: _ when file.[0] >= 'a' && file.[0] <= 'z' -> failwith ("Display file '" ^ file ^ "' should not start with a lowercase letter")
+					| _ -> ());
+					DPKDirect real
 				in
-				path
-			| None ->
-				if not (Sys.file_exists real) then failwith "Display file does not exist";
-				(match List.rev (ExtString.String.nsplit real Path.path_sep) with
-				| file :: _ when file.[0] >= 'a' && file.[0] <= 'z' -> failwith ("Display file '" ^ file ^ "' should not start with a lowercase letter")
-				| _ -> ());
-				DPKDirect real
-			in
-			Common.log com ("Display file : " ^ real);
+				Common.log com ("Display file : " ^ real);
+				dpk
+			) DisplayPosition.display_position#get_files in
 			Common.log com ("Classes found : ["  ^ (String.concat "," (List.map s_type_path actx.classes)) ^ "]");
-			path
+			match dpk with
+				| [dfile] -> dfile
+				| _ -> DPKNone
 
 (* 3. Loaders for display file that might be called *)
 
@@ -348,10 +353,12 @@ let handle_display_after_finalization ctx tctx display_file_dot_path =
 	end;
 	process_global_display_mode com tctx;
 	begin match com.report_mode with
+	| RMLegacyDiagnostics _ ->
+		DisplayOutput.emit_legacy_diagnostics com
 	| RMDiagnostics _ ->
 		DisplayOutput.emit_diagnostics com
 	| RMStatistics ->
 		DisplayOutput.emit_statistics tctx
 	| RMNone ->
 		()
-	end
+	end

src/compiler/server.ml

@@ -18,15 +18,7 @@ let has_error ctx =
 	ctx.has_error || ctx.com.Common.has_error
 
 let check_display_flush ctx f_otherwise = match ctx.com.json_out with
-	| None ->
-		if is_diagnostics ctx.com then begin
-			List.iter (fun cm ->
-				add_diagnostics_message ~depth:cm.cm_depth ctx.com (located cm.cm_message cm.cm_pos) cm.cm_kind cm.cm_severity
-			) (List.rev ctx.messages);
-			raise (Completion (Diagnostics.print ctx.com))
-		end else
-			f_otherwise ()
-	| Some api ->
+	| Some api when not (is_diagnostics ctx.com) ->
 		if has_error ctx then begin
 			let errors = List.map (fun cm ->
 				JObject [
@@ -37,6 +29,17 @@ let check_display_flush ctx f_otherwise = match ctx.com.json_out with
 			) (List.rev ctx.messages) in
 			api.send_error errors
 		end
+	| _ ->
+		if is_diagnostics ctx.com then begin
+			List.iter (fun cm ->
+				add_diagnostics_message ~depth:cm.cm_depth ctx.com (located cm.cm_message cm.cm_pos) cm.cm_kind cm.cm_severity
+			) (List.rev ctx.messages);
+			(match ctx.com.report_mode with
+			| RMDiagnostics _ -> ()
+			| RMLegacyDiagnostics _ -> raise (Completion (Diagnostics.print ctx.com))
+			| _ -> die "" __LOC__)
+		end else
+			f_otherwise ()
 
 let current_stdin = ref None
 
@@ -46,7 +49,7 @@ let parse_file cs com file p =
 	and fkey = com.file_keys#get file in
 	let is_display_file = DisplayPosition.display_position#is_in_file (com.file_keys#get ffile) in
 	match is_display_file, !current_stdin with
-	| true, Some stdin when Common.defined com Define.DisplayStdin ->
+	| true, Some stdin when (com.file_contents <> [] || Common.defined com Define.DisplayStdin) ->
 		TypeloadParse.parse_file_from_string com file p stdin
 	| _ ->
 		let ftime = file_time ffile in

src/compiler/serverConfig.ml

@@ -1,3 +1,2 @@
 let do_not_check_modules = ref false
-let populate_cache_from_display = ref true
 let legacy_completion = ref false

src/context/common.ml

@@ -272,7 +272,8 @@ type compiler_stage =
 
 type report_mode =
 	| RMNone
-	| RMDiagnostics of Path.UniqueKey.t list
+	| RMLegacyDiagnostics of (Path.UniqueKey.t list)
+	| RMDiagnostics of (Path.UniqueKey.t list)
 	| RMStatistics
 
 class virtual ['key,'value] lookup = object(self)
@@ -382,6 +383,7 @@ type context = {
 	display_information : display_information;
 	file_lookup_cache : (string,string option) lookup;
 	file_keys : file_keys;
+	mutable file_contents : (Path.UniqueKey.t * string option) list;
 	readdir_cache : (string * string,(string array) option) lookup;
 	parser_cache : (string,(type_def * pos) list) lookup;
 	module_to_file : (path,string) lookup;
@@ -852,6 +854,7 @@ let create compilation_step cs version args =
 		};
 		file_lookup_cache = new hashtbl_lookup;
 		file_keys = new file_keys;
+		file_contents = [];
 		readdir_cache = new hashtbl_lookup;
 		module_to_file = new hashtbl_lookup;
 		stored_typed_exprs = new hashtbl_lookup;
@@ -867,7 +870,7 @@ let create compilation_step cs version args =
 	com
 
 let is_diagnostics com = match com.report_mode with
-	| RMDiagnostics _ -> true
+	| RMLegacyDiagnostics _ | RMDiagnostics _ -> true
 	| _ -> false
 
 let disable_report_mode com =

src/context/display/diagnostics.ml

@@ -20,13 +20,14 @@ let find_unused_variables com e =
 	let vars = Hashtbl.create 0 in
 	let pmin_map = Hashtbl.create 0 in
 	let rec loop e = match e.eexpr with
-		| TVar({v_kind = VUser _} as v,eo) when v.v_name <> "_" ->
+		| TVar({v_kind = VUser origin} as v,eo) when v.v_name <> "_" && not (has_var_flag v VUsedByTyper) ->
 			Hashtbl.add pmin_map e.epos.pmin v;
 			let p = match eo with
-				| None -> e.epos
-				| Some e1 ->
-					loop e1;
-					{ e.epos with pmax = e1.epos.pmin }
+			| Some e1 when origin <> TVOPatternVariable ->
+				loop e1;
+				{ e.epos with pmax = e1.epos.pmin }
+			| _ ->
+				e.epos
 			in
 			Hashtbl.replace vars v.v_id (v,p);
 		| TLocal ({v_kind = VUser _} as v) ->
@@ -179,15 +180,10 @@ let prepare com =
 	dctx.unresolved_identifiers <- com.display_information.unresolved_identifiers;
 	dctx
 
-let secure_generated_code ctx e =
-	(* This causes problems and sucks in general... need a different solution. But I forgot which problem this solved anyway. *)
-	(* mk (TMeta((Meta.Extern,[],e.epos),e)) e.etype e.epos *)
-	e
-
 let print com =
 	let dctx = prepare com in
 	Json.string_of_json (DiagnosticsPrinter.json_of_diagnostics com dctx)
 
 let run com =
 	let dctx = prepare com in
-	dctx
+	dctx

src/context/display/diagnosticsPrinter.ml

@@ -25,8 +25,8 @@ let make_diagnostic kd p sev args = {
 
 let is_diagnostics_file com file_key =
 	match com.report_mode with
-	| RMDiagnostics [] -> true
-	| RMDiagnostics file_keys -> List.exists (fun key' -> file_key = key') file_keys
+	| RMLegacyDiagnostics [] | RMDiagnostics [] -> true
+	| RMLegacyDiagnostics file_keys | RMDiagnostics file_keys -> List.mem file_key file_keys
 	| _ -> false
 
 module UnresolvedIdentifierSuggestion = struct