Use Odoc_document.Url.Anchor to generate anchors in source code

The anchors are different, since source code anchors needs the full path, but at least the qualification is similar. Replaces `full_name` which did not included enough information to disambiguate functor parameters. Signed-off-by: Paul-Elliot <[email protected]>
ocaml · Sep 5, 2023 · 7804bc0 · Julow · Sep 5, 2023 · 7804bc0
1 parent 37bc8de
commit 7804bc0
Show file tree

Hide file tree

Showing 12 changed files with 201 additions and 171 deletions.
diff --git a/src/document/url.ml b/src/document/url.ml
@@ -3,15 +3,6 @@ open Odoc_model.Paths
 open Odoc_model.Names
 module Root = Odoc_model.Root
 
-let functor_arg_pos : Odoc_model.Paths.Identifier.FunctorParameter.t -> int =
-  let open Odoc_model.Paths.Identifier in
-  fun { iv = `Parameter (p, _); _ } ->
-    let rec inner_sig = function
-      | `Result { iv = p; _ } -> 1 + inner_sig p
-      | `Module _ | `ModuleType _ | `Root _ | `Parameter _ -> 1
-    in
-    inner_sig p.iv
-
 let render_path : Odoc_model.Paths.Path.t -> string =
   let open Odoc_model.Paths.Path in
   let rec render_resolved : Odoc_model.Paths.Path.Resolved.t -> string =
@@ -160,7 +151,7 @@ module Path = struct
         mk ~parent kind name
     | { iv = `Parameter (functor_id, arg_name); _ } as p ->
         let parent = from_identifier (functor_id :> any) in
-        let arg_num = functor_arg_pos p in
+        let arg_num = Identifier.FunctorParameter.functor_arg_pos p in
         let kind = `Parameter arg_num in
         let name = ModuleName.to_string arg_name in
         mk ~parent kind name

diff --git a/src/loader/dune b/src/loader/dune
@@ -22,4 +22,4 @@
  (preprocess
   (action
    (run %{bin:cppo} -V OCAML:%{ocaml_version} %{input-file})))
- (libraries odoc_model odoc-parser syntax_highlighter))
+ (libraries odoc_model odoc-parser syntax_highlighter odoc_document))
diff --git a/src/loader/implementation.ml b/src/loader/implementation.ml
@@ -381,37 +381,79 @@ let postprocess_poses source_id poses uid_to_id uid_to_loc =
   in
   defs @ poses
 
-let string_of_full_name_ty : Odoc_model.Paths.Identifier.full_name_ty -> string
-    = function
-  | `Page -> "page"
-  | `Module -> "module"
-  | `Constructor -> "constructor"
-  | `Field -> "field"
-  | `Extension -> "extension"
-  | `Exception -> "exception"
-  | `Value -> "value"
-  | `Class -> "class"
-  | `ClassType -> "class_type"
-  | `Method -> "method"
-  | `InstanceVariable -> "instance_variable"
-  | `Label -> "label"
-  | `ModuleType -> "module_type"
-  | `Type -> "type"
-  | `Parameter -> "parameter"
-  | `Src -> "src"
-  | `Asset -> "asset"
-
 let anchor_of_identifier id =
-  let full_name = Odoc_model.Paths.Identifier.full_name id in
-  List.filter_map
-    (fun (x, y) ->
-      match x with
-      | `Page -> None
-      | `Src -> None
-      | `Asset -> None
-      | _ -> Some (Printf.sprintf "%s-%s" (string_of_full_name_ty x) y))
-    full_name
-  |> List.tl |> String.concat "."
+  let open Odoc_document.Url in
+  let open Odoc_model.Paths in
+  let open Odoc_model.Names in
+  let rec anchor_of_identifier acc (id : Identifier.t) =
+    let continue anchor parent =
+      anchor_of_identifier (anchor :: acc) (parent :> Identifier.t)
+    in
+    let anchor kind name =
+      Printf.sprintf "%s-%s" (Anchor.string_of_kind kind) name
+    in
+    match id.iv with
+    | `InstanceVariable (parent, name) ->
+        let anchor = anchor `Val (InstanceVariableName.to_string name) in
+        continue anchor parent
+    | `Parameter (parent, name) as iv ->
+        let arg_num =
+          Identifier.FunctorParameter.functor_arg_pos { id with iv }
+        in
+        let kind = `Parameter arg_num in
+        let anchor = anchor kind (ModuleName.to_string name) in
+        continue anchor parent
+    | `Module (parent, name) ->
+        let anchor = anchor `Module (ModuleName.to_string name) in
+        continue anchor parent
+    | `SourceDir _ -> assert false
+    | `ModuleType (parent, name) ->
+        let anchor = anchor `ModuleType (ModuleTypeName.to_string name) in
+        continue anchor parent
+    | `Method (parent, name) ->
+        let anchor = anchor `Method (MethodName.to_string name) in
+        continue anchor parent
+    | `AssetFile _ -> assert false
+    | `Field (parent, name) ->
+        let anchor = anchor `Field (FieldName.to_string name) in
+        continue anchor parent
+    | `SourceLocationMod _ -> assert false
+    | `Result parent -> anchor_of_identifier acc (parent :> Identifier.t)
+    | `SourceLocationInt _ -> assert false
+    | `Type (parent, name) ->
+        let anchor = anchor `Type (TypeName.to_string name) in
+        continue anchor parent
+    | `Label _ -> assert false
+    | `Exception (parent, name) ->
+        let anchor = anchor `Exception (ExceptionName.to_string name) in
+        continue anchor parent
+    | `Class (parent, name) ->
+        let anchor = anchor `Class (ClassName.to_string name) in
+        continue anchor parent
+    | `Page _ -> assert false
+    | `LeafPage _ -> assert false
+    | `CoreType _ -> assert false
+    | `SourceLocation _ -> assert false
+    | `ClassType (parent, name) ->
+        let anchor = anchor `ClassType (ClassTypeName.to_string name) in
+        continue anchor parent
+    | `SourcePage _ -> assert false
+    | `Value (parent, name) ->
+        let anchor = anchor `Val (ValueName.to_string name) in
+        continue anchor parent
+    | `CoreException _ -> assert false
+    | `Constructor (parent, name) ->
+        let anchor = anchor `Constructor (ConstructorName.to_string name) in
+        continue anchor parent
+    | `Root _ ->
+        (* We do not need to include the "container" root module in the anchor
+           to have unique anchors. *)
+        acc
+    | `Extension (parent, name) ->
+        let anchor = anchor `Extension (ExtensionName.to_string name) in
+        continue anchor parent
+  in
+  anchor_of_identifier [] id |> String.concat "."
 
 let of_cmt (source_id_opt : Odoc_model.Paths.Identifier.SourcePage.t option)
     (id : Odoc_model.Paths.Identifier.RootModule.t) (cmt : Cmt_format.cmt_infos)

diff --git a/src/model/paths.ml b/src/model/paths.ml
@@ -64,79 +64,6 @@ module Identifier = struct
 
   let name : [< t_pv ] id -> string = fun n -> name_aux (n :> t)
 
-  type full_name_ty =
-    [ `Page
-    | `Module
-    | `Parameter
-    | `ModuleType
-    | `Type
-    | `Constructor
-    | `Field
-    | `Extension
-    | `Exception
-    | `Value
-    | `Class
-    | `ClassType
-    | `Method
-    | `InstanceVariable
-    | `Label
-    | `Src
-    | `Asset ]
-  let rec full_name_aux : t -> (full_name_ty * string) list =
-   fun x ->
-    match x.iv with
-    | `Root (_, name) -> [ (`Module, ModuleName.to_string name) ]
-    | `Page (_, name) -> [ (`Page, PageName.to_string name) ]
-    | `LeafPage (_, name) -> [ (`Page, PageName.to_string name) ]
-    | `Module (parent, name) ->
-        (`Module, ModuleName.to_string name) :: full_name_aux (parent :> t)
-    | `Parameter (parent, name) ->
-        (`Parameter, ModuleName.to_string name) :: full_name_aux (parent :> t)
-    | `Result x -> full_name_aux (x :> t)
-    | `ModuleType (parent, name) ->
-        (`ModuleType, ModuleTypeName.to_string name)
-        :: full_name_aux (parent :> t)
-    | `Type (parent, name) ->
-        (`Type, TypeName.to_string name) :: full_name_aux (parent :> t)
-    | `CoreType name -> [ (`Type, TypeName.to_string name) ]
-    | `Constructor (parent, name) ->
-        (`Constructor, ConstructorName.to_string name)
-        :: full_name_aux (parent :> t)
-    | `Field (parent, name) ->
-        (`Field, FieldName.to_string name) :: full_name_aux (parent :> t)
-    | `Extension (parent, name) ->
-        (`Extension, ExtensionName.to_string name)
-        :: full_name_aux (parent :> t)
-    | `Exception (parent, name) ->
-        (`Exception, ExceptionName.to_string name)
-        :: full_name_aux (parent :> t)
-    | `CoreException name -> [ (`Exception, ExceptionName.to_string name) ]
-    | `Value (parent, name) ->
-        (`Value, ValueName.to_string name) :: full_name_aux (parent :> t)
-    | `Class (parent, name) ->
-        (`Class, ClassName.to_string name) :: full_name_aux (parent :> t)
-    | `ClassType (parent, name) ->
-        (`ClassType, ClassTypeName.to_string name)
-        :: full_name_aux (parent :> t)
-    | `Method (parent, name) ->
-        (`Method, MethodName.to_string name) :: full_name_aux (parent :> t)
-    | `InstanceVariable (parent, name) ->
-        (`InstanceVariable, InstanceVariableName.to_string name)
-        :: full_name_aux (parent :> t)
-    | `Label (parent, name) ->
-        (`Label, LabelName.to_string name) :: full_name_aux (parent :> t)
-    | `SourceDir (parent, name) -> (`Page, name) :: full_name_aux (parent :> t)
-    | `SourceLocation (parent, name) ->
-        (`Src, DefName.to_string name) :: full_name_aux (parent :> t)
-    | `SourceLocationInt (parent, name) ->
-        (`Src, LocalName.to_string name) :: full_name_aux (parent :> t)
-    | `SourceLocationMod name -> full_name_aux (name :> t)
-    | `SourcePage (parent, name) -> (`Page, name) :: full_name_aux (parent :> t)
-    | `AssetFile (parent, name) -> (`Asset, name) :: full_name_aux (parent :> t)
-
-  let full_name : [< t_pv ] id -> (full_name_ty * string) list =
-   fun n -> List.rev @@ full_name_aux (n :> t)
-
   let rec label_parent_aux =
     let open Id in
     fun (n : non_src) ->
@@ -246,6 +173,13 @@ module Identifier = struct
     let equal = equal
     let hash = hash
     let compare = compare
+
+    let functor_arg_pos { iv = `Parameter (p, _); _ } =
+      let rec inner_sig = function
+        | `Result { iv = p; _ } -> 1 + inner_sig p
+        | `Module _ | `ModuleType _ | `Root _ | `Parameter _ -> 1
+      in
+      inner_sig p.iv
   end
 
   module FunctorResult = struct

diff --git a/src/model/paths.mli b/src/model/paths.mli
@@ -50,10 +50,17 @@ module Identifier : sig
 
   module Module : IdSig with type t = Id.module_ and type t_pv = Id.module_pv
 
-  module FunctorParameter :
-    IdSig
-      with type t = Id.functor_parameter
-       and type t_pv = Id.functor_parameter_pv
+  module FunctorParameter : sig
+    include
+      IdSig
+        with type t = Id.functor_parameter
+         and type t_pv = Id.functor_parameter_pv
+
+    val functor_arg_pos : t -> int
+    (** Gets the index in which the functor argument is, in the argument list.
+      Useful to turn identifiers into unique anchors, since multiple arguments
+      can have the same name. *)
+  end
 
   module ModuleType :
     IdSig with type t = Id.module_type and type t_pv = Id.module_type_pv
@@ -179,27 +186,6 @@ module Identifier : sig
 
   val name : [< t_pv ] id -> string
 
-  type full_name_ty =
-    [ `Page
-    | `Module
-    | `Parameter
-    | `ModuleType
-    | `Type
-    | `Constructor
-    | `Field
-    | `Extension
-    | `Exception
-    | `Value
-    | `Class
-    | `ClassType
-    | `Method
-    | `InstanceVariable
-    | `Label
-    | `Src
-    | `Asset ]
-
-  val full_name : [< t_pv ] id -> (full_name_ty * string) list
-
   (* val root : [< t_pv ] id -> RootModule.t_pv id option *)
 
   val compare : t -> t -> int

diff --git a/test/sources/double_wrapped.t/run.t b/test/sources/double_wrapped.t/run.t
@@ -58,7 +58,7 @@ Look if all the source files are generated:
      <div class="odoc-spec">
       <div class="spec value anchored" id="val-x">
        <a href="#val-x" class="anchor"></a>
-       <a href="../../root/source/a.ml.html#value-x" class="source_link">Source
+       <a href="../../root/source/a.ml.html#val-x" class="source_link">Source
        </a><code><span><span class="keyword">val</span> x : int</span></code>
       </div>
      </div>

diff --git a/test/sources/functor.t/run.t b/test/sources/functor.t/run.t
@@ -53,9 +53,9 @@ In this test, the functor expansion contains the right link.
         class="source_link">Source
        </a>
   --
-       <a href="../../root/source/a.ml.html#module-F.value-y"
-        class="source_link">Source
-       </a>
+       <a href="#val-y" class="anchor"></a>
+       <a href="../../root/source/a.ml.html#module-F.val-y" class="source_link">
+        Source
 
   $ cat html/root/source/a.ml.html | grep L3
   <a id="L3" class="source_line" href="#L3">3</a>
@@ -75,11 +75,11 @@ However, on functor results, there is a link to source in the file:
        </a>
        <code><span><span class="keyword">type</span> t</span>
   --
+      <div class="spec value anchored" id="val-y">
        <a href="#val-y" class="anchor"></a>
-       <a href="../../root/source/a.ml.html#module-F.value-y"
-        class="source_link">Source
+       <a href="../../root/source/a.ml.html#module-F.val-y" class="source_link">
+        Source
        </a>
-       <code>
 
 Source links in functor parameters might not make sense. Currently we generate none:
 

diff --git a/test/sources/include_in_expansion.t/run.t b/test/sources/include_in_expansion.t/run.t
@@ -28,9 +28,9 @@ source parent of value y should be left to B.
      </h1>
   --
          <a href="#val-y" class="anchor"></a>
-         <a href="../../root/source/b.ml.html#value-y" class="source_link">
-          Source
+         <a href="../../root/source/b.ml.html#val-y" class="source_link">Source
+         </a><code><span><span class="keyword">val</span> y : int</span></code>
   --
        <a href="#val-x" class="anchor"></a>
-       <a href="../../root/source/a.ml.html#value-x" class="source_link">Source
+       <a href="../../root/source/a.ml.html#val-x" class="source_link">Source
        </a><code><span><span class="keyword">val</span> x : int</span></code>
diff --git a/test/sources/lookup_def.t/run.t b/test/sources/lookup_def.t/run.t
@@ -14,14 +14,14 @@ Show the locations:
   $ odoc_print a.odocl | jq -c '.. | select(.locs?) | [ .id, .locs ]'
   [{"`Module":[{"`Root":["None","A"]},"M"]},{"Some":{"`SourceLocation":[{"`SourcePage":[{"`Page":[{"Some":{"`Page":["None","root"]}},"source"]},"a.ml"]},"module-M"]}}]
   [{"`Module":[{"`Root":["None","A"]},"N"]},{"Some":{"`SourceLocation":[{"`SourcePage":[{"`Page":[{"Some":{"`Page":["None","root"]}},"source"]},"a.ml"]},"module-N"]}}]
-  [{"`ModuleType":[{"`Module":[{"`Root":["None","A"]},"N"]},"S"]},{"Some":{"`SourceLocation":[{"`SourcePage":[{"`Page":[{"Some":{"`Page":["None","root"]}},"source"]},"a.ml"]},"module-N.module_type-S"]}}]
-  [{"`Value":[{"`ModuleType":[{"`Module":[{"`Root":["None","A"]},"N"]},"S"]},"x"]},{"Some":{"`SourceLocation":[{"`SourcePage":[{"`Page":[{"Some":{"`Page":["None","root"]}},"source"]},"a.ml"]},"module-N.module_type-S"]}}]
+  [{"`ModuleType":[{"`Module":[{"`Root":["None","A"]},"N"]},"S"]},{"Some":{"`SourceLocation":[{"`SourcePage":[{"`Page":[{"Some":{"`Page":["None","root"]}},"source"]},"a.ml"]},"module-N.module-type-S"]}}]
+  [{"`Value":[{"`ModuleType":[{"`Module":[{"`Root":["None","A"]},"N"]},"S"]},"x"]},{"Some":{"`SourceLocation":[{"`SourcePage":[{"`Page":[{"Some":{"`Page":["None","root"]}},"source"]},"a.ml"]},"module-N.module-type-S"]}}]
   [{"`Module":[{"`Module":[{"`Root":["None","A"]},"N"]},"T"]},{"Some":{"`SourceLocation":[{"`SourcePage":[{"`Page":[{"Some":{"`Page":["None","root"]}},"source"]},"a.ml"]},"module-N.module-T"]}}]
-  [{"`Value":[{"`Module":[{"`Module":[{"`Root":["None","A"]},"N"]},"T"]},"x"]},{"Some":{"`SourceLocation":[{"`SourcePage":[{"`Page":[{"Some":{"`Page":["None","root"]}},"source"]},"a.ml"]},"module-N.module-T.value-x"]}}]
+  [{"`Value":[{"`Module":[{"`Module":[{"`Root":["None","A"]},"N"]},"T"]},"x"]},{"Some":{"`SourceLocation":[{"`SourcePage":[{"`Page":[{"Some":{"`Page":["None","root"]}},"source"]},"a.ml"]},"module-N.module-T.val-x"]}}]
   [{"`Type":[{"`Root":["None","A"]},"t"]},{"Some":{"`SourceLocation":[{"`SourcePage":[{"`Page":[{"Some":{"`Page":["None","root"]}},"source"]},"a.ml"]},"type-t"]}}]
-  [{"`Value":[{"`Root":["None","A"]},"a"]},{"Some":{"`SourceLocation":[{"`SourcePage":[{"`Page":[{"Some":{"`Page":["None","root"]}},"source"]},"a.ml"]},"value-a"]}}]
+  [{"`Value":[{"`Root":["None","A"]},"a"]},{"Some":{"`SourceLocation":[{"`SourcePage":[{"`Page":[{"Some":{"`Page":["None","root"]}},"source"]},"a.ml"]},"val-a"]}}]
   [{"`Exception":[{"`Root":["None","A"]},"Exn"]},{"Some":{"`SourceLocation":[{"`SourcePage":[{"`Page":[{"Some":{"`Page":["None","root"]}},"source"]},"a.ml"]},"exception-Exn"]}}]
   [{"`Type":[{"`Root":["None","A"]},"ext"]},{"Some":{"`SourceLocation":[{"`SourcePage":[{"`Page":[{"Some":{"`Page":["None","root"]}},"source"]},"a.ml"]},"type-ext"]}}]
   [{"`Extension":[{"`Root":["None","A"]},"Ext"]},{"Some":{"`SourceLocation":[{"`SourcePage":[{"`Page":[{"Some":{"`Page":["None","root"]}},"source"]},"a.ml"]},"extension-Ext"]}}]
   [{"`Class":[{"`Root":["None","A"]},"cls"]},{"Some":{"`SourceLocation":[{"`SourcePage":[{"`Page":[{"Some":{"`Page":["None","root"]}},"source"]},"a.ml"]},"class-cls"]}}]
-  [{"`ClassType":[{"`Root":["None","A"]},"clst"]},{"Some":{"`SourceLocation":[{"`SourcePage":[{"`Page":[{"Some":{"`Page":["None","root"]}},"source"]},"a.ml"]},"class_type-clst"]}}]
+  [{"`ClassType":[{"`Root":["None","A"]},"clst"]},{"Some":{"`SourceLocation":[{"`SourcePage":[{"`Page":[{"Some":{"`Page":["None","root"]}},"source"]},"a.ml"]},"class-type-clst"]}}]
diff --git a/test/sources/lookup_def_wrapped.t/run.t b/test/sources/lookup_def_wrapped.t/run.t
@@ -62,7 +62,7 @@ Look if all the source files are generated:
      <div class="odoc-spec">
       <div class="spec value anchored" id="val-x">
        <a href="#val-x" class="anchor"></a>
-       <a href="../../root/source/a.ml.html#value-x" class="source_link">Source
+       <a href="../../root/source/a.ml.html#val-x" class="source_link">Source
        </a><code><span><span class="keyword">val</span> x : int</span></code>
       </div>
      </div>

diff --git a/test/sources/source.t/a.ml b/test/sources/source.t/a.ml
@@ -2,6 +2,14 @@ type t = string
 
 type truc = A | B
 
+let xazaz = A
+
+module Yoyo = struct
+  type bli = Aa | Bb
+end
+
+let segr = Yoyo.Aa
+
 let x = 2
 let y = x + 1
 let z a = if x = 1 || true then x + y else 0
@@ -42,3 +50,11 @@ end
 module FM = F (struct
   module A = struct end
 end)
+
+module FF (A : sig end) (B : sig end) = struct end
+module FF2 (A : sig
+  module E : sig end
+end) (A : sig
+  module F : sig end
+end) =
+struct end