Source file doctree.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
open Types
module Take = struct
type ('a, 'b, 'c) action =
| Rec of 'a list
| Skip
| Accum of 'b list
| Stop_and_keep
| Stop_and_accum of 'b list * 'c option
let until ~classify items =
let rec loop acc = function
| [] -> (List.rev acc, None, [])
| b :: rest -> (
match classify b with
| Skip -> loop acc rest
| Rec x -> loop acc (x @ rest)
| Accum v -> loop (List.rev_append v acc) rest
| Stop_and_keep -> (List.rev acc, None, b :: rest)
| Stop_and_accum (v, e) -> (List.rev_append acc v, e, rest))
in
loop [] items
end
module Rewire = struct
type ('a, 'h) action = Rec of 'a | Skip | Heading of 'h * int
let walk ~classify ~node items =
let rec loop current_level acc l =
match l with
| [] -> (List.rev acc, [])
| b :: rest -> (
match classify b with
| Skip -> loop current_level acc rest
| Rec l -> loop current_level acc (l @ rest)
| Heading (h, level) ->
if level > current_level then
let children, rest = loop level [] rest in
loop current_level (node h children :: acc) rest
else (List.rev acc, l))
in
let trees, rest = loop (-1) [] items in
assert (rest = []);
trees
end
module Toc : sig
type t = one list
and one = { url : Url.t; text : Inline.t; children : t }
val compute :
Url.Path.t -> on_sub:(Include.status -> bool) -> Item.t list -> t
end = struct
type t = one list
and one = { url : Url.t; text : Inline.t; children : t }
let classify ~on_sub (i : Item.t) : _ Rewire.action =
match i with
| Text _ | Declaration _ -> Skip
| Include { content = { status; content; _ }; _ } ->
if on_sub status then Rec content else Skip
| Heading { label = None; _ } -> Skip
| Heading { label = Some label; level; title } ->
Heading ((label, title), level)
let node mkurl (anchor, text) children =
{ url = mkurl anchor; text; children }
let compute page ~on_sub t =
let mkurl anchor = { Url.Anchor.page; anchor; kind = `LeafPage } in
Rewire.walk ~classify:(classify ~on_sub) ~node:(node mkurl) t
end
module Subpages : sig
val compute : Page.t -> Subpage.t list
end = struct
let rec walk_documentedsrc (l : DocumentedSrc.t) =
Utils.flatmap l ~f:(function
| DocumentedSrc.Code _ -> []
| Documented _ -> []
| Nested { code; _ } -> walk_documentedsrc code
| Subpage p -> [ p ]
| Alternative (Expansion r) -> walk_documentedsrc r.expansion)
let rec walk_items (l : Item.t list) =
Utils.flatmap l ~f:(function
| Item.Text _ -> []
| Heading _ -> []
| Declaration { content; _ } -> walk_documentedsrc content
| Include i -> walk_items i.content.content)
let compute (p : Page.t) = walk_items (p.header @ p.items)
end
module Shift = struct
type state = { englobing_level : int; current_level : int }
let start = { englobing_level = 0; current_level = 0 }
let shift st x =
let level = st.englobing_level + x in
({ st with current_level = level }, level)
let enter { current_level; _ } i =
{ englobing_level = current_level + i; current_level }
let rec walk_documentedsrc ~on_sub shift_state (l : DocumentedSrc.t) =
match l with
| [] -> []
| ((Code _ | Documented _) as h) :: rest ->
h :: walk_documentedsrc ~on_sub shift_state rest
| Nested ds :: rest ->
let ds =
{ ds with code = walk_documentedsrc ~on_sub shift_state ds.code }
in
Nested ds :: walk_documentedsrc ~on_sub shift_state rest
| Subpage subp :: rest ->
let subp = subpage ~on_sub shift_state subp in
Subpage subp :: walk_documentedsrc ~on_sub shift_state rest
| Alternative (Expansion r) :: rest ->
let expansion = walk_documentedsrc ~on_sub shift_state r.expansion in
Alternative (Expansion { r with expansion })
:: walk_documentedsrc ~on_sub shift_state rest
and subpage ~on_sub shift_state (subp : Subpage.t) =
match on_sub (`Page subp) with
| None -> subp
| Some i ->
let shift_state = enter shift_state i in
let page = subp.content in
let content =
{
page with
header = walk_item ~on_sub shift_state page.header;
items = walk_item ~on_sub shift_state page.items;
}
in
{ subp with content }
and include_ ~on_sub shift_state (subp : Include.t) =
match on_sub (`Include subp) with
| None -> subp
| Some i ->
let shift_state = enter shift_state i in
let content = walk_item ~on_sub shift_state subp.content in
{ subp with content }
and walk_item ~on_sub shift_state (l : Item.t list) =
match l with
| [] -> []
| Heading { label; level; title } :: rest ->
let shift_state, level = shift shift_state level in
Item.Heading { label; level; title }
:: walk_item ~on_sub shift_state rest
| Include subp :: rest ->
let content = include_ ~on_sub shift_state subp.content in
let subp = { subp with content } in
Item.Include subp :: walk_item ~on_sub shift_state rest
| Declaration decl :: rest ->
let decl =
{
decl with
content = walk_documentedsrc ~on_sub shift_state decl.content;
}
in
Declaration decl :: walk_item ~on_sub shift_state rest
| Text txt :: rest -> Text txt :: walk_item ~on_sub shift_state rest
let compute ~on_sub i =
let shift_state = start in
walk_item ~on_sub shift_state i
end
module Headings : sig
val fold : ('a -> Heading.t -> 'a) -> 'a -> Page.t -> 'a
(** Fold over every headings, follow subpages, nested documentedsrc and
expansions. *)
val foldmap :
('a -> Heading.t -> 'a * Heading.t) -> 'a -> Page.t -> 'a * Page.t
end = struct
let fold =
let rec w_page f acc page =
w_items f (w_items f acc page.Page.header) page.items
and w_items f acc ts = List.fold_left (w_item f) acc ts
and w_item f acc = function
| Heading h -> f acc h
| Text _ -> acc
| Declaration t -> w_documentedsrc f acc t.Item.content
| Include t -> w_items f acc t.Item.content.content
and w_documentedsrc f acc t = List.fold_left (w_documentedsrc_one f) acc t
and w_documentedsrc_one f acc = function
| DocumentedSrc.Code _ | Documented _ -> acc
| Nested t -> w_documentedsrc f acc t.code
| Subpage sp -> w_page f acc sp.content
| Alternative (Expansion exp) -> w_documentedsrc f acc exp.expansion
in
w_page
let rec foldmap_left f acc rlst = function
| [] -> (acc, List.rev rlst)
| hd :: tl ->
let acc, hd = f acc hd in
foldmap_left f acc (hd :: rlst) tl
let foldmap_left f acc lst = foldmap_left f acc [] lst
let foldmap =
let rec w_page f acc page =
let acc, header = w_items f acc page.Page.header in
let acc, items = w_items f acc page.items in
(acc, { page with header; items })
and w_items f acc items = foldmap_left (w_item f) acc items
and w_item f acc = function
| Heading h ->
let acc, h = f acc h in
(acc, Heading h)
| Text _ as x -> (acc, x)
| Declaration t ->
let acc, content = w_documentedsrc f acc t.content in
(acc, Declaration { t with content })
| Include t ->
let acc, content = w_items f acc t.Item.content.content in
(acc, Include { t with content = { t.content with content } })
and w_documentedsrc f acc t = foldmap_left (w_documentedsrc_one f) acc t
and w_documentedsrc_one f acc = function
| (Code _ | Documented _) as x -> (acc, x)
| Nested t ->
let acc, code = w_documentedsrc f acc t.code in
(acc, Nested { t with code })
| Subpage sp ->
let acc, content = w_page f acc sp.content in
(acc, Subpage { sp with content })
| Alternative (Expansion exp) ->
let acc, expansion = w_documentedsrc f acc exp.expansion in
(acc, Alternative (Expansion { exp with expansion }))
in
w_page
end
module Labels : sig
val disambiguate_page : Page.t -> Page.t
(** Colliding labels are allowed in the model but don't make sense in
generators because we need to link to everything (eg. the TOC).
Post-process the doctree, add a "_N" suffix to dupplicates, the first
occurence is unchanged. Iterate through subpages. *)
end = struct
module StringMap = Map.Make (String)
let rec make_label_unique labels di label =
let label' = label ^ "_" in
let new_label = label' ^ string_of_int (di + 1) in
if StringMap.mem new_label labels then make_label_unique labels di label'
else new_label
let disambiguate_page page =
let labels =
Headings.fold
(fun acc h ->
match h.label with Some l -> StringMap.add l 0 acc | None -> acc)
StringMap.empty page
in
Headings.foldmap
(fun acc h ->
match h.label with
| Some l ->
let d_index = StringMap.find l acc in
let h =
if d_index = 0 then h
else
let label = Some (make_label_unique acc d_index l) in
{ h with label }
in
(StringMap.add l (d_index + 1) acc, h)
| None -> (acc, h))
labels page
|> snd
end