[server] functional API & enum lookup

src/plugins/server/data.ml

@@ -39,8 +39,6 @@ sig
   val to_json : t -> json
 end
 
-type 'a data = (module S with type t = 'a)
-
 exception InputError of string
 
 let failure ?json msg =
@@ -228,6 +226,47 @@ struct
     datatype ~package ~name:"text" ~descr jdef
 end
 
+(* -------------------------------------------------------------------------- *)
+(* --- Functional API                                                     --- *)
+(* -------------------------------------------------------------------------- *)
+
+type 'a data = (module S with type t = 'a)
+
+let junit : unit data = (module Junit)
+let jany : json data = (module Jany)
+let jbool : bool data = (module Jbool)
+let jint : int data = (module Jint)
+let jfloat : float data = (module Jfloat)
+let jstring : string data = (module Jstring)
+
+let jkey ~kind =
+  let module JkeyKind =
+  struct
+    include Jstring
+    let jtype = Jkey kind
+  end in
+  (module JkeyKind : S with type t = string)
+
+let jindex ~kind =
+  let module JindexKind =
+  struct
+    include Jint
+    let jtype = Jindex kind
+  end in
+  (module JindexKind : S with type t = int)
+
+let joption (type a) (d : a data) : a option data =
+  let module A = Joption(val d) in
+  (module A : S with type t = a option)
+
+let jlist (type a) (d : a data) : a list data =
+  let module A = Jlist(val d) in
+  (module A : S with type t = a list)
+
+let jarray (type a) (d : a data) : a array data =
+  let module A = Jarray(val d) in
+  (module A : S with type t = a array)
+
 (* -------------------------------------------------------------------------- *)
 (* --- Records                                                            --- *)
 (* -------------------------------------------------------------------------- *)
@@ -377,6 +416,7 @@ struct
     mutable syntax : Markdown.text ;
     mutable published : (package * string) option ;
     mutable tags : tagInfo list ;
+    mutable lookup : ('a -> string) option ;
   }
 
   type 'a tag = string
@@ -393,6 +433,7 @@ struct
     vindex = Hashtbl.create 0 ;
     syntax = [] ;
     tags = [] ;
+    lookup = None ;
   }
 
   let tag ~name ?label ~descr ?value (d : 'a dictionary) : 'a tag =
@@ -411,8 +452,12 @@ struct
       | Some v -> Hashtbl.add d.vindex v name
     end ; name
 
-  let find_tag (d : 'a dictionary) name =
-    if Hashtbl.mem d.values name then name else raise Not_found
+  let find (d : 'a dictionary) name : 'a tag =
+    if Hashtbl.mem d.values name then name else
+      raise Not_found
+
+  let set_lookup (d : 'a dictionary) (tag : 'a -> 'a tag) =
+    d.lookup <- Some tag
 
   let instance_name = Printf.sprintf "%s:%s"
 
@@ -434,10 +479,16 @@ struct
         Package.update ~package ~name (D_enum (List.rev d.tags))
     ) ; name
 
-  let to_json name vindex v =
-    try `String (Hashtbl.find vindex v)
-    with Not_found ->
-      failure "[%s] Value not found" name
+  let to_json name lookup vindex v =
+    `String begin
+      try match lookup with
+        | None ->
+          Hashtbl.find vindex v
+        | Some f ->
+          try f v with Not_found -> Hashtbl.find vindex v
+      with Not_found ->
+        failure "[%s] Value not found" name
+    end
 
   let of_json name values js =
     let tag = Ju.to_string js in
@@ -450,7 +501,7 @@ struct
 
   let tags d = List.rev d.tags
 
-  let publish (type a) ~package ~name ~descr ?tag (d : a dictionary) =
+  let publish (type a) ~package ~name ~descr (d : a dictionary) =
     ( match d.published with
       | None -> ()
       | Some _ ->
@@ -463,10 +514,7 @@ struct
         let enums = D_enum (List.rev d.tags) in
         Jdata (Package.declare_id ~package ~name ~descr enums)
       let of_json = of_json name d.values
-      let to_json =
-        match tag with
-        | None -> to_json name d.vindex
-        | Some to_tag -> fun x -> `String (to_tag x)
+      let to_json = to_json name d.lookup d.vindex
     end in
     begin
       d.published <- Some (package,name) ;

src/plugins/server/data.mli

@@ -70,9 +70,6 @@ sig
   val to_json : t -> json
 end
 
-(** Polymorphic data value. *)
-type 'a data = (module S with type t = 'a)
-
 (** Of main kernel data. *)
 val package : package
 
@@ -113,6 +110,25 @@ module Jtriple(A : S)(B : S)(C : S) : S with type t = A.t * B.t * C.t
 module Jlist(A : S) : S with type t = A.t list
 module Jarray(A : S) : S with type t = A.t array
 
+(* -------------------------------------------------------------------------- *)
+(** {2 Functional API} *)
+(* -------------------------------------------------------------------------- *)
+
+(** Polymorphic data value. *)
+type 'a data = (module S with type t = 'a)
+
+val junit : unit data
+val jany : json data
+val jbool : bool data
+val jint : int data
+val jfloat : float data
+val jstring : string data
+val jindex : kind:string -> int data
+val jkey : kind:string -> string data
+val jlist : 'a data -> 'a list data
+val jarray : 'a data -> 'a array data
+val joption : 'a data -> 'a option data
+
 (* -------------------------------------------------------------------------- *)
 (** {2 Records} *)
 (* -------------------------------------------------------------------------- *)
@@ -229,7 +245,7 @@ sig
 
   (** Returns the tag from its name.
       @raise Not_found if no tag has been registered with this name. *)
-  val find_tag: 'a dictionary -> string -> 'a tag
+  val find: 'a dictionary -> string -> 'a tag
 
   (** Register a new prefix tag in the dictionary.
       The default label is the capitalized prefix.
@@ -258,12 +274,17 @@ sig
   (** Obtain all the tags registered in the dictionary so far. *)
   val tags : 'a dictionary -> Tag.t list
 
+  (** Set tagging function for values. If the lookup function
+      raises `Not_found`, the dictionary will use the tag associated
+      with the provided value, if any. *)
+  val set_lookup : 'a dictionary -> ('a -> 'a tag) -> unit
+
   (**
      Publish the dictionary. No more tag nor prefix can be added afterwards.
      If no [~tag] function is provided, the values registered with tags are used.
   *)
   val publish : package:package -> name:string -> descr:Markdown.text ->
-    ?tag:('a -> 'a tag) -> 'a dictionary -> (module S with type t = 'a)
+    'a dictionary -> (module S with type t = 'a)
 
 end
 

src/plugins/server/kernel_main.ml

@@ -129,13 +129,15 @@ module LogKind = Collection
       let t_failure = t_kind Log.Failure "FAILURE" "Plugin Failure"
       let t_debug = t_kind Log.Debug "DEBUG" "Analyser Debug"
 
-      let tag = function
-        | Log.Error -> t_error
-        | Log.Warning -> t_warning
-        | Log.Feedback -> t_feedback
-        | Log.Result -> t_result
-        | Log.Failure -> t_failure
-        | Log.Debug -> t_debug
+      let () = Enum.set_lookup kinds
+          begin function
+            | Log.Error -> t_error
+            | Log.Warning -> t_warning
+            | Log.Feedback -> t_feedback
+            | Log.Result -> t_result
+            | Log.Failure -> t_failure
+            | Log.Debug -> t_debug
+          end
 
       let data = Request.dictionary ~package
           ~name:"logkind"