[display] refactor diagnostics a bit

see #9134

src/compiler/haxe.ml

@@ -1194,7 +1194,11 @@ with
 	| Parser.SyntaxCompletion(kind,subj) ->
 		DisplayOutput.handle_syntax_completion com kind subj;
 		error ctx ("Error: No completion point was found") null_pos
-	| DisplayException(ModuleSymbols s | Diagnostics s | Statistics s | Metadata s) ->
+	| DisplayException(DisplayDiagnostics dctx) ->
+		let s = Json.string_of_json (DiagnosticsPrinter.json_of_diagnostics dctx) in
+		DisplayPosition.display_position#reset;
+		raise (DisplayOutput.Completion s)
+	| DisplayException(ModuleSymbols s | Statistics s | Metadata s) ->
 		DisplayPosition.display_position#reset;
 		raise (DisplayOutput.Completion s)
 	| EvalExceptions.Sys_exit i | Hlinterp.Sys_exit i ->

src/context/display/diagnostics.ml

@@ -5,15 +5,9 @@ open Typecore
 open Common
 open Display
 open DisplayTypes.DisplayMode
-
-type diagnostics_context = {
-	com : Common.context;
-	mutable removable_code : (string * pos * pos) list;
-	mutable import_positions : (pos,bool ref) PMap.t;
-	mutable dead_blocks : (string,(pos * expr) list) Hashtbl.t;
-}
-
 open DisplayTypes
+open DisplayException
+open DiagnosticsTypes
 
 let add_removable_code ctx s p prange =
 	ctx.removable_code <- (s,p,prange) :: ctx.removable_code
@@ -95,25 +89,27 @@ let check_other_things com e =
 	in
 	loop true e
 
-let prepare_field dctx cf = match cf.cf_expr with
+let prepare_field dctx com cf = match cf.cf_expr with
 	| None -> ()
 	| Some e ->
 		find_unused_variables dctx e;
-		check_other_things dctx.com e;
-		DeprecationCheck.run_on_expr dctx.com e
+		check_other_things com e;
+		DeprecationCheck.run_on_expr com e
 
 let prepare com global =
 	let dctx = {
+		global = global;
 		removable_code = [];
-		com = com;
 		import_positions = PMap.empty;
 		dead_blocks = Hashtbl.create 0;
+		diagnostics_messages = [];
+		unresolved_identifiers = [];
 	} in
 	List.iter (function
 		| TClassDecl c when global || DisplayPosition.display_position#is_in_file c.cl_pos.pfile ->
-			List.iter (prepare_field dctx) c.cl_ordered_fields;
-			List.iter (prepare_field dctx) c.cl_ordered_statics;
-			(match c.cl_constructor with None -> () | Some cf -> prepare_field dctx cf);
+			List.iter (prepare_field dctx com) c.cl_ordered_fields;
+			List.iter (prepare_field dctx com) c.cl_ordered_statics;
+			(match c.cl_constructor with None -> () | Some cf -> prepare_field dctx com cf);
 		| _ ->
 			()
 	) com.types;
@@ -158,6 +154,9 @@ let prepare com global =
 	| None -> ()
 	| Some com -> process_modules com
 	end;
+	(* We do this at the end because some of the prepare functions might add information to the common context. *)
+	dctx.diagnostics_messages <- com.shared.shared_display_information.diagnostics_messages;
+	dctx.unresolved_identifiers <- com.display_information.unresolved_identifiers;
 	dctx
 
 let is_diagnostics_run p = match (!Parser.display_mode) with
@@ -168,107 +167,10 @@ let is_diagnostics_run p = match (!Parser.display_mode) with
 let secure_generated_code ctx e =
 	if is_diagnostics_run e.epos then mk (TMeta((Meta.Extern,[],e.epos),e)) e.etype e.epos else e
 
-module Printer = struct
-	open Json
-	open DiagnosticsKind
-	open DisplayTypes
-
-	type t = DiagnosticsKind.t * pos
-
-	module UnresolvedIdentifierSuggestion = struct
-		type t =
-			| UISImport
-			| UISTypo
-
-		let to_int = function
-			| UISImport -> 0
-			| UISTypo -> 1
-	end
-
-	open UnresolvedIdentifierSuggestion
-	open CompletionItem
-	open CompletionModuleType
-
-	let print_diagnostics dctx com global =
-		let diag = Hashtbl.create 0 in
-		let add dk p sev args =
-			let file = if p = null_pos then p.pfile else Path.get_real_path p.pfile in
-			let diag = try
-				Hashtbl.find diag file
-			with Not_found ->
-				let d = Hashtbl.create 0 in
-				Hashtbl.add diag file d;
-				d
-			in
-			if not (Hashtbl.mem diag p) then
-				Hashtbl.add diag p (dk,p,sev,args)
-		in
-		let add dk p sev args =
-			if global || p = null_pos || DisplayPosition.display_position#is_in_file p.pfile then add dk p sev args
-		in
-		List.iter (fun (s,p,suggestions) ->
-			let suggestions = ExtList.List.filter_map (fun (s,item,r) ->
-				match item.ci_kind with
-				| ITType(t,_) when r = 0 ->
-					let path = if t.module_name = t.name then (t.pack,t.name) else (t.pack @ [t.module_name],t.name) in
-					Some (JObject [
-						"kind",JInt (to_int UISImport);
-						"name",JString (s_type_path path);
-					])
-				| _ when r = 0 ->
-					(* TODO !!! *)
-					None
-				| _ ->
-					Some (JObject [
-						"kind",JInt (to_int UISTypo);
-						"name",JString s;
-					])
-			) suggestions in
-			add DKUnresolvedIdentifier p DiagnosticsSeverity.Error (JArray suggestions);
-		) com.display_information.unresolved_identifiers;
-		PMap.iter (fun p r ->
-			if not !r then add DKUnusedImport p DiagnosticsSeverity.Warning (JArray [])
-		) dctx.import_positions;
-		List.iter (fun (s,p,kind,sev) ->
-			add kind p sev (JString s)
-		) (List.rev com.shared.shared_display_information.diagnostics_messages);
-		List.iter (fun (s,p,prange) ->
-			add DKRemovableCode p DiagnosticsSeverity.Warning (JObject ["description",JString s;"range",if prange = null_pos then JNull else Genjson.generate_pos_as_range prange])
-		) dctx.removable_code;
-		Hashtbl.iter (fun p s ->
-			add DKDeprecationWarning p DiagnosticsSeverity.Warning (JString s);
-		) DeprecationCheck.warned_positions;
-		Hashtbl.iter (fun file ranges ->
-			List.iter (fun (p,e) ->
-				let jo = JObject [
-					"expr",JObject [
-						"string",JString (Ast.Printer.s_expr e)
-					]
-				] in
-				add DKInactiveBlock p DiagnosticsSeverity.Hint jo
-			) ranges
-		) dctx.dead_blocks;
-		let jl = Hashtbl.fold (fun file diag acc ->
-			let jl = Hashtbl.fold (fun _ (dk,p,sev,jargs) acc ->
-				(JObject [
-					"kind",JInt (DiagnosticsKind.to_int dk);
-					"severity",JInt (DiagnosticsSeverity.to_int sev);
-					"range",Genjson.generate_pos_as_range p;
-					"args",jargs
-				]) :: acc
-			) diag [] in
-			(JObject [
-				"file",if file = "?" then JNull else JString file;
-				"diagnostics",JArray jl
-			]) :: acc
-		) diag [] in
-		let js = JArray jl in
-		string_of_json js
-end
-
 let print com global =
 	let dctx = prepare com global in
-	Printer.print_diagnostics dctx com global
+	Json.string_of_json (DiagnosticsPrinter.json_of_diagnostics dctx)
 
 let run com global =
-	DisplayException.raise_diagnostics (print com global)
+	let dctx = prepare com global in
+	DisplayException.raise_diagnostics dctx

src/context/display/diagnosticsPrinter.ml

@@ -0,0 +1,98 @@
+open Globals
+open Json
+open DisplayTypes
+open DiagnosticsKind
+open DisplayTypes
+open DiagnosticsTypes
+
+type t = DiagnosticsKind.t * pos
+
+module UnresolvedIdentifierSuggestion = struct
+	type t =
+		| UISImport
+		| UISTypo
+
+	let to_int = function
+		| UISImport -> 0
+		| UISTypo -> 1
+end
+
+open UnresolvedIdentifierSuggestion
+open CompletionItem
+open CompletionModuleType
+
+let json_of_diagnostics dctx =
+	let diag = Hashtbl.create 0 in
+	let add dk p sev args =
+		let file = if p = null_pos then p.pfile else Path.get_real_path p.pfile in
+		let diag = try
+			Hashtbl.find diag file
+		with Not_found ->
+			let d = Hashtbl.create 0 in
+			Hashtbl.add diag file d;
+			d
+		in
+		if not (Hashtbl.mem diag p) then
+			Hashtbl.add diag p (dk,p,sev,args)
+	in
+	let add dk p sev args =
+		if dctx.global || p = null_pos || DisplayPosition.display_position#is_in_file p.pfile then add dk p sev args
+	in
+	List.iter (fun (s,p,suggestions) ->
+		let suggestions = ExtList.List.filter_map (fun (s,item,r) ->
+			match item.ci_kind with
+			| ITType(t,_) when r = 0 ->
+				let path = if t.module_name = t.name then (t.pack,t.name) else (t.pack @ [t.module_name],t.name) in
+				Some (JObject [
+					"kind",JInt (to_int UISImport);
+					"name",JString (s_type_path path);
+				])
+			| _ when r = 0 ->
+				(* TODO !!! *)
+				None
+			| _ ->
+				Some (JObject [
+					"kind",JInt (to_int UISTypo);
+					"name",JString s;
+				])
+		) suggestions in
+		add DKUnresolvedIdentifier p DiagnosticsSeverity.Error (JArray suggestions);
+	) dctx.unresolved_identifiers;
+	PMap.iter (fun p r ->
+		if not !r then add DKUnusedImport p DiagnosticsSeverity.Warning (JArray [])
+	) dctx.import_positions;
+	List.iter (fun (s,p,kind,sev) ->
+		add kind p sev (JString s)
+	) (List.rev dctx.diagnostics_messages);
+	List.iter (fun (s,p,prange) ->
+		add DKRemovableCode p DiagnosticsSeverity.Warning (JObject ["description",JString s;"range",if prange = null_pos then JNull else Genjson.generate_pos_as_range prange])
+	) dctx.removable_code;
+	Hashtbl.iter (fun p s ->
+		add DKDeprecationWarning p DiagnosticsSeverity.Warning (JString s);
+	) DeprecationCheck.warned_positions;
+	Hashtbl.iter (fun file ranges ->
+		List.iter (fun (p,e) ->
+			let jo = JObject [
+				"expr",JObject [
+					"string",JString (Ast.Printer.s_expr e)
+				]
+			] in
+			add DKInactiveBlock p DiagnosticsSeverity.Hint jo
+		) ranges
+	) dctx.dead_blocks;
+	let jl = Hashtbl.fold (fun file diag acc ->
+		let jl = Hashtbl.fold (fun _ (dk,p,sev,jargs) acc ->
+			(JObject [
+				"kind",JInt (DiagnosticsKind.to_int dk);
+				"severity",JInt (DiagnosticsSeverity.to_int sev);
+				"range",Genjson.generate_pos_as_range p;
+				"args",jargs
+			]) :: acc
+		) diag [] in
+		(JObject [
+			"file",if file = "?" then JNull else JString file;
+			"diagnostics",JArray jl
+		]) :: acc
+	) diag [] in
+	let js = JArray jl in
+	js

src/context/display/diagnosticsTypes.ml

@@ -0,0 +1,11 @@
+open Globals
+open Ast
+
+type diagnostics_context = {
+	global : bool;
+	mutable removable_code : (string * pos * pos) list;
+	mutable import_positions : (pos,bool ref) PMap.t;
+	mutable dead_blocks : (string,(pos * expr) list) Hashtbl.t;
+	mutable unresolved_identifiers : (string * pos * (string * CompletionItem.t * int) list) list;
+	mutable diagnostics_messages : (string * pos * DisplayTypes.DiagnosticsKind.t * DisplayTypes.DiagnosticsSeverity.t) list;
+}

src/context/display/displayException.ml

@@ -22,7 +22,7 @@ type signature_kind =
 	| SKArrayAccess
 
 type kind =
-	| Diagnostics of string
+	| DisplayDiagnostics of DiagnosticsTypes.diagnostics_context
 	| Statistics of string
 	| ModuleSymbols of string
 	| Metadata of string
@@ -34,7 +34,7 @@ type kind =
 
 exception DisplayException of kind
 
-let raise_diagnostics s = raise (DisplayException(Diagnostics s))
+let raise_diagnostics s = raise (DisplayException(DisplayDiagnostics s))
 let raise_statistics s = raise (DisplayException(Statistics s))
 let raise_module_symbols s = raise (DisplayException(ModuleSymbols s))
 let raise_metadata s = raise (DisplayException(Metadata s))
@@ -167,12 +167,13 @@ let fields_to_json ctx fields kind subj =
 
 let to_json ctx de =
 	match de with
-	| Diagnostics _
 	| Statistics _
 	| ModuleSymbols _
 	| Metadata _ -> assert false
 	| DisplaySignatures None ->
 		jnull
+	| DisplayDiagnostics dctx ->
+		DiagnosticsPrinter.json_of_diagnostics dctx
 	| DisplaySignatures Some(sigs,isig,iarg,kind) ->
 		(* We always want full info for signatures *)
 		let ctx = Genjson.create_context GMFull in