[display] send progress events for class path reading

see #8696

src/context/common.ml

@@ -171,6 +171,7 @@ type shared_context = {
 type json_api = {
 	send_result : Json.t -> unit;
 	send_error : Json.t list -> unit;
+	send_notification : (string * (string * Json.t) list) -> unit;
 	jsonrpc : Jsonrpc_handler.jsonrpc_handler;
 }
 
@@ -836,3 +837,13 @@ let adapt_defines_to_macro_context defines =
 	values := PMap.foldi (fun k v acc -> if List.mem k to_remove then acc else PMap.add k v acc) !values PMap.empty;
 	values := PMap.add "macro" "1" !values;
 	{values = !values; defines_signature = None }
+
+let maybe_send_notification com f = match com.json_out with
+	| Some api ->
+		api.send_notification (f())
+	| None ->
+		()
+
+let get_notification_function com = match com.json_out with
+	| Some api -> (fun f -> api.send_notification (f()))
+	| None -> (fun _ -> ())

src/context/display/displayJson.ml

@@ -79,6 +79,7 @@ type handler_context = {
 	display : display_handler;
 	send_result : Json.t -> unit;
 	send_error : 'a . Json.t list -> 'a;
+	send_notification : (string * (string * Json.t) list) -> unit;
 }
 
 let handler =
@@ -277,9 +278,14 @@ let parse_input com input report_times =
 		send_json (JsonRpc.error jsonrpc#get_id 0 ~data:(Some (JArray jl)) "Compiler error")
 	in
 
+	let send_notification (name,jl) =
+		send_json (JsonRpc.notification name (Some (jobject jl)))
+	in
+
 	com.json_out <- Some({
 		send_result = send_result;
 		send_error = send_error;
+		send_notification = send_notification;
 		jsonrpc = jsonrpc
 	});
 
@@ -296,6 +302,7 @@ let parse_input com input report_times =
 		display = display;
 		send_result = send_result;
 		send_error = send_error;
+		send_notification = send_notification;
 	} in
 
 	JsonRpc.handle_jsonrpc_error (fun () ->

src/context/display/displayToplevel.ml

@@ -74,7 +74,13 @@ let explore_class_paths com timer class_paths recusive f_pack f_module =
 
 let read_class_paths com timer =
 	let sign = Define.get_signature com.defines in
-	explore_class_paths com timer (List.filter ((<>) "") com.class_path) true (fun _ -> ()) (fun file path ->
+	let progress = new Notifications.Progress.t in
+	let send = get_notification_function com in
+	send (fun () -> progress#start "Reading class paths");
+	let f_pack (pack,dir) =
+		send (progress#report ~message:("Reading package " ^ dir))
+	in
+	explore_class_paths com timer (List.filter ((<>) "") com.class_path) true f_pack (fun file path ->
 		(* Don't parse the display file as that would maybe overwrite the content from stdin with the file contents. *)
 		if not (DisplayPosition.display_position#is_in_file file) then begin
 			let file,_,pack,_ = Display.parse_module' com path Globals.null_pos in
@@ -85,7 +91,8 @@ let read_class_paths com timer =
 			| _ ->
 				()
 		end
-	)
+	);
+	send (fun () -> progress#done')
 
 let init_or_update_server cs com timer_name =
 	let sign = Define.get_signature com.defines in

src/core/json/notifications.ml

@@ -0,0 +1,40 @@
+open JsonRpc
+open Genjson
+
+let notification name fl =
+	notification name (Some (jobject fl))
+
+module Progress = struct
+	let get_id =
+		let id = ref 0 in
+		(fun () ->
+			incr id;
+			!id
+		)
+
+	class t = object(self)
+		val id = get_id();
+
+		method start ?cancellable ?message ?percentage title = "progress/start",[
+			"id",jint id;
+			"title",jstring title;
+			"cancellable",jopt jbool cancellable;
+			"message",jopt jstring message;
+			"percentage",jopt jfloat percentage;
+		]
+
+		method done' = "progress/done",[
+			"id",jint id;
+		]
+
+		method report ?message ?percentage () = "progress/report",[
+			"id",jint id;
+			"message",jopt jstring message;
+			"percentage",jopt jfloat percentage;
+		]
+
+		method cancel = "progress/cancel",[
+			"id",jint id;
+		]
+	end
+end