From bbd0c46cd23013208837368a1afa1964ba2cdc77 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Tue, 15 Oct 2024 14:59:43 +0200 Subject: [PATCH 01/16] Add reproduction from issue #1848 --- tests/test-dirs/locate/issue1848.t | 71 ++++++++++++++++++++++++++++++ 1 file changed, 71 insertions(+) create mode 100644 tests/test-dirs/locate/issue1848.t diff --git a/tests/test-dirs/locate/issue1848.t b/tests/test-dirs/locate/issue1848.t new file mode 100644 index 000000000..da2d95fe9 --- /dev/null +++ b/tests/test-dirs/locate/issue1848.t @@ -0,0 +1,71 @@ +Create a module with an mli file + $ cat > foo.ml << EOF + > type t = Foo + > module Bar = struct + > type t = Bar + > end + > EOF + + $ cat > foo.mli << EOF + > module Bar : sig + > type t + > end + > type t + > EOF + + $ $OCAMLC -c -bin-annot foo.mli + $ $OCAMLC -c -bin-annot foo.ml + +Locate the Bar on line 4 + $ cat > test1.ml << EOF + > module type Foo = sig + > include module type of Foo + > module Bar : sig + > include module type of Bar + > end + > end + > EOF + +The expected location is 2:7 of foo.ml, but it instead goes to 1:9, which is the +constructor Foo + $ $MERLIN single locate -position 4:28 -look-for ml \ + > -filename test1.ml < test1.ml | jq .value + { + "file": "$TESTCASE_ROOT/foo.ml", + "pos": { + "line": 1, + "col": 9 + } + } + +Locate the Bar on line 3 + $ cat > test2.ml << EOF + > include Foo + > module Bar = struct + > include Bar + > end + > EOF + +Correctly returns 2:7 + $ $MERLIN single locate -position 3:12 -look-for ml -filename test2.ml < test2.ml | jq .value + { + "file": "$TESTCASE_ROOT/foo.ml", + "pos": { + "line": 2, + "col": 7 + } + } + +Locate the Foo.Bar on line 1 + $ cat > test3.ml << EOF + > include module type of Foo.Bar + > EOF +Correctly returns 2:7 + $ $MERLIN single locate -position 1:28 -look-for ml -filename test3.ml < test3.ml | jq .value + { + "file": "$TESTCASE_ROOT/foo.ml", + "pos": { + "line": 2, + "col": 7 + } + } From 642b25dca5f0bdf1c85b2dd19227878cd610a7ad Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Tue, 15 Oct 2024 15:02:31 +0200 Subject: [PATCH 02/16] Use new information from uids to jump to the correct file. --- src/analysis/locate.ml | 8 +++++++- tests/test-dirs/locate/issue1848.t | 8 ++++---- 2 files changed, 11 insertions(+), 5 deletions(-) diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml index a91e37b4a..51e779b03 100644 --- a/src/analysis/locate.ml +++ b/src/analysis/locate.ml @@ -510,9 +510,15 @@ let find_loc_of_uid ~config ~local_defs uid comp_unit = end else begin log ~title "Loading the cmt file for unit %S" comp_unit; + let ml_or_mli = + match uid with + | Item { from = Intf; _ } -> `MLI + | _ -> config.ml_or_mli + in + let config = { config with ml_or_mli } in match load_cmt ~config comp_unit with | Ok (_pos_fname, cmt) -> - log ~title "Shapes successfully loaded, looking for %a" Logger.fmt + log ~title "Cmt successfully loaded, looking for %a" Logger.fmt (fun fmt -> Shape.Uid.print fmt uid); begin match Shape.Uid.Tbl.find_opt cmt.cmt_uid_to_decl uid with diff --git a/tests/test-dirs/locate/issue1848.t b/tests/test-dirs/locate/issue1848.t index da2d95fe9..748107055 100644 --- a/tests/test-dirs/locate/issue1848.t +++ b/tests/test-dirs/locate/issue1848.t @@ -26,15 +26,15 @@ Locate the Bar on line 4 > end > EOF -The expected location is 2:7 of foo.ml, but it instead goes to 1:9, which is the -constructor Foo +FIXME Module type Bar in foo.mli is a correct answer, but since there is only +one corresponding implementation we could jump there instead. $ $MERLIN single locate -position 4:28 -look-for ml \ > -filename test1.ml < test1.ml | jq .value { - "file": "$TESTCASE_ROOT/foo.ml", + "file": "$TESTCASE_ROOT/foo.mli", "pos": { "line": 1, - "col": 9 + "col": 7 } } From 5c4605a085f9d0ac3cea2f5f533f89d14c0e8a78 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Tue, 15 Oct 2024 16:44:38 +0200 Subject: [PATCH 03/16] Add jump-to-mli test case --- tests/test-dirs/locate/issue1848.t | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/tests/test-dirs/locate/issue1848.t b/tests/test-dirs/locate/issue1848.t index 748107055..418036305 100644 --- a/tests/test-dirs/locate/issue1848.t +++ b/tests/test-dirs/locate/issue1848.t @@ -26,6 +26,17 @@ Locate the Bar on line 4 > end > EOF + + $ $MERLIN single locate -position 4:28 -look-for mli \ + > -filename test1.ml < test1.ml | jq .value + { + "file": "$TESTCASE_ROOT/foo.mli", + "pos": { + "line": 1, + "col": 7 + } + } + FIXME Module type Bar in foo.mli is a correct answer, but since there is only one corresponding implementation we could jump there instead. $ $MERLIN single locate -position 4:28 -look-for ml \ From bab3ab1a1229fd28ef4bf4afdc360777f0c3c184 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 4 Nov 2024 16:17:19 +0100 Subject: [PATCH 04/16] Use 5.3's uid association tables to find the definition when stuck in the interface. --- src/analysis/locate.ml | 110 ++++++++++++++++++++--------- src/analysis/locate.mli | 8 ++- src/frontend/query_commands.ml | 5 ++ src/ocaml/typing/cmt_format.ml | 2 + src/ocaml/typing/cmt_format.mli | 1 + tests/test-dirs/locate/issue1848.t | 8 +-- 6 files changed, 96 insertions(+), 38 deletions(-) diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml index 51e779b03..5fa2199f6 100644 --- a/src/analysis/locate.ml +++ b/src/analysis/locate.ml @@ -33,7 +33,10 @@ let last_location = ref Location.none let { Logger.log } = Logger.for_section "locate" type config = - { mconfig : Mconfig.t; ml_or_mli : [ `ML | `MLI ]; traverse_aliases : bool } + { mconfig : Mconfig.t; + ml_or_mli : [ `ML | `Smart | `MLI ]; + traverse_aliases : bool + } type result = { uid : Shape.Uid.t; @@ -146,7 +149,7 @@ end = struct end module Preferences : sig - val set : [ `ML | `MLI ] -> unit + val set : [ `ML | `Smart | `MLI ] -> unit val src : string -> File.t val build : string -> File.t @@ -158,7 +161,7 @@ end = struct let set choice = prioritize_impl := match choice with - | `ML -> true + | `ML | `Smart -> true | _ -> false let src file = if !prioritize_impl then File.ml file else File.mli file @@ -481,21 +484,51 @@ let find_source ~config loc path = doesn't know which is the right one: %s" matches) -(** [find_loc_of_uid] uid's location are given by tables stored int he cmt files - for external compilation units or computed by Merlin for the current buffer. - This function lookups a uid's location in the appropriate table. *) +let loc_of_decl ~uid def = + let title = "loc_of_decl" in + match Typedtree_utils.location_of_declaration ~uid def with + | Some loc -> + log ~title "Found location: %a" Logger.fmt (fun fmt -> + Location.print_loc fmt loc.loc); + `Some (uid, loc.loc) + | None -> + log ~title "The declaration has no location."; + `None + +let maybe_get_linked_uid ~config comp_unit decl_uid = + let title = "linked_uids" in + match load_cmt ~config comp_unit with + | Ok (_pos_fname, cmt) -> + log ~title "Cmt successfully loaded, looking for %a" Logger.fmt (fun fmt -> + Shape.Uid.print fmt decl_uid); + begin + let defs = + List.filter_map + ~f:(function + | Cmt_format.Definition_to_declaration, def, decl + when decl = decl_uid -> Some def + | _ -> None) + cmt.cmt_declaration_dependencies + in + match defs with + | [ def ] -> ( + match Shape.Uid.Tbl.find_opt cmt.cmt_uid_to_decl def with + | Some decl -> loc_of_decl ~uid:decl_uid decl + | None -> + log ~title "Uid not found in the cmt's table."; + `None) + | _ -> `None + end + | _ -> + log ~title "Failed to load the cmt file"; + `None + +(** uid's location are given by tables stored int he cmt files for external + compilation units or computed by Merlin for the current buffer. + [find_loc_of_uid] function lookups a uid's location in the appropriate + table. *) let find_loc_of_uid ~config ~local_defs uid comp_unit = let title = "find_loc_of_uid" in - let loc_of_decl ~uid def = - match Typedtree_utils.location_of_declaration ~uid def with - | Some loc -> - log ~title "Found location: %a" Logger.fmt (fun fmt -> - Location.print_loc fmt loc.loc); - `Some (uid, loc.loc) - | None -> - log ~title "The declaration has no location."; - `None - in if Env.get_current_unit_name () = comp_unit then begin log ~title "We look for %a in the current compilation unit." Logger.fmt (fun fmt -> Shape.Uid.print fmt uid); @@ -515,21 +548,32 @@ let find_loc_of_uid ~config ~local_defs uid comp_unit = | Item { from = Intf; _ } -> `MLI | _ -> config.ml_or_mli in - let config = { config with ml_or_mli } in - match load_cmt ~config comp_unit with - | Ok (_pos_fname, cmt) -> - log ~title "Cmt successfully loaded, looking for %a" Logger.fmt - (fun fmt -> Shape.Uid.print fmt uid); - begin - match Shape.Uid.Tbl.find_opt cmt.cmt_uid_to_decl uid with - | Some decl -> loc_of_decl ~uid decl - | None -> - log ~title "Uid not found in the cmt's table."; - `None - end - | _ -> - log ~title "Failed to load the cmt file"; - `None + let result = + (* When looking for a definition but stuck on an interface we load the + corresponding cmt file to try to find a corresponding definition. *) + if ml_or_mli = `MLI && config.ml_or_mli = `Smart then + maybe_get_linked_uid ~config comp_unit uid + else `None + in + match result with + | `Some _ as result -> result + | `None -> begin + let config = { config with ml_or_mli } in + match load_cmt ~config comp_unit with + | Ok (_pos_fname, cmt) -> + log ~title "Cmt successfully loaded, looking for %a" Logger.fmt + (fun fmt -> Shape.Uid.print fmt uid); + begin + match Shape.Uid.Tbl.find_opt cmt.cmt_uid_to_decl uid with + | Some decl -> loc_of_decl ~uid decl + | None -> + log ~title "Uid not found in the cmt's table."; + `None + end + | _ -> + log ~title "Failed to load the cmt file"; + `None + end end let find_loc_of_comp_unit ~config uid comp_unit = @@ -612,7 +656,7 @@ let from_path ~config ~env ~local_defs ~decl path = let uid, approximated = match config.ml_or_mli with | `MLI -> (decl.uid, false) - | `ML -> ( + | `ML | `Smart -> ( let traverse_aliases = config.traverse_aliases in let result = find_definition_uid ~config ~env ~decl path in match uid_of_result ~traverse_aliases result with @@ -711,7 +755,7 @@ let from_string ~config ~env ~local_defs ~pos ?namespaces path = log ~title:"from_string" "looking for the source of '%s' (prioritizing %s files)" path (match config.ml_or_mli with - | `ML -> ".ml" + | `ML | `Smart -> ".ml" | `MLI -> ".mli"); from_longident ~config ~env ~local_defs nss ident in diff --git a/src/analysis/locate.mli b/src/analysis/locate.mli index f685087ca..b037ccd8b 100644 --- a/src/analysis/locate.mli +++ b/src/analysis/locate.mli @@ -29,7 +29,13 @@ val log : 'a Logger.printf type config = - { mconfig : Mconfig.t; ml_or_mli : [ `ML | `MLI ]; traverse_aliases : bool } + { mconfig : Mconfig.t; + ml_or_mli : [ `ML | `Smart | `MLI ]; + (** When [ml_or_mli] is [`Smart], if locate blocks on an interface uid, + it will use the [cmt_declaration_dependencies] to try finding a + unique corresponding definition in the implementation. *) + traverse_aliases : bool + } type result = { uid : Shape.Uid.t; diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml index 6bd337099..c1c12ff46 100644 --- a/src/frontend/query_commands.ml +++ b/src/frontend/query_commands.ml @@ -509,6 +509,11 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function in if path = "" then `Invalid_context else + let ml_or_mli = + match ml_or_mli with + | `ML -> `Smart + | `MLI -> `MLI + in let config = Locate. { mconfig = Mpipeline.final_config pipeline; diff --git a/src/ocaml/typing/cmt_format.ml b/src/ocaml/typing/cmt_format.ml index 4a5d2362e..dda3dcbfb 100644 --- a/src/ocaml/typing/cmt_format.ml +++ b/src/ocaml/typing/cmt_format.ml @@ -454,6 +454,8 @@ let add_saved_type b = saved_types := b :: !saved_types let get_saved_types () = !saved_types let set_saved_types l = saved_types := l +let get_declaration_dependencies () = !uids_deps + let record_declaration_dependency (rk, uid1, uid2) = if not (Uid.equal uid1 uid2) then uids_deps := (rk, uid1, uid2) :: !uids_deps diff --git a/src/ocaml/typing/cmt_format.mli b/src/ocaml/typing/cmt_format.mli index 9b87374a8..f6015ec41 100644 --- a/src/ocaml/typing/cmt_format.mli +++ b/src/ocaml/typing/cmt_format.mli @@ -109,6 +109,7 @@ val add_saved_type : binary_part -> unit val get_saved_types : unit -> binary_part list val set_saved_types : binary_part list -> unit +val get_declaration_dependencies : unit -> (dependency_kind * Uid.t * Uid.t) list val record_declaration_dependency: dependency_kind * Uid.t * Uid.t -> unit (* diff --git a/tests/test-dirs/locate/issue1848.t b/tests/test-dirs/locate/issue1848.t index 418036305..a196bc3f2 100644 --- a/tests/test-dirs/locate/issue1848.t +++ b/tests/test-dirs/locate/issue1848.t @@ -37,14 +37,14 @@ Locate the Bar on line 4 } } -FIXME Module type Bar in foo.mli is a correct answer, but since there is only -one corresponding implementation we could jump there instead. +Module Bar in foo.mli is a correct answer, but since there is only +one corresponding implementation we can jump there instead. $ $MERLIN single locate -position 4:28 -look-for ml \ > -filename test1.ml < test1.ml | jq .value { - "file": "$TESTCASE_ROOT/foo.mli", + "file": "$TESTCASE_ROOT/foo.ml", "pos": { - "line": 1, + "line": 2, "col": 7 } } From 3315b0e2cc030d28a1b8843f00559082fe512489 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 4 Nov 2024 16:22:18 +0100 Subject: [PATCH 05/16] Add changelog entry for #1857 --- CHANGES.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index fbe09a20b..7602212bb 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -3,6 +3,8 @@ unreleased + merlin binary - Support for OCaml 5.3 + - Use new 5.3 features to improve locate behavior in some cases. Merlin no + longer confuses uids from interfaces and implementations. (#1857) + vim plugin - Added support for search-by-type (#1846) This is exposed through the existing `:MerlinSearch` command, that From 99760de1061e9d76384eaa7f06d6fba77a3a7ba5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 6 Nov 2024 15:57:36 +0100 Subject: [PATCH 06/16] Add more tests showing issues with occurrences between interface and implementation files --- .../occurrences/project-wide/mli-vs-ml.t | 90 ++++++++++++++++++- 1 file changed, 86 insertions(+), 4 deletions(-) diff --git a/tests/test-dirs/occurrences/project-wide/mli-vs-ml.t b/tests/test-dirs/occurrences/project-wide/mli-vs-ml.t index 12e0926dc..35b7d3377 100644 --- a/tests/test-dirs/occurrences/project-wide/mli-vs-ml.t +++ b/tests/test-dirs/occurrences/project-wide/mli-vs-ml.t @@ -6,6 +6,7 @@ $ cat >main.ml <<'EOF' > let x = () > type t = unit + > let _ : t = () > EOF $ ocamlc -bin-annot -bin-annot-occurrences -c main.mli main.ml @@ -16,10 +17,13 @@ The indexer should not mixup uids from mli and ml files: $ ocaml-index dump project.ocaml-index 2 uids: {uid: Main.0; locs: "x": File "main.ml", line 1, characters 4-5 - uid: Main.1; locs: "t": File "main.ml", line 2, characters 5-6 }, - 0 approx shapes: {}, and shapes for CUS . + uid: Main.1; locs: + "t": File "main.ml", line 2, characters 5-6; + "t": File "main.ml", line 3, characters 8-9 + }, 0 approx shapes: {}, and shapes for CUS . -Merlin should not mixup uids from mli and ml files: +Merlin should not mixup uids from mli and ml files, and return results in both +the interface and the implementation. $ $MERLIN single occurrences -scope project -identifier-at 2:8 \ > -index-file project.ocaml-index \ > -filename main.mli -index-file project.ocaml-index \ + > -index-file project.ocaml-index \ > -filename main.mli -index-file project.ocaml-index \ + > -filename main.ml -index-file project.ocaml-index \ + > -filename main.ml -index-file project.ocaml-index \ + > -filename main.mli Date: Wed, 6 Nov 2024 15:58:57 +0100 Subject: [PATCH 07/16] pwo: use linked declaration to return results in both interface and implem. --- src/analysis/locate.ml | 110 +++++++++-------- src/analysis/locate.mli | 6 + src/analysis/occurrences.ml | 114 +++++++++--------- src/ocaml-index/lib/index.ml | 11 +- .../occurrences/project-wide/mli-vs-ml.t | 96 ++++++++++++++- 5 files changed, 219 insertions(+), 118 deletions(-) diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml index 5fa2199f6..0253391b6 100644 --- a/src/analysis/locate.ml +++ b/src/analysis/locate.ml @@ -69,6 +69,8 @@ module File : sig val explain_not_found : ?doc_from:string -> string -> t -> [> `File_not_found of string ] + + val is_source : t -> bool end = struct type t = | ML of string @@ -146,6 +148,10 @@ end = struct str_ident in `File_not_found msg + + let is_source = function + | ML _ | MLL _ | MLI _ -> true + | CMT _ | CMTI _ -> false end module Preferences : sig @@ -254,7 +260,15 @@ module Utils = struct List.dedup_adjacent files ~cmp:String.compare let find_file_with_path ~config ?(with_fallback = false) file path = - if File.name file = Misc.unitname Mconfig.(config.query.filename) then + let title = "find_file_with_path" in + let filename = File.name file in + log ~title "Try find %S" filename; + if + File.is_source file + && filename = Misc.unitname Mconfig.(config.query.filename) + then + (* No need to search when looking for the source of the current buffer's + compilation unit *) Some Mconfig.(config.query.filename) else let attempt_search src_suffix_pair = @@ -264,6 +278,7 @@ module Utils = struct else None in let fname = File.with_ext ~src_suffix_pair file in + log ~title "Trying %S" fname; try Some (Misc.find_in_path_normalized ?fallback path fname) with Not_found -> None in @@ -308,10 +323,12 @@ let move_to filename cmt_infos = File_switching.move_to ~digest filename let load_cmt ~config ?(with_fallback = true) comp_unit = + let title = "load_cmt" in Preferences.set config.ml_or_mli; let file = Preferences.build comp_unit in match Utils.find_file ~config:config.mconfig ~with_fallback file with | Some path -> + log ~title "Found %S at path %S" comp_unit path; let cmt_infos = (Cmt_cache.read path).cmt_infos in let source_file = cmt_infos.cmt_sourcefile in let source_file = Option.value ~default:"*pack*" source_file in @@ -490,38 +507,29 @@ let loc_of_decl ~uid def = | Some loc -> log ~title "Found location: %a" Logger.fmt (fun fmt -> Location.print_loc fmt loc.loc); - `Some (uid, loc.loc) + Some (uid, loc.loc) | None -> log ~title "The declaration has no location."; - `None + None -let maybe_get_linked_uid ~config comp_unit decl_uid = +let get_linked_uids ~config ~comp_unit decl_uid = let title = "linked_uids" in + log ~title "Try find cmt file for %s" comp_unit; match load_cmt ~config comp_unit with | Ok (_pos_fname, cmt) -> log ~title "Cmt successfully loaded, looking for %a" Logger.fmt (fun fmt -> Shape.Uid.print fmt decl_uid); - begin - let defs = - List.filter_map - ~f:(function - | Cmt_format.Definition_to_declaration, def, decl - when decl = decl_uid -> Some def - | _ -> None) - cmt.cmt_declaration_dependencies - in - match defs with - | [ def ] -> ( - match Shape.Uid.Tbl.find_opt cmt.cmt_uid_to_decl def with - | Some decl -> loc_of_decl ~uid:decl_uid decl - | None -> - log ~title "Uid not found in the cmt's table."; - `None) - | _ -> `None - end + List.filter_map + ~f:(function + | Cmt_format.Definition_to_declaration, def, decl when decl = decl_uid + -> Some def + | Cmt_format.Definition_to_declaration, def, decl when def = decl_uid -> + Some decl + | _ -> None) + cmt.cmt_declaration_dependencies | _ -> log ~title "Failed to load the cmt file"; - `None + [] (** uid's location are given by tables stored int he cmt files for external compilation units or computed by Merlin for the current buffer. @@ -536,10 +544,10 @@ let find_loc_of_uid ~config ~local_defs uid comp_unit = Shape.Uid.print fmt uid); let tbl = Ast_iterators.build_uid_to_locs_tbl ~local_defs () in match Shape.Uid.Tbl.find_opt tbl uid with - | Some { Location.loc; _ } -> `Some (uid, loc) + | Some { Location.loc; _ } -> Some (uid, loc) | None -> log ~title "Uid not found in the local table."; - `None + None end else begin log ~title "Loading the cmt file for unit %S" comp_unit; @@ -548,32 +556,31 @@ let find_loc_of_uid ~config ~local_defs uid comp_unit = | Item { from = Intf; _ } -> `MLI | _ -> config.ml_or_mli in - let result = + let uid = (* When looking for a definition but stuck on an interface we load the corresponding cmt file to try to find a corresponding definition. *) if ml_or_mli = `MLI && config.ml_or_mli = `Smart then - maybe_get_linked_uid ~config comp_unit uid - else `None + match get_linked_uids ~config ~comp_unit uid with + | [ uid ] -> uid + | _ -> uid + else uid in - match result with - | `Some _ as result -> result - | `None -> begin - let config = { config with ml_or_mli } in - match load_cmt ~config comp_unit with - | Ok (_pos_fname, cmt) -> - log ~title "Cmt successfully loaded, looking for %a" Logger.fmt - (fun fmt -> Shape.Uid.print fmt uid); - begin - match Shape.Uid.Tbl.find_opt cmt.cmt_uid_to_decl uid with - | Some decl -> loc_of_decl ~uid decl - | None -> - log ~title "Uid not found in the cmt's table."; - `None - end - | _ -> - log ~title "Failed to load the cmt file"; - `None - end + let config = { config with ml_or_mli } in + match load_cmt ~config comp_unit with + | Ok (_pos_fname, cmt) -> + log ~title "Cmt successfully loaded, looking for %a" Logger.fmt + (fun fmt -> Shape.Uid.print fmt uid); + begin + match Shape.Uid.Tbl.find_opt cmt.cmt_uid_to_decl uid with + | Some decl -> loc_of_decl ~uid decl + | None -> + log ~title "Uid not found in the cmt's table."; + None + end + | _ -> + log ~title "Failed to load the cmt file"; + None + (* end *) end let find_loc_of_comp_unit ~config uid comp_unit = @@ -672,20 +679,21 @@ let from_path ~config ~env ~local_defs ~decl path = match uid with | Predef s -> `Builtin (uid, s) | Internal -> `Builtin (uid, "") - | Item { comp_unit; _ } -> find_loc_of_uid ~config ~local_defs uid comp_unit + | Item { comp_unit; _ } -> + `Opt (find_loc_of_uid ~config ~local_defs uid comp_unit) | Compilation_unit comp_unit -> find_loc_of_comp_unit ~config uid comp_unit in let loc = match loc with - | `None -> + | `None | `Opt None -> log ~title "Falling back to the declaration's location: %a" Logger.fmt (Fun.flip Location.print_loc decl.loc); `Some (decl.uid, decl.loc) - | other -> other + | `Opt (Some result) -> `Some result + | (`Builtin _ | `Some _) as other -> other in (* Step 3: Location => Source *) match loc with - | `None -> assert false | `Builtin _ as err -> err | `Some (uid, loc) -> ( match find_source ~config:config.mconfig loc (Path.name path) with diff --git a/src/analysis/locate.mli b/src/analysis/locate.mli index b037ccd8b..9e71d3f16 100644 --- a/src/analysis/locate.mli +++ b/src/analysis/locate.mli @@ -48,6 +48,12 @@ type result = val uid_of_result : traverse_aliases:bool -> Shape_reduce.result -> Shape.Uid.t option * bool +(** [get_linked_uids] queries the [cmt_declaration_dependencies] table and + returns udis related to the one passed as argument. TODO right now this + function only returns simple links tagged with [Definition_to_declaration] *) +val get_linked_uids : + config:config -> comp_unit:string -> Shape.Uid.t -> Shape.Uid.t list + val find_source : config:Mconfig.t -> Warnings.loc -> diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml index 42eb8fc5d..b5a49ef9d 100644 --- a/src/analysis/occurrences.ml +++ b/src/analysis/occurrences.ml @@ -116,10 +116,60 @@ let get_buffer_locs result uid = if Shape.Uid.equal uid uid' then Lid_set.add loc acc else acc) (Mtyper.get_index result) Lid_set.empty -let is_in_interface (config : Mconfig.t) (loc : Warnings.loc) = - let extension = Filename.extension loc.loc_start.pos_fname in - List.exists config.merlin.suffixes ~f:(fun (_impl, intf) -> - String.equal extension intf) +let get_external_locs ~(config : Mconfig.t) ~current_buffer_path uid = + let title = "get_external_locs" in + List.filter_map config.merlin.index_files ~f:(fun file -> + log ~title "Lookin for occurrences of %a in index %s" Logger.fmt + (Fun.flip Shape.Uid.print uid) + file; + let external_locs = + try + let external_index = Index_cache.read 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; + 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; _ } -> + (* We ignore 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 + if String.equal file buf then false + 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, + Stat_check.get_outdated_files stats ))) + +let find_linked_uids ~config uid = + let title = "find_linked_uids" in + match uid with + | Shape.Uid.Item { from = _; comp_unit; _ } -> ( + let config = + { Locate.mconfig = config; ml_or_mli = `ML; traverse_aliases = false } + in + match Locate.get_linked_uids ~config ~comp_unit uid with + | [ uid' ] -> + log ~title "Found linked uid: %a" Logger.fmt (fun fmt -> + Shape.Uid.print fmt uid'); + + [ uid' ] + | _ -> []) + | _ -> [] let locs_of ~config ~env ~typer_result ~pos ~scope path = log ~title:"occurrences" "Looking for occurences of %s (pos: %s)" path @@ -139,28 +189,11 @@ let locs_of ~config ~env ~typer_result ~pos ~scope path = let browse = Mbrowse.of_typedtree local_defs in let env, node = Mbrowse.leaf_node (Mbrowse.enclosing pos [ browse ]) in let node_uid_loc = uid_and_loc_of_node env node in - let scope = - match node_uid_loc with - | Some (_, l) when is_in_interface config l -> - (* There is no way to distinguish uids from interfaces from uids of - implementations. We fallback on buffer occurrences in that case. - TODO: we should be able to improve on that situation when we will be - able to distinguish between impl/intf uids and know which declaration - are actually linked. *) - `Buffer - | _ -> scope - in (node_uid_loc, scope) | `Found { uid; location; approximated = false; _ } | `File_not_found { uid; location; approximated = false; _ } -> log ~title:"locs_of" "Found definition uid using locate: %a " Logger.fmt (fun fmt -> Shape.Uid.print fmt uid); - (* There is no way to distinguish uids from interfaces from uids of - implementations. We fallback on buffer occurrences in that case. - TODO: we should be able to improve on that situation when we will be - able to distinguish between impl/intf uids and know which declaration - are actually linked. *) - let scope = if is_in_interface config location then `Buffer else scope in (Some (uid, location), scope) | `Found { decl_uid; location; approximated = true; _ } | `File_not_found { decl_uid; location; approximated = true; _ } -> @@ -188,41 +221,10 @@ 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 -> - 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 (index, locs) -> - let stats = Stat_check.create ~cache_size:128 index in - ( Lid_set.filter - (fun { loc; _ } -> - (* We ignore 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 - if String.equal file buf then false - 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:"locs_of" "File %s might be out-of-sync." - file; - check - end) - locs, - Stat_check.get_outdated_files stats ))) + let additional_uids = find_linked_uids ~config def_uid in + List.concat_map + (def_uid :: additional_uids) + ~f:(get_external_locs ~config ~current_buffer_path) in let external_locs, out_of_sync_files = List.fold_left diff --git a/src/ocaml-index/lib/index.ml b/src/ocaml-index/lib/index.ml index cbdbd6e62..554880cc4 100644 --- a/src/ocaml-index/lib/index.ml +++ b/src/ocaml-index/lib/index.ml @@ -89,10 +89,8 @@ let index_of_cmt ~root ~rewrite_root ~build_path ~do_not_use_cmt_loadpath init_load_path_once ~do_not_use_cmt_loadpath ~dirs:build_path cmt_loadpath; let module Reduce = Shape_reduce.Make (Reduce_conf) in let defs = - if Option.is_none cmt_impl_shape then Shape.Uid.Map.empty - else - gather_locs_from_fragments ~root ~rewrite_root Shape.Uid.Map.empty - cmt_uid_to_decl + gather_locs_from_fragments ~root ~rewrite_root Shape.Uid.Map.empty + cmt_uid_to_decl in (* The list [cmt_ident_occurrences] associate each ident usage location in the module with its (partially) reduced shape. We finish the reduction and @@ -104,11 +102,6 @@ let index_of_cmt ~root ~rewrite_root ~build_path ~do_not_use_cmt_loadpath let resolved = match item with | Unresolved shape -> Reduce.reduce_for_uid cmt_initial_env shape - | Resolved _ when Option.is_none cmt_impl_shape -> - (* Right now, without additional information we cannot take the - risk to mix uids from interfaces with the ones from - implementations. We simply ignore items defined in an interface. *) - Internal_error_missing_uid | result -> result in match Locate.uid_of_result ~traverse_aliases:false resolved with diff --git a/tests/test-dirs/occurrences/project-wide/mli-vs-ml.t b/tests/test-dirs/occurrences/project-wide/mli-vs-ml.t index 35b7d3377..5fa03901f 100644 --- a/tests/test-dirs/occurrences/project-wide/mli-vs-ml.t +++ b/tests/test-dirs/occurrences/project-wide/mli-vs-ml.t @@ -15,8 +15,12 @@ The indexer should not mixup uids from mli and ml files: $ ocaml-index dump project.ocaml-index - 2 uids: - {uid: Main.0; locs: "x": File "main.ml", line 1, characters 4-5 + 4 uids: + {uid: [intf]Main.0; locs: + "t": File "main.mli", line 1, characters 5-6; + "t": File "main.mli", line 2, characters 8-9 + uid: Main.0; locs: "x": File "main.ml", line 1, characters 4-5 + uid: [intf]Main.1; locs: "x": File "main.mli", line 2, characters 4-5 uid: Main.1; locs: "t": File "main.ml", line 2, characters 5-6; "t": File "main.ml", line 3, characters 8-9 @@ -41,6 +45,28 @@ the interface and the implementation. "col": 6 } }, + { + "file": "$TESTCASE_ROOT/main.ml", + "start": { + "line": 2, + "col": 5 + }, + "end": { + "line": 2, + "col": 6 + } + }, + { + "file": "$TESTCASE_ROOT/main.ml", + "start": { + "line": 3, + "col": 8 + }, + "end": { + "line": 3, + "col": 9 + } + }, { "file": "$TESTCASE_ROOT/main.mli", "start": { @@ -74,6 +100,28 @@ Same when the cursor is at the origin: "col": 6 } }, + { + "file": "$TESTCASE_ROOT/main.ml", + "start": { + "line": 2, + "col": 5 + }, + "end": { + "line": 2, + "col": 6 + } + }, + { + "file": "$TESTCASE_ROOT/main.ml", + "start": { + "line": 3, + "col": 8 + }, + "end": { + "line": 3, + "col": 9 + } + }, { "file": "$TESTCASE_ROOT/main.mli", "start": { @@ -117,6 +165,28 @@ It also works when querying for t from the implementation: "line": 3, "col": 9 } + }, + { + "file": "$TESTCASE_ROOT/main.mli", + "start": { + "line": 1, + "col": 5 + }, + "end": { + "line": 1, + "col": 6 + } + }, + { + "file": "$TESTCASE_ROOT/main.mli", + "start": { + "line": 2, + "col": 8 + }, + "end": { + "line": 2, + "col": 9 + } } ], "notifications": [] @@ -140,6 +210,17 @@ It also works when querying for x from the implementation: "line": 1, "col": 5 } + }, + { + "file": "$TESTCASE_ROOT/main.mli", + "start": { + "line": 2, + "col": 4 + }, + "end": { + "line": 2, + "col": 5 + } } ], "notifications": [] @@ -162,6 +243,17 @@ It also works when querying for x from the interface: "line": 2, "col": 5 } + }, + { + "file": "$TESTCASE_ROOT/main.ml", + "start": { + "line": 1, + "col": 4 + }, + "end": { + "line": 1, + "col": 5 + } } ], "notifications": [] From 3790a44912783c14a6e888ce63cb868ab374bbf3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 13 Nov 2024 16:24:19 +0100 Subject: [PATCH 08/16] refactor loc_of_decl --- src/analysis/locate.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml index 0253391b6..ab26e663b 100644 --- a/src/analysis/locate.ml +++ b/src/analysis/locate.ml @@ -507,7 +507,7 @@ let loc_of_decl ~uid def = | Some loc -> log ~title "Found location: %a" Logger.fmt (fun fmt -> Location.print_loc fmt loc.loc); - Some (uid, loc.loc) + Some loc | None -> log ~title "The declaration has no location."; None @@ -572,7 +572,9 @@ let find_loc_of_uid ~config ~local_defs uid comp_unit = (fun fmt -> Shape.Uid.print fmt uid); begin match Shape.Uid.Tbl.find_opt cmt.cmt_uid_to_decl uid with - | Some decl -> loc_of_decl ~uid decl + | Some decl -> + loc_of_decl ~uid decl + |> Option.map ~f:(fun { Location.loc; _ } -> (uid, loc)) | None -> log ~title "Uid not found in the cmt's table."; None From 9f592e9a3da10da820fc6ca462ebca4143e897f2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 13 Nov 2024 16:24:35 +0100 Subject: [PATCH 09/16] Add test showing wrong result with outdated cmts. --- .../occurrences/project-wide/mli-vs-ml.t | 52 +++++++++++++++++++ 1 file changed, 52 insertions(+) diff --git a/tests/test-dirs/occurrences/project-wide/mli-vs-ml.t b/tests/test-dirs/occurrences/project-wide/mli-vs-ml.t index 5fa03901f..19ce2cfca 100644 --- a/tests/test-dirs/occurrences/project-wide/mli-vs-ml.t +++ b/tests/test-dirs/occurrences/project-wide/mli-vs-ml.t @@ -258,3 +258,55 @@ It also works when querying for x from the interface: ], "notifications": [] } + +If we switch lines without rebuilding... + $ cat >main.ml <<'EOF' + > type t = unit + > let x = () + > let _ : t = () + > EOF + +FIXME: Merlin would get confused and return an occurrence of `x` in the +interface when asked from occurrences of `t` in the implementation. + $ $MERLIN single occurrences -scope project -identifier-at 1:5 \ + > -index-file project.ocaml-index \ + > -filename main.ml Date: Wed, 13 Nov 2024 16:49:05 +0100 Subject: [PATCH 10/16] refactor --- src/analysis/locate.ml | 58 ++++++++++++++++++++++-------------------- 1 file changed, 30 insertions(+), 28 deletions(-) diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml index ab26e663b..fe069844d 100644 --- a/src/analysis/locate.ml +++ b/src/analysis/locate.ml @@ -512,25 +512,6 @@ let loc_of_decl ~uid def = log ~title "The declaration has no location."; None -let get_linked_uids ~config ~comp_unit decl_uid = - let title = "linked_uids" in - log ~title "Try find cmt file for %s" comp_unit; - match load_cmt ~config comp_unit with - | Ok (_pos_fname, cmt) -> - log ~title "Cmt successfully loaded, looking for %a" Logger.fmt (fun fmt -> - Shape.Uid.print fmt decl_uid); - List.filter_map - ~f:(function - | Cmt_format.Definition_to_declaration, def, decl when decl = decl_uid - -> Some def - | Cmt_format.Definition_to_declaration, def, decl when def = decl_uid -> - Some decl - | _ -> None) - cmt.cmt_declaration_dependencies - | _ -> - log ~title "Failed to load the cmt file"; - [] - (** uid's location are given by tables stored int he cmt files for external compilation units or computed by Merlin for the current buffer. [find_loc_of_uid] function lookups a uid's location in the appropriate @@ -556,15 +537,6 @@ let find_loc_of_uid ~config ~local_defs uid comp_unit = | Item { from = Intf; _ } -> `MLI | _ -> config.ml_or_mli in - let uid = - (* When looking for a definition but stuck on an interface we load the - corresponding cmt file to try to find a corresponding definition. *) - if ml_or_mli = `MLI && config.ml_or_mli = `Smart then - match get_linked_uids ~config ~comp_unit uid with - | [ uid ] -> uid - | _ -> uid - else uid - in let config = { config with ml_or_mli } in match load_cmt ~config comp_unit with | Ok (_pos_fname, cmt) -> @@ -597,6 +569,25 @@ let find_loc_of_comp_unit ~config uid comp_unit = log ~title "Failed to load the CU's cmt"; `None +let get_linked_uids ~config ~comp_unit decl_uid = + let title = "linked_uids" in + log ~title "Try find cmt file for %s" comp_unit; + match load_cmt ~config comp_unit with + | Ok (_pos_fname, cmt) -> + log ~title "Cmt successfully loaded, looking for %a" Logger.fmt (fun fmt -> + Shape.Uid.print fmt decl_uid); + List.filter_map + ~f:(function + | Cmt_format.Definition_to_declaration, def, decl when decl = decl_uid + -> Some def + | Cmt_format.Definition_to_declaration, def, decl when def = decl_uid -> + Some decl + | _ -> None) + cmt.cmt_declaration_dependencies + | _ -> + log ~title "Failed to load the cmt file"; + [] + let find_definition_uid ~config ~env ~(decl : Env_lookup.item) path = let namespace = decl.namespace in let module Reduce = Shape_reduce.Make (struct @@ -676,6 +667,17 @@ let from_path ~config ~env ~local_defs ~decl path = (Fun.flip Shape.Uid.print decl.uid); (decl.uid, true)) in + (* Step 1': Try refine Uid *) + let uid = + (* When looking for a definition but stuck on an interface we load the + corresponding cmt file to try to find a corresponding definition. *) + match (uid, config.ml_or_mli) with + | Item { from = Intf; comp_unit; _ }, `Smart -> ( + match get_linked_uids ~config ~comp_unit uid with + | [ uid ] -> uid + | _ -> uid) + | _ -> uid + in (* Step 2: Uid => Location *) let loc = match uid with From 9ebafe31bf09099beb0660492ae704cb036856ad Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 13 Nov 2024 17:25:03 +0100 Subject: [PATCH 11/16] Check ident names when relying on cmt files for locate. That way if the cmt files are outdated we don't return non-sensical results. --- src/analysis/locate.ml | 60 ++++++++++++------- .../locate/context-detection/cd-test.t/run.t | 2 +- 2 files changed, 40 insertions(+), 22 deletions(-) diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml index fe069844d..3d8f80cfd 100644 --- a/src/analysis/locate.ml +++ b/src/analysis/locate.ml @@ -357,8 +357,8 @@ let scrape_alias ~env ~fallback_uid ~namespace path = when namespace = Shape.Sig_component_kind.Module_type -> (* This case is necessary to traverse module type aliases *) non_alias_declaration_uid ~fallback_uid alias_path - | _, md_uid -> md_uid - | exception Not_found -> fallback_uid + | _, md_uid -> (path, md_uid) + | exception Not_found -> (path, fallback_uid) in non_alias_declaration_uid ~fallback_uid path @@ -516,7 +516,7 @@ let loc_of_decl ~uid def = compilation units or computed by Merlin for the current buffer. [find_loc_of_uid] function lookups a uid's location in the appropriate table. *) -let find_loc_of_uid ~config ~local_defs uid comp_unit = +let find_loc_of_item ~config ~local_defs uid comp_unit = let title = "find_loc_of_uid" in if Env.get_current_unit_name () = comp_unit then begin log ~title "We look for %a in the current compilation unit." Logger.fmt @@ -525,7 +525,7 @@ let find_loc_of_uid ~config ~local_defs uid comp_unit = Shape.Uid.print fmt uid); let tbl = Ast_iterators.build_uid_to_locs_tbl ~local_defs () in match Shape.Uid.Tbl.find_opt tbl uid with - | Some { Location.loc; _ } -> Some (uid, loc) + | Some loc -> Some loc | None -> log ~title "Uid not found in the local table."; None @@ -544,9 +544,7 @@ let find_loc_of_uid ~config ~local_defs uid comp_unit = (fun fmt -> Shape.Uid.print fmt uid); begin match Shape.Uid.Tbl.find_opt cmt.cmt_uid_to_decl uid with - | Some decl -> - loc_of_decl ~uid decl - |> Option.map ~f:(fun { Location.loc; _ } -> (uid, loc)) + | Some decl -> loc_of_decl ~uid decl | None -> log ~title "Uid not found in the cmt's table."; None @@ -569,6 +567,24 @@ let find_loc_of_comp_unit ~config uid comp_unit = log ~title "Failed to load the CU's cmt"; `None +let find_loc_of_uid ~config ~local_defs ~ident ?fallback (uid : Shape.Uid.t) = + let find_loc_of_item ~comp_unit = + match (find_loc_of_item ~config ~local_defs uid comp_unit, fallback) with + | Some { loc; txt }, _ when String.equal txt ident -> + (* Checking the ident prevent returning nonsensical results when some uid + were swaped but the cmt files were not rebuilt. *) + Some (uid, loc) + | (Some _ | None), Some fallback -> + find_loc_of_item ~config ~local_defs fallback comp_unit + |> Option.map ~f:(fun { Location.loc; _ } -> (fallback, loc)) + | _ -> None + in + match uid with + | Predef s -> `Builtin (uid, s) + | Internal -> `Builtin (uid, "") + | Item { comp_unit; _ } -> `Opt (find_loc_of_item ~comp_unit) + | Compilation_unit comp_unit -> find_loc_of_comp_unit ~config uid comp_unit + let get_linked_uids ~config ~comp_unit decl_uid = let title = "linked_uids" in log ~title "Try find cmt file for %s" comp_unit; @@ -639,20 +655,23 @@ let rec uid_of_result ~traverse_aliases = function let from_path ~config ~env ~local_defs ~decl path = let title = "from_path" in let unalias (decl : Env_lookup.item) = - if not config.traverse_aliases then decl.uid + if not config.traverse_aliases then (path, decl.uid) else let namespace = decl.namespace in - let uid = scrape_alias ~fallback_uid:decl.uid ~env ~namespace path in + let path, uid = + scrape_alias ~fallback_uid:decl.uid ~env ~namespace path + in if uid <> decl.uid then log ~title:"uid_of_path" "Unaliased declaration uid: %a -> %a" Logger.fmt (Fun.flip Shape.Uid.print decl.uid) Logger.fmt (Fun.flip Shape.Uid.print uid); - uid + (path, uid) in (* Step 1: Path => Uid *) - let decl : Env_lookup.item = { decl with uid = unalias decl } in + let path, uid = unalias decl in + let decl : Env_lookup.item = { decl with uid } in let uid, approximated = match config.ml_or_mli with | `MLI -> (decl.uid, false) @@ -668,24 +687,23 @@ let from_path ~config ~env ~local_defs ~decl path = (decl.uid, true)) in (* Step 1': Try refine Uid *) - let uid = + let impl_uid = (* When looking for a definition but stuck on an interface we load the corresponding cmt file to try to find a corresponding definition. *) match (uid, config.ml_or_mli) with | Item { from = Intf; comp_unit; _ }, `Smart -> ( match get_linked_uids ~config ~comp_unit uid with - | [ uid ] -> uid - | _ -> uid) - | _ -> uid + | [ uid ] -> Some uid + | _ -> None) + | _ -> None in (* Step 2: Uid => Location *) let loc = - match uid with - | Predef s -> `Builtin (uid, s) - | Internal -> `Builtin (uid, "") - | Item { comp_unit; _ } -> - `Opt (find_loc_of_uid ~config ~local_defs uid comp_unit) - | Compilation_unit comp_unit -> find_loc_of_comp_unit ~config uid comp_unit + let ident = Path.last path in + match impl_uid with + | Some impl_uid -> + find_loc_of_uid ~config ~local_defs ~ident ~fallback:uid impl_uid + | None -> find_loc_of_uid ~config ~local_defs ~ident uid in let loc = match loc with diff --git a/tests/test-dirs/locate/context-detection/cd-test.t/run.t b/tests/test-dirs/locate/context-detection/cd-test.t/run.t index 3e0131483..867e37d01 100644 --- a/tests/test-dirs/locate/context-detection/cd-test.t/run.t +++ b/tests/test-dirs/locate/context-detection/cd-test.t/run.t @@ -32,7 +32,7 @@ Trying them all: "value": { "file": "$TESTCASE_ROOT/test.ml", "pos": { - "line": 7, + "line": 3, "col": 12 } }, From eb89212521789b129f458e2c3ea0c5226af17dbc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 14 Nov 2024 15:22:43 +0100 Subject: [PATCH 12/16] Refactor: remove unnecessary wrapper --- src/analysis/locate.ml | 13 +------------ 1 file changed, 1 insertion(+), 12 deletions(-) diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml index 3d8f80cfd..85e076943 100644 --- a/src/analysis/locate.ml +++ b/src/analysis/locate.ml @@ -501,17 +501,6 @@ let find_source ~config loc path = doesn't know which is the right one: %s" matches) -let loc_of_decl ~uid def = - let title = "loc_of_decl" in - match Typedtree_utils.location_of_declaration ~uid def with - | Some loc -> - log ~title "Found location: %a" Logger.fmt (fun fmt -> - Location.print_loc fmt loc.loc); - Some loc - | None -> - log ~title "The declaration has no location."; - None - (** uid's location are given by tables stored int he cmt files for external compilation units or computed by Merlin for the current buffer. [find_loc_of_uid] function lookups a uid's location in the appropriate @@ -544,7 +533,7 @@ let find_loc_of_item ~config ~local_defs uid comp_unit = (fun fmt -> Shape.Uid.print fmt uid); begin match Shape.Uid.Tbl.find_opt cmt.cmt_uid_to_decl uid with - | Some decl -> loc_of_decl ~uid decl + | Some decl -> Typedtree_utils.location_of_declaration ~uid decl | None -> log ~title "Uid not found in the cmt's table."; None From d351390740307c4f50d512fcb83720300d35355d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 14 Nov 2024 15:34:46 +0100 Subject: [PATCH 13/16] Refactor: extract lookup_decl function --- src/analysis/locate.ml | 46 ++++++++++++++++++++--------------------- src/analysis/locate.mli | 4 ++++ 2 files changed, 26 insertions(+), 24 deletions(-) diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml index 85e076943..8c6294e3e 100644 --- a/src/analysis/locate.ml +++ b/src/analysis/locate.ml @@ -501,6 +501,25 @@ let find_source ~config loc path = doesn't know which is the right one: %s" matches) +let lookup_uid_decl ~config:mconfig uid = + let title = "lookup_uid_decl" in + let item = + match uid with + | Shape.Uid.Internal | Predef _ | Compilation_unit _ -> None + | Item { from = Intf; comp_unit; _ } -> Some (`MLI, comp_unit) + | Item { from = _; comp_unit; _ } -> Some (`ML, comp_unit) + in + Option.bind item ~f:(fun (ml_or_mli, comp_unit) -> + let config = { mconfig; ml_or_mli; traverse_aliases = false } in + match load_cmt ~config comp_unit with + | Ok (_pos_fname, cmt) -> + log ~title "Cmt successfully loaded, looking for %a" Logger.fmt + (fun fmt -> Shape.Uid.print fmt uid); + Shape.Uid.Tbl.find_opt cmt.cmt_uid_to_decl uid + | _ -> + log ~title "Failed to load the cmt file"; + None) + (** uid's location are given by tables stored int he cmt files for external compilation units or computed by Merlin for the current buffer. [find_loc_of_uid] function lookups a uid's location in the appropriate @@ -519,30 +538,9 @@ let find_loc_of_item ~config ~local_defs uid comp_unit = log ~title "Uid not found in the local table."; None end - else begin - log ~title "Loading the cmt file for unit %S" comp_unit; - let ml_or_mli = - match uid with - | Item { from = Intf; _ } -> `MLI - | _ -> config.ml_or_mli - in - let config = { config with ml_or_mli } in - match load_cmt ~config comp_unit with - | Ok (_pos_fname, cmt) -> - log ~title "Cmt successfully loaded, looking for %a" Logger.fmt - (fun fmt -> Shape.Uid.print fmt uid); - begin - match Shape.Uid.Tbl.find_opt cmt.cmt_uid_to_decl uid with - | Some decl -> Typedtree_utils.location_of_declaration ~uid decl - | None -> - log ~title "Uid not found in the cmt's table."; - None - end - | _ -> - log ~title "Failed to load the cmt file"; - None - (* end *) - end + else + lookup_uid_decl ~config:config.mconfig uid + |> Option.bind ~f:(Typedtree_utils.location_of_declaration ~uid) let find_loc_of_comp_unit ~config uid comp_unit = let title = "find_loc_of_comp_unit" in diff --git a/src/analysis/locate.mli b/src/analysis/locate.mli index 9e71d3f16..d2aa5c9cc 100644 --- a/src/analysis/locate.mli +++ b/src/analysis/locate.mli @@ -48,6 +48,10 @@ type result = val uid_of_result : traverse_aliases:bool -> Shape_reduce.result -> Shape.Uid.t option * bool +(** Lookup the delcaration of the given Uid in the appropriate cmt file *) +val lookup_uid_decl : + config:Mconfig.t -> Shape.Uid.t -> Typedtree.item_declaration option + (** [get_linked_uids] queries the [cmt_declaration_dependencies] table and returns udis related to the one passed as argument. TODO right now this function only returns simple links tagged with [Definition_to_declaration] *) From 38d0601c95a25a4913760fe7282cbc4335065453 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 14 Nov 2024 16:53:57 +0100 Subject: [PATCH 14/16] Use the same identifier-checking heuristic in occurrences. --- src/analysis/occurrences.ml | 17 +++++++++++++---- .../occurrences/project-wide/mli-vs-ml.t | 18 +++++------------- 2 files changed, 18 insertions(+), 17 deletions(-) diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml index b5a49ef9d..cd9acd810 100644 --- a/src/analysis/occurrences.ml +++ b/src/analysis/occurrences.ml @@ -155,7 +155,7 @@ let get_external_locs ~(config : Mconfig.t) ~current_buffer_path uid = locs, Stat_check.get_outdated_files stats ))) -let find_linked_uids ~config uid = +let find_linked_uids ~config ~name uid = let title = "find_linked_uids" in match uid with | Shape.Uid.Item { from = _; comp_unit; _ } -> ( @@ -166,8 +166,14 @@ let find_linked_uids ~config uid = | [ uid' ] -> log ~title "Found linked uid: %a" Logger.fmt (fun fmt -> Shape.Uid.print fmt uid'); - - [ uid' ] + let name_check = + Locate.lookup_uid_decl ~config:config.mconfig uid' + |> Option.bind ~f:(Typedtree_utils.location_of_declaration ~uid:uid') + |> Option.value_map + ~f:(fun { Location.txt; _ } -> String.equal name txt) + ~default:false + in + if name_check then [ uid' ] else [] | _ -> []) | _ -> [] @@ -221,7 +227,10 @@ let locs_of ~config ~env ~typer_result ~pos ~scope path = let external_locs = if scope = `Buffer then [] else - let additional_uids = find_linked_uids ~config def_uid in + let name = + String.split_on_char ~sep:'.' path |> List.last |> Option.get + in + let additional_uids = find_linked_uids ~config ~name def_uid in List.concat_map (def_uid :: additional_uids) ~f:(get_external_locs ~config ~current_buffer_path) diff --git a/tests/test-dirs/occurrences/project-wide/mli-vs-ml.t b/tests/test-dirs/occurrences/project-wide/mli-vs-ml.t index 19ce2cfca..23b2a6a91 100644 --- a/tests/test-dirs/occurrences/project-wide/mli-vs-ml.t +++ b/tests/test-dirs/occurrences/project-wide/mli-vs-ml.t @@ -266,8 +266,11 @@ If we switch lines without rebuilding... > let _ : t = () > EOF -FIXME: Merlin would get confused and return an occurrence of `x` in the -interface when asked from occurrences of `t` in the implementation. +Merlin should not get confused and return an occurrence of `x` in the interface +when asked from occurrences of `t` in the implementation. + +FIXME: this is based on a heuristic that compares the identifiers it could still +get confused if both identifers are the same. $ $MERLIN single occurrences -scope project -identifier-at 1:5 \ > -index-file project.ocaml-index \ > -filename main.ml Date: Fri, 15 Nov 2024 14:07:44 +0100 Subject: [PATCH 15/16] Promote updated test --- src/ocaml-index/tests/tests-dirs/interfaces.t | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/ocaml-index/tests/tests-dirs/interfaces.t b/src/ocaml-index/tests/tests-dirs/interfaces.t index 2232ed41b..7514c55cf 100644 --- a/src/ocaml-index/tests/tests-dirs/interfaces.t +++ b/src/ocaml-index/tests/tests-dirs/interfaces.t @@ -17,7 +17,8 @@ $ ocaml-index aggregate main.cmti -o main.index $ ocaml-index dump main.index - 1 uids: - {uid: Stdlib__Float.81; locs: + 2 uids: + {uid: [intf]Main.0; locs: "t": File "main.mli", line 1, characters 5-6 + uid: Stdlib__Float.81; locs: "Float.t": File "main.mli", line 1, characters 9-16 }, 0 approx shapes: {}, and shapes for CUS . From f95f1789fb097894f5aa2912ac2264ab58605e7a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 20 Dec 2024 16:40:14 +0100 Subject: [PATCH 16/16] Disable test on windows --- tests/test-dirs/locate/dune | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/test-dirs/locate/dune b/tests/test-dirs/locate/dune index 7e226fede..2f1e864e3 100755 --- a/tests/test-dirs/locate/dune +++ b/tests/test-dirs/locate/dune @@ -1,6 +1,6 @@ (cram (applies_to looping-substitution mutually-recursive partial-cmt includes - issue802 issue845 issue1199 issue1524 sig-substs l-413-features + issue802 issue845 issue1848 issue1199 issue1524 sig-substs l-413-features module-aliases locate-constrs without-implem without-sig module-decl-aliases in-implicit-trans-dep) (enabled_if