Change char payload (#5759)

butterunderflow · bobzhang · commit 2b510e032a6b · 2022-10-31T17:08:19.000+08:00
* change Pconst_char payload (WIP)

* tweak

* tweak

* representation of char for lambda

* lib

* bugfix: replace wrong pp

* libs

* bugfix: replace wrong print

* use unsafe_chr to handle possible overflow char

* safe print int as char

* reduce duplication

* (re)use encodeCodepoint to support string_of_int_as_char

* some refactor

* libs

* changelog
diff --git a/CHANGELOG.md b/CHANGELOG.md
@@ -73,6 +73,7 @@
 - Add `loading`, `aria-*` DOM element attributes in `JsxDOM.domProps`: `ariaCurrent`, `ariaInvalid`, `ariaAutocomplete`, etc.
 - Change the internal representation of props for the lowercase components to record. https://github.com/rescript-lang/syntax/pull/665
 - Add `JsxPPXReactSupport` module to relocate the helper functions for JSX v4 from `rescript-react`
+- Change the payload of Pconst_char for type safety. https://github.com/rescript-lang/syntax/pull/709
 
 # 10.1.0-alpha.2
 
diff --git a/jscomp/core/js_dump.ml b/jscomp/core/js_dump.ml
@@ -630,7 +630,7 @@ and expression_desc cxt ~(level : int) f x : cxt =
         match v with
         | Float { f } -> Js_number.caml_float_literal_to_js_string f
         (* attach string here for float constant folding?*)
-        | Int { i; c = Some c } -> Format.asprintf "/* %C */%ld" c i
+        | Int { i; c = Some c } -> Format.asprintf "/* %s */%ld" (Ext_util.string_of_int_as_char c) i
         | Int { i; c = None } ->
             Int32.to_string i
             (* check , js convention with ocaml lexical convention *)
diff --git a/jscomp/core/js_exp_make.mli b/jscomp/core/js_exp_make.mli
@@ -103,7 +103,7 @@ val method_ :
 
 val econd : ?comment:string -> t -> t -> t -> t
 
-val int : ?comment:string -> ?c:char -> int32 -> t
+val int : ?comment:string -> ?c:int -> int32 -> t
 
 val uint32 : ?comment:string -> int32 -> t
 
diff --git a/jscomp/core/js_of_lam_string.ml b/jscomp/core/js_of_lam_string.ml
@@ -29,7 +29,7 @@ module E = Js_exp_make
     currently, it follows the same patten of ocaml, [char] is [int]
 *)
 
-let const_char (i : char) = E.int ~c:i (Int32.of_int @@ Char.code i)
+let const_char (i : int) = E.int ~c:i (Int32.of_int @@ i)
 
 (* string [s[i]] expects to return a [ocaml_char] *)
 let ref_string e e1 = E.string_index e e1
diff --git a/jscomp/core/js_of_lam_string.mli b/jscomp/core/js_of_lam_string.mli
@@ -34,6 +34,6 @@ val ref_byte : J.expression -> J.expression -> J.expression
 
 val set_byte : J.expression -> J.expression -> J.expression -> J.expression
 
-val const_char : char -> J.expression
+val const_char : int -> J.expression
 
 val bytes_to_string : J.expression -> J.expression
diff --git a/jscomp/core/js_op.ml b/jscomp/core/js_op.ml
@@ -126,7 +126,7 @@ type float_lit = { f : string } [@@unboxed]
 
 type number =
   | Float of float_lit
-  | Int of { i : int32; c : char option }
+  | Int of { i : int32; c : int option }
   | Uint of int32
 
 (* becareful when constant folding +/-,
diff --git a/jscomp/core/lam.ml b/jscomp/core/lam.ml
@@ -562,7 +562,7 @@ let prim ~primitive:(prim : Lam_primitive.t) ~args loc : t =
       | ( (Pstringrefs | Pstringrefu),
           Const_string { s = a; unicode = false },
           Const_int { i = b } ) -> (
-          try Lift.char (String.get a (Int32.to_int b)) with _ -> default ())
+          try Lift.char (Char.code (String.get a (Int32.to_int b))) with _ -> default ())
       | _ -> default ())
   | _ -> (
       match prim with
@@ -633,7 +633,7 @@ let rec complete_range (sw_consts : (int * _) list) ~(start : int) ~finish =
 let rec eval_const_as_bool (v : Lam_constant.t) : bool =
   match v with
   | Const_int { i = x } -> x <> 0l
-  | Const_char x -> Char.code x <> 0
+  | Const_char x -> x <> 0
   | Const_int64 x -> x <> 0L
   | Const_js_false | Const_js_null | Const_module_alias | Const_js_undefined ->
       false
diff --git a/jscomp/core/lam_constant.ml b/jscomp/core/lam_constant.ml
@@ -42,7 +42,7 @@ type t =
   | Const_js_true
   | Const_js_false
   | Const_int of { i : int32; comment : pointer_info }
-  | Const_char of char
+  | Const_char of int
   | Const_string of { s : string; unicode : bool }
   | Const_float of string
   | Const_int64 of int64
diff --git a/jscomp/core/lam_constant.mli b/jscomp/core/lam_constant.mli
@@ -38,7 +38,7 @@ type t =
   | Const_js_true
   | Const_js_false
   | Const_int of { i : int32; comment : pointer_info }
-  | Const_char of char
+  | Const_char of int
   | Const_string of { s : string; unicode : bool }
   | Const_float of string
   | Const_int64 of int64
diff --git a/jscomp/core/lam_pass_lets_dce.ml b/jscomp/core/lam_pass_lets_dce.ml
@@ -209,7 +209,7 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t =
           |Lconst((Const_int {i})) -> 
             let i = Int32.to_int i in
             if i < String.length l_s && i >= 0  then
-              Lam.const ((Const_char l_s.[i]))
+              Lam.const ((Const_char (Char.code l_s.[i])))
             else 
               Lam.prim ~primitive ~args:[l';r'] loc 
           | _ -> 
diff --git a/jscomp/core/lam_pass_lets_dce.pp.ml b/jscomp/core/lam_pass_lets_dce.pp.ml
@@ -208,7 +208,7 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t =
           |Lconst((Const_int {i})) -> 
             let i = Int32.to_int i in
             if i < String.length l_s && i >= 0  then
-              Lam.const ((Const_char l_s.[i]))
+              Lam.const ((Const_char (Char.code l_s.[i])))
             else 
               Lam.prim ~primitive ~args:[l';r'] loc 
           | _ -> 
diff --git a/jscomp/core/lam_print.ml b/jscomp/core/lam_print.ml
@@ -21,7 +21,7 @@ let rec struct_const ppf (cst : Lam_constant.t) =
   | Const_module_alias -> fprintf ppf "#alias"
   | Const_js_undefined -> fprintf ppf "#undefined"
   | Const_int { i } -> fprintf ppf "%ld" i
-  | Const_char c -> fprintf ppf "%C" c
+  | Const_char i -> fprintf ppf "%s" (Ext_util.string_of_int_as_char i)
   | Const_string { s } -> fprintf ppf "%S" s
   | Const_float f -> fprintf ppf "%s" f
   | Const_int64 n -> fprintf ppf "%LiL" n
diff --git a/jscomp/ext/ext_utf8.ml b/jscomp/ext/ext_utf8.ml
@@ -92,3 +92,40 @@ let decode_utf8_string s =
 
 (* let verify s loc =
    assert false *)
+
+let encode_codepoint c =
+  (* reused from syntax/src/res_utf8.ml *)
+  let h2 = 0b1100_0000 in
+  let h3 = 0b1110_0000 in
+  let h4 = 0b1111_0000 in
+  let cont_mask = 0b0011_1111 in
+  if c <= 127 then (
+    let bytes = (Bytes.create [@doesNotRaise]) 1 in
+    Bytes.unsafe_set bytes 0 (Char.unsafe_chr c);
+    Bytes.unsafe_to_string bytes)
+  else if c <= 2047 then (
+    let bytes = (Bytes.create [@doesNotRaise]) 2 in
+    Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h2 lor (c lsr 6)));
+    Bytes.unsafe_set bytes 1
+      (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask)));
+    Bytes.unsafe_to_string bytes)
+  else if c <= 65535 then (
+    let bytes = (Bytes.create [@doesNotRaise]) 3 in
+    Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h3 lor (c lsr 12)));
+    Bytes.unsafe_set bytes 1
+      (Char.unsafe_chr (0b1000_0000 lor ((c lsr 6) land cont_mask)));
+    Bytes.unsafe_set bytes 2
+      (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask)));
+    Bytes.unsafe_to_string bytes)
+  else
+    (* if c <= max then *)
+    let bytes = (Bytes.create [@doesNotRaise]) 4 in
+    Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h4 lor (c lsr 18)));
+    Bytes.unsafe_set bytes 1
+      (Char.unsafe_chr (0b1000_0000 lor ((c lsr 12) land cont_mask)));
+    Bytes.unsafe_set bytes 2
+      (Char.unsafe_chr (0b1000_0000 lor ((c lsr 6) land cont_mask)));
+    Bytes.unsafe_set bytes 3
+      (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask)));
+    Bytes.unsafe_to_string bytes
+
diff --git a/jscomp/ext/ext_utf8.mli b/jscomp/ext/ext_utf8.mli
@@ -36,3 +36,5 @@ val next : string -> remaining:int -> int -> int
 exception Invalid_utf8 of string
 
 val decode_utf8_string : string -> int list
+
+val encode_codepoint : int -> string
diff --git a/jscomp/ext/ext_util.ml b/jscomp/ext/ext_util.ml
@@ -40,3 +40,20 @@ let stats_to_string
     num_buckets max_bucket_length
     (String.concat ","
        (Array.to_list (Array.map string_of_int bucket_histogram)))
+
+let string_of_int_as_char i =
+  let str = match Char.unsafe_chr i with
+    | '\'' -> "\\'"
+    | '\\' -> "\\\\"
+    | '\n' -> "\\n"
+    | '\t' -> "\\t"
+    | '\r' -> "\\r"
+    | '\b' -> "\\b"
+    | ' ' .. '~' as c ->
+      let s = (Bytes.create [@doesNotRaise]) 1 in
+      Bytes.unsafe_set s 0 c;
+      Bytes.unsafe_to_string s
+    | _ ->  Ext_utf8.encode_codepoint i
+  in
+  Printf.sprintf "\'%s\'" str
+
diff --git a/jscomp/ext/ext_util.mli b/jscomp/ext/ext_util.mli
@@ -25,3 +25,6 @@
 val power_2_above : int -> int -> int
 
 val stats_to_string : Hashtbl.statistics -> string
+
+val string_of_int_as_char : int -> string
+
diff --git a/jscomp/ml/ast_helper.ml b/jscomp/ml/ast_helper.ml
@@ -39,7 +39,7 @@ module Const = struct
   let int64 ?(suffix='L') i = integer ~suffix (Int64.to_string i)
   let nativeint ?(suffix='n') i = integer ~suffix (Nativeint.to_string i)
   let float ?suffix f = Pconst_float (f, suffix)
-  let char c = Pconst_char c
+  let char c = Pconst_char (Char.code c)
   let string ?quotation_delimiter s = Pconst_string (s, quotation_delimiter)
 end
 
diff --git a/jscomp/ml/asttypes.ml b/jscomp/ml/asttypes.ml
@@ -17,7 +17,7 @@
 
 type constant =
     Const_int of int
-  | Const_char of char
+  | Const_char of int
   | Const_string of string * string option
   | Const_float of string
   | Const_int32 of int32
@@ -70,4 +70,4 @@ let same_arg_label (x : arg_label) y =
       begin match y with 
       | Optional s0 -> s = s0
       | _ -> false  
-      end  
+      end  
diff --git a/jscomp/ml/matching.ml b/jscomp/ml/matching.ml
@@ -2202,7 +2202,7 @@ let combine_constant names loc arg cst partial ctx def
         call_switcher loc fail arg min_int max_int int_lambda_list names
     | Const_char _ ->
         let int_lambda_list =
-          List.map (function Const_char c, l -> (Char.code c, l)
+          List.map (function Const_char c, l -> (c, l)
             | _ -> assert false)
             const_lambda_list in
         call_switcher loc fail arg 0 max_int int_lambda_list names
diff --git a/jscomp/ml/parmatch.ml b/jscomp/ml/parmatch.ml
@@ -379,7 +379,7 @@ let is_cons = function
 
 let pretty_const c = match c with
 | Const_int i -> Printf.sprintf "%d" i
-| Const_char c -> Printf.sprintf "%C" c
+| Const_char i -> Printf.sprintf "%s" (Pprintast.string_of_int_as_char i)
 | Const_string (s, _) -> Printf.sprintf "%S" s
 | Const_float f -> Printf.sprintf "%s" f
 | Const_int32 i -> Printf.sprintf "%ldl" i
diff --git a/jscomp/ml/parser.ml b/jscomp/ml/parser.ml
@@ -11015,7 +11015,7 @@ let yyact = [|
     let _1 = (Parsing.peek_val __caml_parser_env 0 : char) in
     Obj.repr(
 # 2155 "ml/parser.mly"
-                 ( Pconst_char _1 )
+                 ( Pconst_char (Char.code _1) )
 # 11020 "ml/parser.ml"
                : 'constant))
 ; (fun __caml_parser_env ->
diff --git a/jscomp/ml/parser.mly b/jscomp/ml/parser.mly
@@ -2152,7 +2152,7 @@ label:
 
 constant:
   | INT          { let (n, m) = $1 in Pconst_integer (n, m) }
-  | CHAR         { Pconst_char $1 }
+  | CHAR         { Pconst_char (Char.code $1) }
   | STRING       { let (s, d) = $1 in Pconst_string (s, d) }
   | FLOAT        { let (f, m) = $1 in Pconst_float (f, m) }
 ;
diff --git a/jscomp/ml/parsetree.ml b/jscomp/ml/parsetree.ml
@@ -24,7 +24,7 @@ type constant =
      Suffixes [g-z][G-Z] are accepted by the parser.
      Suffixes except 'l', 'L' and 'n' are rejected by the typechecker
   *)
-  | Pconst_char of char
+  | Pconst_char of int
   (* 'c' *)
   | Pconst_string of string * string option
   (* "constant"
diff --git a/jscomp/ml/pprintast.ml b/jscomp/ml/pprintast.ml
@@ -192,8 +192,10 @@ let rec longident f = function
 
 let longident_loc f x = pp f "%a" longident x.txt
 
+let string_of_int_as_char i = Ext_utf8.encode_codepoint i
+
 let constant f = function
-  | Pconst_char i -> pp f "%C"  i
+  | Pconst_char i -> pp f "%s"  (string_of_int_as_char i)
   | Pconst_string (i, None) -> pp f "%S" i
   | Pconst_string (i, Some delim) -> pp f "{%s|%s|%s}" delim i delim
   | Pconst_integer (i, None) -> paren (i.[0]='-') (fun f -> pp f "%s") f i
@@ -770,7 +772,7 @@ and value_description ctxt f x =
   pp f "@[<hov2>%a%a@]" (core_type ctxt) x.pval_type
     (fun f x ->
       
-# 772 "ml/pprintast.pp.ml"
+# 774 "ml/pprintast.pp.ml"
       match x.pval_prim with 
       | first :: second :: _ 
         when Ext_string.first_marshal_char second
@@ -783,7 +785,7 @@ and value_description ctxt f x =
         pp f "@ =@ %a" (list constant_string) x.pval_prim
       
     
-# 787 "ml/pprintast.pp.ml"
+# 789 "ml/pprintast.pp.ml"
     ) x
 
 and extension ctxt f (s, e) =
diff --git a/jscomp/ml/pprintast.mli b/jscomp/ml/pprintast.mli
@@ -24,3 +24,4 @@ val pattern: Format.formatter -> Parsetree.pattern -> unit
 val signature: Format.formatter -> Parsetree.signature -> unit
 val structure: Format.formatter -> Parsetree.structure -> unit
 val string_of_structure: Parsetree.structure -> string
+val string_of_int_as_char: int -> string
diff --git a/jscomp/ml/pprintast.pp.ml b/jscomp/ml/pprintast.pp.ml
@@ -191,8 +191,10 @@ let rec longident f = function
 
 let longident_loc f x = pp f "%a" longident x.txt
 
+let string_of_int_as_char i = Ext_util.string_of_int_as_char i
+
 let constant f = function
-  | Pconst_char i -> pp f "%C"  i
+  | Pconst_char i -> pp f "%s"  (string_of_int_as_char i)
   | Pconst_string (i, None) -> pp f "%S" i
   | Pconst_string (i, Some delim) -> pp f "{%s|%s|%s}" delim i delim
   | Pconst_integer (i, None) -> paren (i.[0]='-') (fun f -> pp f "%s") f i
diff --git a/jscomp/ml/printast.ml b/jscomp/ml/printast.ml
@@ -60,7 +60,7 @@ let fmt_char_option f = function
 let fmt_constant f x =
   match x with
   | Pconst_integer (i,m) -> fprintf f "PConst_int (%s,%a)" i fmt_char_option m;
-  | Pconst_char (c) -> fprintf f "PConst_char %02x" (Char.code c);
+  | Pconst_char (c) -> fprintf f "PConst_char %02x" c;
   | Pconst_string (s, None) -> fprintf f "PConst_string(%S,None)" s;
   | Pconst_string (s, Some delim) ->
       fprintf f "PConst_string (%S,Some %S)" s delim;
diff --git a/jscomp/ml/printlambda.ml b/jscomp/ml/printlambda.ml
@@ -21,7 +21,7 @@ open Lambda
 
 let rec struct_const ppf = function
   | Const_base(Const_int n) -> fprintf ppf "%i" n
-  | Const_base(Const_char c) -> fprintf ppf "%C" c
+  | Const_base(Const_char i) -> fprintf ppf "%s" (Pprintast.string_of_int_as_char i)
   | Const_base(Const_string (s, _)) -> fprintf ppf "%S" s
   | Const_immstring s -> fprintf ppf "#%S" s
   | Const_base(Const_float f) -> fprintf ppf "%s" f
diff --git a/jscomp/ml/printtyped.ml b/jscomp/ml/printtyped.ml
@@ -58,7 +58,7 @@ let fmt_path f x = fprintf f "\"%a\"" fmt_path_aux x;;
 let fmt_constant f x =
   match x with
   | Const_int (i) -> fprintf f "Const_int %d" i;
-  | Const_char (c) -> fprintf f "Const_char %02x" (Char.code c);
+  | Const_char (c) -> fprintf f "Const_char %02x" c;
   | Const_string (s, None) -> fprintf f "Const_string(%S,None)" s;
   | Const_string (s, Some delim) ->
       fprintf f "Const_string (%S,Some %S)" s delim;
diff --git a/jscomp/ml/typecore.ml b/jscomp/ml/typecore.ml
@@ -1009,7 +1009,7 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env
         else
           or_ ~loc:gloc
             (constant ~loc:gloc (Pconst_char c1))
-            (loop (Char.chr(Char.code c1 + 1)) c2)
+            (loop (c1 + 1) c2)
       in
       let p = if c1 <= c2 then loop c1 c2 else loop c2 c1 in
       let p = {p with ppat_loc=loc} in
diff --git a/jscomp/test/gpr_5753.js b/jscomp/test/gpr_5753.js
@@ -0,0 +1,6 @@
+'use strict';
+
+
+console.log(/* '文' */25991);
+
+/*  Not a pure module */
diff --git a/jscomp/test/gpr_5753.res b/jscomp/test/gpr_5753.res
@@ -0,0 +1,5 @@
+@@config({
+  flags : ["-w", "-8"]
+})
+
+'文'-> Js.log
diff --git a/jscomp/test/res_debug.js b/jscomp/test/res_debug.js
@@ -70,7 +70,7 @@ var v1 = {
   z: 3
 };
 
-var h = /* '\522' */128522;
+var h = /* '😊' */128522;
 
 var hey = "hello, 世界";
 
diff --git a/jscomp/test/string_unicode_test.js b/jscomp/test/string_unicode_test.js
@@ -47,9 +47,9 @@ function f(x) {
 
 eq("File \"string_unicode_test.ml\", line 27, characters 7-14", f(/* '{' */123), 0);
 
-eq("File \"string_unicode_test.ml\", line 28, characters 7-14", f(/* '\333' */333), 2);
+eq("File \"string_unicode_test.ml\", line 28, characters 7-14", f(/* 'ō' */333), 2);
 
-eq("File \"string_unicode_test.ml\", line 29, characters 7-14", f(/* '\444' */444), 3);
+eq("File \"string_unicode_test.ml\", line 29, characters 7-14", f(/* 'Ƽ' */444), 3);
 
 Mt.from_pair_suites("string_unicode_test.ml", suites.contents);
 
diff --git a/lib/4.06.1/rescript.ml b/lib/4.06.1/rescript.ml
diff --git a/lib/4.06.1/rescript.ml.d b/lib/4.06.1/rescript.ml.d
diff --git a/lib/4.06.1/unstable/all_ounit_tests.ml b/lib/4.06.1/unstable/all_ounit_tests.ml
diff --git a/lib/4.06.1/unstable/js_compiler.ml.d b/lib/4.06.1/unstable/js_compiler.ml.d
