Fix unhandled cases for exotic idents

CHANGELOG.md

@@ -23,6 +23,10 @@
 - Remove obsolete `@bs.open` feature. https://github.com/rescript-lang/rescript-compiler/pull/6629
 - Drop Node.js version <18 support, due to it reaching End-of-Life. https://github.com/rescript-lang/rescript-compiler/pull/6429
 
+#### :bug: Bug Fix
+
+- Fix exotic ParscalCased identifiers for type names. https://github.com/rescript-lang/rescript-compiler/pull/6658
+
 #### :house: Internal
 
 - Build with OCaml 5.1.1. https://github.com/rescript-lang/rescript-compiler/pull/6641

jscomp/ext/ext_ident.ml

@@ -132,6 +132,23 @@ let [@inline] no_escape (c : char) =
   | '0' .. '9' | '_' | '$' -> true 
   | _ -> false
 
+let is_exotic name =
+  (* Exotic idents should always wrapped by \"..." *)
+  let len = String.length name in
+  len >= 3
+  && String.unsafe_get name 0 = '\\'
+  && String.unsafe_get name 1 = '\"'
+  && String.unsafe_get name (len - 1) = '\"'
+
+let wrap_exotic name = "\\\"" ^ name ^ "\""
+
+let unwrap_exotic name =
+  if is_exotic name then
+   let len = String.length name in
+   (* Exotic idents should always wrapped by \"..." *)
+   String.sub name 2 (len - 3)
+  else name
+
 exception Not_normal_letter of int
 let name_mangle name =
   let len = String.length name  in
@@ -162,7 +179,8 @@ let name_mangle name =
    a valid js identifier
 *)
 let convert (name : string) =
-  if  Js_reserved_map.is_reserved name  then
+  let name = unwrap_exotic name in
+  if Js_reserved_map.is_reserved name then
     "$$" ^ name
   else name_mangle name
 

jscomp/ext/ext_ident.mli

@@ -48,7 +48,11 @@ val create_tmp :  ?name:string -> unit -> Ident.t
 
 val make_unused : unit -> Ident.t 
 
+val is_exotic : string -> bool
 
+val wrap_exotic : string -> string
+
+val unwrap_exotic : string -> string
 
 (**
    Invariant: if name is not converted, the reference should be equal

jscomp/frontend/ast_external_process.ml

@@ -316,7 +316,8 @@ let parse_external_attributes (no_arguments : bool) (prim_name_check : string)
                          | Pexp_constant (Pconst_string (s, _)) -> (
                            match l.txt with
                            | Longident.Lident "type_" -> Some ("type", s)
-                           | Longident.Lident txt -> Some (txt, s)
+                           | Longident.Lident name ->
+                             Some (Ext_ident.unwrap_exotic name, s)
                            | _ ->
                              Location.raise_errorf ~loc:exp.pexp_loc
                                "Field must be a regular key.")

jscomp/gentype/GenTypeCommon.ml

@@ -60,7 +60,7 @@ let labelJSToString case =
   | BoolLabel b -> b |> string_of_bool
   | FloatLabel s -> s
   | IntLabel i -> i
-  | StringLabel s -> s |> EmitText.quotes
+  | StringLabel s -> s |> Ext_ident.unwrap_exotic |> EmitText.quotes
 
 type closedFlag = Open | Closed | Inline
 

jscomp/stdlib-406/release.ninja

@@ -12,7 +12,7 @@ o stdlib-406/pervasives.cmj : cc_cmi stdlib-406/pervasives.res | stdlib-406/perv
     bsc_flags = $bsc_flags -nopervasives
 o stdlib-406/pervasives.cmi : cc stdlib-406/pervasives.resi | $bsc others
     bsc_flags = $bsc_flags -nopervasives
-o stdlib-406/arg.cmj : cc_cmi stdlib-406/arg.res | stdlib-406/arg.cmi stdlib-406/array.cmj stdlib-406/buffer.cmj stdlib-406/list.cmj stdlib-406/string.cmj stdlib-406/sys.cmj $bsc others
+o stdlib-406/arg.cmj : cc_cmi stdlib-406/arg.res | stdlib-406/arg.cmi stdlib-406/array.cmj stdlib-406/buffer.cmj stdlib-406/list.cmj stdlib-406/set.cmj stdlib-406/string.cmj stdlib-406/sys.cmj $bsc others
 o stdlib-406/arg.cmi : cc stdlib-406/arg.resi | stdlib-406/pervasives.cmj $bsc others
 o stdlib-406/array.cmj : cc_cmi stdlib-406/array.res | stdlib-406/array.cmi $bsc others
 o stdlib-406/array.cmi : cc stdlib-406/array.resi | stdlib-406/pervasives.cmj $bsc others

jscomp/syntax/src/jsx_v4.ml

@@ -916,7 +916,7 @@ let mapBinding ~config ~emptyLoc ~pstr_loc ~fileName ~recFlag binding =
       }
     in
     let fnName = getFnName binding.pvb_pat in
-    let internalFnName = fnName ^ "$Internal" in
+    let internalFnName = Ext_ident.wrap_exotic (fnName ^ "$Internal") in
     let fullModuleName = makeModuleName fileName config.nestedModules fnName in
     let bindingWrapper, hasForwardRef, expression =
       modifiedBinding ~bindingLoc ~bindingPatLoc ~fnName binding
@@ -988,6 +988,7 @@ let mapBinding ~config ~emptyLoc ~pstr_loc ~fileName ~recFlag binding =
       match fullModuleName with
       | "" -> fullExpression
       | txt ->
+        let txt = Ext_ident.wrap_exotic txt in
         Exp.let_ Nonrecursive
           [
             Vb.mk ~loc:emptyLoc

jscomp/syntax/src/reactjs_jsx_v3.ml

@@ -151,7 +151,7 @@ let getPropsNameValue _acc (loc, exp) =
 
 (* Lookup the `props` record or string as part of [@react.component] and store the name for use when rewriting *)
 let getPropsAttr payload =
-  let defaultProps = {propsName = "Props"} in
+  let defaultProps = {propsName = Ext_ident.wrap_exotic "Props"} in
   match payload with
   | Some
       (PStr
@@ -317,7 +317,8 @@ let makeExternalDecl fnName loc namedArgListWithKeyAndRef namedTypeList =
     (makePropsType ~loc namedTypeList)
 
 let newtypeToVar newtype type_ =
-  let var_desc = Ptyp_var ("type-" ^ newtype) in
+  let newtype_label = Ext_ident.wrap_exotic ("type-" ^ newtype) in
+  let var_desc = Ptyp_var newtype_label in
   let typ (mapper : Ast_mapper.mapper) typ =
     match typ.ptyp_desc with
     | Ptyp_constr ({txt = Lident name}, _) when name = newtype ->
@@ -970,6 +971,7 @@ let jsxMapper ~config =
             match fullModuleName with
             | "" -> fullExpression
             | txt ->
+              let txt = Ext_ident.wrap_exotic txt in
               Exp.let_ Nonrecursive
                 [
                   Vb.mk ~loc:emptyLoc

jscomp/syntax/src/res_ast_debugger.ml

@@ -54,7 +54,7 @@ module SexpAst = struct
     | [] -> [Sexp.list []]
     | items -> List.map f items
 
-  let string txt = Sexp.atom ("\"" ^ txt ^ "\"")
+  let string txt = Sexp.atom ("\"" ^ Ext_ident.unwrap_exotic txt ^ "\"")
 
   let char c = Sexp.atom ("'" ^ Char.escaped c ^ "'")
 
@@ -910,11 +910,19 @@ module SexpAst = struct
 
   and attribute (stringLoc, p) =
     Sexp.list
-      [Sexp.atom "attribute"; Sexp.atom stringLoc.Asttypes.txt; payload p]
+      [
+        Sexp.atom "attribute";
+        Sexp.atom (Ext_ident.unwrap_exotic stringLoc.Asttypes.txt);
+        payload p;
+      ]
 
   and extension (stringLoc, p) =
     Sexp.list
-      [Sexp.atom "extension"; Sexp.atom stringLoc.Asttypes.txt; payload p]
+      [
+        Sexp.atom "extension";
+        Sexp.atom (Ext_ident.unwrap_exotic stringLoc.Asttypes.txt);
+        payload p;
+      ]
 
   and attributes attrs =
     let sexprs = mapEmpty ~f:attribute attrs in

jscomp/syntax/src/res_outcome_printer.ml

@@ -8,70 +8,7 @@
  * In general it represent messages to show results or errors to the user. *)
 
 module Doc = Res_doc
-module Token = Res_token
-
-let rec unsafe_for_all_range s ~start ~finish p =
-  start > finish
-  || p (String.unsafe_get s start)
-     && unsafe_for_all_range s ~start:(start + 1) ~finish p
-
-let for_all_from s start p =
-  let len = String.length s in
-  unsafe_for_all_range s ~start ~finish:(len - 1) p
-
-(* See https://github.com/rescript-lang/rescript-compiler/blob/726cfa534314b586e5b5734471bc2023ad99ebd9/jscomp/ext/ext_string.ml#L510 *)
-let isValidNumericPolyvarNumber (x : string) =
-  let len = String.length x in
-  len > 0
-  &&
-  let a = Char.code (String.unsafe_get x 0) in
-  a <= 57
-  &&
-  if len > 1 then
-    a > 48
-    && for_all_from x 1 (function
-         | '0' .. '9' -> true
-         | _ -> false)
-  else a >= 48
-
-type identifierStyle = ExoticIdent | NormalIdent
-
-let classifyIdentContent ~allowUident txt =
-  let len = String.length txt in
-  let rec go i =
-    if i == len then NormalIdent
-    else
-      let c = String.unsafe_get txt i in
-      if
-        i == 0
-        && not
-             ((allowUident && c >= 'A' && c <= 'Z')
-             || (c >= 'a' && c <= 'z')
-             || c = '_')
-      then ExoticIdent
-      else if
-        not
-          ((c >= 'a' && c <= 'z')
-          || (c >= 'A' && c <= 'Z')
-          || c = '\'' || c = '_'
-          || (c >= '0' && c <= '9'))
-      then ExoticIdent
-      else go (i + 1)
-  in
-  if Token.isKeywordTxt txt then ExoticIdent else go 0
-
-let printIdentLike ~allowUident txt =
-  match classifyIdentContent ~allowUident txt with
-  | ExoticIdent -> Doc.concat [Doc.text "\\\""; Doc.text txt; Doc.text "\""]
-  | NormalIdent -> Doc.text txt
-
-let printPolyVarIdent txt =
-  (* numeric poly-vars don't need quotes: #644 *)
-  if isValidNumericPolyvarNumber txt then Doc.text txt
-  else
-    match classifyIdentContent ~allowUident:true txt with
-    | ExoticIdent -> Doc.concat [Doc.text "\""; Doc.text txt; Doc.text "\""]
-    | NormalIdent -> Doc.text txt
+module Printer = Res_printer
 
 (* ReScript doesn't have parenthesized identifiers.
  * We don't support custom operators. *)
@@ -117,9 +54,9 @@ let escapeStringContents s =
      print_ident fmt id2;
      Format.pp_print_char fmt ')' *)
 
-let rec printOutIdentDoc ?(allowUident = true) (ident : Outcometree.out_ident) =
+let rec printOutIdentDoc (ident : Outcometree.out_ident) =
   match ident with
-  | Oide_ident s -> printIdentLike ~allowUident s
+  | Oide_ident s -> Doc.text s
   | Oide_dot (ident, s) ->
     Doc.concat [printOutIdentDoc ident; Doc.dot; Doc.text s]
   | Oide_apply (call, arg) ->
@@ -188,9 +125,7 @@ let rec printOutTypeDoc (outType : Outcometree.out_type) =
                   [
                     Doc.space;
                     Doc.join ~sep:Doc.space
-                      (List.map
-                         (fun lbl -> printIdentLike ~allowUident:true lbl)
-                         tags);
+                      (List.map (fun lbl -> Doc.text lbl) tags);
                   ]));
            Doc.softLine;
            Doc.rbracket;
@@ -220,7 +155,7 @@ let rec printOutTypeDoc (outType : Outcometree.out_type) =
   | Otyp_constr (Oide_ident "function$", [Otyp_var _; _arity]) ->
     (* function$<'a, arity> -> _ => _ *)
     printOutTypeDoc (Otyp_stuff "_ => _")
-  | Otyp_constr (outIdent, []) -> printOutIdentDoc ~allowUident:false outIdent
+  | Otyp_constr (outIdent, []) -> printOutIdentDoc outIdent
   | Otyp_manifest (typ1, typ2) ->
     Doc.concat [printOutTypeDoc typ1; Doc.text " = "; printOutTypeDoc typ2]
   | Otyp_record record -> printRecordDeclarationDoc ~inline:true record
@@ -400,7 +335,7 @@ and printOutVariant variant =
                  (Doc.concat
                     [
                       Doc.text "#";
-                      printPolyVarIdent name;
+                      Printer.printPolyVarIdent name;
                       (match types with
                       | [] -> Doc.nil
                       | types ->
@@ -530,7 +465,7 @@ and printRecordDeclRowDoc (name, mut, opt, arg) =
     (Doc.concat
        [
          (if mut then Doc.text "mutable " else Doc.nil);
-         printIdentLike ~allowUident:false name;
+         Doc.text name;
          (if opt then Doc.text "?" else Doc.nil);
          Doc.text ": ";
          printOutTypeDoc arg;
@@ -733,7 +668,7 @@ let rec printOutSigItemDoc ?(printNameAsIs = false)
                   attrs;
                   kw;
                   (if printNameAsIs then Doc.text outTypeDecl.otype_name
-                   else printIdentLike ~allowUident:false outTypeDecl.otype_name);
+                   else Doc.text outTypeDecl.otype_name);
                   typeParams;
                   kind;
                 ]);
@@ -865,7 +800,7 @@ and printOutExtensionConstructorDoc
     (Doc.concat
        [
          Doc.text "type ";
-         printIdentLike ~allowUident:false outExt.oext_type_name;
+         Doc.text outExt.oext_type_name;
          typeParams;
          Doc.text " += ";
          Doc.line;
@@ -904,7 +839,7 @@ and printOutTypeExtensionDoc (typeExtension : Outcometree.out_type_extension) =
     (Doc.concat
        [
          Doc.text "type ";
-         printIdentLike ~allowUident:false typeExtension.otyext_name;
+         Doc.text typeExtension.otyext_name;
          typeParams;
          Doc.text " += ";
          (if typeExtension.otyext_private = Asttypes.Private then