From c9d8b01cfdd8ff7a165e59a5c1177635be022cfc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 22 Feb 2024 17:03:18 +0100 Subject: [PATCH 1/8] index: add new configuration directive --- src/dot-merlin/dot_merlin_reader.ml | 6 +++++- src/dot-protocol/merlin_dot_protocol.ml | 9 ++++++++- src/dot-protocol/merlin_dot_protocol.mli | 7 ++++++- src/kernel/mconfig.ml | 10 ++++++++++ src/kernel/mconfig.mli | 1 + src/kernel/mconfig_dot.ml | 5 +++++ src/kernel/mconfig_dot.mli | 1 + tests/test-dirs/config/dot-merlin-reader/quoting.t | 1 + 8 files changed, 37 insertions(+), 3 deletions(-) diff --git a/src/dot-merlin/dot_merlin_reader.ml b/src/dot-merlin/dot_merlin_reader.ml index e768d6cacb..a4dc799bf5 100644 --- a/src/dot-merlin/dot_merlin_reader.ml +++ b/src/dot-merlin/dot_merlin_reader.ml @@ -82,6 +82,8 @@ module Cache = File_cache.Make (struct tell (`CMI (String.drop 4 line)) else if String.is_prefixed ~by:"CMT " line then tell (`CMT (String.drop 4 line)) + else if String.is_prefixed ~by:"INDEX " line then + tell (`INDEX (String.drop 6 line)) else if String.is_prefixed ~by:"PKG " line then tell (`PKG (rev_split_words (String.drop 4 line))) else if String.is_prefixed ~by:"EXT " line then @@ -326,7 +328,7 @@ let empty_config = { let prepend_config ~cwd ~cfg = List.fold_left ~init:cfg ~f:(fun cfg (d : Merlin_dot_protocol.Directive.Raw.t) -> match d with - | `B _ | `H _ | `S _ | `CMI _ | `CMT _ as directive -> + | `B _ | `H _ | `S _ | `CMI _ | `CMT _ | `INDEX _ as directive -> { cfg with to_canonicalize = (cwd, directive) :: cfg.to_canonicalize } | `EXT _ | `SUFFIX _ | `FLG _ | `READER _ | (`EXCLUDE_QUERY_DIR | `USE_PPX_CACHE | `UNKNOWN_TAG _) as directive -> @@ -458,6 +460,8 @@ let postprocess cfg = | `S path -> List.map (expand ~stdlib dir path) ~f:(fun p -> `S p) | `CMI path -> List.map (expand ~stdlib dir path) ~f:(fun p -> `CMI p) | `CMT path -> List.map (expand ~stdlib dir path) ~f:(fun p -> `CMT p) + | `INDEX path -> + List.map (expand ~stdlib dir path) ~f:(fun p -> `INDEX p) in (dirs :> Merlin_dot_protocol.directive list) ) diff --git a/src/dot-protocol/merlin_dot_protocol.ml b/src/dot-protocol/merlin_dot_protocol.ml index ba7ea25d0c..f10ccc4abe 100644 --- a/src/dot-protocol/merlin_dot_protocol.ml +++ b/src/dot-protocol/merlin_dot_protocol.ml @@ -31,7 +31,12 @@ open Merlin_utils.Std.Result module Directive = struct type include_path = - [ `B of string | `H of string | `S of string | `CMI of string | `CMT of string ] + [ `B of string + | `H of string + | `S of string + | `CMI of string + | `CMT of string + | `INDEX of string ] type no_processing_required = [ `EXT of string list @@ -85,6 +90,7 @@ module Sexp = struct | "H" -> `H value | "CMI" -> `CMI value | "CMT" -> `CMT value + | "INDEX" -> `INDEX value | "STDLIB" -> `STDLIB value | "SUFFIX" -> `SUFFIX value | "ERROR" -> `ERROR_MSG value @@ -116,6 +122,7 @@ module Sexp = struct | `S s -> ("S", single s) | `CMI s -> ("CMI", single s) | `CMT s -> ("CMT", single s) + | `INDEX s -> ("INDEX", single s) | `EXT ss -> ("EXT", [ List (atoms_of_strings ss) ]) | `FLG ss -> ("FLG", [ List (atoms_of_strings ss) ]) | `STDLIB s -> ("STDLIB", single s) diff --git a/src/dot-protocol/merlin_dot_protocol.mli b/src/dot-protocol/merlin_dot_protocol.mli index 2acff7bbf3..c11e8bd137 100644 --- a/src/dot-protocol/merlin_dot_protocol.mli +++ b/src/dot-protocol/merlin_dot_protocol.mli @@ -43,7 +43,12 @@ really do not want to load them. *) module Directive : sig type include_path = - [ `B of string | `H of string| `S of string | `CMI of string | `CMT of string ] + [ `B of string + | `H of string + | `S of string + | `CMI of string + | `CMT of string + | `INDEX of string ] type no_processing_required = [ `EXT of string list diff --git a/src/kernel/mconfig.ml b/src/kernel/mconfig.ml index 7ac75834ec..6dbcc90576 100644 --- a/src/kernel/mconfig.ml +++ b/src/kernel/mconfig.ml @@ -75,6 +75,7 @@ type merlin = { source_path : string list; cmi_path : string list; cmt_path : string list; + index_files : string list; extensions : string list; suffixes : (string * string) list; stdlib : string option; @@ -107,6 +108,7 @@ let dump_merlin x = "source_path" , `List (List.map ~f:Json.string x.source_path); "cmi_path" , `List (List.map ~f:Json.string x.cmi_path); "cmt_path" , `List (List.map ~f:Json.string x.cmt_path); + "index_files" , `List (List.map ~f:Json.string x.index_files); "flags_applied", `List (List.map ~f:dump_flag_list x.flags_applied); "extensions" , `List (List.map ~f:Json.string x.extensions); "suffixes" , `List ( @@ -247,6 +249,7 @@ let get_external_config path t = source_path = dot.source_path @ merlin.source_path; cmi_path = dot.cmi_path @ merlin.cmi_path; cmt_path = dot.cmt_path @ merlin.cmt_path; + index_files = dot.index_files @ merlin.index_files; exclude_query_dir = dot.exclude_query_dir || merlin.exclude_query_dir; use_ppx_cache = dot.use_ppx_cache || merlin.use_ppx_cache; extensions = dot.extensions @ merlin.extensions; @@ -287,6 +290,12 @@ let merlin_flags = [ {merlin with cmt_path = dir :: merlin.cmt_path}), " Add to merlin cmt path" ); + ( + "-index-file", + marg_path (fun file merlin -> + {merlin with index_files = file :: merlin.index_files}), + " Add to the index files used by merlin" + ); ( "-reader", Marg.param "command" (fun reader merlin -> @@ -620,6 +629,7 @@ let initial = { source_path = []; cmi_path = []; cmt_path = []; + index_files = []; extensions = []; suffixes = [(".ml", ".mli"); (".re", ".rei")]; stdlib = None; diff --git a/src/kernel/mconfig.mli b/src/kernel/mconfig.mli index 8337776ccb..bd8e5b21b6 100644 --- a/src/kernel/mconfig.mli +++ b/src/kernel/mconfig.mli @@ -33,6 +33,7 @@ type merlin = { source_path : string list; cmi_path : string list; cmt_path : string list; + index_files : string list; extensions : string list; suffixes : (string * string) list; stdlib : string option; diff --git a/src/kernel/mconfig_dot.ml b/src/kernel/mconfig_dot.ml index a4d7ff1a9c..a902551b9f 100644 --- a/src/kernel/mconfig_dot.ml +++ b/src/kernel/mconfig_dot.ml @@ -38,6 +38,7 @@ type config = { source_path : string list; cmi_path : string list; cmt_path : string list; + index_files : string list; flags : string list with_workdir list; extensions : string list; suffixes : (string * string) list; @@ -53,6 +54,7 @@ let empty_config = { source_path = []; cmi_path = []; cmt_path = []; + index_files = []; extensions = []; suffixes = []; flags = []; @@ -240,6 +242,8 @@ let prepend_config ~dir:cwd configurator (directives : directive list) config = | `S path -> {config with source_path = path :: config.source_path}, errors | `CMI path -> {config with cmi_path = path :: config.cmi_path}, errors | `CMT path -> {config with cmt_path = path :: config.cmt_path}, errors + | `INDEX file -> + {config with index_files = file :: config.index_files}, errors | `EXT exts -> {config with extensions = exts @ config.extensions}, errors | `SUFFIX suffix -> @@ -274,6 +278,7 @@ let postprocess_config config = source_path = clean config.source_path; cmi_path = clean config.cmi_path; cmt_path = clean config.cmt_path; + index_files = clean config.index_files; extensions = clean config.extensions; suffixes = clean config.suffixes; flags = clean config.flags; diff --git a/src/kernel/mconfig_dot.mli b/src/kernel/mconfig_dot.mli index 60636e37e3..7a7fb1b175 100644 --- a/src/kernel/mconfig_dot.mli +++ b/src/kernel/mconfig_dot.mli @@ -34,6 +34,7 @@ type config = { source_path : string list; cmi_path : string list; cmt_path : string list; + index_files : string list; flags : string list with_workdir list; extensions : string list; suffixes : (string * string) list; diff --git a/tests/test-dirs/config/dot-merlin-reader/quoting.t b/tests/test-dirs/config/dot-merlin-reader/quoting.t index b9ae8c7eee..40ef946790 100644 --- a/tests/test-dirs/config/dot-merlin-reader/quoting.t +++ b/tests/test-dirs/config/dot-merlin-reader/quoting.t @@ -16,6 +16,7 @@ "source_path": [], "cmi_path": [], "cmt_path": [], + "index_files": [], "flags_applied": [ { "workdir": "$TESTCASE_ROOT", From c6df11d8f9a4e2ae79db857f0ec16900981aa766 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 22 Feb 2024 17:05:58 +0100 Subject: [PATCH 2/8] occurrences: add support for project-wide occurrences --- src/analysis/dune | 3 +- src/analysis/index_format.ml | 96 +++++++++++++++++++++++++-- src/analysis/occurrences.ml | 116 ++++++++++++++++++++++++++------- src/analysis/occurrences.mli | 5 +- src/frontend/query_commands.ml | 11 ++-- 5 files changed, 192 insertions(+), 39 deletions(-) diff --git a/src/analysis/dune b/src/analysis/dune index 6b4d2f6d09..09227105d8 100644 --- a/src/analysis/dune +++ b/src/analysis/dune @@ -22,4 +22,5 @@ query_protocol ocaml_typing ocaml_utils - str)) + str + unix)) diff --git a/src/analysis/index_format.ml b/src/analysis/index_format.ml index 12957f1d9d..e31baf369a 100644 --- a/src/analysis/index_format.ml +++ b/src/analysis/index_format.ml @@ -1,8 +1,11 @@ +exception Not_an_index of string + module Lid : Set.OrderedType with type t = Longident.t Location.loc = struct type t = Longident.t Location.loc let compare_pos (p1 : Lexing.position) (p2 : Lexing.position) = - match String.compare p1.pos_fname p2.pos_fname with + let p1f, p2f = Filename.(basename p1.pos_fname, basename p2.pos_fname) in + match String.compare p1f p2f with | 0 -> Int.compare p1.pos_cnum p2.pos_cnum | n -> n @@ -13,11 +16,92 @@ module Lid : Set.OrderedType with type t = Longident.t Location.loc = struct end module LidSet = Set.Make (Lid) +module Stats = Map.Make (String) (** [add tbl uid locs] adds a binding of [uid] to the locations [locs]. If this key is already present the locations are merged. *) - let add tbl uid locs = - try - let locations = Hashtbl.find tbl uid in - Hashtbl.replace tbl uid (LidSet.union locs locations) - with Not_found -> Hashtbl.add tbl uid locs +let add tbl uid locs = + try + let locations = Hashtbl.find tbl uid in + Hashtbl.replace tbl uid (LidSet.union locs locations) + with Not_found -> Hashtbl.add tbl uid locs + +type stat = { mtime : float; size : int; source_digest: string option } +type index = { + defs : (Shape.Uid.t, LidSet.t) Hashtbl.t; + approximated : (Shape.Uid.t, LidSet.t) Hashtbl.t; + load_path : Load_path.paths; + cu_shape : (string, Shape.t) Hashtbl.t; + stats : stat Stats.t; +} + +let pp_partials (fmt : Format.formatter) + (partials : (Shape.Uid.t, LidSet.t) Hashtbl.t) = + Format.fprintf fmt "{@["; + Hashtbl.iter + (fun uid locs -> + Format.fprintf fmt "@[uid: %a; locs:@ @[%a@]@]@;" + Shape.Uid.print uid + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt ";@;") + (fun fmt { Location.txt; loc } -> + Format.fprintf fmt "%S: %a" + (try Longident.flatten txt |> String.concat "." with _ -> "") + Location.print_loc loc)) + (LidSet.elements locs)) + partials; + Format.fprintf fmt "@]}" + +let pp (fmt : Format.formatter) pl = + Format.fprintf fmt "%i uids:@ {@[" (Hashtbl.length pl.defs); + Hashtbl.iter + (fun uid locs -> + Format.fprintf fmt "@[uid: %a; locs:@ @[%a@]@]@;" + Shape.Uid.print uid + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt ";@;") + (fun fmt { Location.txt; loc } -> + Format.fprintf fmt "%S: %a" + (try Longident.flatten txt |> String.concat "." with _ -> "") + Location.print_loc loc)) + (LidSet.elements locs)) + pl.defs; + Format.fprintf fmt "@]},@ "; + Format.fprintf fmt "%i approx shapes:@ @[%a@],@ " + (Hashtbl.length pl.approximated) + pp_partials pl.approximated; + Format.fprintf fmt "and shapes for CUS %s.@ " + (String.concat ";@," (Hashtbl.to_seq_keys pl.cu_shape |> List.of_seq)) + +let ext = "ocaml-index" + +(* [magic_number] Must be the same lenght as cmt's magic numbers *) +let magic_number = "Merl2023I001" + +let write ~file index = + Merlin_utils.Misc.output_to_file_via_temporary ~mode:[ Open_binary ] file + (fun _temp_file_name oc -> + output_string oc magic_number; + output_value oc (index : index)) + +type file_content = Cmt of Cmt_format.cmt_infos | Index of index | Unknown + +let read ~file = + let ic = open_in_bin file in + Merlin_utils.Misc.try_finally + ~always:(fun () -> close_in ic) + (fun () -> + let file_magic_number = ref (Cmt_format.read_magic_number ic) in + let cmi_magic_number = Ocaml_utils.Config.cmi_magic_number in + let cmt_magic_number = Ocaml_utils.Config.cmt_magic_number in + (if String.equal !file_magic_number cmi_magic_number then + let _ = Cmi_format.input_cmi ic in + file_magic_number := Cmt_format.read_magic_number ic); + if String.equal !file_magic_number cmt_magic_number then + Cmt (input_value ic : Cmt_format.cmt_infos) + else if String.equal !file_magic_number magic_number then + Index (input_value ic : index) + else Unknown) + +let read_exn ~file = + match read ~file with Index index -> index | _ -> raise (Not_an_index file) diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml index edb205c97b..79ad78e0e1 100644 --- a/src/analysis/occurrences.ml +++ b/src/analysis/occurrences.ml @@ -3,6 +3,8 @@ module LidSet = Index_format.LidSet let {Logger. log} = Logger.for_section "occurrences" +type res = { locs: Warnings.loc list; synced: bool } + let set_fname ~file (loc : Location.t) = let pos_fname = file in { loc with @@ -25,7 +27,7 @@ let decl_of_path_or_lid env namespace path lid = end | _ -> Env_lookup.loc path namespace env -let index_buffer_ ~current_buffer_path ~local_defs () = +let index_buffer_ ~scope ~current_buffer_path ~local_defs () = let {Logger. log} = Logger.for_section "index" in let defs = Hashtbl.create 64 in let module Shape_reduce = @@ -86,6 +88,7 @@ let index_buffer_ ~current_buffer_path ~local_defs () = occurrences in the current buffer only. *) let rec iter_on_path ~namespace path ({Location.txt; loc} as lid) = let () = f ~namespace env path lid in + if scope = `Buffer then match path, txt with | Pdot (path, _), Ldot (lid, s) -> let length_with_dot = String.length s + 1 in @@ -106,19 +109,20 @@ let index_buffer = (* Right now, we only cache the last used index. We could do better by caching the index for every known buffer. *) let cache = ref None in - fun ~current_buffer_path ~stamp ~local_defs () -> + fun ~scope ~current_buffer_path ~stamp ~local_defs () -> let {Logger. log} = Logger.for_section "index" in match !cache with - | Some (path, stamp', value) when + | Some (path, stamp', scope', value) when String.equal path current_buffer_path - && Int.equal stamp' stamp -> + && Int.equal stamp' stamp + && scope' = scope -> log ~title:"index_cache" "Reusing cached value for path %s and stamp %i." path stamp'; value | _ -> log ~title:"index_cache" "No valid cache found, reindexing."; - let result = index_buffer_ ~current_buffer_path ~local_defs () in - cache := Some (current_buffer_path, stamp, result); + let result = index_buffer_ ~current_buffer_path ~scope ~local_defs () in + cache := Some (current_buffer_path, stamp, scope, result); result (* A longident can have the form: A.B.x Right now we are only interested in @@ -163,7 +167,24 @@ let comp_unit_of_uid = function | Item { comp_unit; _ } -> Some comp_unit | Internal | Predef _ -> None -let locs_of ~config ~env ~typer_result ~pos path = +let check Index_format.{ stats; _ } file = + let open Index_format in + match Stats.find_opt file stats with + | None -> log ~title:"stat_check" "No mtime found for file %S." file; true + | Some { size; _ } -> + try + let stats = Unix.stat file in + let equal = + (* This is fast but approximative. A better option would be to check + [mtime] and then [source_digest] if the times differ. *) + Int.equal stats.st_size size + in + log ~title:"stat_check" + "File %s has been modified since the index was built." file; + equal + with Unix.Unix_error _ -> false + +let locs_of ~config ~env ~typer_result ~pos ~scope path = log ~title:"occurrences" "Looking for occurences of %s (pos: %s)" path (Lexing.print_position () pos); @@ -173,28 +194,29 @@ let locs_of ~config ~env ~typer_result ~pos path = ~config:{ mconfig = config; traverse_aliases=false; ml_or_mli = `ML} ~env ~local_defs ~pos path in - let def = + (* When we fail to find an exact definition we restrict scope to `Buffer *) + let def, scope = match locate_result with | `At_origin -> log ~title:"locs_of" "Cursor is on definition / declaration"; (* We are on a definition / declaration so we look for the node's uid *) let browse = Mbrowse.of_typedtree local_defs in let env, node = Mbrowse.leaf_node (Mbrowse.enclosing pos [browse]) in - uid_and_loc_of_node env node + uid_and_loc_of_node env node, scope | `Found { uid; location; approximated = false; _ } -> log ~title:"locs_of" "Found definition uid using locate: %a " Logger.fmt (fun fmt -> Shape.Uid.print fmt uid); - Some (uid, location) + Some (uid, location), scope | `Found { decl_uid; location; approximated = true; _ } -> - log ~title:"locs_of" "Approx: %a " + log ~title:"locs_of" "Approx. definition: %a " Logger.fmt (fun fmt -> Shape.Uid.print fmt decl_uid); - Some (decl_uid, location) + Some (decl_uid, location), `Buffer | `Builtin (uid, s) -> log ~title:"locs_of" "Locate found a builtin: %s" s; - Some (uid, Location.none) + Some (uid, Location.none), scope | _ -> log ~title:"locs_of" "Locate failed to find a definition."; - None + None, `Buffer in let current_buffer_path = Filename.concat config.query.directory config.query.filename @@ -207,23 +229,67 @@ let locs_of ~config ~env ~typer_result ~pos path = log ~title:"locs_of" "Indexing current buffer"; let buffer_index = let stamp = Mtyper.get_stamp typer_result in - index_buffer ~current_buffer_path ~stamp ~local_defs () + index_buffer ~scope ~current_buffer_path ~stamp ~local_defs () in let buffer_locs = Hashtbl.find_opt buffer_index def_uid in - let locs = Option.value ~default:LidSet.empty buffer_locs in + let external_locs, desync = + if scope = `Buffer then [], false else begin + let exception File_changed in + try + let locs = List.filter_map config.merlin.index_files ~f:(fun file -> + let external_index = Index_format.read_exn ~file in + Hashtbl.find_opt external_index.defs def_uid + |> Option.map ~f:(fun locs -> LidSet.filter (fun {loc; _} -> + (* We ignore external results that concern the current buffer *) + let fname = loc.Location.loc_start.Lexing.pos_fname in + if String.equal fname current_buffer_path then false + else begin + (* We ignore external results if the index is not up-to-date *) + (* We could return partial results from up-to-date file *) + if not (check external_index fname) then begin + log ~title:"locs_of" "File %s might be out-of-sync." fname; + raise File_changed + end; + true + end) locs)) + in + locs, false + with File_changed -> [], true + end + 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:LidSet.empty ~f:LidSet.union all_locs + in let locs = - log ~title:"occurrences" "Found %i locs" (LidSet.cardinal locs); - LidSet.elements locs - |> List.map ~f:(fun {Location.txt; loc} -> - log ~title:"occurrences" "Found occ: %s %a" - (Longident.head txt) Logger.fmt (Fun.flip Location.print_loc loc); - last_loc loc txt) + log ~title:"occurrences" "Found %i locs" (LidSet.cardinal locs); + LidSet.elements locs + |> List.filter_map ~f:(fun {Location.txt; loc} -> + log ~title:"occurrences" "Found occ: %s %a" + (Longident.head txt) 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 Filename.is_relative fname then 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 else Some loc) in let def_uid_is_in_current_unit = let uid_comp_unit = comp_unit_of_uid def_uid in Option.value_map ~default:false uid_comp_unit ~f:(String.equal @@ Env.get_unit_name ()) in - if not def_uid_is_in_current_unit then Ok locs - else Ok (set_fname ~file:current_buffer_path def_loc :: locs) - | None -> Error "Could not find the uid of the definition." + let synced = not desync in + if not def_uid_is_in_current_unit then Ok { locs; synced } + else + let locs = set_fname ~file:current_buffer_path def_loc :: locs in + Ok { locs; synced } + | None -> Error "Could not find the definition [uid]" diff --git a/src/analysis/occurrences.mli b/src/analysis/occurrences.mli index eea7b6b3e7..4a60ac3908 100644 --- a/src/analysis/occurrences.mli +++ b/src/analysis/occurrences.mli @@ -1,7 +1,10 @@ +type res = { locs: Warnings.loc list; synced: bool } + val locs_of : config:Mconfig.t -> env:Env.t -> typer_result:Mtyper.result -> pos:Lexing.position + -> scope:[`Project | `Buffer] -> string - -> (Warnings.loc list, string) result + -> (res, string) result diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml index 150a53e622..379ba19ed8 100644 --- a/src/frontend/query_commands.ml +++ b/src/frontend/query_commands.ml @@ -795,7 +795,7 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = let config = Mpipeline.final_config pipeline in Mconfig.(config.merlin.source_path) - | Occurrences (`Ident_at pos, _) -> + | Occurrences (`Ident_at pos, scope) -> let config = Mpipeline.final_config pipeline in let typer_result = Mpipeline.typer_result pipeline in let pos = Mpipeline.get_lexing_pos pipeline pos in @@ -809,12 +809,11 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = path in let locs = - Occurrences.locs_of ~config ~env ~typer_result ~pos path - |> Result.value ~default:[] + match Occurrences.locs_of ~config ~env ~typer_result ~pos ~scope path with + | Ok { locs; _ } -> locs + | Error _ -> [] in - let loc_start l = l.Location.loc_start in - let cmp l1 l2 = Lexing.compare_pos (loc_start l1) (loc_start l2) in - (List.sort ~cmp locs) + locs | Version -> Printf.sprintf "The Merlin toolkit version %s, for Ocaml %s\n" From 806c374d1cc16993c828e9fc86f9bcf69817dfb4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 22 Feb 2024 17:06:36 +0100 Subject: [PATCH 3/8] test: add a test for project-wide occurrences Requires ocaml-index --- .../occurrences/project-wide/pwo-basic.t | 65 +++++++++++++++++++ 1 file changed, 65 insertions(+) create mode 100644 tests/test-dirs/occurrences/project-wide/pwo-basic.t diff --git a/tests/test-dirs/occurrences/project-wide/pwo-basic.t b/tests/test-dirs/occurrences/project-wide/pwo-basic.t new file mode 100644 index 0000000000..dcc5b295f2 --- /dev/null +++ b/tests/test-dirs/occurrences/project-wide/pwo-basic.t @@ -0,0 +1,65 @@ + $ cat >lib.ml <<'EOF' + > let foo = "bar" + > let () = print_string foo + > 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 + $ ocaml-index dump project.ocaml-index + 2 uids: + {uid: Stdlib.312; locs: + "print_string": File "lib.ml", line 2, characters 9-21; + "print_string": File "main.ml", line 1, characters 9-21 + uid: Lib.0; locs: + "foo": File "lib.ml", line 1, characters 4-7; + "foo": File "lib.ml", line 2, characters 22-25; + "Lib.foo": File "main.ml", line 1, characters 22-29 + }, 0 approx shapes: {}, and shapes for CUS . + + $ $MERLIN single occurrences -scope project -identifier-at 1:28 \ + > -index-file project.ocaml-index \ + > -filename main.ml Date: Thu, 22 Feb 2024 17:52:04 +0100 Subject: [PATCH 4/8] index: cache files (and move to another library) --- src/analysis/dune | 4 +++- src/analysis/occurrences.ml | 2 +- src/index-format/dune | 10 ++++++++++ src/index-format/index_cache.ml | 5 +++++ src/{analysis => index-format}/index_format.ml | 2 +- src/kernel/dune | 2 +- src/kernel/mocaml.ml | 3 ++- 7 files changed, 23 insertions(+), 5 deletions(-) create mode 100644 src/index-format/dune create mode 100644 src/index-format/index_cache.ml rename src/{analysis => index-format}/index_format.ml (98%) diff --git a/src/analysis/dune b/src/analysis/dune index 09227105d8..905df41c6d 100644 --- a/src/analysis/dune +++ b/src/analysis/dune @@ -10,13 +10,15 @@ -open Merlin_utils -open Merlin_specific -open Merlin_extend - -open Merlin_kernel) + -open Merlin_kernel + -open Merlin_index_format) (libraries merlin_config merlin_specific merlin_extend merlin_kernel merlin_utils + merlin_index_format ocaml_parsing ocaml_preprocess query_protocol diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml index 79ad78e0e1..a17d284811 100644 --- a/src/analysis/occurrences.ml +++ b/src/analysis/occurrences.ml @@ -237,7 +237,7 @@ let locs_of ~config ~env ~typer_result ~pos ~scope path = let exception File_changed in try let locs = List.filter_map config.merlin.index_files ~f:(fun file -> - let external_index = Index_format.read_exn ~file in + let external_index = Index_cache.read file in Hashtbl.find_opt external_index.defs def_uid |> Option.map ~f:(fun locs -> LidSet.filter (fun {loc; _} -> (* We ignore external results that concern the current buffer *) diff --git a/src/index-format/dune b/src/index-format/dune new file mode 100644 index 0000000000..7cdf97ffd4 --- /dev/null +++ b/src/index-format/dune @@ -0,0 +1,10 @@ +(library + (name merlin_index_format) + (public_name merlin-lib.index_format) + (flags + :standard + -open Ocaml_parsing + -open Ocaml_typing + -open Ocaml_utils + -open Merlin_utils) + (libraries ocaml_parsing ocaml_typing ocaml_utils merlin_utils)) diff --git a/src/index-format/index_cache.ml b/src/index-format/index_cache.ml new file mode 100644 index 0000000000..6ff979bfd4 --- /dev/null +++ b/src/index-format/index_cache.ml @@ -0,0 +1,5 @@ +include File_cache.Make (struct + type t = Index_format.index + let read file = Index_format.read_exn ~file + let cache_name = "Index_cache" +end) diff --git a/src/analysis/index_format.ml b/src/index-format/index_format.ml similarity index 98% rename from src/analysis/index_format.ml rename to src/index-format/index_format.ml index e31baf369a..98da574135 100644 --- a/src/analysis/index_format.ml +++ b/src/index-format/index_format.ml @@ -79,7 +79,7 @@ let ext = "ocaml-index" let magic_number = "Merl2023I001" let write ~file index = - Merlin_utils.Misc.output_to_file_via_temporary ~mode:[ Open_binary ] file + Misc.output_to_file_via_temporary ~mode:[ Open_binary ] file (fun _temp_file_name oc -> output_string oc magic_number; output_value oc (index : index)) diff --git a/src/kernel/dune b/src/kernel/dune index 7d12d85e73..bd98153bd1 100644 --- a/src/kernel/dune +++ b/src/kernel/dune @@ -15,7 +15,7 @@ -open Merlin_extend) (libraries merlin_config os_ipc ocaml_parsing ocaml_preprocess ocaml_typing ocaml_utils merlin_extend merlin_specific merlin_utils - merlin_dot_protocol unix str)) + merlin_dot_protocol merlin_index_format unix str)) (rule (targets standard_library.ml) diff --git a/src/kernel/mocaml.ml b/src/kernel/mocaml.ml index 833db64fe8..650d8d7925 100644 --- a/src/kernel/mocaml.ml +++ b/src/kernel/mocaml.ml @@ -112,5 +112,6 @@ let clear_caches () = ( (* Flush cache *) let flush_caches ?older_than () = ( Cmi_cache.flush ?older_than (); - Cmt_cache.flush ?older_than () + Cmt_cache.flush ?older_than (); + Merlin_index_format.Index_cache.flush ?older_than () ) From 1792af8f10074f96885ef9eae0c23aeb0d50a0e7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 23 Feb 2024 09:53:53 +0100 Subject: [PATCH 5/8] [emacs] handle project-wide-occurrences in occur-mode --- emacs/merlin.el | 51 ++++++++++++++++++++++++++++++++++--------------- 1 file changed, 36 insertions(+), 15 deletions(-) diff --git a/emacs/merlin.el b/emacs/merlin.el index 9100dfa360..06212e1b41 100644 --- a/emacs/merlin.el +++ b/emacs/merlin.el @@ -1784,24 +1784,20 @@ Empty string defaults to jumping to all these." (let ((inhibit-read-only t) (buffer-undo-list t) (pending-line) - (pending-lines-text)) + (pending-lines-text) + (previous-buf)) (erase-buffer) (occur-mode) - (insert (propertize (format "%d occurrences in buffer: %s" - (length lst) - src-buff) - 'font-lock-face list-matching-lines-buffer-name-face - 'read-only t - 'occur-title (get-buffer src-buff))) - (insert "\n") (dolist (pos positions) - (let* ((marker (cdr (assoc 'marker pos))) - (start (assoc 'start pos)) + (let* ((start (assoc 'start pos)) (end (assoc 'end pos)) + (occ-buff (find-file-noselect (cdr (assoc 'file pos)))) + (marker (with-current-buffer occ-buff + (copy-marker (merlin--point-of-pos start)))) (line (cdr (assoc 'line start))) - (start-buf-pos (with-current-buffer src-buff + (start-buf-pos (with-current-buffer occ-buff (merlin--point-of-pos start))) - (end-buf-pos (with-current-buffer src-buff + (end-buf-pos (with-current-buffer occ-buff (merlin--point-of-pos end))) (prefix-length 8) (start-offset (+ prefix-length @@ -1813,8 +1809,7 @@ Empty string defaults to jumping to all these." marker start-buf-pos end-buf-pos - src-buff)))) - + occ-buff)))) ;; Insert the critical text properties that occur-mode ;; makes use of (add-text-properties start-offset @@ -1828,9 +1823,22 @@ Empty string defaults to jumping to all these." ;; found in order to accumulate multiple matches within ;; one line. (when (and pending-lines-text - (not (equal line pending-line))) + (or (not (equal line pending-line)) + (not (equal previous-buf occ-buff)))) (insert pending-lines-text)) + + (when (not (equal previous-buf occ-buff)) + (insert (propertize (format "Occurrences in buffer: %s" + ;(length lst) + occ-buff) + 'font-lock-face + list-matching-lines-buffer-name-face + 'read-only t + 'occur-title occ-buff)) + (insert "\n")) + (setq pending-line line) + (setq previous-buf occ-buff) (setq pending-lines-text lines-text))) ;; Catch final pending text @@ -1860,6 +1868,19 @@ Empty string defaults to jumping to all these." (merlin-occurrences-list r) (error "%s" r))))) +(defun merlin--project-occurrences () + (merlin-call "occurrences" "-scope" "project" "-identifier-at" + (merlin-unmake-point (point)))) + +(defun merlin-project-occurrences () + "List all occurrences of identifier under cursor in buffer." + (interactive) + (let ((r (merlin--project-occurrences))) + (when r + (if (listp r) + (merlin-occurrences-list r) + (error "%s" r))))) + ;;;;;;;;;;;;;;;;;;; ;; OPEN REFACTOR ;; ;;;;;;;;;;;;;;;;;;; From a8db612b5e9b8a7baacaf532d7275bc445ecaba0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 24 Apr 2024 12:13:03 +0200 Subject: [PATCH 6/8] index_format: using maps is more efficient when merging indexes --- src/analysis/occurrences.ml | 22 ++++++---- src/index-format/index_format.ml | 40 +++++++++---------- src/index-format/index_format.mli | 37 +++++++++++++++++ src/ocaml/utils/config.ml | 1 + src/ocaml/utils/config.mli | 2 + .../occurrences/project-wide/pwo-basic.t | 8 ++-- 6 files changed, 77 insertions(+), 33 deletions(-) create mode 100644 src/index-format/index_format.mli diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml index a17d284811..782af6046c 100644 --- a/src/analysis/occurrences.ml +++ b/src/analysis/occurrences.ml @@ -1,5 +1,5 @@ open Std -module LidSet = Index_format.LidSet +module Lid_set = Index_format.Lid_set let {Logger. log} = Logger.for_section "occurrences" @@ -30,6 +30,12 @@ let decl_of_path_or_lid env namespace path lid = let index_buffer_ ~scope ~current_buffer_path ~local_defs () = let {Logger. log} = Logger.for_section "index" in let defs = Hashtbl.create 64 in + let add tbl uid locs = + try + let locations = Hashtbl.find tbl uid in + Hashtbl.replace tbl uid (Lid_set.union locs locations) + with Not_found -> Hashtbl.add tbl uid locs + in let module Shape_reduce = Shape_reduce.Make (struct let fuel = 10 @@ -56,7 +62,7 @@ let index_buffer_ ~scope ~current_buffer_path ~local_defs () = | Some decl -> log ~title:"index_buffer" "Found declaration: %a" Logger.fmt (Fun.flip Location.print_loc decl.loc); - Index_format.(add defs decl.uid (LidSet.singleton lid)) + add defs decl.uid (Lid_set.singleton lid) end in if not_ghost lid then @@ -72,7 +78,7 @@ let index_buffer_ ~scope ~current_buffer_path ~local_defs () = (Longident.head lid.txt) Logger.fmt (Fun.flip Location.print_loc lid.loc) Logger.fmt (Fun.flip Shape.Uid.print uid); - Index_format.(add defs uid (LidSet.singleton lid)) + add defs uid (Lid_set.singleton lid) | Some uid, true -> log ~title:"index_buffer" "Shape is approximative, found uid: %a" Logger.fmt (Fun.flip Shape.Uid.print uid); @@ -238,8 +244,8 @@ let locs_of ~config ~env ~typer_result ~pos ~scope path = try let locs = List.filter_map config.merlin.index_files ~f:(fun file -> let external_index = Index_cache.read file in - Hashtbl.find_opt external_index.defs def_uid - |> Option.map ~f:(fun locs -> LidSet.filter (fun {loc; _} -> + Index_format.Uid_map.find_opt def_uid external_index.defs + |> Option.map ~f:(fun locs -> Lid_set.filter (fun {loc; _} -> (* We ignore external results that concern the current buffer *) let fname = loc.Location.loc_start.Lexing.pos_fname in if String.equal fname current_buffer_path then false @@ -264,11 +270,11 @@ let locs_of ~config ~env ~typer_result ~pos ~scope path = | Some buffer_locs -> buffer_locs :: external_locs | None -> external_locs in - List.fold_left ~init:LidSet.empty ~f:LidSet.union all_locs + List.fold_left ~init:Lid_set.empty ~f:Lid_set.union all_locs in let locs = - log ~title:"occurrences" "Found %i locs" (LidSet.cardinal locs); - LidSet.elements locs + log ~title:"occurrences" "Found %i locs" (Lid_set.cardinal locs); + Lid_set.elements locs |> List.filter_map ~f:(fun {Location.txt; loc} -> log ~title:"occurrences" "Found occ: %s %a" (Longident.head txt) Logger.fmt (Fun.flip Location.print_loc loc); diff --git a/src/index-format/index_format.ml b/src/index-format/index_format.ml index 98da574135..12606cbb25 100644 --- a/src/index-format/index_format.ml +++ b/src/index-format/index_format.ml @@ -15,30 +15,29 @@ module Lid : Set.OrderedType with type t = Longident.t Location.loc = struct | n -> n end -module LidSet = Set.Make (Lid) +module Lid_set = Set.Make (Lid) +module Uid_map = Shape.Uid.Map module Stats = Map.Make (String) -(** [add tbl uid locs] adds a binding of [uid] to the locations [locs]. If this key is +(** [add map uid locs] adds a binding of [uid] to the locations [locs]. If this key is already present the locations are merged. *) -let add tbl uid locs = - try - let locations = Hashtbl.find tbl uid in - Hashtbl.replace tbl uid (LidSet.union locs locations) - with Not_found -> Hashtbl.add tbl uid locs +let add map uid locs = Uid_map.update uid (function + | None -> Some locs + | Some locs' -> Some (Lid_set.union locs' locs)) + map + +type stat = { mtime : float; size : int; source_digest : string option } -type stat = { mtime : float; size : int; source_digest: string option } type index = { - defs : (Shape.Uid.t, LidSet.t) Hashtbl.t; - approximated : (Shape.Uid.t, LidSet.t) Hashtbl.t; - load_path : Load_path.paths; + defs : Lid_set.t Uid_map.t; + approximated : Lid_set.t Uid_map.t; cu_shape : (string, Shape.t) Hashtbl.t; stats : stat Stats.t; } -let pp_partials (fmt : Format.formatter) - (partials : (Shape.Uid.t, LidSet.t) Hashtbl.t) = +let pp_partials (fmt : Format.formatter) (partials : Lid_set.t Uid_map.t) = Format.fprintf fmt "{@["; - Hashtbl.iter + Uid_map.iter (fun uid locs -> Format.fprintf fmt "@[uid: %a; locs:@ @[%a@]@]@;" Shape.Uid.print uid @@ -48,13 +47,13 @@ let pp_partials (fmt : Format.formatter) Format.fprintf fmt "%S: %a" (try Longident.flatten txt |> String.concat "." with _ -> "") Location.print_loc loc)) - (LidSet.elements locs)) + (Lid_set.elements locs)) partials; Format.fprintf fmt "@]}" let pp (fmt : Format.formatter) pl = - Format.fprintf fmt "%i uids:@ {@[" (Hashtbl.length pl.defs); - Hashtbl.iter + Format.fprintf fmt "%i uids:@ {@[" (Uid_map.cardinal pl.defs); + Uid_map.iter (fun uid locs -> Format.fprintf fmt "@[uid: %a; locs:@ @[%a@]@]@;" Shape.Uid.print uid @@ -64,19 +63,18 @@ let pp (fmt : Format.formatter) pl = Format.fprintf fmt "%S: %a" (try Longident.flatten txt |> String.concat "." with _ -> "") Location.print_loc loc)) - (LidSet.elements locs)) + (Lid_set.elements locs)) pl.defs; Format.fprintf fmt "@]},@ "; Format.fprintf fmt "%i approx shapes:@ @[%a@],@ " - (Hashtbl.length pl.approximated) + (Uid_map.cardinal pl.approximated) pp_partials pl.approximated; Format.fprintf fmt "and shapes for CUS %s.@ " (String.concat ";@," (Hashtbl.to_seq_keys pl.cu_shape |> List.of_seq)) let ext = "ocaml-index" -(* [magic_number] Must be the same lenght as cmt's magic numbers *) -let magic_number = "Merl2023I001" +let magic_number = Config.index_magic_number let write ~file index = Misc.output_to_file_via_temporary ~mode:[ Open_binary ] file diff --git a/src/index-format/index_format.mli b/src/index-format/index_format.mli new file mode 100644 index 0000000000..3b3866eb6e --- /dev/null +++ b/src/index-format/index_format.mli @@ -0,0 +1,37 @@ +exception Not_an_index of string + +val ext : string +val magic_number : string + +module Lid : Set.OrderedType with type t = Longident.t Location.loc +module Lid_set : Set.S with type elt = Lid.t +module Stats : Map.S with type key = String.t +module Uid_map = Shape.Uid.Map + +type stat = { + mtime : float; + size : int; + source_digest : string option +} + +type index = { + defs : Lid_set.t Uid_map.t; + approximated : Lid_set.t Uid_map.t; + cu_shape : (string, Shape.t) Hashtbl.t; + stats : stat Stats.t; +} + +val pp : Format.formatter -> index -> unit + +(** [add tbl uid locs] adds a binding of [uid] to the locations [locs]. If this + key is already present the locations are merged. *) +val add : Lid_set.t Uid_map.t -> Shape.Uid.t -> Lid_set.t -> Lid_set.t Uid_map.t + +type file_content = + | Cmt of Cmt_format.cmt_infos + | Index of index + | Unknown + +val write : file:string -> index -> unit +val read : file:string -> file_content +val read_exn : file:string -> index diff --git a/src/ocaml/utils/config.ml b/src/ocaml/utils/config.ml index 4c2a9566f6..0a2c82eec5 100644 --- a/src/ocaml/utils/config.ml +++ b/src/ocaml/utils/config.ml @@ -49,6 +49,7 @@ and ast_impl_magic_number = "Caml1999M034" and ast_intf_magic_number = "Caml1999N034" and cmxs_magic_number = "Caml1999D034" and cmt_magic_number = "Caml1999T034" +and index_magic_number = "Merl2023I001" let interface_suffix = ref ".mli" diff --git a/src/ocaml/utils/config.mli b/src/ocaml/utils/config.mli index 26323f87fa..df34aee281 100644 --- a/src/ocaml/utils/config.mli +++ b/src/ocaml/utils/config.mli @@ -43,6 +43,8 @@ val cmxs_magic_number: string (* Magic number for dynamically-loadable plugins *) val cmt_magic_number: string (* Magic number for compiled interface files *) +val index_magic_number: string + (* Magic number for index files *) val max_tag: int (* Biggest tag that can be stored in the header of a regular block. *) diff --git a/tests/test-dirs/occurrences/project-wide/pwo-basic.t b/tests/test-dirs/occurrences/project-wide/pwo-basic.t index dcc5b295f2..5fcd73f6e1 100644 --- a/tests/test-dirs/occurrences/project-wide/pwo-basic.t +++ b/tests/test-dirs/occurrences/project-wide/pwo-basic.t @@ -12,13 +12,13 @@ $ ocaml-index aggregate main.cmt lib.cmt $ ocaml-index dump project.ocaml-index 2 uids: - {uid: Stdlib.312; locs: - "print_string": File "lib.ml", line 2, characters 9-21; - "print_string": File "main.ml", line 1, characters 9-21 - uid: Lib.0; locs: + {uid: Lib.0; locs: "foo": File "lib.ml", line 1, characters 4-7; "foo": File "lib.ml", line 2, characters 22-25; "Lib.foo": File "main.ml", line 1, characters 22-29 + uid: Stdlib.312; locs: + "print_string": File "lib.ml", line 2, characters 9-21; + "print_string": File "main.ml", line 1, characters 9-21 }, 0 approx shapes: {}, and shapes for CUS . $ $MERLIN single occurrences -scope project -identifier-at 1:28 \ From 2abfae2ff2231b3aad2ed01d5530922c31c8a80a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 25 Apr 2024 16:39:45 +0200 Subject: [PATCH 7/8] index: do not fail when index file does not exist --- src/analysis/occurrences.ml | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml index 782af6046c..b9cef538ab 100644 --- a/src/analysis/occurrences.ml +++ b/src/analysis/occurrences.ml @@ -243,16 +243,23 @@ let locs_of ~config ~env ~typer_result ~pos ~scope path = let exception File_changed in try let locs = List.filter_map config.merlin.index_files ~f:(fun file -> - let external_index = Index_cache.read file in - Index_format.Uid_map.find_opt def_uid external_index.defs - |> Option.map ~f:(fun locs -> Lid_set.filter (fun {loc; _} -> + let external_locs = try + let external_index = Index_cache.read 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; + None + in + Option.map external_locs ~f:(fun (file, locs) -> Lid_set.filter (fun {loc; _} -> (* We ignore external results that concern the current buffer *) let fname = loc.Location.loc_start.Lexing.pos_fname in if String.equal fname current_buffer_path then false else begin (* We ignore external results if the index is not up-to-date *) (* We could return partial results from up-to-date file *) - if not (check external_index fname) then begin + if not (check file fname) then begin log ~title:"locs_of" "File %s might be out-of-sync." fname; raise File_changed end; From 35b94d9e8ba13765e26ee0a7db7f65b5dff3ac9f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 25 Apr 2024 16:44:42 +0200 Subject: [PATCH 8/8] Return partial results even in index is not up to date --- src/analysis/occurrences.ml | 53 ++++++++++++++++++------------------- 1 file changed, 26 insertions(+), 27 deletions(-) diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml index b9cef538ab..91a54d2247 100644 --- a/src/analysis/occurrences.ml +++ b/src/analysis/occurrences.ml @@ -240,34 +240,33 @@ let locs_of ~config ~env ~typer_result ~pos ~scope path = let buffer_locs = Hashtbl.find_opt buffer_index def_uid in let external_locs, desync = if scope = `Buffer then [], false else begin - let exception File_changed in - try - let locs = 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 - |> 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; - None - in - Option.map external_locs ~f:(fun (file, locs) -> Lid_set.filter (fun {loc; _} -> - (* We ignore external results that concern the current buffer *) - let fname = loc.Location.loc_start.Lexing.pos_fname in - if String.equal fname current_buffer_path then false - else begin - (* We ignore external results if the index is not up-to-date *) - (* We could return partial results from up-to-date file *) - if not (check file fname) then begin - log ~title:"locs_of" "File %s might be out-of-sync." fname; - raise File_changed - end; + let file_changed = ref false in + let locs = 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 + |> 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; + None + in + Option.map external_locs ~f:(fun (file, locs) -> Lid_set.filter (fun {loc; _} -> + (* We ignore external results that concern the current buffer *) + let fname = loc.Location.loc_start.Lexing.pos_fname in + if String.equal fname current_buffer_path then false + else begin + (* We ignore external results if the index is not up-to-date *) + (* We could return partial results from up-to-date file *) + if not (check file fname) then begin + log ~title:"locs_of" "File %s might be out-of-sync." fname; + file_changed := true; + false + end else true - end) locs)) - in - locs, false - with File_changed -> [], true + end) locs)) + in + locs, !file_changed end in if desync then log ~title:"locs_of" "External index might be out-of-sync.";