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 <[email protected]>
ocaml · May 3, 2024 · 58c3497 · 58c3497
1 parent 9624fc1
commit 58c3497
Show file tree

Hide file tree

Showing 6 changed files with 121 additions and 86 deletions.
diff --git a/src/model/fold.ml b/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_internal] does not work on children of
@@ -53,26 +57,32 @@ and class_type ~f acc ct =
   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 (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_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
+          (cl.id :> Paths.Identifier.LabelParent.t)
+          acc cl_signature
 
 and exception_ ~f acc exc =
   if Paths.Identifier.is_internal 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_internal 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
diff --git a/src/model/fold.mli b/src/model/fold.mli
@@ -17,23 +17,54 @@ 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 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) -> 'a -> ClassType.t -> 'a
-val class_signature : f:('a -> item -> 'a) -> 'a -> ClassSignature.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
+  f:('a -> item -> 'a) ->
+  Paths.Identifier.LabelParent.t ->
+  '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
@@ -42,6 +73,15 @@ 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
+  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
diff --git a/src/search/entry.ml b/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
diff --git a/src/search/entry.mli b/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
diff --git a/src/search/json_index/json_search.ml b/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