Improve the logic in html/link.ml

This should additionally fix the issue mentioned in PR #528

Signed-off-by: Jon Ludlam <jon@recoil.org>

Author: jonludlam

src/html/link.ml

@@ -14,24 +14,28 @@ module Path = struct
   let for_printing url = List.map snd @@ to_list url
 
   let segment_to_string (kind, name) =
-    if kind = "module" || kind = "cpage" || kind = "page"
-    then name
-    else Printf.sprintf "%s-%s" kind name
-  let for_linking url = List.map segment_to_string @@ to_list url
+    match kind with
+    | "module" | "cpage" -> name
+    | _ -> Printf.sprintf "%s-%s" kind name
 
   let is_leaf_page url = (url.Url.Path.kind = "page")
 
   let rec get_dir {Url.Path. parent ; name ; kind} =
-    let s = segment_to_string (kind, name) in
-    match parent with
-    | None -> Fpath.v s
-    | Some p -> Fpath.(get_dir p / s)
+    let ppath = match parent with | Some p -> get_dir p | None -> [] in
+    match kind with
+    | "page" -> ppath
+    | _ -> ppath @ [segment_to_string (kind, name)]
+
+  let get_file : Url.Path.t -> string = fun t ->
+    match t.kind with
+    | "page" -> t.name ^ ".html"
+    | _ -> "index.html"
+
+  let for_linking : Url.Path.t -> string list = fun url ->
+    get_dir url @ [get_file url]
 
   let as_filename (url : Url.Path.t) =
-    if is_leaf_page url then
-      Fpath.(get_dir url + ".html")
-    else
-      Fpath.(get_dir url / "index.html")
+    Fpath.(v @@ String.concat Fpath.dir_sep @@ for_linking url)
 end
 
 let semantic_uris = ref false
@@ -46,34 +50,51 @@ let rec drop_shared_prefix l1 l2 =
     drop_shared_prefix l1s l2s
   | _, _ -> l1, l2
 
-let href ~resolve { Url.Anchor. page; anchor; kind } =
-  let leaf = if !semantic_uris || kind = "page" then [] else ["index.html"] in
-  let target = Path.for_linking page @ leaf in
-  match resolve with
+let href ~resolve t =
+  let { Url.Anchor. page; anchor; _ } = t in
+
+  let target_loc = Path.for_linking page in
+
   (* If xref_base_uri is defined, do not perform relative URI resolution. *)
+  match resolve with
   | Base xref_base_uri ->
-    let page = xref_base_uri ^ String.concat "/" target in
+    let page = xref_base_uri ^ (String.concat "/" target_loc) in
     begin match anchor with
     | "" -> page
     | anchor -> page ^ "#" ^ anchor
     end
   | Current path ->
-    let current_loc =
-      let l = Path.for_linking path in
-      if Path.is_leaf_page path then
-        (* Sadness. *)
-        List.tl l
-      else l
-    in
+    let current_loc = Path.for_linking path in
+
     let current_from_common_ancestor, target_from_common_ancestor =
-      drop_shared_prefix current_loc target
+      drop_shared_prefix current_loc target_loc
     in
+
     let relative_target =
-      List.map (fun _ -> "..") current_from_common_ancestor
-      @ target_from_common_ancestor
+      match current_from_common_ancestor with
+      | [] -> (* We're already on the right page *)
+        (* If we're already on the right page, the target from our common
+            ancestor can't be anything other than the empty list *)
+        assert(target_from_common_ancestor = []);
+        []
+      | [_] -> (* We're already in the right dir *)
+        target_from_common_ancestor
+      | l -> (* We need to go up some dirs *)
+        List.map (fun _ -> "..") (List.tl l)
+        @ target_from_common_ancestor
     in
-    let page = String.concat "/" relative_target in
-    begin match anchor with
-    | "" -> page
-    | anchor -> page ^ "#" ^ anchor
+    let remove_index_html l =
+      match List.rev l with
+      | "index.html" :: rest -> List.rev ("" :: rest)
+      | _ -> l
+    in
+    let relative_target =
+      if !semantic_uris
+      then remove_index_html relative_target
+      else relative_target
+    in
+    begin match relative_target, anchor with
+    | [], "" -> "#"
+    | page, "" -> String.concat "/" page
+    | page, anchor -> String.concat "/" page ^ "#" ^ anchor
     end

test/html/expect/test_package+custom_theme,ml/Module/index.html

@@ -58,7 +58,7 @@ <h1>
     <a href="#type-result" class="anchor"></a><code><span class="keyword">type</span> <span>('a, 'b) result</span></code>
    </div>
    <div class="spec module-type" id="module-type-S6">
-    <a href="#module-type-S6" class="anchor"></a><code><span class="keyword">module</span> <span class="keyword">type</span> <a href="module-type-S6/index.html">S6</a> = <a href="module-type-S/index.html">S</a> <span class="keyword">with</span> <span class="keyword">type</span> <span>('a, 'b) <a href="module-type-S/index.html#type-w">w</a></span> := <span><span>(<span class="type-var">'a</span>,&nbsp;<span class="type-var">'b</span>)</span> <a href="index.html#type-result">result</a></span></code>
+    <a href="#module-type-S6" class="anchor"></a><code><span class="keyword">module</span> <span class="keyword">type</span> <a href="module-type-S6/index.html">S6</a> = <a href="module-type-S/index.html">S</a> <span class="keyword">with</span> <span class="keyword">type</span> <span>('a, 'b) <a href="module-type-S/index.html#type-w">w</a></span> := <span><span>(<span class="type-var">'a</span>,&nbsp;<span class="type-var">'b</span>)</span> <a href="#type-result">result</a></span></code>
    </div>
    <div class="spec module" id="module-M'">
     <a href="#module-M'" class="anchor"></a><code><span class="keyword">module</span> <a href="M'/index.html">M'</a> : <span class="keyword">sig</span> ... <span class="keyword">end</span></code>

test/html/expect/test_package+ml/Labels/index.html

@@ -51,7 +51,7 @@ <h2 id="L2">
    </div>
    <div>
     <div class="spec value" id="val-f">
-     <a href="#val-f" class="anchor"></a><code><span class="keyword">val</span> f : <a href="index.html#type-t">t</a></code>
+     <a href="#val-f" class="anchor"></a><code><span class="keyword">val</span> f : <a href="#type-t">t</a></code>
     </div>
     <div>
      <p>
@@ -61,7 +61,7 @@ <h2 id="L2">
    </div>
    <div>
     <div class="spec external" id="val-e">
-     <a href="#val-e" class="anchor"></a><code><span class="keyword">val</span> e : unit <span>-&gt;</span> <a href="index.html#type-t">t</a></code>
+     <a href="#val-e" class="anchor"></a><code><span class="keyword">val</span> e : unit <span>-&gt;</span> <a href="#type-t">t</a></code>
     </div>
     <div>
      <p>
@@ -93,7 +93,7 @@ <h2 id="L2">
    </div>
    <div>
     <div class="spec extension">
-     <code><span class="keyword">type</span> <a href="index.html#type-x">x</a> += </code>
+     <code><span class="keyword">type</span> <a href="#type-x">x</a> += </code>
      <table>
       <tbody>
        <tr id="extension-X" class="anchored">
@@ -122,7 +122,7 @@ <h2 id="L2">
    </div>
    <div>
     <div class="spec type-subst" id="type-s">
-     <a href="#type-s" class="anchor"></a><code><span class="keyword">type</span> s := <a href="index.html#type-t">t</a></code>
+     <a href="#type-s" class="anchor"></a><code><span class="keyword">type</span> s := <a href="#type-t">t</a></code>
     </div>
     <div>
      <p>
@@ -153,7 +153,7 @@ <h2 id="L2">
      <tbody>
       <tr id="type-v.f" class="anchored">
        <td class="def record field">
-        <a href="#type-v.f" class="anchor"></a><code>f : <a href="index.html#type-t">t</a>;</code>
+        <a href="#type-v.f" class="anchor"></a><code>f : <a href="#type-t">t</a>;</code>
        </td>
        <td class="doc">
         <p>
@@ -171,43 +171,43 @@ <h2 id="L2">
     </p>
     <ul>
      <li>
-      <a href="index.html#L1">Attached to unit</a>
+      <a href="#L1">Attached to unit</a>
      </li>
      <li>
-      <a href="index.html#L2">Attached to nothing</a>
+      <a href="#L2">Attached to nothing</a>
      </li>
      <li>
-      <a href="index.html#L3">Attached to module</a>
+      <a href="#L3">Attached to module</a>
      </li>
      <li>
-      <a href="index.html#L4">Attached to type</a>
+      <a href="#L4">Attached to type</a>
      </li>
      <li>
-      <a href="index.html#L5">Attached to value</a>
+      <a href="#L5">Attached to value</a>
      </li>
      <li>
-      <a href="index.html#L6">Attached to class</a>
+      <a href="#L6">Attached to class</a>
      </li>
      <li>
-      <a href="index.html#L7">Attached to class type</a>
+      <a href="#L7">Attached to class type</a>
      </li>
      <li>
-      <a href="index.html#L8">Attached to exception</a>
+      <a href="#L8">Attached to exception</a>
      </li>
      <li>
-      <a href="index.html#L9">Attached to extension</a>
+      <a href="#L9">Attached to extension</a>
      </li>
      <li>
-      <a href="index.html#L10">Attached to module subst</a>
+      <a href="#L10">Attached to module subst</a>
      </li>
      <li>
-      <a href="index.html#L11">Attached to type subst</a>
+      <a href="#L11">Attached to type subst</a>
      </li>
      <li>
-      <a href="index.html#L12">Attached to constructor</a>
+      <a href="#L12">Attached to constructor</a>
      </li>
      <li>
-      <a href="index.html#L13">Attached to field</a>
+      <a href="#L13">Attached to field</a>
      </li>
     </ul>
    </aside>

test/html/expect/test_package+ml/Markup/index.html

@@ -112,7 +112,7 @@ <h4 id="anchors">
    </h4>
    <aside>
     <p>
-     Sections can have attached <a href="index.html#anchors">Anchors</a>, and it is possible to <a href="index.html#anchors">link</a> to them. Links to section headers should not be set in source code style.
+     Sections can have attached <a href="#anchors">Anchors</a>, and it is possible to <a href="#anchors">link</a> to them. Links to section headers should not be set in source code style.
     </p>
    </aside>
    <h5 id="paragraph">
@@ -162,7 +162,7 @@ <h2 id="links-and-references">
      This is a <a href="#">link</a>. It sends you to the top of this page. Links can have markup inside them: <a href="#"><b>bold</b></a>, <a href="#"><i>italics</i></a>, <a href="#"><em>emphasis</em></a>, <a href="#">super<sup>script</sup></a>, <a href="#">sub<sub>script</sub></a>, and <a href="#"><code>code</code></a>. Links can also be nested <em><a href="#">inside</a></em> markup. Links cannot be nested inside each other. This link has no replacement text: <a href="#">#</a>. The text is filled in by odoc. This is a shorthand link: <a href="#">#</a>. The text is also filled in by odoc in this case.
     </p>
     <p>
-     This is a reference to <a href="index.html#val-foo"><code>foo</code></a>. References can have replacement text: <a href="index.html#val-foo">the value foo</a>. Except for the special lookup support, references are pretty much just like links. The replacement text can have nested styles: <a href="index.html#val-foo"><b>bold</b></a>, <a href="index.html#val-foo"><i>italic</i></a>, <a href="index.html#val-foo"><em>emphasis</em></a>, <a href="index.html#val-foo">super<sup>script</sup></a>, <a href="index.html#val-foo">sub<sub>script</sub></a>, and <a href="index.html#val-foo"><code>code</code></a>. It's also possible to surround a reference in a style: <b><a href="index.html#val-foo"><code>foo</code></a></b>. References can't be nested inside references, and links and references can't be nested inside each other.
+     This is a reference to <a href="#val-foo"><code>foo</code></a>. References can have replacement text: <a href="#val-foo">the value foo</a>. Except for the special lookup support, references are pretty much just like links. The replacement text can have nested styles: <a href="#val-foo"><b>bold</b></a>, <a href="#val-foo"><i>italic</i></a>, <a href="#val-foo"><em>emphasis</em></a>, <a href="#val-foo">super<sup>script</sup></a>, <a href="#val-foo">sub<sub>script</sub></a>, and <a href="#val-foo"><code>code</code></a>. It's also possible to surround a reference in a style: <b><a href="#val-foo"><code>foo</code></a></b>. References can't be nested inside references, and links and references can't be nested inside each other.
     </p>
    </aside>
    <h2 id="preformatted-text">
@@ -256,7 +256,7 @@ <h2 id="lists">
         and can include references
        </li>
        <li>
-        <a href="index.html#val-foo"><code>foo</code></a>
+        <a href="#val-foo"><code>foo</code></a>
        </li>
       </ul>
      </li>

test/html/expect/test_package+ml/Module/index.html

@@ -58,7 +58,7 @@ <h1>
     <a href="#type-result" class="anchor"></a><code><span class="keyword">type</span> <span>('a, 'b) result</span></code>
    </div>
    <div class="spec module-type" id="module-type-S6">
-    <a href="#module-type-S6" class="anchor"></a><code><span class="keyword">module</span> <span class="keyword">type</span> <a href="module-type-S6/index.html">S6</a> = <a href="module-type-S/index.html">S</a> <span class="keyword">with</span> <span class="keyword">type</span> <span>('a, 'b) <a href="module-type-S/index.html#type-w">w</a></span> := <span><span>(<span class="type-var">'a</span>,&nbsp;<span class="type-var">'b</span>)</span> <a href="index.html#type-result">result</a></span></code>
+    <a href="#module-type-S6" class="anchor"></a><code><span class="keyword">module</span> <span class="keyword">type</span> <a href="module-type-S6/index.html">S6</a> = <a href="module-type-S/index.html">S</a> <span class="keyword">with</span> <span class="keyword">type</span> <span>('a, 'b) <a href="module-type-S/index.html#type-w">w</a></span> := <span><span>(<span class="type-var">'a</span>,&nbsp;<span class="type-var">'b</span>)</span> <a href="#type-result">result</a></span></code>
    </div>
    <div class="spec module" id="module-M'">
     <a href="#module-M'" class="anchor"></a><code><span class="keyword">module</span> <a href="M'/index.html">M'</a> : <span class="keyword">sig</span> ... <span class="keyword">end</span></code>

test/html/expect/test_package+ml/Nested/F/argument-1-Arg1/index.html

@@ -51,7 +51,7 @@ <h2 id="values">
    </h2>
    <div>
     <div class="spec value" id="val-y">
-     <a href="#val-y" class="anchor"></a><code><span class="keyword">val</span> y : <a href="index.html#type-t">t</a></code>
+     <a href="#val-y" class="anchor"></a><code><span class="keyword">val</span> y : <a href="#type-t">t</a></code>
     </div>
     <div>
      <p>

test/html/expect/test_package+ml/Nested/X/index.html

@@ -57,7 +57,7 @@ <h2 id="values">
    </h2>
    <div>
     <div class="spec value" id="val-x">
-     <a href="#val-x" class="anchor"></a><code><span class="keyword">val</span> x : <a href="index.html#type-t">t</a></code>
+     <a href="#val-x" class="anchor"></a><code><span class="keyword">val</span> x : <a href="#type-t">t</a></code>
     </div>
     <div>
      <p>

test/html/expect/test_package+ml/Nested/module-type-Y/index.html

@@ -57,7 +57,7 @@ <h2 id="values">
    </h2>
    <div>
     <div class="spec value" id="val-y">
-     <a href="#val-y" class="anchor"></a><code><span class="keyword">val</span> y : <a href="index.html#type-t">t</a></code>
+     <a href="#val-y" class="anchor"></a><code><span class="keyword">val</span> y : <a href="#type-t">t</a></code>
     </div>
     <div>
      <p>