Report 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,7 +242,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
         List.filter_map config.merlin.index_files ~f:(fun index_file ->
@@ -211,8 +260,8 @@ let locs_of ~config ~env ~typer_result ~pos ~scope path =
             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) ->
+                ( 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
@@ -231,61 +280,71 @@ let locs_of ~config ~env ~typer_result ~pos ~scope path =
                         (* 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:file_rel_to_root 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
@@ -298,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.t → tests/test-dirs/occurrences/project-wide/stale-index.t

@@ -10,21 +10,28 @@
   $ $OCAMLC -bin-annot -bin-annot-occurrences -c lib.ml main.ml
 
   $ ocaml-index aggregate main.cmt lib.cmt
-  $ ocaml-index dump-file-stats project.ocaml-index
-  File stats for index "project.ocaml-index":
-    "lib.ml": { mtime=1735062283.193617; size=27; source_digest="o\183+\155\030\018\214\030\137\200\198\231\024z\158\240" }
-    "main.ml": { mtime=1735062283.196618; size=30; source_digest="e)\028\0281\244\1875EN\151 z@%\217" }
 
 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
 
-TODO: Report the stale occurrence too
   $ $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": {