1 (** Shared document AST and renderer for prose formats. 2 3 Format-specific parsing is supplied by the {!format} type; the renderer, TOC 4 generation, and anchor management are format-independent. 5 6 Every text fragment is emitted through {!Ui}, ensuring safe escaping of 7 repository content. *) 8 9 (* {1 Document AST} *) 10 11 type inline = 12 | Text of string 13 | Code of string 14 | Verbatim of string 15 | Link of { href : string; text : string } 16 17 type block = 18 | Heading of int * string 19 | Paragraph of string 20 | Unordered_list of string list 21 | Ordered_list of string list 22 | Definition_list of (string * string) list 23 | Code_block of string option * string 24 25 type document = { 26 title : string option; 27 metadata : (string * string) list; 28 blocks : block list; 29 } 30 31 (* {1 Format interface} *) 32 33 type format = { 34 name : string; 35 css_class : string; 36 parse : string -> document; 37 inline : string -> Ui.node list; 38 } 39 (** A documentation format provides parsing and inline markup rendering. *) 40 41 (* {1 Shared utilities} *) 42 43 let first_word text = 44 match 45 String.split_on_char ' ' text |> List.filter (fun word -> word <> "") 46 with 47 | word :: _ -> Some word 48 | [] -> None 49 50 (** A continuation line belongs to the current list item if it is indented 51 (starts with whitespace) and is not blank. *) 52 let is_continuation line = 53 String.length line > 0 54 && (line.[0] = ' ' || line.[0] = '\t') 55 && String.trim line <> "" 56 57 let take_continuations rest = 58 let rec loop acc = function 59 | line :: rest when is_continuation line -> 60 loop (String.trim line :: acc) rest 61 | remaining -> (List.rev acc, remaining) 62 in 63 loop [] rest 64 65 let rec take_until close collected = function 66 | [] -> (List.rev collected, []) 67 | line :: rest when close line -> (List.rev collected, rest) 68 | line :: rest -> take_until close (line :: collected) rest 69 70 (* {1 Shared list-item classifiers} *) 71 72 (** Recognise an unordered list item ([-], [+], or indented [*]). *) 73 let unordered_item line = 74 let length = String.length line in 75 let trimmed = String.trim line in 76 let tlen = String.length trimmed in 77 if tlen >= 2 && List.mem trimmed.[0] [ '-'; '+' ] && trimmed.[1] = ' ' then 78 Some (String.sub trimmed 2 (tlen - 2) |> String.trim) 79 else if 80 tlen >= 2 81 && trimmed.[0] = '*' 82 && trimmed.[1] = ' ' 83 && length > 0 84 && (line.[0] = ' ' || line.[0] = '\t') 85 then Some (String.sub trimmed 2 (tlen - 2) |> String.trim) 86 else None 87 88 (** Recognise an ordered list item ([1.], [2)], etc.). *) 89 let ordered_item line = 90 let trimmed = String.trim line in 91 let tlen = String.length trimmed in 92 let rec digits i = 93 if i < tlen && trimmed.[i] >= '0' && trimmed.[i] <= '9' then digits (i + 1) 94 else i 95 in 96 let d = digits 0 in 97 if d = 0 || d >= tlen then None 98 else if 99 (trimmed.[d] = '.' || trimmed.[d] = ')') 100 && d + 1 < tlen 101 && trimmed.[d + 1] = ' ' 102 then Some (String.sub trimmed (d + 2) (tlen - d - 2) |> String.trim) 103 else None 104 105 (** True when a line starts a new block (blank, or a list item). *) 106 let is_boundary_common line = 107 String.trim line = "" 108 || Option.is_some (unordered_item line) 109 || Option.is_some (ordered_item line) 110 111 (* {1 Anchor generation} *) 112 113 let new_anchor () = 114 let seen = Hashtbl.create 16 in 115 fun text -> 116 let base = 117 let buffer = Buffer.create (String.length text) in 118 let pending_separator = ref false in 119 String.iter 120 (fun character -> 121 if 122 (character >= 'a' && character <= 'z') 123 || (character >= 'A' && character <= 'Z') 124 || (character >= '0' && character <= '9') 125 then ( 126 if !pending_separator && Buffer.length buffer > 0 then 127 Buffer.add_char buffer '-'; 128 pending_separator := false; 129 Buffer.add_char buffer (Char.lowercase_ascii character)) 130 else pending_separator := true) 131 text; 132 if Buffer.length buffer = 0 then "section" else Buffer.contents buffer 133 in 134 let count = Option.value (Hashtbl.find_opt seen base) ~default:0 + 1 in 135 Hashtbl.replace seen base count; 136 if count = 1 then base else Printf.sprintf "%s-%d" base count 137 138 (* {1 Rendering} *) 139 140 let render_heading anchor level text = 141 let id = anchor text in 142 Ui.heading ~id ~level ~class_:"readme-heading" 143 [ Ui.text_link ~class_:"readme-heading-link" ~href:("#" ^ id) text ] 144 145 let render_code_block language source = 146 let nodes = 147 match language with 148 | None | Some "" -> [ Ui.text source ] 149 | Some language -> 150 Highlight.Engine.highlight ~lang:(Some language) source |> List.concat 151 in 152 Ui.code_block ~class_:"readme-code-block" nodes 153 154 let render_block format anchor = function 155 | Heading (level, text) -> render_heading anchor level text 156 | Paragraph text -> 157 Ui.paragraph ~class_:"readme-paragraph" (format.inline text) 158 | Unordered_list items -> 159 Ui.items ~class_:"readme-list" 160 (List.map (fun item -> Ui.item (format.inline item)) items) 161 | Ordered_list items -> 162 Ui.ordered_items ~class_:"readme-list readme-ordered-list" 163 (List.map (fun item -> Ui.item (format.inline item)) items) 164 | Definition_list items -> 165 Ui.definitions ~class_:"readme-definition-list" 166 (List.map (fun (term, desc) -> (term, format.inline desc)) items) 167 | Code_block (language, source) -> render_code_block language source 168 169 let render_toc ~title_text body_headings = 170 let toc_anchor = new_anchor () in 171 (match title_text with Some t -> ignore (toc_anchor t) | None -> ()); 172 (* Build a nested tree from a flat (level, text) list. Headings at a deeper 173 level than the current base become children of the preceding entry. *) 174 let rec build base_level headings = 175 match headings with 176 | [] -> ([], []) 177 | (level, _) :: _ when level < base_level -> ([], headings) 178 | (level, text) :: rest -> 179 let id = toc_anchor text in 180 let children, rest' = build (level + 1) rest in 181 let entry = Ui.toc_entry ~children ~href:("#" ^ id) text in 182 let siblings, rest'' = build base_level rest' in 183 (entry :: siblings, rest'') 184 in 185 let min_level = 186 List.fold_left (fun acc (l, _) -> min acc l) max_int body_headings 187 in 188 let entries, _ = build min_level body_headings in 189 Ui.toc ~class_:"readme-toc" ~title:"Table of Contents" entries 190 191 (** Render a document using the given format. *) 192 let render format content = 193 let doc = format.parse content in 194 let body_headings = 195 List.filter_map 196 (function Heading (level, text) -> Some (level, text) | _ -> None) 197 doc.blocks 198 in 199 let toc = render_toc ~title_text:doc.title body_headings in 200 let anchor = new_anchor () in 201 let title = 202 match doc.title with 203 | None -> None 204 | Some t -> Some (render_heading anchor 1 t) 205 in 206 let metadata_node = 207 match doc.metadata with 208 | [] -> Ui.nothing 209 | entries -> 210 Ui.definitions ~class_:"readme-org-metadata" 211 (List.map 212 (fun (key, value) -> 213 (String.capitalize_ascii key, [ Ui.text value ])) 214 entries) 215 in 216 Ui.region ~class_:format.css_class 217 (Option.to_list title @ [ metadata_node; toc ] 218 @ List.map (render_block format anchor) doc.blocks) 219