linol/thirdparty/lsp/ocaml-lsp-server/vendor/cmarkit/cmarkit_html.ml

518 lines
19 KiB
OCaml

(*---------------------------------------------------------------------------
Copyright (c) 2021 The cmarkit programmers. All rights reserved.
Distributed under the ISC license, see terms at the end of the file.
---------------------------------------------------------------------------*)
open Cmarkit
module C = Cmarkit_renderer.Context
module String_set = Set.Make (String)
(* Renderer state *)
type state =
{ safe : bool;
backend_blocks : bool;
mutable ids : String_set.t;
mutable footnote_count : int;
mutable footnotes :
(* Text, id, ref count, footnote *)
(string * string * int ref * Block.Footnote.t) Label.Map.t }
let state : state C.State.t = C.State.make ()
let safe c = (C.State.get c state).safe
let backend_blocks c = (C.State.get c state).backend_blocks
let init_context ?(backend_blocks = false) ~safe c _ =
let ids = String_set.empty and footnotes = Label.Map.empty in
let st = { safe; backend_blocks; ids; footnote_count = 0; footnotes } in
C.State.set c state (Some st)
let unique_id c id =
let st = C.State.get c state in
let rec loop ids id c =
let id' = if c = 0 then id else (String.concat "-" [id; Int.to_string c]) in
match String_set.mem id' ids with
| true -> loop ids id (c + 1)
| false -> st.ids <- String_set.add id' ids; id'
in
loop st.ids id 0
let footnote_id label =
let make_label l = String.map (function ' ' | '\t' -> '-' | c -> c) l in
"fn-" ^ (make_label (String.sub label 1 (String.length label - 1)))
let footnote_ref_id fnid c = String.concat "-" ["ref"; Int.to_string c; fnid]
let make_footnote_ref_ids c label fn =
let st = C.State.get c state in
match Label.Map.find_opt label st.footnotes with
| Some (text, id, refc, _) -> incr refc; (text, id, footnote_ref_id id !refc)
| None ->
st.footnote_count <- st.footnote_count + 1;
let text = String.concat "" ["["; Int.to_string st.footnote_count;"]"] in
let id = footnote_id label in
st.footnotes <- Label.Map.add label (text, id, ref 1, fn) st.footnotes;
text, id, footnote_ref_id id 1
(* Escaping *)
let buffer_add_html_escaped_uchar b u = match Uchar.to_int u with
| 0x0000 -> Buffer.add_utf_8_uchar b Uchar.rep
| 0x0026 (* & *) -> Buffer.add_string b "&amp;"
| 0x003C (* < *) -> Buffer.add_string b "&lt;"
| 0x003E (* > *) -> Buffer.add_string b "&gt;"
(* | 0x0027 (* ' *) -> Buffer.add_string b "&apos;" *)
| 0x0022 (* '\"' *) -> Buffer.add_string b "&quot;"
| _ -> Buffer.add_utf_8_uchar b u
let html_escaped_uchar c s = buffer_add_html_escaped_uchar (C.buffer c) s
let buffer_add_html_escaped_string b s =
let string = Buffer.add_string in
let len = String.length s in
let max_idx = len - 1 in
let flush b start i =
if start < len then Buffer.add_substring b s start (i - start);
in
let rec loop start i =
if i > max_idx then flush b start i else
let next = i + 1 in
match String.get s i with
| '\x00' ->
flush b start i; Buffer.add_utf_8_uchar b Uchar.rep; loop next next
| '&' -> flush b start i; string b "&amp;"; loop next next
| '<' -> flush b start i; string b "&lt;"; loop next next
| '>' -> flush b start i; string b "&gt;"; loop next next
(* | '\'' -> flush c start i; string c "&apos;"; loop next next *)
| '\"' -> flush b start i; string b "&quot;"; loop next next
| c -> loop start next
in
loop 0 0
let html_escaped_string c s = buffer_add_html_escaped_string (C.buffer c) s
let buffer_add_pct_encoded_string b s = (* Percent encoded + HTML escaped *)
let byte = Buffer.add_char and string = Buffer.add_string in
let unsafe_hexdig_of_int i = match i < 10 with
| true -> Char.unsafe_chr (i + 0x30)
| false -> Char.unsafe_chr (i + 0x37)
in
let flush b max start i =
if start <= max then Buffer.add_substring b s start (i - start);
in
let rec loop b s max start i =
if i > max then flush b max start i else
let next = i + 1 in
match String.get s i with
| '%' (* In CommonMark destinations may have percent encoded chars *)
(* See https://tools.ietf.org/html/rfc3986 *)
(* unreserved *)
| 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '-' | '.' | '_' | '~'
(* sub-delims *)
| '!' | '$' | (*'&' | '\'' | *) '(' | ')' | '*' | '+' | ',' | ';' | '='
(* gen-delims *)
| ':' | '/' | '?' | '#' | (* '[' | ']' cmark escapes them | *) '@' ->
loop b s max start next
| '&' -> flush b max start i; string b "&amp;"; loop b s max next next
| '\'' -> flush b max start i; string b "&apos;"; loop b s max next next
| c ->
flush b max start i;
let hi = (Char.code c lsr 4) land 0xF in
let lo = (Char.code c) land 0xF in
byte b '%';
byte b (unsafe_hexdig_of_int hi);
byte b (unsafe_hexdig_of_int lo);
loop b s max next next
in
loop b s (String.length s - 1) 0 0
let pct_encoded_string c s = buffer_add_pct_encoded_string (C.buffer c) s
(* Rendering functions *)
let comment c s =
C.string c "<!-- "; html_escaped_string c s; C.string c " -->"
let comment_undefined_label c l = match Inline.Link.referenced_label l with
| None -> () | Some def -> comment c ("Undefined label " ^ (Label.key def))
let comment_unknown_def_type c l = match Inline.Link.referenced_label l with
| None -> () | Some def ->
comment c ("Unknown label definition type for " ^ (Label.key def))
let comment_foonote_image c l = match Inline.Link.referenced_label l with
| None -> () | Some def ->
comment c ("Footnote " ^ (Label.key def) ^ " referenced as image")
let block_lines c = function (* newlines only between lines *)
| [] -> () | (l, _) :: ls ->
let line c (l, _) = C.byte c '\n'; C.string c l in
C.string c l; List.iter (line c) ls
(* Inline rendering *)
let autolink c a =
let pre = if Inline.Autolink.is_email a then "mailto:" else "" in
let url = pre ^ (fst (Inline.Autolink.link a)) in
let url = if Inline.Link.is_unsafe url then "" else url in
C.string c "<a href=\""; pct_encoded_string c url; C.string c "\">";
html_escaped_string c (fst (Inline.Autolink.link a));
C.string c "</a>"
let break c b = match Inline.Break.type' b with
| `Hard -> C.string c "<br>\n"
| `Soft -> C.byte c '\n'
let code_span c cs =
C.string c "<code>";
html_escaped_string c (Inline.Code_span.code cs);
C.string c "</code>"
let emphasis c e =
C.string c "<em>"; C.inline c (Inline.Emphasis.inline e); C.string c "</em>"
let strong_emphasis c e =
C.string c "<strong>";
C.inline c (Inline.Emphasis.inline e);
C.string c "</strong>"
let link_dest_and_title c ld =
let dest = match Link_definition.dest ld with
| None -> ""
| Some (link, _) when safe c && Inline.Link.is_unsafe link -> ""
| Some (link, _) -> link
in
let title = match Link_definition.title ld with
| None -> ""
| Some title -> String.concat "\n" (List.map (fun (_, (t, _)) -> t) title)
in
dest, title
let image ?(close = " >") c i =
match Inline.Link.reference_definition (C.get_defs c) i with
| Some (Link_definition.Def (ld, _)) ->
let plain_text c i =
let lines = Inline.to_plain_text ~break_on_soft:false i in
String.concat "\n" (List.map (String.concat "") lines)
in
let link, title = link_dest_and_title c ld in
C.string c "<img src=\""; pct_encoded_string c link;
C.string c "\" alt=\"";
html_escaped_string c (plain_text c (Inline.Link.text i));
C.byte c '\"';
if title <> ""
then (C.string c " title=\""; html_escaped_string c title; C.byte c '\"');
C.string c close
| Some (Block.Footnote.Def _) -> comment_foonote_image c i
| None -> comment_undefined_label c i
| Some _ -> comment_unknown_def_type c i
let link_footnote c l fn =
let key = Label.key (Option.get (Inline.Link.referenced_label l)) in
let text, label, ref = make_footnote_ref_ids c key fn in
let is_full_ref = match Inline.Link.reference l with
| `Ref (`Full, _, _) -> true | _ -> false
in
if is_full_ref then begin
C.string c "<a href=\"#"; pct_encoded_string c label;
C.string c "\" id=\""; html_escaped_string c ref;
C.string c "\" role=\"doc-noteref\">";
C.inline c (Inline.Link.text l); C.string c "</a>"
end else begin
C.string c "<sup><a href=\"#"; pct_encoded_string c label;
C.string c "\" id=\""; html_escaped_string c ref;
C.string c "\" role=\"doc-noteref\" class=\"fn-label\">";
C.string c text; C.string c "</a></sup>"
end
let link c l = match Inline.Link.reference_definition (C.get_defs c) l with
| Some (Link_definition.Def (ld, _)) ->
let link, title = link_dest_and_title c ld in
C.string c "<a href=\""; pct_encoded_string c link;
if title <> "" then (C.string c "\" title=\""; html_escaped_string c title);
C.string c "\">"; C.inline c (Inline.Link.text l); C.string c "</a>"
| Some (Block.Footnote.Def (fn, _)) -> link_footnote c l fn
| None -> C.inline c (Inline.Link.text l); comment_undefined_label c l
| Some _ -> C.inline c (Inline.Link.text l); comment_unknown_def_type c l
let raw_html c h =
if safe c then comment c "CommonMark raw HTML omitted" else
let line c (_, (h, _)) = C.byte c '\n'; C.string c h in
if h <> []
then (C.string c (fst (snd (List.hd h))); List.iter (line c) (List.tl h))
let strikethrough c s =
C.string c "<del>";
C.inline c (Inline.Strikethrough.inline s);
C.string c "</del>"
let math_span c ms =
let tex_line c l = html_escaped_string c (Block_line.tight_to_string l) in
let tex_lines c = function (* newlines only between lines *)
| [] -> () | l :: ls ->
let line c l = C.byte c '\n'; tex_line c l in
tex_line c l; List.iter (line c) ls
in
let tex = Inline.Math_span.tex_layout ms in
if tex = [] then () else
(C.string c (if Inline.Math_span.display ms then "\\[" else "\\(");
tex_lines c tex;
C.string c (if Inline.Math_span.display ms then "\\]" else "\\)"))
let inline c = function
| Inline.Autolink (a, _) -> autolink c a; true
| Inline.Break (b, _) -> break c b; true
| Inline.Code_span (cs, _) -> code_span c cs; true
| Inline.Emphasis (e, _) -> emphasis c e; true
| Inline.Image (i, _) -> image c i; true
| Inline.Inlines (is, _) -> List.iter (C.inline c) is; true
| Inline.Link (l, _) -> link c l; true
| Inline.Raw_html (html, _) -> raw_html c html; true
| Inline.Strong_emphasis (e, _) -> strong_emphasis c e; true
| Inline.Text (t, _) -> html_escaped_string c t; true
| Inline.Ext_strikethrough (s, _) -> strikethrough c s; true
| Inline.Ext_math_span (ms, _) -> math_span c ms; true
| _ -> comment c "<!-- Unknown Cmarkit inline -->"; true
(* Block rendering *)
let block_quote c bq =
C.string c "<blockquote>\n";
C.block c (Block.Block_quote.block bq);
C.string c "</blockquote>\n"
let code_block c cb =
let i = Option.map fst (Block.Code_block.info_string cb) in
let lang = Option.bind i Block.Code_block.language_of_info_string in
let line (l, _) = html_escaped_string c l; C.byte c '\n' in
match lang with
| Some (lang, _env) when backend_blocks c && lang.[0] = '=' ->
if lang = "=html" && not (safe c)
then block_lines c (Block.Code_block.code cb) else ()
| _ ->
C.string c "<pre><code";
begin match lang with
| None -> ()
| Some (lang, _env) ->
C.string c " class=\"language-"; html_escaped_string c lang;
C.byte c '\"'
end;
C.byte c '>';
List.iter line (Block.Code_block.code cb);
C.string c "</code></pre>\n"
let heading c h =
let level = string_of_int (Block.Heading.level h) in
C.string c "<h"; C.string c level;
begin match Block.Heading.id h with
| None -> C.byte c '>';
| Some (`Auto id | `Id id) ->
let id = unique_id c id in
C.string c " id=\""; C.string c id;
C.string c "\"><a class=\"anchor\" aria-hidden=\"true\" href=\"#";
C.string c id; C.string c "\"></a>";
end;
C.inline c (Block.Heading.inline h);
C.string c "</h"; C.string c level; C.string c ">\n"
let paragraph c p =
C.string c "<p>"; C.inline c (Block.Paragraph.inline p); C.string c "</p>\n"
let item_block ~tight c = function
| Block.Blank_line _ -> ()
| Block.Paragraph (p, _) when tight -> C.inline c (Block.Paragraph.inline p)
| Block.Blocks (bs, _) ->
let rec loop c add_nl = function
| Block.Blank_line _ :: bs -> loop c add_nl bs
| Block.Paragraph (p,_) :: bs when tight ->
C.inline c (Block.Paragraph.inline p); loop c true bs
| b :: bs -> (if add_nl then C.byte c '\n'); C.block c b; loop c false bs
| [] -> ()
in
loop c true bs
| b -> C.byte c '\n'; C.block c b
let list_item ~tight c (i, _) = match Block.List_item.ext_task_marker i with
| None ->
C.string c "<li>";
item_block ~tight c (Block.List_item.block i);
C.string c "</li>\n"
| Some (mark, _) ->
C.string c "<li>";
let close = match Block.List_item.task_status_of_task_marker mark with
| `Unchecked ->
C.string c
"<div class=\"task\"><input type=\"checkbox\" disabled><div>";
"</div></div></li>\n"
| `Checked | `Other _ ->
C.string c
"<div class=\"task\"><input type=\"checkbox\" disabled checked><div>";
"</div></div></li>\n"
| `Cancelled ->
C.string c
"<div class=\"task\"><input type=\"checkbox\" disabled><del>";
"<del></div></li>\n"
in
item_block ~tight c (Block.List_item.block i);
C.string c close
let list c l =
let tight = Block.List'.tight l in
match Block.List'.type' l with
| `Unordered _ ->
C.string c "<ul>\n";
List.iter (list_item ~tight c) (Block.List'.items l);
C.string c "</ul>\n"
| `Ordered (start, _) ->
C.string c "<ol";
if start = 1 then C.string c ">\n" else
(C.string c " start=\""; C.string c (string_of_int start);
C.string c "\">\n");
List.iter (list_item ~tight c) (Block.List'.items l);
C.string c "</ol>\n"
let html_block c lines =
let line (l, _) = C.string c l; C.byte c '\n' in
if safe c then (comment c "CommonMark HTML block omitted"; C.byte c '\n') else
List.iter line lines
let thematic_break c = C.string c "<hr>\n"
let math_block c cb =
let line l = html_escaped_string c (Block_line.to_string l); C.byte c '\n' in
C.string c "\\[\n";
List.iter line (Block.Code_block.code cb);
C.string c "\\]\n"
let table c t =
let start c align tag =
C.byte c '<'; C.string c tag;
match align with
| None -> C.byte c '>';
| Some `Left -> C.string c " class=\"left\">"
| Some `Center -> C.string c " class=\"center\">"
| Some `Right -> C.string c " class=\"right\">"
in
let close c tag = C.string c "</"; C.string c tag; C.string c ">\n" in
let rec cols c tag ~align count cs = match align, cs with
| ((a, _) :: align), (col, _) :: cs ->
start c (fst a) tag; C.inline c col; close c tag;
cols c tag ~align (count - 1) cs
| ((a, _) :: align), [] ->
start c (fst a) tag; close c tag;
cols c tag ~align (count - 1) []
| [], (col, _) :: cs ->
start c None tag; C.inline c col; close c tag;
cols c tag ~align:[] (count - 1) cs
| [], [] ->
for i = count downto 1 do start c None tag; close c tag done;
in
let row c tag ~align count cs =
C.string c "<tr>\n"; cols c tag ~align count cs; C.string c "</tr>\n";
in
let header c count ~align cols = row c "th" ~align count cols in
let data c count ~align cols = row c "td" ~align count cols in
let rec rows c col_count ~align = function
| ((`Header cols, _), _) :: rs ->
let align, rs = match rs with
| ((`Sep align, _), _) :: rs -> align, rs
| _ -> align, rs
in
header c col_count ~align cols; rows c col_count ~align rs
| ((`Data cols, _), _) :: rs ->
data c col_count ~align cols; rows c col_count ~align rs
| ((`Sep align, _), _) :: rs -> rows c col_count ~align rs
| [] -> ()
in
C.string c "<div role=\"region\"><table>\n";
rows c (Block.Table.col_count t) ~align:[] (Block.Table.rows t);
C.string c "</table></div>"
let block c = function
| Block.Block_quote (bq, _) -> block_quote c bq; true
| Block.Blocks (bs, _) -> List.iter (C.block c) bs; true
| Block.Code_block (cb, _) -> code_block c cb; true
| Block.Heading (h, _) -> heading c h; true
| Block.Html_block (h, _) -> html_block c h; true
| Block.List (l, _) -> list c l; true
| Block.Paragraph (p, _) -> paragraph c p; true
| Block.Thematic_break (_, _) -> thematic_break c; true
| Block.Ext_math_block (cb, _) -> math_block c cb; true
| Block.Ext_table (t, _) -> table c t; true
| Block.Blank_line _
| Block.Link_reference_definition _
| Block.Ext_footnote_definition _ -> true
| _ -> comment c "Unknown Cmarkit block"; C.byte c '\n'; true
(* XHTML rendering *)
let xhtml_block c = function
| Block.Thematic_break _ -> C.string c "<hr />\n"; true
| b -> block c b
let xhtml_inline c = function
| Inline.Break (b, _) when Inline.Break.type' b = `Hard ->
C.string c "<br />\n"; true
| Inline.Image (i, _) ->
image ~close:" />" c i; true
| i -> inline c i
(* Document rendering *)
let footnotes c fns =
(* XXX we could do something about recursive footnotes and footnotes in
footnotes here. *)
let fns = Label.Map.fold (fun _ fn acc -> fn :: acc) fns [] in
let fns = List.sort Stdlib.compare fns in
let footnote c (_, id, refc, fn) =
C.string c "<li id=\""; html_escaped_string c id; C.string c "\">\n";
C.block c (Block.Footnote.block fn);
C.string c "<span>";
for r = 1 to !refc do
C.string c "<a href=\"#"; pct_encoded_string c (footnote_ref_id id r);
C.string c "\" role=\"doc-backlink\" class=\"fn-label\">↩︎︎";
if !refc > 1 then
(C.string c "<sup>"; C.string c (Int.to_string r); C.string c "</sup>");
C.string c "</a>"
done;
C.string c "</span>";
C.string c "</li>"
in
C.string c "<section role=\"doc-endnotes\"><ol>\n";
List.iter (footnote c) fns;
C.string c "</ol></section>\n"
let doc c d =
C.block c (Doc.block d);
let st = C.State.get c state in
if Label.Map.is_empty st.footnotes then () else footnotes c st.footnotes;
true
(* Renderer *)
let renderer ?backend_blocks ~safe () =
let init_context = init_context ?backend_blocks ~safe in
Cmarkit_renderer.make ~init_context ~inline ~block ~doc ()
let xhtml_renderer ?backend_blocks ~safe () =
let init_context = init_context ?backend_blocks ~safe in
let inline = xhtml_inline and block = xhtml_block in
Cmarkit_renderer.make ~init_context ~inline ~block ~doc ()
let of_doc ?backend_blocks ~safe d =
Cmarkit_renderer.doc_to_string (renderer ~safe ()) d
(*---------------------------------------------------------------------------
Copyright (c) 2021 The cmarkit programmers
Permission to use, copy, modify, and/or distribute this software for any
purpose with or without fee is hereby granted, provided that the above
copyright notice and this permission notice appear in all copies.
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
---------------------------------------------------------------------------*)