Fix issue with pattern match escape. (#6062)

* Fix issue with pattern match escape.

Fixes #6060

The compiler's ppx was missing the same processing on patterns it performs on expressions in string constants: handles "js" string transformation. (On expressions it also handles "j" transformations).

Remove compiler error when it encounters pattern matching with processed string.

Changed compiler compilation to assume the cases in string switch are processed string.

There's still the overarching questions of whether the transformation should be performed in the parser instead.

* Remove unused file.

Author: cristianoc

CHANGELOG.md

@@ -15,6 +15,7 @@
 #### :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 -> J.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
@@ -126,7 +119,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 -> (
@@ -174,7 +167,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 *)