From 6666b735edce4dc104c0d3bf215fa0c162e82375 Mon Sep 17 00:00:00 2001 From: Liam Stevenson Date: Tue, 24 Dec 2024 12:57:26 -0500 Subject: [PATCH 1/3] Fix bug with checking staleness --- src/analysis/occurrences.ml | 33 +++++++++++++++++---------------- 1 file changed, 17 insertions(+), 16 deletions(-) diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml index 19e67546..8083936f 100644 --- a/src/analysis/occurrences.ml +++ b/src/analysis/occurrences.ml @@ -199,33 +199,34 @@ let locs_of ~config ~env ~typer_result ~pos ~scope path = let external_locs = if scope = `Buffer then [] else - List.filter_map config.merlin.index_files ~f:(fun file -> + List.filter_map config.merlin.index_files ~f:(fun 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 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; + log ~title:"external_index" "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; _ } as lid) -> - let is_current_buffer = - (* We filter external results that concern the current buffer *) - let file = loc.Location.loc_start.Lexing.pos_fname in - let file, buf = - match config.merlin.source_root with - | Some root -> - (Filename.concat root file, current_buffer_path) - | None -> (file, config.query.filename) - in - let file = Misc.canonicalize_filename file in - let buf = Misc.canonicalize_filename buf in - String.equal file buf + (* We filter external results that concern the current buffer *) + 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_rel_to_root, + current_buffer_path ) + | None -> (file_rel_to_root, config.query.filename) + in + let file = Misc.canonicalize_filename file_uncanon in + let buf = Misc.canonicalize_filename buf_uncanon in + let is_current_buffer = String.equal file buf in let should_be_ignored = (* We ignore results that don't have a location *) Index_occurrences.should_ignore_lid lid @@ -233,7 +234,7 @@ let locs_of ~config ~env ~typer_result ~pos ~scope path = if is_current_buffer || should_be_ignored then false else begin (* We ignore external results if their source was modified *) - let check = Stat_check.check stats ~file in + let check = Stat_check.check stats ~file:file_rel_to_root in if not check then log ~title:"locs_of" "File %s might be out-of-sync." file; From 6acb8200d168313579705e9c2c68aab6656db303 Mon Sep 17 00:00:00 2001 From: Liam Stevenson Date: Tue, 24 Dec 2024 12:57:41 -0500 Subject: [PATCH 2/3] Create staleness test --- .../occurrences/project-wide/stale.t | 39 +++++++++++++++++++ 1 file changed, 39 insertions(+) create mode 100644 tests/test-dirs/occurrences/project-wide/stale.t diff --git a/tests/test-dirs/occurrences/project-wide/stale.t b/tests/test-dirs/occurrences/project-wide/stale.t new file mode 100644 index 00000000..33ae96cf --- /dev/null +++ b/tests/test-dirs/occurrences/project-wide/stale.t @@ -0,0 +1,39 @@ + $ 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 + $ 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/main.ml", + "start": { + "line": 1, + "col": 22 + }, + "end": { + "line": 1, + "col": 29 + } + } + ] From 7773e85e21d2cc0df4997ef760d7ac30a9435788 Mon Sep 17 00:00:00 2001 From: Liam Stevenson Date: Wed, 8 Jan 2025 10:55:57 -0500 Subject: [PATCH 3/3] Report stale occurrences --- src/analysis/occurrences.ml | 168 ++++++++++++------ src/analysis/occurrences.mli | 4 +- src/commands/query_json.ml | 11 +- src/frontend/query_commands.ml | 4 +- src/frontend/query_protocol.ml | 4 +- .../project-wide/{stale.t => stale-index.t} | 17 +- 6 files changed, 144 insertions(+), 64 deletions(-) rename tests/test-dirs/occurrences/project-wide/{stale.t => stale-index.t} (66%) diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml index 8083936f..f0d7e605 100644 --- a/src/analysis/occurrences.ml +++ b/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 } diff --git a/src/analysis/occurrences.mli b/src/analysis/occurrences.mli index d41d4d40..96f57d46 100644 --- a/src/analysis/occurrences.mli +++ b/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 -> diff --git a/src/commands/query_json.ml b/src/commands/query_json.ml index d730f921..cf74e420 100644 --- a/src/commands/query_json.ml +++ b/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 diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml index b8f47d47..677b80af 100644 --- a/src/frontend/query_commands.ml +++ b/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) -> diff --git a/src/frontend/query_protocol.ml b/src/frontend/query_protocol.ml index 6261c011..5f60dfe1 100644 --- a/src/frontend/query_protocol.ml +++ b/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 diff --git a/tests/test-dirs/occurrences/project-wide/stale.t b/tests/test-dirs/occurrences/project-wide/stale-index.t similarity index 66% rename from tests/test-dirs/occurrences/project-wide/stale.t rename to tests/test-dirs/occurrences/project-wide/stale-index.t index 33ae96cf..1667871b 100644 --- a/tests/test-dirs/occurrences/project-wide/stale.t +++ b/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": {