1 (* Implementation of the site building blocks. The API and its rationale are 2 documented in ui.mli; comments here cover implementation choices only. 3 4 Attribute order is deliberate and load-bearing for readability of the 5 rendered HTML: id, then href, then class, then ARIA. Keeping it uniform means 6 a page's markup diffs cleanly when a block changes. *) 7 8 open Dream_html 9 10 type node = Dream_html.node 11 12 let classes parts = 13 parts |> List.filter (fun part -> part <> "") |> String.concat " " 14 15 (* Optional attributes collapse to the empty list so they can be concatenated 16 unconditionally at each call site. *) 17 let opt_id = function None -> [] | Some value -> [ HTML.id "%s" value ] 18 let opt_class = function None -> [] | Some value -> [ HTML.class_ "%s" value ] 19 let opt_aria_label = function None -> [] | Some v -> [ Aria.label "%s" v ] 20 let flag_current = function false -> [] | true -> [ Aria.current `page ] 21 let flag_open = function false -> [] | true -> HTML.[ open_ ] 22 23 (* Text and grouping *) 24 25 let nothing = HTML.null [] 26 let text value = txt "%s" value 27 let group nodes = HTML.null nodes 28 29 (* Inline *) 30 31 let inline ?class_ ?(decorative = false) children = 32 let hidden = if decorative then [ Aria.hidden true ] else [] in 33 HTML.span (opt_class class_ @ hidden) children 34 35 let inline_text ?class_ ?decorative value = 36 inline ?class_ ?decorative [ text value ] 37 38 (* Links *) 39 40 let link ?id ?class_ ?label ~href children = 41 HTML.a 42 (opt_id id 43 @ [ HTML.href "%s" href ] 44 @ opt_class class_ @ opt_aria_label label) 45 children 46 47 let text_link ?id ?class_ ?label ~href value = 48 link ?id ?class_ ?label ~href [ text value ] 49 50 (* Images *) 51 52 let image ?class_ ?alt ~src () = 53 let describe = 54 match alt with 55 | Some value -> [ HTML.alt "%s" value ] 56 (* An empty alt alone is enough for most readers, but the explicit 57 presentation role removes any doubt. *) 58 | None -> [ HTML.alt ""; HTML.role `presentation ] 59 in 60 HTML.img ((HTML.src "%s" src :: describe) @ opt_class class_) 61 62 (* Blocks *) 63 64 let block ?id ?class_ children = 65 HTML.div (opt_id id @ opt_class class_) children 66 67 let region ?id ?class_ children = 68 HTML.section (opt_id id @ opt_class class_) children 69 70 let paragraph ?class_ children = HTML.p (opt_class class_) children 71 let paragraph_text ?class_ value = paragraph ?class_ [ text value ] 72 73 let heading ?id ?(level = 1) ?class_ children = 74 let element = 75 match level with 76 | 1 -> HTML.h1 77 | 2 -> HTML.h2 78 | 3 -> HTML.h3 79 | 4 -> HTML.h4 80 | 5 -> HTML.h5 81 | _ -> HTML.h6 82 in 83 element (opt_id id @ opt_class class_) children 84 85 let code_block ?class_ children = 86 (* Pre-serialize the entire <code> block into a single raw text node placed 87 directly inside <pre>. This prevents the pretty-printer from injecting 88 visible whitespace between the <pre> open tag and the code content. 89 Dream_html.to_string appends a newline after each element; strip those to 90 avoid spurious line breaks between inline spans. *) 91 let raw_content = 92 children 93 |> List.map (fun node -> 94 let s = Dream_html.to_string node in 95 if String.length s > 0 && s.[String.length s - 1] = '\n' then 96 String.sub s 0 (String.length s - 1) 97 else s) 98 |> String.concat "" 99 in 100 HTML.pre (opt_class class_) [ txt ~raw:true "<code>%s</code>" raw_content ] 101 102 (* Lists *) 103 104 let items ?id ?class_ children = HTML.ul (opt_id id @ opt_class class_) children 105 106 let ordered_items ?id ?class_ children = 107 HTML.ol (opt_id id @ opt_class class_) children 108 109 let item ?class_ ?(current = false) children = 110 HTML.li (opt_class class_ @ flag_current current) children 111 112 let items_of ?id ?class_ render values = 113 items ?id ?class_ (List.map render values) 114 115 let code_inline ?class_ value = HTML.code (opt_class class_) [ text value ] 116 117 (* Badges *) 118 119 let badge ?(base_class = "badge") ?variant ?href value = 120 let classes = 121 match variant with 122 | None -> base_class 123 | Some variant -> Printf.sprintf "%s %s-%s" base_class base_class variant 124 in 125 (* Only the text is linked: a link wrapping the whole badge would make its 126 padding clickable, which reads as a button rather than a label. *) 127 let body = 128 match href with 129 | None -> [ text value ] 130 | Some href -> [ link ~href [ text value ] ] 131 in 132 inline ~class_:classes body 133 134 (* Time *) 135 136 let timestamp ~machine display = 137 HTML.time [ HTML.datetime "%s" machine ] [ text display ] 138 139 (* Definition lists *) 140 141 let definitions ?class_ pairs = 142 (* dt and dd are siblings, not nested, so each pair becomes a flat group. *) 143 let entry (term, description) = 144 group [ HTML.dt [] [ text term ]; HTML.dd [] description ] 145 in 146 HTML.dl (opt_class class_) (List.map entry pairs) 147 148 (* Disclosure *) 149 150 let chevron ?(class_ = "tree-chevron") () = 151 inline ~class_ ~decorative:true [ text "\xe2\x80\xba" ] 152 153 let disclosure ?id ?class_ ?(expanded = false) ?summary_class ~summary children 154 = 155 HTML.details 156 (opt_id id @ opt_class class_ @ flag_open expanded) 157 (HTML.summary (opt_class summary_class) summary :: children) 158 159 let css_toggle ~id:toggle_id ~toggle_class ~control_class ~label:control_label 160 ~glyph () = 161 group 162 [ 163 HTML.input 164 [ 165 HTML.type_ "checkbox"; 166 HTML.id "%s" toggle_id; 167 HTML.class_ "%s" toggle_class; 168 ]; 169 HTML.label 170 [ 171 HTML.for_ "%s" toggle_id; 172 HTML.class_ "%s" control_class; 173 Aria.label "%s" control_label; 174 ] 175 [ text glyph ]; 176 ] 177 178 (* Table of contents *) 179 180 type toc_entry = { 181 toc_href : string; 182 toc_label : string; 183 toc_children : toc_entry list; 184 } 185 186 let toc_entry ?(children = []) ~href label = 187 { toc_href = href; toc_label = label; toc_children = children } 188 189 let rec toc_items entries = 190 items ~class_:"toc-list" 191 (List.map 192 (fun { toc_href; toc_label; toc_children } -> 193 let nested = 194 match toc_children with [] -> [] | kids -> [ toc_items kids ] 195 in 196 item (text_link ~href:toc_href toc_label :: nested)) 197 entries) 198 199 let toc ?class_ ~title entries = 200 let rec count = function 201 | [] -> 0 202 | e :: rest -> 1 + count e.toc_children + count rest 203 in 204 match entries with 205 | [] -> nothing 206 | _ when count entries < 2 -> nothing 207 | _ -> 208 let outer_class = classes [ "toc"; Option.value class_ ~default:"" ] in 209 disclosure ~class_:outer_class ~summary_class:"toc-summary" 210 ~summary:[ text title ] 211 [ toc_items entries ] 212 213 (* Trees *) 214 215 let tree_leaf ?(modifier = "") ~href label = 216 item ~class_:(classes [ "tree-file"; modifier ]) [ text_link ~href label ] 217 218 let tree_branch ?(modifier = "") ?(expanded = false) ~href label children = 219 item 220 ~class_:(classes [ "tree-dir"; modifier ]) 221 [ 222 disclosure ~expanded ~summary_class:"tree-toggle" 223 ~summary:[ chevron (); text_link ~class_:"tree-link" ~href label ] 224 [ items ~class_:"tree-nested" children ]; 225 ] 226 227 let tree_overflow ?(class_ = "tree-overflow") ~href label = 228 item ~class_ [ text_link ~href label ] 229 230 (* Breadcrumbs *) 231 232 type crumb = { crumb_text : string; crumb_href : string option } 233 234 let crumb ?href text = { crumb_text = text; crumb_href = href } 235 236 let breadcrumb ?id ?class_ ?link_class ?separator_class 237 ?(separator_decorative = false) ~separator crumbs = 238 (* The separator precedes every crumb but the first, so the trail has no 239 leading or trailing delimiter. *) 240 let render index { crumb_text; crumb_href } = 241 let body = 242 match crumb_href with 243 | Some href -> text_link ?class_:link_class ~href crumb_text 244 | None -> inline_text ?class_:link_class crumb_text 245 in 246 if index = 0 then body 247 else 248 group 249 [ 250 inline_text ?class_:separator_class ~decorative:separator_decorative 251 separator; 252 body; 253 ] 254 in 255 HTML.span (opt_id id @ opt_class class_) (List.mapi render crumbs) 256 257 (* Navigation *) 258 259 type nav_link = { nav_href : string; nav_text : string; nav_current : bool } 260 261 let nav_link ?(current = false) ~href text = 262 { nav_href = href; nav_text = text; nav_current = current } 263 264 let navigation ?id ?class_ ~label children = 265 HTML.nav (opt_id id @ opt_class class_ @ [ Aria.label "%s" label ]) children 266 267 let nav_links ?id ?class_ ?item_class links = 268 (* aria-current goes on the list item rather than the link so the marker 269 survives styling the item as the highlighted row. *) 270 let render { nav_href; nav_text; nav_current } = 271 item ?class_:item_class ~current:nav_current 272 [ text_link ~href:nav_href nav_text ] 273 in 274 items ?id ?class_ (List.map render links) 275 276 (* Toolbars *) 277 278 let toolbar ?id ?class_ ?label children = 279 match children with 280 | [] -> nothing 281 | _ -> 282 HTML.div 283 (opt_id id @ opt_class class_ 284 @ [ HTML.role `toolbar ] 285 @ opt_aria_label label) 286 children 287 288 let button_link ?(class_ = "toolbar-button") ?label ~href text = 289 text_link ~class_ ?label ~href text 290 291 let dismissible ?(class_ = "toolbar-filter") 292 ?(dismiss_class = "toolbar-dismiss") ~value_class ~dismiss_href 293 ~dismiss_label value = 294 inline ~class_ 295 [ 296 inline_text ~class_:value_class value; 297 text_link ~class_:dismiss_class ~label:dismiss_label ~href:dismiss_href 298 "\xc3\x97"; 299 ] 300 301 (* Pagination *) 302 303 let pagination ?(label = "Pagination") ?(previous_text = "<") ?(next_text = ">") 304 ?(previous_label = "Previous page") ?(next_label = "Next page") 305 ?previous_href ?next_href page_number = 306 (* An unavailable neighbour still occupies its slot, so the page number does 307 not shift horizontally as the reader moves through the list. *) 308 let control href_opt glyph control_label = 309 match href_opt with 310 | Some href -> 311 text_link ~class_:"pagination-btn" ~label:control_label ~href glyph 312 | None -> 313 inline_text ~class_:"pagination-btn pagination-disabled" 314 ~decorative:true glyph 315 in 316 navigation ~class_:"toolbar-pagination" ~label 317 [ 318 control previous_href previous_text previous_label; 319 HTML.span 320 [ HTML.class_ "pagination-page"; Aria.current `page ] 321 [ text (string_of_int page_number) ]; 322 control next_href next_text next_label; 323 ] 324 325 (* Code *) 326 327 let numbered_lines ?id ?class_ ?(anchor_prefix = "") render_line lines = 328 let numbered_line index line = 329 let number = index + 1 in 330 let name = Printf.sprintf "%s%d" anchor_prefix number in 331 [ 332 HTML.a 333 [ 334 HTML.id "%s" name; 335 HTML.class_ "line-anchor"; 336 HTML.href "#%s" name; 337 Aria.label "Line %d" number; 338 ] 339 [ text (string_of_int number) ]; 340 HTML.span [ HTML.class_ "line" ] (render_line line); 341 ] 342 in 343 block ?id ?class_ (List.mapi numbered_line lines |> List.concat) 344 345 let code_listing ?id ?class_ ?anchor_prefix content = 346 (* Anchor and text alternate as siblings of one grid container, so the 347 stylesheet can align numbers against wrapping lines without a table. The 348 leading tab and trailing newline preserve the source's shape when the 349 listing is copied. *) 350 numbered_lines ?id ?class_ ?anchor_prefix 351 (fun line -> [ txt "\t%s\n" line ]) 352 (String.split_on_char '\n' content) 353 354 let highlighted_code_listing ?id ?class_ ?anchor_prefix lines = 355 (* Same grid layout as code_listing, but each line is a list of pre-rendered 356 nodes (highlighted spans) rather than plain text. The tab/newline framing 357 is identical so copy-paste behaviour is preserved. *) 358 numbered_lines ?id ?class_ ?anchor_prefix 359 (fun line_nodes -> txt "\t" :: line_nodes) 360 lines 361 362 (* Diffs *) 363 364 module Diff = struct 365 type change = Unchanged | Added | Removed 366 367 type line = { 368 before : string; 369 after : string; 370 change : change; 371 content : string; 372 } 373 374 type section = { section_heading : string; lines : line list } 375 376 type file = { 377 path : string; 378 detail : string; 379 sections : section list; 380 note : string option; 381 } 382 383 let line_node { before; after; change; content } = 384 let variant, marker, announcement = 385 match change with 386 | Unchanged -> ("context", " ", "") 387 | Added -> ("addition", "+", "Added: ") 388 | Removed -> ("deletion", "-", "Removed: ") 389 in 390 block ~class_:("diff-line " ^ variant) 391 [ 392 inline_text ~class_:"line-number" before; 393 inline_text ~class_:"line-number" after; 394 inline_text ~class_:"diff-marker" ~decorative:true marker; 395 (* Restores, for screen readers, the meaning the marker conveys 396 visually. *) 397 inline_text ~class_:"sr-only" announcement; 398 inline_text ~class_:"diff-text" content; 399 ] 400 401 let section_node { section_heading; lines } = 402 disclosure ~class_:"diff-hunk" ~expanded:true ~summary_class:"hunk-header" 403 ~summary:[ text section_heading ] 404 [ 405 (* The inner scroll container keeps long lines from widening the page. *) 406 block ~class_:"diff-lines-scroll" 407 [ block ~class_:"diff-lines" (List.map line_node lines) ]; 408 ] 409 410 let file_id index = Printf.sprintf "file-%d" (index + 1) 411 412 let file_node index { path; detail; sections; note } = 413 let body = 414 match note with 415 | Some note -> [ paragraph_text ~class_:"binary-diff" note ] 416 | None -> List.map section_node sections 417 in 418 disclosure ~class_:"diff-file" ~expanded:true 419 ~summary_class:"diff-file-header" 420 ~summary:[ text path ] 421 ~id:(file_id index) 422 (block ~class_:"diff-meta" [ text detail ] :: body) 423 424 let file_toc files = 425 toc ~class_:"diff-toc" ~title:"Changed files" 426 (List.mapi 427 (fun index { path; _ } -> toc_entry ~href:("#" ^ file_id index) path) 428 files) 429 430 let view ~empty_message = function 431 | [] -> [ paragraph_text empty_message ] 432 | files -> file_toc files :: List.mapi file_node files 433 end 434 435 (* Document scaffolding *) 436 437 let meta_viewport = 438 HTML.meta 439 [ HTML.name "viewport"; HTML.content "width=device-width, initial-scale=1" ] 440 441 let stylesheet href = HTML.link [ HTML.rel "stylesheet"; HTML.href "%s" href ] 442 443 let icon ?(media_type = "image/x-icon") href = 444 HTML.link [ HTML.rel "icon"; HTML.type_ "%s" media_type; HTML.href "%s" href ] 445 446 let deferred_script src = HTML.script [ HTML.src "%s" src; HTML.defer ] "" 447 let inline_script source = HTML.script [] "%s" source 448 449 let document_head ~title:document_title extra = 450 HTML.head [] (HTML.title [] "%s" document_title :: extra) 451 452 let skip_link ~href label = text_link ~class_:"skip-link" ~href label 453 454 let page_banner ?id ?class_ children = 455 HTML.header (opt_id id @ opt_class class_) children 456 457 let page_content ?id ?class_ children = 458 HTML.main (opt_id id @ opt_class class_) children 459 460 let page_footer ?class_ children = HTML.footer (opt_class class_) children 461 let document_body ?class_ children = HTML.body (opt_class class_) children 462 463 let document ?(lang = "en") ~head ~body () = 464 HTML.html [ HTML.lang "%s" lang ] [ head; body ] 465 466 (* Responses *) 467 468 let respond ?status page = 469 match status with 470 | None -> Dream_html.respond page 471 | Some status -> Dream_html.respond ~status page 472