Fix reference urls to sections

It was using the wrong parent (which defines the containing page).

Author: Julow

src/document/url.ml

@@ -144,6 +144,10 @@ module Anchor = struct
   let add_suffix ~kind { page; anchor; _ } suffix =
     { page; anchor = anchor ^ "." ^ suffix; kind }
 
+  let mk ~kind parent str_name =
+    let page = Path.from_identifier parent in
+    Ok { page; anchor = str_name; kind }
+
   let rec from_identifier : Identifier.t -> (t, Error.t) result =
     let open Error in
     function
@@ -230,16 +234,15 @@ module Anchor = struct
         let kind = "field" in
         let suffix = FieldName.to_string name in
         Ok (add_suffix ~kind page suffix)
-    | `Label (parent, anchor') -> (
-        let anchor = LabelName.to_string anchor' in
-        from_identifier (parent :> Identifier.t) >>= function
-        | { page; anchor = _; kind } ->
-            (* Really ad-hoc and shitty, but it works. *)
-            if kind = "page" then Ok { page; anchor; kind }
-            else Ok { page; anchor; kind = "" })
-
-  (* | _ ->
-     Error (Unexpected_anchor ("label " ^ anchor)) *)
+    | `Label (parent, anchor) -> (
+        let str_name = LabelName.to_string anchor in
+        (* [Identifier.LabelParent.t] contains datatypes. [`CoreType] can't
+           happen, [`Type] may not happen either but just in case, use the
+           grand-parent. *)
+        match parent with
+        | #Path.source as parent -> mk ~kind:"section" parent str_name
+        | `CoreType _ -> Error (Unexpected_anchor "core_type label parent")
+        | `Type (gp, _) -> mk ~kind:"section" gp str_name)
 
   let polymorphic_variant ~type_ident elt =
     let name_of_type_constr te =

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

@@ -1922,7 +1922,7 @@ <h2 id="section-title-splicing">
      <code>{!section:SuperSig.SubSigA.subSig}</code> : <code>SuperSig</code>.SubSigA.subSig
     </li>
     <li>
-     <code>{!Aliases.incl}</code> : <a href="#incl"><code>Aliases:incl</code></a>
+     <code>{!Aliases.incl}</code> : <a href="Aliases/index.html#incl"><code>Aliases:incl</code></a>
     </li>
    </ul>
    <p>
@@ -1939,7 +1939,7 @@ <h2 id="section-title-splicing">
      <code>{{!section:SuperSig.SubSigA.subSig}C}</code> : <span class="xref-unresolved">C</span>
     </li>
     <li>
-     <code>{{!Aliases.incl}D}</code> : <a href="#incl">D</a>
+     <code>{{!Aliases.incl}D}</code> : <a href="Aliases/index.html#incl">D</a>
     </li>
    </ul>
    <h2 id="new-reference-syntax">

test/html/expect/test_package+re/Ocamlary/index.html

@@ -1939,7 +1939,7 @@ <h2 id="section-title-splicing">
      <code>{!section:SuperSig.SubSigA.subSig}</code> : <code>SuperSig</code>.SubSigA.subSig
     </li>
     <li>
-     <code>{!Aliases.incl}</code> : <a href="#incl"><code>Aliases:incl</code></a>
+     <code>{!Aliases.incl}</code> : <a href="Aliases/index.html#incl"><code>Aliases:incl</code></a>
     </li>
    </ul>
    <p>
@@ -1956,7 +1956,7 @@ <h2 id="section-title-splicing">
      <code>{{!section:SuperSig.SubSigA.subSig}C}</code> : <span class="xref-unresolved">C</span>
     </li>
     <li>
-     <code>{{!Aliases.incl}D}</code> : <a href="#incl">D</a>
+     <code>{{!Aliases.incl}D}</code> : <a href="Aliases/index.html#incl">D</a>
     </li>
    </ul>
    <h2 id="new-reference-syntax">

test/xref2/labels.t/run.t

@@ -54,8 +54,8 @@ There are two references in N, one should point to a local label and the other t
     </nav>
     <div class="odoc-content">
      <h2 id="B"><a href="#B" class="anchor"></a>An other conflicting label</h2>
-     <p><a href="../index.html#B">An other conflicting label</a> 
-      <a href="../index.html#B"><code>M:B</code></a>
+     <p><a href="#B">An other conflicting label</a> 
+      <a href="../M/index.html#B"><code>M:B</code></a>
      </p>
     </div>
    </body>