rescript-lang · cristianoc · Mar 24, 2023 · Mar 20, 2023 · Mar 20, 2023 · Mar 20, 2023
diff --git a/CHANGELOG.md b/CHANGELOG.md
@@ -44,6 +44,8 @@ These are only breaking changes for unformatted code.
 - Exponentiation operator `**` is now right-associative. `2. ** 3. ** 2.` now compile to `Math.pow(2, Math.pow(3, 2))` and not anymore `Math.pow(Math.pow(2, 3), 2)`. Parentheses can be used to change precedence.
 - Remove unsafe ``` j`$(a)$(b)` ``` interpolation deprecated in compiler version 10 https://github.com/rescript-lang/rescript-compiler/pull/6068
 - Remove deprecated module `Printexc`
+- `@deriving(jsConverter)` not supported anymore for variant types https://github.com/rescript-lang/rescript-compiler/pull/6088
+- New representation for variants, where the tag is a string instead of a number. https://github.com/rescript-lang/rescript-compiler/pull/6088
 
 #### :bug: Bug Fix
 

diff --git a/jscomp/build_tests/white space/yy.ml b/jscomp/build_tests/white space/yy.ml
@@ -1,6 +1,5 @@
 type t = 
   | Foo
-  [@@bs.deriving jsConverter]
 
 let u = Xx.sum 3
 
diff --git a/jscomp/core/js_dump.ml b/jscomp/core/js_dump.ml
@@ -771,15 +771,8 @@ and expression_desc cxt ~(level : int) f x : cxt =
               | Undefined when is_optional f -> None
               | _ -> Some (f, x))
           in
-        if p.num_nonconst = 1 then tails
-        else
-          ( Js_op.Lit L.tag,
-            if !Js_config.debug then tag else { tag with comment = Some p.name }
-          )
-          :: tails
+        (Js_op.Lit L.tag, E.str p.name) :: tails
       in
-      if p.num_nonconst = 1 && not !Js_config.debug then
-        pp_comment_option f (Some p.name);
       expression_desc cxt ~level f (Object objs)
   | Caml_block (el, _, tag, Blk_constructor p) ->
       let not_is_cons = p.name <> Literals.cons in
@@ -796,15 +789,13 @@ and expression_desc cxt ~(level : int) f x : cxt =
              [ (name_symbol, E.str p.name) ]
             else [])
         in
-        if p.num_nonconst = 1 then tails
+        if not_is_cons = false && p.num_nonconst = 1 then tails
         else
           ( Js_op.Lit L.tag,
-            if !Js_config.debug then tag else { tag with comment = Some p.name }
+            E.str p.name
           )
           :: tails
       in
-      if p.num_nonconst = 1 && (not !Js_config.debug) && not_is_cons then
-        pp_comment_option f (Some p.name);
       expression_desc cxt ~level f (Object objs)
   | Caml_block
       ( _,

diff --git a/jscomp/core/js_exp_make.ml b/jscomp/core/js_exp_make.ml
@@ -763,7 +763,7 @@ let is_type_number ?comment (e : t) : t =
   string_equal ?comment (typeof e) (str "number")
 
 let is_tag (e : t) : t =
-  string_equal ~comment:"tag" (typeof e) (str "number")
+  { expression_desc = Bin (NotEqEq, typeof e, str "object"); comment=None }
 
 let is_type_string ?comment (e : t) : t =
   string_equal ?comment (typeof e) (str "string")
@@ -776,12 +776,7 @@ let is_type_object (e : t) : t = string_equal (typeof e) (str "object")
 *)
 
 let tag ?comment e : t =
-  {
-    expression_desc =
-      Bin
-        (Bor, { expression_desc = Caml_block_tag e; comment }, zero_int_literal);
-    comment = None;
-  }
+  { expression_desc = Caml_block_tag e; comment }
 
 (* according to the compiler, [Btype.hash_variant],
    it's reduced to 31 bits for hash

diff --git a/jscomp/core/js_of_lam_block.ml b/jscomp/core/js_of_lam_block.ml
@@ -30,15 +30,6 @@ module E = Js_exp_make
 let make_block mutable_flag (tag_info : Lam_tag_info.t) tag args =
   match tag_info with _ -> E.make_block tag tag_info args mutable_flag
 
-(* | _, (  Tuple | Variant _ ) -> (\** TODO: check with inline record *\) *)
-(*     E.arr Immutable *)
-(*       (E.small_int  ?comment:(Lam_compile_util.comment_of_tag_info tag_info) tag   *)
-(*        :: args) *)
-(* | _, _  ->  *)
-(*     E.arr mutable_flag *)
-(*       (E.int  ?comment:(Lam_compile_util.comment_of_tag_info tag_info) tag   *)
-(*        :: args) *)
-
 let field (field_info : Lam_compat.field_dbg_info) e (i : int32) =
   match field_info with
   | Fld_tuple | Fld_array ->

diff --git a/jscomp/core/lam_compile.ml b/jscomp/core/lam_compile.ml
@@ -568,8 +568,17 @@ and compile_general_cases :
           [ switch ?default ?declaration switch_exp body ])
 
 and compile_cases cxt (switch_exp : E.t) table default get_name =
+  let string_table = table |> List.filter_map (fun (i, lam) -> match get_name i
+        with None -> None
+        | Some n -> Some (n, lam)) in
+  if List.length string_table = List.length table
+  then
+    compile_string_cases cxt switch_exp string_table default
+  else
   compile_general_cases get_name
-    (fun i -> { (E.small_int i) with comment = get_name i })
+    (fun i -> match get_name i with
+      | None ->  E.small_int i
+      | Some name -> E.str name)
     E.int_equal cxt
     (fun ?default ?declaration e clauses ->
       S.int_switch ?default ?declaration e clauses)

diff --git a/jscomp/core/lam_compile_const.ml b/jscomp/core/lam_compile_const.ml
@@ -47,6 +47,8 @@ and translate (x : Lam_constant.t) : J.expression =
   | Const_js_false -> E.bool false
   | Const_js_null -> E.nil
   | Const_js_undefined -> E.undefined
+  | Const_int { i; comment = Pt_constructor {name}} when name <> "[]" ->
+      E.str name
   | Const_int { i; comment } ->
       E.int i ?comment:(Lam_constant.string_of_pointer_info comment)
   | Const_char i -> Js_of_lam_string.const_char i

diff --git a/jscomp/core/lam_compile_util.ml b/jscomp/core/lam_compile_util.ml
@@ -30,18 +30,3 @@ let jsop_of_comp (cmp : Lam_compat.comparison) : Js_op.binop =
   | Cgt -> Gt
   | Cle -> Le
   | Cge -> Ge
-
-let comment_of_tag_info (x : Lam_tag_info.t) =
-  match x with
-  | Blk_constructor { name = n } -> Some n
-  | Blk_tuple -> Some "tuple"
-  | Blk_poly_var _ -> None
-  | Blk_record _ -> None
-  | Blk_record_inlined { name = ctor } -> Some ctor
-  | Blk_record_ext _ -> None
-  | Blk_module_export _ | Blk_module _ ->
-      (* Turn it on next time to save some noise diff*)
-      None
-  | Blk_extension (* TODO: enhance it later *) -> None
-  | Blk_some | Blk_some_not_nested | Blk_lazy_general -> assert false
-(* let module_alias = Some "alias"   *)
diff --git a/jscomp/core/lam_compile_util.mli b/jscomp/core/lam_compile_util.mli
@@ -25,5 +25,3 @@
 (** Some utilities for lambda compilation*)
 
 val jsop_of_comp : Lam_compat.comparison -> Js_op.binop
-
-val comment_of_tag_info : Lam_tag_info.t -> string option
diff --git a/jscomp/ext/warnings.ml b/jscomp/ext/warnings.ml
@@ -480,7 +480,7 @@ let message = function
   | Bs_polymorphic_comparison ->
       "Polymorphic comparison introduced (maybe unsafe)"
   | Bs_ffi_warning s -> "FFI warning: " ^ s
-  | Bs_derive_warning s -> "bs.deriving warning: " ^ s
+  | Bs_derive_warning s -> "@deriving warning: " ^ s
   | Bs_fragile_external s ->
       s
       ^ " : using an empty string as a shorthand to infer the external's name \

diff --git a/jscomp/frontend/ast_derive_js_mapper.ml b/jscomp/frontend/ast_derive_js_mapper.ml
@@ -127,49 +127,17 @@ let app1 = Ast_compatible.app1
 
 let app2 = Ast_compatible.app2
 
-let app3 = Ast_compatible.app3
-
-let ( <=~ ) a b = app2 (Exp.ident { loc = noloc; txt = Lident "<=" }) a b
-
-let ( -~ ) a b =
-  app2 (Exp.ident { loc = noloc; txt = Ldot (Lident "Pervasives", "-") }) a b
-
-let ( +~ ) a b =
-  app2 (Exp.ident { loc = noloc; txt = Ldot (Lident "Pervasives", "+") }) a b
-
-let ( &&~ ) a b =
-  app2 (Exp.ident { loc = noloc; txt = Ldot (Lident "Pervasives", "&&") }) a b
-
 let ( ->~ ) a b = Ast_compatible.arrow a b
 
 let jsMapperRt = Longident.Ldot (Lident "Js", "MapperRt")
 
-let fromInt len array exp =
-  app3
-    (Exp.ident { loc = noloc; txt = Longident.Ldot (jsMapperRt, "fromInt") })
-    len array exp
-
-let fromIntAssert len array exp =
-  app3
-    (Exp.ident
-       { loc = noloc; txt = Longident.Ldot (jsMapperRt, "fromIntAssert") })
-    len array exp
-
 let raiseWhenNotFound x =
   app1
     (Exp.ident
        { loc = noloc; txt = Longident.Ldot (jsMapperRt, "raiseWhenNotFound") })
     x
-
-let assertExp e = Exp.assert_ e
-
 let derivingName = "jsConverter"
 
-(* let notApplicable loc =
-   Location.prerr_warning
-    loc
-    (Warnings.Bs_derive_warning ( derivingName ^ " not applicable to this type")) *)
-
 let init () =
   Ast_derive.register derivingName (fun (x : Parsetree.expression option) ->
       let createType = handle_config x in
@@ -182,7 +150,6 @@ let init () =
               let name = tdcl.ptype_name.txt in
               let toJs = name ^ "ToJs" in
               let fromJs = name ^ "FromJs" in
-              let constantArray = "jsMapperConstantArray" in
               let loc = tdcl.ptype_loc in
               let patToJs = { Asttypes.loc; txt = toJs } in
               let patFromJs = { Asttypes.loc; txt = fromJs } in
@@ -302,95 +269,9 @@ let init () =
                   | None ->
                       U.notApplicable tdcl.Parsetree.ptype_loc derivingName;
                       [])
-              | Ptype_variant ctors ->
-                  if Ast_polyvar.is_enum_constructors ctors then
-                    let xs =
-                      Ast_polyvar.map_constructor_declarations_into_ints ctors
-                    in
-                    match xs with
-                    | `New xs ->
-                        let constantArrayExp =
-                          Exp.ident { loc; txt = Lident constantArray }
-                        in
-                        let exp_len =
-                          Ast_compatible.const_exp_int (List.length ctors)
-                        in
-                        let v =
-                          [
-                            unsafeIndexGet;
-                            eraseTypeStr;
-                            Ast_comb.single_non_rec_value
-                              { loc; txt = constantArray }
-                              (Ast_compatible.const_exp_int_list_as_array xs);
-                            toJsBody
-                              (app2 unsafeIndexGetExp constantArrayExp exp_param);
-                            Ast_comb.single_non_rec_value patFromJs
-                              (Ast_compatible.fun_ (Pat.var pat_param)
-                                 (if createType then
-                                  fromIntAssert exp_len constantArrayExp
-                                    (exp_param +: newType)
-                                  +> core_type
-                                 else
-                                   fromInt exp_len constantArrayExp exp_param
-                                   +> Ast_core_type.lift_option_type core_type));
-                          ]
-                        in
-                        if createType then newTypeStr :: v else v
-                    | `Offset offset ->
-                        let v =
-                          [
-                            eraseTypeStr;
-                            toJsBody
-                              (coerceResultToNewType
-                                 (eraseType exp_param
-                                 +~ Ast_compatible.const_exp_int offset));
-                            (let len = List.length ctors in
-                             let range_low =
-                               Ast_compatible.const_exp_int (offset + 0)
-                             in
-                             let range_upper =
-                               Ast_compatible.const_exp_int (offset + len - 1)
-                             in
-
-                             Ast_comb.single_non_rec_value { loc; txt = fromJs }
-                               (Ast_compatible.fun_ (Pat.var pat_param)
-                                  (if createType then
-                                   Exp.let_ Nonrecursive
-                                     [
-                                       Vb.mk (Pat.var pat_param)
-                                         (exp_param +: newType);
-                                     ]
-                                     (Exp.sequence
-                                        (assertExp
-                                           (exp_param <=~ range_upper
-                                          &&~ (range_low <=~ exp_param)))
-                                        (exp_param
-                                        -~ Ast_compatible.const_exp_int offset))
-                                   +> core_type
-                                  else
-                                    Exp.ifthenelse
-                                      (exp_param <=~ range_upper
-                                     &&~ (range_low <=~ exp_param))
-                                      (Exp.construct
-                                         { loc; txt = Ast_literal.predef_some }
-                                         (Some
-                                            (exp_param
-                                            -~ Ast_compatible.const_exp_int
-                                                 offset)))
-                                      (Some
-                                         (Exp.construct
-                                            {
-                                              loc;
-                                              txt = Ast_literal.predef_none;
-                                            }
-                                            None))
-                                    +> Ast_core_type.lift_option_type core_type)));
-                          ]
-                        in
-                        if createType then newTypeStr :: v else v
-                  else (
-                    U.notApplicable tdcl.Parsetree.ptype_loc derivingName;
-                    [])
+              | Ptype_variant _ ->
+                  U.notApplicable tdcl.Parsetree.ptype_loc derivingName;
+                  []
               | Ptype_open ->
                   U.notApplicable tdcl.Parsetree.ptype_loc derivingName;
                   []
@@ -452,23 +333,9 @@ let init () =
                   | None ->
                       U.notApplicable tdcl.Parsetree.ptype_loc derivingName;
                       [])
-              | Ptype_variant ctors ->
-                  if Ast_polyvar.is_enum_constructors ctors then
-                    let ty1 =
-                      if createType then newType else Ast_literal.type_int ()
-                    in
-                    let ty2 =
-                      if createType then core_type
-                      else Ast_core_type.lift_option_type core_type
-                    in
-                    newTypeStr
-                    +? [
-                         toJsType ty1;
-                         Ast_comb.single_non_rec_val patFromJs (ty1 ->~ ty2);
-                       ]
-                  else (
-                    U.notApplicable tdcl.Parsetree.ptype_loc derivingName;
-                    [])
+              | Ptype_variant _ ->
+                  U.notApplicable tdcl.Parsetree.ptype_loc derivingName;
+                  []
               | Ptype_open ->
                   U.notApplicable tdcl.Parsetree.ptype_loc derivingName;
                   []

diff --git a/jscomp/frontend/ast_derive_util.ml b/jscomp/frontend/ast_derive_util.ml
@@ -43,28 +43,6 @@ let new_type_of_type_declaration (tdcl : Parsetree.type_declaration) newName =
           ptype_private = Public;
           ptype_manifest = None;
         } )
-
-(* let mk_fun ~loc (typ : Parsetree.core_type)
-    (value : string) body
-   : Parsetree.expression =
-   Ast_compatible.fun_
-    (Pat.constraint_ (Pat.var {txt = value ; loc}) typ)
-    body
-
-   let destruct_label_declarations ~loc
-    (arg_name : string)
-    (labels : Parsetree.label_declaration list) :
-   (Parsetree.core_type * Parsetree.expression) list * string list
-   =
-   Ext_list.fold_right labels ([], [])
-    (fun {pld_name = {txt}; pld_type}
-      (core_type_exps, labels) ->
-      ((pld_type,
-        Exp.field (Exp.ident {txt = Lident arg_name ; loc})
-          {txt = Lident txt ; loc}) :: core_type_exps),
-      txt :: labels
-    ) *)
-
 let notApplicable loc derivingName =
   Location.prerr_warning loc
     (Warnings.Bs_derive_warning (derivingName ^ " not applicable to this type"))

diff --git a/jscomp/frontend/ast_polyvar.ml b/jscomp/frontend/ast_polyvar.ml
@@ -115,16 +115,3 @@ let is_enum_polyvar (ty : Parsetree.type_declaration) =
     when is_enum row_fields ->
       Some row_fields
   | _ -> None
-
-let is_enum_constructors (constructors : Parsetree.constructor_declaration list)
-    =
-  List.for_all
-    (fun (x : Parsetree.constructor_declaration) ->
-      match x with
-      | {
-       pcd_args =
-         Pcstr_tuple [] (* Note the enum is encoded using [Pcstr_tuple []]*);
-      } ->
-          true
-      | _ -> false)
-    constructors
diff --git a/jscomp/frontend/ast_polyvar.mli b/jscomp/frontend/ast_polyvar.mli
@@ -38,5 +38,3 @@ val map_row_fields_into_strings :
 
 val is_enum_polyvar :
   Parsetree.type_declaration -> Parsetree.row_field list option
-
-val is_enum_constructors : Parsetree.constructor_declaration list -> bool
Original file line number	Diff line number	Diff line change
Expand Up		@@ -25,5 +25,3 @@
		(** Some utilities for lambda compilation*)

		val jsop_of_comp : Lam_compat.comparison -> Js_op.binop

		val comment_of_tag_info : Lam_tag_info.t -> string option
Original file line number	Diff line number	Diff line change
Expand Up		@@ -38,5 +38,3 @@ val map_row_fields_into_strings :

		val is_enum_polyvar :
		Parsetree.type_declaration -> Parsetree.row_field list option

		val is_enum_constructors : Parsetree.constructor_declaration list -> bool