jon.recoil.org
this repo has no description
1open Odoc_utils
2open Odoc_model
3
4(* Selective opens *)
5module Id = Odoc_model.Paths.Identifier
6module PageName = Odoc_model.Names.PageName
7module ModuleName = Odoc_model.Names.ModuleName
8
9type t = Entry.t Tree.t
10
11let compare_entry (t1 : t) (t2 : t) =
12 let by_kind (t : t) =
13 match t.node.kind with
14 | Page _ | Dir -> 0
15 | Module _ -> 10
16 | Impl -> 20
17 | _ -> 30
18 in
19 let by_category (t : t) =
20 match t.node.kind with
21 | Page { order_category = Some o; _ } -> o
22 | _ -> "default"
23 in
24 let by_name (t : t) =
25 match t.node.kind with
26 | Page { short_title = Some title; _ } -> Comment.to_string title
27 | _ -> (
28 match t.node.id.iv with
29 | `LeafPage (Some parent, name)
30 when Names.PageName.to_string name = "index" ->
31 Id.name parent
32 | _ -> Id.name t.node.id)
33 in
34 let try_ comp f fallback =
35 match comp (f t1) (f t2) with 0 -> fallback () | i -> i
36 in
37 try_ (compare : int -> int -> int) by_kind @@ fun () ->
38 try_ Astring.String.compare by_category @@ fun () ->
39 try_ Astring.String.compare by_name @@ fun () -> 0
40
41let rec t_of_in_progress (dir : In_progress.in_progress) : t =
42 let entry_of_page page =
43 let kind = Entry.Page page.Lang.Page.frontmatter in
44 let doc = page.content.elements in
45 let id = page.name in
46 Entry.entry ~kind ~doc ~id ~source_loc:None
47 in
48 let entry_of_impl id =
49 let kind = Entry.Impl in
50 Entry.entry ~kind ~doc:[] ~id ~source_loc:None
51 in
52 let children_order, index =
53 match In_progress.index dir with
54 | Some (_, page) ->
55 let children_order = page.frontmatter.children_order in
56 let entry = entry_of_page page in
57 (children_order, entry)
58 | None ->
59 let entry =
60 match In_progress.root_dir dir with
61 | Some id ->
62 let kind = Entry.Dir in
63 Entry.entry ~kind ~doc:[] ~id ~source_loc:None
64 | None ->
65 let id =
66 (* root dir must have an index page *)
67 Id.Mk.leaf_page (None, Names.PageName.make_std "index")
68 in
69 let kind = Entry.Dir in
70 Entry.entry ~kind ~doc:[] ~id ~source_loc:None
71 in
72 (None, entry)
73 in
74 let pp_content fmt (id, _) =
75 match id.Id.iv with
76 | `LeafPage (_, name) -> Format.fprintf fmt "'%s'" (PageName.to_string name)
77 | `Page (_, name) -> Format.fprintf fmt "'%s/'" (PageName.to_string name)
78 | `Root (_, name) ->
79 Format.fprintf fmt "'module-%s'" (ModuleName.to_string name)
80 | _ -> Format.fprintf fmt "'unsupported'"
81 in
82 let pp_children fmt c =
83 match c.Location_.value with
84 | Frontmatter.Page s -> Format.fprintf fmt "'%s'" s
85 | Dir s -> Format.fprintf fmt "'%s/'" s
86 | Module s -> Format.fprintf fmt "'module-%s'" s
87 in
88 let ordered, unordered =
89 let contents =
90 let leafs =
91 In_progress.leafs dir
92 |> List.map (fun (_, page) ->
93 let id :> Id.t = page.Lang.Page.name in
94 let entry = entry_of_page page in
95 (id, Tree.leaf entry))
96 in
97 let dirs =
98 In_progress.dirs dir
99 |> List.map (fun (id, payload) ->
100 let id :> Id.t = id in
101 (id, t_of_in_progress payload))
102 in
103 let modules =
104 In_progress.modules dir
105 |> List.map (fun (id, payload) -> ((id :> Id.t), payload))
106 in
107 let implementations =
108 In_progress.implementations dir
109 |> List.map (fun (id, _impl) ->
110 ((id :> Id.t), Tree.leaf @@ entry_of_impl id))
111 in
112 leafs @ dirs @ modules @ implementations
113 in
114 match children_order with
115 | None -> ([], contents)
116 | Some children_order ->
117 let children_indexes =
118 List.mapi (fun i x -> (i, x)) children_order.value
119 in
120 let equal id ch =
121 match (ch, id.Id.iv) with
122 | (_, { Location_.value = Frontmatter.Dir c; _ }), `Page (_, name) ->
123 Astring.String.equal (PageName.to_string name) c
124 | (_, { Location_.value = Page c; _ }), `LeafPage (_, name) ->
125 Astring.String.equal (PageName.to_string name) c
126 | (_, { Location_.value = Module c; _ }), `Root (_, name) ->
127 Astring.String.equal (ModuleName.to_string name) c
128 | _ -> false
129 in
130 let children_indexes, indexed_content, unindexed_content =
131 List.fold_left
132 (fun (children_indexes, indexed_content, unindexed_content)
133 ((id, _) as entry) ->
134 let indexes_for_entry, children_indexes =
135 List.partition (equal id) children_indexes
136 in
137 match indexes_for_entry with
138 | [] ->
139 (children_indexes, indexed_content, entry :: unindexed_content)
140 | (i, _) :: rest ->
141 List.iter
142 (fun (_, c) ->
143 Error.raise_warning
144 (Error.make "Duplicate %a in (children)." pp_children c
145 (Location_.location c)))
146 rest;
147 ( children_indexes,
148 (i, entry) :: indexed_content,
149 unindexed_content ))
150 (children_indexes, [], []) contents
151 in
152 List.iter
153 (fun (_, c) ->
154 Error.raise_warning
155 (Error.make "%a in (children) does not correspond to anything."
156 pp_children c (Location_.location c)))
157 children_indexes;
158 (indexed_content, unindexed_content)
159 in
160 let () =
161 match (children_order, unordered) with
162 | Some x, (_ :: _ as l) ->
163 Error.raise_warning
164 (Error.make "(children) doesn't include %a."
165 (Format.pp_print_list pp_content)
166 l (Location_.location x))
167 | _ -> ()
168 in
169 let ordered =
170 ordered
171 |> List.sort (fun (i, _) (j, _) -> (compare : int -> int -> int) i j)
172 |> List.map snd
173 in
174 let unordered =
175 List.sort (fun (_, x) (_, y) -> compare_entry x y) unordered
176 in
177 let contents = ordered @ unordered |> List.map snd in
178 { Tree.node = index; children = contents }
179
180let rec remove_common_root (v : t) =
181 match v with
182 | { Tree.children = [ v ]; node = { kind = Dir; _ } } -> remove_common_root v
183 | _ -> v
184
185let lang ~pages ~modules ~implementations =
186 let dir = In_progress.empty_t None in
187 List.iter (In_progress.add_page dir) pages;
188 List.iter (In_progress.add_module dir) modules;
189 List.iter (In_progress.add_implementation dir) implementations;
190 t_of_in_progress dir |> remove_common_root