From 67033aa70226d4c95efc2bc31fa295c4248b5c9f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Loi=CC=88c=20Correnson?= <loic.correnson@cea.fr>
Date: Wed, 17 Jun 2020 08:53:55 +0200
Subject: [PATCH] [server] functional API & enum lookup
---
src/plugins/server/data.ml | 74 +++++++++++++++++++++++++------
src/plugins/server/data.mli | 31 ++++++++++---
src/plugins/server/kernel_main.ml | 16 ++++---
3 files changed, 96 insertions(+), 25 deletions(-)
diff --git a/src/plugins/server/data.ml b/src/plugins/server/data.ml
index 8620eccd1a4..63744296bf4 100644
--- a/src/plugins/server/data.ml
+++ b/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) ;
diff --git a/src/plugins/server/data.mli b/src/plugins/server/data.mli
index 5bb3b13aff3..f63673c9a09 100644
--- a/src/plugins/server/data.mli
+++ b/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
diff --git a/src/plugins/server/kernel_main.ml b/src/plugins/server/kernel_main.ml
index 3fe87efe0b4..ad3e9fd94b8 100644
--- a/src/plugins/server/kernel_main.ml
+++ b/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"
--
GitLab