jon.recoil.org
this repo has no description
1open Odoc_utils
2open Types
3
4module Take = struct
5 type ('a, 'b, 'c) action =
6 | Rec of 'a list
7 | Skip
8 | Accum of 'b list
9 | Stop_and_keep
10 | Stop_and_accum of 'b list * 'c option
11
12 let until ~classify items =
13 let rec loop acc = function
14 | [] -> (List.rev acc, None, [])
15 | b :: rest -> (
16 match classify b with
17 | Skip -> loop acc rest
18 | Rec x -> loop acc (x @ rest)
19 | Accum v -> loop (List.rev_append v acc) rest
20 | Stop_and_keep -> (List.rev acc, None, b :: rest)
21 | Stop_and_accum (v, e) -> (List.rev_append acc v, e, rest))
22 in
23 loop [] items
24end
25
26module Rewire = struct
27 type ('a, 'h) action = Rec of 'a | Skip | Heading of 'h * int
28
29 let walk ~classify ~node items =
30 let rec loop current_level acc l =
31 match l with
32 | [] -> (List.rev acc, [])
33 | b :: rest -> (
34 match classify b with
35 | Skip -> loop current_level acc rest
36 | Rec l -> loop current_level acc (l @ rest)
37 | Heading (h, level) ->
38 if level > current_level then
39 let children, rest = loop level [] rest in
40 loop current_level (node h children :: acc) rest
41 else (List.rev acc, l))
42 in
43 let trees, rest = loop (-1) [] items in
44 assert (rest = []);
45 trees
46end
47
48module Toc : sig
49 type t = one list
50
51 and one = { url : Url.t; text : Inline.t; children : t }
52
53 val compute :
54 Url.Path.t -> on_sub:(Include.status -> bool) -> Item.t list -> t
55end = struct
56 type t = one list
57
58 and one = { url : Url.t; text : Inline.t; children : t }
59 let rec remove_links l =
60 let open Inline in
61 l
62 |> List.map (fun one ->
63 let return desc = [ { one with desc } ] in
64 match one.desc with
65 | Text _ as t -> return t
66 | Entity _ as t -> return t
67 | Linebreak as t -> return t
68 | Styled (st, content) -> return (Styled (st, remove_links content))
69 | Link { target = _; content = t; _ } -> t
70 | Source l ->
71 let rec f = function
72 | Source.Elt t -> Source.Elt (remove_links t)
73 | Tag (tag, t) -> Tag (tag, List.map f t)
74 in
75 return @@ Source (List.map f l)
76 | (Math _ | Raw_markup _) as t -> return t)
77 |> List.concat
78
79 let classify ~on_sub (i : Item.t) : _ Rewire.action =
80 match i with
81 | Text _ | Declaration _ -> Skip
82 | Include { content = { status; content; _ }; _ } ->
83 if on_sub status then Rec content else Skip
84 | Heading { label = None; _ } -> Skip
85 | Heading { label = Some label; level; title; _ } ->
86 let title = remove_links title in
87 Heading ((label, title), level)
88
89 let node mkurl (anchor, text) children =
90 { url = mkurl anchor; text; children }
91
92 let compute page ~on_sub t =
93 let mkurl anchor = { Url.Anchor.page; anchor; kind = `LeafPage } in
94 Rewire.walk ~classify:(classify ~on_sub) ~node:(node mkurl) t
95end
96
97module Subpages : sig
98 val compute : Page.t -> Subpage.t list
99end = struct
100 let rec walk_documentedsrc (l : DocumentedSrc.t) =
101 List.concat_map
102 (function
103 | DocumentedSrc.Code _ -> []
104 | Documented _ -> []
105 | Nested { code; _ } -> walk_documentedsrc code
106 | Subpage p -> [ p ]
107 | Alternative (Expansion r) -> walk_documentedsrc r.expansion)
108 l
109
110 let rec walk_items (l : Item.t list) =
111 List.concat_map
112 (function
113 | Item.Text _ -> []
114 | Heading _ -> []
115 | Declaration { content; _ } -> walk_documentedsrc content
116 | Include i -> walk_items i.content.content)
117 l
118
119 let compute (p : Page.t) = walk_items (p.preamble @ p.items)
120end
121
122module Shift = struct
123 type state = { englobing_level : int; current_level : int }
124
125 let start = { englobing_level = 0; current_level = 0 }
126
127 let shift st x =
128 let level = st.englobing_level + x in
129 ({ st with current_level = level }, level)
130
131 let enter { current_level; _ } i =
132 { englobing_level = current_level + i; current_level }
133
134 let rec walk_documentedsrc ~on_sub shift_state (l : DocumentedSrc.t) =
135 match l with
136 | [] -> []
137 | ((Code _ | Documented _) as h) :: rest ->
138 h :: walk_documentedsrc ~on_sub shift_state rest
139 | Nested ds :: rest ->
140 let ds =
141 { ds with code = walk_documentedsrc ~on_sub shift_state ds.code }
142 in
143 Nested ds :: walk_documentedsrc ~on_sub shift_state rest
144 | Subpage subp :: rest ->
145 let subp = subpage ~on_sub shift_state subp in
146 Subpage subp :: walk_documentedsrc ~on_sub shift_state rest
147 | Alternative (Expansion r) :: rest ->
148 let expansion = walk_documentedsrc ~on_sub shift_state r.expansion in
149 Alternative (Expansion { r with expansion })
150 :: walk_documentedsrc ~on_sub shift_state rest
151
152 and subpage ~on_sub shift_state (subp : Subpage.t) =
153 match on_sub (`Page subp) with
154 | None -> subp
155 | Some i ->
156 let shift_state = enter shift_state i in
157 let page = subp.content in
158 let content =
159 {
160 page with
161 preamble = walk_item ~on_sub shift_state page.preamble;
162 items = walk_item ~on_sub shift_state page.items;
163 }
164 in
165 { subp with content }
166
167 and include_ ~on_sub shift_state (subp : Include.t) =
168 match on_sub (`Include subp) with
169 | None -> subp
170 | Some i ->
171 let shift_state = enter shift_state i in
172 let content = walk_item ~on_sub shift_state subp.content in
173 { subp with content }
174
175 and walk_item ~on_sub shift_state (l : Item.t list) =
176 match l with
177 | [] -> []
178 | Heading { label; level; title; source_anchor } :: rest ->
179 let shift_state, level = shift shift_state level in
180 Item.Heading { label; level; title; source_anchor }
181 :: walk_item ~on_sub shift_state rest
182 | Include subp :: rest ->
183 let content = include_ ~on_sub shift_state subp.content in
184 let subp = { subp with content } in
185 Item.Include subp :: walk_item ~on_sub shift_state rest
186 | Declaration decl :: rest ->
187 let decl =
188 {
189 decl with
190 content = walk_documentedsrc ~on_sub shift_state decl.content;
191 }
192 in
193 Declaration decl :: walk_item ~on_sub shift_state rest
194 | Text txt :: rest -> Text txt :: walk_item ~on_sub shift_state rest
195
196 let compute ~on_sub i =
197 let shift_state = start in
198 walk_item ~on_sub shift_state i
199end
200
201module Headings : sig
202 val fold :
203 enter_subpages:bool -> ('a -> Heading.t -> 'a) -> 'a -> Page.t -> 'a
204 (** Fold over every headings, follow nested documentedsrc and expansions, as
205 well as subpages if [enter_subpages] is [true]. *)
206
207 val foldmap :
208 enter_subpages:bool ->
209 ('a -> Heading.t -> 'a * Heading.t) ->
210 'a ->
211 Page.t ->
212 'a * Page.t
213end = struct
214 let fold ~enter_subpages =
215 let rec w_page f acc page =
216 w_items f (w_items f acc page.Page.preamble) page.items
217 and w_items f acc ts = List.fold_left (w_item f) acc ts
218 and w_item f acc = function
219 | Heading h -> f acc h
220 | Text _ -> acc
221 | Declaration t -> w_documentedsrc f acc t.Item.content
222 | Include t -> w_items f acc t.Item.content.content
223 and w_documentedsrc f acc t = List.fold_left (w_documentedsrc_one f) acc t
224 and w_documentedsrc_one f acc = function
225 | DocumentedSrc.Code _ | Documented _ -> acc
226 | Nested t -> w_documentedsrc f acc t.code
227 | Subpage sp -> if enter_subpages then w_page f acc sp.content else acc
228 | Alternative (Expansion exp) -> w_documentedsrc f acc exp.expansion
229 in
230 w_page
231
232 let rec foldmap_left f acc rlst = function
233 | [] -> (acc, List.rev rlst)
234 | hd :: tl ->
235 let acc, hd = f acc hd in
236 foldmap_left f acc (hd :: rlst) tl
237
238 let foldmap_left f acc lst = foldmap_left f acc [] lst
239
240 let foldmap ~enter_subpages =
241 let rec w_page f acc page =
242 let acc, preamble = w_items f acc page.Page.preamble in
243 let acc, items = w_items f acc page.items in
244 (acc, { page with preamble; items })
245 and w_items f acc items = foldmap_left (w_item f) acc items
246 and w_item f acc = function
247 | Heading h ->
248 let acc, h = f acc h in
249 (acc, Heading h)
250 | Text _ as x -> (acc, x)
251 | Declaration t ->
252 let acc, content = w_documentedsrc f acc t.content in
253 (acc, Declaration { t with content })
254 | Include t ->
255 let acc, content = w_items f acc t.Item.content.content in
256 (acc, Include { t with content = { t.content with content } })
257 and w_documentedsrc f acc t = foldmap_left (w_documentedsrc_one f) acc t
258 and w_documentedsrc_one f acc = function
259 | (Code _ | Documented _) as x -> (acc, x)
260 | Nested t ->
261 let acc, code = w_documentedsrc f acc t.code in
262 (acc, Nested { t with code })
263 | Subpage sp ->
264 if enter_subpages then
265 let acc, content = w_page f acc sp.content in
266 (acc, Subpage { sp with content })
267 else (acc, Subpage sp)
268 | Alternative (Expansion exp) ->
269 let acc, expansion = w_documentedsrc f acc exp.expansion in
270 (acc, Alternative (Expansion { exp with expansion }))
271 in
272 w_page
273end
274
275module Labels : sig
276 val disambiguate_page : enter_subpages:bool -> Page.t -> Page.t
277 (** Colliding labels are allowed in the model but don't make sense in
278 generators because we need to link to everything (eg. the TOC).
279 Post-process the doctree, add a "_N" suffix to dupplicates, the first
280 occurence is unchanged. Iterate through subpages. *)
281end = struct
282 module StringMap = Map.Make (String)
283
284 let rec make_label_unique labels di label =
285 let label' = label ^ "_" in
286 (* start at [_2]. *)
287 let new_label = label' ^ string_of_int (di + 1) in
288 (* If the label is still ambiguous after suffixing, add an extra '_'. *)
289 if StringMap.mem new_label labels then make_label_unique labels di label'
290 else new_label
291
292 let disambiguate_page ~enter_subpages page =
293 (* Perform two passes, we need to know every labels before allocating new
294 ones. *)
295 let labels =
296 Headings.fold ~enter_subpages
297 (fun acc h ->
298 match h.label with Some l -> StringMap.add l 0 acc | None -> acc)
299 StringMap.empty page
300 in
301 Headings.foldmap ~enter_subpages
302 (fun labels h ->
303 match h.label with
304 | Some l ->
305 let d_index = StringMap.find l labels in
306 let h =
307 if d_index = 0 then h
308 else
309 let label = Some (make_label_unique labels d_index l) in
310 { h with label }
311 in
312 (StringMap.add l (d_index + 1) labels, h)
313 | None -> (labels, h))
314 labels page
315 |> snd
316end
317
318module PageTitle : sig
319 val render_title : ?source_anchor:Url.t -> Page.t -> Item.t list * Item.t list
320 (** Also returns the "new" preamble, since in the case of pages, the title may
321 be extracted from the preamle *)
322
323 val render_src_title : Source_page.t -> Item.t list
324end = struct
325 let format_title ~source_anchor kind name preamble =
326 let mk title =
327 let level = 0 and label = None in
328 [ Types.Item.Heading { level; label; title; source_anchor } ]
329 in
330 let prefix s =
331 mk (Types.inline (Text (s ^ " ")) :: Codefmt.code (Codefmt.txt name))
332 in
333 match kind with
334 | `Module -> (prefix "Module", preamble)
335 | `Parameter _ -> (prefix "Parameter", preamble)
336 | `ModuleType -> (prefix "Module type", preamble)
337 | `ClassType -> (prefix "Class type", preamble)
338 | `Class -> (prefix "Class", preamble)
339 | `SourcePage -> (prefix "Source file", preamble)
340 | `File -> ([], preamble)
341 | `Page | `LeafPage -> (
342 match preamble with
343 | (Item.Heading _ as h) :: rest -> ([ h ], rest)
344 | _ -> ([], preamble))
345
346 let make_name_from_path { Url.Path.name; parent; _ } =
347 match parent with
348 | None | Some { kind = `Page; _ } -> name
349 | Some p -> Printf.sprintf "%s.%s" p.name name
350
351 let render_title ?source_anchor (p : Page.t) =
352 format_title ~source_anchor p.url.kind
353 (make_name_from_path p.url)
354 p.preamble
355
356 let render_src_title (p : Source_page.t) =
357 format_title ~source_anchor:None p.url.kind (make_name_from_path p.url) []
358 |> fst
359end
360
361module Math : sig
362 val has_math_elements : Page.t -> bool
363end = struct
364 let rec items x = List.exists item x
365
366 and item : Item.t -> bool = function
367 | Text x -> block x
368 | Heading x -> heading x
369 | Declaration { content = x; doc; _ } -> documentedsrc x || block doc
370 | Include { content = x; doc; _ } -> include_ x || block doc
371
372 and documentedsrc : DocumentedSrc.t -> bool =
373 fun x ->
374 let documentedsrc_ : DocumentedSrc.one -> bool = function
375 | Code _ -> false
376 | Documented { code = x; doc; _ } -> inline x || block doc
377 | Nested { code = x; doc; _ } -> documentedsrc x || block doc
378 | Subpage x -> subpage x
379 | Alternative x -> alternative x
380 in
381 List.exists documentedsrc_ x
382
383 and subpage : Subpage.t -> bool = fun x -> page x.content
384
385 and page : Page.t -> bool = fun x -> items x.preamble || items x.items
386
387 and alternative : Alternative.t -> bool = function
388 | Expansion x -> documentedsrc x.expansion
389
390 and include_ : Include.t -> bool = fun x -> items x.content
391
392 and block : Block.t -> bool =
393 fun x ->
394 let block_ : Block.one -> bool =
395 fun x ->
396 match x.desc with
397 | Inline x -> inline x
398 | Paragraph x -> inline x
399 | List (_, x) -> List.exists block x
400 | Table { data; align = _ } ->
401 List.exists (List.exists (fun (cell, _) -> block cell)) data
402 | Description x -> description x
403 | Math _ -> true
404 | Audio (_, _)
405 | Video (_, _)
406 | Image (_, _)
407 | Source _ | Verbatim _ | Raw_markup _ ->
408 false
409 in
410 List.exists block_ x
411
412 and heading : Heading.t -> bool = fun x -> inline x.title
413
414 and inline : Inline.t -> bool =
415 fun x ->
416 let inline_ : Inline.one -> bool =
417 fun x ->
418 match x.desc with
419 | Styled (_, x) -> inline x
420 | Link { content = t; _ } -> inline t
421 | Math _ -> true
422 | Text _ | Entity _ | Linebreak | Source _ | Raw_markup _ -> false
423 in
424 List.exists inline_ x
425
426 and description : Description.t -> bool =
427 fun x ->
428 let description_ : Description.one -> bool =
429 fun x -> inline x.key || block x.definition
430 in
431 List.exists description_ x
432
433 let has_math_elements = page
434end