count occurrences: untangle feature from render source code

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

Author: panglesd

src/document/generator.ml

@@ -1810,8 +1810,8 @@ module Make (Syntax : SYNTAX) = struct
       in
       let source_anchor =
         match t.source_info with
-        | Some { id; _ } -> Some (Source_page.url id)
-        | None -> None
+        | Some { id = Some id; _ } -> Some (Source_page.url id)
+        | _ -> None
       in
       let page = make_expansion_page ~source_anchor url [ unit_doc ] items in
       Document.Page page

src/loader/implementation.ml

@@ -503,22 +503,30 @@ let of_cmt (source_id : Odoc_model.Paths.Identifier.SourcePage.t)
 
   (uid_to_id, postprocess_poses source_id vs uid_to_id uid_to_loc)
 
-let read_cmt_infos source_id_opt id cmt_info =
-  let occ_infos = Occurrences.of_cmt cmt_info in
+let read_cmt_infos source_id_opt id cmt_info ~count_occurrences =
   match Odoc_model.Compat.shape_of_cmt_infos cmt_info with
   | Some shape -> (
       let uid_to_loc = cmt_info.cmt_uid_to_loc in
-      match (source_id_opt, cmt_info.cmt_annots) with
-      | Some source_id, Implementation impl ->
+      match (source_id_opt, count_occurrences, cmt_info.cmt_annots) with
+      | Some source_id, _, Implementation impl ->
           let map, source_infos = of_cmt source_id id impl uid_to_loc in
+          let occ_infos = Occurrences.of_cmt impl in
           let source_infos = List.rev_append source_infos occ_infos in
           ( Some (shape, map),
             Some
               {
-                Odoc_model.Lang.Source_info.id = source_id;
+                Odoc_model.Lang.Source_info.id = Some source_id;
                 infos = source_infos;
               } )
-      | _, _ -> (Some (shape, Odoc_model.Compat.empty_map), None))
+      | None, true, Implementation impl ->
+          let occ_infos = Occurrences.of_cmt impl in
+          ( None,
+            Some
+              {
+                Odoc_model.Lang.Source_info.id = None;
+                infos = occ_infos;
+              } )
+      | _, _, _ -> (Some (shape, Odoc_model.Compat.empty_map), None))
   | None -> (None, None)
 
 

src/loader/implementation.mli

@@ -2,6 +2,7 @@ val read_cmt_infos :
   Odoc_model.Paths.Identifier.Id.source_page option ->
   Odoc_model.Paths.Identifier.Id.root_module ->
   Cmt_format.cmt_infos ->
+  count_occurrences:bool ->
   (Odoc_model.Compat.shape
   * Odoc_model.Paths.Identifier.Id.source_location
     Odoc_model.Compat.shape_uid_map)

src/loader/occurrences.ml

@@ -106,46 +106,42 @@ module Global_analysis = struct
     | _ -> ()
 end
 
-let of_cmt (cmt : Cmt_format.cmt_infos) =
-  let ttree = cmt.cmt_annots in
-  match ttree with
-  | Cmt_format.Implementation structure ->
-      let poses = ref [] in
-      let module_expr iterator mod_expr =
-        Global_analysis.module_expr poses mod_expr;
-        Compat.Tast_iterator.default_iterator.module_expr iterator mod_expr
-      in
-      let expr iterator e =
-        Global_analysis.expr poses e;
-        Compat.Tast_iterator.default_iterator.expr iterator e
-      in
-      let pat iterator e =
-        Global_analysis.pat poses e;
-        Compat.Tast_iterator.default_iterator.pat iterator e
-      in
-      let typ iterator ctyp_expr =
-        Global_analysis.core_type poses ctyp_expr;
-        Compat.Tast_iterator.default_iterator.typ iterator ctyp_expr
-      in
-      let module_type iterator mty =
-        Global_analysis.module_type poses mty;
-        Compat.Tast_iterator.default_iterator.module_type iterator mty
-      in
-      let class_type iterator cl_type =
-        Global_analysis.class_type poses cl_type;
-        Compat.Tast_iterator.default_iterator.class_type iterator cl_type
-      in
-      let iterator =
-        {
-          Compat.Tast_iterator.default_iterator with
-          expr;
-          pat;
-          module_expr;
-          typ;
-          module_type;
-          class_type;
-        }
-      in
-      iterator.structure iterator structure;
-      !poses
-  | _ -> []
+let of_cmt structure =
+  let poses = ref [] in
+  let module_expr iterator mod_expr =
+    Global_analysis.module_expr poses mod_expr;
+    Compat.Tast_iterator.default_iterator.module_expr iterator mod_expr
+  in
+  let expr iterator e =
+    Global_analysis.expr poses e;
+    Compat.Tast_iterator.default_iterator.expr iterator e
+  in
+  let pat iterator e =
+    Global_analysis.pat poses e;
+    Compat.Tast_iterator.default_iterator.pat iterator e
+  in
+  let typ iterator ctyp_expr =
+    Global_analysis.core_type poses ctyp_expr;
+    Compat.Tast_iterator.default_iterator.typ iterator ctyp_expr
+  in
+  let module_type iterator mty =
+    Global_analysis.module_type poses mty;
+    Compat.Tast_iterator.default_iterator.module_type iterator mty
+  in
+  let class_type iterator cl_type =
+    Global_analysis.class_type poses cl_type;
+    Compat.Tast_iterator.default_iterator.class_type iterator cl_type
+  in
+  let iterator =
+    {
+      Compat.Tast_iterator.default_iterator with
+      expr;
+      pat;
+      module_expr;
+      typ;
+      module_type;
+      class_type;
+    }
+  in
+  iterator.structure iterator structure;
+  !poses

src/loader/odoc_loader.ml

@@ -42,12 +42,12 @@ exception Not_an_interface
 
 exception Make_root_error of string
 
-let read_cmt_infos source_id_opt id ~filename () =
+let read_cmt_infos source_id_opt id ~filename ~count_occurrences () =
   match Cmt_format.read_cmt filename with
   | exception Cmi_format.Error _ -> raise Corrupted
   | cmt_info -> (
       match cmt_info.cmt_annots with
-      | Implementation _ -> Implementation.read_cmt_infos source_id_opt id cmt_info
+      | Implementation _ -> Implementation.read_cmt_infos source_id_opt id cmt_info ~count_occurrences
       | _ -> raise Not_an_implementation)
 
 
@@ -99,7 +99,7 @@ let compilation_unit_of_sig ~make_root ~imports ~interface ?sourcefile ~name ~id
   make_compilation_unit ~make_root ~imports ~interface ?sourcefile ~name ~id
     ?canonical ?shape_info content
 
-let read_cmti ~make_root ~parent ~filename ~cmt_filename_opt ~source_id_opt () =
+let read_cmti ~make_root ~parent ~filename ~cmt_filename_opt ~source_id_opt ~count_occurrences () =
   let cmt_info = Cmt_format.read_cmt filename in
   match cmt_info.cmt_annots with
   | Interface intf -> (
@@ -116,15 +116,16 @@ let read_cmti ~make_root ~parent ~filename ~cmt_filename_opt ~source_id_opt () =
           let shape_info, source_info =
             match cmt_filename_opt with
             | Some cmt_filename ->
-                read_cmt_infos source_id_opt id ~filename:cmt_filename ()
-            | None -> (None, None)
+                read_cmt_infos source_id_opt id ~filename:cmt_filename ~count_occurrences ()
+            | None ->
+               (None, None)
           in
           compilation_unit_of_sig ~make_root ~imports:cmt_info.cmt_imports
             ~interface ~sourcefile ~name ~id ?shape_info ~source_info
             ?canonical sg)
   | _ -> raise Not_an_interface
 
-let read_cmt ~make_root ~parent ~filename ~source_id_opt () =
+let read_cmt ~make_root ~parent ~filename ~source_id_opt ~count_occurrences () =
   match Cmt_format.read_cmt filename with
   | exception Cmi_format.Error (Not_an_interface _) ->
       raise Not_an_implementation
@@ -168,7 +169,7 @@ let read_cmt ~make_root ~parent ~filename ~source_id_opt () =
       | Implementation impl ->
           let id, sg, canonical = Cmt.read_implementation parent name impl in
           let shape_info, source_info =
-            read_cmt_infos source_id_opt id ~filename ()
+            read_cmt_infos source_id_opt id ~filename ~count_occurrences ()
           in
           compilation_unit_of_sig ~make_root ~imports ~interface ~sourcefile
             ~name ~id ?canonical ?shape_info ~source_info sg
@@ -199,12 +200,12 @@ let wrap_errors ~filename f =
       | Not_an_interface -> not_an_interface filename
       | Make_root_error m -> error_msg filename m)
 
-let read_cmti ~make_root ~parent ~filename ~source_id_opt ~cmt_filename_opt =
+let read_cmti ~make_root ~parent ~filename ~source_id_opt ~cmt_filename_opt ~count_occurrences =
   wrap_errors ~filename
-    (read_cmti ~make_root ~parent ~filename ~source_id_opt ~cmt_filename_opt)
+    (read_cmti ~make_root ~parent ~filename ~source_id_opt ~cmt_filename_opt ~count_occurrences)
 
-let read_cmt ~make_root ~parent ~filename ~source_id_opt =
-  wrap_errors ~filename (read_cmt ~make_root ~parent ~filename ~source_id_opt)
+let read_cmt ~make_root ~parent ~filename ~source_id_opt ~count_occurrences =
+  wrap_errors ~filename (read_cmt ~make_root ~parent ~filename ~source_id_opt ~count_occurrences)
 
 let read_cmi ~make_root ~parent ~filename =
   wrap_errors ~filename (read_cmi ~make_root ~parent ~filename)

src/loader/odoc_loader.mli

@@ -19,13 +19,15 @@ val read_cmti :
   filename:string ->
   source_id_opt:Identifier.SourcePage.t option ->
   cmt_filename_opt:string option ->
+  count_occurrences:bool ->
   (Lang.Compilation_unit.t, Error.t) result Error.with_warnings
 
 val read_cmt :
   make_root:make_root ->
   parent:Identifier.ContainerPage.t option ->
   filename:string ->
   source_id_opt:Identifier.SourcePage.t option ->
+  count_occurrences:bool ->
   (Lang.Compilation_unit.t, Error.t) result Error.with_warnings
 
 val read_cmi :

src/model/lang.ml

@@ -32,7 +32,7 @@ module Source_info = struct
 
   type infos = annotation with_pos list
 
-  type t = { id : Identifier.SourcePage.t; infos : infos }
+  type t = { id : Identifier.SourcePage.t option; infos : infos }
 end
 
 module rec Module : sig

src/model_desc/lang_desc.ml

@@ -18,7 +18,7 @@ let inline_status =
 
 let source_info =
   let open Lang.Source_info in
-  Record [ F ("id", (fun t -> t.id), identifier) ]
+  Record [ F ("id", (fun t -> t.id), Option identifier) ]
 
 (** {3 Module} *)
 

src/odoc/compile.ml

@@ -99,16 +99,17 @@ let resolve_imports resolver imports =
 (** Raises warnings and errors. *)
 let resolve_and_substitute ~resolver ~make_root ~source_id_opt ~cmt_filename_opt
     ~hidden (parent : Paths.Identifier.ContainerPage.t option) input_file
-    input_type ~count_occurrences:_ =
+    input_type ~count_occurrences =
   let filename = Fs.File.to_string input_file in
   let unit =
     match input_type with
     | `Cmti ->
         Odoc_loader.read_cmti ~make_root ~parent ~filename ~source_id_opt
-          ~cmt_filename_opt
+          ~cmt_filename_opt ~count_occurrences
         |> Error.raise_errors_and_warnings
     | `Cmt ->
         Odoc_loader.read_cmt ~make_root ~parent ~filename ~source_id_opt
+          ~count_occurrences
         |> Error.raise_errors_and_warnings
     | `Cmi ->
         Odoc_loader.read_cmi ~make_root ~parent ~filename

src/odoc/html_page.ml

@@ -39,7 +39,7 @@ let render { html_config; source = _; assets = _ } page =
 
 let source_documents source_info source ~syntax =
   match (source_info, source) with
-  | Some { Lang.Source_info.id; infos }, Some src -> (
+  | Some { Lang.Source_info.id = Some id; infos }, Some src -> (
       let file =
         match src with
         | Source.File f -> f
@@ -68,7 +68,7 @@ let source_documents source_info source ~syntax =
             Odoc_document.Renderer.document_of_source ~syntax id syntax_info
               infos source_code;
           ])
-  | Some { id; _ }, None ->
+  | Some { id = Some id; _ }, None ->
       let filename = Paths.Identifier.name id in
       Error.raise_warning
         (Error.filename_only
@@ -77,14 +77,14 @@ let source_documents source_info source ~syntax =
             --source-name"
            filename);
       []
-  | None, Some src ->
+  | _, Some src ->
       Error.raise_warning
         (Error.filename_only
            "--source argument is invalid on compilation unit that were not \
             compiled with --source-parent and --source-name"
            (Source.to_string src));
       []
-  | None, None -> []
+  | _, None -> []
 
 let list_filter_map f lst =
   List.rev