occ: return list of out of sync files

src/analysis/occurrences.ml

@@ -3,7 +3,7 @@ module Lid_set = Index_format.Lid_set
 
 let {Logger. log} = Logger.for_section "occurrences"
 
-type res = { locs: Warnings.loc list; synced: bool }
+type t = { locs: Warnings.loc list; status: Query_protocol.occurrences_status }
 
 let set_fname ~file (loc : Location.t) =
   let pos_fname = file in
@@ -170,11 +170,17 @@ module Stat_check : sig
   type t
   val create: cache_size:int -> Index_format.index -> t
   val check: t -> file:string -> bool
+  val get_outdated_files: t -> String.Set.t
 end = struct
   type t = { index : Index_format.index; cache : (string, bool) Hashtbl.t }
 
   let create ~cache_size index = { index; cache = Hashtbl.create cache_size }
 
+  let get_outdated_files t =
+    Hashtbl.fold
+      (fun file check acc -> if check then acc else String.Set.add file acc)
+      t.cache String.Set.empty
+
   let stat t file =
     let open Index_format in
     match Stats.find_opt file t.index.stats with
@@ -252,10 +258,9 @@ let locs_of ~config ~env ~typer_result ~pos ~scope path =
       index_buffer ~scope ~current_buffer_path ~stamp ~local_defs ()
     in
     let buffer_locs = Hashtbl.find_opt buffer_index def_uid in
-    let external_locs, desync =
-      if scope = `Buffer then [], false else begin
-      let file_changed = ref false in
-      let locs = List.filter_map config.merlin.index_files ~f:(fun file ->
+    let external_locs =
+      if scope = `Buffer then []
+      else List.filter_map config.merlin.index_files ~f:(fun file ->
         let external_locs = try
             let external_index = Index_cache.read file in
             Index_format.Uid_map.find_opt def_uid external_index.defs
@@ -274,24 +279,22 @@ let locs_of ~config ~env ~typer_result ~pos ~scope path =
           else begin
             (* We ignore external results if their source was modified *)
             let check = Stat_check.check stats ~file in
-            if not check then begin
+            if not check then
               log ~title:"locs_of" "File %s might be out-of-sync." file;
-              file_changed := true
-            end;
             check
-          end) locs))
-        in
-        locs, !file_changed
-      end
+          end) locs,
+          Stat_check.get_outdated_files stats))
+    in
+    let external_locs, out_of_sync_files =
+      List.fold_left ~init:(Lid_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)
     in
-    if desync then log ~title:"locs_of" "External index might be out-of-sync.";
     let locs =
-      let all_locs =
-        match buffer_locs with
-        | Some buffer_locs -> buffer_locs :: external_locs
-        | None -> external_locs
-      in
-      List.fold_left ~init:Lid_set.empty ~f:Lid_set.union all_locs
+      match buffer_locs with
+      | Some buffer_locs -> Lid_set.union buffer_locs external_locs
+      | None -> external_locs
     in
     let locs =
       log ~title:"occurrences" "Found %i locs" (Lid_set.cardinal locs);
@@ -320,9 +323,13 @@ let locs_of ~config ~env ~typer_result ~pos ~scope path =
       Option.value_map ~default:false uid_comp_unit
         ~f:(String.equal @@ Env.get_unit_name ())
     in
-    let synced = not desync in
-    if not def_uid_is_in_current_unit then Ok { locs; synced }
+    let status = match scope, String.Set.to_list out_of_sync_files with
+      | `Project, [] -> `Included
+      | `Project, l -> `Out_of_sync l
+      | `Buffer, _ -> `Not_requested
+    in
+    if not def_uid_is_in_current_unit then { locs; status }
     else
       let locs = set_fname ~file:current_buffer_path def_loc :: locs in
-      Ok { locs;  synced }
-  | None -> Error "Could not find the definition [uid]"
+      { locs;  status }
+  | None -> { locs = []; status = `No_def}

src/analysis/occurrences.mli

@@ -1,4 +1,4 @@
-type res = { locs: Warnings.loc list; synced: bool }
+type t = { locs: Warnings.loc list; status: Query_protocol.occurrences_status }
 
 val locs_of
   : config:Mconfig.t
@@ -7,4 +7,4 @@ val locs_of
   -> pos:Lexing.position
   -> scope:[`Project | `Buffer]
   -> string
-  -> (res, string) result
+  -> t

src/frontend/query_commands.ml

@@ -808,11 +808,10 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a =
       Locate.log ~title:"reconstructed identifier" "%s" path;
       path
     in
-    (match scope, Occurrences.locs_of ~config ~env ~typer_result ~pos ~scope path with
-    | `Buffer, Ok { locs; _ } -> locs, `Not_requested
-    | `Project, Ok { locs; synced = true } -> locs, `Included
-    | `Project, Ok { locs; synced = false } -> locs, `Out_of_sync
-    | _, Error _ -> [], `Included)
+    let { Occurrences.locs; status } =
+      Occurrences.locs_of ~config ~env ~typer_result ~pos ~scope path
+    in
+    locs, status
 
   | Version ->
     Printf.sprintf "The Merlin toolkit version %s, for Ocaml %s\n"

src/frontend/query_protocol.ml

@@ -107,6 +107,13 @@ type is_tail_position = [`No | `Tail_position | `Tail_call]
 
 type _ _bool = bool
 
+type occurrences_status = [
+  | `Not_requested
+  | `Out_of_sync of string list
+  | `No_def
+  | `Included
+]
+
 type _ t =
   | Type_expr(* *)
     :  string * Msource.position
@@ -207,7 +214,6 @@ type _ t =
     -> string list t
   | Occurrences(* *)
     : [`Ident_at of Msource.position] * [`Project | `Buffer]
-    -> (Location.t list
-        * [`Not_requested|`Out_of_sync|`No_def|`Included]) t
+    -> (Location.t list * occurrences_status) t
   | Version
     : string t