Share the load-path lookup, polyvariant label printing and ident tables

analysis/src/type_utils.ml

@@ -476,7 +476,8 @@ let rec extract_type ?(print_opening_debug = true)
           {
             name = label;
             display_name =
-              Utils.print_maybe_exotic_ident ~allow_uident:true label;
+              Res_printer.print_poly_var_ident label
+              |> Res_doc.to_string ~width:80;
             args =
               (* Multiple arguments are represented as a Ttuple, while a single argument is just the type expression itself. *)
               (match field with

analysis/src/utils.ml

@@ -242,29 +242,6 @@ let rec flatten_any_namespace_in_path path =
       (parts |> List.rev) @ flatten_any_namespace_in_path tail
     else head :: flatten_any_namespace_in_path tail
 
-let print_maybe_exotic_ident ?(allow_uident = false) txt =
-  let len = String.length txt in
-
-  let rec loop i =
-    if i == len then txt
-    else if i == 0 then
-      match String.unsafe_get txt i with
-      | 'A' .. 'Z' when allow_uident -> loop (i + 1)
-      | 'a' .. 'z' | '$' -> loop (i + 1)
-      (* Same as Res_printer.classify_ident_content: a lone [_] or one
-         followed by another character is not scanned as an identifier. *)
-      | '_' when len > 1 -> (
-        match String.unsafe_get txt 1 with
-        | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '_' | '$' -> loop (i + 1)
-        | _ -> "\"" ^ txt ^ "\"")
-      | _ -> "\"" ^ txt ^ "\""
-    else
-      match String.unsafe_get txt i with
-      | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '\'' | '_' | '$' -> loop (i + 1)
-      | _ -> "\"" ^ txt ^ "\""
-  in
-  if Res_token.is_keyword_txt txt then "\"" ^ txt ^ "\"" else loop 0
-
 let find_package_json root =
   let path = Uri.to_path root in
 

changes/polyvariant-completion-labels.fix.md

@@ -0,0 +1 @@
+- Editor completion shows the polymorphic variant labels `#644` and `#""` as the formatter prints them, instead of `#"644"` and `#`.

compiler/core/bs_cmi_load.ml

@@ -26,30 +26,18 @@ let load_cmi ~unit_name : Env.Persistent_signature.t option =
   (* On case-insensitive filesystems a lowercase alias can remain visible to
      [Sys.file_exists] briefly after its CMI is removed. Open each candidate
      once and parse that descriptor, so a vanished CMI is a missing module. *)
-  let name = unit_name ^ ".cmi" in
-  let lower_name = String.uncapitalize_ascii name in
-  let rec find = function
-    | [] -> None
-    | directory :: rest ->
-      let rec try_names = function
-        | [] -> find rest
-        | name :: names -> (
-          let filename = Filename.concat directory name in
-          let path = Compiler_request_state.resolve_path filename in
-          match Unix.openfile path [Unix.O_RDONLY; Unix.O_CLOEXEC] 0 with
-          | descriptor ->
-            let channel = Unix.in_channel_of_descr descriptor in
-            let cmi =
-              Fun.protect
-                (fun () -> Cmi_format.read_cmi_channel filename channel)
-                ~finally:(fun () -> close_in_noerr channel)
-            in
-            Some Env.Persistent_signature.{filename; cmi}
-          | exception Unix.Unix_error ((Unix.ENOENT | Unix.ENOTDIR), _, _) ->
-            try_names names
-          | exception Unix.Unix_error (error, _, _) ->
-            raise (Sys_error (path ^ ": " ^ Unix.error_message error)))
-      in
-      try_names (if lower_name = name then [name] else [name; lower_name])
-  in
-  find (Config.get_load_path ())
+  Misc.find_map_in_path_uncap (Config.get_load_path ()) (unit_name ^ ".cmi")
+    (fun filename ->
+      let path = Compiler_request_state.resolve_path filename in
+      match Unix.openfile path [Unix.O_RDONLY; Unix.O_CLOEXEC] 0 with
+      | descriptor ->
+        let channel = Unix.in_channel_of_descr descriptor in
+        let cmi =
+          Fun.protect
+            (fun () -> Cmi_format.read_cmi_channel filename channel)
+            ~finally:(fun () -> close_in_noerr channel)
+        in
+        Some Env.Persistent_signature.{filename; cmi}
+      | exception Unix.Unix_error ((Unix.ENOENT | Unix.ENOTDIR), _, _) -> None
+      | exception Unix.Unix_error (error, _, _) ->
+        raise (Sys_error (path ^ ": " ^ Unix.error_message error)))

compiler/core/config_util.ml

@@ -22,27 +22,8 @@
  * along with this program; if not, write to the Free Software
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
 
-(* Try the name as written before its uncapitalized form: on a
-   case-insensitive file system both match, and the result is shown in error
-   messages and used in generated import paths. *)
-let find_in_path_uncap path name =
-  let uname = Ext_string.uncapitalize_ascii name in
-  let rec try_dir = function
-    | [] -> None
-    | dir :: rem ->
-      let fullname = Filename.concat dir name in
-      if Sys.file_exists (Compiler_request_state.resolve_path fullname) then
-        Some fullname
-      else
-        let ufullname = Filename.concat dir uname in
-        if Sys.file_exists (Compiler_request_state.resolve_path ufullname) then
-          Some ufullname
-        else try_dir rem
-  in
-  try_dir path
-
 (* ATTENTION: read the load path after request options have populated it. *)
-let find_opt file = find_in_path_uncap (Config.get_load_path ()) file
+let find_opt file = Misc.find_in_path_uncap_opt (Config.get_load_path ()) file
 
 let output_prefix name =
   match !((Clflags.current ()).output_name) with

compiler/core/lam_check.ml

@@ -28,24 +28,24 @@
    2. all variables are of right scope
 *)
 let check ~file ~pass lam =
-  let defined_variables = Hash_set_ident.create 1000 in
+  let defined_variables = Hash_ident.create 1000 in
   let success = ref true in
   let use (id : Ident.t) =
-    if not @@ Hash_set_ident.mem defined_variables id then (
+    if not @@ Hash_ident.mem defined_variables id then (
       Format.fprintf
         (Compiler_request_output.stderr_formatter ())
         "\n[SANITY after %s]:%s/%d used before defined in %s@." pass id.name
         id.stamp file;
       success := false)
   in
   let def (id : Ident.t) =
-    if Hash_set_ident.mem defined_variables id then (
+    if Hash_ident.mem defined_variables id then (
       Format.fprintf
         (Compiler_request_output.stderr_formatter ())
         "\n[SANITY after %s]:%s/%d bound twice in %s@." pass id.name id.stamp
         file;
       success := false)
-    else Hash_set_ident.add defined_variables id ()
+    else Hash_ident.add defined_variables id ()
   in
   let rec check_list xs (cxt : Set_int.t) =
     Ext_list.iter xs (fun x -> check_staticfails x cxt)

compiler/core/lam_dce.ml

@@ -24,10 +24,10 @@
 
 let transitive_closure (initial_idents : Ident.t list)
     (ident_freevars : Set_ident.t Hash_ident.t) =
-  let visited = Hash_set_ident.create 31 in
+  let visited = Hash_ident.create 31 in
   let rec dfs (id : Ident.t) : unit =
-    if not (Hash_set_ident.mem visited id || Ext_ident.is_js_or_global id) then (
-      Hash_set_ident.add visited id ();
+    if not (Hash_ident.mem visited id || Ext_ident.is_js_or_global id) then (
+      Hash_ident.add visited id ();
       match Hash_ident.find_opt ident_freevars id with
       | None ->
         Ext_fmt.failwithf ~loc:__LOC__ "%s/%d not found" (Ident.name id)
@@ -69,13 +69,12 @@ let remove export_idents (rest : Lam_group.t list) : Lam_group.t list =
   let visited = transitive_closure initial_idents ident_free_vars in
   Ext_list.fold_left rest [] (fun acc x ->
       match x with
-      | Single (_, id, _) ->
-        if Hash_set_ident.mem visited id then x :: acc else acc
+      | Single (_, id, _) -> if Hash_ident.mem visited id then x :: acc else acc
       | Nop _ -> x :: acc
       | Recursive bindings -> (
         let b =
           Ext_list.fold_right bindings [] (fun ((id, _) as v) acc ->
-              if Hash_set_ident.mem visited id then v :: acc else acc)
+              if Hash_ident.mem visited id then v :: acc else acc)
         in
         match b with
         | [] -> acc

compiler/ext/misc.ml

@@ -61,21 +61,36 @@ let may_map = Stdlib.Option.map
 
 (* File functions *)
 
-let find_in_path_uncap path name =
+(* In each directory of [path], try [name] as written before its uncapitalized
+   form: on a case-insensitive file system both match, and the result is shown
+   in error messages and used in generated import paths. [f] gets each
+   candidate and returns the first result found. *)
+let find_map_in_path_uncap path name f =
   let uname = String.uncapitalize_ascii name in
   let rec try_dir = function
-    | [] -> raise Not_found
-    | dir :: rem ->
-      let fullname = Filename.concat dir name
-      and ufullname = Filename.concat dir uname in
-      if Sys.file_exists (Compiler_request_state.resolve_path fullname) then
-        fullname
-      else if Sys.file_exists (Compiler_request_state.resolve_path ufullname)
-      then ufullname
-      else try_dir rem
+    | [] -> None
+    | dir :: rem -> (
+      match f (Filename.concat dir name) with
+      | Some _ as found -> found
+      | None when uname = name -> try_dir rem
+      | None -> (
+        match f (Filename.concat dir uname) with
+        | Some _ as found -> found
+        | None -> try_dir rem))
   in
   try_dir path
 
+let find_in_path_uncap_opt path name =
+  find_map_in_path_uncap path name (fun fullname ->
+      if Sys.file_exists (Compiler_request_state.resolve_path fullname) then
+        Some fullname
+      else None)
+
+let find_in_path_uncap path name =
+  match find_in_path_uncap_opt path name with
+  | Some fullname -> fullname
+  | None -> raise Not_found
+
 let remove_file filename =
   let filename = Compiler_request_state.resolve_path filename in
   try if Sys.file_exists filename then Sys.remove filename

compiler/ext/misc.mli

@@ -37,10 +37,18 @@ val protect_refs : ref_and_value list -> (unit -> 'a) -> 'a
     while executing [f]. The previous contents of the references is restored
     even if [f] raises an exception. *)
 
+val find_map_in_path_uncap :
+  string list -> string -> (string -> 'a option) -> 'a option
+(* [find_map_in_path_uncap path name f] applies [f] to the candidates for
+   name in each directory of path, name as written and then its
+   uncapitalized form, i.e. /path/Foo.ml before /path/foo.ml, and returns
+   the first result. *)
+
+val find_in_path_uncap_opt : string list -> string -> string option
+(* The first candidate of [find_map_in_path_uncap] that exists. *)
+
 val find_in_path_uncap : string list -> string -> string
-(* Search the path for name, then for its uncapitalized form, i.e.
-   if name is Foo.ml, allow /path/Foo.ml and /path/foo.ml
-   to match, preferring the former. *)
+(* Like [find_in_path_uncap_opt]; raises [Not_found]. *)
 
 val remove_file : string -> unit
 (* Delete the given file if it exists. Never raise an error. *)

tests/analysis_tests/tests/src/CompletionExpressions.res

@@ -263,7 +263,7 @@ let arr = ["hello"]
 // arr->Belt.Array.map()
 //                     ^com
 
-type exoticPolyvariant = [#"some exotic" | #dollar$ | #"_"]
+type exoticPolyvariant = [#"some exotic" | #dollar$ | #"_" | #644 | #""]
 
 let takesExotic = (e: exoticPolyvariant) => {
   ignore(e)

tests/analysis_tests/tests/src/expected/CompletionExpressions.res.txt

@@ -1326,11 +1326,23 @@ ContextPath CArgument Value[takesExotic]($0)
 ContextPath Value[takesExotic]
 Path takesExotic
 [
+  {
+    "detail": "#\"\"",
+    "documentation": {
+      "kind": "markdown",
+      "value": "```rescript\n#\"\"\n```\n\n```rescript\n[#\"\" | #644 | #\"_\" | #dollar$ | #\"some exotic\"]\n```"
+    },
+    "insertText": "#\"\"",
+    "insertTextFormat": 2,
+    "kind": 4,
+    "label": "#\"\"",
+    "tags": []
+  },
   {
     "detail": "#\"some exotic\"",
     "documentation": {
       "kind": "markdown",
-      "value": "```rescript\n#\"some exotic\"\n```\n\n```rescript\n[#\"_\" | #dollar$ | #\"some exotic\"]\n```"
+      "value": "```rescript\n#\"some exotic\"\n```\n\n```rescript\n[#\"\" | #644 | #\"_\" | #dollar$ | #\"some exotic\"]\n```"
     },
     "insertText": "#\"some exotic\"",
     "insertTextFormat": 2,
@@ -1342,7 +1354,7 @@ Path takesExotic
     "detail": "#\"_\"",
     "documentation": {
       "kind": "markdown",
-      "value": "```rescript\n#\"_\"\n```\n\n```rescript\n[#\"_\" | #dollar$ | #\"some exotic\"]\n```"
+      "value": "```rescript\n#\"_\"\n```\n\n```rescript\n[#\"\" | #644 | #\"_\" | #dollar$ | #\"some exotic\"]\n```"
     },
     "insertText": "#\"_\"",
     "insertTextFormat": 2,
@@ -1354,13 +1366,25 @@ Path takesExotic
     "detail": "#dollar$",
     "documentation": {
       "kind": "markdown",
-      "value": "```rescript\n#dollar$\n```\n\n```rescript\n[#\"_\" | #dollar$ | #\"some exotic\"]\n```"
+      "value": "```rescript\n#dollar$\n```\n\n```rescript\n[#\"\" | #644 | #\"_\" | #dollar$ | #\"some exotic\"]\n```"
     },
     "insertText": "#dollar$",
     "insertTextFormat": 2,
     "kind": 4,
     "label": "#dollar$",
     "tags": []
+  },
+  {
+    "detail": "#644",
+    "documentation": {
+      "kind": "markdown",
+      "value": "```rescript\n#644\n```\n\n```rescript\n[#\"\" | #644 | #\"_\" | #dollar$ | #\"some exotic\"]\n```"
+    },
+    "insertText": "#644",
+    "insertTextFormat": 2,
+    "kind": 4,
+    "label": "#644",
+    "tags": []
   }
 ]