From fd93979dfe43ffdb86db49f941928794654c2e4d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 2 Feb 2023 14:46:52 +0100 Subject: [PATCH 1/7] tests: Add a test illustrating the issue --- tests/test-dirs/locate/module-decl-aliases.t | 61 ++++++++++++++++++++ 1 file changed, 61 insertions(+) create mode 100644 tests/test-dirs/locate/module-decl-aliases.t diff --git a/tests/test-dirs/locate/module-decl-aliases.t b/tests/test-dirs/locate/module-decl-aliases.t new file mode 100644 index 0000000000..109853cf2f --- /dev/null +++ b/tests/test-dirs/locate/module-decl-aliases.t @@ -0,0 +1,61 @@ + $ cat >main.ml < module Bar : sig + > module Foo : sig + > val v : int + > end + > end = struct + > module Foo = struct + > let v = 42 + > end + > end + > module Foo = Bar.Foo + > let _ = Foo.v + > EOF + + $ cat>other.ml < module Foo = Main.Bar.Foo + > let _ = Foo.v + > EOF + + $ $OCAMLC -c -bin-annot main.ml other.ml + + $ $MERLIN single locate -look-for ml -position 11:10 \ + > -filename ./main.ml < ./main.ml | jq '.value' + { + "file": "$TESTCASE_ROOT/main.ml", + "pos": { + "line": 6, + "col": 2 + } + } + +FIXME: it would be more useful to traverse the alias and jump to 2:2 + $ $MERLIN single locate -look-for mli -position 11:10 \ + > -filename ./main.ml < ./main.ml | jq '.value' + { + "file": "$TESTCASE_ROOT/main.ml", + "pos": { + "line": 10, + "col": 0 + } + } + $ $MERLIN single locate -look-for ml -position 2:10 \ + > -filename ./other.ml < ./other.ml | jq '.value' + { + "file": "$TESTCASE_ROOT/main.ml", + "pos": { + "line": 6, + "col": 2 + } + } + +FIXME: it would be more useful to traverse the alias and jump to main 2:2 + $ $MERLIN single locate -look-for mli -position 2:10 \ + > -filename ./other.ml < ./other.ml | jq '.value' + { + "file": "$TESTCASE_ROOT/other.ml", + "pos": { + "line": 1, + "col": 0 + } + } From b81f066ac1fbd099ff817ccd46c1431532df34f8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 2 Feb 2023 14:48:00 +0100 Subject: [PATCH 2/7] Use the env (and cmis) to traverse module aliases Co-authored-by: Leo White --- src/analysis/locate.ml | 12 +++++++++++- tests/test-dirs/locate/module-aliases.t/run.t | 10 ++++------ tests/test-dirs/locate/module-decl-aliases.t | 12 +++++------- 3 files changed, 20 insertions(+), 14 deletions(-) diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml index 62daa561c1..ea925b962c 100644 --- a/src/analysis/locate.ml +++ b/src/analysis/locate.ml @@ -310,6 +310,16 @@ let load_cmt ~config comp_unit ml_or_mli = Ok (source_file, cmt_infos) | None -> Error () +let find_declaration_uid ~env ~decl_uid path = + let rec non_alias_declaration_uid path = + let md = Env.find_module path env in + match md.md_type with + | Mty_ident _ | Mty_signature _ | Mty_functor _ | Mty_for_hole -> md.md_uid + | Mty_alias path -> non_alias_declaration_uid path + in + try non_alias_declaration_uid path +with Not_found -> decl_uid + let uid_of_path ~config ~env ~ml_or_mli ~decl_uid path ns = let module Shape_reduce = Shape.Make_reduce (struct @@ -333,7 +343,7 @@ let uid_of_path ~config ~env ~ml_or_mli ~decl_uid path ns = end) in match ml_or_mli with - | `MLI -> Some decl_uid + | `MLI -> Some (find_declaration_uid ~decl_uid ~env path) | `ML -> let shape = Env.shape_of_path ~namespace:ns env path in log ~title:"shape_of_path" "initial: %a" diff --git a/tests/test-dirs/locate/module-aliases.t/run.t b/tests/test-dirs/locate/module-aliases.t/run.t index b505e42654..5eac85a908 100644 --- a/tests/test-dirs/locate/module-aliases.t/run.t +++ b/tests/test-dirs/locate/module-aliases.t/run.t @@ -65,12 +65,11 @@ Jump to an aliased module `A|.f`: } Jump to the declaration of an aliased module `A|.f`. -With the new shape implementation it is expected that we jump to the -declaration of the alias and not to the aliased module itself. +The alias is traversed. $ $MERLIN single locate -look-for mli -position 5:2 \ > -filename ./main.ml < ./main.ml | jq '.value' { - "file": "$TESTCASE_ROOT/main.ml", + "file": "$TESTCASE_ROOT/anothermod.mli", "pos": { "line": 1, "col": 0 @@ -168,12 +167,11 @@ Jump to an aliased module `A|.f`: } Jump to the declaration of an aliased module `A|.f`: -With the new shape implementation it is expected that we jump to the -declaration of the alias and not to the aliased module itself. +The alias is traversed. $ $MERLIN single locate -look-for mli -position 5:2 \ > -filename ./main.ml < ./main.ml | jq '.value' { - "file": "$TESTCASE_ROOT/main.ml", + "file": "$TESTCASE_ROOT/anothermod.mli", "pos": { "line": 1, "col": 0 diff --git a/tests/test-dirs/locate/module-decl-aliases.t b/tests/test-dirs/locate/module-decl-aliases.t index 109853cf2f..0d297716e1 100644 --- a/tests/test-dirs/locate/module-decl-aliases.t +++ b/tests/test-dirs/locate/module-decl-aliases.t @@ -29,14 +29,13 @@ } } -FIXME: it would be more useful to traverse the alias and jump to 2:2 $ $MERLIN single locate -look-for mli -position 11:10 \ > -filename ./main.ml < ./main.ml | jq '.value' { "file": "$TESTCASE_ROOT/main.ml", "pos": { - "line": 10, - "col": 0 + "line": 2, + "col": 2 } } $ $MERLIN single locate -look-for ml -position 2:10 \ @@ -49,13 +48,12 @@ FIXME: it would be more useful to traverse the alias and jump to 2:2 } } -FIXME: it would be more useful to traverse the alias and jump to main 2:2 $ $MERLIN single locate -look-for mli -position 2:10 \ > -filename ./other.ml < ./other.ml | jq '.value' { - "file": "$TESTCASE_ROOT/other.ml", + "file": "$TESTCASE_ROOT/main.ml", "pos": { - "line": 1, - "col": 0 + "line": 2, + "col": 2 } } From 8a207ed39c27044b869e6dffe35d06640fe30b74 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 2 Feb 2023 14:45:09 +0100 Subject: [PATCH 3/7] Cleanup useless aliasing code --- src/analysis/locate.ml | 56 ------------------------------------------ 1 file changed, 56 deletions(-) diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml index ea925b962c..167f8f75d4 100644 --- a/src/analysis/locate.ml +++ b/src/analysis/locate.ml @@ -353,48 +353,6 @@ let uid_of_path ~config ~env ~ml_or_mli ~decl_uid path ns = Logger.fmt (fun fmt -> Shape.print fmt r); r.uid -(** [module_aliasing] iterates on a typedtree to check if the provided uid - corresponds to a module alias. If it does the function returns the uid of the - aliased module. If not it returns None. - The intended use of this function is to traverse dune-generated aliases. *) -let module_aliasing ~(bin_annots : Cmt_format.binary_annots) uid = - let exception Found of Path.t * Env.t in - let iterator env = { Tast_iterator.default_iterator with - module_binding = (fun sub mb -> - begin match mb with - | { mb_id = Some id; mb_expr = { mod_desc = Tmod_ident (path, _); _ }; _ } - -> - let md = Env.find_module (Pident id) env in - if Shape.Uid.equal uid md.md_uid then - raise (Found (path, env)) - | _ -> () end; - Tast_iterator.default_iterator.module_binding sub mb) - } - in - try - begin match bin_annots with - | Interface s -> - let sig_final_env = Envaux.env_of_only_summary s.sig_final_env in - let iterator = iterator sig_final_env in - iterator.signature iterator { s with sig_final_env } - | Implementation str -> - let str_final_env = Envaux.env_of_only_summary str.str_final_env in - let iterator = iterator str_final_env in - iterator.structure iterator { str with str_final_env } - | _ -> () end; - None - with Found (path, env) -> - let namespace = Shape.Sig_component_kind.Module in - let shape = Env.shape_of_path ~namespace env path in - log ~title:"locate" "Uid %a corresponds to an alias of %a - which has the shape %a and the uid %a" - Logger.fmt (fun fmt -> Shape.Uid.print fmt uid) - Logger.fmt (fun fmt -> Path.print fmt path) - Logger.fmt (fun fmt -> Shape.print fmt shape) - Logger.fmt (fun fmt -> - Format.pp_print_option Shape.Uid.print fmt shape.uid); - Option.map ~f:(fun uid -> uid, path) shape.uid - let from_uid ~config ~ml_or_mli uid loc path = let loc_of_comp_unit comp_unit = match load_cmt ~config comp_unit ml_or_mli with @@ -430,20 +388,6 @@ let from_uid ~config ~ml_or_mli uid loc path = log ~title "Shapes 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_loc uid with - | Some loc when - String.ends_with ~suffix:"ml-gen" loc.loc_start.pos_fname -> - log ~title "Found location in generated file: %a" - Logger.fmt (fun fmt -> Location.print_loc fmt loc); - (* This notably happens when using Dune. In that case we - try to resolve the alias immediately. *) - begin match module_aliasing ~bin_annots:cmt.cmt_annots uid with - | Some (Shape.Uid.Compilation_unit comp_unit as uid, _path) -> - log ~title - "The alias points to another compilation unit %s" comp_unit; - loc_of_comp_unit comp_unit - |> Option.map ~f:(fun loc -> uid, loc) - | _ -> Some (uid, loc) - end | Some loc -> log ~title "Found location: %a" Logger.fmt (fun fmt -> Location.print_loc fmt loc); From bcf5fe1c396ca23fa62083f02bc04bba4d91e803 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 6 Feb 2023 13:34:49 +0100 Subject: [PATCH 4/7] Use the latest Uid if declaration is not found --- src/analysis/locate.ml | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml index 167f8f75d4..1ecf8ae2b6 100644 --- a/src/analysis/locate.ml +++ b/src/analysis/locate.ml @@ -310,15 +310,16 @@ let load_cmt ~config comp_unit ml_or_mli = Ok (source_file, cmt_infos) | None -> Error () -let find_declaration_uid ~env ~decl_uid path = - let rec non_alias_declaration_uid path = - let md = Env.find_module path env in - match md.md_type with - | Mty_ident _ | Mty_signature _ | Mty_functor _ | Mty_for_hole -> md.md_uid - | Mty_alias path -> non_alias_declaration_uid path +let find_declaration_uid ~env ~fallback_uid path = + let rec non_alias_declaration_uid ~fallback_uid path = + match Env.find_module path env with + | { md_type = Mty_alias path; md_uid = fallback_uid; _ } -> + non_alias_declaration_uid ~fallback_uid path + | { md_type = Mty_ident _ | Mty_signature _ | Mty_functor _ | Mty_for_hole; + md_uid; _ }-> md_uid + | exception Not_found -> fallback_uid in - try non_alias_declaration_uid path -with Not_found -> decl_uid + non_alias_declaration_uid ~fallback_uid path let uid_of_path ~config ~env ~ml_or_mli ~decl_uid path ns = let module Shape_reduce = @@ -343,7 +344,7 @@ let uid_of_path ~config ~env ~ml_or_mli ~decl_uid path ns = end) in match ml_or_mli with - | `MLI -> Some (find_declaration_uid ~decl_uid ~env path) + | `MLI -> Some (find_declaration_uid ~fallback_uid:decl_uid ~env path) | `ML -> let shape = Env.shape_of_path ~namespace:ns env path in log ~title:"shape_of_path" "initial: %a" From 9930b302ac8bce96fac3b9a9cbd6ecd32be424f5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 6 Feb 2023 13:35:55 +0100 Subject: [PATCH 5/7] Rename `find_declaration_uid` to `scrape_alias` --- src/analysis/locate.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml index 1ecf8ae2b6..ae6926b61a 100644 --- a/src/analysis/locate.ml +++ b/src/analysis/locate.ml @@ -310,7 +310,7 @@ let load_cmt ~config comp_unit ml_or_mli = Ok (source_file, cmt_infos) | None -> Error () -let find_declaration_uid ~env ~fallback_uid path = +let scrape_alias ~env ~fallback_uid path = let rec non_alias_declaration_uid ~fallback_uid path = match Env.find_module path env with | { md_type = Mty_alias path; md_uid = fallback_uid; _ } -> @@ -344,7 +344,7 @@ let uid_of_path ~config ~env ~ml_or_mli ~decl_uid path ns = end) in match ml_or_mli with - | `MLI -> Some (find_declaration_uid ~fallback_uid:decl_uid ~env path) + | `MLI -> Some (scrape_alias ~fallback_uid:decl_uid ~env path) | `ML -> let shape = Env.shape_of_path ~namespace:ns env path in log ~title:"shape_of_path" "initial: %a" From 477c98ef9fc6b1da3393ce23bcc1aaf4a0364bde Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 8 Feb 2023 16:15:03 +0100 Subject: [PATCH 6/7] ci: Disable new 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 27e7e4f3a4..d1173a0ab2 100755 --- a/tests/test-dirs/locate/dune +++ b/tests/test-dirs/locate/dune @@ -1,7 +1,7 @@ (cram (applies_to looping-substitution mutually-recursive partial-cmt includes issue802 issue845 issue1199 issue1524 sig-substs l-413-features - module-aliases locate-constrs without-implem without-sig) + module-aliases locate-constrs without-implem without-sig module-decl-aliases) (enabled_if (<> %{os_type} Win32))) From 192ed6bfe86b4b90383b28ae365672a99d8d316e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 8 Feb 2023 16:17:03 +0100 Subject: [PATCH 7/7] Add changelog entry for #1563 --- CHANGES.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index 3e046c8746..f6e203649a 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -8,6 +8,8 @@ unreleased fixes #1564) - Restore compatibility with some OCaml compiler's debug flags that were incorrectly rejected by Merlin. (#1556) + - Traverse aliases when jumping to declaration. This matches + jump-to-definition'q behavior (#1563) merlin 4.7 ==========