Fix issue with pattern match escape.

CHANGELOG.md

@@ -69,6 +69,9 @@ These are only breaking changes for unformatted code.
 
 #### :bug: Bug Fix
 - Fix implementation of directives https://github.com/rescript-lang/rescript-compiler/pull/6052
+- Fix issue if the `lib` dir is included in the sources of bsconfig.json https://github.com/rescript-lang/rescript-compiler/pull/6055
+- Fix issue with string escape in pattern match https://github.com/rescript-lang/rescript-compiler/pull/6062
+
 
 #### :rocket: New Feature
 - Add support for toplevel `await` https://github.com/rescript-lang/rescript-compiler/pull/6054

jscomp/core/js_dump.ml

@@ -1197,7 +1197,8 @@ and statement_desc top cxt f (s : J.statement_desc) : cxt =
       let cxt = P.paren_group f 1 (fun _ -> expression ~level:0 cxt f e) in
       P.space f;
       P.brace_vgroup f 1 (fun _ ->
-          let cxt = loop_case_clauses cxt f Js_dump_string.pp_string cc in
+          let pp_string f txt = ignore @@ expression_desc cxt ~level:0 f (Str {txt; delim=DStarJ}) in
+          let cxt = loop_case_clauses cxt f pp_string cc in
           match def with
           | None -> cxt
           | Some def ->

jscomp/core/lam_compile.ml

@@ -651,7 +651,7 @@ and compile_switch (switch_arg : Lam.t) (sw : Lam.lambda_switch)
 and compile_string_cases cxt switch_exp table default =
   compile_general_cases
     (fun _ -> None)
-    E.str E.string_equal cxt
+    (fun str -> E.str str ~delim:DStarJ) E.string_equal cxt
     (fun ?default ?declaration e clauses ->
       S.string_switch ?default ?declaration e clauses)
     switch_exp table default

jscomp/frontend/ast_utf8_string_interp.ml

@@ -330,10 +330,14 @@ module Delim = struct
     | Some "*j" -> Some DStarJ
     | _ -> None
 
+  type interpolation =
+    | Js (* string interpolation *)
+    | J (* old unsafe interpolation *)
+    | Unrecognized (* no interpolation: delimiter not recognized *)
   let parse_unprocessed = function
-    | "js" -> `string_interpolation
-    | "j" -> `old_unsafe_interpolation
-    | _ -> `no_interpolation
+    | "js" -> Js
+    | "j" -> J
+    | _ -> Unrecognized
 
   let escaped_j_delimiter = "*j" (* not user level syntax allowed *)
   let unescaped_j_delimiter = "j"
@@ -397,16 +401,28 @@ let transform_interp loc s =
   with Error (start, pos, error) ->
     Location.raise_errorf ~loc:(update border start pos loc) "%a" pp_error error
 
-let transform (e : Parsetree.expression) s delim : Parsetree.expression =
+let transform_exp (e : Parsetree.expression) s delim : Parsetree.expression =
   match Delim.parse_unprocessed delim with
-  | `string_interpolation ->
+  | Js ->
       let js_str = Ast_utf8_string.transform e.pexp_loc s in
       {
         e with
         pexp_desc = Pexp_constant (Pconst_string (js_str, Delim.escaped));
       }
-  | `old_unsafe_interpolation -> transform_interp e.pexp_loc s
-  | `no_interpolation -> e
+  | J -> transform_interp e.pexp_loc s
+  | Unrecognized -> e
+
+
+let transform_pat (p : Parsetree.pattern) s delim : Parsetree.pattern =
+  match Delim.parse_unprocessed delim with
+  | Js ->
+      let js_str = Ast_utf8_string.transform p.ppat_loc s in
+      {
+        p with
+        ppat_desc = Ppat_constant (Pconst_string (js_str, Delim.escaped));
+      }
+  | J (* No j interpolation on patterns *)
+  | Unrecognized -> p
 
 let is_unicode_string opt = Ext_string.equal opt Delim.escaped_j_delimiter
 

jscomp/frontend/ast_utf8_string_interp.mli

@@ -55,7 +55,8 @@ type exn += Error of pos * pos * error
 
 val empty_segment : segment -> bool
 val transform_test : string -> segment list
-val transform : Parsetree.expression -> string -> string -> Parsetree.expression
+val transform_exp : Parsetree.expression -> string -> string -> Parsetree.expression
+val transform_pat : Parsetree.pattern -> string -> string -> Parsetree.pattern
 val is_unicode_string : string -> bool
 val is_unescaped : string -> bool
 val parse_processed_delim : string option -> External_arg_spec.delim option

jscomp/frontend/bs_ast_invariant.ml

@@ -70,19 +70,12 @@ type iterator = Ast_iterator.iterator
 
 let super = Ast_iterator.default_iterator
 
-let check_constant loc kind (const : Parsetree.constant) =
+let check_constant loc (const : Parsetree.constant) =
   match const with
-  | Pconst_string (_, Some s) -> (
-      match kind with
-      | `expr ->
-          if Ast_utf8_string_interp.is_unescaped s then
-            Bs_warnings.error_unescaped_delimiter loc s
-      | `pat ->
-          if Ast_utf8_string_interp.parse_processed_delim (Some s) = Some DStarJ
-          then
-            Location.raise_errorf ~loc
-              "Unicode string is not allowed in pattern match")
-  | Pconst_integer (s, None) -> (
+  | Pconst_string (_, Some s) ->
+      if Ast_utf8_string_interp.is_unescaped s then
+        Bs_warnings.error_unescaped_delimiter loc s
+| Pconst_integer (s, None) -> (
       (* range check using int32
          It is better to give a warning instead of error to avoid make people unhappy.
          It also has restrictions in which platform bsc is running on since it will
@@ -124,7 +117,7 @@ let emit_external_warnings : iterator =
     expr =
       (fun self ({ pexp_loc = loc } as a) ->
         match a.pexp_desc with
-        | Pexp_constant const -> check_constant loc `expr const
+        | Pexp_constant const -> check_constant loc const
         | Pexp_object _ | Pexp_new _ ->
             Location.raise_errorf ~loc "OCaml style objects are not supported"
         | Pexp_variant (s, None) when Ext_string.is_valid_hash_number s -> (
@@ -173,7 +166,7 @@ let emit_external_warnings : iterator =
     pat =
       (fun self (pat : Parsetree.pattern) ->
         match pat.ppat_desc with
-        | Ppat_constant constant -> check_constant pat.ppat_loc `pat constant
+        | Ppat_constant constant -> check_constant pat.ppat_loc constant
         | Ppat_record ([], _) ->
             Location.raise_errorf ~loc:pat.ppat_loc
               "Empty record pattern is not supported"

jscomp/frontend/bs_builtin_ppx.ml

@@ -64,11 +64,13 @@ let default_mapper = Bs_ast_mapper.default_mapper
 let default_expr_mapper = Bs_ast_mapper.default_mapper.expr
 let default_pat_mapper = Bs_ast_mapper.default_mapper.pat
 
-let pat_mapper (self : mapper) (e : Parsetree.pattern) =
-  match e.ppat_desc with
+let pat_mapper (self : mapper) (p : Parsetree.pattern) =
+  match p.ppat_desc with
   | Ppat_constant (Pconst_integer (s, Some 'l')) ->
-      { e with ppat_desc = Ppat_constant (Pconst_integer (s, None)) }
-  | _ -> default_pat_mapper self e
+      { p with ppat_desc = Ppat_constant (Pconst_integer (s, None)) }
+  | Ppat_constant (Pconst_string (s, Some delim)) ->
+      Ast_utf8_string_interp.transform_pat p s delim
+  | _ -> default_pat_mapper self p
 
 let expr_mapper ~async_context ~in_function_def (self : mapper)
     (e : Parsetree.expression) =
@@ -98,7 +100,7 @@ let expr_mapper ~async_context ~in_function_def (self : mapper)
              (Nolabel, expr);
            ])
   | Pexp_constant (Pconst_string (s, Some delim)) ->
-      Ast_utf8_string_interp.transform e s delim
+      Ast_utf8_string_interp.transform_exp e s delim
   | Pexp_constant (Pconst_integer (s, Some 'l')) ->
       { e with pexp_desc = Pexp_constant (Pconst_integer (s, None)) }
   (* End rewriting *)

jscomp/test/switch_case_test.js

@@ -29,10 +29,10 @@ function eq(loc, x, y) {
 
 function f(x) {
   switch (x) {
-    case "xx\"" :
-        return 1;
     case "xx'''" :
         return 0;
+    case "xx\"" :
+        return 1;
     case "xx\\\"" :
         return 2;
     case "xx\\\"\"" :
@@ -42,13 +42,13 @@ function f(x) {
   }
 }
 
-eq("File \"switch_case_test.ml\", line 19, characters 7-14", f("xx'''"), 0);
+eq("File \"switch_case_test.res\", line 19, characters 5-12", f("xx'''"), 0);
 
-eq("File \"switch_case_test.ml\", line 20, characters 7-14", f("xx\""), 1);
+eq("File \"switch_case_test.res\", line 20, characters 5-12", f("xx\""), 1);
 
-eq("File \"switch_case_test.ml\", line 21, characters 7-14", f("xx\\\""), 2);
+eq("File \"switch_case_test.res\", line 21, characters 5-12", f("xx\\\""), 2);
 
-eq("File \"switch_case_test.ml\", line 22, characters 7-14", f("xx\\\"\""), 3);
+eq("File \"switch_case_test.res\", line 22, characters 5-12", f("xx\\\"\""), 3);
 
 Mt.from_pair_suites("Switch_case_test", suites.contents);
 

jscomp/test/switch_case_test.res

@@ -0,0 +1,24 @@
+let suites: ref<Mt.pair_suites> = ref(list{})
+let test_id = ref(0)
+let eq = (loc, x, y) => {
+  incr(test_id)
+  suites :=
+    list{(loc ++ (" id " ++ string_of_int(test_id.contents)), _ => Mt.Eq(x, y)), ...suites.contents}
+}
+
+let f = x =>
+  switch x {
+  | "xx'''" => 0
+  | "xx\"" => 1
+  | `xx\\"` => 2
+  | `xx\\""` => 3
+  | _ => 4
+  }
+
+let () = {
+  eq(__LOC__, f("xx'''"), 0)
+  eq(__LOC__, f("xx\""), 1)
+  eq(__LOC__, f(`xx\\"`), 2)
+  eq(__LOC__, f(`xx\\""`), 3)
+}
+let () = Mt.from_pair_suites(__MODULE__, suites.contents)

jscomp/test/switch_string.js

@@ -0,0 +1,28 @@
+'use strict';
+
+
+function foo(x) {
+  if (x === "\"") {
+    return "\"";
+  } else {
+    return "";
+  }
+}
+
+function bar(x) {
+  switch (x) {
+    case "\\" :
+        return "\\";
+    case "😀" :
+        return "😀";
+    default:
+      return "";
+  }
+}
+
+var s = "😀";
+
+exports.foo = foo;
+exports.s = s;
+exports.bar = bar;
+/* No side effect */

jscomp/test/switch_string.res

@@ -0,0 +1,13 @@
+let foo = x =>
+  switch x {
+  | "\"" => "\""
+  | _ => ""
+  }
+
+let s = "😀"
+
+let bar = x => switch x {
+  | "\\" => "\\"
+  | "😀" => "😀"
+  | _ => ""
+}