diff --git a/src/plugins/server/data.ml b/src/plugins/server/data.ml
index 10a7eef47743d582d6e0075dc82de2759b6a995b..1a0f56ec23f196813d20c0d2c49e9c815731e17e 100644
--- a/src/plugins/server/data.ml
+++ b/src/plugins/server/data.ml
@@ -38,6 +38,14 @@ sig
val to_json : t -> json
end
+module type Info =
+sig
+ val name : string
+ val descr : Markdown.text
+end
+
+type 'a data = (module S with type t = 'a)
+
let d_tuple ts = Markdown.(tt "[" <+> glue ~sep:(raw " `,` ") ts <+> tt "]")
let d_record txt = Markdown.(tt "{" <+> txt <+> tt "}")
let d_array txt = Markdown.(tt "[" <+> txt <+> tt ",…]")
@@ -45,210 +53,75 @@ let d_option txt = Markdown.(txt <@> tt "?")
let failure msg js = raise (Jutil.Type_error(msg,js))
-(* -------------------------------------------------------------------------- *)
-(* --- Field --- *)
-(* -------------------------------------------------------------------------- *)
-
-type 'a field = {
- name: string ;
- field: Markdown.text ;
- default: Markdown.text option ;
- descr: Markdown.text ;
- optional: bool ;
- get: ('a -> json option) option ;
- set: ('a -> json -> 'a) option ;
-}
-
-module type S_field =
-sig
- include S
-
- val mk_field :
- name:string ->
- optional:bool ->
- ?default:Markdown.text ->
- descr:Markdown.text ->
- ?get:('a -> t option) ->
- ?set:('a -> t -> 'a) ->
- unit -> 'a field
-
- val field :
- name:string ->
- descr:string ->
- ('a -> t) ->
- ('a -> t -> 'a) ->
- 'a field
-
- val option :
- name:string ->
- ?default:string ->
- descr:string ->
- ('a -> t option) ->
- ('a -> t -> 'a) ->
- 'a field
-
- val getter :
- name:string ->
- descr:string ->
- ('a -> t) ->
- 'a field
-
- val getopt :
- name:string ->
- ?default:string ->
- descr:string ->
- ('a -> t option) ->
- 'a field
-
- val setter :
- name:string ->
- descr:string ->
- ('a -> t -> 'a) ->
- 'a field
-
- val setopt :
- name:string ->
- ?default:string ->
- descr:string ->
- ('a -> t -> 'a) ->
- 'a field
-
-end
-
-module Field(A : S) : S_field with type t = A.t =
-struct
- include A
-
- let opt f = function None -> None | Some x -> Some (f x)
-
- let mk_field ~name ~optional ?default ~descr ?get ?set () =
- begin match get , set with
- | None , None ->
- raise (Invalid_argument "Server.Data.field: no setter and no getter")
- | _ -> ()
- end ;
- {
- name ; optional ; default ; descr ;
- field = A.descr ;
- set = opt (fun f data js -> f data (A.of_json js)) set ;
- get = opt (fun f data -> opt A.to_json (f data)) get ;
- }
-
- let field ~name ~descr get set =
- mk_field ~name
- ~descr:(Markdown.rm descr)
- ~optional:false
- ~get:(fun d -> Some (get d)) ~set ()
-
- let option ~name ?default ~descr get set =
- mk_field ~name
- ~descr:(Markdown.rm descr)
- ?default:(opt Markdown.rm default)
- ~optional:true
- ~get ~set ()
-
- let getter ~name ~descr get =
- mk_field ~name
- ~optional:false
- ~descr:(Markdown.rm descr)
- ~get:(fun d -> Some (get d)) ()
-
- let setter ~name ~descr set =
- mk_field ~name
- ~optional:false
- ~descr:(Markdown.rm descr)
- ~set ()
-
- let getopt ~name ?default ~descr get =
- mk_field ~name
- ~optional:true
- ?default:(opt Markdown.rm default)
- ~descr:(Markdown.rm descr)
- ~get ()
-
- let setopt ~name ?default ~descr set =
- mk_field ~name
- ~optional:true
- ?default:(opt Markdown.rm default)
- ~descr:(Markdown.rm descr)
- ~set ()
-
-end
-
(* -------------------------------------------------------------------------- *)
(* --- Option --- *)
(* -------------------------------------------------------------------------- *)
-module Joption(A : S) : S_field with type t = A.t option =
- Field
- (struct
- type t = A.t option
+module Joption(A : S) : S with type t = A.t option =
+struct
+ type t = A.t option
- let nullable = try ignore (A.of_json `Null) ; true with _ -> false
- let descr = d_option (if nullable then A.descr else d_tuple [A.descr])
+ let nullable = try ignore (A.of_json `Null) ; true with _ -> false
+ let descr = d_option (if nullable then A.descr else d_tuple [A.descr])
- let to_json = function
- | None -> `Null
- | Some v -> if nullable then `List [A.to_json v] else A.to_json v
+ let to_json = function
+ | None -> `Null
+ | Some v -> if nullable then `List [A.to_json v] else A.to_json v
- let of_json = function
- | `Null -> None
- | `List [js] when nullable -> Some (A.of_json js)
- | js -> Some (A.of_json js)
+ let of_json = function
+ | `Null -> None
+ | `List [js] when nullable -> Some (A.of_json js)
+ | js -> Some (A.of_json js)
- end)
+end
(* -------------------------------------------------------------------------- *)
(* --- Tuples --- *)
(* -------------------------------------------------------------------------- *)
-module Jpair(A : S)(B : S) : S_field with type t = A.t * B.t =
- Field
- (struct
- type t = A.t * B.t
- let descr = d_tuple [A.descr;B.descr]
- 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 ))
- end)
+module Jpair(A : S)(B : S) : S with type t = A.t * B.t =
+struct
+ type t = A.t * B.t
+ let descr = d_tuple [A.descr;B.descr]
+ 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 ))
+end
-module Jtriple(A : S)(B : S)(C : S) : S_field with type t = A.t * B.t * C.t =
- Field
- (struct
- type t = A.t * B.t * C.t
- let descr = d_tuple [A.descr;B.descr;C.descr]
- 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 ))
- end)
+module Jtriple(A : S)(B : S)(C : S) : S with type t = A.t * B.t * C.t =
+struct
+ type t = A.t * B.t * C.t
+ let descr = d_tuple [A.descr;B.descr;C.descr]
+ 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 ))
+end
(* -------------------------------------------------------------------------- *)
(* --- Lists --- *)
(* -------------------------------------------------------------------------- *)
-module Jlist(A : S) : S_field with type t = A.t list =
- Field
- (struct
- type t = A.t list
- let descr = d_array A.descr
- let to_json xs = `List (List.map A.to_json xs)
- let of_json js = List.map A.of_json (Jutil.to_list js)
- end)
+module Jlist(A : S) : S with type t = A.t list =
+struct
+ type t = A.t list
+ let descr = d_array A.descr
+ let to_json xs = `List (List.map A.to_json xs)
+ let of_json js = List.map A.of_json (Jutil.to_list js)
+end
(* -------------------------------------------------------------------------- *)
(* --- Arrays --- *)
(* -------------------------------------------------------------------------- *)
-module Jarray(A : S) : S_field with type t = A.t array =
- Field
- (struct
- type t = A.t array
- let descr = d_array A.descr
- 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)
- end)
+module Jarray(A : S) : S with type t = A.t array =
+struct
+ type t = A.t array
+ let descr = d_array A.descr
+ 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)
+end
(* -------------------------------------------------------------------------- *)
(* --- Collections --- *)
@@ -256,15 +129,15 @@ module Jarray(A : S) : S_field with type t = A.t array =
module type S_collection =
sig
- include S_field
- module Joption : S_field with type t = t option
- module Jlist : S_field with type t = t list
- module Jarray : S_field with type t = t array
+ include S
+ module Joption : S with type t = t option
+ module Jlist : S with type t = t list
+ module Jarray : S with type t = t array
end
module Collection(A : S) : S_collection with type t = A.t =
struct
- include Field(A)
+ include A
module Joption = Joption(A)
module Jlist = Jlist(A)
module Jarray = Jarray(A)
@@ -282,14 +155,13 @@ struct
let to_json () = `Null
end
-module Jany : S_field with type t = json =
- Field
- (struct
- type t = json
- let descr = Markdown.it "any"
- let of_json js = js
- let to_json js = js
- end)
+module Jany : S with type t = json =
+struct
+ type t = json
+ let descr = Markdown.it "any"
+ let of_json js = js
+ let to_json js = js
+end
module Jbool : S_collection with type t = bool =
Collection
@@ -339,111 +211,87 @@ end
(* --- Records --- *)
(* -------------------------------------------------------------------------- *)
-module Record =
+module Fmap = Map.Make(String)
+
+module Record( R : Info ) =
struct
- type 'a record = 'a field list
+ type t = json Fmap.t
+ let descr = Markdown.it R.name
- let descr_table
+ type 'a field = {
+ member : t -> bool ;
+ getter : t -> 'a ;
+ setter : t -> 'a -> t ;
+ }
+
+ (* Declared Fields in this Record *)
+ let fdocs = ref []
+ let defaults = ref Fmap.empty
+
+ let default () = !defaults
+ let has fd r = fd.member r
+ let get fd r = fd.getter r
+ let set fd v r = fd.setter r v
+
+ let field (type a) name ~descr ?default (d : a data) : a field =
+ let module D = (val d) in
+ let def = match default with
+ | None -> None
+ | Some v ->
+ let jd = D.to_json v in
+ defaults := Fmap.add name jd !defaults ; Some jd
+ in fdocs := (name , D.descr , def , descr) :: !fdocs ;
+ let member r = Fmap.mem name r in
+ let getter r = D.of_json (Fmap.find name r) in
+ let setter r v = Fmap.add name (D.to_json v) r in
+ { member ; getter ; setter }
+
+ let option (type a) name ~descr (d : a data) : a option field =
+ let module D = (val d) in
+ fdocs := (name , d_option D.descr , None , descr) :: !fdocs ;
+ let member r = Fmap.mem name r in
+ let getter r =
+ try Some (D.of_json (Fmap.find name r)) with Not_found -> None in
+ let setter r = function
+ | None -> Fmap.remove name r
+ | Some v -> Fmap.add name (D.to_json v) r in
+ { member ; getter ; setter }
+
+ let details
?(field=`Center "Field")
?(format=`Center "Format")
?(default=`Center "Default")
?(descr=`Left "Description")
- ?(filter=(fun _ -> true))
- record =
- let defs = ref false in
- let fields = List.filter
- (fun fd ->
- if filter fd then
- ((if fd.default<>None then defs := true) ; true)
- else false)
- record in
- if fields = [] then Markdown.empty else
- let typ fd = if fd.optional then d_option fd.field else fd.field in
- if !defs then
- let def = function None -> Markdown.rm "" | Some text -> text in
- Markdown.table
- [ field ; format ; default ; descr ]
- (List.map
- (fun fd -> [
- Markdown.tt fd.name ;
- typ fd ;
- def fd.default ;
- fd.descr ;
- ])
- fields)
- else
- Markdown.table
- [ field ; format ; descr ]
- (List.map
- (fun fd -> [ Markdown.tt fd.name ; typ fd ; fd.descr ])
- fields)
-
- let rec getters = function
- | { name ; optional ; get = Some f } :: fds ->
- (name,optional,f) :: getters fds
- | _ :: fds -> getters fds
- | [] -> []
-
- let rec setters = function
- | { name ; optional ; set = Some f } :: fds ->
- (name,optional,f) :: setters fds
- | _ :: fds -> setters fds
- | [] -> []
-
- let parser stage index default setters =
- let values = Array.make (Array.length stage) None in
- List.iter
- (fun (fd,js) ->
- try
- let i = Hashtbl.find index fd in
- if values.(i) = None then
- failure (Printf.sprintf "Duplicate field %S" fd) js ;
- values.(i) <- Some js ;
- with Not_found ->
- failure (Printf.sprintf "Unexpected field %S" fd) js
- ) setters ;
- let value = ref default in
- Array.iteri
- (fun i (name,required,set) ->
- match values.(i) with
- | None ->
- if required then
- failwith (Printf.sprintf "Missing field %S" name)
- | Some js -> value := set !value js
- ) stage ;
- !value
-
- let of_json record =
- let stage = Array.of_list (setters record) in
- let index = Hashtbl.create (Array.length stage) in
- Array.iteri
- (fun i (name,_,_) ->
- if Hashtbl.mem index name then
- raise (Invalid_argument
- "Server.Data.Record.compile: duplicate field") ;
- Hashtbl.add index name i)
- stage ;
- fun default json ->
- match json with
- | `Null -> default
- | `Assoc fields ->
- begin
- try parser stage index default fields
- with Failure msg -> failure msg json
- end
- | js -> failure "Record expected" js
-
- let formatter data (name,_optional,f) fds =
- match f data with
- | None -> fds
- | Some js -> (name,js) :: fds
-
- let to_json record =
- let printer = getters record in
- fun data ->
- let fields = List.fold_right (formatter data) printer [] in
- if fields = [] then `Null else `Assoc fields
+ ()
+ =
+ if Fmap.is_empty !defaults then
+ Markdown.table [ field ; format ; descr ]
+ (List.map
+ (fun (fd,fmt,_def,descr) -> [ Markdown.tt fd ; fmt ; descr ])
+ !fdocs)
+ else
+ let mk_format def fmt = if def <> None then d_option fmt else fmt in
+ let mk_default = function
+ | None -> Markdown.text []
+ | Some js -> Markdown.tt (Json.to_string js) in
+ Markdown.table [ field ; format ; default ; descr ]
+ (List.map
+ (fun (fd,fmt,def,descr) -> [
+ Markdown.tt fd ;
+ mk_format def fmt ;
+ mk_default def ;
+ descr ;
+ ])
+ !fdocs)
+
+ let of_json js =
+ List.fold_left
+ (fun r (fd,js) -> Fmap.add fd js r)
+ (default ()) (Jutil.to_assoc js)
+
+ let to_json r : json =
+ `Assoc (Fmap.fold (fun fd js fds -> (fd,js) :: fds) r [])
end
@@ -461,12 +309,6 @@ sig
val find : key -> 'a t -> 'a
end
-module type IndexInfo =
-sig
- val name : string
- val descr : Markdown.text
-end
-
module type Index =
sig
include S_collection
@@ -475,7 +317,7 @@ sig
val clear : unit -> unit
end
-module INDEXER(M : Map)(I : IndexInfo) :
+module INDEXER(M : Map)(I : Info) :
sig
type index
val create : unit -> index
@@ -526,7 +368,7 @@ struct
end
-module Static(M : Map)(I : IndexInfo) : Index with type t = M.key =
+module Static(M : Map)(I : Info) : Index with type t = M.key =
struct
module INDEX = INDEXER(M)(I)
let index = INDEX.create ()
@@ -542,7 +384,7 @@ struct
end)
end
-module Index(M : Map)(I : IndexInfo) : Index with type t = M.key =
+module Index(M : Map)(I : Info) : Index with type t = M.key =
struct
module INDEX = INDEXER(M)(I)
@@ -582,8 +424,7 @@ module type IdentifiedType =
sig
type t
val id : t -> int
- val name : string
- val descr : Markdown.text
+ include Info
end
module Identified(A : IdentifiedType) : Index with type t = A.t =
@@ -635,9 +476,8 @@ end
module type Enum =
sig
type t
- val name : string
- val descr : Markdown.text
val values : (t * string * Markdown.text) list
+ include Info
end
module Dictionary(E : Enum) :
diff --git a/src/plugins/server/data.mli b/src/plugins/server/data.mli
index 761b3aeee892697b57a11bbb3c9525cb94433a6b..5650d886ab60249e0842f15819c0abd47c9e079d 100644
--- a/src/plugins/server/data.mli
+++ b/src/plugins/server/data.mli
@@ -36,166 +36,89 @@ sig
val to_json : t -> json
end
-(* -------------------------------------------------------------------------- *)
-(** {2 Collections} *)
-(* -------------------------------------------------------------------------- *)
-
-(** Record field specification. *)
-type 'a field = {
-
- name: string ; (** Name of JSON field *)
- field: Markdown.text ; (** Format of JSON field *)
- default: Markdown.text option ; (** Description of the field default *)
- descr: Markdown.text ; (** Description of the JSON field *)
-
- optional: bool ; (** Whether the field is optional or not *)
-
- get: ('a -> json option) option ;
- (** Accessor for building the « field » value from type ['a], if
- to be including in the output. *)
-
- set: ('a -> json -> 'a) option ;
- (** Updater for some under-construction « record » value of type ['a]
- with the field value. *)
-
-}
-
-module type S_field =
+module type Info =
sig
- include S
+ val name : string
+ val descr : Markdown.text
+end
- (** Generic field build.
- At least one of [~get] or [~set] shall be specified. *)
- val mk_field :
- name:string ->
- optional:bool ->
- ?default:Markdown.text ->
- descr:Markdown.text ->
- ?get:('a -> t option) ->
- ?set:('a -> t -> 'a) ->
- unit -> 'a field
-
- (** Helper for simple (required) field *)
- val field :
- name:string ->
- descr:string ->
- ('a -> t) ->
- ('a -> t -> 'a) ->
- 'a field
-
- (** Helper for simple (optional) field *)
- val option :
- name:string ->
- ?default:string ->
- descr:string ->
- ('a -> t option) ->
- ('a -> t -> 'a) ->
- 'a field
-
- (** Helper for simple fields with only a getter. *)
- val getter :
- name:string ->
- descr:string ->
- ('a -> t) ->
- 'a field
-
- (** Helper for simple fields with only an optional getter. *)
- val getopt :
- name:string ->
- ?default:string ->
- descr:string ->
- ('a -> t option) ->
- 'a field
-
- (** Helper for simple fields with only a (required) setter. *)
- val setter :
- name:string ->
- descr:string ->
- ('a -> t -> 'a) ->
- 'a field
-
- (** Helper for simple fields with only a (required) setter. *)
- val setopt :
- name:string ->
- ?default:string ->
- descr:string ->
- ('a -> t -> 'a) ->
- 'a field
+type 'a data = (module S with type t = 'a)
-end
+(* -------------------------------------------------------------------------- *)
+(** {2 Collections} *)
+(* -------------------------------------------------------------------------- *)
module type S_collection =
sig
- include S_field
- module Joption : S_field with type t = t option
- module Jlist : S_field with type t = t list
- module Jarray : S_field with type t = t array
+ include S
+ module Joption : S with type t = t option
+ module Jlist : S with type t = t list
+ module Jarray : S with type t = t array
end
-module Field(A : S) : S_field with type t = A.t
module Collection(A : S) : S_collection with type t = A.t
(* -------------------------------------------------------------------------- *)
(** {2 Constructors} *)
(* -------------------------------------------------------------------------- *)
-module Joption(A : S) : S_field with type t = A.t option
-module Jpair(A : S)(B : S) : S_field with type t = A.t * B.t
-module Jtriple(A : S)(B : S)(C : S) : S_field with type t = A.t * B.t * C.t
-module Jlist(A : S) : S_field with type t = A.t list
-module Jarray(A : S) : S_field with type t = A.t array
+module Joption(A : S) : S with type t = A.t option
+module Jpair(A : S)(B : S) : S with type t = A.t * B.t
+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 Atomic Data} *)
(* -------------------------------------------------------------------------- *)
module Junit : S with type t = unit
-module Jany : S_field with type t = json
+module Jany : S with type t = json
module Jbool : S_collection with type t = bool
module Jint : S_collection with type t = int
module Jfloat : S_collection with type t = float
module Jstring : S_collection with type t = string
-module Jtext : S_field with type t = json
+module Jtext : S with type t = json
(** Rich text encoding, see [Jbuffer] *)
(* -------------------------------------------------------------------------- *)
-(** {2 Record Helper} *)
+(** {2 Records} *)
(* -------------------------------------------------------------------------- *)
-module Record :
+module Record(R : Info) :
sig
+ (** A new type [t] is created for each application of the functor. *)
+ include S
- (** Ordered collection of fields to finally build values of type ['a] *)
- type 'a record = 'a field list
-
- (** Create a parser of JSON records from the specification.
- Each field setter is applied in its order of declaration.
- Extra fields or missing required ones leads to errors. *)
- val of_json : 'a record -> ('a -> json -> 'a)
-
- (** Create a formatter into JSON records from the specification.
- Each field getter is applied when specified. *)
- val to_json : 'a record -> ('a -> json)
-
- (** Output a description table for the field specification.
- Options allow to configure the columns of the table, and the rows to
- be printed.
- - [~field] is the field name column title (defaults to [`Center "Field"])
- - [~format] is the field format column title (defaults to [`Center "Format"])
- - [~default] if an optional column title for defaults (defaults to [`Center "Default"])
- - [~descr] is the field description title (defaults to [`Left "Description"])
- - [~filter] is an optional filer over field specifications
-
- The [default] column is discarded if none of the filtered field has
- a default description. The output is [Markdown.empty] if all fields are
- filtered out. *)
- val descr_table :
+ (** Parametric field. Can only be used with type [t]. *)
+ type 'a field
+
+ (** Field constructor *)
+ val field : string -> descr:Markdown.text -> ?default:'a -> 'a data -> 'a field
+
+ (** Optional field constructor *)
+ val option : string -> descr:Markdown.text -> 'a data -> 'a option field
+
+ (** Field presence. If the field has a default value, it will be always
+ present. *)
+ val has : 'a field -> t -> bool
+
+ (** Field accessor.
+ @raise Not_found if the field is optional and not present *)
+ val get : 'a field -> t -> 'a
+
+ (** Field updator. *)
+ val set : 'a field -> 'a -> t -> t
+
+ (** Contains only the default values. *)
+ val default : unit -> t
+
+ val details :
?field:Markdown.column ->
?format:Markdown.column ->
?default:Markdown.column ->
?descr:Markdown.column ->
- ?filter:('a field -> bool) ->
- 'a record -> Markdown.block
+ unit -> Markdown.block
end
@@ -213,12 +136,6 @@ sig
val find : key -> 'a t -> 'a
end
-module type IndexInfo =
-sig
- val name : string
- val descr : Markdown.text (** Actually an integer JSON *)
-end
-
module type Index =
sig
include S_collection
@@ -229,10 +146,10 @@ sig
end
(** Builds an indexer that {i does not} depend on current project. *)
-module Static(M : Map)(I : IndexInfo) : Index with type t = M.key
+module Static(M : Map)(I : Info) : Index with type t = M.key
(** Builds a {i projectified} index. *)
-module Index(M : Map)(I : IndexInfo) : Index with type t = M.key
+module Index(M : Map)(I : Info) : Index with type t = M.key
(* -------------------------------------------------------------------------- *)
(** {2 Identified Types} *)
@@ -256,9 +173,9 @@ module Identified(A : IdentifiedType) : Index with type t = A.t
module type Enum =
sig
type t
+ val values : (t * string * Markdown.text) list
val name : string
val descr : Markdown.text
- val values : (t * string * Markdown.text) list
end
module Dictionary(E : Enum) :
diff --git a/src/plugins/server/kernel_fc.ml b/src/plugins/server/kernel_fc.ml
index 2ef1873d5588525a089a9cfe6c3adb1dbad2c510..51bac5783330bd87adc44fce39e773454cf1a39b 100644
--- a/src/plugins/server/kernel_fc.ml
+++ b/src/plugins/server/kernel_fc.ml
@@ -40,27 +40,22 @@ struct
type t = unit
let descr = Markdown.tt "{ … }"
- let version =
- Jstring.getter ~name:"version" ~descr:"Frama-C version"
- (fun () -> Config.version)
-
- let datadir =
- Jstring.getter ~name:"datadir" ~descr:"Shared directory (FRAMAC_SHARE)"
- (fun () -> Config.datadir)
-
- let libdir =
- Jstring.getter ~name:"libdir" ~descr:"Lib directory (FRAMAC_LIB)"
- (fun () -> Config.datadir)
-
- let pluginpath =
- Jstring.Jlist.getter ~name:"pluginpath"
- ~descr:"Plugin directories (FRAMAC_PLUGIN)"
- (fun () -> Config.plugin_dir)
+ let to_json () = `Assoc [
+ "version" , Jstring.to_json Config.version ;
+ "datadir" , Jstring.to_json Config.datadir ;
+ "libdir" , Jstring.to_json Config.libdir ;
+ "pluginpath" , Jstring.Jlist.to_json Config.plugin_dir ;
+ ]
- let record = [ version ; datadir ; libdir ; pluginpath ]
+ let details =
+ let open Markdown in
+ table [ `Left "field" ; `Left "format" ; `Left "Description" ] [
+ [ tt "'version'" ; Jstring.descr ; rm "Frama-C version" ] ;
+ [ tt "'datadir'" ; Jstring.descr ; rm "Shared directory (FRAMAC_SHARE)" ] ;
+ [ tt "'libdir'" ; Jstring.descr ; rm "Lib directory (FRAMAC_LIB)" ] ;
+ [ tt "'pluginpath'" ; Jstring.Jlist.descr ; rm "Plugin directories (FRAMAC_PLUGIN)" ] ;
+ ]
- let to_json = Data.Record.to_json record
- let details = Data.Record.descr_table record
end
module GetConfig =
@@ -143,44 +138,48 @@ end
module RawEvent =
struct
- let kind = LogKind.field ~name:"kind" ~descr:"Message kind"
- Log.(fun evt -> evt.evt_kind)
- Log.(fun evt evt_kind -> { evt with evt_kind })
-
- let plugin = Jstring.field ~name:"plugin" ~descr:"Emitter plugin"
- Log.(fun evt -> evt.evt_plugin)
- Log.(fun evt evt_plugin -> { evt with evt_plugin })
+ module R = Record
+ (struct
+ let name = "log"
+ let descr = Markdown.href (Doc.href fc_page "log")
+ end)
- let category = Jstring.option ~name:"category"
- ~descr:"Message category (DEBUG or WARNING)"
- Log.(fun evt -> evt.evt_category)
- Log.(fun evt a -> { evt with evt_category = Some a })
+ let descr = Markdown.rm
- let source = LogSource.option ~name:"source" ~descr:"Source file position"
- Log.(fun evt -> evt.evt_source)
- Log.(fun evt s -> { evt with evt_source = Some s })
+ let kind = R.field "kind" ~descr:(descr "Message kind") (module LogKind)
+ let plugin = R.field "plugin" ~descr:(descr "Emitter plugin") (module Jstring)
+ let message = R.field "message" ~descr:(descr "Message text") (module Jstring)
- let message = Jstring.field ~name:"message" ~descr:"Message text"
- Log.(fun evt -> evt.evt_message)
- Log.(fun evt evt_message -> { evt with evt_message })
+ let category = R.option "category"
+ ~descr:(descr "Message category (DEBUG or WARNING)")
+ (module Jstring)
- let record = [ kind ; plugin ; category ; source ; message ]
+ let source = R.option "source" ~descr:(descr "Source file position")
+ (module LogSource)
type t = Log.event
- let default = Log.{
- evt_plugin = "" ;
- evt_kind = Feedback ;
- evt_category = None ;
- evt_source = None ;
- evt_message = "" ;
+ let to_json evt =
+ R.default () |>
+ R.set plugin evt.Log.evt_plugin |>
+ R.set kind evt.Log.evt_kind |>
+ R.set category evt.Log.evt_category |>
+ R.set source evt.Log.evt_source |>
+ R.set message evt.Log.evt_message |>
+ R.to_json
+
+ let of_json js =
+ let r = R.of_json js in
+ {
+ Log.evt_plugin = R.get plugin r ;
+ Log.evt_kind = R.get kind r ;
+ Log.evt_category = R.get category r ;
+ Log.evt_source = R.get source r ;
+ Log.evt_message = R.get message r ;
}
- let to_json = Record.to_json record
- let of_json = Record.of_json record default
-
let descr = Markdown.href (Doc.href fc_page "log")
- let details = Record.descr_table record
+ let details = R.details ()
end