jon.recoil.org
this repo has no description
1(*
2 * Copyright (c) 2016 Thomas Refis <trefis@janestreet.com>
3 *
4 * Permission to use, copy, modify, and distribute this software for any
5 * purpose with or without fee is hereby granted, provided that the above
6 * copyright notice and this permission notice appear in all copies.
7 *
8 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
9 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
10 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
11 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
12 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
13 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
14 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
15 *)
16open Odoc_utils
17
18module HLink = Link
19open Odoc_document.Types
20module Html = Tyxml.Html
21module Doctree = Odoc_document.Doctree
22module Url = Odoc_document.Url
23module Link = HLink
24
25type any = Html_types.flow5
26
27type item = Html_types.flow5_without_header_footer
28
29type flow = Html_types.flow5_without_sectioning_heading_header_footer
30
31type phrasing = Html_types.phrasing
32
33type non_link_phrasing = Html_types.phrasing_without_interactive
34
35let mk_anchor_link id =
36 [ Html.a ~a:[ Html.a_href ("#" ^ id); Html.a_class [ "anchor" ] ] [] ]
37
38let mk_anchor config anchor =
39 match anchor with
40 | None -> ([], [], [])
41 | _ when Config.search_result config ->
42 (* When displaying for a search result, anchor are not added as it would
43 make no sense to add them. *)
44 ([], [], [])
45 | Some { Url.Anchor.anchor; _ } ->
46 let link = mk_anchor_link anchor in
47 let extra_attr = [ Html.a_id anchor ] in
48 let extra_class = [ "anchored" ] in
49 (extra_attr, extra_class, link)
50
51let mk_link_to_source ~config ~resolve anchor =
52 match anchor with
53 | None -> []
54 | Some url ->
55 let href = Link.href ~config ~resolve url in
56 [
57 Html.a
58 ~a:[ Html.a_href href; Html.a_class [ "source_link" ] ]
59 [ Html.txt "Source" ];
60 ]
61
62let class_ (l : Class.t) = if l = [] then [] else [ Html.a_class l ]
63
64let inline_math (s : Math.t) =
65 Html.code ~a:[ Html.a_class [ "odoc-katex-math" ] ] [ Html.txt s ]
66
67let source_text_content (t : Source.t) =
68 let buf = Buffer.create 16 in
69 let rec token (x : Source.token) =
70 match x with
71 | Elt inl ->
72 List.iter
73 (fun (one : Inline.one) ->
74 match one.desc with Inline.Text s -> Buffer.add_string buf s | _ -> ())
75 inl
76 | Tag (_, l) -> List.iter token l
77 in
78 List.iter token t;
79 Buffer.contents buf
80
81let block_math (s : Math.t) =
82 Html.pre ~a:[ Html.a_class [ "odoc-katex-math"; "display" ] ] [ Html.txt s ]
83
84and raw_markup (t : Raw_markup.t) =
85 let target, content = t in
86 match Astring.String.Ascii.lowercase target with
87 | "html" ->
88 (* This is OK because we output *textual* HTML.
89 In theory, we should try to parse the HTML with lambdasoup and rebuild
90 the HTML tree from there.
91 *)
92 [ Html.Unsafe.data content ]
93 | _ -> []
94
95and source k ?a ?mode_links (t : Source.t) =
96 let rec token (x : Source.token) =
97 match x with
98 | Elt i -> k i
99 | Tag (None, l) ->
100 let content = tokens l in
101 if content = [] then [] else [ Html.span content ]
102 | Tag (Some "mode", l) -> (
103 match mode_links with
104 | Some base_uri ->
105 let name = source_text_content l in
106 let href = base_uri ^ "#" ^ name in
107 let content = tokens l in
108 let link =
109 Html.a
110 ~a:[ Html.a_href href; Html.a_class [ "mode-link" ] ]
111 (Html.totl (Html.toeltl content))
112 in
113 Html.totl (Html.toeltl [ link ])
114 | None -> [ Html.span ~a:[ Html.a_class [ "mode" ] ] (tokens l) ])
115 | Tag (Some s, l) -> [ Html.span ~a:[ Html.a_class [ s ] ] (tokens l) ]
116 and tokens t = List.concat_map token t in
117 match tokens t with [] -> [] | l -> [ Html.code ?a l ]
118
119and styled style ~emph_level =
120 match style with
121 | `Emphasis ->
122 let a = if emph_level mod 2 = 0 then [] else [ Html.a_class [ "odd" ] ] in
123 (emph_level + 1, Html.em ~a)
124 | `Bold -> (emph_level, Html.b ~a:[])
125 | `Italic -> (emph_level, Html.i ~a:[])
126 | `Superscript -> (emph_level, Html.sup ~a:[])
127 | `Subscript -> (emph_level, Html.sub ~a:[])
128
129let rec internallink ~config ~emph_level ~resolve ?(a = []) target content
130 tooltip =
131 let a = match tooltip with Some s -> Html.a_title s :: a | None -> a in
132 let elt =
133 match target with
134 | Target.Resolved uri ->
135 let href = Link.href ~config ~resolve uri in
136 let content = inline_nolink ~emph_level content in
137 if Config.search_result config then
138 (* When displaying for a search result, links are displayed as regular
139 text. *)
140 Html.span ~a content
141 else
142 let a =
143 Html.a_href href :: (a :> Html_types.a_attrib Html.attrib list)
144 in
145 Html.a ~a content
146 | Unresolved ->
147 (* let title =
148 * Html.a_title (Printf.sprintf "unresolved reference to %S"
149 * (ref_to_string ref)
150 * in *)
151 let a = Html.a_class [ "xref-unresolved" ] :: a in
152 Html.span ~a (inline ~config ~emph_level ~resolve content)
153 in
154 [ (elt :> phrasing Html.elt) ]
155
156and inline ~config ?(emph_level = 0) ~resolve (l : Inline.t) :
157 phrasing Html.elt list =
158 let one (t : Inline.one) =
159 let a = class_ t.attr in
160 match t.desc with
161 | Text "" -> []
162 | Text s ->
163 if a = [] then [ Html.txt s ] else [ Html.span ~a [ Html.txt s ] ]
164 | Entity s ->
165 if a = [] then [ Html.entity s ] else [ Html.span ~a [ Html.entity s ] ]
166 | Linebreak -> [ Html.br ~a () ]
167 | Styled (style, c) ->
168 let emph_level, app_style = styled style ~emph_level in
169 [ app_style @@ inline ~config ~emph_level ~resolve c ]
170 | Link { content = c; _ } when Config.search_result config ->
171 (* When displaying for a search result, links are displayed as regular
172 text. *)
173 let content = inline_nolink ~emph_level c in
174 [ Html.span ~a content ]
175 | Link { target = External href; content = c; _ } ->
176 let a = (a :> Html_types.a_attrib Html.attrib list) in
177 let content = inline_nolink ~emph_level c in
178 [ Html.a ~a:(Html.a_href href :: a) content ]
179 | Link { target = Internal t; content; tooltip } ->
180 internallink ~config ~emph_level ~resolve ~a t content tooltip
181 | Source c ->
182 source (inline ~config ~emph_level ~resolve) ~a
183 ?mode_links:(Config.mode_links config) c
184 | Math s -> [ inline_math s ]
185 | Raw_markup r -> raw_markup r
186 in
187 List.concat_map one l
188
189and inline_nolink ?(emph_level = 0) (l : Inline.t) :
190 non_link_phrasing Html.elt list =
191 let one (t : Inline.one) =
192 let a = class_ t.attr in
193 match t.desc with
194 | Text "" -> []
195 | Text s ->
196 if a = [] then [ Html.txt s ] else [ Html.span ~a [ Html.txt s ] ]
197 | Entity s ->
198 if a = [] then [ Html.entity s ] else [ Html.span ~a [ Html.entity s ] ]
199 | Linebreak -> [ Html.br ~a () ]
200 | Styled (style, c) ->
201 let emph_level, app_style = styled style ~emph_level in
202 [ app_style @@ inline_nolink ~emph_level c ]
203 | Link _ -> assert false
204 | Source c -> source (inline_nolink ~emph_level) ~a c
205 | Math s -> [ inline_math s ]
206 | Raw_markup r -> raw_markup r
207 in
208 List.concat_map one l
209
210let heading ~config ~resolve (h : Heading.t) =
211 let a, anchor =
212 match h.label with
213 | Some _ when Config.search_result config ->
214 (* When displaying for a search result, anchor are not added as it would
215 make no sense to add them. *)
216 ([], [])
217 | Some id -> ([ Html.a_id id ], mk_anchor_link id)
218 | None -> ([], [])
219 in
220 let content = inline ~config ~resolve h.title in
221 let source_link = mk_link_to_source ~config ~resolve h.source_anchor in
222 let mk =
223 match h.level with
224 | 0 -> Html.h1
225 | 1 -> Html.h2
226 | 2 -> Html.h3
227 | 3 -> Html.h4
228 | 4 -> Html.h5
229 | _ -> Html.h6
230 in
231 mk ~a (anchor @ content @ source_link)
232
233let text_align = function
234 | Table.Left -> [ Html.a_style "text-align:left" ]
235 | Center -> [ Html.a_style "text-align:center" ]
236 | Right -> [ Html.a_style "text-align:right" ]
237 | Default -> []
238
239let cell_kind = function `Header -> Html.th | `Data -> Html.td
240
241let rec block ~config ~resolve (l : Block.t) : flow Html.elt list =
242 let as_flow x = (x : phrasing Html.elt list :> flow Html.elt list) in
243 let one (t : Block.one) =
244 let mk_block ?(extra_class = []) mk content =
245 let a = Some (class_ (extra_class @ t.attr)) in
246 [ mk ?a content ]
247 in
248 let mk_media_block media_block target alt =
249 let block =
250 match target with
251 | Target.External url -> media_block url alt
252 | Internal (Resolved uri) ->
253 let url = Link.href ~config ~resolve uri in
254 media_block url alt
255 | Internal Unresolved ->
256 let content = [ Html.txt alt ] in
257 let a = Html.a_class [ "xref-unresolved" ] :: [] in
258 [ Html.span ~a content ]
259 in
260 mk_block Html.div block
261 in
262 match t.desc with
263 | Inline i ->
264 if t.attr = [] then as_flow @@ inline ~config ~resolve i
265 else mk_block Html.span (inline ~config ~resolve i)
266 | Paragraph i -> mk_block Html.p (inline ~config ~resolve i)
267 | List (typ, l) ->
268 let mk = match typ with Ordered -> Html.ol | Unordered -> Html.ul in
269 mk_block mk (List.map (fun x -> Html.li (block ~config ~resolve x)) l)
270 | Table t ->
271 mk_block ~extra_class:[ "odoc-table" ]
272 (fun ?a x -> Html.table ?a x)
273 (mk_rows ~config ~resolve t)
274 | Description l ->
275 let item i =
276 let a = class_ i.Description.attr in
277 let term =
278 (inline ~config ~resolve i.Description.key
279 : phrasing Html.elt list
280 :> flow Html.elt list)
281 in
282 let def = block ~config ~resolve i.Description.definition in
283 Html.li ~a (term @ (Html.txt " " :: def))
284 in
285 mk_block Html.ul (List.map item l)
286 | Raw_markup r -> raw_markup r
287 | Verbatim s -> mk_block Html.pre [ Html.txt s ]
288 | Source (lang_tag, _classes, _data, c, output) ->
289 let extra_class = [ "language-" ^ lang_tag ] in
290 mk_block Html.div
291 ((mk_block ~extra_class Html.pre
292 (source (inline ~config ~resolve)
293 ?mode_links:(Config.mode_links config) c))
294 @ block ~config ~resolve output)
295 | Math s -> mk_block Html.div [ block_math s ]
296 | Audio (target, alt) ->
297 let audio src alt =
298 [
299 Html.audio ~src
300 ~a:[ Html.a_controls (); Html.a_aria "label" [ alt ] ]
301 [];
302 ]
303 in
304 mk_media_block audio target alt
305 | Video (target, alt) ->
306 let video src alt =
307 [
308 Html.video ~src
309 ~a:[ Html.a_controls (); Html.a_aria "label" [ alt ] ]
310 [];
311 ]
312 in
313 mk_media_block video target alt
314 | Image (target, alt) ->
315 let image src alt =
316 let img =
317 Html.a
318 ~a:[ Html.a_href src; Html.a_class [ "img-link" ] ]
319 [ Html.img ~src ~alt () ]
320 in
321 [ img ]
322 in
323 mk_media_block image target alt
324 in
325
326 List.concat_map one l
327
328and mk_rows ~config ~resolve { align; data } =
329 let mk_row row =
330 let mk_cell ~align (x, h) =
331 let a = text_align align in
332 cell_kind ~a h (block ~config ~resolve x)
333 in
334 let alignment align =
335 match align with align :: q -> (align, q) | [] -> (Table.Default, [])
336 (* Second case is for recovering from a too short alignment list. A
337 warning should have been raised when loading the doc-comment. *)
338 in
339 let acc, _align =
340 List.fold_left
341 (fun (acc, aligns) (x, h) ->
342 let align, aligns = alignment aligns in
343 let cell = mk_cell ~align (x, h) in
344 (cell :: acc, aligns))
345 ([], align) row
346 in
347 Html.tr (List.rev acc)
348 in
349 List.map mk_row data
350
351(* This coercion is actually sound, but is not currently accepted by Tyxml.
352 See https://github.com/ocsigen/tyxml/pull/265 for details
353 Can be replaced by a simple type coercion once this is fixed
354*)
355let flow_to_item : flow Html.elt list -> item Html.elt list =
356 fun x -> Html.totl @@ Html.toeltl x
357
358let div : ([< Html_types.div_attrib ], [< item ], [> Html_types.div ]) Html.star
359 =
360 Html.Unsafe.node "div"
361
362let spec_class attr = class_ ("spec" :: attr)
363
364let spec_doc_div ~config ~resolve = function
365 | [] -> []
366 | docs ->
367 let a = [ Html.a_class [ "spec-doc" ] ] in
368 [ div ~a (flow_to_item @@ block ~config ~resolve docs) ]
369
370let rec documentedSrc ~config ~resolve (t : DocumentedSrc.t) :
371 item Html.elt list =
372 let open DocumentedSrc in
373 let take_code l =
374 Doctree.Take.until l ~classify:(function
375 | Code code -> Accum code
376 | Alternative (Expansion { summary; _ }) -> Accum summary
377 | _ -> Stop_and_keep)
378 in
379 let take_descr l =
380 Doctree.Take.until l ~classify:(function
381 | Documented { attrs; anchor; code; doc; markers } ->
382 Accum
383 [ { DocumentedSrc.attrs; anchor; code = `D code; doc; markers } ]
384 | Nested { attrs; anchor; code; doc; markers } ->
385 Accum
386 [ { DocumentedSrc.attrs; anchor; code = `N code; doc; markers } ]
387 | _ -> Stop_and_keep)
388 in
389 let rec to_html t : item Html.elt list =
390 match t with
391 | [] -> []
392 | (Code _ | Alternative _) :: _ ->
393 let code, _, rest = take_code t in
394 source (inline ~config ~resolve)
395 ?mode_links:(Config.mode_links config) code
396 @ to_html rest
397 | Subpage subp :: _ -> subpage ~config ~resolve subp
398 | (Documented _ | Nested _) :: _ ->
399 let l, _, rest = take_descr t in
400 let one { DocumentedSrc.attrs; anchor; code; doc; markers } =
401 let content =
402 match code with
403 | `D code -> (inline ~config ~resolve code :> item Html.elt list)
404 | `N n -> to_html n
405 in
406 let doc =
407 match doc with
408 | [] -> []
409 | doc ->
410 let opening, closing = markers in
411 let delim s =
412 [ Html.span ~a:(class_ [ "comment-delim" ]) [ Html.txt s ] ]
413 in
414 [
415 Html.div ~a:(class_ [ "def-doc" ])
416 (delim opening @ block ~config ~resolve doc @ delim closing);
417 ]
418 in
419 let extra_attr, extra_class, link = mk_anchor config anchor in
420 let content = (content :> any Html.elt list) in
421 Html.li
422 ~a:(extra_attr @ class_ (attrs @ extra_class))
423 (link @ content @ doc)
424 in
425 Html.ol (List.map one l) :: to_html rest
426 in
427 to_html t
428
429and subpage ~config ~resolve (subp : Subpage.t) : item Html.elt list =
430 items ~config ~resolve subp.content.items
431
432and items ~config ~resolve l : item Html.elt list =
433 let rec walk_items acc (t : Item.t list) : item Html.elt list =
434 let continue_with rest elts =
435 (walk_items [@tailcall]) (List.rev_append elts acc) rest
436 in
437 match t with
438 | [] -> List.rev acc
439 | Text _ :: _ as t ->
440 let text, _, rest =
441 Doctree.Take.until t ~classify:(function
442 | Item.Text text -> Accum text
443 | _ -> Stop_and_keep)
444 in
445 let content = flow_to_item @@ block ~config ~resolve text in
446 (continue_with [@tailcall]) rest content
447 | Heading h :: rest ->
448 (continue_with [@tailcall]) rest [ heading ~config ~resolve h ]
449 | Include
450 {
451 attr;
452 anchor;
453 source_anchor;
454 doc;
455 content = { summary; status; content };
456 }
457 :: rest ->
458 let doc = spec_doc_div ~config ~resolve doc in
459 let included_html = (items content :> item Html.elt list) in
460 let a_class =
461 if List.length content = 0 then [ "odoc-include"; "shadowed-include" ]
462 else [ "odoc-include" ]
463 in
464 let content : item Html.elt list =
465 let details ~open' =
466 let open' = if open' then [ Html.a_open () ] else [] in
467 let summary =
468 let extra_attr, extra_class, anchor_link =
469 mk_anchor config anchor
470 in
471 let link_to_source =
472 mk_link_to_source ~config ~resolve source_anchor
473 in
474 let a = spec_class (attr @ extra_class) @ extra_attr in
475 Html.summary ~a @@ anchor_link @ link_to_source
476 @ source (inline ~config ~resolve)
477 ?mode_links:(Config.mode_links config) summary
478 in
479 let inner =
480 [
481 Html.details ~a:open' summary
482 (included_html :> any Html.elt list);
483 ]
484 in
485 [ Html.div ~a:[ Html.a_class a_class ] (doc @ inner) ]
486 in
487 match status with
488 | `Inline -> doc @ included_html
489 | `Closed -> details ~open':false
490 | `Open -> details ~open':true
491 | `Default -> details ~open':(Config.open_details config)
492 in
493 (continue_with [@tailcall]) rest content
494 | Declaration { Item.attr; anchor; source_anchor; content; doc } :: rest ->
495 let extra_attr, extra_class, anchor_link = mk_anchor config anchor in
496 let link_to_source = mk_link_to_source ~config ~resolve source_anchor in
497 let a = spec_class (attr @ extra_class) @ extra_attr in
498 let content =
499 anchor_link @ link_to_source @ documentedSrc ~config ~resolve content
500 in
501 let spec =
502 let doc = spec_doc_div ~config ~resolve doc in
503 [ div ~a:[ Html.a_class [ "odoc-spec" ] ] (div ~a content :: doc) ]
504 in
505 (continue_with [@tailcall]) rest spec
506 and items l = walk_items [] l in
507 items l
508
509module Toc = struct
510 open Odoc_document.Doctree
511 open Types
512
513 let on_sub : Subpage.status -> bool = function
514 | `Closed | `Open | `Default -> false
515 | `Inline -> true
516
517 let gen_toc ~config ~resolve ~path i =
518 let toc = Toc.compute path ~on_sub i in
519 let rec section { Toc.url; text; children } =
520 let text = inline_nolink text in
521 let title =
522 (text
523 : non_link_phrasing Html.elt list
524 :> Html_types.flow5_without_interactive Html.elt list)
525 in
526 let title_str =
527 List.map (Format.asprintf "%a" (Tyxml.Html.pp_elt ())) text
528 |> String.concat ~sep:""
529 in
530 let href = Link.href ~config ~resolve url in
531 { title; title_str; href; children = List.map section children }
532 in
533 List.map section toc
534end
535
536module Breadcrumbs = struct
537 open Types
538
539 let page_parent (page : Url.Path.t) =
540 let page =
541 match page with
542 | { parent = Some parent; name = "index"; kind = `LeafPage } -> parent
543 | _ -> page
544 in
545 match page with
546 | { parent = None; name = "index"; kind = `LeafPage } -> None
547 | { parent = Some parent; _ } -> Some parent
548 | { parent = None; _ } ->
549 Some { Url.Path.parent = None; name = "index"; kind = `LeafPage }
550
551 let home_breadcrumb ~home_name config ~current_path ~home_path =
552 let href =
553 Some
554 (Link.href ~config ~resolve:(Current current_path)
555 (Odoc_document.Url.from_path home_path))
556 in
557 { href; name = [ Html.txt home_name ]; kind = `LeafPage }
558
559 let gen_breadcrumbs_no_sidebar ~config ~url =
560 let url =
561 match url with
562 | { Url.Path.name = "index"; parent = Some parent; kind = `LeafPage } ->
563 parent
564 | _ -> url
565 in
566 match url with
567 | { Url.Path.name = "index"; parent = None; kind = `LeafPage } ->
568 let kind = `LeafPage in
569 let current = { href = None; name = [ Html.txt "" ]; kind } in
570 { parents = []; up_url = None; current }
571 | url -> (
572 (* This is the pre 3.0 way of computing the breadcrumbs *)
573 let rec get_parent_paths x =
574 match x with
575 | [] -> []
576 | x :: xs -> (
577 match Odoc_document.Url.Path.of_list (List.rev (x :: xs)) with
578 | Some x -> x :: get_parent_paths xs
579 | None -> get_parent_paths xs)
580 in
581 let to_breadcrumb path =
582 let href =
583 Some
584 (Link.href ~config ~resolve:(Current url)
585 (Odoc_document.Url.from_path path))
586 in
587 { href; name = [ Html.txt path.name ]; kind = path.kind }
588 in
589 let parent_paths =
590 get_parent_paths (List.rev (Odoc_document.Url.Path.to_list url))
591 |> List.rev
592 in
593 match List.rev parent_paths with
594 | [] -> assert false
595 | current :: parents ->
596 let up_url =
597 match page_parent current with
598 | None -> None
599 | Some up ->
600 Some
601 (Link.href ~config ~resolve:(Current url)
602 (Odoc_document.Url.from_path up))
603 in
604 let current = to_breadcrumb current in
605 let parents = List.map to_breadcrumb parents |> List.rev in
606 let home =
607 home_breadcrumb ~home_name:"Index" config ~current_path:url
608 ~home_path:
609 { Url.Path.name = "index"; parent = None; kind = `LeafPage }
610 in
611 { current; parents = home :: parents; up_url })
612
613 let gen_breadcrumbs_with_sidebar ~config ~sidebar ~url:current_url =
614 let find_parent =
615 List.find_opt (function
616 | ({ node = { url = { page; anchor = ""; _ }; _ }; _ } :
617 Odoc_document.Sidebar.entry Tree.t)
618 when Url.Path.is_prefix page current_url ->
619 true
620 | _ -> false)
621 in
622 let rec extract acc (tree : Odoc_document.Sidebar.t) =
623 let parent =
624 match find_parent tree with
625 | Some { node = { url; valid_link; content; _ }; children } ->
626 let href =
627 if valid_link then
628 Some (Link.href ~config ~resolve:(Current current_url) url)
629 else None
630 in
631 let name = inline_nolink content in
632 let breadcrumb = { href; name; kind = url.page.kind } in
633 if url.page = current_url then Some (`Current breadcrumb)
634 else Some (`Parent (breadcrumb, children))
635 | _ -> None
636 in
637 match parent with
638 | Some (`Parent (bc, children)) -> extract (bc :: acc) children
639 | Some (`Current current) ->
640 let up_url =
641 List.find_map (fun (b : Types.breadcrumb) -> b.href) acc
642 in
643 { Types.current; parents = List.rev acc; up_url }
644 | None ->
645 let kind = current_url.kind and name = current_url.name in
646 let current = { href = None; name = [ Html.txt name ]; kind } in
647 let up_url =
648 List.find_map (fun (b : Types.breadcrumb) -> b.href) acc
649 in
650 let parents = List.rev acc in
651 { Types.current; parents; up_url }
652 in
653 let escape =
654 match (Config.home_breadcrumb config, find_parent sidebar) with
655 | Some home_name, Some { node; _ } -> (
656 match page_parent node.url.page with
657 | None -> []
658 | Some parent ->
659 [
660 home_breadcrumb ~home_name config ~current_path:current_url
661 ~home_path:parent;
662 ])
663 | _ -> []
664 in
665 extract escape sidebar
666
667 let gen_breadcrumbs ~config ~sidebar ~url =
668 match sidebar with
669 | None -> gen_breadcrumbs_no_sidebar ~config ~url
670 | Some sidebar -> gen_breadcrumbs_with_sidebar ~config ~sidebar ~url
671end
672
673module Page = struct
674 let on_sub = function
675 | `Page _ -> None
676 | `Include x -> (
677 match x.Include.status with
678 | `Closed | `Open | `Default -> None
679 | `Inline -> Some 0)
680
681 let rec include_ ~config ~sidebar { Subpage.content; _ } =
682 page ~config ~sidebar content
683
684 and subpages ~config ~sidebar subpages =
685 List.map (include_ ~config ~sidebar) subpages
686
687 and page ~config ~sidebar p : Odoc_document.Renderer.page =
688 let { Page.preamble = _; items = i; url; source_anchor; resources; assets } =
689 Doctree.Labels.disambiguate_page ~enter_subpages:false p
690 in
691 let subpages = subpages ~config ~sidebar @@ Doctree.Subpages.compute p in
692 let resolve = Link.Current url in
693 let breadcrumbs = Breadcrumbs.gen_breadcrumbs ~config ~sidebar ~url in
694 let sidebar_html =
695 match sidebar with
696 | None -> None
697 | Some sidebar ->
698 let sidebar = Odoc_document.Sidebar.to_block sidebar url in
699 (Some (block ~config ~resolve sidebar) :> any Html.elt list option)
700 in
701 let i = Doctree.Shift.compute ~on_sub i in
702 let uses_katex = Doctree.Math.has_math_elements p in
703 let toc = Toc.gen_toc ~config ~resolve ~path:url i in
704 let content = (items ~config ~resolve i :> any Html.elt list) in
705 let header, preamble = Doctree.PageTitle.render_title ?source_anchor p in
706 let header = items ~config ~resolve header in
707 let preamble = items ~config ~resolve preamble in
708 let source_anchor =
709 match source_anchor with
710 | Some url -> Some (Link.href ~config ~resolve url)
711 | None -> None
712 in
713 let shell_name =
714 match Config.shell config with
715 | Some name -> name
716 | None -> if Config.as_json config then "json" else "default"
717 in
718 let (module Shell : Html_shell.S) =
719 match Html_shell.find shell_name with
720 | Some shell -> shell
721 | None ->
722 match Config.shell config with
723 | Some name ->
724 failwith
725 (Printf.sprintf
726 "Shell '%s' not found. Available shells: %s. \
727 Ensure the shell plugin is installed (run 'dune build \
728 @install' first)."
729 name
730 (Stdlib.String.concat ", " (Html_shell.list_shells ())))
731 | None -> Html_shell.default ()
732 in
733 Shell.make ~config
734 { url; header; preamble; content; breadcrumbs; toc;
735 sidebar = sidebar_html; sidebar_data = sidebar;
736 uses_katex; source_anchor; resources; assets; children = subpages }
737
738 and source_page ~config ~sidebar sp =
739 let { Source_page.url; contents } = sp in
740 let resolve = Link.Current sp.url in
741 let breadcrumbs = Breadcrumbs.gen_breadcrumbs ~config ~sidebar ~url in
742 let sidebar_html =
743 match sidebar with
744 | None -> None
745 | Some sidebar ->
746 let sidebar = Odoc_document.Sidebar.to_block sidebar url in
747 (Some (block ~config ~resolve sidebar) :> any Html.elt list option)
748 in
749 let title = url.Url.Path.name
750 and doc = Html_source.html_of_doc ~config ~resolve contents in
751 let header =
752 items ~config ~resolve (Doctree.PageTitle.render_src_title sp)
753 in
754 let shell_name =
755 match Config.shell config with
756 | Some name -> name
757 | None -> if Config.as_json config then "json" else "default"
758 in
759 let (module Shell : Html_shell.S) =
760 match Html_shell.find shell_name with
761 | Some shell -> shell
762 | None ->
763 match Config.shell config with
764 | Some name ->
765 failwith
766 (Printf.sprintf
767 "Shell '%s' not found. Available shells: %s. \
768 Ensure the shell plugin is installed (run 'dune build \
769 @install' first)."
770 name
771 (Stdlib.String.concat ", " (Html_shell.list_shells ())))
772 | None -> Html_shell.default ()
773 in
774 Shell.make_src ~config
775 { url; header; breadcrumbs; sidebar = sidebar_html;
776 sidebar_data = sidebar; title; content = [ doc ] }
777end
778
779let render ~config ~sidebar = function
780 | Document.Page page -> [ Page.page ~config ~sidebar page ]
781 | Source_page src -> [ Page.source_page ~config ~sidebar src ]
782
783let filepath ~config url = Link.Path.as_filename ~config url
784
785let doc ~config ~xref_base_uri b =
786 let resolve = Link.Base xref_base_uri in
787 block ~config ~resolve b
788
789let inline ~config ~xref_base_uri b =
790 let resolve = Link.Base xref_base_uri in
791 inline ~config ~resolve b