Report stale occurrences

CHANGES.md

@@ -9,6 +9,7 @@ Fri Jan 10 17:55:42 CET 2025
     - Perform less merges in the indexer (#1881)
     - Add initial support for project-wide renaming: occurrences can now return
       all usages of all related definitions. (#1877)
+    - Stale occurrences are flagged as such
   + vim plugin
     - Added support for search-by-type (#1846)
       This is exposed through the existing `:MerlinSearch` command, that

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
 
@@ -116,43 +162,52 @@ let get_buffer_locs result uid =
       if Shape.Uid.equal uid uid' then Lid_set.add loc acc else acc)
     (Mtyper.get_index result) Lid_set.empty
 
-let get_external_locs ~(config : Mconfig.t) ~current_buffer_path uid =
+let get_external_locs ~(config : Mconfig.t) ~current_buffer_path uid :
+    (Occurrence_set.t * Std.String.Set.t) list =
   let title = "get_external_locs" in
-  List.filter_map config.merlin.index_files ~f:(fun file ->
+  List.filter_map config.merlin.index_files ~f:(fun index_file ->
       log ~title "Lookin for occurrences of %a in index %s" Logger.fmt
         (Fun.flip Shape.Uid.print uid)
-        file;
+        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 uid external_index.defs
           |> Option.map ~f:(fun uid_locs -> (external_index, uid_locs))
         with Index_format.Not_an_index _ | Sys_error _ ->
-          log ~title "Could not load index %s" file;
+          log ~title "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; _ } ->
+          ( Occurrence_set.of_filtered_lid_set locs ~f:(fun { loc; _ } ->
                 (* We ignore external results that concern the current buffer *)
-                let file = loc.Location.loc_start.Lexing.pos_fname in
-                let file, buf =
+                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, current_buffer_path)
-                  | None -> (file, config.query.filename)
+                  | 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 in
-                let buf = Misc.canonicalize_filename buf in
-                if String.equal file buf then false
+                let file = Misc.canonicalize_filename file_uncanon in
+                let buf = Misc.canonicalize_filename buf_uncanon in
+                if String.equal file buf 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
-                    log ~title "File %s might be out-of-sync." file;
-                  check
-                end)
-              locs,
+                  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;
+                  let staleness : Staleness.t =
+                    match is_fresh with
+                    | true -> Fresh
+                    | false -> Stale
+                  in
+                  Some staleness
+                end),
             Stat_check.get_outdated_files stats )))
 
 let lookup_related_uids_in_indexes ~(config : Mconfig.t) uid =
@@ -252,7 +307,10 @@ 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
         let name =
@@ -263,47 +321,51 @@ let locs_of ~config ~env ~typer_result ~pos ~scope path =
           (def_uid :: additional_uids)
           ~f:(get_external_locs ~config ~current_buffer_path)
     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);
-             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);
+          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
@@ -316,8 +378,11 @@ let locs_of ~config ~env ~typer_result ~pos ~scope path =
       | _, [] -> `Included
       | _, l -> `Out_of_sync l
     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

@@ -488,8 +488,15 @@ 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 || scope = `Renaming 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 -> `String version

src/frontend/query_commands.ml

@@ -789,10 +789,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 }
+
 type _ t =
   | Type_expr (* *) : string * Msource.position -> string t
   | Type_enclosing (* *) :
@@ -213,7 +215,7 @@ type _ t =
   | Path_list : [ `Build | `Source ] -> string list t
   | Occurrences (* *) :
       [ `Ident_at of Msource.position ] * [ `Project | `Buffer | `Renaming ]
-      -> (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": 26
+      },
+      "end": {
+        "line": 1,
+        "col": 29
+      }
+    }
+  ]