From 1aa1f72f90d0f1e4a9bb4b570758fcb57406a24b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Loi=CC=88c=20Correnson?= <loic.correnson@cea.fr>
Date: Thu, 24 Oct 2019 16:09:03 +0200
Subject: [PATCH] [utils/markdown] use smart constructors for text
---
src/libraries/utils/markdown.ml | 6 +-
src/libraries/utils/markdown.mli | 3 +
src/plugins/markdown-report/md_gen.ml | 100 ++++++++++++--------------
src/plugins/server/data.ml | 3 +-
src/plugins/server/doc.ml | 14 ++--
src/plugins/server/syntax.ml | 60 ++++++++--------
6 files changed, 86 insertions(+), 100 deletions(-)
diff --git a/src/libraries/utils/markdown.ml b/src/libraries/utils/markdown.ml
index 2f9e3555411..58cbefe073a 100644
--- a/src/libraries/utils/markdown.ml
+++ b/src/libraries/utils/markdown.ml
@@ -97,17 +97,17 @@ let format txt = Format.kasprintf plain txt
let image ~alt ~file = [Image(alt,file)]
-let mklink ?text href =
+let href ?text href =
let txt =
match text with Some txt -> txt | None ->
let tt = match href with URL u -> u | Page p -> p | Section(_,s) -> s in
[Inline_code tt]
in [Link(txt, href)]
-let url ?text href = mklink ?text (URL href)
+let url ?text addr = href ?text (URL addr)
let link ?text ?page ?name () =
- mklink ?text @@ match page, name with
+ href ?text @@ match page, name with
| None, None -> Page ""
| Some p, None -> Page p
| None, Some a -> Section("",a)
diff --git a/src/libraries/utils/markdown.mli b/src/libraries/utils/markdown.mli
index afa491d9302..1745b1683ce 100644
--- a/src/libraries/utils/markdown.mli
+++ b/src/libraries/utils/markdown.mli
@@ -109,6 +109,9 @@ val code: string -> text
(** Image *)
val image: alt:string -> file:string -> text
+(** Href link *)
+val href: ?text:text -> href -> text
+
(** Local links *)
val link: ?text:text -> ?page:string -> ?name:string -> unit -> text
diff --git a/src/plugins/markdown-report/md_gen.ml b/src/plugins/markdown-report/md_gen.ml
index 7976815caac..b5cec960eb4 100644
--- a/src/plugins/markdown-report/md_gen.ml
+++ b/src/plugins/markdown-report/md_gen.ml
@@ -74,7 +74,7 @@ let plural l s =
let get_eva_domains () =
Extlib.filter_map
(fun (x,_) -> Dynamic.Parameter.Bool.get x ())
- (fun (x,y) -> ([Plain "option"; Bold x], plain y))
+ (fun (x,y) -> (plain "option" @ bold x), plain y)
all_eva_domains
let section_domains env =
@@ -138,7 +138,7 @@ let section_stubs env =
Printer.pp_funspec (Annotations.funspec kf) in
Block ( intro @ funspec ) :: insert_remark env anchor
in
- H4 ([Inline_code s], Some anchor) :: content)
+ H4 (code s, Some anchor) :: content)
l
in
let describe_func kf =
@@ -155,7 +155,7 @@ let section_stubs env =
Printer.pp_global (GFun (Kernel_function.get_definition kf,loc)) in
Block ( intro @ fundecl ) :: insert_remark env anchor
in
- H4 ([Inline_code name], Some anchor) :: content
+ H4 (code name, Some anchor) :: content
in
let content =
if stubbed_kf <> [] then begin
@@ -240,7 +240,7 @@ let gen_inputs env =
plain "that have been considered during the analysis \
are the following:"
);
- UL (List.map (fun x -> [Text [ Inline_code x ]]) (get_files()));
+ UL (List.map (fun x -> text @@ code x) (get_files()));
]]
let gen_config env =
@@ -339,12 +339,7 @@ let make_events_table print_kind caption events =
in
let line =
[ plain (string_of_pos_opt evt_source);
- [ Inline_code evt_message;
- Plain "(emitted by";
- Inline_code evt_plugin;
- Plain ")"
- ]
- ]
+ format "`%s` (emitted by `%s`)" evt_message evt_plugin ]
in
if print_kind then plain (kind evt_kind) :: line else line
in
@@ -412,15 +407,14 @@ let gen_section_warnings env =
[ Comment "you can comment on each individual error" ]
else
[
- Block [
- Text [Bold "Important warning:";
- Plain "Frama-C did not complete its execution ";
- Plain "successfully. Analysis results may be inaccurate.";
- Plain ((plural errs "The error") ^ " listed below must be");
- Plain "fixed first before examining other ";
- Plain "warnings and alarms."
- ];
- ];
+ Block ( text @@ glue [
+ bold "Important warning:";
+ plain "Frama-C did not complete its execution ";
+ plain "successfully. Analysis results may be inaccurate.";
+ plain ((plural errs "The error") ^ " listed below must be");
+ plain "fixed first before examining other ";
+ plain "warnings and alarms."
+ ] ) ;
make_errors_table errs
]
in
@@ -434,22 +428,20 @@ let gen_section_warnings env =
if env.is_draft then
[Comment "you can comment on each individual error"]
else
- [
- Block [
- Text [
- Plain ("The table below lists the " ^ plural warnings "warning");
- Plain "that have been emitted by the analyzer.";
- Plain "They might put additional assumptions on the relevance";
- Plain "of the analysis results and must be reviewed carefully";
- ];
- Text (
- plain "Note that this does not take into account emitted alarms:"@
- plain "they are reported in"@
- Markdown.link ~text:(plain "the next section") ~name:"alarms" ()
- )
- ];
- make_warnings_table warnings
- ]
+ [Block (
+ (text @@ glue [
+ plain ("The table below lists the " ^ plural warnings "warning");
+ plain "that have been emitted by the analyzer.";
+ plain "They might put additional assumptions on the relevance";
+ plain "of the analysis results and must be reviewed carefully";
+ ]) @
+ (text @@ glue [
+ plain "Note that this does not take into account emitted alarms:";
+ plain "they are reported in";
+ link ~text:(plain "the next section") ~name:"alarms" ()
+ ])
+ );
+ make_warnings_table warnings ]
in
error_section @
H1 (plain "Warnings", Some "warnings")
@@ -492,15 +484,13 @@ let gen_section_alarms env =
if env.is_draft then
Comment "No alarm!" :: insert_marks env anchor
else
- Block [
- Text
- [ Bold "No alarm"; Plain "was found during the analysis";
- Plain "Any execution starting from";
- Inline_code (Kernel.MainFunction.get_function_name ());
- Plain "in a context matching the one used for the analysis";
- Plain "will be immune from any undefined behavior."
- ]
- ]
+ Block (text @@ glue [
+ bold "No alarm"; plain "was found during the analysis";
+ plain "Any execution starting from";
+ code (Kernel.MainFunction.get_function_name ());
+ plain "in a context matching the one used for the analysis";
+ plain "will be immune from any undefined behavior."
+ ])
:: insert_remark env anchor
in
H1 (plain "Results of the analysis", Some anchor) :: text_content
@@ -521,18 +511,16 @@ let gen_section_alarms env =
if env.is_draft then begin
sections
end else begin
- Block [
- Text
- [ Plain ("The table below lists the " ^ alarm);
- Plain "that have been emitted during the analysis.";
- Plain "Any execution starting from";
- Inline_code (Kernel.MainFunction.get_function_name());
- Plain "in a context matching the one used for the analysis";
- Plain "will be immune from any other undefined behavior.";
- Plain "More information on each individual alarm is";
- Plain "given in the remainder of this section"
- ]
- ] ::
+ Block (text @@ glue [
+ plain ("The table below lists the " ^ alarm);
+ plain "that have been emitted during the analysis.";
+ plain "Any execution starting from";
+ code (Kernel.MainFunction.get_function_name());
+ plain "in a context matching the one used for the analysis";
+ plain "will be immune from any other undefined behavior.";
+ plain "More information on each individual alarm is";
+ plain "given in the remainder of this section"
+ ]) ::
Table { content; caption; header } ::
sections
end
diff --git a/src/plugins/server/data.ml b/src/plugins/server/data.ml
index c81c5ab623b..99b3bca1693 100644
--- a/src/plugins/server/data.ml
+++ b/src/plugins/server/data.ml
@@ -513,8 +513,7 @@ struct
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 ])
+ (fun (_,tag,descr) -> [ format "`%S`" tag ; descr ])
E.values
in
Table { caption; header; content }
diff --git a/src/plugins/server/doc.ml b/src/plugins/server/doc.ml
index 5db96f030f9..c54ec9e8a91 100644
--- a/src/plugins/server/doc.ml
+++ b/src/plugins/server/doc.ml
@@ -108,11 +108,9 @@ let pages_of_chapter c =
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))]]
+ Block (list (List.map
+ (fun p -> text (link ~text:(plain p.title) ~page:p.path ()))
+ (pages_of_chapter c)))]
let table_of_contents () =
table_of_chapter `Protocol @
@@ -124,7 +122,7 @@ let table_of_contents () =
let index () =
List.map
- (fun (title,entry) -> Markdown.Link(plain title, entry))
+ (fun (title,entry) -> Markdown.href ~text:(plain title) entry)
(List.sort (fun (a,_) (b,_) -> String.compare a b) !entries)
let link ~toc ~title ~href : json =
@@ -191,12 +189,12 @@ let dump ~root ?(meta=true) () =
Yojson.Basic.to_file path maindata ;
let body =
[ H1 (plain "Documentation", None);
- Block [Text [Bold "Version"; Plain Config.version]]]
+ Block (text (format "Version %s" Config.version))]
@
table_of_contents ()
@
[H2 (plain "Index", None);
- Block [UL (List.map (fun i -> [Text [i]]) (index ()))]]
+ Block (list (List.map text (index ())))]
in
let title = "Documentation" in
pp_one_page ~root ~page:"readme.md" ~title body
diff --git a/src/plugins/server/syntax.ml b/src/plugins/server/syntax.ml
index 3f69008114a..41d2b8e45ff 100644
--- a/src/plugins/server/syntax.ml
+++ b/src/plugins/server/syntax.ml
@@ -58,57 +58,54 @@ let flow md = { atomic=false ; text=md }
let text { text } = text
let protect a =
- if a.atomic then a.text else Markdown.((Plain "(") :: a.text @ [Plain ")"])
+ if a.atomic then a.text else Markdown.(plain "(" @ a.text @ plain ")")
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 href = Doc.href page id in
- let link_title = Markdown.emph name in
- let data_link = Markdown.Link(link_title, href) in
- let syntax = Markdown.(Text (
- Plain "<" :: data_link :: Plain ">" :: Plain ":=" :: synopsis.text
- )) in
- let content = Markdown.((Block [Text descr; syntax]) :: details) in
+ let dref = Doc.href page id in
+ let dlink = Markdown.href ~text:(Markdown.emph name) dref in
+ let syntax = Markdown.(glue [
+ plain "<" ; dlink ; plain ">" ; plain ":=" ; synopsis.text ]) in
+ let content = Markdown.(Block ( text descr @ text syntax ) :: details) in
let _href = Doc.publish ~page ~name:id ~title ~index:[name] content [] in
- atom [data_link]
+ atom dlink
-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 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)
+ Markdown.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 tag name = atom @@ escaped name
+let array a = atom @@ Markdown.(code "[" @ protect a @ code ", … ]")
let tuple ts =
atom @@
Markdown.(
- Inline_code "[" ::
- glue ~sep:[Inline_code ","] (List.map protect ts) @
- [Inline_code "]"])
+ code "[" @
+ glue ~sep:(code ",") (List.map protect ts) @
+ code "]"
+ )
let union ts = flow @@ Markdown.(glue ~sep:(plain "|") (List.map protect ts))
-let option t = atom @@ Markdown.(protect t @ [Inline_code "?"])
+let option t = atom @@ Markdown.(protect t @ code "?")
-let field (a,t) = Markdown.( escaped a :: Inline_code ":" :: t.text )
+let field (a,t) = Markdown.( escaped a @ code ":" @ t.text )
let record fds =
let fields =
if fds = [] then Markdown.plain "…" else
- Markdown.(glue ~sep:[Inline_code ";"] (List.map field fds))
- in atom @@ Markdown.(Inline_code "{" :: fields @ [Inline_code "}"])
+ Markdown.(glue ~sep:(code ";") (List.map field fds))
+ in atom @@ Markdown.(code "{" @ fields @ code "}")
type field = {
name : string ;
@@ -118,13 +115,14 @@ type field = {
let fields ~title (fds : field list) =
let open Markdown in
- let caption = Some (plain "Fields description") in
let header = [
plain title, Left;
plain "Format", Center;
plain "Description", Left
] in
- let field f = [[Inline_code f.name]; f.syntax.text ; f.descr] in
- Markdown.Table { caption; header; content = List.map field fds }
+ let column f = [ code f.name ; f.syntax.text ; f.descr ] in
+ Markdown.Table {
+ caption = None ; header ; content = List.map column fds ;
+ }
(* -------------------------------------------------------------------------- *)
--
GitLab