jon.recoil.org
this repo has no description
1open Odoc_utils
2module ManLink = Link
3open Odoc_document
4open Types
5open Doctree
6module Link = ManLink
7
8(*
9Manpages relies on the (g|t|n)roff document language.
10This language has a fairly long history
11(see https://en.wikipedia.org/wiki/Groff_(software)).
12
13Unfortunately, this language is very old and quite clunky.
14Most manpages relies on a set of high-level macros
15(http://man7.org/linux/man-pages/man7/groff_man.7.html)
16that attempts to represent the semantic of common constructs in man pages. These
17macros are too constraining for the rich ocamldoc markup and
18their semantics are quite brittle, making them hard to use in a machine-output
19context.
20
21For these reason, we hit the low level commands directly:
22- http://man7.org/linux/man-pages/man7/groff.7.html
23- http://mandoc.bsd.lv/man/roff.7.html
24
25The downside of these commands is their poor translation to HTML, which we
26don't care about.
27
28In the roff language:
291) newlines are not distinguished from other whitespace
302) Successive whitespaces are ignored, except to trigger
31 "end of sentence detection" for 2 or more successive whitespaces.
323) Commands must start at the beginning of a line.
334) Whitespaces separated by a macro are not treated as a single whitespace.
34
35For all these reasons, We use a concatenative API that will gobble up adjacent
36extra whitespaces and never output successive whitespaces at all.
37This makes the output much more consistent.
38*)
39module Roff = struct
40 type t =
41 | Concat of t list
42 | Font of string * t
43 | Macro of string * string
44 | Space
45 | Break
46 | String of string
47 | Vspace
48 | Indent of int * t
49 | Align_line of string
50 | Table_cell of t
51
52 let noop = Concat []
53
54 let sp = Space
55
56 let break = Break
57
58 let vspace = Vspace
59
60 let append t1 t2 =
61 match (t1, t2) with
62 | Concat l1, Concat l2 -> Concat (l1 @ l2)
63 | Concat l1, e2 -> Concat (l1 @ [ e2 ])
64 | e1, Concat l2 -> Concat (e1 :: l2)
65 | e1, e2 -> Concat [ e1; e2 ]
66
67 let ( ++ ) = append
68
69 let concat = List.fold_left ( ++ ) (Concat [])
70
71 let rec intersperse ~sep = function
72 | [] -> []
73 | [ h ] -> [ h ]
74 | h1 :: (_ :: _ as t) -> h1 :: sep :: intersperse ~sep t
75
76 let list ?(sep = Concat []) l = concat @@ intersperse ~sep l
77
78 let indent i content = Indent (i, content)
79
80 let macro id fmt = Format.ksprintf (fun s -> Macro (id, s)) fmt
81
82 (* copied from cmdliner *)
83 let escape s =
84 (* escapes [s] from doc language. *)
85 let markup_text_need_esc = function '.' | '\\' -> true | _ -> false in
86 let max_i = String.length s - 1 in
87 let rec escaped_len i l =
88 if i > max_i then l
89 else if markup_text_need_esc s.[i] then escaped_len (i + 1) (l + 2)
90 else escaped_len (i + 1) (l + 1)
91 in
92 let escaped_len = escaped_len 0 0 in
93 if escaped_len = String.length s then s
94 else
95 let b = Bytes.create escaped_len in
96 let rec loop i k =
97 if i > max_i then Bytes.unsafe_to_string b
98 else
99 let c = String.unsafe_get s i in
100 if not (markup_text_need_esc c) then (
101 Bytes.unsafe_set b k c;
102 loop (i + 1) (k + 1))
103 else (
104 Bytes.unsafe_set b k '\\';
105 Bytes.unsafe_set b (k + 1) c;
106 loop (i + 1) (k + 2))
107 in
108 loop 0 0
109
110 let str fmt = Format.ksprintf (fun s -> String (escape s)) fmt
111
112 let escaped fmt = Format.ksprintf (fun s -> String s) fmt
113
114 let env o c arg content = macro o "%s" arg ++ content ++ macro c ""
115
116 let font s content = Font (s, content)
117
118 let font_stack = Stack.create ()
119
120 let pp_font ppf s fmt =
121 let command_f ppf s =
122 if String.length s = 1 then Format.fprintf ppf {|\f%s|} s
123 else Format.fprintf ppf {|\f[%s]|} s
124 in
125 Stack.push s font_stack;
126 command_f ppf s;
127 Format.kfprintf
128 (fun ppf ->
129 ignore @@ Stack.pop font_stack;
130 let s =
131 if Stack.is_empty font_stack then "R" else Stack.top font_stack
132 in
133 command_f ppf s)
134 ppf fmt
135
136 let collapse x =
137 let skip_spaces l =
138 let _, _, rest =
139 Take.until l ~classify:(function Space -> Skip | _ -> Stop_and_keep)
140 in
141 rest
142 and skip_spaces_and_break l =
143 let _, _, rest =
144 Take.until l ~classify:(function
145 | Space | Break -> Skip
146 | _ -> Stop_and_keep)
147 in
148 rest
149 and skip_spaces_and_break_and_vspace l =
150 let _, _, rest =
151 Take.until l ~classify:(function
152 | Space | Break | Vspace -> Skip
153 | _ -> Stop_and_keep)
154 in
155 rest
156 in
157 let rec loop acc l =
158 match l with
159 (* | (Space | Break) :: (Macro _ :: _ as t) ->
160 * loop acc t *)
161 | Vspace :: _ ->
162 let rest = skip_spaces_and_break_and_vspace l in
163 loop (Vspace :: acc) rest
164 | Break :: _ ->
165 let rest = skip_spaces_and_break l in
166 loop (Break :: acc) rest
167 | Space :: _ ->
168 let rest = skip_spaces l in
169 loop (Space :: acc) rest
170 | Concat l :: rest -> loop acc (l @ rest)
171 | (Macro _ as h) :: rest ->
172 let rest = skip_spaces rest in
173 loop (h :: acc) rest
174 | [] -> acc
175 | h :: t -> loop (h :: acc) t
176 in
177 List.rev @@ loop [] [ x ]
178
179 let rec next_is_macro = function
180 | (Vspace | Break | Macro _) :: _ -> true
181 | Concat l :: _ -> next_is_macro l
182 | Font (_, content) :: _ | Indent (_, content) :: _ ->
183 next_is_macro [ content ]
184 | _ -> false
185
186 let pp_macro ppf s fmt = Format.fprintf ppf ("@\n.%s " ^^ fmt) s
187
188 let pp_indent ppf indent =
189 if indent = 0 then () else pp_macro ppf "ti" "+%d" indent
190
191 let newline_if ppf b = if b then Format.pp_force_newline ppf () else ()
192
193 let pp ppf t =
194 let rec many ~indent ppf l =
195 match l with
196 | [] -> ()
197 | h :: t ->
198 let is_macro = next_is_macro t in
199 (match h with
200 | Concat l -> many ~indent ppf l
201 | String s -> Format.pp_print_string ppf s
202 | Font (s, t) -> pp_font ppf s "%a" (one ~indent) t
203 | Space -> Format.fprintf ppf " "
204 | Break ->
205 pp_macro ppf "br" "";
206 pp_indent ppf indent;
207 newline_if ppf (not is_macro)
208 | Vspace ->
209 pp_macro ppf "sp" "";
210 pp_indent ppf indent;
211 newline_if ppf (not is_macro)
212 | Macro (s, args) ->
213 pp_macro ppf s "%s" args;
214 newline_if ppf (not is_macro)
215 | Align_line s ->
216 Format.pp_print_string ppf (s ^ ".");
217 newline_if ppf (not is_macro)
218 | Table_cell c ->
219 Format.pp_print_text ppf "T{\n";
220 one ~indent ppf c;
221 Format.pp_print_text ppf "\nT}"
222 | Indent (i, content) ->
223 let indent = indent + i in
224 one ~indent ppf content);
225 many ~indent ppf t
226 and one ~indent ppf x = many ~indent ppf @@ collapse x in
227 Format.pp_set_margin ppf max_int;
228 one ~indent:0 ppf t
229end
230
231open Roff
232
233let style (style : style) content =
234 match style with
235 | `Bold -> font "B" content
236 | `Italic -> font "I" content
237 (* We ignore those *)
238 | `Emphasis | `Superscript | `Subscript -> content
239
240(* Striped content should be rendered in one line, without styling *)
241let strip l =
242 let rec loop acc = function
243 | [] -> acc
244 | h :: t -> (
245 match h.Inline.desc with
246 | Text _ | Entity _ | Raw_markup _ | Math _ -> loop (h :: acc) t
247 | Linebreak -> loop acc t
248 | Styled (sty, content) ->
249 let h =
250 { h with desc = Styled (sty, List.rev @@ loop [] content) }
251 in
252 loop (h :: acc) t
253 | Link { content; _ } ->
254 let acc = loop acc content in
255 loop acc t
256 | Source code ->
257 let acc = loop_source acc code in
258 loop acc t)
259 and loop_source acc = function
260 | [] -> acc
261 | Source.Elt content :: t -> loop_source (List.rev_append content acc) t
262 | Source.Tag (_, content) :: t ->
263 let acc = loop_source acc content in
264 loop_source acc t
265 in
266 List.rev @@ loop [] l
267
268(* Partial support for now *)
269let entity e =
270 match e with "#45" -> escaped "\\-" | "gt" -> str ">" | s -> str "&%s;" s
271
272(* Should hopefully make people notice and report *)
273
274let raw_markup (t : Raw_markup.t) =
275 let target, content = t in
276 match Astring.String.Ascii.lowercase target with
277 | "manpage" | "troff" | "roff" -> String content
278 | _ -> noop
279
280let math (s : Types.Math.t) = String s
281
282let rec source_code (s : Source.t) =
283 match s with
284 | [] -> noop
285 | h :: t -> (
286 match h with
287 | Source.Elt i -> inline (strip i) ++ source_code t
288 | Tag (None, s) -> source_code s ++ source_code t
289 | Tag (Some _, s) -> font "CB" (source_code s) ++ source_code t)
290
291and inline (l : Inline.t) =
292 match l with
293 | [] -> noop
294 | i :: rest -> (
295 match i.desc with
296 | Text "" -> inline rest
297 | Text _ ->
298 let l, _, rest =
299 Doctree.Take.until l ~classify:(function
300 | { Inline.desc = Text s; _ } -> Accum [ s ]
301 | _ -> Stop_and_keep)
302 in
303 str {|%s|} (String.concat ~sep:"" l) ++ inline rest
304 | Entity e ->
305 let x = entity e in
306 x ++ inline rest
307 | Linebreak -> break ++ inline rest
308 | Styled (sty, content) -> style sty (inline content) ++ inline rest
309 | Link { target = External href; content; _ } ->
310 env "UR" "UE" href (inline @@ strip content) ++ inline rest
311 | Link { content; _ } ->
312 font "CI" (inline @@ strip content) ++ inline rest
313 | Source content -> source_code content ++ inline rest
314 | Math s -> math s ++ inline rest
315 | Raw_markup t -> raw_markup t ++ inline rest)
316
317let table pp { Table.data; align } =
318 let sep = '\t' in
319 let alignment =
320 let alignment =
321 match align with
322 | align ->
323 List.map
324 (function
325 (* Since we are enclosing cells in text blocks, the alignment has
326 no effect on the content of a sufficiently big cell, for some
327 reason... (see the markup test in generators)
328
329 One solution would be to use the [m] column specifier to apply
330 a macro to the text blocks of the columns. Those macros would
331 be [lj], [ce] or [rj], which define alignment. However, this
332 breaks both the alignment for small table cells, and the
333 largeness of columns. For the records, it woulb be:
334
335 {[
336 | Some `Left -> "lmlj"
337 | Some `Center -> "cmce"
338 | Some `Right -> "rmrj"
339 | None -> "l"
340 ]} *)
341 | Table.Left -> "l"
342 | Center -> "c"
343 | Right -> "r"
344 | Default -> "l")
345 align
346 in
347 Align_line (String.concat ~sep:"" alignment)
348 in
349 env "TS" "TE" ""
350 (str "allbox;" ++ alignment
351 ++ List.fold_left
352 (fun acc row ->
353 acc ++ vspace
354 ++
355 match row with
356 | [] -> noop
357 | (h, _) :: t ->
358 List.fold_left
359 (fun acc (x, _) -> acc ++ str "%c" sep ++ Table_cell (pp x))
360 (Table_cell (pp h))
361 t)
362 noop data)
363
364let rec block (l : Block.t) =
365 match l with
366 | [] -> noop
367 | b :: rest -> (
368 let continue r = if r = [] then noop else vspace ++ block r in
369 match b.desc with
370 | Inline i -> inline i ++ continue rest
371 | Video (_, content) | Audio (_, content) | Image (_, content) ->
372 str "%s" content ++ continue rest
373 | Paragraph i -> inline i ++ continue rest
374 | List (list_typ, l) ->
375 let f n b =
376 let bullet =
377 match list_typ with
378 | Unordered -> escaped {|\(bu|}
379 | Ordered -> str "%d)" (n + 1)
380 in
381 indent 2 (bullet ++ sp ++ block b)
382 in
383 list ~sep:break (List.mapi f l) ++ continue rest
384 | Table t -> table block t ++ continue rest
385 | Description _ ->
386 let descrs, _, rest =
387 Take.until l ~classify:(function
388 | { Block.desc = Description l; _ } -> Accum l
389 | _ -> Stop_and_keep)
390 in
391 let f i =
392 let key = inline i.Description.key in
393 let def = block i.Description.definition in
394 indent 2 (str "@" ++ key ++ str ":" ++ sp ++ def)
395 in
396 list ~sep:break (List.map f descrs) ++ continue rest
397 | Source (_, _, _, content, _) ->
398 env "EX" "EE" "" (source_code content) ++ continue rest
399 | Math s -> math s ++ continue rest
400 | Verbatim content -> env "EX" "EE" "" (str "%s" content) ++ continue rest
401 | Raw_markup t -> raw_markup t ++ continue rest)
402
403let next_heading, reset_heading =
404 let heading_stack = ref [] in
405 let rec succ_heading i l =
406 match (i, l) with
407 | 1, [] -> [ 1 ]
408 | _, [] -> 1 :: succ_heading (i - 1) []
409 | 1, n :: _ -> [ n + 1 ]
410 | i, n :: t -> n :: succ_heading (i - 1) t
411 in
412 let print_heading l = String.concat ~sep:"." @@ List.map string_of_int l in
413 let next level =
414 let new_heading = succ_heading level !heading_stack in
415 heading_stack := new_heading;
416 print_heading new_heading
417 and reset () = heading_stack := [] in
418 (next, reset)
419
420let heading ~nested { Heading.label = _; level; title; source_anchor = _ } =
421 let prefix =
422 if level = 0 then noop
423 else if level <= 3 then str "%s " (next_heading level)
424 else noop
425 in
426 if not nested then
427 macro "in" "%d" (level + 2)
428 ++ font "B" (prefix ++ inline (strip title))
429 ++ macro "in" ""
430 else font "B" (prefix ++ inline (strip title))
431
432let expansion_not_inlined url = not (Link.should_inline url)
433
434let take_code l =
435 let c, _, rest =
436 Take.until l ~classify:(function
437 | DocumentedSrc.Code c -> Accum c
438 | DocumentedSrc.Alternative (Expansion e) when expansion_not_inlined e.url
439 ->
440 Accum e.summary
441 | _ -> Stop_and_keep)
442 in
443 (c, rest)
444
445let inline_subpage = function
446 | `Inline | `Open | `Default -> true
447 | `Closed -> false
448
449let rec documentedSrc (l : DocumentedSrc.t) =
450 match l with
451 | [] -> noop
452 | line :: rest -> (
453 let break_if_nonempty r = if r = [] then noop else break in
454 let continue r = documentedSrc r in
455 match line with
456 | Code _ ->
457 let c, rest = take_code l in
458 source_code c ++ continue rest
459 | Alternative alt -> (
460 match alt with
461 | Expansion { expansion; url; _ } ->
462 if expansion_not_inlined url then
463 let c, rest = take_code l in
464 source_code c ++ continue rest
465 else documentedSrc expansion)
466 | Subpage p -> subpage p.content ++ continue rest
467 | Documented _ | Nested _ ->
468 let lines, _, rest =
469 Take.until l ~classify:(function
470 | DocumentedSrc.Documented { code; doc; _ } ->
471 Accum [ (`D code, doc) ]
472 | DocumentedSrc.Nested { code; doc; _ } ->
473 Accum [ (`N code, doc) ]
474 | _ -> Stop_and_keep)
475 in
476 let f (content, doc) =
477 let doc =
478 match doc with
479 | [] -> noop
480 | doc ->
481 indent 2
482 (break ++ str "(*" ++ sp ++ block doc ++ sp ++ str "*)")
483 in
484 let content =
485 match content with
486 | `D code -> inline code
487 | `N l -> indent 2 (documentedSrc l)
488 in
489 content ++ doc
490 in
491 let l = list ~sep:break (List.map f lines) in
492 indent 2 (break ++ l) ++ break_if_nonempty rest ++ continue rest)
493
494and subpage { preamble = _; items; url = _; _ } =
495 let content = items in
496 let surround body =
497 if content = [] then sp else indent 2 (break ++ body) ++ break
498 in
499 surround @@ item ~nested:true content
500
501and item ~nested (l : Item.t list) =
502 match l with
503 | [] -> noop
504 | i :: rest -> (
505 let continue r = if r = [] then noop else vspace ++ item ~nested r in
506 match i with
507 | Text b ->
508 let d = env "fi" "nf" "" (block b) in
509 d ++ continue rest
510 | Heading h ->
511 let h = heading ~nested h in
512 vspace ++ h ++ vspace ++ item ~nested rest
513 | Declaration { attr = _; anchor = _; source_anchor = _; content; doc } ->
514 let decl = documentedSrc content in
515 let doc =
516 match doc with
517 | [] -> noop
518 | doc -> env "fi" "nf" "" (indent 2 (break ++ block doc))
519 in
520 decl ++ doc ++ continue rest
521 | Include
522 {
523 attr = _;
524 anchor = _;
525 source_anchor = _;
526 content = { summary; status; content };
527 doc;
528 } ->
529 let d =
530 if inline_subpage status then item ~nested content
531 else
532 let s = source_code summary in
533 match doc with
534 | [] -> s
535 | doc -> s ++ indent 2 (break ++ block doc)
536 in
537 d ++ continue rest)
538
539let on_sub subp =
540 match subp with
541 | `Page p -> if Link.should_inline p.Subpage.content.url then Some 1 else None
542 | `Include incl -> if inline_subpage incl.Include.status then Some 0 else None
543
544let page p =
545 reset_heading ();
546 let header, preamble = Doctree.PageTitle.render_title p in
547 let header = header @ Shift.compute ~on_sub preamble in
548 let i = Shift.compute ~on_sub p.items in
549 macro "TH" {|%s 3 "" "Odoc" "OCaml Library"|} p.url.name
550 ++ macro "SH" "Name"
551 ++ str "%s" (String.concat ~sep:"." @@ Link.for_printing p.url)
552 ++ macro "SH" "Synopsis" ++ vspace ++ item ~nested:false header
553 ++ macro "SH" "Documentation" ++ vspace ++ macro "nf" ""
554 ++ item ~nested:false i
555
556let rec subpage subp =
557 let p = subp.Subpage.content in
558 if Link.should_inline p.url then [] else [ render_page p ]
559
560and render_page (p : Page.t) =
561 let p = Doctree.Labels.disambiguate_page ~enter_subpages:true p
562 and children = List.concat_map subpage (Subpages.compute p) in
563 let content ppf = Format.fprintf ppf "%a@." Roff.pp (page p) in
564 let filename = Link.as_filename p.url in
565 { Renderer.filename; content; children; path = p.url; assets = [] }
566
567let render = function
568 | Document.Page page -> [ render_page page ]
569 | Source_page _ -> []
570
571let filepath url = Link.as_filename ~add_ext:false url