Fix wrong id being given to doc comments

Standalone documentation comments currently do not have an id. This id was
carried as the accumulator of the field, which yielded wrong results!

Signed-off-by: Paul-Elliot <peada@free.fr>

Author: panglesd

src/model/fold.ml

@@ -11,23 +11,28 @@ 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
+  | Module (_, m) -> module_ ~f (m.id :> Paths.Identifier.LabelParent.t) acc m
+  | ModuleType mt ->
+      module_type ~f (mt.id :> Paths.Identifier.LabelParent.t) acc mt
   | ModuleSubstitution _ -> acc
   | ModuleTypeSubstitution _ -> acc
   | Open _ -> acc
@@ -36,43 +41,46 @@ and signature_item ~f acc s_item =
   | TypExt te -> type_extension ~f acc te
   | Exception exc -> exception_ ~f acc exc
   | 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
+  | Class (_, cl) -> class_ ~f (cl.id :> Paths.Identifier.LabelParent.t) acc cl
+  | ClassType (_, clt) ->
+      class_type ~f (clt.id :> Paths.Identifier.LabelParent.t) acc clt
+  | 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 =
+and class_type ~f id acc ct =
   (* This check is important because [is_internal] does not work on children of
      internal items. This means that if [Fold] did not make this check here,
      it would be difficult to filter for internal items afterwards. This also
      applies to the same check in functions bellow. *)
   if Paths.Identifier.is_internal 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 id 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 =
+and class_ ~f id acc cl =
   if Paths.Identifier.is_internal 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 id acc cl_signature
 
 and exception_ ~f acc exc =
   if Paths.Identifier.is_internal exc.id then acc else f acc (Exception exc)
@@ -82,45 +90,48 @@ and type_extension ~f acc te = f acc (Extension te)
 and value ~f acc v =
   if Paths.Identifier.is_internal v.id then acc else f acc (Value v)
 
-and module_ ~f acc m =
+and module_ ~f id acc m =
   if Paths.Identifier.is_internal m.id then acc
   else
     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 id acc s_e
+    | ModuleType mte -> module_type_expr ~f id acc mte
 
 and type_decl ~f acc td =
   if Paths.Identifier.is_internal td.id then acc else f acc (TypeDecl td)
 
-and module_type ~f acc mt =
+and module_type ~f id acc mt =
   if Paths.Identifier.is_internal mt.id then acc
   else
     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 id 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,83 @@ 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 class_type : f:('a -> item -> 'a) -> 'a -> ClassType.t -> 'a
-val class_signature : f:('a -> item -> 'a) -> 'a -> ClassSignature.t -> 'a
+val signature :
+  f:('a -> item -> 'a) ->
+  Paths.Identifier.LabelParent.t ->
+  'a ->
+  Signature.t ->
+  'a
+val signature_item :
+  f:('a -> item -> 'a) ->
+  Paths.Identifier.LabelParent.t ->
+  'a ->
+  Signature.item ->
+  'a
+val docs :
+  f:('a -> item -> 'a) ->
+  Paths.Identifier.LabelParent.t ->
+  'a ->
+  Comment.docs_or_stop ->
+  'a
+val include_ :
+  f:('a -> item -> 'a) ->
+  Paths.Identifier.LabelParent.t ->
+  'a ->
+  Include.t ->
+  'a
+val class_type :
+  f:('a -> item -> 'a) ->
+  Paths.Identifier.LabelParent.t ->
+  'a ->
+  ClassType.t ->
+  'a
+val class_signature :
+  f:('a -> item -> 'a) ->
+  Paths.Identifier.LabelParent.t ->
+  '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
+  f:('a -> item -> 'a) ->
+  Paths.Identifier.LabelParent.t ->
+  'a ->
+  ClassSignature.item ->
+  'a
+val class_ :
+  f:('a -> item -> 'a) -> Paths.Identifier.LabelParent.t -> '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 module_ :
+  f:('a -> item -> 'a) -> Paths.Identifier.LabelParent.t -> '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 module_type :
+  f:('a -> item -> 'a) ->
+  Paths.Identifier.LabelParent.t ->
+  '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
+  f:('a -> item -> 'a) ->
+  Paths.Identifier.LabelParent.t ->
+  'a ->
+  ModuleType.simple_expansion ->
+  'a
+val module_type_expr :
+  f:('a -> item -> 'a) ->
+  Paths.Identifier.LabelParent.t ->
+  '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