From eb6f852a99dfbca7379446cc710d9076fd42a575 Mon Sep 17 00:00:00 2001
From: Virgile Prevosto <virgile.prevosto@m4x.org>
Date: Tue, 22 Oct 2019 13:22:33 +0200
Subject: [PATCH] [library] Promote MdR markdown module as the main Frama-C
markdown lib
---
src/libraries/utils/markdown.ml | 68 ++++++++++--
src/libraries/utils/markdown.mli | 54 ++++++++--
src/plugins/markdown-report/Makefile | 2 +-
.../markdown-report/Report_markdown.mli | 100 ------------------
src/plugins/markdown-report/md_gen.ml | 16 +--
src/plugins/markdown-report/sarif.ml | 10 +-
src/plugins/markdown-report/sarif_gen.ml | 2 +-
src/plugins/server/data.ml | 26 +++--
src/plugins/server/doc.ml | 83 +++++++++------
src/plugins/server/doc.mli | 6 +-
src/plugins/server/kernel_ast.ml | 10 +-
src/plugins/server/kernel_main.ml | 35 +++---
src/plugins/server/kernel_project.ml | 16 +--
src/plugins/server/request.ml | 39 ++++---
src/plugins/server/syntax.ml | 94 ++++++++--------
src/plugins/server/syntax.mli | 4 +-
16 files changed, 288 insertions(+), 277 deletions(-)
delete mode 100644 src/plugins/markdown-report/Report_markdown.mli
diff --git a/src/libraries/utils/markdown.ml b/src/libraries/utils/markdown.ml
index 7ba2e768fe1..e1fec7d81ef 100644
--- a/src/libraries/utils/markdown.ml
+++ b/src/libraries/utils/markdown.ml
@@ -30,8 +30,8 @@ and block = block_element list
and element =
| Block of block
| Raw of string list
- (** non-markdown. Each element of the list is printed as-is on its own line.
- A blank line separates the [Raw] node from the next one. *)
+ (** non-markdown. Each element of the list is printed as-is on its own line.
+ A blank line separates the [Raw] node from the next one. *)
| Comment of string (** markdown comment, printed <!-- like this --> *)
| H1 of text * string option (** optional label. *)
| H2 of text * string option
@@ -40,19 +40,23 @@ and element =
| H5 of text * string option
| H6 of text * string option
| Table of { caption: text option; header: (text * align) list;
- content: text list list; }
+ content: text list list; }
+
+type elements = element list
type pandoc_markdown =
{ title: text;
authors: text list;
date: text;
- elements: element list
+ elements: elements
}
let plain s = [ Plain s]
let plain_format txt = Format.kasprintf plain txt
+let link_current_page sec = Section("", sec)
+
let plain_link h =
let s = match h with
| URL url -> url
@@ -67,6 +71,26 @@ let codelines lang pp code =
let lines = String.split_on_char '\n' s in
Code_block (lang, lines)
+let raw_markdown filename =
+ let chan = open_in filename in
+ let res = ref [] in
+ try
+ while true do
+ res := input_line chan :: !res;
+ done;
+ assert false
+ with End_of_file ->
+ close_in chan;
+ Raw (List.rev !res)
+
+let glue ?(sep=[]) texts =
+ let rec aux = function
+ | [] -> []
+ | [t] -> t
+ | hd::tl -> hd @ sep @ aux tl
+ in
+ aux texts
+
let id m =
let buffer = Buffer.create (String.length m) in
let lowercase = Char.lowercase_ascii in
@@ -84,6 +108,36 @@ let id m =
| _ -> ()) m ;
Buffer.contents buffer
+let section ?name ~title elements =
+ let anchor =
+ match name with
+ | None -> id title
+ | Some n -> n
+ in
+ (H1 (plain title, Some anchor)) :: elements
+
+let subsections header body =
+ let body =
+ List.map
+ (function
+ | H1(t,h) -> H2(t,h)
+ | H2(t,h) -> H3(t,h)
+ | H3(t,h) -> H4(t,h)
+ | H4(t,h) -> H5(t,h)
+ | e -> e)
+ (List.concat body)
+ in
+ header @ body
+
+let mk_date () =
+ let tm = Unix.gmtime (Unix.time()) in
+ plain
+ (Printf.sprintf "%d-%02d-%02d"
+ (1900 + tm.Unix.tm_year) (1 + tm.Unix.tm_mon) tm.Unix.tm_mday)
+
+let pandoc ?(title=plain "") ?(authors=[]) ?(date=mk_date()) elements =
+ { title; authors; date; elements }
+
let pp_href fmt = function
| URL s | Page s -> Format.pp_print_string fmt s
| Section (p,s) -> Format.fprintf fmt "%s#%s" p (id s)
@@ -116,9 +170,9 @@ let pp_dashes fmt size =
Format.fprintf fmt "%s+" dashes
let pp_sep_line fmt sizes =
-Format.fprintf fmt "@[<h>+";
-List.iter (pp_dashes fmt) sizes;
-Format.fprintf fmt "@]@\n"
+ Format.fprintf fmt "@[<h>+";
+ List.iter (pp_dashes fmt) sizes;
+ Format.fprintf fmt "@]@\n"
let pp_header fmt (t,_) size =
let real_size = test_size t in
diff --git a/src/libraries/utils/markdown.mli b/src/libraries/utils/markdown.mli
index 5580883687b..2cdef522113 100644
--- a/src/libraries/utils/markdown.mli
+++ b/src/libraries/utils/markdown.mli
@@ -30,8 +30,8 @@ and block = block_element list
and element =
| Block of block
| Raw of string list
- (** non-markdown. Each element of the list is printed as-is on its own line.
- A blank line separates the [Raw] node from the next one. *)
+ (** non-markdown. Each element of the list is printed as-is on its own line.
+ A blank line separates the [Raw] node from the next one. *)
| Comment of string (** markdown comment, printed <!-- like this --> *)
| H1 of text * string option (** optional label. *)
| H2 of text * string option
@@ -40,24 +40,64 @@ and element =
| H5 of text * string option
| H6 of text * string option
| Table of { caption: text option; header: (text * align) list;
- content: text list list; }
+ content: text list list; }
+
+type elements = element list
type pandoc_markdown =
{ title: text;
authors: text list;
date: text;
- elements: element list
+ elements: elements
}
+(** creates a document from a list of elements and optional metadatas.
+ Defaults are:
+ - title: empty
+ - authors: empty list
+ - date: current day, in ISO format
+*)
+val pandoc:
+ ?title:text -> ?authors: text list -> ?date: text -> elements ->
+ pandoc_markdown
+
+(** get the content of a file as raw markdown.
+ @raise Sys_error if there's no such file.
+*)
+val raw_markdown: string -> element
+
val plain: string -> text
val plain_format: ('a, Format.formatter, unit, text) format4 -> 'a
+(** glue text fragments. *)
+val glue: ?sep: text -> text list -> text
+
+(** transforms a string into an anchor name, roughly following
+ pandoc's conventions.
+*)
+val id: string -> string
+
+(** adds a [H1] header with the given [title] on top of the given elements.
+ If name is not explicitly provided,
+ the header will have as associated anchor [id title]
+*)
+val section: ?name:string -> title:string -> elements -> elements
+
+(** [subsections header body] returns a list of [element]s where the [body]'s
+ headers have been increased by one (i.e. [H1] becomes [H2]).
+ [H5] stays at [H5], though.
+*)
+val subsections: elements -> elements list -> elements
+
+(** returns an internal link relative to the current page *)
+val link_current_page: string -> href
+
(** gives a link whose text is the URL itself. *)
-val plain_link: string -> inline
+val plain_link: href -> inline
(** [codelines lang pp code] returns a [Code_block] for [code], written
-in [lang], as pretty-printed by [pp]. *)
+ in [lang], as pretty-printed by [pp]. *)
val codelines:
string -> (Format.formatter -> 'a -> unit) -> 'a -> block_element
@@ -71,6 +111,6 @@ val pp_block: Format.formatter -> block -> unit
val pp_element: Format.formatter -> element -> unit
-val pp_elements: Format.formatter -> element list -> unit
+val pp_elements: Format.formatter -> elements -> unit
val pp_pandoc: Format.formatter -> pandoc_markdown -> unit
diff --git a/src/plugins/markdown-report/Makefile b/src/plugins/markdown-report/Makefile
index d9b339efd9a..12c2879b68e 100644
--- a/src/plugins/markdown-report/Makefile
+++ b/src/plugins/markdown-report/Makefile
@@ -7,7 +7,7 @@ Report_markdown_VERSION:=0.1~beta
PLUGIN_NAME:=Report_markdown
PLUGIN_GENERATED:=$(PLUGIN_DIR)/mdr_version.ml
PLUGIN_CMO:=\
- markdown sarif mdr_version mdr_params parse_remarks \
+ sarif mdr_version mdr_params parse_remarks \
eva_coverage md_gen sarif_gen mdr_register
PLUGIN_NO_TEST:=true
PLUGIN_REQUIRES:=ppx_deriving ppx_deriving_yojson yojson
diff --git a/src/plugins/markdown-report/Report_markdown.mli b/src/plugins/markdown-report/Report_markdown.mli
deleted file mode 100644
index 9ba082ead85..00000000000
--- a/src/plugins/markdown-report/Report_markdown.mli
+++ /dev/null
@@ -1,100 +0,0 @@
-module Mdr_params: sig
-include Plugin.S
-
-(** Value of [-mdr-out]. *)
-module Output: Parameter_sig.String
-
-(** Value of [-mdr-gen]. *)
-module Generate: Parameter_sig.String
-
-(** Value of [-mdr-remarks]. *)
-module Remarks: Parameter_sig.String
-
-(** Value of [-mdr-flamegraph]. *)
-module FlameGraph: Parameter_sig.String
-
-(** Value of [-mdr-authors]. *)
-module Authors: Parameter_sig.String_list
-
-(** Value of [-mdr-title]. *)
-module Title: Parameter_sig.String
-
-(** Value of [-mdr-stubs]. *)
-module Stubs: Parameter_sig.String_list
-end
-module Markdown: sig
-type align = Left | Center | Right
-
-type inline =
- | Plain of string
- | Emph of string
- | Bold of string
- | Inline_code of string
- | Link of text * string (** [Link(text,url)] *)
- | Image of string * string (** [Image(alt,location)] *)
-
-and text = inline list
-
-type block_element =
- | Text of text (** single paragraph of text. *)
- | Block_quote of element list
- | UL of block list
- | OL of block list
- | DL of (text * text) list (** definition list *)
- | EL of (string option * text) list (** example list *)
- | Code_block of string * string list
-
-and block = block_element list
-
-and element =
- | Block of block
- | Raw of string list
- (** non-markdown. Each element of the list is printed as-is on its own line.
- A blank line separates the [Raw] node from the next one. *)
- | Comment of string (** markdown comment, printed <!-- like this --> *)
- | H1 of text * string option (** optional label. *)
- | H2 of text * string option
- | H3 of text * string option
- | H4 of text * string option
- | H5 of text * string option
- | H6 of text * string option
- | Table of { caption: text option; header: (text * align) list;
- content: text list list; }
-
-type pandoc_markdown =
- { title: text;
- authors: text list;
- date: text;
- elements: element list
- }
-
-val plain: string -> text
-
-val plain_format: ('a, Format.formatter, unit, text) format4 -> 'a
-
-(** gives a link whose text is the URL itself. *)
-val plain_link: string -> inline
-
-(** [codelines lang pp code] returns a [Code_block] for [code], written
-in [lang], as pretty-printed by [pp]. *)
-val codelines:
- string -> (Format.formatter -> 'a -> unit) -> 'a -> block_element
-
-val pp_inline: Format.formatter -> inline -> unit
-
-val pp_text: Format.formatter -> text -> unit
-
-val pp_block_element: Format.formatter -> block_element -> unit
-
-val pp_block: Format.formatter -> block -> unit
-
-val pp_element: Format.formatter -> element -> unit
-
-val pp_elements: Format.formatter -> element list -> unit
-
-val pp_pandoc: Format.formatter -> pandoc_markdown -> unit
-end
-module Md_gen: sig
-(** generates the report (either final or [draft] according to the flag) *)
-val gen_report: draft:bool -> unit -> unit
-end
diff --git a/src/plugins/markdown-report/md_gen.ml b/src/plugins/markdown-report/md_gen.ml
index f364f505685..b3d015cda0c 100644
--- a/src/plugins/markdown-report/md_gen.ml
+++ b/src/plugins/markdown-report/md_gen.ml
@@ -430,7 +430,8 @@ let gen_section_warnings env =
Text [
Plain "Note that this does not take into account emitted alarms:";
Plain "they are reported in";
- Link (plain "the next section", "#alarms")
+ Link (plain "the next section",
+ Markdown.link_current_page "alarms")
]
];
make_warnings_table warnings
@@ -446,7 +447,7 @@ let gen_section_alarms env =
let treat_alarm e kf s ~rank:_ alarm annot (i, sec, content) =
let kind = plain (Alarms.get_name alarm) in
let label = "Alarm-" ^ string_of_int i in
- let link = [Link (plain_format "%d" i, "#"^label)] in
+ let link = [Link (plain_format "%d" i, link_current_page label)] in
let func = plain (Kernel_function.get_name kf) in
let loc = string_of_loc (Cil_datatype.Stmt.loc s) in
let loc_text = plain loc in
@@ -543,7 +544,7 @@ let gen_section_callgraph env =
Block [
Text [
Plain "The image below shows the flamegraph (";
- plain_link "http://www.brendangregg.com/flamegraphs.html";
+ plain_link (URL "http://www.brendangregg.com/flamegraphs.html");
Plain ") for the chosen entry point."
]]
:: Block [ Text [Image ("Flamegraph visualization.", f)] ]
@@ -571,12 +572,6 @@ let gen_alarms env =
gen_section_callgraph env @
gen_section_postlude env
-let mk_date () =
- let tm = Unix.gmtime (Unix.time()) in
- plain
- (Printf.sprintf "%d-%02d-%02d"
- (1900 + tm.Unix.tm_year) (1 + tm.Unix.tm_mon) tm.Unix.tm_mday)
-
let mk_remarks is_draft =
let f = Mdr_params.Remarks.get () in
if f <> "" then Parse_remarks.get_remarks f
@@ -605,7 +600,6 @@ let gen_report ~draft:is_draft () =
end else plain title
in
let authors = List.map (fun x -> plain x) (Mdr_params.Authors.get ()) in
- let date = mk_date () in
let elements = context @ coverage @ alarms in
let elements =
if is_draft then
@@ -628,7 +622,7 @@ let gen_report ~draft:is_draft () =
"\\renewcommand{\\_}{\\discretionary{\\underscore}{}{\\underscore}}"]
:: elements
in
- let doc = { title; authors; date; elements;} in
+ let doc = Markdown.pandoc ~title ~authors elements in
try
let out = open_out (Mdr_params.Output.get()) in
let fmt = Format.formatter_of_out_channel out in
diff --git a/src/plugins/markdown-report/sarif.ml b/src/plugins/markdown-report/sarif.ml
index b6f0b7684b9..7bc383a632f 100644
--- a/src/plugins/markdown-report/sarif.ml
+++ b/src/plugins/markdown-report/sarif.ml
@@ -6,8 +6,8 @@
module type Json_type = sig
type t
- val of_yojson: Yojson.Safe.json -> t Ppx_deriving_yojson_runtime.error_or
- val to_yojson: t -> Yojson.Safe.json
+ val of_yojson: Yojson.Safe.t -> t Ppx_deriving_yojson_runtime.error_or
+ val to_yojson: t -> Yojson.Safe.t
end
module Json_dictionary(J: Json_type):
@@ -167,7 +167,7 @@ end
module Custom_properties =
Json_dictionary(struct
- type t = Yojson.Safe.json
+ type t = Yojson.Safe.t
let of_yojson x = Ok x
let to_yojson x = x
end)
@@ -808,8 +808,8 @@ sig
val warning: t
val error: t
- val to_yojson: t -> Yojson.Safe.json
- val of_yojson: Yojson.Safe.json -> (t,string) result
+ val to_yojson: t -> Yojson.Safe.t
+ val of_yojson: Yojson.Safe.t -> (t,string) result
end
=
struct
diff --git a/src/plugins/markdown-report/sarif_gen.ml b/src/plugins/markdown-report/sarif_gen.ml
index ea8e9bd9b01..c87b44bf192 100644
--- a/src/plugins/markdown-report/sarif_gen.ml
+++ b/src/plugins/markdown-report/sarif_gen.ml
@@ -100,7 +100,7 @@ let gen_results remarks =
rules, List.rev content
let is_alarm = function
- | Property.IPCodeAnnot (_,_,ca) -> Extlib.has_some (Alarms.find ca)
+ | Property.(IPCodeAnnot { ica_ca }) -> Extlib.has_some (Alarms.find ica_ca)
| _ -> false
let make_ip_message ip =
diff --git a/src/plugins/server/data.ml b/src/plugins/server/data.ml
index 796f4c54dce..c81c5ab623b 100644
--- a/src/plugins/server/data.ml
+++ b/src/plugins/server/data.ml
@@ -225,7 +225,7 @@ module Jtext =
struct
include Jany
let syntax = Syntax.publish ~page:text_page ~name:"text"
- ~synopsis:Syntax.any ~descr:(Markdown.rm "Formatted text.") ()
+ ~synopsis:Syntax.any ~descr:(Markdown.plain "Formatted text.") ()
end
(* -------------------------------------------------------------------------- *)
@@ -277,13 +277,13 @@ struct
| Some v -> Fmap.add name (D.to_json v) r in
{ member ; getter ; setter }
- let fields () = Syntax.fields ~title:"Field" !fdocs
+ let fields = Syntax.fields ~title:"Field" !fdocs
let syntax =
Syntax.publish ~page:R.page ~name:R.name
~descr:R.descr
~synopsis:(Syntax.record [])
- ~details:(Markdown.mk_block fields) ()
+ ~details:[fields] ()
let of_json js =
List.fold_left
@@ -507,13 +507,17 @@ struct
) E.values
end
- let values () =
- Markdown.table
- [ `Left E.name ; `Left "Description" ]
- (List.map
- (fun (_,tag,descr) ->
- [ Markdown.tt (Printf.sprintf "%S" tag) ; descr ]
- ) E.values)
+ let values =
+ let open Markdown in
+ let caption = Some (plain "Values description") in
+ let header = [ plain E.name, Left; plain "Description", Left ] in
+ let content =
+ List.map
+ (fun (_,tag,descr) ->
+ [ [Markdown.Inline_code (Printf.sprintf "%S" tag)] ; descr ])
+ E.values
+ in
+ Table { caption; header; content }
include Collection
(struct
@@ -522,7 +526,7 @@ struct
let syntax = Syntax.publish
~page:E.page ~name:E.name
~synopsis:Syntax.ident
- ~descr:E.descr ~details:(Markdown.mk_block values) ()
+ ~descr:E.descr ~details:[values] ()
let to_json value =
register () ;
diff --git a/src/plugins/server/doc.ml b/src/plugins/server/doc.ml
index 0d141b3f018..e99ce3bd631 100644
--- a/src/plugins/server/doc.ml
+++ b/src/plugins/server/doc.ml
@@ -24,6 +24,7 @@
(* --- Server Documentation --- *)
(* -------------------------------------------------------------------------- *)
+open Markdown
type json = Yojson.Basic.t
module Senv = Server_parameters
module Pages = Map.Make(String)
@@ -36,8 +37,8 @@ type page = {
chapter : chapter ;
title : string ;
order : int ;
- intro : Markdown.section ;
- mutable sections : Markdown.section list ;
+ intro : Markdown.elements ;
+ mutable sections : Markdown.elements list ;
}
let order = ref 0
@@ -45,7 +46,7 @@ let pages : page Pages.t ref = ref Pages.empty
let plugins : string list ref = ref []
let entries : (string * Markdown.href) list ref = ref []
let path page = page.path
-let href page name : Markdown.href = `Section( page.path , name )
+let href page name : Markdown.href = Section( page.path , name )
(* -------------------------------------------------------------------------- *)
(* --- Page Collection --- *)
@@ -73,8 +74,8 @@ let page chapter ~title ~filename =
Printf.sprintf "%s/%s/server/%s" Config.datadir name filename in
let intro =
if Sys.file_exists intro
- then Markdown.read_section intro
- else Markdown.(section ~title empty []) in
+ then [Markdown.raw_markdown intro]
+ else Markdown.(section ~title []) in
let order = incr order ; !order in
let page = { order ; rootdir ; path ;
chapter ; title ; intro ;
@@ -83,8 +84,8 @@ let page chapter ~title ~filename =
let publish ~page ?name ?(index=[]) ~title content sections =
let id = match name with Some id -> id | None -> title in
- let href = `Section( page.path , id ) in
- let section = Markdown.section ?name ~title content sections in
+ let href = Section( page.path , id ) in
+ let section = Markdown.section ?name ~title (content @ sections) in
List.iter (fun entry -> entries := (entry , href) :: !entries) index ;
page.sections <- section :: page.sections ; href
@@ -105,27 +106,25 @@ let pages_of_chapter c =
(fun _ p -> if p.chapter = c then w := p :: !w) !pages ;
List.sort (fun p q -> p.order - q.order) !w
-let table_of_chapter c fmt =
- begin
- Format.fprintf fmt "## %s@\n@." (title_of_chapter c) ;
- List.iter
- (fun p -> Format.fprintf fmt " - [%s](%s)@." p.title p.path)
- (pages_of_chapter c) ;
- Format.pp_print_newline fmt () ;
- end
-
-let table_of_contents fmt =
- begin
- table_of_chapter `Protocol fmt ;
- table_of_chapter `Kernel fmt ;
- List.iter
- (fun p -> table_of_chapter (`Plugin p) fmt)
- (List.sort String.compare !plugins)
- end
+let table_of_chapter c =
+ [H2 (Markdown.plain (title_of_chapter c), None);
+ Block
+ [UL
+ (List.map
+ (fun p -> [Text [Link(Markdown.plain p.title, Page p.path)]])
+ (pages_of_chapter c))]]
+
+let table_of_contents () =
+ table_of_chapter `Protocol @
+ table_of_chapter `Kernel @
+ List.concat
+ (List.map
+ (fun p -> table_of_chapter (`Plugin p))
+ (List.sort String.compare !plugins))
let index () =
List.map
- (fun (title,entry) -> Markdown.href ~title entry)
+ (fun (title,entry) -> Markdown.Link(plain title, entry))
(List.sort (fun (a,_) (b,_) -> String.compare a b) !entries)
let link ~toc ~title ~href : json =
@@ -162,13 +161,26 @@ let metadata page : json =
(* --- Dump Documentation --- *)
(* -------------------------------------------------------------------------- *)
+let pp_one_page ~root ~page ~title body =
+ let full_path = Filepath.normalize (root ^ "/" ^ page) in
+ let dir = Filename.dirname full_path in
+ Extlib.mkdir ~parents:true dir 0o755;
+ try
+ let chan = open_out full_path in
+ let fmt = Format.formatter_of_out_channel chan in
+ let title = plain title in
+ Markdown.(pp_pandoc fmt (pandoc ~title body))
+ with Sys_error e ->
+ Senv.fatal "Could not open file %s for writing: %s" full_path e
+
let dump ~root ?(meta=true) () =
begin
Pages.iter
(fun path page ->
Senv.feedback "[doc] Page: '%s'" path ;
let body = Markdown.subsections page.intro (List.rev page.sections) in
- Markdown.dump ~root ~page:path (Markdown.document body) ;
+ let title = page.title in
+ pp_one_page ~root ~page:path ~title body ;
if meta then
let path = Printf.sprintf "%s/%s.json" root path in
Yojson.Basic.to_file path (metadata page) ;
@@ -177,14 +189,17 @@ let dump ~root ?(meta=true) () =
if meta then
let path = Printf.sprintf "%s/readme.md.json" root in
Yojson.Basic.to_file path maindata ;
- Markdown.(dump ~root ~page:"readme.md"
- begin
- h1 "Documentation" </>
- par (bf "Version" <+> rm Config.version) </>
- fmt_block table_of_contents </>
- h2 "Index" </>
- list (index ())
- end) ;
+ let body =
+ [ H1 (plain "Documentation", None);
+ Block [Text [Bold "Version"; Plain Config.version]]]
+ @
+ table_of_contents ()
+ @
+ [H2 (plain "Index", None);
+ Block [UL (List.map (fun i -> [Text [i]]) (index ()))]]
+ in
+ let title = "Documentation" in
+ pp_one_page ~root ~page:"readme.md" ~title body
end
let () =
diff --git a/src/plugins/server/doc.mli b/src/plugins/server/doc.mli
index e204916f44b..e80db0a9a2a 100644
--- a/src/plugins/server/doc.mli
+++ b/src/plugins/server/doc.mli
@@ -56,9 +56,9 @@ val publish :
?name:string ->
?index:string list ->
title:string ->
- Markdown.block ->
- Markdown.section list ->
- href
+ Markdown.elements ->
+ Markdown.elements ->
+ Markdown.href
(** Dumps all published pages of documentations. Unless [~meta:false],
also generates METADATA for each page in
diff --git a/src/plugins/server/kernel_ast.ml b/src/plugins/server/kernel_ast.ml
index 77605bf53f3..9001f346b63 100644
--- a/src/plugins/server/kernel_ast.ml
+++ b/src/plugins/server/kernel_ast.ml
@@ -35,7 +35,7 @@ let page = Doc.page `Kernel ~title:"Ast Services" ~filename:"ast.md"
let () = Request.register ~page
~kind:`EXEC ~name:"kernel.ast.compute"
- ~descr:(Md.rm "Ensures that AST is computed")
+ ~descr:(Md.plain "Ensures that AST is computed")
~input:(module Junit) ~output:(module Junit) Ast.compute
(* -------------------------------------------------------------------------- *)
@@ -104,7 +104,7 @@ module Stmt = Data.Collection
type t = stmt
let syntax = Sy.publish ~page ~name:"stmt"
~synopsis:Sy.ident
- ~descr:(Md.rm "Code statement identifier") ()
+ ~descr:(Md.plain "Code statement identifier") ()
let to_json st = `String (Tag.of_stmt st)
let of_json js =
let id = Js.to_string js in
@@ -134,7 +134,7 @@ module Kf = Data.Collection
type t = kernel_function
let syntax = Sy.publish ~page ~name:"fct-id"
~synopsis:Sy.ident
- ~descr:(Md.rm "Function identified by its global name.") ()
+ ~descr:(Md.plain "Function identified by its global name.") ()
let to_json kf =
`String (Kernel_function.get_name kf)
let of_json js =
@@ -149,7 +149,7 @@ module Kf = Data.Collection
let () = Request.register ~page
~kind:`GET ~name:"kernel.ast.getFunctions"
- ~descr:(Md.rm "Collect all functions in the AST")
+ ~descr:(Md.plain "Collect all functions in the AST")
~input:(module Junit) ~output:(module Kf.Jlist)
begin fun () ->
let pool = ref [] in
@@ -159,7 +159,7 @@ let () = Request.register ~page
let () = Request.register ~page
~kind:`GET ~name:"kernel.ast.printFunction"
- ~descr:(Md.rm "Print the AST of a function")
+ ~descr:(Md.plain "Print the AST of a function")
~input:(module Kf) ~output:(module Jtext)
(fun kf -> Jbuffer.to_json PP.pp_global (Kernel_function.get_global kf))
diff --git a/src/plugins/server/kernel_main.ml b/src/plugins/server/kernel_main.ml
index 7448c53e42d..24bd58d36ad 100644
--- a/src/plugins/server/kernel_main.ml
+++ b/src/plugins/server/kernel_main.ml
@@ -38,15 +38,15 @@ let page = Doc.page `Kernel ~title:"Kernel Services" ~filename:"kernel.md"
let () =
let get_config = Request.signature
~page ~kind:`GET ~name:"kernel.getConfig"
- ~descr:(Md.rm "Frama-C Kernel configuration")
+ ~descr:(Md.plain "Frama-C Kernel configuration")
~input:(module Junit) () in
let result name descr =
- Request.result get_config ~name ~descr:(Md.rm descr) (module Jstring) in
+ Request.result get_config ~name ~descr:(Md.plain descr) (module Jstring) in
let set_version = result "version" "Frama-C version" in
let set_datadir = result "datadir" "Shared directory (FRAMAC_SHARE)" in
let set_libdir = result "libdir" "Lib directory (FRAMAC_LIB)" in
let set_pluginpath = Request.result get_config
- ~name:"pluginpath" ~descr:(Md.rm "Plugin directories (FRAMAC_PLUGIN)")
+ ~name:"pluginpath" ~descr:(Md.plain "Plugin directories (FRAMAC_PLUGIN)")
(module Jstring.Jlist) in
Request.register_sig get_config
begin fun rq () ->
@@ -65,9 +65,10 @@ struct
type t = Filepath.position
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.") ()
+ ~descr:(Md.plain "Source file positions.")
+ ~details:Md.([Block [Text (plain "The file path is normalized, \
+ and the line number starts at one.")]])
+ ()
let to_json p = `Assoc [
"file" , `String (p.Filepath.pos_path :> string) ;
@@ -93,14 +94,14 @@ struct
type t = Log.kind
let page = page
let name = "kind"
- let descr = Md.rm "Frama-C message category."
+ let descr = Md.plain "Frama-C message category."
let values = [
- 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" ;
+ 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" ;
]
end
@@ -117,12 +118,12 @@ struct
(struct
let page = page
let name = "log"
- let descr = Md.rm "Message event record."
+ let descr = Md.plain "Message event record."
end)
let syntax = R.syntax
- let descr = Md.rm
+ let descr = Md.plain
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)
@@ -195,12 +196,12 @@ let () =
let () = Request.register
~page ~kind:`SET ~name:"kernel.setLogs"
- ~descr:(Md.rm "Turn logs monitoring on/off")
+ ~descr:(Md.plain "Turn logs monitoring on/off")
~input:(module Jbool) ~output:(module Junit) monitor
let () = Request.register
~page ~kind:`GET ~name:"kernel.getLogs"
- ~descr:(Md.rm "Flush the last emitted logs since last call (max 100)")
+ ~descr:(Md.plain "Flush the last emitted logs since last call (max 100)")
~input:(module Junit) ~output:(module LogEvent.Jlist)
begin fun () ->
let pool = ref [] in
diff --git a/src/plugins/server/kernel_project.ml b/src/plugins/server/kernel_project.ml
index 883cea34f37..f2fd2ec4d9e 100644
--- a/src/plugins/server/kernel_project.ml
+++ b/src/plugins/server/kernel_project.ml
@@ -37,7 +37,7 @@ module ProjectInfo =
type t = Project.t
let syntax = Sy.publish ~page ~name:"project-info"
- ~descr:(Md.rm "Project informations")
+ ~descr:(Md.plain "Project informations")
~synopsis:Sy.(record[ "id",ident; "name",string; "current",boolean ])
()
@@ -63,7 +63,7 @@ struct
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.") ()
+ ~descr:(Md.plain "Request to be executed on the specified project.") ()
let of_json js =
begin
@@ -86,37 +86,37 @@ end
let () = Request.register ~page
~kind:`GET ~name:"kernel.project.getCurrent"
- ~descr:(Md.rm "Returns the current project")
+ ~descr:(Md.plain "Returns the current project")
~input:(module Junit) ~output:(module ProjectInfo)
Project.current
let () = Request.register ~page
~kind:`SET ~name:"kernel.project.setCurrent"
- ~descr:(Md.rm "Switches the current project")
+ ~descr:(Md.plain "Switches the current project")
~input:(module Jident) ~output:(module Junit)
(fun pid -> Project.(set_current (from_unique_name pid)))
let () = Request.register ~page
~kind:`GET ~name:"kernel.project.getList"
- ~descr:(Md.rm "Returns the list of all projects")
+ ~descr:(Md.plain "Returns the list of all projects")
~input:(module Junit) ~output:(module ProjectInfo.Jlist)
(fun () -> Project.fold_on_projects (fun ids p -> p :: ids) [])
let () = Request.register ~page
~kind:`GET ~name:"kernel.project.getOn"
- ~descr:(Md.rm "Execute a GET request within the given project")
+ ~descr:(Md.plain "Execute a GET request within the given project")
~input:(module ProjectRequest) ~output:(module Jany)
(ProjectRequest.process `GET)
let () = Request.register ~page
~kind:`SET ~name:"kernel.project.setOn"
- ~descr:(Md.rm "Execute a SET request within the given project")
+ ~descr:(Md.plain "Execute a SET request within the given project")
~input:(module ProjectRequest) ~output:(module Jany)
(ProjectRequest.process `SET)
let () = Request.register ~page
~kind:`EXEC ~name:"kernel.project.execOn"
- ~descr:(Md.rm "Execute an EXEC request within the given project")
+ ~descr:(Md.plain "Execute an EXEC request within the given project")
~input:(module ProjectRequest) ~output:(module Jany)
(ProjectRequest.process `EXEC)
diff --git a/src/plugins/server/request.ml b/src/plugins/server/request.ml
index 039ee9f3c3c..7c042be0849 100644
--- a/src/plugins/server/request.ml
+++ b/src/plugins/server/request.ml
@@ -144,18 +144,18 @@ let sy_output (type b) (output : b rq_output) : Syntax.t =
| Rfields _ -> Syntax.record []
(* json input documentation *)
-let doc_input (type a) (input : a rq_input) : Markdown.block =
+let doc_input (type a) (input : a rq_input) =
match input with
| Pnone -> assert false
- | Pdata _ -> Markdown.empty
- | Pfields fs -> Syntax.fields ~title:"Input" (List.rev fs)
+ | Pdata _ -> []
+ | Pfields fs -> [Syntax.fields ~title:"Input" (List.rev fs)]
(* json output syntax *)
-let doc_output (type b) (output : b rq_output) : Markdown.block =
+let doc_output (type b) (output : b rq_output) =
match output with
| Rnone -> assert false
- | Rdata _ -> Markdown.empty
- | Rfields fs -> Syntax.fields ~title:"Output" (List.rev fs)
+ | Rdata _ -> []
+ | Rfields fs -> [Syntax.fields ~title:"Output" (List.rev fs)]
(* -------------------------------------------------------------------------- *)
(* --- Multi-Parameters Requests --- *)
@@ -253,8 +253,7 @@ let result_opt (type a b) (s : (a,unit) signature) ~name ~descr
(* -------------------------------------------------------------------------- *)
let signature
- ~page ~kind ~name ~descr ?(details=Markdown.empty)
- ?input ?output () =
+ ~page ~kind ~name ~descr ?(details=[]) ?input ?output () =
check_name name ;
check_page page name ;
check_kind kind name ;
@@ -299,6 +298,7 @@ let mk_output (type b) name required (output : b rq_output) : (rq -> b -> json)
fmap_to_json rq.result)
let register_sig (type a b) (s : (a,b) signature) (process : rq -> a -> b) =
+ let open Markdown in
if s.defined then
Senv.fatal "Request '%s' is defined twice" s.name ;
let input = mk_input s.name s.defaults s.input in
@@ -309,19 +309,18 @@ let register_sig (type a b) (s : (a,b) signature) (process : rq -> a -> b) =
in
let skind = Main.string_of_kind s.kind in
let title = Printf.sprintf "`%s` %s" skind s.name in
- let synopsis =
- Markdown.table
- [`Center "Input" ; `Center "Output" ]
- [[ Syntax.format @@ sy_input s.input ;
- Syntax.format @@ sy_output s.output ]] in
+ let caption = Some s.descr in
+ let header = [ plain "Input", Center; plain "Output", Center] in
let content =
- Markdown.concat [
- Markdown.par s.descr ;
- synopsis ;
- s.details ;
- doc_input s.input ;
- doc_output s.output ;
- ] in
+ [[ Syntax.format @@ sy_input s.input ;
+ Syntax.format @@ sy_output s.output ]]
+ in
+ let synopsis = Table { caption; header; content } in
+ let content =
+ [ synopsis ; Block s.details] @
+ doc_input s.input @
+ doc_output s.output
+ in
let _ = Doc.publish ~page:s.page ~name:s.name ~title content [] in
Main.register s.kind s.name processor ;
s.defined <- true
diff --git a/src/plugins/server/syntax.ml b/src/plugins/server/syntax.ml
index 565a227cde5..fc97bc44c6f 100644
--- a/src/plugins/server/syntax.ml
+++ b/src/plugins/server/syntax.ml
@@ -58,55 +58,59 @@ let flow md = { atomic=false ; text=md }
let format { text } = text
let protect a =
- if a.atomic then a.text else Markdown.(rm "(" <+> a.text <+> rm ")")
+ if a.atomic then a.text else Markdown.((Plain "(") :: a.text @ [Plain ")"])
-let publish ~page ~name ~descr ~synopsis ?(details = Markdown.empty) () =
+let publish ~page ~name ~descr ~synopsis ?(details = []) () =
check_name name ;
check_page page name ;
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 "> %a ::= %a"
- Markdown.pp_text !format
- Markdown.pp_text synopsis.text
- ) in
- let content = Markdown.( par descr </> syntax </> details ) in
- let href = Doc.publish ~page ~name:id ~title ~index:[name] content [] in
+ let href = Doc.href page id in
let link_title = Printf.sprintf "_%s_" name in
- let link = Markdown.href ~title:link_title href in
- format := link ; atom @@ link
-
-let unit = atom @@ Markdown.rm "-"
-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 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 link = Markdown.(Link (plain link_title, href)) in
+ let syntax =
+ Markdown.(
+ Text
+ (Plain ">" :: link :: Plain "::=" :: synopsis.text))
+ in
+ let content = Markdown.((Block [Text descr; syntax]) :: details) in
+ let _href = Doc.publish ~page ~name:id ~title ~index:[name] content [] in
+ atom @@ [link]
+
+let unit = atom @@ [Markdown.Plain "-"]
+let any = atom @@ [Markdown.Emph "any"]
+let int = atom @@ [Markdown.Emph "int"]
+let ident = atom @@ [Markdown.Emph "ident"]
+let string = atom @@ [Markdown.Emph "string"]
+let number = atom @@ [Markdown.Emph "number"]
+let boolean = atom @@ [Markdown.Emph "boolean"]
+
+let escaped name =
+ Markdown.Inline_code (Printf.sprintf "'%s'" @@ String.escaped name)
+
+let tag name = atom @@ [escaped name]
+
+let array a =
+ atom @@ Markdown.(Inline_code "[" :: protect a @ [Inline_code ", … ]"])
let tuple ts =
- atom @@ Markdown.(tt "["
- <+> glue ~sep:(raw " `,` ") (List.map protect ts) <+>
- tt "]")
+ atom @@
+ Markdown.(
+ Inline_code "[" ::
+ glue ~sep:[Inline_code ","] (List.map protect ts) @
+ [Inline_code "]"])
-let union ts = flow @@ Markdown.(glue ~sep:(raw " | ") (List.map protect ts))
+let union ts = flow @@ Markdown.(glue ~sep:(plain "|") (List.map protect ts))
-let option t = atom @@ Markdown.(protect t <@> tt "?")
+let option t = atom @@ Markdown.(protect t @ [Inline_code "?"])
-let field (a,t) = Markdown.( escaped a <+> tt ":" <+> t.text )
+let field (a,t) = Markdown.( escaped a :: Inline_code ":" :: t.text )
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 "}")
+ if fds = [] then Markdown.plain "…" else
+ Markdown.(glue ~sep:[Inline_code ";"] (List.map field fds))
+ in atom @@ Markdown.(Inline_code "{" :: fields @ [Inline_code "}"])
type field = {
name : string ;
@@ -115,15 +119,15 @@ type field = {
}
let fields ~title (fds : field list) =
- let c_field = `Left title in
- let c_format = `Center "Format" in
- let c_descr = `Left "Description" in
- Markdown.table [ c_field ; c_format ; c_descr ]
- begin
- List.map
- (fun f ->
- [ Markdown.tt f.name ; format f.syntax ; f.descr ])
- fds
- end
+ let open Markdown in
+ let caption = Some (plain "Fields description") in
+ let header =
+ [plain title, Left; plain "Format", Center; plain "Description", Left]
+ in
+ let content =
+ List.map
+ (fun f -> [[Markdown.Inline_code f.name]; format f.syntax ; f.descr]) fds
+ in
+ Markdown.Table { caption; header; content }
(* -------------------------------------------------------------------------- *)
diff --git a/src/plugins/server/syntax.mli b/src/plugins/server/syntax.mli
index ff4c575e6c3..c56312909ed 100644
--- a/src/plugins/server/syntax.mli
+++ b/src/plugins/server/syntax.mli
@@ -33,7 +33,7 @@ val format : t -> Markdown.text
the description block. *)
val publish :
page:Doc.page -> name:string -> descr:Markdown.text ->
- synopsis:t -> ?details:Markdown.block -> unit -> t
+ synopsis:t -> ?details:Markdown.elements -> unit -> t
val unit : t
val any : t
@@ -54,6 +54,6 @@ type field = { name : string ; syntax : t ; descr : Markdown.text }
(** Builds a table with fields column named with [~title]
(shall be capitalized) *)
-val fields : title:string -> field list -> Markdown.block
+val fields : title:string -> field list -> Markdown.element
(* -------------------------------------------------------------------------- *)
--
GitLab