[server] add description to server signatures so we know where they come from

src/compiler/displayOutput.ml

@@ -258,7 +258,7 @@ module Memory = struct
 					"size",jint size;
 				]
 			) modules in
-			let j = try fst (List.assoc sign cs.signs) with Not_found -> jnull in
+			let j = try (List.assoc sign cs.signs).cs_json with Not_found -> jnull in
 			let jo = jobject [
 				"context",j;
 				"size",jint !size;

src/compiler/main.ml

@@ -827,14 +827,13 @@ try
 		let t = Timer.timer ["typing"] in
 		Typecore.type_expr_ref := (fun ctx e with_type -> Typer.type_expr ctx e with_type);
 		let tctx = Typer.create com in
+		let add_signature desc =
+			Option.may (fun cs -> CompilationServer.maybe_add_context_sign cs com desc) (CompilationServer.get ());
+		in
+		add_signature "before_init_macros";
 		List.iter (MacroContext.call_init_macro tctx) (List.rev !config_macros);
+		add_signature "after_init_macros";
 		List.iter (fun f -> f ()) (List.rev com.callbacks#get_after_init_macros);
-		begin match CompilationServer.get () with
-		| None -> ()
-		| Some cs ->
-			let sign = Define.get_signature com.defines in
-			try ignore(CompilationServer.get_sign cs sign) with Not_found -> ignore(CompilationServer.add_sign cs sign com)
-		end;
 		List.iter (fun cpath -> ignore(tctx.Typecore.g.Typecore.do_load_module tctx cpath null_pos)) (List.rev !classes);
 		Finalization.finalize tctx;
 		(* If we are trying to find references, let's syntax-explore everything we know to check for the

src/compiler/serverMessage.ml

@@ -59,9 +59,9 @@ let sign_string com =
 	let cs = CompilationServer.force () in
 	let	sign_id =
 		try
-			snd (CompilationServer.get_sign cs sign)
+			(CompilationServer.get_sign cs sign).cs_index
 		with Not_found ->
-			let i = CompilationServer.add_sign cs sign com in
+			let i = CompilationServer.add_sign cs sign "message" com in
 			if config.print_new_context then print_endline (Printf.sprintf "Found context %i:\n%s" i (dump_context com));
 			i
 	in

src/context/compilationServer.ml

@@ -23,9 +23,14 @@ type cache = {
 	c_directories : (string, cached_directory list) Hashtbl.t;
 }
 
+type context_sign = {
+	cs_json : Json.t;
+	cs_index : int;
+}
+
 type t = {
 	cache : cache;
-	mutable signs : (string * (Json.t * int)) list;
+	mutable signs : (string * context_sign) list;
 	mutable initialized : bool;
 }
 
@@ -77,13 +82,14 @@ let get_context_files cs signs =
 let get_sign cs sign =
 	List.assoc sign cs.signs
 
-let get_sign_by_index cs index =
-	List.find (fun (_,(_,i)) -> i = index) cs.signs
+let has_sign cs sign =
+	List.mem_assoc sign cs.signs
 
-let add_sign cs sign com =
+let add_sign cs sign desc com =
 	let i = List.length cs.signs in
 	let jo = JObject [
 		"index",JInt i;
+		"desc",JString desc;
 		"platform",JString (platform_name com.platform);
 		"classPaths",JArray (List.map (fun s -> JString s) com.class_path);
 		"signature",JString (Digest.to_hex sign);
@@ -92,9 +98,13 @@ let add_sign cs sign com =
 			"value",JString v;
 		] :: acc) com.defines.values []);
 	] in
-	cs.signs <- (sign,(jo,i)) :: cs.signs;
+	cs.signs <- (sign,{cs_json = jo;cs_index = i}) :: cs.signs;
 	i
 
+let maybe_add_context_sign cs com desc =
+	let sign = Define.get_signature com.defines in
+	if not (has_sign cs sign) then ignore (add_sign cs sign desc com)
+
 let get_signs cs =
 	cs.signs
 

src/context/display/displayJson.ml

@@ -157,7 +157,7 @@ let handler =
 			)
 		);
 		"server/contexts", (fun hctx ->
-			let l = List.map (fun (sign,(jo,_)) -> jo) (CompilationServer.get_signs hctx.display#get_cs) in
+			let l = List.map (fun (sign,csign) -> csign.cs_json) (CompilationServer.get_signs hctx.display#get_cs) in
 			hctx.send_result (jarray l)
 		);
 		"server/modules", (fun hctx ->

src/typing/macroContext.ml

@@ -484,12 +484,7 @@ let get_macro_context ctx p =
 		let mctx = ctx.g.do_create com2 in
 		mctx.is_display_file <- false;
 		create_macro_interp ctx mctx;
-		begin match CompilationServer.get () with
-		| None -> ()
-		| Some cs ->
-			let sign = Define.get_signature com2.defines in
-			try ignore(CompilationServer.get_sign cs sign) with Not_found -> ignore(CompilationServer.add_sign cs sign com2)
-		end;
+		Option.may (fun cs -> CompilationServer.maybe_add_context_sign cs com2 "get_macro_context") (CompilationServer.get());
 		api, mctx
 
 let load_macro_module ctx cpath display p =

src/typing/typeload.ml

@@ -735,6 +735,7 @@ let load_core_class ctx c =
 			if ctx.in_macro then Common.define com2 Define.Macro;
 			com2.class_path <- ctx.com.std_path;
 			if com2.display.dms_check_core_api then com2.display <- {com2.display with dms_check_core_api = false};
+			Option.may (fun cs -> CompilationServer.maybe_add_context_sign cs com2 "load_core_class") (CompilationServer.get ());
 			let ctx2 = ctx.g.do_create com2 in
 			ctx.g.core_api <- Some ctx2;
 			ctx2