Fix confusion when scraping aliases of module / module-types (ocaml#1676

)

from voodoos/issue1667-module-type-locate

CHANGES.md

@@ -5,6 +5,8 @@ unreleased
   + merlin binary
     - Improve error messages for missing configuration reader (#1669)
     - Fix regression causing crash when using ppxes under Windows (#1673)
+    - Fix confusion between aliased modules and module types (#1676,
+      fixes #1667)
   + editor modes
     - emacs: fix/improve keybindings (#1668, fixes #1386):
       Unbind <kbd>C-c C-r</kbd> (to avoid shadowing `tuareg-eval-region`)

src/analysis/locate.ml

@@ -310,18 +310,30 @@ let load_cmt ~config comp_unit ml_or_mli =
       Ok (source_file, cmt_infos)
   | None -> Error ()
 
-let scrape_alias ~env ~fallback_uid path =
+let scrape_alias ~env ~fallback_uid ~namespace path =
+  let find_type_and_uid ~env ~namespace path =
+    match namespace with
+    | Shape.Sig_component_kind.Module ->
+      let { Types.md_type; md_uid; _ } = Env.find_module path env in
+      md_type, md_uid
+    | Module_type ->
+      begin match Env.find_modtype path env with
+      | { Types.mtd_type = Some mtd_type; mtd_uid; _ } ->
+        mtd_type, mtd_uid
+      | _ -> raise Not_found
+    end
+    | _ -> raise Not_found
+  in
   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; _ } ->
+    match find_type_and_uid ~env ~namespace path with
+    | (Mty_alias path | Mty_ident path), fallback_uid ->
         non_alias_declaration_uid ~fallback_uid path
-    | { md_type = Mty_ident _ | Mty_signature _ | Mty_functor _ | Mty_for_hole;
-        md_uid; _ }-> md_uid
+    | _, 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 uid_of_path ~config ~env ~ml_or_mli ~decl_uid path namespace =
   let module Shape_reduce =
     Shape.Make_reduce (struct
       type env = Env.t
@@ -344,9 +356,15 @@ let uid_of_path ~config ~env ~ml_or_mli ~decl_uid path ns =
     end)
   in
   match ml_or_mli with
-  | `MLI -> Some (scrape_alias ~fallback_uid:decl_uid ~env path)
+  | `MLI ->
+    let uid = scrape_alias ~fallback_uid:decl_uid ~env ~namespace path in
+    log ~title:"uid_of_path" "Declaration uid: %a"
+      Logger.fmt (fun fmt -> Shape.Uid.print fmt decl_uid);
+    log ~title:"uid_of_path" "Alias scrapped: %a"
+      Logger.fmt (fun fmt -> Shape.Uid.print fmt uid);
+    Some uid
   | `ML ->
-    let shape = Env.shape_of_path ~namespace:ns env path in
+    let shape = Env.shape_of_path ~namespace env path in
     log ~title:"shape_of_path" "initial: %a"
       Logger.fmt (fun fmt -> Shape.print fmt shape);
     let r = Shape_reduce.weak_reduce env shape in

tests/test-dirs/locate/issue1667.t

@@ -0,0 +1,33 @@
+  $ cat >main.ml <<EOF
+  > module B = struct
+  >   module type T = sig end
+  > 
+  >   module T = struct end
+  > end
+  > 
+  > module M : B.T = struct end
+  > module type T2 = B.T
+  > module M2 : T2 = struct end
+  > EOF
+
+  $ $MERLIN single locate -look-for mli -position 7:13 \
+  > -filename ./main.ml < ./main.ml | jq '.value.pos'
+  {
+    "line": 2,
+    "col": 2
+  }
+
+  $ $MERLIN single locate -look-for ml -position 7:13 \
+  > -filename ./main.ml < ./main.ml | jq '.value.pos'
+  {
+    "line": 2,
+    "col": 2
+  }
+
+
+  $ $MERLIN single locate -look-for mli -position 9:12 \
+  > -filename ./main.ml < ./main.ml | jq '.value.pos'
+  {
+    "line": 2,
+    "col": 2
+  }