Improve stale occurrences

src/analysis/occurrences.ml

@@ -4,7 +4,53 @@ module Lid_set = Index_format.Lid_set
 let { Logger.log } = Logger.for_section "occurrences"
 
 type t =
-  { locs : Warnings.loc list; status : Query_protocol.occurrences_status }
+  { occurrences : Query_protocol.occurrence list;
+    status : Query_protocol.occurrences_status
+  }
+
+module Staleness = struct
+  type t = Stale | Fresh
+
+  let is_stale = function
+    | Stale -> true
+    | Fresh -> false
+end
+
+module Occurrence_set : sig
+  type t
+
+  val empty : t
+
+  (** Filter an [Lid_set.t]. [Lid.t]s that are kept must be assigned a staleness *)
+  val of_filtered_lid_set :
+    Lid_set.t -> f:(Index_format.Lid.t -> Staleness.t option) -> t
+
+  val to_list : t -> (Index_format.Lid.t * Staleness.t) list
+  val union : t -> t -> t
+end = struct
+  module Lid_map = Map.Make (Index_format.Lid)
+
+  type t = Staleness.t Lid_map.t
+
+  let empty = Lid_map.empty
+  let to_list = Lid_map.to_list
+
+  let of_filtered_lid_set lid_set ~f:get_staleness =
+    let maybe_add_lid lid acc =
+      match get_staleness lid with
+      | Some staleness -> Lid_map.add lid staleness acc
+      | None -> acc
+    in
+    Lid_set.fold maybe_add_lid lid_set empty
+
+  let either_fresh a b =
+    let open Staleness in
+    match (a, b) with
+    | Fresh, _ | _, Fresh -> Fresh
+    | Stale, Stale -> Stale
+
+  let union a b = Lid_map.union (fun _ a b -> Some (either_fresh a b)) a b
+end
 
 let () = Mtyper.set_index_items Index_occurrences.items
 
@@ -196,95 +242,109 @@ let locs_of ~config ~env ~typer_result ~pos ~scope path =
       (fun fmt -> Location.print_loc fmt def_loc);
     log ~title:"locs_of" "Indexing current buffer";
     let buffer_locs = get_buffer_locs typer_result def_uid in
-    let external_locs =
+    let buffer_occurrences =
+      Occurrence_set.of_filtered_lid_set buffer_locs ~f:(fun _ -> Some Fresh)
+    in
+    let external_occurrences =
       if scope = `Buffer then []
       else
-        List.filter_map config.merlin.index_files ~f:(fun file ->
+        List.filter_map config.merlin.index_files ~f:(fun index_file ->
             let external_locs =
               try
-                let external_index = Index_cache.read file in
+                let external_index = Index_cache.read index_file in
                 Index_format.Uid_map.find_opt def_uid external_index.defs
                 |> Option.map ~f:(fun uid_locs -> (external_index, uid_locs))
               with Index_format.Not_an_index _ | Sys_error _ ->
-                log ~title:"external_index" "Could not load index %s" file;
+                log ~title:"external_index" "Could not load index %s" index_file;
                 None
             in
             Option.map external_locs ~f:(fun (index, locs) ->
                 let stats = Stat_check.create ~cache_size:128 index in
-                ( Lid_set.filter
-                    (fun ({ loc; _ } as lid) ->
-                      let is_current_buffer =
-                        (* We filter external results that concern the current buffer *)
-                        let file = loc.Location.loc_start.Lexing.pos_fname in
-                        let file, buf =
-                          match config.merlin.source_root with
-                          | Some root ->
-                            (Filename.concat root file, current_buffer_path)
-                          | None -> (file, config.query.filename)
-                        in
-                        let file = Misc.canonicalize_filename file in
-                        let buf = Misc.canonicalize_filename buf in
-                        String.equal file buf
+                ( Occurrence_set.of_filtered_lid_set locs
+                    ~f:(fun ({ loc; _ } as lid) ->
+                      (* We filter external results that concern the current buffer *)
+                      let file_rel_to_root =
+                        loc.Location.loc_start.Lexing.pos_fname
+                      in
+                      let file_uncanon, buf_uncanon =
+                        match config.merlin.source_root with
+                        | Some root ->
+                          ( Filename.concat root file_rel_to_root,
+                            current_buffer_path )
+                        | None -> (file_rel_to_root, config.query.filename)
                       in
+                      let file = Misc.canonicalize_filename file_uncanon in
+                      let buf = Misc.canonicalize_filename buf_uncanon in
+                      let is_current_buffer = String.equal file buf in
                       let should_be_ignored =
                         (* We ignore results that don't have a location *)
                         Index_occurrences.should_ignore_lid lid
                       in
-                      if is_current_buffer || should_be_ignored then false
+                      if is_current_buffer || should_be_ignored then None
                       else begin
                         (* We ignore external results if their source was modified *)
-                        let check = Stat_check.check stats ~file in
-                        if not check then
+                        let is_fresh =
+                          Stat_check.check stats ~file:file_rel_to_root
+                        in
+                        if not is_fresh then
                           log ~title:"locs_of" "File %s might be out-of-sync."
                             file;
-                        check
-                      end)
-                    locs,
+                        let staleness : Staleness.t =
+                          match is_fresh with
+                          | true -> Fresh
+                          | false -> Stale
+                        in
+                        Some staleness
+                      end),
                   Stat_check.get_outdated_files stats )))
     in
-    let external_locs, out_of_sync_files =
+    let external_occurrences, out_of_sync_files =
       List.fold_left
-        ~init:(Lid_set.empty, String.Set.empty)
+        ~init:(Occurrence_set.empty, String.Set.empty)
         ~f:(fun (acc_locs, acc_files) (locs, files) ->
-          (Lid_set.union acc_locs locs, String.Set.union acc_files files))
-        external_locs
+          (Occurrence_set.union acc_locs locs, String.Set.union acc_files files))
+        external_occurrences
     in
-    let locs = Lid_set.union buffer_locs external_locs in
-    (* Some of the paths may have redundant `.`s or `..`s in them. Although canonicalizing
-       is not necessary for correctness, it makes the output a bit nicer. *)
-    let canonicalize_file_in_loc ({ txt; loc } : 'a Location.loc) :
-        'a Location.loc =
-      let file =
-        Misc.canonicalize_filename ?cwd:config.merlin.source_root
-          loc.loc_start.pos_fname
-      in
-      { txt; loc = set_fname ~file loc }
+    let occurrences =
+      Occurrence_set.union buffer_occurrences external_occurrences
     in
-    let locs = Lid_set.map canonicalize_file_in_loc locs in
-    let locs =
-      log ~title:"occurrences" "Found %i locs" (Lid_set.cardinal locs);
-      Lid_set.elements locs
-      |> List.filter_map ~f:(fun { Location.txt; loc } ->
-             let lid = try Longident.head txt with _ -> "not flat lid" in
-             log ~title:"occurrences" "Found occ: %s %a" lid Logger.fmt
-               (Fun.flip Location.print_loc loc);
-             (* Merlin-jst: See comment at the commented-out definition of last_loc for
-                explanation of why this is commented out. *)
-             (* let loc = last_loc loc txt in *)
-             let fname = loc.Location.loc_start.Lexing.pos_fname in
-             if not (Filename.is_relative fname) then Some loc
-             else
-               match config.merlin.source_root with
-               | Some path ->
-                 let file = Filename.concat path loc.loc_start.pos_fname in
-                 Some (set_fname ~file loc)
-               | None -> begin
-                 match Locate.find_source ~config loc fname with
-                 | `Found (file, _) -> Some (set_fname ~file loc)
-                 | `File_not_found msg ->
-                   log ~title:"occurrences" "%s" msg;
-                   None
-               end)
+    let occurrences = Occurrence_set.to_list occurrences in
+    log ~title:"occurrences" "Found %i locs" (List.length occurrences);
+    let occurrences =
+      List.filter_map occurrences
+        ~f:(fun (({ txt; loc } : _ Location.loc), staleness) ->
+          (* Canonoicalize filenames. Some of the paths may have redundant `.`s or `..`s in
+             them. Although canonicalizing is not necessary for correctness, it makes the
+             output a bit nicer. *)
+          let file =
+            Misc.canonicalize_filename ?cwd:config.merlin.source_root
+              loc.loc_start.pos_fname
+          in
+          let loc = set_fname ~file loc in
+          let lid = try Longident.head txt with _ -> "not flat lid" in
+          log ~title:"occurrences" "Found occ: %s %a" lid Logger.fmt
+            (Fun.flip Location.print_loc loc);
+          (* Merlin-jst: See comment at the commented-out definition of last_loc for
+             explanation of why this is commented out. *)
+          (* let loc = last_loc loc txt in *)
+          let fname = loc.Location.loc_start.Lexing.pos_fname in
+          let loc =
+            if not (Filename.is_relative fname) then Some loc
+            else
+              match config.merlin.source_root with
+              | Some path ->
+                let file = Filename.concat path loc.loc_start.pos_fname in
+                Some (set_fname ~file loc)
+              | None -> begin
+                match Locate.find_source ~config loc fname with
+                | `Found (file, _) -> Some (set_fname ~file loc)
+                | `File_not_found msg ->
+                  log ~title:"occurrences" "%s" msg;
+                  None
+              end
+          in
+          Option.map loc ~f:(fun loc : Query_protocol.occurrence ->
+              { loc; is_stale = Staleness.is_stale staleness }))
     in
     let def_uid_is_in_current_unit =
       let uid_comp_unit = comp_unit_of_uid def_uid in
@@ -297,8 +357,11 @@ let locs_of ~config ~env ~typer_result ~pos ~scope path =
       | `Project, l -> `Out_of_sync l
       | `Buffer, _ -> `Not_requested
     in
-    if not def_uid_is_in_current_unit then { locs; status }
+    if not def_uid_is_in_current_unit then { occurrences; status }
     else
-      let locs = set_fname ~file:current_buffer_path def_loc :: locs in
-      { locs; status }
-  | None -> { locs = []; status = `No_def }
+      let definition_occurrence : Query_protocol.occurrence =
+        { loc = set_fname ~file:current_buffer_path def_loc; is_stale = false }
+      in
+      let occurrences = definition_occurrence :: occurrences in
+      { occurrences; status }
+  | None -> { occurrences = []; status = `No_def }

src/analysis/occurrences.mli

@@ -1,5 +1,7 @@
 type t =
-  { locs : Warnings.loc list; status : Query_protocol.occurrences_status }
+  { occurrences : Query_protocol.occurrence list;
+    status : Query_protocol.occurrences_status
+  }
 
 val locs_of :
   config:Mconfig.t ->

src/commands/query_json.ml

@@ -511,9 +511,16 @@ let json_of_response (type a) (query : a t) (response : a) : json =
   | Findlib_list, strs -> `List (List.map ~f:Json.string strs)
   | Extension_list _, strs -> `List (List.map ~f:Json.string strs)
   | Path_list _, strs -> `List (List.map ~f:Json.string strs)
-  | Occurrences (_, scope), (locations, _project) ->
+  | Occurrences (_, scope), (occurrences, _project) ->
     let with_file = scope = `Project in
-    `List (List.map locations ~f:(fun loc -> with_location ~with_file loc []))
+    `List
+      (List.map occurrences ~f:(fun occurrence ->
+           let without_location =
+             match occurrence.is_stale with
+             | true -> [ ("stale", Json.bool true) ]
+             | false -> []
+           in
+           with_location ~with_file occurrence.loc without_location))
   | Signature_help _, s -> json_of_signature_help s
   | Version, (version, magic_numbers) ->
     `Assoc

src/frontend/query_commands.ml

@@ -930,10 +930,10 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function
       Locate.log ~title:"reconstructed identifier" "%s" path;
       path
     in
-    let { Occurrences.locs; status } =
+    let { Occurrences.occurrences; status } =
       Occurrences.locs_of ~config ~env ~typer_result ~pos ~scope path
     in
-    (locs, status)
+    (occurrences, status)
   | Inlay_hints
       (start, stop, hint_let_binding, hint_pattern_binding, avoid_ghost_location)
     ->

src/frontend/query_protocol.ml

@@ -129,6 +129,8 @@ type _ _bool = bool
 type occurrences_status =
   [ `Not_requested | `Out_of_sync of string list | `No_def | `Included ]
 
+type occurrence = { loc : Location.t; is_stale : bool }
+
 module Locate_context = struct
   type t =
     | Expr
@@ -267,7 +269,7 @@ type _ t =
   | Path_list : [ `Build | `Source ] -> string list t
   | Occurrences (* *) :
       [ `Ident_at of Msource.position ] * [ `Project | `Buffer ]
-      -> (Location.t list * occurrences_status) t
+      -> (occurrence list * occurrences_status) t
   | Signature_help : signature_help -> signature_help_result option t
       (** In current version, Merlin only uses the parameter [position] to answer
         signature_help queries. The additionnal parameters are described in the

tests/test-dirs/occurrences/project-wide/stale-index.t

@@ -0,0 +1,46 @@
+  $ cat >lib.ml <<'EOF'
+  > (* blah *)
+  > let foo = "bar"
+  > EOF
+
+  $ cat >main.ml <<'EOF'
+  > let () = print_string Lib.foo
+  > EOF
+
+  $ $OCAMLC -bin-annot -bin-annot-occurrences -c lib.ml main.ml
+
+  $ ocaml-index aggregate main.cmt lib.cmt
+
+Foo was defined on line 2 when the index was built, but is now defined on line 1
+  $ cat >lib.ml <<'EOF'
+  > let foo = "bar"
+  > EOF
+
+  $ $MERLIN single occurrences -scope project -identifier-at 1:28 \
+  > -index-file project.ocaml-index \
+  > -filename main.ml < main.ml | jq .value
+  [
+    {
+      "file": "$TESTCASE_ROOT/lib.ml",
+      "start": {
+        "line": 2,
+        "col": 4
+      },
+      "end": {
+        "line": 2,
+        "col": 7
+      },
+      "stale": true
+    },
+    {
+      "file": "$TESTCASE_ROOT/main.ml",
+      "start": {
+        "line": 1,
+        "col": 22
+      },
+      "end": {
+        "line": 1,
+        "col": 29
+      }
+    }
+  ]