Report stale occurrences

.github/workflows/ocaml-lsp-compat.yml

@@ -51,7 +51,6 @@ jobs:
 
       - name: Check that Merlin and OCaml-LSP are co-installable
         run: |
-          opam --cli=2.1 pin --with-version=dev --no-action https://github.com/liam923/ocaml-lsp.git#rename-holes
+          opam --cli=2.1 pin --with-version=dev --no-action https://github.com/liam923/ocaml-lsp.git#stale-occurrences
           opam --cli=2.1 pin --with-version=5.4-503 --no-action .
           opam install ocaml-lsp-server --ignore-constraints-on=ocamlformat
-

CHANGES.md

@@ -6,6 +6,7 @@ unreleased
       (#1888)
     - `locate` can now disambiguate between files with identical names and contents
       (#1882)
+    - `occurrences` now reports stale files (#1885)
   + ocaml-index
     - Improve the granularity of index reading by segmenting the marshalization
       of the involved data-structures. (#1889)
@@ -28,6 +29,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 acc lid =
+      match get_staleness lid with
+      | Some staleness -> Lid_map.add lid staleness acc
+      | None -> acc
+    in
+    Lid_set.fold maybe_add_lid empty lid_set
+
+  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
 
@@ -118,44 +164,53 @@ let get_buffer_locs result uid =
       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 lid ->
+          ( Occurrence_set.of_filtered_lid_set locs ~f:(fun lid ->
                 let { Location.loc; _ } = Index_format.Lid.to_lid lid in
                 (* 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 =
@@ -255,7 +310,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 =
@@ -266,48 +324,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 lid =
-      let ({ txt; loc } : 'a Location.loc) = Index_format.Lid.to_lid lid in
-      let file =
-        Misc.canonicalize_filename ?cwd:config.merlin.source_root
-          loc.loc_start.pos_fname
-      in
-      Index_format.Lid.of_lid { 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 lid ->
-             let { Location.txt; loc } = Index_format.Lid.to_lid lid 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
-             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 (lid, staleness) ->
+          let ({ txt; loc } : 'a Location.loc) = Index_format.Lid.to_lid lid in
+          (* 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
@@ -320,8 +381,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,11 @@ 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 ->
+           with_location ~with_file occurrence.loc
+             [ ("stale", Json.bool occurrence.is_stale) ]))
   | Signature_help _, s -> json_of_signature_help s
   | Version, version -> `String version

src/frontend/query_commands.ml

@@ -791,10 +791,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

src/index-format/granular_set.ml

@@ -31,6 +31,7 @@ module type S = sig
   val iter : (elt -> unit) -> t -> unit
   val cardinal : t -> int
   val elements : t -> elt list
+  val fold : ('acc -> elt -> 'acc) -> 'acc -> t -> 'acc
   val schema :
     Granular_marshal.iter -> (Granular_marshal.iter -> elt -> unit) -> t -> unit
 end
@@ -234,12 +235,12 @@ module Make (Ord : Set.OrderedType) = struct
     | Empty -> 0
     | Node { l; r; _ } -> cardinal l + 1 + cardinal r
 
-  let rec elements_aux accu t =
+  let rec fold f acc t =
     match fetch t with
-    | Empty -> accu
-    | Node { l; v; r; _ } -> elements_aux (v :: elements_aux accu r) l
+    | Empty -> acc
+    | Node { l; v; r; _ } -> fold f (f (fold f acc r) v) l
 
-  let elements s = elements_aux [] s
+  let elements s = fold (fun acc v -> v :: acc) [] s
 
   let try_join l v r =
     if

src/index-format/granular_set.mli

@@ -29,6 +29,7 @@ module type S = sig
   val iter : (elt -> unit) -> t -> unit
   val cardinal : t -> int
   val elements : t -> elt list
+  val fold : ('acc -> elt -> 'acc) -> 'acc -> t -> 'acc
   val schema :
     Granular_marshal.iter -> (Granular_marshal.iter -> elt -> unit) -> t -> unit
 end