Jump to declaration through aliases (#1563)

from voodoos/jump-to-declaration-through-aliases

Author: voodoos

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
 ==========

src/analysis/locate.ml

@@ -310,6 +310,17 @@ let load_cmt ~config comp_unit ml_or_mli =
       Ok (source_file, cmt_infos)
   | None -> Error ()
 
+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; _ } ->
+        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
+  non_alias_declaration_uid ~fallback_uid path
+
 let uid_of_path ~config ~env ~ml_or_mli ~decl_uid path ns =
   let module Shape_reduce =
     Shape.Make_reduce (struct
@@ -333,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 decl_uid
+  | `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"
@@ -343,48 +354,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
@@ -420,20 +389,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);

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)))
 

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

tests/test-dirs/locate/module-decl-aliases.t

@@ -0,0 +1,59 @@
+  $ cat >main.ml <<EOF
+  > 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 <<EOF
+  > 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
+    }
+  }
+
+  $ $MERLIN single locate -look-for mli -position 11:10 \
+  > -filename ./main.ml < ./main.ml | jq '.value'
+  {
+    "file": "$TESTCASE_ROOT/main.ml",
+    "pos": {
+      "line": 2,
+      "col": 2
+    }
+  }
+  $ $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
+    }
+  }
+
+  $ $MERLIN single locate -look-for mli -position 2:10 \
+  > -filename ./other.ml < ./other.ml | jq '.value'
+  {
+    "file": "$TESTCASE_ROOT/main.ml",
+    "pos": {
+      "line": 2,
+      "col": 2
+    }
+  }