diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml index 62daa561c1..5368e68f02 100644 --- a/src/analysis/locate.ml +++ b/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,60 +716,62 @@ 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 @@ -763,12 +779,13 @@ 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 diff --git a/tests/test-dirs/document/issue1513.t b/tests/test-dirs/document/issue1513.t index b9e18604f9..1a3e2e7744 100644 --- a/tests/test-dirs/document/issue1513.t +++ b/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 &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 \ 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 34e4cce900..8ac17c8d9f 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 @@ -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": [] diff --git a/tests/test-dirs/locate/issue802.t/run.t b/tests/test-dirs/locate/issue802.t/run.t index 73505e98d8..355a215325 100644 --- a/tests/test-dirs/locate/issue802.t/run.t +++ b/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": [] diff --git a/tests/test-dirs/locate/locate-constrs.t b/tests/test-dirs/locate/locate-constrs.t index 6df036bc09..f0b95be39c 100644 --- a/tests/test-dirs/locate/locate-constrs.t +++ b/tests/test-dirs/locate/locate-constrs.t @@ -3,46 +3,58 @@ **/ $ cat >constr.ml < 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 < 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 } }