jon.recoil.org
this repo has no description
1module Url = Odoc_document.Url
2
3type link = Relative of string list * string | Absolute of string
4
5(* Translation from Url.Path *)
6module Path = struct
7 let for_printing url = List.map snd @@ Url.Path.to_list url
8
9 let segment_to_string (kind, name) =
10 Format.asprintf "%a%s" Url.Path.pp_disambiguating_prefix kind name
11
12 let is_leaf_page url = url.Url.Path.kind = `LeafPage
13
14 let remap config f =
15 let l = String.concat "/" f in
16 let remaps =
17 List.filter
18 (fun (prefix, _replacement) -> Astring.String.is_prefix ~affix:prefix l)
19 (Config.remap config)
20 in
21 let remaps =
22 List.sort
23 (fun (a, _) (b, _) -> compare (String.length b) (String.length a))
24 remaps
25 in
26 match remaps with
27 | [] -> None
28 | (prefix, replacement) :: _ ->
29 let len = String.length prefix in
30 let l = String.sub l len (String.length l - len) in
31 Some (replacement ^ l)
32
33 let get_dir_and_file ~config url =
34 let l = Url.Path.to_list url in
35 let is_dir =
36 if Config.flat config then function `Page -> `Always | _ -> `Never
37 else function `LeafPage | `File | `SourcePage -> `Never | _ -> `Always
38 in
39 let dir, file = Url.Path.split ~is_dir l in
40 let dir = List.map segment_to_string dir in
41 let file =
42 match file with
43 | [] -> "index.html"
44 | [ (`LeafPage, name) ] -> name ^ ".html"
45 | [ (`File, name) ] -> name
46 | [ (`SourcePage, name) ] -> name ^ ".html"
47 | xs ->
48 assert (Config.flat config);
49 String.concat "-" (List.map segment_to_string xs) ^ ".html"
50 in
51 (dir, file)
52
53 let for_linking ~config url =
54 let dir, file = get_dir_and_file ~config url in
55 match remap config dir with
56 | None -> Relative (dir, file)
57 | Some x -> Absolute (x ^ "/" ^ file)
58
59 let as_filename ~config (url : Url.Path.t) =
60 let dir, file = get_dir_and_file ~config url in
61 Fpath.(v @@ String.concat Fpath.dir_sep (dir @ [ file ]))
62end
63
64type resolve = Current of Url.Path.t | Base of string
65
66let rec drop_shared_prefix l1 l2 =
67 match (l1, l2) with
68 | l1 :: l1s, l2 :: l2s when l1 = l2 -> drop_shared_prefix l1s l2s
69 | _, _ -> (l1, l2)
70
71let href ~config ~resolve t =
72 let { Url.Anchor.page; anchor; _ } = t in
73 let add_anchor y = match anchor with "" -> y | anchor -> y ^ "#" ^ anchor in
74 let target_loc = Path.for_linking ~config page in
75
76 match target_loc with
77 | Absolute y -> add_anchor y
78 | Relative (dir, file) -> (
79 let target_loc = dir @ [ file ] in
80 (* If xref_base_uri is defined, do not perform relative URI resolution. *)
81 match resolve with
82 | Base xref_base_uri ->
83 let page = xref_base_uri ^ String.concat "/" target_loc in
84 add_anchor page
85 | Current path -> (
86 let current_loc =
87 let dir, file = Path.get_dir_and_file ~config path in
88 dir @ [ file ]
89 in
90
91 let current_from_common_ancestor, target_from_common_ancestor =
92 drop_shared_prefix current_loc target_loc
93 in
94
95 let relative_target =
96 match current_from_common_ancestor with
97 | [] ->
98 (* We're already on the right page *)
99 (* If we're already on the right page, the target from our common
100 ancestor can't be anything other than the empty list *)
101 assert (target_from_common_ancestor = []);
102 []
103 | [ _ ] ->
104 (* We're already in the right dir *)
105 target_from_common_ancestor
106 | l ->
107 (* We need to go up some dirs *)
108 List.map (fun _ -> "..") (List.tl l)
109 @ target_from_common_ancestor
110 in
111 let remove_index_html l =
112 match List.rev l with
113 | "index.html" :: rest -> List.rev ("" :: rest)
114 | _ -> l
115 in
116 let relative_target =
117 if Config.semantic_uris config then
118 remove_index_html relative_target
119 else relative_target
120 in
121 match (relative_target, anchor) with
122 | [], "" -> "#"
123 | page, _ -> add_anchor @@ String.concat "/" page))