Locate constructors' exact positions

src/analysis/locate.ml

@@ -472,11 +472,22 @@ let locate ~config ~env ~ml_or_mli decl_uid loc path ns =
 
 let path_and_loc_of_cstr desc _ =
   let open Types in
+  (* At this point the location of a constructor englobs its arguments so we
+    need to shrink it *)
+  let loc_without_args { cstr_name; cstr_loc; _ } =
+    let name_length = String.length cstr_name in
+    let loc_end = { cstr_loc.loc_start with
+      pos_bol = cstr_loc.loc_start.pos_bol + name_length;
+      pos_cnum = cstr_loc.loc_start.pos_cnum + name_length }
+    in
+    { cstr_loc with loc_end }
+  in
+  let loc = loc_without_args desc in
   match desc.cstr_tag with
-  | Cstr_extension (path, _) -> path, desc.cstr_loc
+  | Cstr_extension (path, _) -> path, loc
   | _ ->
     match get_desc desc.cstr_res with
-    | Tconstr (path, _, _) -> path, desc.cstr_loc
+    | Tconstr (path, _, _) -> path, loc
     | _ -> assert false
 
 let path_and_loc_from_label desc env =
@@ -655,11 +666,14 @@ module Env_lookup : sig
     -> Env.t
     -> (Location.t * Shape.Uid.t * Shape.Sig_component_kind.t) option
 
+  (** The latest argument is only true in the constructor case and signal that
+      using the declaration's uid is preferable. Shapes would lead to the
+      definition of the type, not the constructor itself. *)
   val in_namespaces
      : Namespace.inferred list
     -> Longident.t
     -> Env.t
-    -> (Path.t * Shape.Sig_component_kind.t * Shape.Uid.t * Location.t) option
+    -> (Path.t * Shape.Sig_component_kind.t * Shape.Uid.t * Location.t * bool) option
 
 end = struct
 
@@ -689,7 +703,7 @@ end = struct
       Not_found -> None
 
   exception Found of
-    (Path.t * Shape.Sig_component_kind.t * Shape.Uid.t * Location.t)
+    (Path.t * Shape.Sig_component_kind.t * Shape.Uid.t * Location.t * bool)
 
   let in_namespaces (nss : Namespace.inferred list) ident env =
     let open Shape.Sig_component_kind in
@@ -702,73 +716,76 @@ end = struct
               "got extension constructor";
             let path, loc = path_and_loc_of_cstr cd env in
             (* TODO: Use [`Constr] here instead of [`Type] *)
-            raise (Found (path, Extension_constructor, cd.cstr_uid, loc))
+            raise (Found (path, Extension_constructor, cd.cstr_uid, loc, false))
           | `This_cstr cd ->
             log ~title:"lookup"
               "got constructor, fetching path and loc in type namespace";
             let path, loc = path_and_loc_of_cstr cd env in
             (* TODO: Use [`Constr] here instead of [`Type] *)
-            raise (Found (path, Type, cd.cstr_uid,loc))
+            (* The path here is the one of the type, not the constructor *)
+            raise (Found (path, Type, cd.cstr_uid,loc, true))
           | `Constr ->
             log ~title:"lookup" "lookup in constructor namespace" ;
             let cd = Env.find_constructor_by_name ident env in
             let path, loc = path_and_loc_of_cstr cd env in
             (* TODO: Use [`Constr] here instead of [`Type] *)
-            raise (Found (path, Type,cd.cstr_uid, loc))
+            raise (Found (path, Type,cd.cstr_uid, loc, false))
           | `Mod ->
             log ~title:"lookup" "lookup in module namespace" ;
             let path, md = Env.find_module_by_name ident env in
-            raise (Found (path, Module, md.md_uid, md.Types.md_loc))
+            raise (Found (path, Module, md.md_uid, md.Types.md_loc, false))
           | `Modtype ->
             log ~title:"lookup" "lookup in module type namespace" ;
             let path, mtd = Env.find_modtype_by_name ident env in
-            raise (Found (path, Module_type, mtd.mtd_uid, mtd.Types.mtd_loc))
+            raise (Found (path, Module_type, mtd.mtd_uid, mtd.Types.mtd_loc, false))
           | `Type ->
             log ~title:"lookup" "lookup in type namespace" ;
             let path, typ_decl = Env.find_type_by_name ident env in
             raise (
-              Found (path, Type, typ_decl.type_uid, typ_decl.Types.type_loc)
+              Found (path, Type, typ_decl.type_uid, typ_decl.Types.type_loc, false)
             )
           | `Vals ->
             log ~title:"lookup" "lookup in value namespace" ;
             let path, val_desc = Env.find_value_by_name ident env in
             raise (
-              Found (path, Value, val_desc.val_uid, val_desc.Types.val_loc)
+              Found (path, Value, val_desc.val_uid, val_desc.Types.val_loc, false)
             )
           | `This_label lbl ->
             log ~title:"lookup"
               "got label, fetching path and loc in type namespace";
             let path, loc = path_and_loc_from_label lbl env in
             (* TODO: Use [`Labels] here instead of [`Type] *)
-            raise (Found (path, Type, lbl.lbl_uid, loc))
+            raise (Found (path, Type, lbl.lbl_uid, loc, false))
           | `Labels ->
             log ~title:"lookup" "lookup in label namespace" ;
             let lbl = Env.find_label_by_name ident env in
             let path, loc = path_and_loc_from_label lbl env in
             (* TODO: Use [`Labels] here instead of [`Type] *)
-            raise (Found (path, Type, lbl.lbl_uid, loc))
+            raise (Found (path, Type, lbl.lbl_uid, loc, false))
         with Not_found -> ()
       ) ;
       log ~title:"lookup" "   ... not in the environment" ;
       None
-    with Found ((path, namespace, decl_uid, _loc) as x) ->
-      log ~title:"env_lookup" "found: '%a' in namespace %s with uid %a"
+    with Found ((path, namespace, decl_uid, loc, _) as x) ->
+      log ~title:"env_lookup" "found: '%a' in nss %s with uid %a at loc %a"
         Logger.fmt (fun fmt -> Path.print fmt path)
         (Shape.Sig_component_kind.to_string namespace)
-        Logger.fmt (fun fmt -> Shape.Uid.print fmt decl_uid);
+        Logger.fmt (fun fmt -> Shape.Uid.print fmt decl_uid)
+        Logger.fmt (fun fmt -> Location.print_loc fmt loc);
       Some x
 end
 
 let uid_from_longident ~config ~env nss ml_or_mli ident =
   let str_ident = String.concat ~sep:"." (Longident.flatten ident) in
   match Env_lookup.in_namespaces nss ident env with
   | None -> `Not_in_env str_ident
-  | Some (path, namespace, decl_uid, loc) ->
-    if Utils.is_builtin_path path then
-      `Builtin
-    else
-      let uid = uid_of_path ~config ~env ~ml_or_mli ~decl_uid path namespace in
-      `Uid (uid, loc, path)
+  | Some (path, _, _, _, _) when Utils.is_builtin_path path -> `Builtin
+  | Some (path, _namespace, decl_uid, loc, true) ->
+    log ~title:"uid_from_longident" "constructor";
+    `Uid (Some decl_uid, loc, path)
+  | Some (path, namespace, decl_uid, loc, false) ->
+    let uid = uid_of_path ~config ~env ~ml_or_mli ~decl_uid path namespace in
+    `Uid (uid, loc, path)
 
 let from_longident ~config ~env nss ml_or_mli ident =
   match uid_from_longident ~config ~env nss ml_or_mli ident with

tests/test-dirs/document/issue1513.t

@@ -21,7 +21,7 @@ FIXME: We should not rely on "fallbacking". This requires a compiler change.
   > -log-file - -log-section locate \
   > -filename main.ml <main.ml 2>&1 | 
   > grep "Uid not found in the cmt table"
-  Uid not found in the cmt table. Fallbacking to the node's location: File "naux.ml", line 2, characters 2-5
+  Uid not found in the cmt table. Fallbacking to the node's location: File "naux.ml", line 2, characters 2-3
 
 FIXME: expected "B Comment"
   $ $MERLIN single document -position 2:13 \

tests/test-dirs/locate/context-detection/cd-test.t/run.t

@@ -7,7 +7,7 @@ Trying them all:
       "file": "$TESTCASE_ROOT/test.ml",
       "pos": {
         "line": 1,
-        "col": 0
+        "col": 9
       }
     },
     "notifications": []
@@ -109,7 +109,7 @@ FIXME we failed to parse/reconstruct the ident, that's interesting
       "file": "$TESTCASE_ROOT/test.ml",
       "pos": {
         "line": 1,
-        "col": 0
+        "col": 9
       }
     },
     "notifications": []

tests/test-dirs/locate/issue802.t/run.t

@@ -15,7 +15,7 @@ Test jumping from a normal constructor:
       "file": "$TESTCASE_ROOT/error.ml",
       "pos": {
         "line": 1,
-        "col": 0
+        "col": 9
       }
     },
     "notifications": []

tests/test-dirs/locate/locate-constrs.t

@@ -3,46 +3,58 @@
 **/
 
   $ cat >constr.ml <<EOF
-  > type t = A of int |  B
-  > let foo : t = A 42
+  > module C : sig type t = A of int | B end
+  >   = struct type t = A of int | B end
+  > let foo : C.t = C.A 42
   > EOF
 
-  $ $MERLIN single locate -look-for mli -position 2:14 \
+We expect 1:24
+  $ $MERLIN single locate -look-for mli -position 3:18 \
   > -filename ./constr.ml < ./constr.ml | jq '.value'
   {
     "file": "$TESTCASE_ROOT/constr.ml",
     "pos": {
       "line": 1,
-      "col": 9
+      "col": 24
     }
   }
 
 FIXME: this is not a very satisfying answer. 
-We could expect 1:9
-  $ $MERLIN single locate  -look-for ml -position 2:14 \
+We expect 1:20
+  $ $MERLIN single locate  -look-for ml -position 3:12 \
   > -filename ./constr.ml < ./constr.ml | jq '.value'
   {
     "file": "$TESTCASE_ROOT/constr.ml",
     "pos": {
-      "line": 1,
-      "col": 0
+      "line": 2,
+      "col": 11
     }
   }
 
 With the declaration in another compilation unit:
   $ cat >other_module.ml <<EOF
-  > let foo = Constr.B
+  > let foo = Constr.C.B
   > EOF
 
   $ $OCAMLC -c -bin-annot constr.ml
 
-  $ $MERLIN single locate -look-for mli -position 1:17 \
+  $ $MERLIN single locate -look-for mli -position 1:19 \
+  > -filename ./other_module.ml < ./other_module.ml | jq '.value'
+  {
+    "file": "$TESTCASE_ROOT/constr.ml",
+    "pos": {
+      "line": 1,
+      "col": 33
+    }
+  }
+
+  $ $MERLIN single locate -look-for ml -position 1:19 \
   > -filename ./other_module.ml < ./other_module.ml | jq '.value'
   {
     "file": "$TESTCASE_ROOT/constr.ml",
     "pos": {
       "line": 1,
-      "col": 18
+      "col": 33
     }
   }