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
open Odoc_utils
module Id = Paths.Identifier
module CPH = Id.Hashtbl.ContainerPage
module LPH = Id.Hashtbl.LeafPage
type page = Id.Page.t
type leaf_page = Id.LeafPage.t
type container_page = Id.ContainerPage.t
open Astring
module PageToc = struct
type title = Comment.link_content
type payload = {
title : title;
children_order : Frontmatter.children_order option;
}
type dir_content = { leafs : payload LPH.t; dirs : in_progress CPH.t }
and in_progress = container_page option * dir_content
let empty_t dir_id = (dir_id, { leafs = LPH.create 10; dirs = CPH.create 10 })
let get_parent id : container_page option =
let id :> page = id in
match id.iv with
| `Page (Some parent, _) -> Some parent
| `LeafPage (Some parent, _) -> Some parent
| `Page (None, _) | `LeafPage (None, _) -> None
let find_leaf ((_, dir_content) : in_progress) leaf_page =
try Some (LPH.find dir_content.leafs leaf_page) with Not_found -> None
let leafs (_, dir_content) =
LPH.fold
(fun id { title = payload; _ } acc ->
if String.equal "index" (Paths.Identifier.name id) then acc
else (id, payload) :: acc)
dir_content.leafs []
let dirs (_, dir_content) =
CPH.fold (fun id payload acc -> (id, payload) :: acc) dir_content.dirs []
let rec get_or_create (dir : in_progress) (id : container_page) : in_progress
=
let _, { dirs = parent_dirs; _ } =
match get_parent id with
| Some parent -> get_or_create dir parent
| None -> dir
in
let current_item =
try Some (CPH.find parent_dirs id) with Not_found -> None
in
match current_item with
| Some item -> item
| None ->
let new_ = empty_t (Some id) in
CPH.add parent_dirs id new_;
new_
let add (dir : in_progress) ((id : leaf_page), title, children_order) =
let _, dir_content =
match get_parent id with
| Some parent -> get_or_create dir parent
| None -> dir
in
LPH.replace dir_content.leafs id { title; children_order }
let dir_index ((parent_id, _) as dir) =
let index_id =
Paths.Identifier.Mk.leaf_page (parent_id, Names.PageName.make_std "index")
in
match find_leaf dir index_id with
| Some payload -> Some (payload, index_id, payload.title)
| None -> None
type index = Id.Page.t * title
type t = (Id.Page.t * content) list * index option
and content = Entry of title | Dir of t
let rec t_of_in_progress (dir : in_progress) =
let children_order, index =
match dir_index dir with
| Some ({ children_order; _ }, index_id, index_title) ->
(children_order, Some (index_id, index_title))
| None -> (None, None)
in
let pp_content fmt (id, _) =
match id.Id.iv with
| `LeafPage (_, name) ->
Format.fprintf fmt "'%s'" (Names.PageName.to_string name)
| `Page (_, name) ->
Format.fprintf fmt "'%s/'" (Names.PageName.to_string name)
in
let pp_children fmt c =
match c.Location_.value with
| Frontmatter.Page s -> Format.fprintf fmt "'%s'" s
| Dir s -> Format.fprintf fmt "'%s/'" s
in
let ordered, unordered =
let contents =
let leafs =
leafs dir
|> List.map (fun (id, payload) -> ((id :> Id.Page.t), Entry payload))
in
let dirs =
dirs dir
|> List.map (fun (id, payload) ->
((id :> Id.Page.t), Dir (t_of_in_progress payload)))
in
leafs @ dirs
in
match children_order with
| None -> ([], contents)
| Some children_order ->
let children_indexes =
List.mapi (fun i x -> (i, x)) children_order.value
in
let equal id ch =
match (ch, id.Id.iv) with
| (_, { Location_.value = Frontmatter.Dir c; _ }), `Page (_, name)
->
String.equal (Names.PageName.to_string name) c
| (_, { Location_.value = Page c; _ }), `LeafPage (_, name) ->
String.equal (Names.PageName.to_string name) c
| _ -> false
in
let children_indexes, indexed_content, unindexed_content =
List.fold_left
(fun (children_indexes, indexed_content, unindexed_content)
(((id : Id.Page.t), _) as entry) ->
let indexes_for_entry, children_indexes =
List.partition (equal id) children_indexes
in
match indexes_for_entry with
| [] ->
( children_indexes,
indexed_content,
entry :: unindexed_content )
| (i, _) :: rest ->
List.iter
(fun (_, c) ->
Error.raise_warning
(Error.make "Duplicate %a in (children)." pp_children
c (Location_.location c)))
rest;
( children_indexes,
(i, entry) :: indexed_content,
unindexed_content ))
(children_indexes, [], []) contents
in
List.iter
(fun (_, c) ->
Error.raise_warning
(Error.make "%a in (children) does not correspond to anything."
pp_children c (Location_.location c)))
children_indexes;
(indexed_content, unindexed_content)
in
let () =
match (children_order, unordered) with
| Some x, (_ :: _ as l) ->
Error.raise_warning
(Error.make "(children) doesn't include %a."
(Format.pp_print_list pp_content)
l (Location_.location x))
| _ -> ()
in
let ordered =
ordered
|> List.sort (fun (i, _) (j, _) -> (compare : int -> int -> int) i j)
|> List.map snd
in
let unordered =
List.sort
(fun (x, _) (y, _) ->
String.compare (Paths.Identifier.name x) (Paths.Identifier.name y))
unordered
in
let contents = ordered @ unordered in
(contents, index)
let rec remove_common_root (v : t) =
match v with [ (_, Dir v) ], None -> remove_common_root v | _ -> v
let of_list l =
let dir = empty_t None in
List.iter (add dir) l;
t_of_in_progress dir |> remove_common_root
end
type toc = PageToc.t
type library = { name : string; units : Paths.Identifier.RootModule.t list }
type page_hierarchy = { hierarchy_name : string; pages : toc }
type t = { pages : page_hierarchy list; libraries : library list }