Occurrences patches (#18)

Author: lukemaurer

src/occurrences/dune

@@ -1,4 +1,4 @@
 (library
  (name odoc_occurrences)
  (public_name odoc.occurrences)
- (libraries odoc_model))
+ (libraries fpath odoc_model unix))

src/occurrences/odoc_occurrences.ml

@@ -1,26 +1,82 @@
 module Table = Table
 
-let of_impl ~include_hidden unit htbl =
-  let incr tbl p =
+let of_impl ~include_hidden unit htbl deftbl =
+  let incr tbl p src_loc =
     let open Odoc_model.Paths.Path.Resolved in
     let p = (p :> t) in
     let id = identifier p in
     match id with
-    | Some id when (not (is_hidden p)) || include_hidden -> Table.add tbl id
+    | Some id when (not (is_hidden p)) || include_hidden -> Table.add tbl id src_loc
     | _ -> ()
   in
+  let add_item p implementation =
+    let src_loc =
+      match implementation with
+      | Some (Odoc_model.Lang.Source_info.Resolved impl) ->
+          Table.Deftbl.get deftbl impl
+      | _ -> None
+    in
+    incr htbl p src_loc
+  in
   let open Odoc_model.Lang in
   List.iter
     (function
-      | Source_info.Module { documentation = Some (`Resolved p); _ }, _ ->
-          incr htbl p
-      | Value { documentation = Some (`Resolved p); _ }, _ -> incr htbl p
-      | ModuleType { documentation = Some (`Resolved p); _ }, _ -> incr htbl p
-      | Type { documentation = Some (`Resolved p); _ }, _ -> incr htbl p
+      | Source_info.Module { documentation = Some (`Resolved p); implementation }, _ ->
+          add_item p implementation
+      | Value { documentation = Some (`Resolved p); implementation }, _ ->
+          add_item p implementation
+      | ModuleType { documentation = Some (`Resolved p); implementation }, _ ->
+          add_item p implementation
+      | Type { documentation = Some (`Resolved p); implementation }, _ ->
+          add_item p implementation
+      | Definition _, _ -> ()
       | _ -> ())
     unit.Implementation.source_info
 
-let aggregate ~tbl ~data =
-  Table.iter
-    (fun id { Table.direct; _ } -> Table.add ~quantity:direct tbl id)
-    data
+let aggregate ~tbl ~data = Table.merge_into ~src:data ~dst:tbl
+
+type hg_revision = string
+
+let unspecified_hg_revision : hg_revision = ""
+
+(* TODO: The [revision] field is really a temporary hack and should be replaced
+   by a dummy with an opaque type. Annoyingly, just removing the field would
+   risk causing segfaults due to unmarshalling.
+*)
+type t = {table : Table.t; revision: hg_revision; max_occurrences: int}
+
+let from_file file : t =
+  Odoc_utils.Io_utils.unmarshal (Fpath.to_string file)
+;;
+
+(* FIXME: Copied from [Odoc_odoc.Fs], which should probably just all be moved into
+   [Odoc_utils]. *)
+let mkdir_p dir =
+  let open StdLabels in
+  let mkdir d =
+    try Unix.mkdir (Fpath.to_string d) 0o755 with
+    | Unix.Unix_error (Unix.EEXIST, _, _) -> ()
+    | exn -> raise exn
+  in
+  let rec dirs_to_create p acc =
+    if Sys.file_exists (Fpath.to_string p) then acc
+    else dirs_to_create (Fpath.parent p) (p :: acc)
+  in
+  List.iter (dirs_to_create dir []) ~f:mkdir
+;;
+
+let to_file (t : t) file =
+  mkdir_p (Fpath.parent file);
+  Odoc_utils.Io_utils.marshal (Fpath.to_string file) t;
+;;
+
+let from_occtbl occtbl revision : t =
+  let get_max tbl =
+    let max = ref 0 in
+    let f _key (item : Table.item) =
+      max := Int.max (!max) (item.direct + item.indirect)
+    in
+    Table.iter f tbl; !max
+  in
+  let revision = revision |> Option.value ~default:unspecified_hg_revision in
+  {table = occtbl; max_occurrences = get_max occtbl; revision}

src/occurrences/odoc_occurrences.mli

@@ -2,9 +2,21 @@ open Odoc_model.Lang
 
 module Table = Table
 
-val of_impl : include_hidden:bool -> Implementation.t -> Table.t -> unit
+val of_impl : include_hidden:bool -> Implementation.t -> Table.t -> Table.Deftbl.t -> unit
 (** Add all occurrences from implementation of a compilation unit into a table
 *)
 
 val aggregate : tbl:Table.t -> data:Table.t -> unit
 (** Aggregate [data] into [tbl] *)
+
+type hg_revision = string
+
+val unspecified_hg_revision : hg_revision
+
+type t = {table : Table.t; revision: hg_revision; max_occurrences: int}
+
+val from_file : Fpath.t -> t
+
+val to_file : t -> Fpath.t -> unit
+
+val from_occtbl : Table.t -> hg_revision option -> t

src/occurrences/table.ml

@@ -1,35 +1,37 @@
-module H = Hashtbl.Make (Odoc_model.Paths.Identifier)
+let get_key (id : Odoc_model.Paths.Identifier.t) = id.ikey
 
-type t = internal_item H.t
-and internal_item = { direct : int; indirect : int; sub : t }
-type key = Odoc_model.Paths.Identifier.t
+module H = Hashtbl.Make (String)
 
-type item = { direct : int; indirect : int }
+type impl_src = {filepath: string list; line_number: int}
+type t = item H.t
+and item = { direct : int; indirect : int ; impl_src : impl_src option }
+type key = string
+type identifier = Odoc_model.Paths.Identifier.t
 
-let internal_to_item : internal_item -> item =
- fun { direct; indirect; _ } -> { direct; indirect }
-
-let v_item () = { direct = 0; indirect = 0; sub = H.create 0 }
+let v_item () = { direct = 0; indirect = 0; impl_src = None }
 
 let v () = H.create 0
 
-let add ?(quantity = 1) tbl id =
+let add ?(quantity = 1) tbl id impl_src =
   let rec add ?(kind = `Indirect) id =
-    let incr htbl id =
-      let { direct; indirect; sub } =
-        try H.find htbl id with Not_found -> v_item ()
+    let incr id =
+      let { direct; indirect ; impl_src=impl_src_old} =
+        try H.find tbl (get_key id) with Not_found -> v_item ()
       in
+      let impl_src =
+        if Option.is_none impl_src || kind <> `Direct
+        then impl_src_old
+        else impl_src in
       let direct, indirect =
         match kind with
         | `Direct -> (direct + quantity, indirect)
         | `Indirect -> (direct, indirect + quantity)
       in
-      H.replace htbl id { direct; indirect; sub };
-      sub
+      H.replace tbl (get_key id) { direct; indirect ; impl_src };
     in
     let do_ parent =
-      let htbl = add (parent :> key) in
-      incr htbl id
+      add (parent :> identifier);
+      incr id
     in
     match id.iv with
     | `InstanceVariable (parent, _) -> do_ parent
@@ -38,6 +40,7 @@ let add ?(quantity = 1) tbl id =
     | `ModuleType (parent, _) -> do_ parent
     | `Method (parent, _) -> do_ parent
     | `Field (parent, _) -> do_ parent
+    | `UnboxedField (parent, _) -> do_ parent
     | `Extension (parent, _) -> do_ parent
     | `Type (parent, _) -> do_ parent
     | `Constructor (parent, _) -> do_ parent
@@ -46,49 +49,43 @@ let add ?(quantity = 1) tbl id =
     | `Class (parent, _) -> do_ parent
     | `Value (parent, _) -> do_ parent
     | `ClassType (parent, _) -> do_ parent
-    | `Root _ -> incr tbl id
+    | `Root _ -> incr id
     | `SourcePage _ | `Page _ | `LeafPage _ | `SourceLocation _ | `Label _
     | `SourceLocationMod _ | `Result _ | `AssetFile _
     | `SourceLocationInternal _ ->
         assert false
   in
-  let _htbl = add ~kind:`Direct id in
-  ()
+  add ~kind:`Direct id
 
-let rec get t id =
-  let do_ parent =
-    get t (parent :> key) |> function
-    | None -> None
-    | Some { sub; _ } -> ( try Some (H.find sub id) with Not_found -> None)
-  in
-  match id.iv with
-  | `InstanceVariable (parent, _) -> do_ parent
-  | `Parameter (parent, _) -> do_ parent
-  | `Module (parent, _) -> do_ parent
-  | `ModuleType (parent, _) -> do_ parent
-  | `Method (parent, _) -> do_ parent
-  | `Field (parent, _) -> do_ parent
-  | `Extension (parent, _) -> do_ parent
-  | `ExtensionDecl (parent, _, _) -> do_ parent
-  | `Type (parent, _) -> do_ parent
-  | `Constructor (parent, _) -> do_ parent
-  | `Exception (parent, _) -> do_ parent
-  | `Class (parent, _) -> do_ parent
-  | `Value (parent, _) -> do_ parent
-  | `ClassType (parent, _) -> do_ parent
-  | `Root _ -> ( try Some (H.find t id) with Not_found -> None)
-  | `SourcePage _ | `Page _ | `LeafPage _ | `SourceLocation _ | `Label _
-  | `SourceLocationMod _ | `Result _ | `AssetFile _ | `SourceLocationInternal _
-    ->
-      None
+let add_entries item item_opt =
+  match item_opt with
+  | Some { direct; indirect ; impl_src } ->
+    let direct = item.direct + direct in
+    let indirect = item.indirect + indirect in
+    let impl_src = if Option.is_some item.impl_src then item.impl_src else impl_src in
+      {direct ; indirect ; impl_src}
+  | None -> item
+
+let get t id = H.find_opt t (get_key id)
+
+let iter = H.iter
+
+let merge_into ~src ~dst =
+  iter (fun key item ->
+    let dst_item = H.find_opt dst key in
+    let new_item = add_entries item dst_item in
+    H.replace dst key new_item
+  ) src
+
+module Deftbl = struct
+  type key = Odoc_model.Paths.Identifier.SourceLocation.t
+  type item = impl_src
+  module H = Hashtbl.Make (String)
+  type t = item H.t
+
+  let v () = H.create 0
 
-let get t id =
-  match get t id with None -> None | Some i -> Some (internal_to_item i)
+  let add t (k: key) (v: item) = H.add t k.ikey v
 
-let rec iter f tbl =
-  H.iter
-    (fun id v ->
-      iter f v.sub;
-      let v = internal_to_item v in
-      f id v)
-    tbl
+  let get t (k: key) = H.find_opt t k.ikey
+end

src/occurrences/table.mli

@@ -1,11 +1,28 @@
 type t
-type item = { direct : int; indirect : int }
-type key = Odoc_model.Paths.Identifier.t
+type impl_src = {filepath: string list; line_number: int}
+type item = { direct : int; indirect : int ; impl_src : impl_src option}
+type key = string
+type identifier = Odoc_model.Paths.Identifier.t
 
 val v : unit -> t
+val v_item : unit -> item
 
-val add : ?quantity:int -> t -> key -> unit
+val add : ?quantity:int -> t -> identifier -> impl_src option -> unit
 
 val iter : (key -> item -> unit) -> t -> unit
 
-val get : t -> key -> item option
+val get : t -> identifier -> item option
+
+val merge_into: src:t -> dst:t -> unit
+
+module Deftbl : sig
+  type key = Odoc_model.Paths.Identifier.SourceLocation.t
+  type item = impl_src
+  type t
+
+  val v : unit -> t
+
+  val add : t -> key -> item -> unit
+
+  val get : t -> key -> item option
+end

src/odoc/bin/main.ml

@@ -1568,9 +1568,9 @@ module Occurrences = struct
     else Ok f
 
   module Count = struct
-    let count directories dst warnings_options include_hidden =
+    let count directories dst revision warnings_options include_hidden =
       dst_of_string dst >>= fun dst ->
-      Occurrences.count ~dst ~warnings_options directories include_hidden
+      Occurrences.count ~dst ~warnings_options ~revision directories include_hidden
 
     let cmd =
       let dst =
@@ -1580,6 +1580,13 @@ module Occurrences = struct
           & opt (some string) None
           & info ~docs ~docv:"PATH" ~doc [ "o" ])
       in
+      let revision =
+        let doc = "Current hg revision id" in
+        Arg.(
+          value & opt (some string) None
+          & info ~docs ~doc ["revision"]
+        )
+      in
       let include_hidden =
         let doc = "Include hidden identifiers in the table" in
         Arg.(value & flag & info ~docs ~doc [ "include-hidden" ])
@@ -1596,7 +1603,7 @@ module Occurrences = struct
       in
       Term.(
         const handle_error
-        $ (const count $ input $ dst $ warnings_options $ include_hidden))
+        $ (const count $ input $ dst $ revision $ warnings_options $ include_hidden))
 
     let info ~docs =
       let doc =