Illustrate and fix issue #1610

src/analysis/locate.ml

@@ -715,7 +715,10 @@ end = struct
 end
 
 let uid_from_longident ~config ~env nss ml_or_mli ident =
- let str_ident = String.concat ~sep:"." (Longident.flatten ident) in
+ let str_ident =
+ try String.concat ~sep:"." (Longident.flatten ident)
+ with _-> "Not a flat longident"
+ in
  match Env_lookup.in_namespaces nss ident env with
  | None -> `Not_in_env str_ident
  | Some (path, namespace, decl_uid, loc) ->
@@ -746,51 +749,55 @@ let from_path ~config ~env ~namespace ml_or_mli path =
  | `Found (file, loc) -> `Found (uid, file, loc)
  | `File_not_found _ as otherwise -> otherwise
 
+let infer_namespace ?namespaces ~pos lid browse is_label =
+ match namespaces with
+ | Some nss ->
+ if not is_label
+ then `Ok (nss :> Namespace.inferred list)
+ else if List.mem `Labels ~set:nss then (
+ log ~title:"from_string" "restricting namespaces to labels";
+ `Ok [ `Labels ]
+ ) else (
+ log ~title:"from_string"
+ "input is clearly a label, but the given namespaces don't cover that";
+ `Error `Missing_labels_namespace
+ )
+ | None ->
+ match Context.inspect_browse_tree ~cursor:pos lid [browse], is_label with
+ | None, _ ->
+ log ~title:"from_string" "already at origin, doing nothing" ;
+ `Error `At_origin
+ | Some (Label _ as ctxt), true
+ | Some ctxt, false ->
+ log ~title:"from_string"
+ "inferred context: %s" (Context.to_string ctxt);
+ `Ok (Namespace.from_context ctxt)
+ | _, true ->
+ log ~title:"from_string"
+ "dropping inferred context, it is not precise enough";
+ `Ok [ `Labels ]
+
 let from_string ~config ~env ~local_defs ~pos ?namespaces switch path =
  File_switching.reset ();
  let browse = Mbrowse.of_typedtree local_defs in
- let lid = Longident.parse path in
- let ident, is_label = Longident.keep_suffix lid in
- match
- match namespaces with
- | Some nss ->
- if not is_label
- then `Ok (nss :> Namespace.inferred list)
- else if List.mem `Labels ~set:nss then (
- log ~title:"from_string" "restricting namespaces to labels";
- `Ok [ `Labels ]
- ) else (
- log ~title:"from_string"
- "input is clearly a label, but the given namespaces don't cover that";
- `Error `Missing_labels_namespace
- )
- | None ->
- match Context.inspect_browse_tree ~cursor:pos lid [browse], is_label with
- | None, _ ->
- log ~title:"from_string" "already at origin, doing nothing" ;
- `Error `At_origin
- | Some (Label _ as ctxt), true
- | Some ctxt, false ->
- log ~title:"from_string"
- "inferred context: %s" (Context.to_string ctxt);
- `Ok (Namespace.from_context ctxt)
- | _, true ->
- log ~title:"from_string"
- "dropping inferred context, it is not precise enough";
- `Ok [ `Labels ]
- with
- | `Error e -> e
- | `Ok nss ->
- log ~title:"from_string"
- "looking for the source of '%s' (prioritizing %s files)"
- path (match switch with `ML -> ".ml" | `MLI -> ".mli");
- match from_longident ~config ~env nss switch ident with
- | `File_not_found _ | `Not_found _ | `Not_in_env _ as err -> err
- | `Builtin -> `Builtin path
- | `Found (uid, loc) ->
- match find_source ~config loc path with
- | `Found (file, loc) -> `Found (uid, file, loc)
- | `File_not_found _ as otherwise -> otherwise
+ let lid = Type_utils.parse_longident path in
+ let from_lid lid =
+ let ident, is_label = Longident.keep_suffix lid in
+ match infer_namespace ?namespaces ~pos lid browse is_label with
+ | `Error e -> e
+ | `Ok nss ->
+ log ~title:"from_string"
+ "looking for the source of '%s' (prioritizing %s files)"
+ path (match switch with `ML -> ".ml" | `MLI -> ".mli");
+ match from_longident ~config ~env nss switch ident with
+ | `File_not_found _ | `Not_found _ | `Not_in_env _ as err -> err
+ | `Builtin -> `Builtin path
+ | `Found (uid, loc) ->
+ match find_source ~config loc path with
+ | `Found (file, loc) -> `Found (uid, file, loc)
+ | `File_not_found _ as otherwise -> otherwise
+ in
+ Option.value_map ~f:from_lid ~default:(`Not_found (path, None)) lid
 
 (** When we look for docstring in external compilation unit we can perform
  a uid-based search and return the attached comment in the attributes.

src/analysis/type_utils.ml

@@ -41,6 +41,23 @@ let parse_expr ?(keywords=Lexer_raw.keywords []) expr =
  let lexer lexbuf = lexer (Lexer_raw.token_without_comments state lexbuf) in
  Parser_raw.parse_expression lexer lexbuf
 
+
+let parse_longident lid =
+ let protected_lid =
+ Pprintast.protect_ident (Format.str_formatter) lid;
+ Format.flush_str_formatter ()
+ in
+ let lexbuf = Lexing.from_string protected_lid in
+ let state = Lexer_raw.make @@ Lexer_raw.keywords [] in
+ let rec lexer = function
+ | Lexer_raw.Fail (e,l) -> raise (Lexer_raw.Error (e,l))
+ | Lexer_raw.Return token -> token
+ | Lexer_raw.Refill k -> lexer (k ())
+ in
+ let lexer lexbuf = lexer (Lexer_raw.token_without_comments state lexbuf) in
+ try Some (Parser_raw.parse_any_longident lexer lexbuf)
+ with Parser_raw.Error -> None
+
 let lookup_module name env =
  let path, md = Env.find_module_by_name name env in
  path, md.Types.md_type, md.Types.md_attributes
@@ -52,7 +69,7 @@ module Printtyp = struct
 
  let expand_type env ty =
  Env.with_cmis @@ fun () -> (* ?? Not sure *)
- match !verbosity with 
+ match !verbosity with
  | Smart | Lvl 0 -> ty
  | Lvl (_ : int) ->
  (* Fresh copy of the type to mutilate *)
@@ -102,32 +119,32 @@ module Printtyp = struct
  let verbose_modtype env ppf t =
  Printtyp.modtype ppf (expand_sig env t)
 
- let select_by_verbosity ~default ?(smart=default) ~verbose = 
+ let select_by_verbosity ~default ?(smart=default) ~verbose =
  match !verbosity with
  | Smart -> smart
  | Lvl 0 -> default
  | Lvl _ -> verbose
 
- let type_scheme env ppf ty = 
- (select_by_verbosity 
- ~default:type_scheme 
+ let type_scheme env ppf ty =
+ (select_by_verbosity
+ ~default:type_scheme
  ~verbose:(verbose_type_scheme env)) ppf ty
 
- let type_declaration env id ppf = 
- (select_by_verbosity 
- ~default:type_declaration 
+ let type_declaration env id ppf =
+ (select_by_verbosity
+ ~default:type_declaration
  ~verbose:(verbose_type_declaration env)) id ppf
 
  let modtype env ppf mty =
- let smart ppf = function 
+ let smart ppf = function
  | Types.Mty_ident _ | Mty_alias _ -> verbose_modtype env ppf mty
- | _ -> modtype ppf mty 
- in 
- (select_by_verbosity 
+ | _ -> modtype ppf mty
+ in
+ (select_by_verbosity
  ~default:modtype
  ~verbose:(verbose_modtype env)
  ~smart) ppf mty
- 
+
  let wrap_printing_env env ~verbosity:v f =
  let_ref verbosity v (fun () -> wrap_printing_env env f)
 end

src/analysis/type_utils.mli

@@ -49,22 +49,22 @@ val mod_smallerthan : int -> Types.module_type -> int option
  otherwise (module is bigger than threshold).
  Used to skip printing big modules in completion. *)
 
-val type_in_env : 
- ?verbosity:Mconfig.Verbosity.t 
- -> ?keywords:Lexer_raw.keywords 
- -> context: Context.t 
- -> Env.t 
- -> Format.formatter 
- -> string 
+val type_in_env :
+ ?verbosity:Mconfig.Verbosity.t
+ -> ?keywords:Lexer_raw.keywords
+ -> context: Context.t
+ -> Env.t
+ -> Format.formatter
+ -> string
  -> bool
 (** [type_in_env env ppf input] parses [input] and prints its type on [ppf].
  Returning true if it printed a type, false otherwise. *)
 
-val print_type_with_decl : 
- verbosity:Mconfig.Verbosity.t 
- -> Env.t 
- -> Format.formatter 
- -> Types.type_expr 
+val print_type_with_decl :
+ verbosity:Mconfig.Verbosity.t
+ -> Env.t
+ -> Format.formatter
+ -> Types.type_expr
  -> unit
 (** [print_type_or_decl] behaves like [Printtyp.type_scheme], it prints the
  type expression, except if it is a type constructor and verbosity is set then
@@ -80,9 +80,11 @@ val read_doc_attributes : Parsetree.attributes -> (string * Location.t) option
 
 val is_deprecated : Parsetree.attributes -> bool
 
-val print_constr : 
- verbosity:Mconfig.Verbosity.t 
- -> Env.t 
- -> Format.formatter 
- -> Types.constructor_description 
+val print_constr :
+ verbosity:Mconfig.Verbosity.t
+ -> Env.t
+ -> Format.formatter
+ -> Types.constructor_description
  -> unit
+
+val parse_longident : string -> Longident.t option

src/kernel/mreader_lexer.ml

@@ -28,6 +28,8 @@
 
 open Std
 
+let {Logger. log} = Logger.for_section "mreader_lexer"
+
 type keywords = Lexer_raw.keywords
 
 type triple = Parser_raw.token * Lexing.position * Lexing.position
@@ -223,6 +225,15 @@ let is_operator = function
  »
 *)
 
+let print_token fmt = function
+ | LIDENT s -> Format.fprintf fmt "LIDENT %s" s
+ | UIDENT s -> Format.fprintf fmt "UIDENT %s" s
+ | LPAREN -> Format.fprintf fmt "LPAREN"
+ | RPAREN -> Format.fprintf fmt "RPAREN"
+ | DOT -> Format.fprintf fmt "DOT"
+ | EOF -> Format.fprintf fmt "EOF"
+ | _ -> Format.fprintf fmt "OTHER";;
+
 let reconstruct_identifier_from_tokens tokens pos =
  let rec look_for_component acc = function
 
@@ -246,6 +257,36 @@ let reconstruct_identifier_from_tokens tokens pos =
  when is_operator token <> None && acc = [] ->
  look_for_dot [item] items
 
+ (* RPAREN UIDENT means that we are in presence of a functor application. *)
+ | (RPAREN, _, end_pos) :: ((UIDENT _, _, _ ) as item) :: items
+ when acc <> [] ->
+ let param_items, items = group_until_lparen [item] items in
+ begin try
+ begin try
+ (* Is the cursor on the parameter ? *)
+ look_for_dot [] (List.rev param_items)
+ with Not_found ->
+ (* Is the cursor on the functor or before ? *)
+ look_for_component [] items
+ end
+ with Not_found ->
+ (* The cursor must be after the application [M.N(F).|t]
+ We make a single component with the applciation and continue *)
+ match items with
+ | (UIDENT f, start_pos, _ ) :: items ->
+ let app =
+ let param = List.map ~f:(function
+ | (DOT, _, _ ) -> "."
+ | (UIDENT s, _, _) -> s
+ | _ -> raise Not_found
+ ) param_items
+ in
+ Format.sprintf "%s(%s)" f (String.concat ~sep:"" param)
+ in
+ look_for_dot ((UIDENT app, start_pos, end_pos ) :: acc) items
+ | _ -> raise Not_found
+ end
+
  (* An operator alone is an identifier on its own *)
  | (token, _, _ as item) :: items
  when is_operator token <> None && acc = [] ->
@@ -257,6 +298,11 @@ let reconstruct_identifier_from_tokens tokens pos =
 
  | [] -> raise Not_found
 
+ and group_until_lparen acc = function
+ | (LPAREN,_,_) :: items -> acc, items
+ | item :: items -> group_until_lparen (item::acc) items
+ | _ -> raise Not_found
+
  and look_for_dot acc = function
  | (DOT,_,_) :: items -> look_for_component acc items
  | items -> check acc items
@@ -312,6 +358,9 @@ let reconstruct_identifier config source pos =
  let lexbuf = Lexing.from_string (Msource.text source) in
  Location.init lexbuf (Mconfig.filename config);
  let tokens = lex [] lexbuf in
+ log ~title:"from_tokens" "%a" Logger.fmt (fun fmt ->
+ Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ")
+ (fun fmt (tok, _, _) -> print_token fmt tok) fmt tokens);
  reconstruct_identifier_from_tokens tokens pos
 
 let is_uppercase {Location. txt = x; _} =

src/ocaml/parsing/pprintast.mli

@@ -56,3 +56,4 @@ val tyvar: Format.formatter -> string -> unit
 
 (* merlin *)
 val case_list : Format.formatter -> Parsetree.case list -> unit
+val protect_ident : Format.formatter -> string -> unit

tests/test-dirs/locate/issue1610.t

@@ -0,0 +1,65 @@
+ $ cat >main.ml <<EOF
+ > module type T = sig
+ > type 'a t
+ > end
+ > 
+ > module N = struct
+ > module M (T : T) = struct
+ > type t = int T.t
+ > end
+ > end
+ > 
+ > module F = struct
+ > module T = struct type 'a t end
+ > end
+ > 
+ > type u = N.M(F.T).t
+ > EOF
+
+We should jump to the functor's body (line 7)
+ $ $MERLIN single locate -look-for ml -position 15:18 \
+ > -filename main.ml <main.ml | jq '.value.pos'
+ {
+ "line": 7,
+ "col": 4
+ }
+
+Should jump to T's definition (line 12)
+ $ $MERLIN single locate -look-for ml -position 15:15 \
+ > -filename main.ml <main.ml | jq '.value.pos'
+ {
+ "line": 12,
+ "col": 2
+ }
+
+Should jump to F's definition (line 11)
+ $ $MERLIN single locate -look-for ml -position 15:13 \
+ > -filename main.ml <main.ml | jq '.value.pos'
+ {
+ "line": 11,
+ "col": 0
+ }
+
+Should jump to M's definition (line 6)
+ $ $MERLIN single locate -look-for ml -position 15:11 \
+ > -filename main.ml <main.ml | jq '.value.pos'
+ {
+ "line": 6,
+ "col": 2
+ }
+
+Should jump to N's definition (line 5)
+ $ $MERLIN single locate -look-for ml -position 15:9 \
+ > -filename main.ml <main.ml | jq '.value.pos'
+ {
+ "line": 5,
+ "col": 0
+ }
+
+It also works as expected when the user inputs the expression manually
+ $ $MERLIN single locate -prefix 'N.M(F.T).t' -look-for ml -position 15:18 \
+ > -filename main.ml <main.ml | jq '.value.pos'
+ {
+ "line": 7,
+ "col": 4
+ }