[json] factor out jsonrpc_handler

src/context/display/displayJson.ml

@@ -1,6 +1,7 @@
 open Globals
 open Json.Reader
 open JsonRpc
+open Jsonrpc_handler
 open Json
 open Common
 open DisplayTypes.DisplayMode
@@ -43,104 +44,6 @@ let send_string j =
 let send_json json =
 	send_string (string_of_json json)
 
-type haxe_json_error =
-	| MissingField of string * string
-	| BadType of string * string
-
-class jsonrpc_handler report_times (id,name,params) = object(self)
-	val id = id
-	val method_name : string = name
-	val params = match params with
-		| Some (JObject fl) -> fl
-		| Some json -> raise_invalid_params json
-		| None -> []
-
-	method get_id = id
-	method get_method_name = method_name
-
-	method raise_haxe_json_error : 'a . haxe_json_error -> 'a = function
-		| MissingField(name,on) -> raise_custom id 1 (Printf.sprintf "Missing param \"%s\" on \"%s\"" name on)
-		| BadType(desc,expected) -> raise_custom id 2 (Printf.sprintf "Unexpected value for \"%s\", expected %s" desc expected)
-
-	method get_field desc fl name : Json.t =
-		try
-			List.assoc name fl
-		with Not_found ->
-			self#raise_haxe_json_error (MissingField(name,desc))
-
-	method get_string desc j = match j with
-		| JString s -> s
-		| _ -> self#raise_haxe_json_error (BadType(desc,"String"))
-
-	method get_int desc j = match j with
-		| JInt i -> i
-		| _ -> self#raise_haxe_json_error (BadType(desc,"String"))
-
-	method get_bool desc j = match j with
-		| JBool b -> b
-		| _ -> self#raise_haxe_json_error (BadType(desc,"Bool"))
-
-	method get_array desc j : Json.t list = match j with
-		| JArray a -> a
-		| _ -> self#raise_haxe_json_error (BadType(desc,"Array"))
-
-	method get_object desc j = match j with
-		| JObject o -> o
-		| _ -> self#raise_haxe_json_error (BadType(desc,"Object"))
-
-	method get_string_field desc name fl =
-		self#get_string desc (self#get_field desc fl name)
-
-	method get_int_field desc name fl =
-		self#get_int desc (self#get_field desc fl name)
-
-	method get_bool_field desc name fl =
-		self#get_bool desc (self#get_field desc fl name)
-
-	method get_array_field desc name fl =
-		self#get_array desc (self#get_field desc fl name)
-
-	method get_object_field desc name fl =
-		self#get_object desc (self#get_field desc fl name)
-
-	method get_string_param name =
-		self#get_string_field "params" name params
-
-	method get_int_param name =
-		self#get_int_field "params" name params
-
-	method get_bool_param name =
-		self#get_bool_field "params" name params
-
-	method get_array_param name =
-		self#get_array_field "params" name params
-
-	method get_object_param name =
-		self#get_object_field "params" name params
-
-	method get_opt_param : 'a . (unit -> 'a) -> 'a -> 'a = fun f def ->
-		try f() with JsonRpc_error _ -> def
-
-	method send_result json : unit =
-		let fl = [
-			"result",json;
-			"timestamp",jfloat (Unix.gettimeofday ());
-		] in
-		let fl = if !report_times then begin
-			close_times();
-			let _,_,root = Timer.build_times_tree () in
-			begin match json_of_times root with
-			| None -> fl
-			| Some jo -> ("timers",jo) :: fl
-			end
-		end else fl in
-		let jo = jobject fl in
-		send_json (JsonRpc.result id jo);
-
-	method send_error : 'a . Json.t list -> 'a  = fun jl ->
-		send_json (JsonRpc.error id 0 ~data:(Some (JArray jl)) "Compiler error")
-end
-
 let debug_context_sign = ref None
 
 class display_handler (jsonrpc : jsonrpc_handler) com cs = object(self)
@@ -184,6 +87,8 @@ type handler_context = {
 	com : Common.context;
 	jsonrpc : jsonrpc_handler;
 	display : display_handler;
+	send_result : Json.t -> unit;
+	send_error : 'a . Json.t list -> 'a;
 }
 
 let handler =
@@ -193,7 +98,7 @@ let handler =
 		"initialize", (fun hctx ->
 			supports_resolve := hctx.jsonrpc#get_opt_param (fun () -> hctx.jsonrpc#get_bool_param "supportsResolve") false;
 			let methods = Hashtbl.fold (fun k _ acc -> (jstring k) :: acc) h [] in
-			hctx.jsonrpc#send_result (JObject [
+			hctx.send_result (JObject [
 				"methods",jarray methods;
 				"haxeVersion",jobject [
 					"major",jint version_major;
@@ -214,9 +119,9 @@ let handler =
 			begin try
 				let item = (!DisplayException.last_completion_result).(i) in
 				let ctx = Genjson.create_context GMFull in
-				hctx.jsonrpc#send_result (jobject ["item",CompletionItem.to_json ctx item])
+				hctx.send_result (jobject ["item",CompletionItem.to_json ctx item])
 			with Invalid_argument _ ->
-				hctx.jsonrpc#send_error [jstring (Printf.sprintf "Invalid index: %i" i)]
+				hctx.send_error [jstring (Printf.sprintf "Invalid index: %i" i)]
 			end
 		);
 		"display/completion", (fun hctx ->
@@ -255,7 +160,7 @@ let handler =
 			hctx.com.callbacks.after_init_macros <- (fun () ->
 				CompilationServer.set_initialized hctx.display#get_cs;
 				DisplayToplevel.read_class_paths hctx.com ["init"];
-				hctx.jsonrpc#send_result (jstring "class paths read");
+				hctx.send_result (jstring "class paths read");
 			) :: hctx.com.callbacks.after_init_macros;
 		);
 		"server/contexts", (fun hctx ->
@@ -263,24 +168,24 @@ let handler =
 				"signature",jstring (Digest.to_hex sign);
 				"context",jo;
 			]) (CompilationServer.get_signs hctx.display#get_cs) in
-			hctx.jsonrpc#send_result (jarray l)
+			hctx.send_result (jarray l)
 		);
 		"server/select", (fun hctx ->
 			let i = hctx.jsonrpc#get_int_param "index" in
 			let (sign,_) = try
 				CompilationServer.get_sign_by_index hctx.display#get_cs i
 			with Not_found ->
-				hctx.jsonrpc#send_error [jstring "No such context"]
+				hctx.send_error [jstring "No such context"]
 			in
 			hctx.display#set_debug_context_sign (Some sign);
-			hctx.jsonrpc#send_result (jstring (Printf.sprintf "Context %i selected" i))
+			hctx.send_result (jstring (Printf.sprintf "Context %i selected" i))
 		 );
 		 "server/modules", (fun hctx ->
 			let sign = hctx.display#get_sign in
 			let l = Hashtbl.fold (fun (_,sign') m acc ->
 				if sign = sign' && m.m_extra.m_kind <> MFake then jstring (s_type_path m.m_path) :: acc else acc
 			) hctx.display#get_cs.cache.c_modules [] in
-			hctx.jsonrpc#send_result (jarray l)
+			hctx.send_result (jarray l)
 		 );
 		"server/module", (fun hctx ->
 			let sign = hctx.display#get_sign in
@@ -288,9 +193,9 @@ let handler =
 			let m = try
 				CompilationServer.find_module hctx.display#get_cs (path,sign)
 			with Not_found ->
-				hctx.jsonrpc#send_error [jstring "No such module"]
+				hctx.send_error [jstring "No such module"]
 			in
-			hctx.jsonrpc#send_result (generate_module () m)
+			hctx.send_result (generate_module () m)
 		);
 		"server/files", (fun hctx ->
 			let sign = hctx.display#get_sign in
@@ -304,13 +209,13 @@ let handler =
 					"moduleName",jopt jstring cfile.c_module_name;
 				]
 			) files in
-			hctx.jsonrpc#send_result (jarray files)
+			hctx.send_result (jarray files)
 		);
 		"server/invalidate", (fun hctx ->
 			let file = hctx.jsonrpc#get_string_param "file" in
 			let file = Path.unique_full_path file in
 			CompilationServer.taint_modules hctx.display#get_cs file;
-			hctx.jsonrpc#send_result jnull
+			hctx.send_result jnull
 		);
 		"server/configure", (fun hctx ->
 			let l = ref (List.map (fun (name,value) ->
@@ -319,7 +224,7 @@ let handler =
 					ServerMessage.set_by_name name value;
 					jstring (Printf.sprintf "Printing %s %s" name (if value then "enabled" else "disabled"))
 				with Not_found ->
-					hctx.jsonrpc#send_error [jstring ("Invalid print parame name: " ^ name)]
+					hctx.send_error [jstring ("Invalid print parame name: " ^ name)]
 			) (hctx.jsonrpc#get_opt_param (fun () -> (hctx.jsonrpc#get_object_param "print")) [])) in
 			hctx.jsonrpc#get_opt_param (fun () ->
 				let b = hctx.jsonrpc#get_bool_param "noModuleChecks" in
@@ -327,7 +232,7 @@ let handler =
 				l := jstring ("Module checks " ^ (if b then "disabled" else "enabled")) :: !l;
 				()
 			) ();
-			hctx.jsonrpc#send_result (jarray !l)
+			hctx.send_result (jarray !l)
 		);
 	] in
 	List.iter (fun (s,f) -> Hashtbl.add h s f) l;
@@ -337,12 +242,34 @@ let parse_input com input report_times =
 	let input =
 		JsonRpc.handle_jsonrpc_error (fun () -> JsonRpc.parse_request input) send_json
 	in
-	let jsonrpc = new jsonrpc_handler report_times input in
-	com.json_out <- Some(jsonrpc#send_result,jsonrpc#send_error);
+	let jsonrpc = new jsonrpc_handler input in
+
+	let send_result json =
+		let fl = [
+			"result",json;
+			"timestamp",jfloat (Unix.gettimeofday ());
+		] in
+		let fl = if !report_times then begin
+			close_times();
+			let _,_,root = Timer.build_times_tree () in
+			begin match json_of_times root with
+			| None -> fl
+			| Some jo -> ("timers",jo) :: fl
+			end
+		end else fl in
+		let jo = jobject fl in
+		send_json (JsonRpc.result jsonrpc#get_id  jo)
+	in
+
+	let send_error jl =
+		send_json (JsonRpc.error jsonrpc#get_id 0 ~data:(Some (JArray jl)) "Compiler error")
+	in
+
+	com.json_out <- Some(send_result,send_error);
 
 	let cs = match CompilationServer.get() with
 		| Some cs -> cs
-		| None -> jsonrpc#send_error [jstring "compilation server not running for some reason"];
+		| None -> send_error [jstring "compilation server not running for some reason"];
 	in
 
 	let display = new display_handler jsonrpc com cs in
@@ -351,6 +278,8 @@ let parse_input com input report_times =
 		com = com;
 		jsonrpc = jsonrpc;
 		display = display;
+		send_result = send_result;
+		send_error = send_error;
 	} in
 
 	JsonRpc.handle_jsonrpc_error (fun () ->

src/core/json/jsonrpc_handler.ml

@@ -0,0 +1,81 @@
+open Json
+open JsonRpc
+
+type haxe_json_error =
+	| MissingField of string * string
+	| BadType of string * string
+
+class jsonrpc_handler (id,name,params) = object(self)
+	val id = id
+	val method_name : string = name
+	val params = match params with
+		| Some (JObject fl) -> fl
+		| Some json -> raise_invalid_params json
+		| None -> []
+
+	method get_id = id
+	method get_method_name = method_name
+
+	method raise_haxe_json_error : 'a . haxe_json_error -> 'a = function
+		| MissingField(name,on) -> raise_custom id 1 (Printf.sprintf "Missing param \"%s\" on \"%s\"" name on)
+		| BadType(desc,expected) -> raise_custom id 2 (Printf.sprintf "Unexpected value for \"%s\", expected %s" desc expected)
+
+	method get_field desc fl name : Json.t =
+		try
+			List.assoc name fl
+		with Not_found ->
+			self#raise_haxe_json_error (MissingField(name,desc))
+
+	method get_string desc j = match j with
+		| JString s -> s
+		| _ -> self#raise_haxe_json_error (BadType(desc,"String"))
+
+	method get_int desc j = match j with
+		| JInt i -> i
+		| _ -> self#raise_haxe_json_error (BadType(desc,"String"))
+
+	method get_bool desc j = match j with
+		| JBool b -> b
+		| _ -> self#raise_haxe_json_error (BadType(desc,"Bool"))
+
+	method get_array desc j : Json.t list = match j with
+		| JArray a -> a
+		| _ -> self#raise_haxe_json_error (BadType(desc,"Array"))
+
+	method get_object desc j = match j with
+		| JObject o -> o
+		| _ -> self#raise_haxe_json_error (BadType(desc,"Object"))
+
+	method get_string_field desc name fl =
+		self#get_string desc (self#get_field desc fl name)
+
+	method get_int_field desc name fl =
+		self#get_int desc (self#get_field desc fl name)
+
+	method get_bool_field desc name fl =
+		self#get_bool desc (self#get_field desc fl name)
+
+	method get_array_field desc name fl =
+		self#get_array desc (self#get_field desc fl name)
+
+	method get_object_field desc name fl =
+		self#get_object desc (self#get_field desc fl name)
+
+	method get_string_param name =
+		self#get_string_field "params" name params
+
+	method get_int_param name =
+		self#get_int_field "params" name params
+
+	method get_bool_param name =
+		self#get_bool_field "params" name params
+
+	method get_array_param name =
+		self#get_array_field "params" name params
+
+	method get_object_param name =
+		self#get_object_field "params" name params
+
+	method get_opt_param : 'a . (unit -> 'a) -> 'a -> 'a = fun f def ->
+		try f() with JsonRpc_error _ -> def
+end