diff --git a/CHANGES.md b/CHANGES.md index 9fdaf38f3..5035780cd 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -21,6 +21,7 @@ unreleased `cmi` files (#1577) - Prevent destruct from crashing on closed variant types (#1602, fixes #1601) + - Improve longident parsing (#1612, fixes #945) + editor modes - emacs: call the user's configured completion UI in `merlin-construct` (#1598) diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml index ce179dbb5..a6c17eab1 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 28f3427da..8398c907e 100644 --- a/src/analysis/type_utils.ml +++ b/src/analysis/type_utils.ml @@ -41,6 +41,22 @@ 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 +68,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 +118,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 ae6e47fa5..73ad9e7a3 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/ocaml/parsing/pprintast.mli b/src/ocaml/parsing/pprintast.mli index 47dbf6d5f..4ceb5bbbb 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/issue949.t b/tests/test-dirs/locate/issue949.t new file mode 100644 index 000000000..f02ec5abc --- /dev/null +++ b/tests/test-dirs/locate/issue949.t @@ -0,0 +1,21 @@ +This test is for testing the behavior of identifiers with a . in them: + + $ cat >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.pos' + { + "line": 1, + "col": 22 + } + + $ $MERLIN single locate -look-for ml -position 3:14 \ + > -filename ./main.ml < ./main.ml | jq '.value.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 f10b2d688..000000000 --- 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 fa80cce67..000000000 --- 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": [] - }