[server] cleaning usage of Json

src/plugins/server/data.ml

@@ -24,11 +24,11 @@
 (* --- Data Encoding                                                      --- *)
 (* -------------------------------------------------------------------------- *)
 
-module Json = Yojson.Basic
-module Jutil = Yojson.Basic.Util
+module Js = Yojson.Basic
+module Ju = Yojson.Basic.Util
 
-type json = Json.t
-let pretty = Json.pretty_print ~std:false
+type json = Js.t
+let pretty = Js.pretty_print ~std:false
 
 module type S =
 sig
@@ -47,7 +47,8 @@ end
 
 type 'a data = (module S with type t = 'a)
 
-let failure msg js = raise (Jutil.Type_error(msg,js))
+let failure js msg =
+  Pretty_utils.ksfprintf (fun msg -> raise(Ju.Type_error(msg,js))) msg
 
 (* -------------------------------------------------------------------------- *)
 (* --- Option                                                             --- *)
@@ -83,7 +84,7 @@ struct
   let to_json (x,y) = `List [ A.to_json x ; B.to_json y ]
   let of_json = function
     | `List [ ja ; jb ] -> A.of_json ja , B.of_json jb
-    | js -> raise (Jutil.Type_error( "Expected list with 2 elements" , js ))
+    | js -> failure js "Expected list with 2 elements"
 end
 
 module Jtriple(A : S)(B : S)(C : S) : S with type t = A.t * B.t * C.t =
@@ -93,7 +94,7 @@ struct
   let to_json (x,y,z) = `List [ A.to_json x ; B.to_json y ; C.to_json z ]
   let of_json = function
     | `List [ ja ; jb ; jc ] -> A.of_json ja , B.of_json jb , C.of_json jc
-    | js -> raise (Jutil.Type_error( "Expected list with 3 elements" , js ))
+    | js -> failure js "Expected list with 3 elements"
 end
 
 (* -------------------------------------------------------------------------- *)
@@ -105,7 +106,7 @@ struct
   type t = A.t list
   let syntax = Syntax.array A.syntax
   let to_json xs = `List (List.map A.to_json xs)
-  let of_json js = List.map A.of_json (Jutil.to_list js)
+  let of_json js = List.map A.of_json (Ju.to_list js)
 end
 
 (* -------------------------------------------------------------------------- *)
@@ -117,7 +118,7 @@ struct
   type t = A.t array
   let syntax = Syntax.array A.syntax
   let to_json xs = `List (List.map A.to_json (Array.to_list xs))
-  let of_json js = Array.of_list @@ List.map A.of_json (Jutil.to_list js)
+  let of_json js = Array.of_list @@ List.map A.of_json (Ju.to_list js)
 end
 
 (* -------------------------------------------------------------------------- *)
@@ -165,7 +166,7 @@ module Jbool : S_collection with type t = bool =
     (struct
       type t = bool
       let syntax = Syntax.boolean
-      let of_json = Jutil.to_bool
+      let of_json = Ju.to_bool
       let to_json b = `Bool b
     end)
 
@@ -174,7 +175,7 @@ module Jint : S_collection with type t = int =
     (struct
       type t = int
       let syntax = Syntax.int
-      let of_json = Jutil.to_int
+      let of_json = Ju.to_int
       let to_json n = `Int n
     end)
 
@@ -183,7 +184,7 @@ module Jfloat : S_collection with type t = float =
     (struct
       type t = float
       let syntax = Syntax.number
-      let of_json = Jutil.to_number
+      let of_json = Ju.to_number
       let to_json v = `Float v
     end)
 
@@ -192,7 +193,7 @@ module Jstring : S_collection with type t = string =
     (struct
       type t = string
       let syntax = Syntax.string
-      let of_json = Jutil.to_string
+      let of_json = Ju.to_string
       let to_json s = `String s
     end)
 
@@ -201,7 +202,7 @@ module Jident : S_collection with type t = string =
     (struct
       type t = string
       let syntax = Syntax.ident
-      let of_json = Jutil.to_string
+      let of_json = Ju.to_string
       let to_json s = `String s
     end)
 
@@ -274,7 +275,7 @@ struct
   let of_json js =
     List.fold_left
       (fun r (fd,js) -> Fmap.add fd js r)
-      (default ()) (Jutil.to_assoc js)
+      (default ()) (Ju.to_assoc js)
 
   let to_json r : json =
     `Assoc (Fmap.fold (fun fd js fds -> (fd,js) :: fds) r [])
@@ -350,11 +351,10 @@ struct
 
   let to_json m a = `Int (get m a)
   let of_json m js =
-    let id = Jutil.to_int js in
+    let id = Ju.to_int js in
     try find m id
     with Not_found ->
-      let msg = Printf.sprintf "[%s] No registered id #%d" I.name id in
-      raise (Jutil.Type_error(msg,js))
+      failure js "[%s] No registered id #%d" I.name id
 
 end
 
@@ -451,11 +451,9 @@ struct
         let syntax = publish_id (module A)
         let to_json a = `Int (get a)
         let of_json js =
-          let k = Jutil.to_int js in
+          let k = Ju.to_int js in
           try find k
-          with Not_found ->
-            let msg = Printf.sprintf "[%s] No registered id #%d" A.name k in
-            raise (Jutil.Type_error(msg,js))
+          with Not_found -> failure js "[%s] No registered id #%d" A.name k
       end)
 
 end
@@ -522,11 +520,11 @@ struct
 
         let of_json js =
           register () ;
-          let tag = Jutil.to_string js in
+          let tag = Ju.to_string js in
           try Hashtbl.find lookup tag
           with Not_found ->
             let msg = Printf.sprintf "[%s] Unregistered tag %S" E.name tag in
-            raise (Jutil.Type_error(msg,js))
+            raise (Ju.Type_error(msg,js))
 
       end)
 

src/plugins/server/data.mli

@@ -184,7 +184,7 @@ module Dictionary(E : Enum) : S_collection with type t = E.t
 (** {2 Misc} *)
 (* -------------------------------------------------------------------------- *)
 
-val failure : string -> json -> 'a
-(** @raise Yojson.Basic.Util.Type_error with the given arguments *)
+val failure : json -> ('a, Format.formatter, unit, 'b) format4 -> 'a
+(** @raise Yojson.Basic.Util.Type_error with provided message *)
 
 (* -------------------------------------------------------------------------- *)

src/plugins/server/doc.ml

@@ -24,6 +24,7 @@
 (* --- Server Documentation                                               --- *)
 (* -------------------------------------------------------------------------- *)
 
+type json = Yojson.Basic.t
 module Senv = Server_parameters
 module Pages = Map.Make(String)
 
@@ -127,8 +128,6 @@ let index () =
     (fun (title,entry) -> Markdown.href ~title entry)
     (List.sort (fun (a,_) (b,_) -> String.compare a b) !entries)
 
-type json = Json.t
-
 let link ~toc ~title ~href : json =
   let link = [ "title" , `String title ; "href" , `String href ] in
   `Assoc (if not toc then link else ( "toc" , `Bool true ) ::  link)

src/plugins/server/jbuffer.ml

@@ -20,7 +20,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
-type json = Json.t
+type json = Yojson.Basic.t
 
 type buffer = {
   text : FCBuffer.t ;

src/plugins/server/kernel_ast.ml

@@ -113,7 +113,7 @@ module Stmt = Data.Collection
           | PStmt(_,st) -> st
           | _ -> raise Not_found
         with Not_found ->
-          Data.failure "Unknown stmt id" js
+          Data.failure js "Unknown stmt id"
     end)
 
 module Ki = Data.Collection
@@ -138,7 +138,7 @@ module Kf = Data.Collection
         `String (Kernel_function.get_name kf)
       let of_json js =
         try Js.to_string js |> Globals.Functions.find_by_name
-        with Not_found -> Data.failure "Undefined function" js
+        with Not_found -> Data.failure js "Undefined function"
     end)
 
 (* -------------------------------------------------------------------------- *)

src/plugins/server/kernel_fc.ml

@@ -78,7 +78,7 @@ struct
     | `Assoc [ "file" , `String path ; "line" , `Int line ]
     | `Assoc [ "line" , `Int line ; "file" , `String path ]
       -> Log.source ~file:(Filepath.Normalized.of_string path) ~line
-    | js -> failure "Invalid source format" js
+    | js -> failure js "Invalid source format"
 
 end
 

src/plugins/server/main.ml

@@ -25,7 +25,6 @@
 (* -------------------------------------------------------------------------- *)
 
 module Senv = Server_parameters
-module Json = Yojson.Basic
 
 let option f = function None -> () | Some x -> f x
 

src/plugins/server/request.ml

@@ -176,13 +176,11 @@ type ('a,'b) signature = {
   mutable output : 'b rq_output ;
 }
 
-let failure_missing name fmap =
-  Data.failure
-    (Printf.sprintf "Missing parameter '%s'" name)
-    (fmap_to_json fmap)
+let failure_missing fmap name =
+  Data.failure (fmap_to_json fmap) "Missing parameter '%s'" name
 
 let check_required fmap fd =
-  if not (Fmap.mem fd fmap) then failure_missing fd fmap
+  if not (Fmap.mem fd fmap) then failure_missing fmap fd
 
 (* -------------------------------------------------------------------------- *)
 (* --- Named Input Parameters Definitions                                 --- *)
@@ -207,7 +205,7 @@ let param (type a b) (s : (unit,b) signature) ~name ~descr
     try D.of_json (Fmap.find name rq.param)
     with Not_found ->
     match default with
-    | None -> failure_missing name rq.param
+    | None -> failure_missing rq.param name
     | Some v -> v
 
 let param_opt (type a b) (s : (unit,b) signature) ~name ~descr

src/plugins/server/server_batch.ml

@@ -47,15 +47,15 @@ let _ = Doc.page `Protocol ~title:"Batch Protocol" ~filename:"server_batch.md"
 (* --- Execute JSON                                                       --- *)
 (* -------------------------------------------------------------------------- *)
 
-module Json = Yojson.Basic
-module Jutil = Yojson.Basic.Util
+module Js = Yojson.Basic
+module Ju = Yojson.Basic.Util
 
-let pretty = Json.pretty_print ~std:false
+let pretty = Js.pretty_print ~std:false
 
 let execute_command js =
-  let request = Jutil.member "request" js |> Jutil.to_string in
-  let id = Jutil.member "id" js in
-  let data = Jutil.member "data" js in
+  let request = Ju.member "request" js |> Ju.to_string in
+  let id = Ju.member "id" js in
+  let data = Ju.member "data" js in
   match Main.find request with
   | None ->
     Senv.error "[batch] %a: request %S not found" pretty id request ;
@@ -64,7 +64,7 @@ let execute_command js =
     try
       Senv.feedback "[%a] %s" Main.pp_kind kind request ;
       `Assoc [ "id" , id ; "data" , handler data ]
-    with Jutil.Type_error(msg,js) ->
+    with Ju.Type_error(msg,js) ->
       Senv.error "[%s] incorrect encoding:@\n%s@\n@[<hov 2>At: %a@]@."
         request msg pretty js ;
       `Assoc [ "id" , id ; "error" , `String msg ; "at" , js ]
@@ -75,7 +75,7 @@ let rec execute_batch js =
   | `List js -> `List (List.map execute_batch js)
   | js ->
     try execute_command js
-    with Jutil.Type_error(msg,js) ->
+    with Ju.Type_error(msg,js) ->
       Senv.error "[batch] incorrect encoding:@\n%s@\n@[<hov 2>At: %a@]@."
         msg pretty js ;
       `Null
@@ -89,10 +89,10 @@ let execute () =
     List.iter
       begin fun file ->
         Senv.feedback "Script %S" file ;
-        let response = execute_batch (Json.from_file file) in
+        let response = execute_batch (Js.from_file file) in
         let output = Filename.remove_extension file ^ ".out.js" in
         Senv.feedback "Output %S" output ;
-        Json.to_file output response ;
+        Js.to_file output response ;
       end
       (Batch.get()) ;
   end