diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml index ce179dbb57..a6c17eab13 100644 --- a/src/analysis/locate.ml +++ b/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. diff --git a/src/analysis/type_utils.ml b/src/analysis/type_utils.ml index 28f3427dab..ef5aa289cc 100644 --- a/src/analysis/type_utils.ml +++ b/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 diff --git a/src/analysis/type_utils.mli b/src/analysis/type_utils.mli index ae6e47fa5d..73ad9e7a31 100644 --- a/src/analysis/type_utils.mli +++ b/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 diff --git a/src/kernel/mreader_lexer.ml b/src/kernel/mreader_lexer.ml index c889790b3d..345c56a810 100644 --- a/src/kernel/mreader_lexer.ml +++ b/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; _} = diff --git a/src/ocaml/parsing/pprintast.mli b/src/ocaml/parsing/pprintast.mli index 47dbf6d5f2..4ceb5bbbb9 100644 --- a/src/ocaml/parsing/pprintast.mli +++ b/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 diff --git a/tests/test-dirs/locate/issue1610.t b/tests/test-dirs/locate/issue1610.t new file mode 100644 index 0000000000..277a5d00ba --- /dev/null +++ b/tests/test-dirs/locate/issue1610.t @@ -0,0 +1,65 @@ + $ cat >main.ml < 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 -filename main.ml -filename main.ml -filename main.ml -filename main.ml -filename main.ml main.ml < module A = struct let (+.) a b = a +. b end + > let f x = A.(x +. 1.) + > let g x = A.(+.) x 1. + > EOF + + $ $MERLIN single locate -look-for ml -position 2:16 \ + > -filename ./main.ml < ./main.ml | jq '.value' + { + "file": "$TESTCASE_ROOT/main.ml", + "pos": { + "line": 1, + "col": 22 + } + } + + $ $MERLIN single locate -look-for ml -position 3:14 \ + > -filename ./main.ml < ./main.ml | jq '.value' + { + "file": "$TESTCASE_ROOT/main.ml", + "pos": { + "line": 1, + "col": 22 + } + } diff --git a/tests/test-dirs/locate/issue949.t/issue949.ml b/tests/test-dirs/locate/issue949.t/issue949.ml deleted file mode 100644 index f10b2d6883..0000000000 --- a/tests/test-dirs/locate/issue949.t/issue949.ml +++ /dev/null @@ -1,2 +0,0 @@ -module A = struct let (+.) a b = a +. b end -let f x = A.(x +. 1.) diff --git a/tests/test-dirs/locate/issue949.t/run.t b/tests/test-dirs/locate/issue949.t/run.t deleted file mode 100644 index fa80cce67a..0000000000 --- a/tests/test-dirs/locate/issue949.t/run.t +++ /dev/null @@ -1,8 +0,0 @@ -This test is for testing the behavior of identifiers with a . in them: - - $ $MERLIN single locate -look-for ml -position 2:16 ./issue949.ml < ./issue949.ml - { - "class": "return", - "value": "Not in environment ''", - "notifications": [] - } diff --git a/tests/test-dirs/type-enclosing/type-papply.t b/tests/test-dirs/type-enclosing/type-papply.t new file mode 100644 index 0000000000..edb73fd934 --- /dev/null +++ b/tests/test-dirs/type-enclosing/type-papply.t @@ -0,0 +1,124 @@ + $ cat >main.ml < 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 + +FIXME: This should return the type of `t` (line 7) + $ $MERLIN single type-enclosing -position 15:18 -verbosity 1 \ + > -filename main.ml sig type t = int T.t end", + "tail": "no" + }, + { + "start": { + "line": 15, + "col": 9 + }, + "end": { + "line": 15, + "col": 19 + }, + "type": "int F.T.t", + "tail": "no" + }, + { + "start": { + "line": 15, + "col": 0 + }, + "end": { + "line": 15, + "col": 19 + }, + "type": "type u = int F.T.t", + "tail": "no" + } + ], + "notifications": [] + } + +Type of T (line 12) + $ $MERLIN single type-enclosing -position 15:15 \ + > -filename main.ml -filename main.ml -filename main.ml sig type t = int T.t end" + +Type of N (and larger enclosings) (line 5) + $ $MERLIN single type-enclosing -position 15:9 \ + > -filename main.ml sig type t = int T.t end end", + "tail": "no" + }, + { + "start": { + "line": 15, + "col": 9 + }, + "end": { + "line": 15, + "col": 19 + }, + "type": "N.M(F.T).t", + "tail": "no" + }, + { + "start": { + "line": 15, + "col": 0 + }, + "end": { + "line": 15, + "col": 19 + }, + "type": "type u = N.M(F.T).t", + "tail": "no" + } + ], + "notifications": [] + }