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 []
18 (* List.filter
19 (fun (prefix, _replacement) -> Astring.String.is_prefix ~affix:prefix l)
20 false (* (Config.remap config) *) *)
21 in
22 let remaps =
23 List.sort
24 (fun (a, _) (b, _) -> compare (String.length b) (String.length a))
25 remaps
26 in
27 match remaps with
28 | [] -> None
29 | (prefix, replacement) :: _ ->
30 let len = String.length prefix in
31 let l = String.sub l len (String.length l - len) in
32 Some (replacement ^ l)
33
34 let get_dir_and_file ~config:_ url =
35 let l = Url.Path.to_list url in
36 let is_dir =
37 if (* Config.flat config *) true then function
38 | `Page -> `Always | _ -> `Never
39 else function `LeafPage | `File | `SourcePage -> `Never | _ -> `Always
40 in
41 let dir, file = Url.Path.split ~is_dir l in
42 let dir = List.map segment_to_string dir in
43 let file =
44 match file with
45 | [] -> "index.md"
46 | [ (`LeafPage, name) ] -> name ^ ".md"
47 | [ (`File, name) ] -> name
48 | [ (`SourcePage, name) ] -> name ^ ".md"
49 | xs ->
50 (* assert (Config.flat config); *)
51 String.concat "-" (List.map segment_to_string xs) ^ ".md"
52 in
53 (dir, file)
54
55 let for_linking ~config url =
56 let dir, file = get_dir_and_file ~config url in
57 match remap config dir with
58 | None -> Relative (dir, file)
59 | Some x -> Absolute (x ^ "/" ^ file)
60
61 let as_filename ~config (url : Url.Path.t) =
62 let dir, file = get_dir_and_file ~config url in
63 Fpath.(v @@ String.concat Fpath.dir_sep (dir @ [ file ]))
64end
65
66type resolve = Current of Url.Path.t | Base of string
67
68let rec drop_shared_prefix l1 l2 =
69 match (l1, l2) with
70 | l1 :: l1s, l2 :: l2s when l1 = l2 -> drop_shared_prefix l1s l2s
71 | _, _ -> (l1, l2)
72
73let href ~config ~resolve t =
74 let { Url.Anchor.page; anchor; _ } = t in
75 let add_anchor y = match anchor with "" -> y | anchor -> y ^ "#" ^ anchor in
76 let target_loc = Path.for_linking ~config page in
77
78 match target_loc with
79 | Absolute y -> add_anchor y
80 | Relative (dir, file) -> (
81 let target_loc = dir @ [ file ] in
82 (* If xref_base_uri is defined, do not perform relative URI resolution. *)
83 match resolve with
84 | Base xref_base_uri ->
85 let page = xref_base_uri ^ String.concat "/" target_loc in
86 add_anchor page
87 | Current path -> (
88 let current_loc =
89 let dir, file = Path.get_dir_and_file ~config path in
90 dir @ [ file ]
91 in
92 let current_from_common_ancestor, target_from_common_ancestor =
93 drop_shared_prefix current_loc target_loc
94 in
95
96 let relative_target =
97 match current_from_common_ancestor with
98 | [] ->
99 (* We're already on the right page *)
100 (* If we're already on the right page, the target from our common
101 ancestor can't be anything other than the empty list *)
102 assert (target_from_common_ancestor = []);
103 []
104 | [ _ ] ->
105 (* We're already in the right dir *)
106 target_from_common_ancestor
107 | l ->
108 (* We need to go up some dirs *)
109 List.map (fun _ -> "..") (List.tl l)
110 @ target_from_common_ancestor
111 in
112 match (relative_target, anchor) with
113 | [], "" -> "#"
114 (* TODO: This looks wrong ./ could technically be the current page *)
115 | page, _ -> "./" ^ add_anchor @@ String.concat "/" page))