From 28a31db62ce4c9d850318987d434147c5af6c19e Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Loi=CC=88c=20Correnson?= <loic.correnson@cea.fr>
Date: Fri, 15 Mar 2019 15:25:06 +0100
Subject: [PATCH] [doc/server] styling the documentation
---
doc/pandoc/style.css | 22 ++++---
src/libraries/utils/markdown.ml | 10 +--
src/plugins/server/data.ml | 41 +++++--------
src/plugins/server/data.mli | 2 +-
src/plugins/server/kernel_ast.ml | 31 +++++-----
src/plugins/server/kernel_fc.ml | 48 ++++++++-------
src/plugins/server/kernel_project.ml | 50 +++++++++------
src/plugins/server/kernel_project.mli | 4 +-
src/plugins/server/request.ml | 31 ++--------
src/plugins/server/share/kernel/project.md | 23 -------
src/plugins/server/syntax.ml | 71 ++++++++++------------
src/plugins/server/syntax.mli | 10 +--
12 files changed, 152 insertions(+), 191 deletions(-)
diff --git a/doc/pandoc/style.css b/doc/pandoc/style.css
index 6e1df1fb54a..ba609d558f7 100644
--- a/doc/pandoc/style.css
+++ b/doc/pandoc/style.css
@@ -25,7 +25,6 @@
html
{
background-color: #fff;
- font-size: 14px;
}
* { margin: 0; padding: 0 }
@@ -37,7 +36,7 @@ body {
height: 100%;
overflow: hidden;
font-family: "Verdana", sans;
- font-size: 12px;
+ font-size: 12pt;
}
/* -------------------------------------------------------------------------- */
@@ -78,15 +77,18 @@ body {
padding: 0cm 1cm 1cm 1cm ;
}
-
/* -------------------------------------------------------------------------- */
/* --- Navigation --- */
/* -------------------------------------------------------------------------- */
+#TOC {
+ font-size: smaller ;
+}
+
#NAVIGATION a.root {
display: block;
- font-size: 2em;
font-family: "Optima", "Verdana", "Arial", sans;
+ font-size: 16pt;
margin-top: 1cm;
margin-bottom: 6mm;
}
@@ -158,7 +160,7 @@ h4,h5,h6 {
margin-top: 4mm;
margin-bottom: 1mm;
font-family: "Optima", "Verdana", "Arial", sans;
- font-size: 10px;
+ font-size: 10pt;
font-style: italic;
font-weight: bold;
color: darkred;
@@ -181,7 +183,7 @@ pre {
background-color: #eef ;
}
-pre,code { color: grey }
+pre,code { font-size: smaller ; color: #106000 }
hr {
border: none ;
@@ -207,10 +209,16 @@ tr.odd {
background-color: rgba(178, 222, 236, 0.3) ;
}
+:target { background-color: darkorange; }
+
a:visited { color: darkred; text-decoration: none }
a:link { color: darkred; text-decoration: none }
a:hover { background-color: lightgray; color: firebrick }
a:active { background-color: lightgray; color: darkgreen }
-:target { background-color: darkorange; }
+
+a:visited em { color: darkgreen; text-decoration: none }
+a:link em { color: darkgreen; text-decoration: none }
+a:hover em { background-color: lightgray; color: firebrick }
+a:active em { background-color: lightgray; color: darkgreen }
/* -------------------------------------------------------------------------- */
diff --git a/src/libraries/utils/markdown.ml b/src/libraries/utils/markdown.ml
index 61a484b6a14..e31749a3b98 100644
--- a/src/libraries/utils/markdown.ml
+++ b/src/libraries/utils/markdown.ml
@@ -96,19 +96,19 @@ let (</>) a b =
fun fmt -> a fmt ; newline fmt ; b fmt
let fmt_text k fmt = Format.fprintf fmt "@[<h 0>%t@]" k
-let fmt_block k fmt = Format.fprintf fmt "@[<v 0>%t@]" k
+let fmt_block k fmt = Format.fprintf fmt "@[<v 0>%t@]@\n" 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
let bf s fmt = Format.fprintf fmt "**%s**" s
let tt s fmt = Format.fprintf fmt "`%s`" s
let text = merge space
+let praw s = fmt_block (raw s)
(* -------------------------------------------------------------------------- *)
(* --- Links --- *)
@@ -165,7 +165,7 @@ let href ?title (h : href) fmt =
(* -------------------------------------------------------------------------- *)
let aname anchor fmt =
- Format.fprintf fmt "<a name=\"%s\"></a>@\n" anchor
+ Format.fprintf fmt "<a name=\"%s\"></a>@\n" (id anchor)
let title h ?name title fmt =
begin
@@ -174,8 +174,8 @@ let title h ?name title fmt =
Format.fprintf fmt "%s %s" (String.make level '#') title ;
if names || name <> None || toc <> None then
begin
- let anchor = match name with None -> id title | Some a -> a in
- Format.fprintf fmt " {#%s}" anchor ;
+ let anchor = match name with None -> title | Some a -> a in
+ Format.fprintf fmt " {#%s}" (id anchor) ;
(match toc with
| None -> ()
| Some callback ->
diff --git a/src/plugins/server/data.ml b/src/plugins/server/data.ml
index 0089341017a..41eb70d929b 100644
--- a/src/plugins/server/data.ml
+++ b/src/plugins/server/data.ml
@@ -42,7 +42,7 @@ module type Info =
sig
val page : Doc.page
val name : string
- val descr : Markdown.block
+ val descr : Markdown.text
end
type 'a data = (module S with type t = 'a)
@@ -202,7 +202,7 @@ module Jtext =
struct
include Jany
let syntax = Syntax.publish ~page:text_page ~name:"text"
- ~synopsis:Syntax.any ~descr:(Markdown.praw "Formatted text.")
+ ~synopsis:Syntax.any ~descr:(Markdown.rm "Formatted text.") ()
end
(* -------------------------------------------------------------------------- *)
@@ -233,18 +233,11 @@ struct
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 (Markdown.tt @@ Json.to_string jd) in
- fdocs := Syntax.{
- fd_name = name ;
- fd_syntax = D.syntax ;
- fd_default = def ;
- fd_descr = descr ;
- } :: !fdocs ;
+ begin match default with
+ | None -> ()
+ | Some v -> defaults := Fmap.add name (D.to_json v) !defaults
+ end ;
+ fdocs := Syntax.{ name ; syntax = D.syntax ; 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
@@ -252,12 +245,7 @@ struct
let option (type a) name ~descr (d : a data) : a option field =
let module D = (val d) in
- fdocs := Syntax.{
- fd_name = name ;
- fd_syntax = D.syntax ;
- fd_default = None ;
- fd_descr = descr ;
- } :: !fdocs ;
+ fdocs := Syntax.{ name ; syntax = option D.syntax ; 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
@@ -269,8 +257,10 @@ struct
let fields () = Syntax.fields ~kind:"Field" !fdocs
let syntax =
- let descr = Markdown.( R.descr </> mk_block fields ) in
- Syntax.publish ~page:R.page ~name:R.name ~synopsis:(Syntax.record []) ~descr
+ Syntax.publish ~page:R.page ~name:R.name
+ ~descr:R.descr
+ ~synopsis:(Syntax.record [])
+ ~details:(Markdown.mk_block fields) ()
let of_json js =
List.fold_left
@@ -305,7 +295,8 @@ sig
end
let publish_id (module A : Info) =
- Syntax.publish ~page:A.page ~name:A.name ~synopsis:Syntax.int ~descr:A.descr
+ Syntax.publish
+ ~page:A.page ~name:A.name ~synopsis:Syntax.int ~descr:A.descr ()
module INDEXER(M : Map)(I : Info) :
sig
@@ -498,7 +489,7 @@ struct
let values () =
Markdown.table
- [ `Center E.name ; `Left "Description" ]
+ [ `Left E.name ; `Left "Description" ]
(List.map
(fun (_,tag,descr) ->
[ Markdown.tt (Printf.sprintf "%S" tag) ; descr ]
@@ -511,7 +502,7 @@ struct
let syntax = Syntax.publish
~page:E.page ~name:E.name
~synopsis:Syntax.ident
- ~descr:Markdown.( E.descr </> mk_block values )
+ ~descr:E.descr ~details:(Markdown.mk_block values) ()
let to_json value =
register () ;
diff --git a/src/plugins/server/data.mli b/src/plugins/server/data.mli
index a1249aebd48..ca76a074c96 100644
--- a/src/plugins/server/data.mli
+++ b/src/plugins/server/data.mli
@@ -40,7 +40,7 @@ module type Info =
sig
val page : Doc.page
val name : string
- val descr : Markdown.block
+ val descr : Markdown.text
end
type 'a data = (module S with type t = 'a)
diff --git a/src/plugins/server/kernel_ast.ml b/src/plugins/server/kernel_ast.ml
index adf62a4c4e5..6d9d4195d81 100644
--- a/src/plugins/server/kernel_ast.ml
+++ b/src/plugins/server/kernel_ast.ml
@@ -20,9 +20,12 @@
(* *)
(**************************************************************************)
-open Cil_types
+
open Data
-module Jutil = Yojson.Basic.Util
+module Sy = Syntax
+module Md = Markdown
+module Js = Yojson.Basic.Util
+open Cil_types
(* -------------------------------------------------------------------------- *)
(* --- Frama-C Ast Services --- *)
@@ -34,7 +37,7 @@ module ExecCompute = Request.Register(Junit)(Junit)
(struct
let kind = `EXEC
let name = "Kernel.Ast.ExecCompute"
- let descr = Markdown.rm "Ensures that AST is computed"
+ let descr = Md.rm "Ensures that AST is computed"
let page = page
let details = []
type input = unit
@@ -106,14 +109,14 @@ module PP = Printer_tag.Make(Tag)
module Stmt = Data.Collection
(struct
type t = stmt
- let syntax = Syntax.publish ~page ~name:"stmt"
- ~synopsis:Syntax.ident
- ~descr:(Markdown.praw "Code statement identifier")
+ let syntax = Sy.publish ~page ~name:"stmt"
+ ~synopsis:Sy.ident
+ ~descr:(Md.rm "Code statement identifier") ()
let to_json st = `String (Tag.of_stmt st)
let of_json js =
try
let open Printer_tag in
- match Tag.lookup (Jutil.to_string js) with
+ match Tag.lookup (Js.to_string js) with
| PStmt(_,st) -> st
| _ -> raise Not_found
with Not_found ->
@@ -123,7 +126,7 @@ module Stmt = Data.Collection
module Ki = Data.Collection
(struct
type t = kinstr
- let syntax = Syntax.union [ Syntax.tag "global" ; Stmt.syntax ]
+ let syntax = Sy.union [ Sy.tag "global" ; Stmt.syntax ]
let to_json = function
| Kglobal -> `String "global"
| Kstmt st -> `String (Tag.of_stmt st)
@@ -135,12 +138,12 @@ module Ki = Data.Collection
module Kf = Data.Collection
(struct
type t = kernel_function
- let syntax = Syntax.publish ~page ~name:"function"
- ~synopsis:Syntax.ident
- ~descr:(Markdown.praw "Function, identified by its global name.")
+ let syntax = Sy.publish ~page ~name:"function"
+ ~synopsis:Sy.ident
+ ~descr:(Md.rm "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
+ try Js.to_string js |> Globals.Functions.find_by_name
with Not_found -> Data.failure "Undefined function" js
end)
@@ -152,7 +155,7 @@ module GetFunctions = Request.Register(Junit)(Kf.Jlist)
(struct
let kind = `GET
let name = "Kernel.Ast.GetFunctions"
- let descr = Markdown.rm "Collect all functions in the AST"
+ let descr = Md.rm "Collect all functions in the AST"
let page = page
let details = []
type input = unit
@@ -167,7 +170,7 @@ module PrintFunction = Request.Register(Kf)(Jtext)
(struct
let kind = `GET
let name = "Kernel.Ast.PrintFunction"
- let descr = Markdown.rm "Print the AST of a function"
+ let descr = Md.rm "Print the AST of a function"
let page = page
let details = []
type input = kernel_function
diff --git a/src/plugins/server/kernel_fc.ml b/src/plugins/server/kernel_fc.ml
index 893b961fd22..91906c9b643 100644
--- a/src/plugins/server/kernel_fc.ml
+++ b/src/plugins/server/kernel_fc.ml
@@ -20,14 +20,15 @@
(* *)
(**************************************************************************)
+open Data
+module Sy = Syntax
+module Md = Markdown
module Senv = Server_parameters
(* -------------------------------------------------------------------------- *)
(* --- Frama-C Kernel Services --- *)
(* -------------------------------------------------------------------------- *)
-open Data
-
let page = Doc.page `Kernel ~title:"Kernel Services" ~filename:"kernel.md"
(* -------------------------------------------------------------------------- *)
@@ -37,7 +38,7 @@ let page = Doc.page `Kernel ~title:"Kernel Services" ~filename:"kernel.md"
module ConfigInfo =
struct
type t = unit
- let syntax = Syntax.record []
+ let syntax = Sy.record []
let to_json () = `Assoc [
"version" , Jstring.to_json Config.version ;
@@ -47,7 +48,7 @@ struct
]
let details =
- let open Markdown in
+ let open Md in
table [ `Left "field" ; `Left "format" ; `Left "Description" ] [
[ tt "'version'" ; it "string" ; rm "Frama-C version" ] ;
[ tt "'datadir'" ; it "string" ; rm "Shared directory (FRAMAC_SHARE)" ] ;
@@ -66,9 +67,9 @@ module GetConfig =
let page = page
let kind = `GET
let name = "Kernel.GetConfig"
- let descr = Markdown.rm "Kernel configuration"
+ let descr = Md.rm "Kernel configuration"
let details =
- [Markdown.section ~title:"Output Configuration" ConfigInfo.details []]
+ [Md.section ~title:"Output Configuration" ConfigInfo.details []]
type input = unit
type output = unit
let process () = ()
@@ -81,10 +82,11 @@ module GetConfig =
module RawSource =
struct
type t = Filepath.position
- let syntax = Syntax.publish ~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 syntax = Sy.publish ~page ~name:"source"
+ ~synopsis:(Sy.record [ "file" , Sy.string ; "line" , Sy.int ])
+ ~descr:(Md.rm "Source file positions.")
+ ~details:(Md.praw "The file path is normalized, \
+ and the line number starts at one.") ()
let to_json p = `Assoc [
"file" , `String (p.Filepath.pos_path :> string) ;
@@ -95,7 +97,7 @@ struct
| `Assoc [ "file" , `String path ; "line" , `Int line ]
| `Assoc [ "line" , `Int line ; "file" , `String path ]
-> Log.source ~file:(Filepath.Normalized.of_string path) ~line
- | js -> failure "invalid source format" js
+ | js -> failure "Invalid source format" js
end
@@ -109,15 +111,15 @@ module RawKind =
struct
type t = Log.kind
let page = page
- let name = "Kind"
- let descr = Markdown.praw "Frama-C message category."
+ let name = "kind"
+ let descr = Md.rm "Frama-C message category."
let values = [
- Log.Error, "ERROR", Markdown.rm "User Error" ;
- Log.Warning, "WARNING", Markdown.rm "User Warning" ;
- Log.Feedback, "FEEDBACK", Markdown.rm "Analyzer Feedback" ;
- Log.Result, "RESULT", Markdown.rm "Analyzer Result" ;
- Log.Failure, "FAILURE", Markdown.rm "Analyzer Failure" ;
- Log.Debug, "DEBUG", Markdown.rm "Analyser Debug" ;
+ Log.Error, "ERROR", Md.rm "User Error" ;
+ Log.Warning, "WARNING", Md.rm "User Warning" ;
+ Log.Feedback, "FEEDBACK", Md.rm "Analyzer Feedback" ;
+ Log.Result, "RESULT", Md.rm "Analyzer Result" ;
+ Log.Failure, "FAILURE", Md.rm "Analyzer Failure" ;
+ Log.Debug, "DEBUG", Md.rm "Analyser Debug" ;
]
end
@@ -134,12 +136,12 @@ struct
(struct
let page = page
let name = "log"
- let descr = Markdown.praw "Message event record."
+ let descr = Md.rm "Message event record."
end)
let syntax = R.syntax
- let descr = Markdown.rm
+ let descr = Md.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)
@@ -208,7 +210,7 @@ module SetLogs =
(Junit)
(struct
let name = "Kernel.SetLogs"
- let descr = Markdown.rm "Turn logs monitoring on/off"
+ let descr = Md.rm "Turn logs monitoring on/off"
let details = []
let page = page
let kind = `SET
@@ -223,7 +225,7 @@ module GetLogs =
(LogEvent.Jlist)
(struct
let name = "Kernel.GetLogs"
- let descr = Markdown.rm "Flush emitted logs since last call (max 100)"
+ let descr = Md.rm "Flush emitted logs since last call (max 100)"
let details = []
let page = page
let kind = `GET
diff --git a/src/plugins/server/kernel_project.ml b/src/plugins/server/kernel_project.ml
index 8cb431633c0..e83eaf0ff7f 100644
--- a/src/plugins/server/kernel_project.ml
+++ b/src/plugins/server/kernel_project.ml
@@ -20,46 +20,58 @@
(* *)
(**************************************************************************)
+open Data
+module Sy = Syntax
+module Md = Markdown
+module Js = Yojson.Basic.Util
+
(* -------------------------------------------------------------------------- *)
(* --- Project Requests --- *)
(* -------------------------------------------------------------------------- *)
-open Data
-module Jutil = Yojson.Basic.Util
-
let page = Doc.page `Kernel ~title:"Project Management" ~filename:"project.md"
module ProjectInfo =
struct
+
type t = Project.t
- let syntax = Syntax.publish ~page ~name:"project"
- ~synopsis:(Syntax.(record ["id",string;"name",string;"current",boolean]))
- ~descr:(Markdown.praw "Project informations")
+ let syntax =
+ Sy.publish ~page ~name:"project-info"
+ ~synopsis:Sy.(record[ "id",ident; "name",string; "current",boolean ])
+ ~descr:(Md.rm "Project informations")
+ ()
+
let name_of_json = function
| `Assoc info -> Jstring.of_json (List.assoc "id" info)
| `String id -> id
- | js -> failure "Kernel.ProjectInfo" js
+ | js -> failure "Invalid project-info" js
+
let of_json js =
Project.from_unique_name (name_of_json js)
+
let to_json p =
`Assoc [
"id", `String (Project.get_unique_name p) ;
"name", `String (Project.get_name p) ;
"current", `Bool (Project.is_current p) ;
]
+
end
module ProjectRequest =
struct
+
type t = Project.t * string * json
- let syntax = Syntax.publish ~page ~name:"project"
- ~synopsis:(Syntax.(record ["project",string;"request",string;"data",any]))
- ~descr:(Markdown.praw "Request to be executed on the specified project.")
+
+ let syntax = Sy.publish ~page ~name:"project-request"
+ ~synopsis:(Sy.(record[ "project",ident; "request",string; "data",any; ]))
+ ~descr:(Md.rm "Request to be executed on the specified project.") ()
+
let of_json js =
begin
- ProjectInfo.of_json (Jutil.member "project" js) ,
- Jutil.(member "request" js |> to_string) ,
- Jutil.(member "data" js)
+ Project.from_unique_name Js.(member "project" js |> to_string) ,
+ Js.(member "request" js |> to_string) ,
+ Js.(member "data" js)
end
let process kind (project,request,data) =
@@ -78,7 +90,7 @@ module GetCurrent =
let page = page
let kind = `GET
let name = "Kernel.Project.GetCurrent"
- let descr = Markdown.rm "Returns the current project"
+ let descr = Md.rm "Returns the current project"
let details = []
type input = unit
type output = Project.t
@@ -93,7 +105,7 @@ module SetCurrent =
let page = page
let kind = `SET
let name = "Kernel.Project.SetCurrent"
- let descr = Markdown.rm "Switches the current project"
+ let descr = Md.rm "Switches the current project"
let details = []
type input = Project.t
type output = unit
@@ -108,7 +120,7 @@ module GetProjects =
let page = page
let kind = `GET
let name = "Kernel.Project.GetList"
- let descr = Markdown.rm "List of projects"
+ let descr = Md.rm "List of projects"
let details = []
type input = unit
type output = Project.t list
@@ -123,7 +135,7 @@ module GetOn =
let page = page
let kind = `GET
let name = "Kernel.Project.GetOn"
- let descr = Markdown.rm "Execute a GET request within the given project"
+ let descr = Md.rm "Execute a GET request within the given project"
let details = []
type input = Project.t * string * json
type output = json
@@ -138,7 +150,7 @@ module SetOn =
let page = page
let kind = `SET
let name = "Kernel.Project.SetOn"
- let descr = Markdown.rm "Execute a SET request within the given project"
+ let descr = Md.rm "Execute a SET request within the given project"
let details = []
type input = Project.t * string * json
type output = json
@@ -153,7 +165,7 @@ module ExecOn =
let page = page
let kind = `EXEC
let name = "Kernel.Project.ExecOn"
- let descr = Markdown.rm "Execute an EXEC request within the given project"
+ let descr = Md.rm "Execute an EXEC request within the given project"
let details = []
type input = Project.t * string * json
type output = json
diff --git a/src/plugins/server/kernel_project.mli b/src/plugins/server/kernel_project.mli
index 30c4158e40f..de40b958448 100644
--- a/src/plugins/server/kernel_project.mli
+++ b/src/plugins/server/kernel_project.mli
@@ -20,12 +20,12 @@
(* *)
(**************************************************************************)
+open Data
+
(* -------------------------------------------------------------------------- *)
(** Project Services *)
(* -------------------------------------------------------------------------- *)
-open Data
-
module ProjectInfo : Data.S with type t = Project.t
module ProjectRequest : Request.Input with type t = Project.t * string * json
diff --git a/src/plugins/server/request.ml b/src/plugins/server/request.ml
index a584b3f4ac7..29e9bbbb2b8 100644
--- a/src/plugins/server/request.ml
+++ b/src/plugins/server/request.ml
@@ -83,7 +83,7 @@ let wkind = Senv.register_warn_category "inconsistent-kind"
let check_name name =
if not (Str.string_match re_name name 0) then
Senv.warning ~wkey:Senv.wname
- "Request %S is not a dot-separated list of identifiers" name
+ "Request %S is not a dot-separated list of identifiers" name
let check_plugin plugin name =
let p = STR.lowercase_ascii plugin in
@@ -256,12 +256,8 @@ let fds_input s : Syntax.field list =
let param (type a b) (s : (unit,b) signature) ~name ~descr
?default (input : a input) : a param =
let module D = (val input) in
- let fd = Syntax.{
- fd_name = name ;
- fd_syntax = if default = None then D.syntax else Syntax.option D.syntax ;
- fd_default = None ;
- fd_descr = descr ;
- } in
+ let syntax = if default = None then D.syntax else Syntax.option D.syntax in
+ let fd = Syntax.{ name ; syntax ; descr } in
s.input <- Pfields (fd :: fds_input s) ;
fun rq ->
try D.of_json (Fmap.find name rq.param)
@@ -273,12 +269,7 @@ 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.{
- fd_name = name ;
- fd_syntax = Syntax.option D.syntax ;
- fd_default = None ;
- fd_descr = descr ;
- } in
+ let fd = Syntax.{ name ; syntax = Syntax.option D.syntax ; descr } in
s.input <- Pfields (fd :: fds_input s) ;
fun rq ->
try Some(D.of_json (Fmap.find name rq.param))
@@ -299,12 +290,7 @@ 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.{
- fd_name = name ;
- fd_syntax = D.syntax ;
- fd_default = None ;
- fd_descr = descr ;
- } in
+ let fd = Syntax.{ name ; syntax = D.syntax ; descr } in
s.output <- Rfields (fd :: fds_output s) ;
begin
match default with
@@ -316,12 +302,7 @@ 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.{
- fd_name = name ;
- fd_syntax = Syntax.option D.syntax ;
- fd_default = None ;
- fd_descr = descr ;
- } in
+ let fd = Syntax.{ name ; syntax = option D.syntax ; descr } in
s.output <- Rfields (fd :: fds_output s) ;
fun rq opt ->
match opt with None -> () | Some v ->
diff --git a/src/plugins/server/share/kernel/project.md b/src/plugins/server/share/kernel/project.md
index c312e8095b4..79715b8efc3 100644
--- a/src/plugins/server/share/kernel/project.md
+++ b/src/plugins/server/share/kernel/project.md
@@ -15,26 +15,3 @@ asynchronous behavior of the server.
However, it is still possible to execute a request on a specific project with
`Kernel.Project.{Get|Set|Exec}On` requests.
-
-## Project Informations {#project-info}
-
-The JSON encoding for `project-info` is a record with the following fields:
-
-| Field | Type | Description |
-|:-----:|:----:|:------------|
-| `"id"` | _string_ | Project unique name |
-| `"name"` | _string_ | Project descriptive name |
-| `"current"` | _boolean_ | Currently selected project |
-
-When used as _input_ parameter of a request, the project unique name can be used instead of the full project info.
-
-## Request Delegation {#request-info}
-
-To send a request on a specific project, the requests `Kernel.Project.{Get|Set|Exec}On` takes a input parameter
-a record `request-info` with the following fields:
-
-| Field | Type | Description |
-|:-----:|:----:|:------------|
-| `"project"` | [project-info](#project-info) | Project to execute the request on |
-| `"request"` | _string_ | The request name |
-| `"data"` | _any_ | The request data |
diff --git a/src/plugins/server/syntax.ml b/src/plugins/server/syntax.ml
index 63cbcd0abab..77d5bea9528 100644
--- a/src/plugins/server/syntax.ml
+++ b/src/plugins/server/syntax.ml
@@ -43,35 +43,40 @@ let check_page page name =
| `Plugin plugin -> check_plugin plugin name
| `Protocol -> check_plugin "server" name
-let re_name = Str.regexp "[a-zA-Z0-9-]+"
+let re_name = Str.regexp "[a-z0-9-]+$"
let check_name name =
if not (Str.string_match re_name name 0) then
Senv.warning ~wkey:Senv.wname
- "Data name %S is not a dash-separated list of identifiers" name
+ "Data name %S is not a dash-separated list of lowercase identifiers" name
(* -------------------------------------------------------------------------- *)
-type t = { atomic:bool ; descr:Markdown.text }
+type t = { atomic:bool ; text:Markdown.text }
-let atom md = { atomic=true ; descr=md }
-let flow md = { atomic=false ; descr=md }
+let atom md = { atomic=true ; text=md }
+let flow md = { atomic=false ; text=md }
-let format { descr } = descr
+let format { text } = text
let protect a =
- if a.atomic then a.descr else Markdown.(rm "(" <+> a.descr <+> rm ")")
+ if a.atomic then a.text else Markdown.(rm "(" <+> a.text <+> rm ")")
-let publish ~page ~name ~synopsis ~descr =
+let publish ~page ~name ~descr ~synopsis ?(details = Markdown.empty) () =
check_name name ;
check_page page name ;
- let title = Printf.sprintf "`Data` %s" name in
+ let id = Printf.sprintf "data-%s" name in
+ let title = Printf.sprintf "`DATA` %s" name in
+ let format = ref Markdown.nil in
let syntax = Markdown.fmt_block (fun fmt ->
- Format.fprintf fmt "> _%s_ ::= @[<h>%a@]"
- name Markdown.pp_text synopsis.descr
+ Format.fprintf fmt "> %a ::= %a"
+ Markdown.pp_text !format
+ Markdown.pp_text synopsis.text
) 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 content = Markdown.( par descr </> syntax </> details ) in
+ let href = Doc.publish ~page ~name:id ~title ~index:[name] content [] in
+ let link_title = Printf.sprintf "_%s_" name in
+ let link = Markdown.href ~title:link_title href in
+ format := link ; atom @@ link
let any = atom @@ Markdown.it "any"
let int = atom @@ Markdown.it "int"
@@ -97,7 +102,7 @@ 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 field (a,t) = Markdown.( escaped a <+> tt ":" <+> t.text )
let record fds =
let fields =
@@ -106,35 +111,21 @@ let record fds =
in atom @@ Markdown.(tt "{" <+> fields <+> tt "}")
type field = {
- fd_name : string ;
- fd_syntax : t ;
- fd_default : Markdown.text option ;
- fd_descr : Markdown.text ;
+ name : string ;
+ syntax : t ;
+ descr : Markdown.text ;
}
let fields ~kind (fds : field list) =
- let c_field = `Center kind in
+ let c_field = `Left kind in
let c_format = `Center "Format" in
- let c_default = `Center "Default" in
let c_descr = `Left "Description" in
- if List.for_all (fun f -> f.fd_default = None) fds then
- Markdown.table [ c_field ; c_format ; c_descr ]
- (List.map
- (fun f ->
- [ Markdown.tt f.fd_name ; format f.fd_syntax ; f.fd_descr ])
- fds)
- else
- let mk_syntax def sy = if def <> None then option sy else sy in
- let mk_default = function
- | None -> Markdown.text []
- | Some default -> default in
- Markdown.table [ c_field ; c_format ; c_default ; c_descr ]
- (List.map
- (fun f -> [
- Markdown.tt f.fd_name ;
- format @@ mk_syntax f.fd_default f.fd_syntax ;
- mk_default f.fd_default ; f.fd_descr ;
- ])
- fds)
+ Markdown.table [ c_field ; c_format ; c_descr ]
+ begin
+ List.map
+ (fun f ->
+ [ Markdown.tt f.name ; format f.syntax ; f.descr ])
+ fds
+ end
(* -------------------------------------------------------------------------- *)
diff --git a/src/plugins/server/syntax.mli b/src/plugins/server/syntax.mli
index 6b6262ffb3e..efcced7984f 100644
--- a/src/plugins/server/syntax.mli
+++ b/src/plugins/server/syntax.mli
@@ -32,7 +32,8 @@ val format : t -> Markdown.text
Extended definition, like record fields and such, must be detailed in
the description block. *)
val publish :
- page:Doc.page -> name:string -> synopsis:t -> descr:Markdown.block -> t
+ page:Doc.page -> name:string -> descr:Markdown.text ->
+ synopsis:t -> ?details:Markdown.block -> unit -> t
val any : t
val int : t (* small, non-decimal, number *)
@@ -49,12 +50,7 @@ val union : t list -> t
val option : t -> t
val record : (string * t) list -> t
-type field = {
- fd_name : string ;
- fd_syntax : t ;
- fd_default : Markdown.text option ;
- fd_descr : Markdown.text ;
-}
+type field = { name : string ; syntax : t ; descr : Markdown.text }
(** Builds a table with fields column named « Kind » *)
val fields : kind:string -> field list -> Markdown.block
--
GitLab