diff --git a/src/libraries/utils/markdown.ml b/src/libraries/utils/markdown.ml
index c33efad4c87e22fa918cb4b654bfb74c277876b1..612c40a9019d941595cf2a3836a9149cca3e206a 100644
--- a/src/libraries/utils/markdown.ml
+++ b/src/libraries/utils/markdown.ml
@@ -25,7 +25,6 @@ type align = Left | Center | Right
type href =
| URL of string
| Page of string
- | Name of string
| Section of string * string
type inline =
@@ -84,9 +83,8 @@ let plain_link h =
| URL url -> url
| Page p -> p
| Section (_,s) -> s
- | Name a -> a
in
- Link ([Inline_code s], URL s)
+ Link ([Inline_code s], h)
let codelines lang pp code =
let s = Format.asprintf "@[%a@]" pp code in
@@ -160,32 +158,58 @@ let mk_date () =
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)
- | Name a -> Format.fprintf fmt "#%s" (id a)
+let relativize page target =
+ let page_dir = String.split_on_char '/' page in
+ let target_dir = String.split_on_char '/' target in
+ let go_up l = List.map (fun _ -> "..") l in
+ let rec remove_common l1 l2 =
+ match l1 with
+ | [] -> assert false (* split on char is always non-empty *)
+ | [_f1] -> l2
+ | d1 :: p1 ->
+ match l2 with
+ | [] -> assert false
+ | [_f2 ] ->
+ (* it's the length of the argument to go_up that matters, not
+ its exact content *)
+ go_up p1 @ l2
+ | d2 :: p2 when d2 = d1 -> remove_common p1 p2
+ | _ -> go_up p1 @ l2
+ in
+ let relative = remove_common page_dir target_dir in
+ String.concat "/" relative
+
+let pp_href ?(page="") fmt = function
+ | URL s -> Format.pp_print_string fmt s
+ | Page s -> Format.pp_print_string fmt (relativize page s)
+ | Section (p,s) -> Format.fprintf fmt "%s#%s" (relativize page p) (id s)
-let rec pp_inline fmt =
+let rec pp_inline ?page fmt =
function
| Plain s -> Format.pp_print_string fmt s
| Emph s -> Format.fprintf fmt "_%s_" (String.trim s)
| Bold s -> Format.fprintf fmt "**%s**" (String.trim s)
| Inline_code s -> Format.fprintf fmt "`%s`" (String.trim s)
| Link (text,url) ->
- Format.fprintf fmt "@[<h>[%a](%a)@]@ " pp_text text pp_href url
+ Format.fprintf fmt "@[<h>[%a](%a)@]@ "
+ (pp_text ?page) text (pp_href ?page) url
| Image (alt,url) -> Format.fprintf fmt "@[<h>@]@ " alt url
-and pp_text fmt l =
+and pp_text ?page fmt l =
match l with
| [] -> ()
- | [ elt ] -> pp_inline fmt elt
- | elt :: text -> Format.fprintf fmt "%a@ %a" pp_inline elt pp_text text
+ | [ elt ] -> pp_inline ?page fmt elt
+ | elt :: text ->
+ Format.fprintf fmt "%a@ %a" (pp_inline ?page) elt (pp_text ?page) text
let pp_lab fmt = function
| None -> ()
| Some lab -> Format.fprintf fmt " {#%s}" lab
-let test_size txt = String.length (Format.asprintf "%a" pp_text txt)
+let test_size txt =
+ (* get rid of ?page *)
+ let pp_text fmt = pp_text fmt in
+ String.length (Format.asprintf "%a" pp_text txt)
let pp_dashes fmt size =
let dashes = String.make (size + 2) '-' in
@@ -196,14 +220,14 @@ let pp_sep_line fmt sizes =
List.iter (pp_dashes fmt) sizes;
Format.fprintf fmt "@]@\n"
-let pp_header fmt (t,_) size =
+let pp_header ?page fmt (t,_) size =
let real_size = test_size t in
let spaces = String.make (size - real_size) ' ' in
- Format.fprintf fmt " %a%s |" pp_text t spaces
+ Format.fprintf fmt " %a%s |" (pp_text ?page) t spaces
-let pp_headers fmt l sizes =
+let pp_headers ?page fmt l sizes =
Format.fprintf fmt "@[<h>|";
- List.iter2 (pp_header fmt) l sizes;
+ List.iter2 (pp_header ?page fmt) l sizes;
Format.fprintf fmt "@]@\n"
let compute_sizes headers contents =
@@ -230,27 +254,29 @@ let pp_aligns fmt headers sizes =
List.iter2 (pp_align fmt) headers sizes;
Format.fprintf fmt "@]@\n"
-let pp_table_cell fmt size t =
+let pp_table_cell ?page fmt size t =
let real_size = test_size t in
let spaces = String.make (size - real_size) ' ' in
- Format.fprintf fmt " %a%s |" pp_text t spaces
+ Format.fprintf fmt " %a%s |" (pp_text ?page) t spaces
-let pp_table_line fmt sizes l =
+let pp_table_line ?page fmt sizes l =
Format.fprintf fmt "@[<h>|";
- List.iter2 (pp_table_cell fmt) sizes l;
+ List.iter2 (pp_table_cell ?page fmt) sizes l;
Format.fprintf fmt "@]@\n";
pp_sep_line fmt sizes
-let pp_table_content fmt l sizes =
+let pp_table_content ?page fmt l sizes =
Format.fprintf fmt "@[<v>";
- List.iter (pp_table_line fmt sizes) l;
+ List.iter (pp_table_line ?page fmt sizes) l;
Format.fprintf fmt "@]"
-let rec pp_block_element fmt = function
+let rec pp_block_element ?page fmt e =
+ let pp_text fmt = pp_text ?page fmt in
+ match e with
| Text t -> Format.fprintf fmt "@[<hov>%a@]@\n" pp_text t
- | Block_quote l -> pp_quote fmt l
- | UL l -> pp_list "*" fmt l
- | OL l -> pp_list "#." fmt l
+ | Block_quote l -> pp_quote ?page fmt l
+ | UL l -> pp_list "*" ?page fmt l
+ | OL l -> pp_list "#." ?page fmt l
| DL l ->
List.iter
(fun (term,def) ->
@@ -269,25 +295,29 @@ let rec pp_block_element fmt = function
List.iter (fun line -> Format.fprintf fmt "@[<h>%s@]@\n" line) lines;
Format.fprintf fmt "```@\n"
-and pp_list prefix fmt l =
+and pp_list ?page prefix fmt l =
List.iter
(fun item ->
- Format.fprintf fmt "@[<v 4>@[<hov>%s %a@]@]" prefix pp_block item)
+ Format.fprintf fmt "@[<v 4>@[<hov>%s %a@]@]"
+ prefix (pp_block ?page) item)
l
-and pp_block fmt l =
+and pp_block ?page fmt l =
match l with
- | [ elt ] -> pp_block_element fmt elt
+ | [ elt ] -> pp_block_element ?page fmt elt
| _ ->
Format.fprintf fmt "%a@\n"
- (Format.pp_print_list ~pp_sep:Format.pp_force_newline pp_block_element) l
+ (Format.pp_print_list
+ ~pp_sep:Format.pp_force_newline (pp_block_element ?page)) l
-and pp_quote fmt l =
+and pp_quote ?page fmt l =
List.iter
- (fun elt -> Format.fprintf fmt "@[<v>> %a@]" pp_element elt) l
+ (fun elt -> Format.fprintf fmt "@[<v>> %a@]" (pp_element ?page) elt) l
-and pp_element fmt = function
- | Block b -> Format.fprintf fmt "@[<v>%a@]" pp_block b
+and pp_element ?page fmt e =
+ let pp_text fmt = pp_text ?page fmt in
+ match e with
+ | Block b -> Format.fprintf fmt "@[<v>%a@]" (pp_block ?page) b
| Raw l ->
Format.(
fprintf fmt "%a"
@@ -307,29 +337,29 @@ and pp_element fmt = function
| Some t -> Format.fprintf fmt "@[<h>Table: %a@]@\n@\n" pp_text t);
let sizes = compute_sizes header content in
pp_sep_line fmt sizes;
- pp_headers fmt header sizes;
+ pp_headers ?page fmt header sizes;
pp_aligns fmt header sizes;
- pp_table_content fmt content sizes
+ pp_table_content ?page fmt content sizes
-let pp_elements fmt l =
+let pp_elements ?page fmt l =
let pp_sep fmt () =
Format.pp_print_newline fmt ();
Format.pp_print_newline fmt ()
in
- Format.pp_print_list ~pp_sep pp_element fmt l
+ Format.pp_print_list ~pp_sep (pp_element ?page) fmt l
-let pp_authors fmt l =
- List.iter (fun t -> Format.fprintf fmt "@[<h>- %a@]@\n" pp_text t) l
+let pp_authors ?page fmt l =
+ List.iter (fun t -> Format.fprintf fmt "@[<h>- %a@]@\n" (pp_text ?page) t) l
-let pp_pandoc fmt { title; authors; date; elements } =
+let pp_pandoc ?page fmt { title; authors; date; elements } =
Format.fprintf fmt "@[<v>";
if title <> [] || authors <> [] || date <> [] then begin
Format.fprintf fmt "@[<h>---@]@\n";
- Format.fprintf fmt "@[<h>title: %a@]@\n" pp_text title;
- Format.fprintf fmt "@[<h>author:@]@\n%a" pp_authors authors;
- Format.fprintf fmt "@[<h>date: %a@]@\n" pp_text date;
+ Format.fprintf fmt "@[<h>title: %a@]@\n" (pp_text ?page) title;
+ Format.fprintf fmt "@[<h>author:@]@\n%a" (pp_authors ?page) authors;
+ Format.fprintf fmt "@[<h>date: %a@]@\n" (pp_text ?page) date;
Format.fprintf fmt "@[<h>...@]@\n";
Format.pp_print_newline fmt ();
end;
- pp_elements fmt elements;
+ pp_elements ?page fmt elements;
Format.fprintf fmt "@]%!"
diff --git a/src/libraries/utils/markdown.mli b/src/libraries/utils/markdown.mli
index b23a4edf7662fb68424717a13646fa9b0d88d556..71ba39525a26465c69c37410a0d1061262421af4 100644
--- a/src/libraries/utils/markdown.mli
+++ b/src/libraries/utils/markdown.mli
@@ -23,10 +23,15 @@
type align = Left | Center | Right
type href =
- | URL of string
+ | URL of string (** uninterpreted URL *)
| Page of string
- | Name of string
- | Section of string * string
+ (** URL relative to a common root.
+ During pretty-printing, if given the path of the current
+ document, the string will be modified accordingly. For instance,
+ when writing to [foo/bar.md], [Page "foo/bla.md"] will be output as
+ [(bla.md)].
+ *)
+ | Section of string * string (** URL of an anchor within a [Page] *)
type inline =
| Plain of string
@@ -123,16 +128,16 @@ val plain_link: href -> inline
val codelines:
string -> (Format.formatter -> 'a -> unit) -> 'a -> block_element
-val pp_inline: Format.formatter -> inline -> unit
+val pp_inline: ?page:string -> Format.formatter -> inline -> unit
-val pp_text: Format.formatter -> text -> unit
+val pp_text: ?page:string -> Format.formatter -> text -> unit
-val pp_block_element: Format.formatter -> block_element -> unit
+val pp_block_element: ?page:string -> Format.formatter -> block_element -> unit
-val pp_block: Format.formatter -> block -> unit
+val pp_block: ?page:string -> Format.formatter -> block -> unit
-val pp_element: Format.formatter -> element -> unit
+val pp_element: ?page:string -> Format.formatter -> element -> unit
-val pp_elements: Format.formatter -> elements -> unit
+val pp_elements: ?page:string -> Format.formatter -> elements -> unit
-val pp_pandoc: Format.formatter -> pandoc_markdown -> unit
+val pp_pandoc: ?page:string -> Format.formatter -> pandoc_markdown -> unit
diff --git a/src/plugins/markdown-report/parse_remarks.ml b/src/plugins/markdown-report/parse_remarks.ml
index 253bd34eadced6bdbbc81aed51b622dbce441924..2cfb092e35f2252a8fa71deb782fcc5d5f199e73 100644
--- a/src/plugins/markdown-report/parse_remarks.ml
+++ b/src/plugins/markdown-report/parse_remarks.ml
@@ -66,9 +66,10 @@ let parse_line env line =
[]
| _ ->
let res = Markdown.Raw remark in
+ let page = "" in
Mdr_params.debug ~dkey
"Remark for section %s:@\n%a"
- env.current_section Markdown.pp_element res;
+ env.current_section (Markdown.pp_element ~page) res;
[res]
in
env.remarks <-
diff --git a/src/plugins/markdown-report/sarif.ml b/src/plugins/markdown-report/sarif.ml
index 46433ec05f3a33c03bf3a9ae69346fdfad6f8f13..df72f6a1f21ab9fac0a3fef50306e55aa4279ea9 100644
--- a/src/plugins/markdown-report/sarif.ml
+++ b/src/plugins/markdown-report/sarif.ml
@@ -99,8 +99,8 @@ module Message = struct
create ~text ?messageId ?arguments ()
let markdown ~markdown ?id:richMessageId ?arguments () =
- let richText =
- String.trim (Format.asprintf "@[%a@]" Markdown.pp_elements markdown)
+ let pp fmt = Markdown.pp_elements fmt in
+ let richText = String.trim (Format.asprintf "@[%a@]" pp markdown)
in
create ~richText ?richMessageId ?arguments ()
diff --git a/src/plugins/markdown-report/sarif_gen.ml b/src/plugins/markdown-report/sarif_gen.ml
index 6f9c2143b921054edc792ecab553007a68d57875..011fb79325a97818fa336b2afbab1b509e03c598 100644
--- a/src/plugins/markdown-report/sarif_gen.ml
+++ b/src/plugins/markdown-report/sarif_gen.ml
@@ -95,7 +95,8 @@ let make_message alarm annot remark =
| _ -> summary :: remark
in
let richText =
- String.trim (Format.asprintf "@[%a@]" Markdown.pp_elements markdown)
+ String.trim
+ (Format.asprintf "@[%a@]" (Markdown.pp_elements ~page:"") markdown)
in
Message.create ~text ~richText ()
diff --git a/src/plugins/server/doc.ml b/src/plugins/server/doc.ml
index 791434e1fe70fc78d0f644266b999ab933c59180..b484beb24bc61f1344ea196abaddff0844d265a4 100644
--- a/src/plugins/server/doc.ml
+++ b/src/plugins/server/doc.ml
@@ -169,7 +169,7 @@ let pp_one_page ~root ~page ~title body =
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))
+ Markdown.(pp_pandoc ~page fmt (pandoc ~title body))
with Sys_error e ->
Senv.fatal "Could not open file %s for writing: %s" full_path e