From 81f5294528839e69cf8e779da9f27cd439790553 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Loi=CC=88c=20Correnson?= <loic.correnson@cea.fr>
Date: Thu, 14 Mar 2019 11:16:30 +0100
Subject: [PATCH] [server] new API for a better formatting doc
Incomplete : request API must also change
---
headers/header_spec.txt | 2 +
src/libraries/utils/markdown.ml | 3 +-
src/libraries/utils/markdown.mli | 3 +-
src/plugins/server/Makefile.in | 4 +-
src/plugins/server/data.ml | 95 +++++++++++----------
src/plugins/server/data.mli | 32 ++------
src/plugins/server/doc.ml | 4 +-
src/plugins/server/kernel_ast.ml | 12 ++-
src/plugins/server/kernel_fc.ml | 51 +++++-------
src/plugins/server/kernel_project.ml | 10 ++-
src/plugins/server/request.ml | 7 +-
src/plugins/server/request.mli | 4 +-
src/plugins/server/server_parameters.ml | 3 +
src/plugins/server/server_parameters.mli | 3 +
src/plugins/server/syntax.ml | 100 +++++++++++++++++++++++
src/plugins/server/syntax.mli | 51 ++++++++++++
16 files changed, 261 insertions(+), 123 deletions(-)
create mode 100644 src/plugins/server/syntax.ml
create mode 100644 src/plugins/server/syntax.mli
diff --git a/headers/header_spec.txt b/headers/header_spec.txt
index 1d49abd4f76..58a70c59b00 100644
--- a/headers/header_spec.txt
+++ b/headers/header_spec.txt
@@ -1037,6 +1037,8 @@ src/plugins/server/server_parameters.ml: CEA_LGPL_OR_PROPRIETARY
src/plugins/server/server_parameters.mli: CEA_LGPL_OR_PROPRIETARY
src/plugins/server/server_batch.ml: CEA_LGPL_OR_PROPRIETARY
src/plugins/server/server_zmq.ml: CEA_LGPL_OR_PROPRIETARY
+src/plugins/server/syntax.ml: CEA_LGPL_OR_PROPRIETARY
+src/plugins/server/syntax.mli: CEA_LGPL_OR_PROPRIETARY
src/plugins/scope/Scope.mli: CEA_LGPL_OR_PROPRIETARY
src/plugins/scope/datascope.ml: CEA_LGPL_OR_PROPRIETARY
src/plugins/scope/datascope.mli: CEA_LGPL_OR_PROPRIETARY
diff --git a/src/libraries/utils/markdown.ml b/src/libraries/utils/markdown.ml
index 9876f81458a..2a5d1ec1656 100644
--- a/src/libraries/utils/markdown.ml
+++ b/src/libraries/utils/markdown.ml
@@ -89,6 +89,7 @@ let fmt_block k fmt = Format.fprintf fmt "@[<v 0>%t@]" k
(* --- Elementary Text --- *)
(* -------------------------------------------------------------------------- *)
+let praw s fmt = Format.pp_print_string fmt s
let raw s fmt = Format.pp_print_string fmt s
let rm s fmt = Format.pp_print_string fmt s
let it s fmt = Format.fprintf fmt "_%s_" s
@@ -197,7 +198,7 @@ let enum ws fmt =
List.iter
(fun w -> incr k ; Format.fprintf fmt "@[<hov 3>%d. %t@]@." !k w) ws
-let descr items fmt =
+let description items fmt =
List.iter
(fun (a,w) -> Format.fprintf fmt "@[<hov 2>- **%s** %t@]@." a w) items
diff --git a/src/libraries/utils/markdown.mli b/src/libraries/utils/markdown.mli
index b3c687ef80f..31fb5e003f6 100644
--- a/src/libraries/utils/markdown.mli
+++ b/src/libraries/utils/markdown.mli
@@ -67,9 +67,10 @@ val in_h3 : block -> block (** Increment title levels by 3 *)
val in_h4 : block -> block (** Increment title levels by 4 *)
val par : text -> block (** Simple text paragraph *)
+val praw : string -> block (** Simple raw paragraph *)
val list : text list -> block (** Itemized list *)
val enum : text list -> block (** Enumerated list *)
-val descr : (string * text) list -> block (** Description list *)
+val description : (string * text) list -> block (** Description list *)
(** Formatted code.
diff --git a/src/plugins/server/Makefile.in b/src/plugins/server/Makefile.in
index e0bfbdbcf55..e63c2cf6b00 100644
--- a/src/plugins/server/Makefile.in
+++ b/src/plugins/server/Makefile.in
@@ -43,7 +43,7 @@ PLUGIN_REQUIRES:= yojson
PLUGIN_CMO:= \
server_parameters \
jbuffer \
- doc data main request \
+ doc syntax data main request \
server_batch \
kernel_fc \
kernel_project \
@@ -74,7 +74,7 @@ include $(FRAMAC_SHARE)/Makefile.dynamic
# --------------------------------------------------------------------------
SERVER_API= \
- doc.mli data.mli request.mli
+ doc.mli syntax.mli data.mli request.mli
define Capitalize
$(shell printf "%s%s" \
diff --git a/src/plugins/server/data.ml b/src/plugins/server/data.ml
index ad5a6ca7502..16fa1dfe42f 100644
--- a/src/plugins/server/data.ml
+++ b/src/plugins/server/data.ml
@@ -33,24 +33,20 @@ let pretty = Json.pretty_print ~std:false
module type S =
sig
type t
- val descr : Markdown.text
+ val syntax : Syntax.t
val of_json : json -> t
val to_json : t -> json
end
module type Info =
sig
+ val page : Doc.page
val name : string
- val descr : Markdown.text
+ val descr : Markdown.block
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 ",…]")
-let d_option txt = Markdown.(txt <@> tt "?")
-
let failure msg js = raise (Jutil.Type_error(msg,js))
(* -------------------------------------------------------------------------- *)
@@ -62,7 +58,8 @@ 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 syntax =
+ Syntax.option (if nullable then A.syntax else Syntax.tuple [A.syntax])
let to_json = function
| None -> `Null
@@ -82,7 +79,7 @@ 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 syntax = Syntax.tuple [A.syntax;B.syntax]
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
@@ -92,7 +89,7 @@ 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 syntax = Syntax.tuple [A.syntax;B.syntax;C.syntax]
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
@@ -106,7 +103,7 @@ 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 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)
end
@@ -118,7 +115,7 @@ 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 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)
end
@@ -150,7 +147,7 @@ end
module Junit : S with type t = unit =
struct
type t = unit
- let descr = Markdown.tt "null"
+ let syntax = Syntax.null
let of_json _js = ()
let to_json () = `Null
end
@@ -158,7 +155,7 @@ end
module Jany : S with type t = json =
struct
type t = json
- let descr = Markdown.it "any"
+ let syntax = Syntax.any
let of_json js = js
let to_json js = js
end
@@ -167,7 +164,7 @@ module Jbool : S_collection with type t = bool =
Collection
(struct
type t = bool
- let descr = Markdown.it "bool"
+ let syntax = Syntax.boolean
let of_json = Jutil.to_bool
let to_json b = `Bool b
end)
@@ -176,7 +173,7 @@ module Jint : S_collection with type t = int =
Collection
(struct
type t = int
- let descr = Markdown.it "int"
+ let syntax = Syntax.int
let of_json = Jutil.to_int
let to_json n = `Int n
end)
@@ -185,7 +182,7 @@ module Jfloat : S_collection with type t = float =
Collection
(struct
type t = float
- let descr = Markdown.it "number"
+ let syntax = Syntax.number
let of_json = Jutil.to_number
let to_json v = `Float v
end)
@@ -194,7 +191,7 @@ module Jstring : S_collection with type t = string =
Collection
(struct
type t = string
- let descr = Markdown.it "string"
+ let syntax = Syntax.string
let of_json = Jutil.to_string
let to_json s = `String s
end)
@@ -204,7 +201,8 @@ let text_page = Doc.page `Kernel ~title:"Rich Text Format" ~filename:"text.md"
module Jtext =
struct
include Jany
- let descr = Markdown.href ~title:"text" (`Page (Doc.path text_page))
+ let syntax = Syntax.publish text_page ~name:"text"
+ ~synopsis:Syntax.any ~descr:(Markdown.praw "Formatted text.")
end
(* -------------------------------------------------------------------------- *)
@@ -217,7 +215,6 @@ module Record( R : Info ) =
struct
type t = json Fmap.t
- let descr = Markdown.it R.name
type 'a field = {
member : t -> bool ;
@@ -241,7 +238,7 @@ struct
| 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 ;
+ in fdocs := (name , D.syntax , 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
@@ -249,7 +246,7 @@ struct
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 ;
+ fdocs := (name , Syntax.option D.syntax , 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
@@ -258,33 +255,35 @@ struct
| 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")
- ()
- =
+ let fields () =
+ let field = `Center "Field" in
+ let format = `Center "Format" in
+ let default = `Center "Default" in
+ let descr = `Left "Description" in
if Fmap.is_empty !defaults then
Markdown.table [ field ; format ; descr ]
(List.map
- (fun (fd,fmt,_def,descr) -> [ Markdown.tt fd ; fmt ; descr ])
+ (fun (fd,sy,_def,descr) ->
+ [ Markdown.tt fd ; Syntax.format sy ; descr ])
!fdocs)
else
- let mk_format def fmt = if def <> None then d_option fmt else fmt in
+ let mk_syntax def sy = if def <> None then Syntax.option sy else sy 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) -> [
+ (fun (fd,sy,def,descr) -> [
Markdown.tt fd ;
- mk_format def fmt ;
- mk_default def ;
- descr ;
+ Syntax.format @@ mk_syntax def sy ;
+ mk_default def ; descr ;
])
!fdocs)
+ let syntax =
+ let descr = Markdown.( R.descr </> mk_block fields ) in
+ Syntax.publish R.page ~name:R.name ~synopsis:(Syntax.record []) ~descr
+
let of_json js =
List.fold_left
(fun r (fd,js) -> Fmap.add fd js r)
@@ -317,6 +316,9 @@ sig
val clear : unit -> unit
end
+let publish_id (module A : Info) =
+ Syntax.publish A.page ~name:A.name ~synopsis:Syntax.int ~descr:A.descr
+
module INDEXER(M : Map)(I : Info) :
sig
type index
@@ -378,7 +380,7 @@ struct
include Collection
(struct
type t = M.key
- let descr = I.descr
+ let syntax = publish_id (module I)
let of_json = INDEX.of_json index
let to_json = INDEX.to_json index
end)
@@ -413,7 +415,7 @@ struct
include Collection
(struct
type t = M.key
- let descr = I.descr
+ let syntax = publish_id (module I)
let of_json js = INDEX.of_json (index()) js
let to_json v = INDEX.to_json (index()) v
end)
@@ -457,7 +459,7 @@ struct
include Collection
(struct
type t = A.t
- let descr = A.descr
+ let syntax = publish_id (module A)
let to_json a = `Int (get a)
let of_json js =
let k = Jutil.to_int js in
@@ -480,14 +482,7 @@ sig
include Info
end
-module Dictionary(E : Enum) :
-sig
- val descr_table :
- ?tag:Markdown.column ->
- ?descr:Markdown.column ->
- unit -> Markdown.block
- include S_collection with type t = E.t
-end =
+module Dictionary(E : Enum) =
struct
let registered = ref false
@@ -512,9 +507,9 @@ struct
) E.values
end
- let descr_table ?(tag=`Center E.name) ?(descr=`Left "Description") () =
+ let values () =
Markdown.table
- [ tag ; descr ]
+ [ `Center E.name ; `Left "Description" ]
(List.map
(fun (_,tag,descr) ->
[ Markdown.tt (Printf.sprintf "%S" tag) ; descr ]
@@ -524,7 +519,9 @@ struct
(struct
type t = E.t
- let descr = E.descr
+ let syntax = Syntax.publish E.page ~name:E.name
+ ~synopsis:Syntax.ident
+ ~descr:Markdown.( E.descr </> mk_block values )
let to_json value =
register () ;
diff --git a/src/plugins/server/data.mli b/src/plugins/server/data.mli
index a05c50891a6..a1249aebd48 100644
--- a/src/plugins/server/data.mli
+++ b/src/plugins/server/data.mli
@@ -31,15 +31,16 @@ val pretty : Format.formatter -> json -> unit
module type S =
sig
type t
- val descr : Markdown.text
+ val syntax : Syntax.t
val of_json : json -> t
val to_json : t -> json
end
module type Info =
sig
+ val page : Doc.page
val name : string
- val descr : Markdown.text
+ val descr : Markdown.block
end
type 'a data = (module S with type t = 'a)
@@ -113,13 +114,6 @@ sig
(** Contains only the default values. *)
val default : unit -> t
- val details :
- ?field:Markdown.column ->
- ?format:Markdown.column ->
- ?default:Markdown.column ->
- ?descr:Markdown.column ->
- unit -> Markdown.block
-
end
(* -------------------------------------------------------------------------- *)
@@ -159,8 +153,7 @@ module type IdentifiedType =
sig
type t
val id : t -> int
- val name : string
- val descr : Markdown.text
+ include Info
end
(** Builds a {i projectified} index on types with {i unique} identifiers *)
@@ -174,18 +167,10 @@ module type Enum =
sig
type t
val values : (t * string * Markdown.text) list
- val name : string
- val descr : Markdown.text
+ include Info
end
-module Dictionary(E : Enum) :
-sig
- val descr_table :
- ?tag:Markdown.column ->
- ?descr:Markdown.column ->
- unit -> Markdown.block
- include S_collection with type t = E.t
-end
+module Dictionary(E : Enum) : S_collection with type t = E.t
(* -------------------------------------------------------------------------- *)
(** {2 Misc} *)
@@ -194,9 +179,4 @@ end
val failure : string -> json -> 'a
(** @raise Yojson.Basic.Util.Type_error with the given arguments *)
-val d_tuple : Markdown.text list -> Markdown.text
-val d_array : Markdown.text -> Markdown.text
-val d_option : Markdown.text -> Markdown.text
-val d_record : Markdown.text -> Markdown.text
-
(* -------------------------------------------------------------------------- *)
diff --git a/src/plugins/server/doc.ml b/src/plugins/server/doc.ml
index 5cd379fa7e2..0bfc615de78 100644
--- a/src/plugins/server/doc.ml
+++ b/src/plugins/server/doc.ml
@@ -58,7 +58,9 @@ let page chapter ~title ~filename =
| `Kernel -> ".." , Printf.sprintf "kernel/%s" filename
| `Plugin name -> "../.." , Printf.sprintf "plugins/%s/%s" name filename
in
- try Pages.find path !pages
+ try
+ let other = Pages.find path !pages in
+ Senv.failure "Duplicate page '%s' path@." path ; other
with Not_found ->
let intro = match chapter with
| `Protocol ->
diff --git a/src/plugins/server/kernel_ast.ml b/src/plugins/server/kernel_ast.ml
index 41ff66735a2..acef66913aa 100644
--- a/src/plugins/server/kernel_ast.ml
+++ b/src/plugins/server/kernel_ast.ml
@@ -107,7 +107,10 @@ module PP = Printer_tag.Make(Tag)
module Stmt = Data.Collection
(struct
type t = stmt
- let descr = Markdown.tt "stmt"
+ let syntax = Syntax.publish ast_page
+ ~name:"stmt"
+ ~synopsis:Syntax.ident
+ ~descr:(Markdown.praw "Code statement identifier")
let to_json st = `String (Tag.of_stmt st)
let of_json js =
try
@@ -122,7 +125,7 @@ module Stmt = Data.Collection
module Ki = Data.Collection
(struct
type t = kinstr
- let descr = Markdown.raw "(stmt|`\"global\")`"
+ let syntax = Syntax.union [ Syntax.tag "global" ; Stmt.syntax ]
let to_json = function
| Kglobal -> `String "global"
| Kstmt st -> `String (Tag.of_stmt st)
@@ -134,7 +137,10 @@ module Ki = Data.Collection
module Kf = Data.Collection
(struct
type t = kernel_function
- let descr = Markdown.tt "function"
+ let syntax = Syntax.publish ast_page
+ ~name:"function"
+ ~synopsis:Syntax.ident
+ ~descr:(Markdown.praw "Function, identified by its global name.")
let to_json kf = `String (Kernel_function.get_name kf)
let of_json js =
try Jutil.to_string js |> Globals.Functions.find_by_name
diff --git a/src/plugins/server/kernel_fc.ml b/src/plugins/server/kernel_fc.ml
index e14ba09207c..efaae9a32c8 100644
--- a/src/plugins/server/kernel_fc.ml
+++ b/src/plugins/server/kernel_fc.ml
@@ -38,7 +38,7 @@ let fc_page =
module ConfigInfo =
struct
type t = unit
- let descr = Markdown.tt "{ … }"
+ let syntax = Syntax.record []
let to_json () = `Assoc [
"version" , Jstring.to_json Config.version ;
@@ -50,10 +50,11 @@ struct
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)" ] ;
+ [ tt "'version'" ; it "string" ; rm "Frama-C version" ] ;
+ [ tt "'datadir'" ; it "string" ; rm "Shared directory (FRAMAC_SHARE)" ] ;
+ [ tt "'libdir'" ; it "string" ; rm "Lib directory (FRAMAC_LIB)" ] ;
+ [ tt "'pluginpath'" ; tt "[" <+> it "string" <+> tt ",…]" ;
+ rm "Plugin directories (FRAMAC_PLUGIN)" ] ;
]
end
@@ -80,10 +81,12 @@ module GetConfig =
module RawSource =
struct
-
type t = Filepath.position
-
- let descr = Markdown.href (Doc.href fc_page "source")
+ let syntax = Syntax.publish fc_page
+ ~name:"source"
+ ~synopsis:(Syntax.record [ "file" , Syntax.string ; "line" , Syntax.int ])
+ ~descr:(Markdown.praw "Source position. The file path is normalized, \
+ and the line number starts at one.")
let to_json p = `Assoc [
"file" , `String (p.Filepath.pos_path :> string) ;
@@ -96,12 +99,6 @@ struct
-> Log.source ~file:(Filepath.Normalized.of_string path) ~line
| js -> failure "invalid source format" js
- let details = Markdown.table
- [`Center "Field" ; `Center "Type" ; `Left "Description" ]
- [[ Markdown.tt "file" ; Jstring.descr ;
- Markdown.rm "File path (normalized)" ];
- [ Markdown.tt "line" ; Jint.descr ;
- Markdown.rm "Line number (counting from 1)" ]]
end
module LogSource = Collection(RawSource)
@@ -113,8 +110,9 @@ module LogSource = Collection(RawSource)
module RawKind =
struct
type t = Log.kind
+ let page = fc_page
let name = "Kind"
- let descr = Markdown.href (Doc.href fc_page "kind")
+ let descr = Markdown.praw "Frama-C message category."
let values = [
Log.Error, "ERROR", Markdown.rm "User Error" ;
Log.Warning, "WARNING", Markdown.rm "User Warning" ;
@@ -125,11 +123,7 @@ struct
]
end
-module LogKind =
-struct
- include Dictionary(RawKind)
- let details = descr_table ~tag:(`Center "Kind") ()
-end
+module LogKind = Dictionary(RawKind)
(* -------------------------------------------------------------------------- *)
(* --- Log Events --- *)
@@ -140,12 +134,14 @@ struct
module R = Record
(struct
+ let page = fc_page
let name = "log"
- let descr = Markdown.href (Doc.href fc_page "log")
+ let descr = Markdown.praw "Message event record."
end)
- let descr = Markdown.rm
+ let syntax = R.syntax
+ let descr = Markdown.rm
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)
@@ -178,9 +174,6 @@ struct
Log.evt_message = R.get message r ;
}
- let descr = Markdown.href (Doc.href fc_page "log")
- let details = R.details ()
-
end
module LogEvent = Collection(RawEvent)
@@ -233,13 +226,7 @@ module GetLogs =
(struct
let name = "Kernel.GetLogs"
let descr = Markdown.rm "Flush emitted logs since last call (max 100)"
-
- let details = [
- Markdown.section ~name:"log" ~title:"Log Format" RawEvent.details [] ;
- Markdown.section ~name:"kind" ~title:"Log Kind" LogKind.details [] ;
- Markdown.section ~name:"source" ~title:"File position" RawSource.details [] ;
- ]
-
+ let details = []
let page = fc_page
let kind = `GET
type input = unit
diff --git a/src/plugins/server/kernel_project.ml b/src/plugins/server/kernel_project.ml
index 72f240f13e5..b9c7d963469 100644
--- a/src/plugins/server/kernel_project.ml
+++ b/src/plugins/server/kernel_project.ml
@@ -33,7 +33,9 @@ let project_page =
module ProjectInfo =
struct
type t = Project.t
- let descr = Markdown.href (`Name "project-info")
+ let syntax = Syntax.publish project_page ~name:"project"
+ ~synopsis:(Syntax.(record ["id",string;"name",string;"current",boolean]))
+ ~descr:(Markdown.praw "Project informations")
let name_of_json = function
| `Assoc info -> Jstring.of_json (List.assoc "id" info)
| `String id -> id
@@ -51,10 +53,12 @@ end
module ProjectRequest =
struct
type t = Project.t * string * json
- let descr = Markdown.(tt "{" <+> href (`Name "project-request") <+> tt "}")
+ let syntax = Syntax.publish project_page ~name:"project"
+ ~synopsis:(Syntax.(record ["project",string;"request",string;"data",any]))
+ ~descr:(Markdown.praw "Request to be executed on the specified project.")
let of_json js =
begin
- ProjectInfo.of_json (Jutil.member "project-request" js) ,
+ ProjectInfo.of_json (Jutil.member "project" js) ,
Jutil.(member "request" js |> to_string) ,
Jutil.(member "data" js)
end
diff --git a/src/plugins/server/request.ml b/src/plugins/server/request.ml
index 4d7779edb2a..47e14e6114a 100644
--- a/src/plugins/server/request.ml
+++ b/src/plugins/server/request.ml
@@ -32,14 +32,14 @@ type kind = [ `GET | `SET | `EXEC ]
module type Input =
sig
type t
- val descr : Markdown.text
+ val syntax : Syntax.t
val of_json : json -> t
end
module type Output =
sig
type t
- val descr : Markdown.text
+ val syntax : Syntax.t
val to_json : t -> json
end
@@ -128,7 +128,8 @@ struct
let synopsis =
Markdown.table
[ `Center "Input" ; `Center "Output" ; `Left "Description" ]
- [[ Input.descr ; Output.descr ; Rq.descr ]]
+ [[ Syntax.format Input.syntax ;
+ Syntax.format Output.syntax ; Rq.descr ]]
in
Doc.publish Rq.page ~index:[Rq.name] ~title synopsis Rq.details
diff --git a/src/plugins/server/request.mli b/src/plugins/server/request.mli
index 412d5196d71..bdd9eed2f4a 100644
--- a/src/plugins/server/request.mli
+++ b/src/plugins/server/request.mli
@@ -30,14 +30,14 @@ type kind = [ `GET | `SET | `EXEC ]
module type Input =
sig
type t
- val descr : Markdown.text
+ val syntax : Syntax.t
val of_json : json -> t
end
module type Output =
sig
type t
- val descr : Markdown.text
+ val syntax : Syntax.t
val to_json : t -> json
end
diff --git a/src/plugins/server/server_parameters.ml b/src/plugins/server/server_parameters.ml
index 7f4c08d0d16..91c06f7b146 100644
--- a/src/plugins/server/server_parameters.ml
+++ b/src/plugins/server/server_parameters.ml
@@ -63,4 +63,7 @@ module Log = P.False
let help = "Start (or stop) monitoring logs"
end)
+let wpage = register_warn_category "inconsistent-page"
+let wkind = register_warn_category "inconsistent-kind"
+
(* -------------------------------------------------------------------------- *)
diff --git a/src/plugins/server/server_parameters.mli b/src/plugins/server/server_parameters.mli
index ac7a81bc409..fab7ab61a32 100644
--- a/src/plugins/server/server_parameters.mli
+++ b/src/plugins/server/server_parameters.mli
@@ -29,4 +29,7 @@ module Rate : Parameter_sig.Int (** Number of fetch per yield *)
module Doc : Parameter_sig.String (** Generate documentation *)
module Log : Parameter_sig.Bool (** Monitor logs *)
+val wpage : warn_category (** Inconsistent page warning *)
+val wkind : warn_category (** Inconsistent category warning *)
+
(**************************************************************************)
diff --git a/src/plugins/server/syntax.ml b/src/plugins/server/syntax.ml
new file mode 100644
index 00000000000..839722e1aed
--- /dev/null
+++ b/src/plugins/server/syntax.ml
@@ -0,0 +1,100 @@
+(**************************************************************************)
+(* *)
+(* This file is part of Frama-C. *)
+(* *)
+(* Copyright (C) 2007-2019 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It is distributed in the hope that it will be useful, *)
+(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
+(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
+(* GNU Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(* *)
+(**************************************************************************)
+
+(* -------------------------------------------------------------------------- *)
+
+module STR = Transitioning.String
+module Senv = Server_parameters
+
+let check_plugin plugin name =
+ let p = STR.lowercase_ascii plugin in
+ let n = STR.lowercase_ascii name in
+ let k = String.length plugin in
+ if not (String.length name > k &&
+ String.sub n 0 k = p &&
+ String.get n k = '.')
+ then
+ Senv.warning ~wkey:Senv.wpage
+ "Data '%s' shall be named « %s.* »"
+ name plugin
+
+let check_page page name =
+ match Doc.chapter page with
+ | `Kernel -> ()
+ | `Plugin plugin -> check_plugin plugin name
+ | `Protocol -> check_plugin "server" name
+
+(* -------------------------------------------------------------------------- *)
+
+type t = { atomic:bool ; descr:Markdown.text }
+
+let atom md = { atomic=true ; descr=md }
+let flow md = { atomic=false ; descr=md }
+
+let format { descr } = descr
+let protect a =
+ if a.atomic then a.descr else Markdown.(rm "(" <+> a.descr <+> rm ")")
+
+let publish page ~name ~synopsis ~descr =
+ check_page page name ;
+ let title = Printf.sprintf "`Data` %s" name in
+ let syntax = Markdown.fmt_block (fun fmt ->
+ Format.fprintf fmt "> _%s_ ::= @[<h>%a@]"
+ name Markdown.pp_text synopsis.descr
+ ) in
+ let content = Markdown.( syntax </> descr ) in
+ let href = Doc.publish page ~name ~title ~index:[name] content [] in
+ atom @@ Markdown.href ~title:name href
+
+let any = atom @@ Markdown.it "any"
+let int = atom @@ Markdown.it "int"
+let ident = atom @@ Markdown.it "ident"
+let string = atom @@ Markdown.it "string"
+let number = atom @@ Markdown.it "number"
+let boolean = atom @@ Markdown.it "boolean"
+
+let null = atom @@ Markdown.tt "null" (* really « tt » *)
+
+let escaped name = Markdown.tt @@ Printf.sprintf "'%s'" @@ String.escaped name
+
+let tag name = atom @@ escaped name
+
+let array a = atom @@ Markdown.(tt "[" <+> protect a <+> tt ",…]")
+
+let tuple ts =
+ atom @@ Markdown.(tt "["
+ <+> glue ~sep:(raw " `,` ") (List.map protect ts) <+>
+ tt "]")
+
+let union ts = flow @@ Markdown.(glue ~sep:(raw " | ") (List.map protect ts))
+
+let option t = atom @@ Markdown.(protect t <@> tt "?")
+
+let field (a,t) = Markdown.( escaped a <+> tt ":" <+> t.descr )
+
+let record fds =
+ let fields =
+ if fds = [] then Markdown.rm "…" else
+ Markdown.(glue ~sep:(raw " `;` ") (List.map field fds))
+ in atom @@ Markdown.(tt "{" <+> fields <+> tt "}")
+
+(* -------------------------------------------------------------------------- *)
diff --git a/src/plugins/server/syntax.mli b/src/plugins/server/syntax.mli
new file mode 100644
index 00000000000..de443d599c0
--- /dev/null
+++ b/src/plugins/server/syntax.mli
@@ -0,0 +1,51 @@
+(**************************************************************************)
+(* *)
+(* This file is part of Frama-C. *)
+(* *)
+(* Copyright (C) 2007-2019 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It is distributed in the hope that it will be useful, *)
+(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
+(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
+(* GNU Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(* *)
+(**************************************************************************)
+
+(* -------------------------------------------------------------------------- *)
+(** JSON Encoding Documentation *)
+(* -------------------------------------------------------------------------- *)
+
+type t
+
+val format : t -> Markdown.text
+
+(** The provided synopsis must be very short, to fit in one line.
+ Extended definition, like record fields and such, must be detailed in
+ the description block. *)
+val publish : Doc.page -> name:string -> synopsis:t -> descr:Markdown.block -> t
+
+val any : t
+val int : t (* small, non-decimal, number *)
+val ident : t (* integer of string *)
+val null : t
+val string : t
+val number : t
+val boolean : t
+
+val tag : string -> t
+val array : t -> t
+val tuple : t list -> t
+val union : t list -> t
+val option : t -> t
+val record : (string * t) list -> t
+
+(* -------------------------------------------------------------------------- *)
--
GitLab