From 3110035e348e636796051ae7417cf16bc3d6226c Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Loi=CC=88c=20Correnson?= <loic.correnson@cea.fr>
Date: Wed, 26 Feb 2020 17:11:21 +0100
Subject: [PATCH] [server] generator for enumerated values
Application to logs, properties kind & status
---
src/plugins/server/data.mli | 88 ++++++++---
src/plugins/server/kernel_ast.ml | 52 -------
src/plugins/server/kernel_main.ml | 42 ++++--
src/plugins/server/kernel_properties.ml | 186 +++++++++++++++++++-----
src/plugins/server/request.ml | 24 ++-
src/plugins/server/states.ml | 18 ++-
src/plugins/server/syntax.ml | 38 ++++-
src/plugins/server/syntax.mli | 16 +-
8 files changed, 321 insertions(+), 143 deletions(-)
diff --git a/src/plugins/server/data.mli b/src/plugins/server/data.mli
index eeda161e364..6950b98de51 100644
--- a/src/plugins/server/data.mli
+++ b/src/plugins/server/data.mli
@@ -94,10 +94,6 @@ module Jtext : S with type t = json (** Rich text encoding, see [Jbuffer] *)
(** {2 Records} *)
(* -------------------------------------------------------------------------- *)
-type 'a record (** Records of type 'a *)
-type 'a signature (** Opened signature for record of type ['a] *)
-type ('a,'b) field (** Field of type ['b] for a record of type ['a] *)
-
(** Record factory.
You shall start by declaring a (ghost) type [r] and call
@@ -122,6 +118,10 @@ type ('a,'b) field (** Field of type ['b] for a record of type ['a] *)
module Record :
sig
+ type 'a record (** Records of type 'a *)
+ type 'a signature (** Opened signature for record of type ['a] *)
+ type ('a,'b) field (** Field of type ['b] for a record of type ['a] *)
+
(** Data with [type t = r record].
Also contains getters and setters for fields. *)
module type S =
@@ -149,7 +149,72 @@ sig
('r,'a option) field
(** Publish and close an opened record *)
- val publish : 'a signature -> (module S with type r = 'a)
+ val publish : 'a signature ->
+ (module S with type r = 'a)
+
+end
+
+(* -------------------------------------------------------------------------- *)
+(** {2 Enums} *)
+(* -------------------------------------------------------------------------- *)
+
+(** Enum factory.
+
+ You shall start by declaring a dictionnary with
+ [Enum.dictionary] for your values.
+ Then, populate the dictionary with [Enum.tag] values.
+ Finally, you shall call [Enum.publish] to obtain a new data module
+ for your type.
+
+ You have two options for computing tags: either you provide values
+ when declaring tags, and these tags will be associated to registered
+ values for both directions;
+ alternatively you might provide a [~tag] function to [Enum.publish].
+
+ The difficulty when providing values only at tag definition is to ensure
+ that all possible value has been registered.
+
+ The conversion values from and to json may fail when no value has been
+ registered with tags.
+*)
+
+module Enum :
+sig
+
+ type 'a dictionary
+ type 'a tag
+ type 'a prefix = string -> 'a tag
+
+ val name : 'a tag -> string
+
+ (** Creates an opened, empty dictionnary. *)
+ val dictionary :
+ page:Doc.page -> name:string -> descr:Markdown.text ->
+ unit -> 'a dictionary
+
+ (** Register a new tag in the dictionnary.
+ The provided value, if any, will be used for decoding json tags.
+ If would be used also for encoding values to json tags if no [~tag]
+ function is provided when publishing the dictionnary.
+ Registered values must be hashable with [Hashtbl.hash] function. *)
+ val tag : 'a dictionary ->
+ name:string -> descr:Markdown.text -> ?value:'a ->
+ unit -> 'a tag
+
+ (** Register a new prefix tag in the dictionnary.
+ To decoding from json is provided to prefix tags.
+ Encoding is done by emitting tags with form ['prefix:*'].
+ The variable part of the prefix is documented as ['prefix:xxx']
+ when [~var:"xxx"] is provided. *)
+ val prefix : 'a dictionary ->
+ prefix:string -> ?var:string -> descr:Markdown.text -> unit -> 'a prefix
+
+ (** Publish the dictionnary. To more tag nor prefix can be added after.
+ If no [~tag] function is provided, registered values with tags
+ are used. *)
+ val publish : 'a dictionary ->
+ ?tag:('a -> 'a tag) ->
+ unit -> (module S with type t = 'a)
end
@@ -196,19 +261,6 @@ end
(** Builds a {i projectified} index on types with {i unique} identifiers *)
module Identified(A : IdentifiedType) : Index with type t = A.t
-(* -------------------------------------------------------------------------- *)
-(** {2 Dictionary} *)
-(* -------------------------------------------------------------------------- *)
-
-module type Enum =
-sig
- type t
- val values : (t * string * Markdown.text) list
- include Info
-end
-
-module Dictionary(E : Enum) : S_collection with type t = E.t
-
(* -------------------------------------------------------------------------- *)
(** {2 Error handling} *)
(* -------------------------------------------------------------------------- *)
diff --git a/src/plugins/server/kernel_ast.ml b/src/plugins/server/kernel_ast.ml
index 915f9e124e7..3861b8cfc8e 100644
--- a/src/plugins/server/kernel_ast.ml
+++ b/src/plugins/server/kernel_ast.ml
@@ -163,58 +163,6 @@ let () = Request.register ~page
~input:(module Kf) ~output:(module Jtext)
(fun kf -> Jbuffer.to_json PP.pp_global (Kernel_function.get_global kf))
-(* -------------------------------------------------------------------------- *)
-(* --- Properties --- *)
-(* -------------------------------------------------------------------------- *)
-
-module Property = struct
- type p
- let signature =
- Record.signature ~page ~name:"property"
- ~descr:(Md.plain "logical property") ()
-
- let name = Record.field signature ~name:"name"
- ~descr:(Md.plain "name") (module Jstring)
- let property = Record.field signature ~name:"property"
- ~descr:(Md.plain "logical property") (module Jstring)
- let status = Record.field signature ~name:"status"
- ~descr:(Md.plain "logical status") (module Jstring)
- let file = Record.field signature ~name:"file"
- ~descr:(Md.plain "file") (module Jstring)
- let kf = Record.field signature ~name:"function"
- ~descr:(Md.plain "kernel function") (module Kf.Joption)
- let kinstr = Record.field signature ~name:"kinstr"
- ~descr:(Md.plain "kinstr") (module Ki)
-
- module R = (val (Record.publish signature) : Record.S with type r = p)
- include R
-
- let make ip =
- let st = Property_status.Feedback.get ip in
- let st = Format.asprintf "%a" Property_status.Feedback.pretty st in
- let p = Format.asprintf "%a" Property.pretty ip in
- let loc = Property.location ip in
- let path = Filepath.(Normalized.to_pretty_string (fst loc).pos_path) in
- default |> set property p |> set status st
- |> set kf (Property.get_kf ip)
- |> set kinstr (Property.get_kinstr ip)
- |> set name (Property.Names.get_prop_name_id ip)
- |> set file path
-end
-
-let get_properties () =
- Property_status.fold (fun ip acc -> Property.make ip :: acc) []
-
-let () =
- Request.register
- ~page
- ~kind:`GET
- ~name:"kernel.ast.getProperties"
- ~descr:(Md.plain "Collect all logical properties")
- ~input:(module Junit)
- ~output:(module Jlist (Property))
- get_properties
-
(* -------------------------------------------------------------------------- *)
(* --- Files --- *)
(* -------------------------------------------------------------------------- *)
diff --git a/src/plugins/server/kernel_main.ml b/src/plugins/server/kernel_main.ml
index 22866e37d79..28e9a6574f0 100644
--- a/src/plugins/server/kernel_main.ml
+++ b/src/plugins/server/kernel_main.ml
@@ -110,21 +110,35 @@ module LogSource = Collection(RawSource)
module RawKind =
struct
- type t = Log.kind
- let page = page
- let name = "kind"
- let descr = Md.plain "Frama-C message category."
- let values = [
- Log.Error, "ERROR", Md.plain "User Error" ;
- Log.Warning, "WARNING", Md.plain "User Warning" ;
- Log.Feedback, "FEEDBACK", Md.plain "Analyzer Feedback" ;
- Log.Result, "RESULT", Md.plain "Analyzer Result" ;
- Log.Failure, "FAILURE", Md.plain "Analyzer Failure" ;
- Log.Debug, "DEBUG", Md.plain "Analyser Debug" ;
- ]
+ let kinds = Enum.dictionary ~page
+ ~name:"kind"
+ ~descr:(Md.plain "Frama-C message category.")
+ ()
+
+ let t_kind value name descr =
+ Enum.tag kinds ~name ~descr:(Md.plain descr) ~value ()
+
+ let t_error = t_kind Log.Error "ERROR" "User Error"
+ let t_warning = t_kind Log.Warning "WARNING" "User Warning"
+ let t_feedback = t_kind Log.Feedback "FEEDBACK" "Plugin Feedback"
+ let t_result = t_kind Log.Result "RESULT" "Plugin Result"
+ 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 data = Enum.publish kinds ~tag ()
+
+ include (val data : S with type t = Log.kind)
end
-module LogKind = Dictionary(RawKind)
+module LogKind = Collection(RawKind)
(* -------------------------------------------------------------------------- *)
(* --- Log Events --- *)
@@ -135,7 +149,7 @@ struct
type rlog
- let jlog : rlog signature = Record.signature ~page
+ let jlog : rlog Record.signature = Record.signature ~page
~name:"log" ~descr:(Md.plain "Message event record.") ()
let kind = Record.field jlog ~name:"kind"
diff --git a/src/plugins/server/kernel_properties.ml b/src/plugins/server/kernel_properties.ml
index bc5461a2585..fe71601a655 100644
--- a/src/plugins/server/kernel_properties.ml
+++ b/src/plugins/server/kernel_properties.ml
@@ -36,43 +36,159 @@ let page = Doc.page `Kernel ~title:"Property Services" ~filename:"properties.md"
module PropKind =
struct
- type t = string
- let syntax = Sy.publish ~page
+ let kinds = Enum.dictionary ~page
~name:"propkind"
~descr:(Md.plain "Property Kind")
- ~synopsis:Sy.string ()
+ ()
+
+ let t_kind name descr = Enum.tag kinds ~name ~descr:(Md.plain descr) ()
+ let t_clause name = t_kind name (Printf.sprintf "Clause `@%s`" name)
+ let t_loop name =
+ t_kind ("loop-" ^ name) (Printf.sprintf "Clause `@loop %s`" name)
+
+ let t_behavior = t_kind "behavior" "Contract behavior"
+ let t_complete = t_kind "complete" "Complete behaviors clause"
+ let t_disjoint = t_kind "disjoint" "Disjoint behaviors clause"
+
+ let t_assumes = t_clause "assumes"
+ let t_requires = t_clause "requires"
+ let t_breaks = t_clause "breaks"
+ let t_continues = t_clause "continues"
+ let t_returns = t_clause "returns"
+ let t_exits = t_clause "exits"
+ let t_ensures = t_clause "ensures"
+ let t_terminates = t_clause "terminates"
+ let t_allocates = t_clause "allocates"
+ let t_decreases = t_clause "decreases"
+ let t_assigns = t_clause "assigns"
+ let t_froms = t_kind "froms" "Clause `@assigns … \\from …`"
+ let t_ext = Enum.prefix kinds ~prefix:"ext" ~var:"<clause>"
+ ~descr:(Md.plain "ACSL extension `<clause>`") ()
+
+ let t_assert = t_clause "assert"
+ let t_loop_invariant = t_loop "invariant"
+ let t_loop_assigns = t_loop "assigns"
+ let t_loop_variant = t_loop "variant"
+ let t_loop_allocates = t_loop "allocates"
+ let t_loop_pragma = t_loop "pragma"
+ let t_loop_ext = Enum.prefix kinds ~prefix:"loop-ext" ~var:"<clause>"
+ ~descr:(Md.plain "ACSL loop extension `loop <clause>`") ()
+
+ let t_reachable = t_kind "reachable" "Reachable statement"
+ let t_code_contract = t_kind "code-contract" "Statement Contract"
+ let t_code_invariant = t_kind "code-invariant" "Generalized loop invariant"
+ let t_type_invariant = t_kind "type-invariant" "Type invariant"
+ let t_global_invariant = t_kind "global-invariant" "Global invariant"
+
+ let t_axiomatic = t_kind "axiomatic" "Axiomatic definitions"
+ let t_axiom = t_kind "axiom" "Logical axiom"
+ let t_lemma = t_kind "lemma" "Logical lemma"
+ let t_other = Enum.prefix kinds ~prefix:"prop" ~var:"<prop>"
+ ~descr:(Md.plain "Plugin Specific properties") ()
+
open Property
- let kind = function
- | IPPredicate _ -> "predicate"
- | IPExtended { ie_ext={ ext_name } } -> ext_name
- | IPAxiomatic _ -> "axiomatic"
- | IPAxiom _ -> "axiom"
- | IPLemma _ -> "lemma"
- | IPBehavior _ -> "behavior"
- | IPComplete _ -> "complete"
- | IPDisjoint _ -> "disjoint"
+
+ let rec tag = function
+ | IPPredicate { ip_kind } ->
+ begin match ip_kind with
+ | PKRequires _ -> t_requires
+ | PKAssumes _ -> t_assumes
+ | PKEnsures(_,Normal) -> t_ensures
+ | PKEnsures(_,Exits) -> t_exits
+ | PKEnsures(_,Breaks) -> t_breaks
+ | PKEnsures(_,Continues) -> t_continues
+ | PKEnsures(_,Returns) -> t_returns
+ | PKTerminates -> t_terminates
+ end
+ | IPExtended { ie_ext={ ext_name } } -> t_ext ext_name
+ | IPAxiomatic _ -> t_axiomatic
+ | IPAxiom _ -> t_axiom
+ | IPLemma _ -> t_lemma
+ | IPBehavior _ -> t_behavior
+ | IPComplete _ -> t_complete
+ | IPDisjoint _ -> t_disjoint
| IPCodeAnnot { ica_ca={ annot_content } } ->
begin match annot_content with
- | AAssert _ -> "assert"
- | AStmtSpec _ -> "stmt-contract"
- | AInvariant(_,false,_) -> "code-invariant"
- | AInvariant(_,true,_) -> "loop-invariant"
- | AVariant _ -> "loop-variant"
- | AAssigns _ -> "loop-assigns"
- | AAllocation _ -> "loop-allocatation"
- | APragma _ -> "loop-pragma"
- | AExtended(_,_,{ext_name}) -> "loop-" ^ ext_name
+ | AAssert _ -> t_assert
+ | AStmtSpec _ -> t_code_contract
+ | AInvariant(_,false,_) -> t_code_invariant
+ | AInvariant(_,true,_) -> t_loop_invariant
+ | AVariant _ -> t_loop_variant
+ | AAssigns _ -> t_loop_assigns
+ | AAllocation _ -> t_loop_allocates
+ | APragma _ -> t_loop_pragma
+ | AExtended(_,_,{ext_name}) -> t_loop_ext ext_name
end
- | IPAllocation _ -> "allocation"
- | IPAssigns _ -> "assigns"
- | IPFrom _ -> "froms"
- | IPDecrease _ -> "decrease"
- | IPReachable _ -> "reachable"
- | IPPropertyInstance _ -> "instance"
- | IPTypeInvariant _ -> "type-invariant"
- | IPGlobalInvariant _ -> "invariant"
- | IPOther { io_name } -> io_name
- let to_json = Jstring.to_json
+ | IPAllocation _ -> t_allocates
+ | IPAssigns _ -> t_assigns
+ | IPFrom _ -> t_froms
+ | IPDecrease _ -> t_decreases
+ | IPReachable _ -> t_reachable
+ | IPPropertyInstance { ii_ip } -> tag ii_ip
+ | IPTypeInvariant _ -> t_type_invariant
+ | IPGlobalInvariant _ -> t_global_invariant
+ | IPOther { io_name } -> t_other io_name
+
+
+ let data = Enum.publish kinds ~tag ()
+
+ include (val data : S with type t = Property.t)
+end
+
+(* -------------------------------------------------------------------------- *)
+(* --- Property Status --- *)
+(* -------------------------------------------------------------------------- *)
+
+module PropStatus =
+struct
+
+ let status = Enum.dictionary ~page ~name:"status"
+ ~descr:(Md.plain "Property Status (consolidated)") ()
+
+ let t_status value name descr =
+ Enum.tag status ~name ~descr:(Md.plain descr) ~value ()
+
+ open Property_status.Feedback
+
+ let t_unknown =
+ t_status Unknown "unknown" "Unknown status"
+ let t_never_tried =
+ t_status Never_tried "never-tried" "Unknown status (never tried)"
+ let t_inconsistent =
+ t_status Inconsistent "inconsistent" "Inconsistent status"
+ let t_valid =
+ t_status Valid "valid" "Valid property"
+ let t_valid_under_hyp =
+ t_status Valid_under_hyp "valid_under_hyp" "Valid (under hypotheses)"
+ let t_considered_valid =
+ t_status Considered_valid "considered_valid" "Valid (external assumption)"
+ let t_invalid =
+ t_status Invalid "invalid" "Invalid property (counter example found)"
+ let t_invalid_under_hyp =
+ t_status Invalid_under_hyp "invalid_under_hyp" "Invalid property (under hypotheses)"
+ let t_invalid_but_dead =
+ t_status Invalid_but_dead "invalid_but_dead" "Dead property (but invalid)"
+ let t_valid_but_dead =
+ t_status Valid_but_dead "valid_but_dead" "Dead property (but valid)"
+ let t_unknown_but_dead =
+ t_status Unknown_but_dead "unknown_but_dead" "Dead property (but unknown)"
+
+ let tag = function
+ | Valid -> t_valid
+ | Invalid -> t_invalid
+ | Unknown -> t_unknown
+ | Never_tried -> t_never_tried
+ | Valid_under_hyp -> t_valid_under_hyp
+ | Valid_but_dead -> t_valid_but_dead
+ | Considered_valid -> t_considered_valid
+ | Invalid_under_hyp -> t_invalid_under_hyp
+ | Invalid_but_dead -> t_invalid_but_dead
+ | Unknown_but_dead -> t_unknown_but_dead
+ | Inconsistent -> t_inconsistent
+
+ let data = Enum.publish status ~tag ()
+
+ include (val data : S with type t = Property_status.Feedback.t)
end
(* -------------------------------------------------------------------------- *)
@@ -89,14 +205,12 @@ let () = States.column ~model ~name:"descr"
let () = States.column ~model ~name:"kind"
~descr:(Md.plain "Kind")
~data:(module PropKind)
- ~get:(PropKind.kind) ()
+ ~get:(fun ip -> ip) ()
let () = States.column ~model ~name:"status"
~descr:(Md.plain "Status")
- ~data:(module Jstring)
- ~get:(fun ip ->
- let st = Property_status.Feedback.get ip
- in Format.asprintf "%a" Property_status.Feedback.pretty st) ()
+ ~data:(module PropStatus)
+ ~get:(Property_status.Feedback.get) ()
let () = States.column ~model ~name:"function"
~descr:(Md.plain "Function")
diff --git a/src/plugins/server/request.ml b/src/plugins/server/request.ml
index 19dc53b676b..ebd45441bbc 100644
--- a/src/plugins/server/request.ml
+++ b/src/plugins/server/request.ml
@@ -205,7 +205,11 @@ let param (type a b) (s : (unit,b) signature) ~name ~descr
?default (input : a input) : a param =
let module D = (val input) in
let syntax = if default = None then D.syntax else Syntax.option D.syntax in
- let fd = Syntax.{ name ; syntax ; descr } in
+ let fd = Syntax.{
+ fd_name = name ;
+ fd_syntax = syntax ;
+ fd_descr = descr ;
+ } in
s.input <- Pfields (fd :: fds_input s) ;
fun rq ->
try D.of_json (Fmap.find name rq.param)
@@ -217,7 +221,11 @@ let param (type a b) (s : (unit,b) signature) ~name ~descr
let param_opt (type a b) (s : (unit,b) signature) ~name ~descr
(input : a input) : a option param =
let module D = (val input) in
- let fd = Syntax.{ name ; syntax = Syntax.option D.syntax ; descr } in
+ let fd = Syntax.{
+ fd_name = name ;
+ fd_syntax = Syntax.option D.syntax ;
+ fd_descr = descr ;
+ } in
s.input <- Pfields (fd :: fds_input s) ;
fun rq ->
try Some(D.of_json (Fmap.find name rq.param))
@@ -238,7 +246,11 @@ let fds_output s : Syntax.field list =
let result (type a b) (s : (a,unit) signature) ~name ~descr
?default (output : b output) : b result =
let module D = (val output) in
- let fd = Syntax.{ name ; syntax = D.syntax ; descr } in
+ let fd = Syntax.{
+ fd_name = name ;
+ fd_syntax = D.syntax ;
+ fd_descr = descr ;
+ } in
s.output <- Rfields (fd :: fds_output s) ;
begin
match default with
@@ -250,7 +262,11 @@ let result (type a b) (s : (a,unit) signature) ~name ~descr
let result_opt (type a b) (s : (a,unit) signature) ~name ~descr
(output : b output) : b option result =
let module D = (val output) in
- let fd = Syntax.{ name ; syntax = option D.syntax ; descr } in
+ let fd = Syntax.{
+ fd_name = name ;
+ fd_syntax = option D.syntax ;
+ fd_descr = descr ;
+ } in
s.output <- Rfields (fd :: fds_output s) ;
fun rq opt ->
match opt with None -> () | Some v ->
diff --git a/src/plugins/server/states.ml b/src/plugins/server/states.ml
index 7ba8567e3ee..2cbb15085cd 100644
--- a/src/plugins/server/states.ml
+++ b/src/plugins/server/states.ml
@@ -98,9 +98,13 @@ let column (type a b) ~(model : a model) ~name ~descr
let module D = (val data) in
if name = "key" || name = "index" then
raise (Invalid_argument "Server.States.column: invalid name") ;
- if List.exists (fun (fd,_) -> fd.Syntax.name = name) !model then
+ if List.exists (fun (fd,_) -> fd.Syntax.fd_name = name) !model then
raise (Invalid_argument "Server.States.column: duplicate name") ;
- let fd = Syntax.{ name ; syntax = D.syntax ; descr } in
+ let fd = Syntax.{
+ fd_name = name ;
+ fd_syntax = D.syntax ;
+ fd_descr = descr ;
+ } in
model := (fd , fun a -> D.to_json (get a)) :: !model
module Kmap = Map.Make(String)
@@ -257,12 +261,12 @@ let register_array ~page ~name ~descr ?(details=[]) ~key
let columns = !model in
let description = [
Block [Text descr] ;
- Syntax.fields ~title:(Printf.sprintf "Array %s" name)
+ Syntax.fields ~title:"Columns"
begin
Syntax.{
- name="key" ;
- syntax=Syntax.ident ;
- descr=plain "entry identifier" ;
+ fd_name = "key" ;
+ fd_syntax = Syntax.ident ;
+ fd_descr = plain "entry identifier" ;
} :: List.rev (List.map fst columns)
end ;
Block details
@@ -270,7 +274,7 @@ let register_array ~page ~name ~descr ?(details=[]) ~key
let mref = Doc.publish ~page:page ~name:name ~title ~index description [] in
let signal = Request.signal ~page ~name:(name ^ ".sig")
~descr:(plain "Signal for array " @ href mref) () in
- let getter = List.map (fun (fd,to_js) -> fd.Syntax.name , to_js) columns in
+ let getter = List.map Syntax.(fun (fd,to_js) -> fd.fd_name , to_js) columns in
let array = {
key ; iter ; getter ; signal ;
current = None ; projects = Hashtbl.create 0
diff --git a/src/plugins/server/syntax.ml b/src/plugins/server/syntax.ml
index bfc7218a57a..7c7a4778f4b 100644
--- a/src/plugins/server/syntax.ml
+++ b/src/plugins/server/syntax.ml
@@ -74,6 +74,8 @@ let publish ~page ~name ~descr ~synopsis ?(details = []) () =
let _href = Doc.publish ~page ~name:id ~title ~index content [] in
atom dlink
+(* -------------------------------------------------------------------------- *)
+
let unit = atom @@ Markdown.plain "-"
let any = atom @@ Markdown.emph "any"
let int = atom @@ Markdown.emph "int"
@@ -101,30 +103,50 @@ let union ts = flow @@ Markdown.(glue ~sep:(plain "|") (List.map protect ts))
let option t = atom @@ Markdown.(protect t @ code "?")
-let field (a,t) = Markdown.( escaped a @ code ":" @ t.text )
+(* -------------------------------------------------------------------------- *)
+
+type tag = {
+ tag_name : string ;
+ tag_descr : Markdown.text ;
+}
+
+let tags ?(title="Tag") (tgs : tag list) =
+ let open Markdown in
+ let header = [
+ plain title, Left;
+ plain "Description", Left
+ ] in
+ let row tg = [ escaped tg.tag_name ; tg.tag_descr ] in
+ Markdown.Table {
+ caption = None ; header ; content = List.map row tgs ;
+ }
+
+(* -------------------------------------------------------------------------- *)
+
+let mfield (a,t) = Markdown.( escaped a @ code ":" @ t.text )
let record fds =
let fields =
if fds = [] then Markdown.plain "…" else
- Markdown.(glue ~sep:(code ";") (List.map field fds))
+ Markdown.(glue ~sep:(code ";") (List.map mfield fds))
in atom @@ Markdown.(code "{" @ fields @ code "}")
type field = {
- name : string ;
- syntax : t ;
- descr : Markdown.text ;
+ fd_name : string ;
+ fd_syntax : t ;
+ fd_descr : Markdown.text ;
}
-let fields ~title (fds : field list) =
+let fields ?(title="Field") (fds : field list) =
let open Markdown in
let header = [
plain title, Left;
plain "Format", Center;
plain "Description", Left
] in
- let column f = [ code f.name ; f.syntax.text ; f.descr ] in
+ let row f = [ code f.fd_name ; f.fd_syntax.text ; f.fd_descr ] in
Markdown.Table {
- caption = None ; header ; content = List.map column fds ;
+ caption = None ; header ; content = List.map row fds ;
}
(* -------------------------------------------------------------------------- *)
diff --git a/src/plugins/server/syntax.mli b/src/plugins/server/syntax.mli
index 1080751de02..b5f0367df2d 100644
--- a/src/plugins/server/syntax.mli
+++ b/src/plugins/server/syntax.mli
@@ -51,10 +51,18 @@ val option : t -> t
val record : (string * t) list -> t
val data : string -> Markdown.href -> t
-type field = { name : string ; syntax : t ; descr : Markdown.text }
+type tag = { tag_name : string ; tag_descr : Markdown.text }
-(** Builds a table with fields column named with [~title]
- (shall be capitalized) *)
-val fields : title:string -> field list -> Markdown.element
+(** Builds a table with tags description.
+ The [~title] is applied to the tag name column
+ (shall be capitalized, defaults to ["Tag"]). *)
+val tags : ?title:string -> tag list -> Markdown.element
+
+type field = { fd_name : string ; fd_syntax : t ; fd_descr : Markdown.text }
+
+(** Builds a table with fields description.
+ The [~title] is applied to the field name column
+ (shall be capitalized, defaults to ["Field"]). *)
+val fields : ?title:string -> field list -> Markdown.element
(* -------------------------------------------------------------------------- *)
--
GitLab