merlin: avoid touching case of filename

CHANGES.md

@@ -115,6 +115,9 @@ Unreleased
   would not be included whenever `(generate_opam_files true)` was set and the
   `.install` file wasn't yet generated. (#7547, @rgrinberg)
 
+- Fix regression where Merlin was unable to handle filenames with uppercase
+  letters under Windows. (#7577, @nojb)
+
 3.7.1 (2023-04-04)
 ------------------
 

bin/ocaml/ocaml_merlin.ml

@@ -50,13 +50,10 @@ end = struct
      Cygwin environment both paths are lowarcased before the comparison *)
   let make_relative_to_root p =
     let p = Path.to_absolute_filename p in
-    let prefix, p =
-      let prefix = Path.(to_absolute_filename root) in
-      if Sys.win32 || Sys.cygwin then
-        (String.lowercase_ascii prefix, String.lowercase_ascii p)
-      else (prefix, p)
-    in
-    String.drop_prefix ~prefix p
+    let prefix = Path.(to_absolute_filename root) in
+    (if Sys.win32 || Sys.cygwin then String.Caseless.drop_prefix
+    else String.drop_prefix)
+      ~prefix p
     (* After dropping the prefix we need to remove the leading path separator *)
     |> Option.map ~f:(fun s -> String.drop s 1)
 

otherlibs/stdune/src/string.ml

@@ -42,45 +42,60 @@ let break s ~pos = (sub s ~pos:0 ~len:pos, sub s ~pos ~len:(length s - pos))
 
 let is_empty s = length s = 0
 
-let rec check_prefix s ~prefix len i =
-  i = len || (s.[i] = prefix.[i] && check_prefix s ~prefix len (i + 1))
-
-let rec check_suffix s ~suffix suffix_len offset i =
-  i = suffix_len
-  || s.[offset + i] = suffix.[i]
-     && check_suffix s ~suffix suffix_len offset (i + 1)
-
-let is_prefix s ~prefix =
-  let len = length s in
-  let prefix_len = length prefix in
-  len >= prefix_len && check_prefix s ~prefix prefix_len 0
-
-let is_suffix s ~suffix =
-  let len = length s in
-  let suffix_len = length suffix in
-  len >= suffix_len && check_suffix s ~suffix suffix_len (len - suffix_len) 0
-
-let drop_prefix s ~prefix =
-  if is_prefix s ~prefix then
-    if length s = length prefix then Some ""
-    else Some (sub s ~pos:(length prefix) ~len:(length s - length prefix))
-  else None
-
-let drop_prefix_if_exists s ~prefix =
-  match drop_prefix s ~prefix with
-  | None -> s
-  | Some s -> s
+module Cased_functions (X : sig
+  val normalize : char -> char
+end) =
+struct
+  let rec check_prefix s ~prefix len i =
+    i = len
+    || X.normalize s.[i] = X.normalize prefix.[i]
+       && check_prefix s ~prefix len (i + 1)
+
+  let rec check_suffix s ~suffix suffix_len offset i =
+    i = suffix_len
+    || X.normalize s.[offset + i] = X.normalize suffix.[i]
+       && check_suffix s ~suffix suffix_len offset (i + 1)
+
+  let is_prefix s ~prefix =
+    let len = length s in
+    let prefix_len = length prefix in
+    len >= prefix_len && check_prefix s ~prefix prefix_len 0
+
+  let is_suffix s ~suffix =
+    let len = length s in
+    let suffix_len = length suffix in
+    len >= suffix_len && check_suffix s ~suffix suffix_len (len - suffix_len) 0
+
+  let drop_prefix s ~prefix =
+    if is_prefix s ~prefix then
+      if length s = length prefix then Some ""
+      else Some (sub s ~pos:(length prefix) ~len:(length s - length prefix))
+    else None
+
+  let drop_prefix_if_exists s ~prefix =
+    match drop_prefix s ~prefix with
+    | None -> s
+    | Some s -> s
+
+  let drop_suffix s ~suffix =
+    if is_suffix s ~suffix then
+      if length s = length suffix then Some ""
+      else Some (sub s ~pos:0 ~len:(length s - length suffix))
+    else None
+
+  let drop_suffix_if_exists s ~suffix =
+    match drop_suffix s ~suffix with
+    | None -> s
+    | Some s -> s
+end
 
-let drop_suffix s ~suffix =
-  if is_suffix s ~suffix then
-    if length s = length suffix then Some ""
-    else Some (sub s ~pos:0 ~len:(length s - length suffix))
-  else None
+include Cased_functions (struct
+  let normalize c = c
+end)
 
-let drop_suffix_if_exists s ~suffix =
-  match drop_suffix s ~suffix with
-  | None -> s
-  | Some s -> s
+module Caseless = Cased_functions (struct
+  let normalize = Char.lowercase_ascii
+end)
 
 let extract_words s ~is_word_char =
   let rec skip_blanks i =

otherlibs/stdune/src/string.mli

@@ -37,6 +37,18 @@ val drop_suffix : t -> suffix:t -> t option
 
 val drop_suffix_if_exists : t -> suffix:t -> t
 
+module Caseless : sig
+  (** Case-insensitive matching semantics. *)
+
+  val drop_prefix : t -> prefix:t -> t option
+
+  val drop_prefix_if_exists : t -> prefix:t -> t
+
+  val drop_suffix : t -> suffix:t -> t option
+
+  val drop_suffix_if_exists : t -> suffix:t -> t
+end
+
 (** These only change ASCII characters *)
 val capitalize : t -> t
 

test/blackbox-tests/test-cases/merlin/github7577.t/run.t

@@ -0,0 +1,16 @@
+We check that the Merlin helper can handle filenames with capital letters in them.
+
+  $ cat >dune-project <<EOF
+  > (lang dune 3.7)
+  > EOF
+
+  $ touch mainFOO.ml
+
+  $ cat >dune <<EOF
+  > (executable (name mainFOO))
+  > EOF
+
+  $ dune build
+
+  $ printf '(4:File10:mainFOO.ml)4:Halt' | dune ocaml merlin start-session | grep ERROR
+  [1]