Look up compiled files under the module name as written first

changes/cmi-lookup-as-written.fix.md

@@ -0,0 +1 @@
+- Find compiled files under the module's name as written before its uncapitalized form, so error messages on case-insensitive file systems show `ABC.cmi` instead of `aBC.cmi`.

compiler/core/bs_cmi_load.ml

@@ -50,6 +50,6 @@ let load_cmi ~unit_name : Env.Persistent_signature.t option =
           | exception Unix.Unix_error (error, _, _) ->
             raise (Sys_error (path ^ ": " ^ Unix.error_message error)))
       in
-      try_names (if lower_name = name then [name] else [lower_name; name])
+      try_names (if lower_name = name then [name] else [name; lower_name])
   in
   find (Config.get_load_path ())

compiler/core/config_util.ml

@@ -22,18 +22,21 @@
  * 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 ufullname = Filename.concat dir uname in
-      if Sys.file_exists (Compiler_request_state.resolve_path ufullname) then
-        Some ufullname
+      let fullname = Filename.concat dir name in
+      if Sys.file_exists (Compiler_request_state.resolve_path fullname) then
+        Some fullname
       else
-        let fullname = Filename.concat dir name in
-        if Sys.file_exists (Compiler_request_state.resolve_path fullname) then
-          Some fullname
+        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

compiler/ext/misc.ml

@@ -68,10 +68,10 @@ let find_in_path_uncap path name =
     | dir :: rem ->
       let fullname = Filename.concat dir name
       and ufullname = Filename.concat dir uname in
-      if Sys.file_exists (Compiler_request_state.resolve_path ufullname) then
-        ufullname
-      else if Sys.file_exists (Compiler_request_state.resolve_path fullname)
-      then fullname
+      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
   in
   try_dir path

compiler/ext/misc.mli

@@ -38,9 +38,9 @@ val protect_refs : ref_and_value list -> (unit -> 'a) -> 'a
     even if [f] raises an exception. *)
 
 val find_in_path_uncap : string list -> string -> string
-(* Same, but search also for uncapitalized name, i.e.
+(* 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. *)
+   to match, preferring the former. *)
 
 val remove_file : string -> unit
 (* Delete the given file if it exists. Never raise an error. *)

tests/ounit_tests/ounit_find_in_path_tests.ml

@@ -0,0 +1,90 @@
+open OUnit
+
+(* Load-path lookups accept a module's file under its name as written and
+   uncapitalized. They return the name as written when it exists, because on a
+   case-insensitive file system both spellings name the same file and the
+   result shows up in error messages and import paths. *)
+
+let rec remove_tree path =
+  match (Unix.lstat path).st_kind with
+  | Unix.S_DIR ->
+    Array.iter
+      (fun name -> remove_tree (Filename.concat path name))
+      (Sys.readdir path);
+    Unix.rmdir path
+  | _ -> Sys.remove path
+  | exception Unix.Unix_error (Unix.ENOENT, _, _) -> ()
+
+let with_temp_dir action =
+  let path = Filename.temp_file "rescript-find-in-path-" "" in
+  Sys.remove path;
+  Unix.mkdir path 0o755;
+  let path = Unix.realpath path in
+  Fun.protect ~finally:(fun () -> remove_tree path) (fun () -> action path)
+
+let write_cmi path =
+  ignore
+    (Cmi_format.create_cmi path
+       {
+         Cmi_format.cmi_name = "Abc";
+         cmi_sign = [];
+         cmi_crcs = [];
+         cmi_flags = [];
+       }
+      : Digest.t)
+
+(* [files] are created in a temporary directory, which is the load path while
+   [check] runs with that directory. *)
+let in_load_path files check =
+  with_temp_dir (fun root ->
+      List.iter (fun name -> write_cmi (Filename.concat root name)) files;
+      Compiler_request_state.with_fresh ~cwd:root (fun () ->
+          Config.set_load_path [root];
+          check root))
+
+let printer = Fun.id
+
+let lookups =
+  [
+    ( "misc",
+      fun name ->
+        Misc.find_in_path_uncap (Config.get_load_path ()) (name ^ ".cmi") );
+    ( "config_util",
+      fun name -> Option.get (Config_util.find_opt (name ^ ".cmi")) );
+    ( "bs_cmi_load",
+      fun name ->
+        (Option.get (Bs_cmi_load.load_cmi ~unit_name:name))
+          .Env.Persistent_signature.filename );
+  ]
+
+let as_written_first_tests _ =
+  List.iter
+    (fun (lookup_name, lookup) ->
+      in_load_path ["Abc.cmi"; "abc.cmi"] (fun root ->
+          assert_equal ~printer ~msg:lookup_name
+            (Filename.concat root "Abc.cmi")
+            (lookup "Abc"));
+      in_load_path ["Abc.cmi"] (fun root ->
+          assert_equal ~printer ~msg:lookup_name
+            (Filename.concat root "Abc.cmi")
+            (lookup "Abc")))
+    lookups
+
+(* Only a case-sensitive file system tells the two spellings apart. *)
+let uncapitalized_fallback_tests _ =
+  List.iter
+    (fun (lookup_name, lookup) ->
+      in_load_path ["abc.cmi"] (fun root ->
+          let found = lookup "Abc" in
+          if not (Sys.file_exists (Filename.concat root "Abc.cmi")) then
+            assert_equal ~printer ~msg:lookup_name
+              (Filename.concat root "abc.cmi")
+              found))
+    lookups
+
+let suites =
+  __FILE__
+  >::: [
+         "as_written_first" >:: as_written_first_tests;
+         "uncapitalized_fallback" >:: uncapitalized_fallback_tests;
+       ]

tests/ounit_tests/ounit_tests_main.ml

@@ -35,6 +35,7 @@ let suites =
       Ounit_typeopt_tests.suites;
       Ounit_gentype_tests.suites;
       Ounit_compiler_request_tests.suites;
+      Ounit_find_in_path_tests.suites;
     ]
 
 let _ = OUnit.run_test_tt_main suites