jon.recoil.org
this repo has no description
1open Odoc_model.Paths
2open Odoc_model.Names
3module Root = Odoc_model.Root
4
5 let parent_is_module : Identifier.Id.signature -> bool = fun x ->
6 match x.iv with
7 | `Module _ -> true
8 | `ModuleType _ -> false
9 | `Parameter _ -> true
10 | `Result _ -> false
11 | `Root _ -> true
12
13 let rec name_aux : Identifier.t -> string list =
14 fun x ->
15 match x.iv with
16 | `Root (_, name) -> [ModuleName.to_string name]
17 | `Module (p, name) when parent_is_module p -> ModuleName.to_string name :: name_aux (p :> Identifier.t)
18 | `Module (_, name) -> [ModuleName.to_string name]
19 | `Parameter (_, name) -> [ModuleName.to_string name]
20 | `Result x -> name_aux (x :> Identifier.t)
21 | `ModuleType (p, name) when parent_is_module p -> ModuleTypeName.to_string name :: name_aux (p :> Identifier.t)
22 | `ModuleType (_, name) -> [ModuleTypeName.to_string name]
23 | `Type (p, name) when parent_is_module p -> TypeName.to_string name :: name_aux (p :> Identifier.t)
24 | `Type (_, name) -> [TypeName.to_string name]
25 | `Constructor (_, name) -> [ConstructorName.to_string name]
26 | `Field (_, name) -> [FieldName.to_string name]
27 | `UnboxedField (_, name) -> [UnboxedFieldName.to_string name]
28 | `Extension (_, name) -> [ExtensionName.to_string name]
29 | `ExtensionDecl (_, _, name) -> [ExtensionName.to_string name]
30 | `Exception (_, name) -> [ExceptionName.to_string name]
31 | `Value (_, name) -> [ValueName.to_string name]
32 | `Class (_, name) -> [TypeName.to_string name]
33 | `ClassType (_, name) -> [TypeName.to_string name]
34 | `Method (_, name) -> [MethodName.to_string name]
35 | `InstanceVariable (_, name) -> [InstanceVariableName.to_string name]
36 | `Label (_, name) -> [LabelName.to_string name]
37 | `SourcePage (_, name) -> [name]
38 | `SourceLocation (x, anchor) ->
39 [List.hd (name_aux (x :> Identifier.t)) ^ "#" ^ DefName.to_string anchor]
40 | `SourceLocationMod x -> name_aux (x :> Identifier.t)
41 | `SourceLocationInternal (x, anchor) ->
42 [List.hd (name_aux (x :> Identifier.t)) ^ "#" ^ LocalName.to_string anchor]
43 | `AssetFile (_, name) -> [AssetName.to_string name]
44 | `Page (_, name) -> [PageName.to_string name]
45 | `LeafPage (_, name) -> [PageName.to_string name]
46
47 let full_ident_name : [< Identifier.t_pv ] Identifier.id -> string = fun id ->
48 let segs = name_aux (id :> Identifier.t) in
49 String.concat "." (List.rev segs)
50
51
52let render_path : Path.t -> string =
53 let rec render_resolved : Path.Resolved.t -> string =
54 let open Path.Resolved in
55 function
56 | `Identifier id -> full_ident_name id
57 | `CoreType n -> TypeName.to_string n
58 | `OpaqueModule p -> render_resolved (p :> t)
59 | `OpaqueModuleType p -> render_resolved (p :> t)
60 | `Subst (_, p) -> render_resolved (p :> t)
61 | `SubstT (_, p) -> render_resolved (p :> t)
62 | `Alias (dest, `Resolved src) ->
63 if Path.Resolved.(is_hidden (src :> t)) then render_resolved (dest :> t)
64 else render_resolved (src :> t)
65 | `Alias (dest, src) ->
66 if Path.is_hidden (src :> Path.t) then render_resolved (dest :> t)
67 else render_path (src :> Path.t)
68 | `AliasModuleType (p1, p2) ->
69 if Path.Resolved.(is_hidden (p2 :> t)) then render_resolved (p1 :> t)
70 else render_resolved (p2 :> t)
71 | `Hidden p -> render_resolved (p :> t)
72 | `Module (p, s) -> render_resolved (p :> t) ^ "." ^ ModuleName.to_string s
73 | `Canonical (_, `Resolved p) -> render_resolved (p :> t)
74 | `Canonical (p, _) -> render_resolved (p :> t)
75 | `CanonicalModuleType (_, `Resolved p) -> render_resolved (p :> t)
76 | `CanonicalModuleType (p, _) -> render_resolved (p :> t)
77 | `CanonicalType (_, `Resolved p) -> render_resolved (p :> t)
78 | `CanonicalType (p, _) -> render_resolved (p :> t)
79 | `Substituted c -> render_resolved (c :> t)
80 | `SubstitutedMT c -> render_resolved (c :> t)
81 | `SubstitutedT c -> render_resolved (c :> t)
82 | `SubstitutedCT c -> render_resolved (c :> t)
83 | `Apply (rp, p) ->
84 render_resolved (rp :> t)
85 ^ "("
86 ^ render_resolved (p :> Path.Resolved.t)
87 ^ ")"
88 | `ModuleType (p, s) ->
89 render_resolved (p :> t) ^ "." ^ ModuleTypeName.to_string s
90 | `Type (p, s) -> render_resolved (p :> t) ^ "." ^ TypeName.to_string s
91 | `Value (p, s) -> render_resolved (p :> t) ^ "." ^ ValueName.to_string s
92 | `Class (p, s) -> render_resolved (p :> t) ^ "." ^ TypeName.to_string s
93 | `ClassType (p, s) -> render_resolved (p :> t) ^ "." ^ TypeName.to_string s
94 and dot p s = render_path (p : Path.Module.t :> Path.t) ^ "." ^ s
95 and render_path : Path.t -> string =
96 fun x ->
97 match x with
98 | `Identifier (id, _) -> Identifier.name id
99 | `Root root -> ModuleName.to_string root
100 | `Forward root -> root
101 | `Dot (p, s) -> dot p (ModuleName.to_string s)
102 | `DotT (p, s) -> dot p (TypeName.to_string s)
103 | `DotMT (p, s) -> dot p (ModuleTypeName.to_string s)
104 | `DotV (p, s) -> dot p (ValueName.to_string s)
105 | `Apply (p1, p2) ->
106 render_path (p1 :> Path.t) ^ "(" ^ render_path (p2 :> Path.t) ^ ")"
107 | `Resolved rp -> render_resolved rp
108 | `Substituted m -> render_path (m :> Path.t)
109 | `SubstitutedMT m -> render_path (m :> Path.t)
110 | `SubstitutedT m -> render_path (m :> Path.t)
111 | `SubstitutedCT m -> render_path (m :> Path.t)
112 in
113
114 render_path
115
116module Path = struct
117 type nonsrc_pv =
118 [ Identifier.Page.t_pv
119 | Identifier.Signature.t_pv
120 | Identifier.ClassSignature.t_pv ]
121
122 type any_pv =
123 [ nonsrc_pv | Identifier.SourcePage.t_pv | Identifier.AssetFile.t_pv ]
124
125 and any = any_pv Identifier.id
126
127 type kind =
128 [ `Module
129 | `Page
130 | `LeafPage
131 | `ModuleType
132 | `Parameter of int
133 | `Class
134 | `ClassType
135 | `File
136 | `SourcePage ]
137
138 let string_of_kind : kind -> string = function
139 | `Page -> "page"
140 | `Module -> "module"
141 | `LeafPage -> "leaf-page"
142 | `ModuleType -> "module-type"
143 | `Parameter arg_num -> Printf.sprintf "argument-%d" arg_num
144 | `Class -> "class"
145 | `ClassType -> "class-type"
146 | `File -> "file"
147 | `SourcePage -> "source"
148
149 let pp_kind fmt kind = Format.fprintf fmt "%s" (string_of_kind kind)
150
151 let pp_disambiguating_prefix fmt = function
152 | `Module | `Page | `LeafPage | `File | `SourcePage -> ()
153 | kind -> Format.fprintf fmt "%s-" (string_of_kind kind)
154
155 type t = { kind : kind; parent : t option; name : string }
156
157 let mk ?parent kind name = { kind; parent; name }
158
159 let rec from_identifier : any -> t =
160 fun x ->
161 match x with
162 | { iv = `Root (parent, unit_name); _ } ->
163 let parent =
164 match parent with
165 | Some p -> Some (from_identifier (p :> any))
166 | None -> None
167 in
168 let kind = `Module in
169 let name = ModuleName.to_string unit_name in
170 mk ?parent kind name
171 | { iv = `Page (parent, page_name); _ } ->
172 let parent =
173 match parent with
174 | Some p -> Some (from_identifier (p :> any))
175 | None -> None
176 in
177 let kind = `Page in
178 let name = PageName.to_string page_name in
179 mk ?parent kind name
180 | { iv = `LeafPage (parent, page_name); _ } ->
181 let parent =
182 match parent with
183 | Some p -> Some (from_identifier (p :> any))
184 | None -> None
185 in
186 let kind = `LeafPage in
187 let name = PageName.to_string page_name in
188 mk ?parent kind name
189 | { iv = `Module (parent, mod_name); _ } ->
190 let parent = from_identifier (parent :> any) in
191 let kind = `Module in
192 let name = ModuleName.to_string mod_name in
193 mk ~parent kind name
194 | { iv = `Parameter (functor_id, arg_name); _ } as p ->
195 let parent = from_identifier (functor_id :> any) in
196 let arg_num = Identifier.FunctorParameter.functor_arg_pos p in
197 let kind = `Parameter arg_num in
198 let name = ModuleName.to_string arg_name in
199 mk ~parent kind name
200 | { iv = `ModuleType (parent, modt_name); _ } ->
201 let parent = from_identifier (parent :> any) in
202 let kind = `ModuleType in
203 let name = ModuleTypeName.to_string modt_name in
204 mk ~parent kind name
205 | { iv = `Class (parent, name); _ } ->
206 let parent = from_identifier (parent :> any) in
207 let kind = `Class in
208 let name = TypeName.to_string name in
209 mk ~parent kind name
210 | { iv = `ClassType (parent, name); _ } ->
211 let parent = from_identifier (parent :> any) in
212 let kind = `ClassType in
213 let name = TypeName.to_string name in
214 mk ~parent kind name
215 | { iv = `Result p; _ } -> from_identifier (p :> any)
216 | { iv = `SourcePage (parent, name); _ } ->
217 let parent = from_identifier (parent :> any) in
218 let kind = `SourcePage in
219 mk ~parent kind name
220 | { iv = `AssetFile (parent, name); _ } ->
221 let parent = from_identifier (parent :> any) in
222 let kind = `File in
223 let name = AssetName.to_string name in
224 mk ~parent kind name
225
226 let from_identifier p = from_identifier (p : [< any_pv ] Identifier.id :> any)
227
228 let to_list url =
229 let rec loop acc { parent; name; kind } =
230 match parent with
231 | None -> (kind, name) :: acc
232 | Some p -> loop ((kind, name) :: acc) p
233 in
234 loop [] url
235
236 let of_list l =
237 let rec inner parent = function
238 | [] -> parent
239 | (kind, name) :: xs -> inner (Some { parent; name; kind }) xs
240 in
241 inner None l
242
243 let split :
244 is_dir:(kind -> [ `Always | `Never | `IfNotLast ]) ->
245 (kind * string) list ->
246 (kind * string) list * (kind * string) list =
247 fun ~is_dir l ->
248 let rec inner dirs = function
249 | [ ((kind, _) as x) ] when is_dir kind = `IfNotLast ->
250 (List.rev dirs, [ x ])
251 | ((kind, _) as x) :: xs when is_dir kind <> `Never ->
252 inner (x :: dirs) xs
253 | xs -> (List.rev dirs, xs)
254 in
255 inner [] l
256
257 let rec is_prefix (url1 : t) (url2 : t) =
258 match url1 with
259 | { kind = `LeafPage; parent = None; name = "index" } -> true
260 | { kind = `LeafPage; parent = Some p; name = "index" } -> is_prefix p url2
261 | _ -> (
262 if url1 = url2 then true
263 else
264 match url2 with
265 | { parent = Some parent; _ } -> is_prefix url1 parent
266 | { parent = None; _ } -> false)
267end
268
269module Anchor = struct
270 type kind =
271 [ Path.kind
272 | `Section
273 | `Type
274 | `Extension
275 | `ExtensionDecl
276 | `Exception
277 | `Method
278 | `Val
279 | `Constructor
280 | `Field
281 | `UnboxedField
282 | `SourceAnchor ]
283
284 let string_of_kind : kind -> string = function
285 | #Path.kind as k -> Path.string_of_kind k
286 | `Section -> "section"
287 | `Type -> "type"
288 | `Extension -> "extension"
289 | `ExtensionDecl -> "extension-decl"
290 | `Exception -> "exception"
291 | `Method -> "method"
292 | `Val -> "val"
293 | `Constructor -> "constructor"
294 | `Field -> "field"
295 | `UnboxedField -> "unboxed-field"
296 | `SourceAnchor -> "source-anchor"
297
298 let pp_kind fmt kind = Format.fprintf fmt "%s" (string_of_kind kind)
299
300 type t = { page : Path.t; anchor : string; kind : kind }
301
302 let anchorify_path { Path.parent; name; kind } =
303 match parent with
304 | None -> assert false (* We got a root, should never happen *)
305 | Some page ->
306 let anchor = Printf.sprintf "%s-%s" (Path.string_of_kind kind) name in
307 { page; anchor; kind = (kind :> kind) }
308
309 let add_suffix ~kind { page; anchor; _ } suffix =
310 { page; anchor = anchor ^ "." ^ suffix; kind }
311
312 let mk ~kind parent str_name =
313 let page = Path.from_identifier parent in
314 { page; anchor = str_name; kind }
315
316 (* This is needed to ensure that references to polymorphic constructors have
317 links that use the right suffix: those resolved references are turned into
318 _constructor_ identifiers. *)
319 let suffix_for_constructor x = x
320
321 let rec from_identifier : Identifier.t -> t = function
322 | { iv = `Module (parent, mod_name); _ } ->
323 let parent = Path.from_identifier (parent :> Path.any) in
324 let kind = `Module in
325 let anchor =
326 Printf.sprintf "%s-%s" (Path.string_of_kind kind)
327 (ModuleName.to_string mod_name)
328 in
329 { page = parent; anchor; kind }
330 | { iv = `Root _; _ } as p ->
331 let page = Path.from_identifier (p :> Path.any) in
332 { page; kind = `Module; anchor = "" }
333 | { iv = `Page _; _ } as p ->
334 let page = Path.from_identifier (p :> Path.any) in
335 { page; kind = `Page; anchor = "" }
336 | { iv = `LeafPage _; _ } as p ->
337 let page = Path.from_identifier (p :> Path.any) in
338 { page; kind = `LeafPage; anchor = "" }
339 (* For all these identifiers, page names and anchors are the same *)
340 | {
341 iv = `Parameter _ | `Result _ | `ModuleType _ | `Class _ | `ClassType _;
342 _;
343 } as p ->
344 anchorify_path @@ Path.from_identifier p
345 | { iv = `Type (parent, type_name); _ } ->
346 let page = Path.from_identifier (parent :> Path.any) in
347 let kind = `Type in
348 {
349 page;
350 anchor =
351 Format.asprintf "%a-%s" pp_kind kind (TypeName.to_string type_name);
352 kind;
353 }
354 | { iv = `Extension (parent, name); _ } ->
355 let page = Path.from_identifier (parent :> Path.any) in
356 let kind = `Extension in
357 {
358 page;
359 anchor =
360 Format.asprintf "%a-%s" pp_kind kind (ExtensionName.to_string name);
361 kind;
362 }
363 | { iv = `ExtensionDecl (parent, name, _); _ } ->
364 let page = Path.from_identifier (parent :> Path.any) in
365 let kind = `ExtensionDecl in
366 {
367 page;
368 anchor =
369 Format.asprintf "%a-%s" pp_kind kind (ExtensionName.to_string name);
370 kind;
371 }
372 | { iv = `Exception (parent, name); _ } ->
373 let page = Path.from_identifier (parent :> Path.any) in
374 let kind = `Exception in
375 {
376 page;
377 anchor =
378 Format.asprintf "%a-%s" pp_kind kind (ExceptionName.to_string name);
379 kind;
380 }
381 | { iv = `Value (parent, name); _ } ->
382 let page = Path.from_identifier (parent :> Path.any) in
383 let kind = `Val in
384 {
385 page;
386 anchor =
387 Format.asprintf "%a-%s" pp_kind kind (ValueName.to_string name);
388 kind;
389 }
390 | { iv = `Method (parent, name); _ } ->
391 let str_name = MethodName.to_string name in
392 let page = Path.from_identifier (parent :> Path.any) in
393 let kind = `Method in
394 { page; anchor = Format.asprintf "%a-%s" pp_kind kind str_name; kind }
395 | { iv = `InstanceVariable (parent, name); _ } ->
396 let str_name = InstanceVariableName.to_string name in
397 let page = Path.from_identifier (parent :> Path.any) in
398 let kind = `Val in
399 { page; anchor = Format.asprintf "%a-%s" pp_kind kind str_name; kind }
400 | { iv = `Constructor (parent, name); _ } ->
401 let page = from_identifier (parent :> Identifier.t) in
402 let kind = `Constructor in
403 let suffix = suffix_for_constructor (ConstructorName.to_string name) in
404 add_suffix ~kind page suffix
405 | { iv = `Field (parent, name); _ } ->
406 let page = from_identifier (parent :> Identifier.t) in
407 let kind = `Field in
408 let suffix = FieldName.to_string name in
409 add_suffix ~kind page suffix
410 | { iv = `UnboxedField (parent, name); _ } ->
411 let page = from_identifier (parent :> Identifier.t) in
412 let kind = `UnboxedField in
413 let suffix = UnboxedFieldName.to_string name in
414 add_suffix ~kind page suffix
415 | { iv = `Label (parent, anchor); _ } -> (
416 let str_name = LabelName.to_string anchor in
417 (* [Identifier.LabelParent.t] contains datatypes. [`CoreType] can't
418 happen, [`Type] may not happen either but just in case, use the
419 grand-parent. *)
420 match parent with
421 | { iv = `Type (gp, _); _ } -> mk ~kind:`Section gp str_name
422 | { iv = #Path.nonsrc_pv; _ } as p ->
423 mk ~kind:`Section (p :> Path.any) str_name)
424 | { iv = `SourceLocation (parent, loc); _ } ->
425 let page = Path.from_identifier (parent :> Path.any) in
426 { page; kind = `SourceAnchor; anchor = DefName.to_string loc }
427 | { iv = `SourceLocationInternal (parent, loc); _ } ->
428 let page = Path.from_identifier (parent :> Path.any) in
429 { page; kind = `SourceAnchor; anchor = LocalName.to_string loc }
430 | { iv = `SourceLocationMod parent; _ } ->
431 let page = Path.from_identifier (parent :> Path.any) in
432 { page; kind = `SourceAnchor; anchor = "" }
433 | { iv = `SourcePage _; _ } as p ->
434 let page = Path.from_identifier (p :> Path.any) in
435 { page; kind = `Page; anchor = "" }
436 | { iv = `AssetFile _; _ } as p ->
437 let page = Path.from_identifier p in
438 { page; kind = `File; anchor = "" }
439
440 let polymorphic_variant ~type_ident elt =
441 let name_of_type_constr te =
442 match te with
443 | Odoc_model.Lang.TypeExpr.Constr (path, _) ->
444 render_path (path :> Odoc_model.Paths.Path.t)
445 | _ ->
446 invalid_arg
447 "DocOckHtml.Url.Polymorphic_variant_decl.name_of_type_constr"
448 in
449 let url = from_identifier type_ident in
450 match elt with
451 | Odoc_model.Lang.TypeExpr.Polymorphic_variant.Type te ->
452 let kind = `Type in
453 let suffix = name_of_type_constr te in
454 add_suffix ~kind url suffix
455 | Constructor { name; _ } ->
456 let kind = `Constructor in
457 let suffix = suffix_for_constructor name in
458 add_suffix ~kind url suffix
459
460 (** The anchor looks like
461 [extension-decl-"Path.target_type"-FirstConstructor]. *)
462 let extension_decl (decl : Odoc_model.Lang.Extension.t) =
463 let page = Path.from_identifier (decl.parent :> Path.any) in
464 let kind = `ExtensionDecl in
465 let first_cons = Identifier.name (List.hd decl.constructors).id in
466 let anchor = Format.asprintf "%a-%s" pp_kind kind first_cons in
467 { page; kind; anchor }
468
469 let source_anchor path anchor = { page = path; anchor; kind = `SourceAnchor }
470end
471
472type kind = Anchor.kind
473
474type t = Anchor.t
475
476let from_path page =
477 { Anchor.page; anchor = ""; kind = (page.kind :> Anchor.kind) }
478
479let from_identifier ~stop_before x =
480 match x with
481 | { Identifier.iv = #Path.any_pv; _ } as p when not stop_before ->
482 from_path @@ Path.from_identifier p
483 | p -> Anchor.from_identifier p
484
485let from_asset_identifier p = from_path @@ Path.from_identifier p
486
487let kind id =
488 let { Anchor.kind; _ } = Anchor.from_identifier id in
489 kind