Fix wrong id being given to doc comments

CHANGES.md

@@ -38,6 +38,7 @@
 - Fixed 404 links from search results (@panglesd, #1108)
 - Fixed title content not being picked up across pages when rendering references
   (#1116, @panglesd)
+- Fix wrong links to standalone comments in search results (#1118, @panglesd)
 
 
 # 2.4.0

src/model/fold.ml

@@ -11,20 +11,24 @@ type item =
   | Class of Class.t
   | Extension of Extension.t
   | ModuleType of ModuleType.t
-  | Doc of Comment.docs_or_stop
+  | Doc of Paths.Identifier.LabelParent.t * Comment.docs_or_stop
 
 let rec unit ~f acc u =
   let acc = f acc (CompilationUnit u) in
-  match u.content with Module m -> signature ~f acc m | Pack _ -> acc
+  match u.content with
+  | Module m -> signature ~f (u.id :> Paths.Identifier.LabelParent.t) acc m
+  | Pack _ -> acc
 
 and page ~f acc p =
   let open Page in
-  docs ~f acc (`Docs p.content)
+  docs ~f (p.name :> Paths.Identifier.LabelParent.t) acc (`Docs p.content)
 
-and signature ~f acc (s : Signature.t) =
-  List.fold_left (signature_item ~f) acc s.items
+and signature ~f id acc (s : Signature.t) =
+  List.fold_left
+    (signature_item ~f (id :> Paths.Identifier.LabelParent.t))
+    acc s.items
 
-and signature_item ~f acc s_item =
+and signature_item ~f id acc s_item =
   match s_item with
   | Module (_, m) -> module_ ~f acc m
   | ModuleType mt -> module_type ~f acc mt
@@ -38,12 +42,12 @@ and signature_item ~f acc s_item =
   | Value v -> value ~f acc v
   | Class (_, cl) -> class_ ~f acc cl
   | ClassType (_, clt) -> class_type ~f acc clt
-  | Include i -> include_ ~f acc i
-  | Comment d -> docs ~f acc d
+  | Include i -> include_ ~f id acc i
+  | Comment d -> docs ~f id acc d
 
-and docs ~f acc d = f acc (Doc d)
+and docs ~f id acc d = f acc (Doc (id, d))
 
-and include_ ~f acc inc = signature ~f acc inc.expansion.content
+and include_ ~f id acc inc = signature ~f id acc inc.expansion.content
 
 and class_type ~f acc ct =
   (* This check is important because [is_hidden] does not work on children of
@@ -53,26 +57,32 @@ and class_type ~f acc ct =
   if Paths.Identifier.is_hidden ct.id then acc
   else
     let acc = f acc (ClassType ct) in
-    match ct.expansion with None -> acc | Some cs -> class_signature ~f acc cs
+    match ct.expansion with
+    | None -> acc
+    | Some cs ->
+        class_signature ~f (ct.id :> Paths.Identifier.LabelParent.t) acc cs
 
-and class_signature ~f acc ct_expr =
-  List.fold_left (class_signature_item ~f) acc ct_expr.items
+and class_signature ~f id acc ct_expr =
+  List.fold_left (class_signature_item ~f id) acc ct_expr.items
 
-and class_signature_item ~f acc item =
+and class_signature_item ~f id acc item =
   match item with
   | Method m -> f acc (Method m)
   | InstanceVariable _ -> acc
   | Constraint _ -> acc
   | Inherit _ -> acc
-  | Comment d -> docs ~f acc d
+  | Comment d -> docs ~f id acc d
 
 and class_ ~f acc cl =
   if Paths.Identifier.is_hidden cl.id then acc
   else
     let acc = f acc (Class cl) in
     match cl.expansion with
     | None -> acc
-    | Some cl_signature -> class_signature ~f acc cl_signature
+    | Some cl_signature ->
+        class_signature ~f
+          (cl.id :> Paths.Identifier.LabelParent.t)
+          acc cl_signature
 
 and exception_ ~f acc exc =
   if Paths.Identifier.is_hidden exc.id then acc else f acc (Exception exc)
@@ -88,8 +98,10 @@ and module_ ~f acc m =
     let acc = f acc (Module m) in
     match m.type_ with
     | Alias (_, None) -> acc
-    | Alias (_, Some s_e) -> simple_expansion ~f acc s_e
-    | ModuleType mte -> module_type_expr ~f acc mte
+    | Alias (_, Some s_e) ->
+        simple_expansion ~f (m.id :> Paths.Identifier.LabelParent.t) acc s_e
+    | ModuleType mte ->
+        module_type_expr ~f (m.id :> Paths.Identifier.LabelParent.t) acc mte
 
 and type_decl ~f acc td =
   if Paths.Identifier.is_hidden td.id then acc else f acc (TypeDecl td)
@@ -100,27 +112,33 @@ and module_type ~f acc mt =
     let acc = f acc (ModuleType mt) in
     match mt.expr with
     | None -> acc
-    | Some mt_expr -> module_type_expr ~f acc mt_expr
+    | Some mt_expr ->
+        module_type_expr ~f
+          (mt.id :> Paths.Identifier.LabelParent.t)
+          acc mt_expr
 
-and simple_expansion ~f acc s_e =
+and simple_expansion ~f id acc s_e =
   match s_e with
-  | Signature sg -> signature ~f acc sg
+  | Signature sg -> signature ~f id acc sg
   | Functor (p, s_e) ->
       let acc = functor_parameter ~f acc p in
-      simple_expansion ~f acc s_e
+      simple_expansion ~f id acc s_e
 
-and module_type_expr ~f acc mte =
+and module_type_expr ~f id acc mte =
   match mte with
-  | Signature s -> signature ~f acc s
+  | Signature s -> signature ~f id acc s
   | Functor (fp, mt_expr) ->
       let acc = functor_parameter ~f acc fp in
-      module_type_expr ~f acc mt_expr
-  | With { w_expansion = Some sg; _ } -> simple_expansion ~f acc sg
-  | TypeOf { t_expansion = Some sg; _ } -> simple_expansion ~f acc sg
-  | Path { p_expansion = Some sg; _ } -> simple_expansion ~f acc sg
+      module_type_expr ~f id acc mt_expr
+  | With { w_expansion = Some sg; _ } -> simple_expansion ~f id acc sg
+  | TypeOf { t_expansion = Some sg; _ } -> simple_expansion ~f id acc sg
+  | Path { p_expansion = Some sg; _ } -> simple_expansion ~f id acc sg
   | Path { p_expansion = None; _ } -> acc
   | With { w_expansion = None; _ } -> acc
   | TypeOf { t_expansion = None; _ } -> acc
 
 and functor_parameter ~f acc fp =
-  match fp with Unit -> acc | Named n -> module_type_expr ~f acc n.expr
+  match fp with
+  | Unit -> acc
+  | Named n ->
+      module_type_expr ~f (n.id :> Paths.Identifier.LabelParent.t) acc n.expr

src/model/fold.mli

@@ -17,31 +17,29 @@ type item =
   | Class of Class.t
   | Extension of Extension.t
   | ModuleType of ModuleType.t
-  | Doc of Comment.docs_or_stop
+  | Doc of Paths.Identifier.LabelParent.t * Comment.docs_or_stop
 
-(** Bellow are the folding functions. For items that may contain
+(** Below are the folding functions. For items that may contain
     others, such as [signature], it folds recursively on the
-    sub-items. It does not recurse into internal items. *)
+    sub-items. It does not recurse into internal items.
+
+ The LabelParent identifier is used to give an id to the doc entries. *)
 
 val unit : f:('a -> item -> 'a) -> 'a -> Compilation_unit.t -> 'a
 val page : f:('a -> item -> 'a) -> 'a -> Page.t -> 'a
 
-val signature : f:('a -> item -> 'a) -> 'a -> Signature.t -> 'a
-val signature_item : f:('a -> item -> 'a) -> 'a -> Signature.item -> 'a
-val docs : f:('a -> item -> 'a) -> 'a -> Comment.docs_or_stop -> 'a
-val include_ : f:('a -> item -> 'a) -> 'a -> Include.t -> 'a
+val docs :
+  f:('a -> item -> 'a) ->
+  Paths.Identifier.LabelParent.t ->
+  'a ->
+  Comment.docs_or_stop ->
+  'a
 val class_type : f:('a -> item -> 'a) -> 'a -> ClassType.t -> 'a
-val class_signature : f:('a -> item -> 'a) -> 'a -> ClassSignature.t -> 'a
-val class_signature_item :
-  f:('a -> item -> 'a) -> 'a -> ClassSignature.item -> 'a
 val class_ : f:('a -> item -> 'a) -> 'a -> Class.t -> 'a
 val exception_ : f:('a -> item -> 'a) -> 'a -> Exception.t -> 'a
 val type_extension : f:('a -> item -> 'a) -> 'a -> Extension.t -> 'a
 val value : f:('a -> item -> 'a) -> 'a -> Value.t -> 'a
 val module_ : f:('a -> item -> 'a) -> 'a -> Module.t -> 'a
 val type_decl : f:('a -> item -> 'a) -> 'a -> TypeDecl.t -> 'a
 val module_type : f:('a -> item -> 'a) -> 'a -> ModuleType.t -> 'a
-val simple_expansion :
-  f:('a -> item -> 'a) -> 'a -> ModuleType.simple_expansion -> 'a
-val module_type_expr : f:('a -> item -> 'a) -> 'a -> ModuleType.expr -> 'a
 val functor_parameter : f:('a -> item -> 'a) -> 'a -> FunctorParameter.t -> 'a

src/search/entry.ml

@@ -146,7 +146,7 @@ and entries_of_doc id d =
   | `Math_block _ -> [ entry ~id ~doc:[ d ] ~kind:(Doc MathBlock) ]
   | `Table _ -> []
 
-let entries_of_item id (x : Odoc_model.Fold.item) =
+let entries_of_item (x : Odoc_model.Fold.item) =
   match x with
   | CompilationUnit u -> (
       match u.content with
@@ -219,5 +219,5 @@ let entries_of_item id (x : Odoc_model.Fold.item) =
                (entry_of_extension_constructor te.type_path te.type_params)
                te.constructors)
   | ModuleType mt -> [ entry ~id:mt.id ~doc:mt.doc ~kind:ModuleType ]
-  | Doc `Stop -> []
-  | Doc (`Docs d) -> entries_of_docs id d
+  | Doc (_, `Stop) -> []
+  | Doc (id, `Docs d) -> entries_of_docs id d

src/search/entry.mli

@@ -61,5 +61,4 @@ type t = {
   kind : kind;
 }
 
-val entries_of_item :
-  Odoc_model.Paths.Identifier.Any.t -> Odoc_model.Fold.item -> t list
+val entries_of_item : Odoc_model.Fold.item -> t list

src/search/json_index/json_search.ml

@@ -193,42 +193,20 @@ let output_json ppf first entries =
     first entries
 
 let unit ppf u =
-  let f (first, id) i =
-    let entries = Entry.entries_of_item id i in
+  let f first i =
+    let entries = Entry.entries_of_item i in
     let entries =
       List.map (fun entry -> (entry, Html.of_entry entry)) entries
     in
-    let id =
-      match i with
-      | CompilationUnit u -> (u.id :> Odoc_model.Paths.Identifier.t)
-      | TypeDecl _ -> id
-      | Module m -> (m.id :> Odoc_model.Paths.Identifier.t)
-      | Value _ -> id
-      | Exception _ -> id
-      | ClassType ct -> (ct.id :> Odoc_model.Paths.Identifier.t)
-      | Method _ -> id
-      | Class c -> (c.id :> Odoc_model.Paths.Identifier.t)
-      | Extension _ -> id
-      | ModuleType mt -> (mt.id :> Odoc_model.Paths.Identifier.t)
-      | Doc _ -> id
-    in
     let first = output_json ppf first entries in
-    (first, id)
-  in
-  let _first =
-    Odoc_model.Fold.unit ~f
-      ( true,
-        (u.Odoc_model.Lang.Compilation_unit.id :> Odoc_model.Paths.Identifier.t)
-      )
-      u
+    first
   in
+  let _first = Odoc_model.Fold.unit ~f true u in
   ()
 
 let page ppf (page : Odoc_model.Lang.Page.t) =
   let f first i =
-    let entries =
-      Entry.entries_of_item (page.name :> Odoc_model.Paths.Identifier.t) i
-    in
+    let entries = Entry.entries_of_item i in
     let entries =
       List.map (fun entry -> (entry, Html.of_entry entry)) entries
     in