jon.recoil.org
this repo has no description
1open Odoc_document.Types
2open Types
3module Doctree = Odoc_document.Doctree
4module Url = Odoc_document.Url
5
6type config = {
7 with_children : bool;
8 shorten_beyond_depth : int option;
9 remove_functor_arg_link : bool;
10}
11
12module Link = struct
13 let rec flatten_path ppf (x : Odoc_document.Url.Path.t) =
14 let pp_parent ppf = function
15 | Some p -> Format.fprintf ppf "%a-" flatten_path p
16 | None -> ()
17 in
18 Format.fprintf ppf "%a%a%s" pp_parent x.parent
19 Url.Path.pp_disambiguating_prefix x.kind x.name
20
21 let page p = Format.asprintf "%a" flatten_path p
22
23 let anchor p a = Format.asprintf "%a--%s" flatten_path p a
24
25 let label (x : Odoc_document.Url.t) =
26 match x.anchor with "" -> page x.page | a -> anchor x.page a
27
28 let rec is_inside_param (x : Odoc_document.Url.Path.t) =
29 match (x.kind, x.parent) with
30 | `Parameter _, _ -> true
31 | _, None -> false
32 | _, Some p -> is_inside_param p
33
34 let ref config (x : Odoc_document.Url.t) =
35 if config.remove_functor_arg_link && is_inside_param x.page then ""
36 else label x
37
38 let get_dir_and_file url =
39 let open Odoc_document in
40 let l = Url.Path.to_list url in
41 let is_dir = function `Page -> `IfNotLast | _ -> `Never in
42 let dir, file = Url.Path.split ~is_dir l in
43 let segment_to_string (_kind, name) = name in
44 ( List.map segment_to_string dir,
45 String.concat "." (List.map segment_to_string file) )
46
47 let filename ?(add_ext = true) url =
48 let dir, file = get_dir_and_file url in
49 let file = Fpath.(v (String.concat dir_sep (dir @ [ file ]))) in
50 if add_ext then Fpath.add_ext "tex" file else file
51end
52
53module Expansion = struct
54 let is_class_or_module (url : Odoc_document.Url.Path.t) =
55 match url.kind with
56 | `Module | `LeafPage | `Class | `Page -> true
57 | _ -> false
58
59 let shortened config status url =
60 let depth x = List.length Odoc_document.Url.(Path.to_list x) in
61 match (config.shorten_beyond_depth, status) with
62 | None, _ | _, (`Inline | `Open | `Closed) -> false
63 | Some d, `Default -> depth url >= d
64
65 let should_inline status url =
66 match status with
67 | `Inline | `Open -> true
68 | `Closed -> false
69 | `Default ->
70 (* we don't inline contents that should appear in their own page.*)
71 not (is_class_or_module url)
72
73 let remove_subpage config status url =
74 shortened config status url || should_inline status url
75end
76
77let style = function
78 | `Emphasis | `Italic -> Raw.emph
79 | `Bold -> Raw.bold
80 | `Subscript -> Raw.subscript
81 | `Superscript -> Raw.superscript
82
83let gen_hyperref pp r ppf =
84 match (r.target, r.text) with
85 | "", None -> ()
86 | "", Some content -> Raw.inline_code pp ppf content
87 | s, None -> Raw.ref ppf s
88 | s, Some content ->
89 let pp =
90 if r.short then Raw.inline_code pp
91 else fun ppf x ->
92 Fmt.pf ppf "%a[p%a]" (Raw.inline_code pp) x Raw.pageref_star s
93 in
94 Raw.hyperref s pp ppf content
95
96let label = function None -> [] | Some x -> [ Label (Link.label x) ]
97
98let level_macro = function
99 | 0 -> Raw.section
100 | 1 -> Raw.subsection
101 | 2 -> Raw.subsubsection
102 | 3 | _ -> Raw.subsubsection
103
104let none _ppf () = ()
105
106let list kind pp ppf x =
107 let list =
108 match kind with Block.Ordered -> Raw.enumerate | Unordered -> Raw.itemize
109 in
110 let elt ppf = Raw.item pp ppf in
111 match x with
112 | [] -> (* empty list are not supported *) ()
113 | _ -> list (Fmt.list ~sep:(fun ppf () -> Raw.break ppf Aesthetic) elt) ppf x
114
115let escape_entity = function "#45" -> "-" | "gt" -> ">" | s -> s
116
117let elt_size (x : elt) =
118 match x with
119 | Txt _ | Internal_ref _ | External_ref _ | Label _ | Style _ | Inlined_code _
120 | Code_fragment _ | Tag _ | Break _ | Ligaturable _ ->
121 Small
122 | List _ | Section _ | Verbatim _ | Raw _ | Code_block _ | Indented _
123 | Description _ | Image _ ->
124 Large
125 | Table _ | Layout_table _ -> Huge
126
127let layout_table = function
128 | [] -> []
129 | a :: _ as m ->
130 let start = List.map (fun _ -> Empty) a in
131 let content_size l =
132 List.fold_left (fun s x -> max s (elt_size x)) Empty l
133 in
134 let row mask l = List.map2 (fun x y -> max x @@ content_size y) mask l in
135 let mask = List.fold_left row start m in
136 let filter_empty = function
137 | Empty, _ -> None
138 | (Small | Large | Huge), x -> Some x
139 in
140 let filter_row row =
141 Odoc_utils.List.filter_map filter_empty @@ List.combine mask row
142 in
143 let row_size = List.fold_left max Empty mask in
144 [ Layout_table { row_size; tbl = List.map filter_row m } ]
145
146let txt ~verbatim ~in_source ws =
147 if verbatim then [ Txt ws ]
148 else
149 let escaped = List.map (Raw.Escape.text ~code_hyphenation:in_source) ws in
150 match List.filter (( <> ) "") escaped with [] -> [] | l -> [ Txt l ]
151
152let entity ~in_source ~verbatim x =
153 if in_source && not verbatim then Ligaturable (escape_entity x)
154 else Txt [ escape_entity x ]
155
156(** Tables with too many rows are hard to typeset correctly on the same page.
157 Splitting tables on multiple pages is unreliable with longtable + hyperref.
158 Thus we limit the height of the tables that we render as latex tables. This
159 variable is kept separated because we may want to make it tunable by the
160 user. *)
161let small_table_height_limit = 10
162
163let rec pp_elt ppf = function
164 | Txt words -> Fmt.list Fmt.string ~sep:none ppf words
165 | Section { level; label; content } ->
166 let with_label ppf (label, content) =
167 pp ppf content;
168 match label with None -> () | Some label -> Raw.label ppf label
169 in
170 level_macro level with_label ppf (label, content)
171 | Break lvl -> Raw.break ppf lvl
172 | Raw s -> Fmt.string ppf s
173 | Verbatim s -> Raw.verbatim ppf s
174 | Internal_ref r -> hyperref ppf r
175 | External_ref (l, x) -> href ppf (l, x)
176 | Style (s, x) -> style s pp ppf x
177 | Code_block [] -> ()
178 | Code_block x -> Raw.code_block pp ppf x
179 | Inlined_code x -> Raw.inline_code pp ppf x
180 | Code_fragment x -> Raw.code_fragment pp ppf x
181 | List { typ; items } -> list typ pp ppf items
182 | Description items -> Raw.description pp ppf items
183 | Table { align; data } -> Raw.small_table pp ppf (Some align, data)
184 | Layout_table { row_size = Large | Huge; tbl } -> large_table ppf tbl
185 | Layout_table { row_size = Small | Empty; tbl } ->
186 if List.length tbl <= small_table_height_limit then
187 Raw.small_table pp ppf (None, tbl)
188 else large_table ppf tbl
189 | Label x -> Raw.label ppf x
190 | Indented x -> Raw.indent pp ppf x
191 | Ligaturable s -> Fmt.string ppf s
192 | Tag (s, t) -> tag s ppf t
193 | Image target -> Raw.includegraphics Fpath.pp ppf target
194
195and pp ppf = function
196 | [] -> ()
197 | Break _ :: ((Layout_table _ | Table _) :: _ as q) -> pp ppf q
198 | ((Layout_table _ | Table _) as t) :: Break _ :: q -> pp ppf (t :: q)
199 | Break a :: Break b :: q -> pp ppf (Break (max a b) :: q)
200 | Ligaturable "-" :: Ligaturable ">" :: q ->
201 Raw.rightarrow ppf;
202 pp ppf q
203 | a :: q ->
204 pp_elt ppf a;
205 pp ppf q
206
207and hyperref ppf r = gen_hyperref pp r ppf
208
209and href ppf (l, txt) =
210 match txt with
211 | Some txt ->
212 Raw.href l pp ppf txt;
213 Raw.footnote ppf l
214 | None -> Raw.url ppf l
215
216and large_table ppf tbl =
217 let rec row ppf = function
218 | [] -> Raw.break ppf Line
219 | [ a ] ->
220 pp ppf a;
221 Raw.break ppf Line
222 | [ a; b ] -> Fmt.pf ppf "%a%a%a" pp a Raw.break Aesthetic (Raw.indent pp) b
223 | a :: (_ :: _ as q) ->
224 Fmt.pf ppf "%a%a%a" pp a Raw.break Aesthetic (Raw.indent row) q
225 in
226 let matrix ppf m = List.iter (row ppf) m in
227 Raw.indent matrix ppf tbl
228
229and tag s ppf x = Raw.ocamltag s pp ppf x
230
231let raw_markup (t : Raw_markup.t) =
232 let target, content = t in
233 match Astring.String.Ascii.lowercase target with
234 | "latex" | "tex" -> [ Raw content ]
235 | _ -> []
236
237let source k (t : Source.t) =
238 let rec token (x : Source.token) =
239 match x with
240 | Elt i -> k i
241 | Tag (None, l) -> tokens l
242 | Tag (Some s, l) -> [ Tag (s, tokens l) ]
243 and tokens t = Odoc_utils.List.concat_map token t in
244 tokens t
245
246let rec internalref ~config ~verbatim ~in_source (t : Target.internal)
247 (c : Inline.t) =
248 let target =
249 match t with
250 | Target.Resolved uri -> Link.ref config uri
251 | Unresolved -> "xref-unresolved"
252 in
253 let text = inline ~config ~verbatim ~in_source c in
254 let short = in_source in
255 Internal_ref { short; target; text = Some text }
256
257and inline ~config ~in_source ~verbatim (l : Inline.t) =
258 let one (t : Inline.one) =
259 match t.desc with
260 | Text _s -> assert false
261 | Linebreak -> [ Break Line ]
262 | Styled (style, c) ->
263 [ Style (style, inline ~config ~verbatim ~in_source c) ]
264 | Link { target = External ext; content = c; _ } ->
265 let content = inline ~config ~verbatim:false ~in_source:false c in
266 [ External_ref (ext, Some content) ]
267 | Link { target = Internal ref_; content = c; _ } ->
268 [ internalref ~config ~in_source ~verbatim ref_ c ]
269 | Source c ->
270 [
271 Inlined_code
272 (source (inline ~config ~verbatim:false ~in_source:true) c);
273 ]
274 | Math s -> [ Raw (Format.asprintf "%a" Raw.math s) ]
275 | Raw_markup r -> raw_markup r
276 | Entity s -> [ entity ~in_source ~verbatim s ]
277 in
278
279 let take_text (l : Inline.t) =
280 Doctree.Take.until l ~classify:(function
281 | { Inline.desc = Text code; _ } -> Accum [ code ]
282 | { desc = Entity e; _ } -> Accum [ escape_entity e ]
283 | _ -> Stop_and_keep)
284 in
285 (* if in_source then block_code_txt s else if_not_empty (fun x -> Txt x) s *)
286 let rec prettify = function
287 | { Inline.desc = Inline.Text _; _ } :: _ as l ->
288 let words, _, rest = take_text l in
289 txt ~in_source ~verbatim words @ prettify rest
290 | o :: q -> one o @ prettify q
291 | [] -> []
292 in
293 prettify l
294
295let heading ~config p (h : Heading.t) =
296 let content = inline ~config ~in_source:false ~verbatim:false h.title in
297 [
298 Section
299 { label = Option.map (Link.anchor p) h.label; level = h.level; content };
300 Break Aesthetic;
301 ]
302
303let non_empty_block_code ~config c =
304 let s = source (inline ~config ~verbatim:true ~in_source:true) c in
305 match s with
306 | [] -> []
307 | _ :: _ as l -> [ Break Separation; Code_block l; Break Separation ]
308
309let non_empty_code_fragment ~config c =
310 let s = source (inline ~config ~verbatim:false ~in_source:true) c in
311 match s with [] -> [] | _ :: _ as l -> [ Code_fragment l ]
312
313let alt_text ~in_source (target : Target.t) alt =
314 let text = txt ~verbatim:false ~in_source:false [ alt ] in
315 let break = if in_source then [] else [ Break Paragraph ] in
316 match target with
317 | Internal _ -> text @ break
318 | External l -> [ External_ref (l, Some text) ] @ break
319
320let image ~in_source (internal_url : Url.t) alt =
321 let dir, file = Link.get_dir_and_file internal_url.page in
322 match Fpath.(get_ext @@ v file) with
323 (* list imported from pdftex.def *)
324 | "" | ".pdf" | ".png" | ".jpg" | ".mps" | ".jpeg" | ".jbig2" | ".jb2"
325 | ".PDF" | ".PNG" | ".JPG" | ".JPEG" | ".JBIG2" | ".JB2" ->
326 let fpath = Fpath.v (String.concat Fpath.dir_sep (dir @ [ file ])) in
327 [ Image fpath ]
328 | _ -> alt_text ~in_source (Internal (Resolved internal_url)) alt
329
330let rec block ~config ~in_source (l : Block.t) =
331 let one (t : Block.one) =
332 match t.desc with
333 | Inline i -> inline ~config ~verbatim:false ~in_source:false i
334 | Image (Internal (Resolved x), alt) -> image ~in_source x alt
335 | Image (t, alt) | Audio (t, alt) | Video (t, alt) ->
336 alt_text ~in_source t alt
337 | Paragraph i ->
338 inline ~config ~in_source:false ~verbatim:false i
339 @ if in_source then [] else [ Break Paragraph ]
340 | List (typ, l) ->
341 [ List { typ; items = List.map (block ~config ~in_source:false) l } ]
342 | Table t -> table_block ~config t
343 | Description l ->
344 [
345 (let item i =
346 ( inline ~config ~in_source ~verbatim:false i.Description.key,
347 block ~config ~in_source i.Description.definition )
348 in
349 Description (List.map item l));
350 ]
351 | Raw_markup r -> raw_markup r
352 | Verbatim s -> [ Verbatim s ]
353 | Source (_, _, _, c, _) -> non_empty_block_code ~config c
354 | Math s ->
355 [
356 Break Paragraph;
357 Raw (Format.asprintf "%a" Raw.equation s);
358 Break Paragraph;
359 ]
360 in
361 Odoc_utils.List.concat_map one l
362
363and table_block ~config { Table.data; align } =
364 let data =
365 List.map
366 (List.map (fun (cell, cell_type) ->
367 let content = block ~config ~in_source:false cell in
368 match cell_type with
369 | `Header -> [ Style (`Bold, content) ]
370 | `Data -> content))
371 data
372 in
373 [ Table { align; data } ]
374
375let rec is_only_text l =
376 let is_text : Item.t -> _ = function
377 | Heading _ | Text _ -> true
378 | Declaration _ -> false
379 | Include { content = items; _ } -> is_only_text items.content
380 in
381 List.for_all is_text l
382
383let rec documentedSrc ~config (t : DocumentedSrc.t) =
384 let open DocumentedSrc in
385 let rec to_latex t =
386 match t with
387 | [] -> []
388 | Code _ :: _ ->
389 let take_code l =
390 Doctree.Take.until l ~classify:(function
391 | Code code -> Accum code
392 | _ -> Stop_and_keep)
393 in
394 let code, _, rest = take_code t in
395 non_empty_code_fragment ~config code @ to_latex rest
396 | Alternative (Expansion e) :: rest ->
397 let elt =
398 (* In the [should_inline] or [shortened], we are replacing the
399 independent page by the inlined contents, thus we need to redirect
400 the links to the missing page to the inlined contents.
401 redirect the *)
402 if Expansion.should_inline e.status e.url then
403 Label (Link.page e.url) :: to_latex e.expansion
404 else if Expansion.shortened config e.status e.url then
405 Label (Link.page e.url) :: non_empty_code_fragment ~config e.summary
406 else non_empty_code_fragment ~config e.summary
407 in
408 elt @ to_latex rest
409 | Subpage subp :: rest ->
410 Indented (items ~config subp.content.url subp.content.items)
411 :: to_latex rest
412 | (Documented _ | Nested _) :: _ ->
413 let take_descr l =
414 Doctree.Take.until l ~classify:(function
415 | Documented { attrs; anchor; code; doc; markers } ->
416 Accum
417 [
418 {
419 DocumentedSrc.attrs;
420 anchor;
421 code = `D code;
422 doc;
423 markers;
424 };
425 ]
426 | Nested { attrs; anchor; code; doc; markers } ->
427 Accum
428 [
429 {
430 DocumentedSrc.attrs;
431 anchor;
432 code = `N code;
433 doc;
434 markers;
435 };
436 ]
437 | _ -> Stop_and_keep)
438 in
439 let l, _, rest = take_descr t in
440 let one dsrc =
441 let content =
442 match dsrc.code with
443 | `D code -> inline ~config ~verbatim:false ~in_source:true code
444 | `N n -> to_latex n
445 in
446 let doc = [ block ~config ~in_source:true dsrc.doc ] in
447 (content @ label dsrc.anchor) :: doc
448 in
449 layout_table (List.map one l) @ to_latex rest
450 in
451 to_latex t
452
453and items ~config page_url l =
454 let rec walk_items ~page_url ~only_text acc (t : Item.t list) =
455 let continue_with rest elts =
456 walk_items ~page_url ~only_text (List.rev_append elts acc) rest
457 in
458 match t with
459 | [] -> List.rev acc
460 | Text _ :: _ as t ->
461 let text, _, rest =
462 Doctree.Take.until t ~classify:(function
463 | Item.Text text -> Accum text
464 | _ -> Stop_and_keep)
465 in
466 let content = block ~config ~in_source:false text in
467 let elts = content in
468 elts |> continue_with rest
469 | Heading h :: rest -> heading ~config page_url h |> continue_with rest
470 | Include
471 {
472 attr = _;
473 source_anchor = _;
474 anchor;
475 doc;
476 content = { summary; status = _; content };
477 }
478 :: rest ->
479 let included = items page_url content in
480 let docs = block ~config ~in_source:true doc in
481 let summary =
482 source (inline ~config ~verbatim:false ~in_source:true) summary
483 in
484 let content = included in
485 label anchor @ docs @ summary @ content |> continue_with rest
486 | Declaration { Item.attr = _; source_anchor = _; anchor; content; doc }
487 :: rest ->
488 let content = label anchor @ documentedSrc ~config content in
489 let elts =
490 match doc with
491 | [] -> content @ [ Break Line ]
492 | docs ->
493 content
494 @ [
495 Indented (block ~config ~in_source:true docs);
496 Break Separation;
497 ]
498 in
499 continue_with rest elts
500 and items page_url l =
501 walk_items ~page_url ~only_text:(is_only_text l) [] l
502 in
503 items page_url l
504
505module Doc = struct
506 let link_children ppf children =
507 let input_child ppf child =
508 Raw.input ppf child.Odoc_document.Renderer.filename
509 in
510 Fmt.list input_child ppf children
511
512 let make ~config url content children =
513 let filename = Link.filename url in
514 let label = Label (Link.page url) in
515 let content =
516 match content with
517 | [] -> [ label ]
518 | (Section _ as s) :: q -> s :: label :: q
519 | q -> label :: q
520 in
521 let children_input ppf =
522 if config.with_children then link_children ppf children else ()
523 in
524 let content ppf = Fmt.pf ppf "@[<v>%a@,%t@]@." pp content children_input in
525 { Odoc_document.Renderer.filename; content; children; path = url; assets = [] }
526end
527
528module Page = struct
529 let on_sub = function `Page _ -> Some 1 | `Include _ -> None
530
531 let rec subpage ~config (p : Subpage.t) =
532 if Expansion.remove_subpage config p.status p.content.url then []
533 else [ page ~config p.content ]
534
535 and subpages ~config subpages =
536 List.flatten @@ List.map (subpage ~config) subpages
537
538 and page ~config p =
539 let { Page.items = i; url; _ } =
540 Doctree.Labels.disambiguate_page ~enter_subpages:true p
541 and subpages = subpages ~config @@ Doctree.Subpages.compute p in
542 let i = Doctree.Shift.compute ~on_sub i in
543 let header, preamble = Doctree.PageTitle.render_title p in
544 let header = items ~config url (header @ preamble) in
545 let content = items ~config url i in
546 let page = Doc.make ~config url (header @ content) subpages in
547 page
548end
549
550let render ~config = function
551 | Document.Page page -> [ Page.page ~config page ]
552 | Source_page _ -> []
553
554let filepath url = Link.filename ~add_ext:false url