[B] Improve longident parsing (ocaml#1612)

from voodoos/better-lid-parsing

Author: voodoos

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)

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,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

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/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/issue949.t

@@ -0,0 +1,21 @@
+This test is for testing the behavior of identifiers with a . in them:
+
+  $ cat >main.ml <<EOF
+  > 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
+  }