Collect occurrences info

Signed-off-by: Paul-Elliot <[email protected]>

Author: panglesd

doc/driver.mld

@@ -135,7 +135,8 @@ Compiling a file with [odoc] requires a few arguments: the file to compile, an
 optional parent, a list of include paths, a list of children for [.mld] files,
 optional parent and name for source implementation, and an output path. Include
 paths can be just ['.'], and we can calculate the output file from the input
-because all of the files are going into the same directory.
+because all of the files are going into the same directory. If we wish to count
+occurrences of each identifier, we need to pass the [--count-occurrences] flag.
 
 Linking a file with [odoc] requires the input file and a list of include paths. As
 for compile, we will hard-code the include path.
@@ -148,6 +149,9 @@ Using the [--source] argument with an [.odocl] file that was not compiled with
 [--source-parent-file] and [--source-name] will result in an error, as will omitting [--source] when generating HTML of an [odocl] that was
 compiled with [--source-parent-file] and [--source-name].
 
+To get the number of uses of each identifier, we can use the [count-occurrences]
+command.
+
 In all of these, we'll capture [stdout] and [stderr] so we can check it later.
 
 {[
@@ -209,7 +213,7 @@ let add_prefixed_output cmd list prefix lines =
       !list
       @ Bos.Cmd.to_string cmd :: List.map (fun l -> prefix ^ ": " ^ l) lines
 
-let compile file ?parent ?(output_dir = Fpath.v "./")
+let compile file ?(count_occurrences = true) ?parent ?(output_dir = Fpath.v "./")
     ?(ignore_output = false) ?source_args children =
   let output_basename =
     let ext = Fpath.get_ext file in
@@ -237,8 +241,9 @@ let compile file ?parent ?(output_dir = Fpath.v "./")
     | _ -> Cmd.empty
     else Cmd.empty
   in
+  let occ = if count_occurrences then Cmd.v "--count-occurrences" else Cmd.empty in
   let cmd =
-    odoc % "compile" % Fpath.to_string file %% source_args %% cmt_arg
+    odoc % "compile" % Fpath.to_string file %% source_args %% occ %% cmt_arg
     % "-I" % "." % "-o" % p output_file
     |> List.fold_right (fun child cmd -> cmd % "--child" % child) children
   in
@@ -289,6 +294,11 @@ let support_files () =
   let open Cmd in
   let cmd = odoc % "support-files" % "-o" % "html/odoc" in
   run cmd
+
+let count_occurrences output =
+  let open Cmd in
+  let cmd = odoc % "count-occurrences" % "-I" % "." % "-o" % p output in
+  run cmd
 ]}
 
 
@@ -750,6 +760,7 @@ let compiled = compile_all () in
 let linked = link_all compiled in
 let () = index_generate () in
 let _ = js_index () in
+let _ = count_occurrences (Fpath.v "occurrences.txt") in
 generate_all linked
 ]}
 

src/document/generator.ml

@@ -252,18 +252,42 @@ module Make (Syntax : SYNTAX) = struct
     let path id = Url.Path.from_identifier id
     let url id = Url.from_path (path id)
 
+    let to_link documentation implementation =
+      let documentation =
+        let open Paths.Path.Resolved in
+        match documentation with
+        | Some (`Resolved p) when not (is_hidden (p :> t)) -> (
+            let id = identifier (p :> t) in
+            match Url.from_identifier ~stop_before:false id with
+            | Ok link -> Some link
+            | _ -> None)
+        | _ -> None
+      in
+      let implementation =
+        match implementation with
+        | Some (Odoc_model.Lang.Source_info.Resolved id) -> (
+            match Url.Anchor.from_identifier (id :> Paths.Identifier.t) with
+            | Ok url -> Some url
+            | Error _ -> None)
+        | _ -> None
+      in
+      Some (Source_page.Link { implementation; documentation })
+
     let info_of_info : Lang.Source_info.annotation -> Source_page.info option =
       function
-      | Value id -> (
-          match Url.Anchor.from_identifier (id :> Paths.Identifier.t) with
-          | Ok url -> Some (Link url)
-          | Error _ -> None)
       | Definition id -> (
           match id.iv with
           | `SourceLocation (_, def) -> Some (Anchor (DefName.to_string def))
           | `SourceLocationInternal (_, local) ->
               Some (Anchor (LocalName.to_string local))
           | _ -> None)
+      | Module { documentation; _ } -> to_link documentation None
+      | ModuleType { documentation; _ } -> to_link documentation None
+      | Type { documentation; _ } -> to_link documentation None
+      | ClassType { documentation; _ } -> to_link documentation None
+      | Value { documentation; implementation } ->
+          to_link documentation implementation
+      | Constructor { documentation; _ } -> to_link documentation None
 
     let source id syntax_info infos source_code =
       let url = path id in
@@ -1784,8 +1808,8 @@ module Make (Syntax : SYNTAX) = struct
       in
       let source_anchor =
         match t.source_info with
-        | Some src -> Some (Source_page.url src.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/document/types.ml

@@ -183,7 +183,11 @@ end =
   Page
 
 and Source_page : sig
-  type info = Syntax of string | Anchor of string | Link of Url.Anchor.t
+  type target = {
+    documentation : Url.Anchor.t option;
+    implementation : Url.Anchor.t option;
+  }
+  type info = Syntax of string | Anchor of string | Link of target
 
   type code = span list
   and span = Tagged_code of info * code | Plain_code of string

src/html/html_source.ml

@@ -24,9 +24,31 @@ let html_of_doc ~config ~resolve docs =
         let children = List.concat @@ List.map (doc_to_html ~is_in_a) docs in
         match info with
         | Syntax tok -> [ span ~a:[ a_class [ tok ] ] children ]
-        | Link anchor ->
-            let href = Link.href ~config ~resolve anchor in
-            [ a ~a:[ a_href href ] children ]
+        | Link { documentation; implementation } -> (
+            let href_implementation =
+              Option.map (Link.href ~config ~resolve) implementation
+            in
+            let href_documentation =
+              Option.map (Link.href ~config ~resolve) documentation
+            in
+            let body =
+              match href_implementation with
+              | Some href -> [ a ~a:[ a_href href ] children ]
+              | None -> children
+            in
+            match href_documentation with
+            | None -> body
+            | Some href ->
+                [
+                  span
+                    ~a:[ a_class [ "jump-to-doc-container" ] ]
+                    [
+                      span ~a:[] body;
+                      a
+                        ~a:[ a_href href; a_class [ "jump-to-doc" ] ]
+                        [ txt " 📖" ];
+                    ];
+                ])
         | Anchor lbl -> [ span ~a:[ a_id lbl ] children ])
   in
   span ~a:[] @@ List.concat @@ List.map (doc_to_html ~is_in_a:false) docs

src/html_support_files/odoc.css

@@ -1206,6 +1206,14 @@ td.def-doc *:first-child {
   color: #657b83;
 }
 
+.jump-to-doc-container:hover .jump-to-doc {
+  display: inline;
+}
+
+.jump-to-doc {
+  display: none;
+}
+
 /* Source directories */
 
 .odoc-directory::before {
@@ -1390,4 +1398,4 @@ td.def-doc *:first-child {
    WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
    ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
    OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
-  ---------------------------------------------------------------------------*/
+  ---------------------------------------------------------------------------*/

src/loader/ident_env.cppo.ml

@@ -718,6 +718,9 @@ module Path = struct
       `Identifier (find_type env id, false)
     with Not_found -> assert false
 
+  let read_value_ident env id : Paths.Path.Value.t =
+    `Identifier (find_value_identifier env id, false)
+
   let read_class_type_ident env id : Paths.Path.ClassType.t =
     try
       `Identifier (find_class_type env id, false)
@@ -796,6 +799,18 @@ module Path = struct
     | Path.Pextra_ty (p,_) -> read_type env p
 #endif
 
+  let read_value env = function
+    | Path.Pident id -> read_value_ident env id
+#if OCAML_VERSION >= (4,8,0)
+    | Path.Pdot(p, s) -> `Dot(read_module env p, s)
+#else
+    | Path.Pdot(p, s, _) -> `Dot(read_module env p, s)
+#endif
+    | Path.Papply(_, _) -> assert false
+#if OCAML_VERSION >= (5,1,0)
+    | Path.Pextra_ty _ -> assert false
+#endif
+
 end
 
 module Fragment = struct

src/loader/ident_env.cppo.mli

@@ -40,6 +40,8 @@ module Path : sig
   val read_type : t -> Path.t -> Paths.Path.Type.t
 
   val read_class_type : t -> Path.t -> Paths.Path.ClassType.t
+
+  val read_value : t -> Path.t -> Paths.Path.Value.t
 end
 
 val find_module : t -> Ident.t -> Paths.Path.Module.t

src/loader/implementation.ml

@@ -147,19 +147,23 @@ module UidHashtbl = Shape.Uid.Tbl
 
 (* Adds the local definitions found in traverse infos to the [loc_to_id] and
    [ident_to_id] tables. *)
-let populate_local_defs source_id poses loc_to_id ident_to_id =
+let populate_local_defs source_id poses loc_to_id ident_to_loc =
   List.iter
     (function
       | Typedtree_traverse.Analysis.Definition id, loc ->
           let name =
             Odoc_model.Names.LocalName.make_std
               (Printf.sprintf "local_%s_%d" (Ident.name id) (counter ()))
           in
-          let identifier =
-            Odoc_model.Paths.Identifier.Mk.source_location_int (source_id, name)
-          in
-          IdentHashtbl.add ident_to_id id identifier;
-          LocHashtbl.add loc_to_id loc identifier
+          (match source_id with
+             Some source_id ->
+              let identifier =
+                Odoc_model.Paths.Identifier.Mk.source_location_int (source_id, name)
+              in
+              LocHashtbl.add loc_to_id loc identifier
+           | None -> ()
+          );
+            IdentHashtbl.add ident_to_loc id loc;
       | _ -> ())
     poses
 
@@ -245,6 +249,7 @@ let anchor_of_identifier id =
 (* Adds the global definitions, found in the [uid_to_loc], to the [loc_to_id]
    and [uid_to_id] tables. *)
 let populate_global_defs env source_id loc_to_id uid_to_loc uid_to_id =
+  match source_id with None -> () | Some source_id ->
   let mk_src_id id =
     let name = Odoc_model.Names.DefName.make_std (anchor_of_identifier id) in
     (Odoc_model.Paths.Identifier.Mk.source_location (source_id, name)
@@ -278,54 +283,86 @@ let populate_global_defs env source_id loc_to_id uid_to_loc uid_to_id =
             | _ -> ()))
     uid_to_loc
 
+let (>>=) a b = Option.map b a
+
 (* Extract [Typedtree_traverse] occurrence information and turn them into proper
    source infos *)
-let process_occurrences poses uid_to_id ident_to_id =
+let process_occurrences env poses loc_to_id ident_to_loc =
+  let open Odoc_model.Lang.Source_info in
+  let process p find_in_env =
+    match p with
+    | Path.Pident id when IdentHashtbl.mem ident_to_loc id -> (
+        match
+          LocHashtbl.find_opt loc_to_id (IdentHashtbl.find ident_to_loc id)
+        with
+        | None -> None
+        | Some id ->
+            let documentation = None and implementation = Some (Resolved id) in
+            Some { documentation; implementation })
+    | p -> (
+        match find_in_env env p with
+        | path ->
+            let documentation = Some path
+            and implementation = Some (Unresolved path) in
+            Some { documentation; implementation }
+        | exception _ -> None)
+  in
   List.filter_map
     (function
-      | Typedtree_traverse.Analysis.Value (LocalValue uniq), loc -> (
-          match IdentHashtbl.find_opt ident_to_id uniq with
-          | Some anchor ->
-              Some (Odoc_model.Lang.Source_info.Value anchor, pos_of_loc loc)
-          | None -> None)
-      | Value (DefJmp x), loc -> (
-          match UidHashtbl.find_opt uid_to_id x with
-          | Some id -> Some (Value id, pos_of_loc loc)
-          | None -> None)
+      | Typedtree_traverse.Analysis.Value p, loc ->
+          process p Ident_env.Path.read_value >>= fun l ->
+          (Value l, pos_of_loc loc)
+      | Module p, loc ->
+          process p Ident_env.Path.read_module >>= fun l ->
+          (Module l, pos_of_loc loc)
+      | ClassType p, loc ->
+          process p Ident_env.Path.read_class_type >>= fun l ->
+          (ClassType l, pos_of_loc loc)
+      | ModuleType p, loc ->
+          process p Ident_env.Path.read_module_type >>= fun l ->
+          (ModuleType l, pos_of_loc loc)
+      | Type p, loc ->
+          process p Ident_env.Path.read_type >>= fun l ->
+          (Type l, pos_of_loc loc)
+      | Constructor _p, loc ->
+          (* process p Ident_env.Path.read_constructor *) None >>= fun l ->
+          (Constructor l, pos_of_loc loc)
       | Definition _, _ -> None)
     poses
 
+
 (* Add definition source info from the [loc_to_id] table *)
 let add_definitions loc_to_id occurrences =
   LocHashtbl.fold
     (fun loc id acc ->
       (Odoc_model.Lang.Source_info.Definition id, pos_of_loc loc) :: acc)
     loc_to_id occurrences
 
-let read_cmt_infos source_id_opt id cmt_info =
+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 _ as source_id), _, Implementation impl
+      | source_id, true, Implementation impl ->
           let env = Env.of_structure id impl in
           let traverse_infos =
-            Typedtree_traverse.of_cmt env uid_to_loc impl |> List.rev
+            Typedtree_traverse.of_cmt env impl |> List.rev
             (* Information are accumulated in a list. We need to have the
                first info first in the list, to assign anchors with increasing
                numbers, so that adding some content at the end of a file does
                not modify the anchors for existing anchors. *)
           in
           let loc_to_id = LocHashtbl.create 10
-          and ident_to_id = IdentHashtbl.create 10
+          and ident_to_loc = IdentHashtbl.create 10
           and uid_to_id = UidHashtbl.create 10 in
           let () =
             (* populate [loc_to_id], [ident_to_id] and [uid_to_id] *)
-            populate_local_defs source_id traverse_infos loc_to_id ident_to_id;
+            populate_local_defs source_id traverse_infos loc_to_id ident_to_loc;
             populate_global_defs env source_id loc_to_id uid_to_loc uid_to_id
           in
           let source_infos =
-            process_occurrences traverse_infos uid_to_id ident_to_id
+            process_occurrences env traverse_infos loc_to_id ident_to_loc
             |> add_definitions loc_to_id
           in
           ( Some (shape, Shape.Uid.Tbl.to_map uid_to_id),
@@ -334,7 +371,7 @@ let read_cmt_infos source_id_opt id cmt_info =
                 Odoc_model.Lang.Source_info.id = source_id;
                 infos = source_infos;
               } )
-      | _, _ -> (Some (shape, Odoc_model.Compat.empty_map), None))
+      | _, _, _ -> (Some (shape, Odoc_model.Compat.empty_map), None))
   | None -> (None, None)
 
 #else

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)