Support @as("foo") to customize the representation of tags. (#6095)

* Emit tags as strings.

* Allow more general type for tags.

Compile is_tag to `!== "object"` instead of `=== "string"`.

* Do not special case variants with only 1 case with payload.

Also the comment is not emitted anymore, since there's always a tag.
Not special casing means that the representation is uniform, and does not change when the type is extended. This is important with zero cost ffi, where the runtime representation is exposed to the user, to reduce possible surprises.

* Support @as("foo") to customize the representation of tags.

* Cleanup: chatgpt's suggestion

* Add support for custom representation of the form `@as(12)`

* Add null, undefined, unboxed customization.

null and undefined can only be applied to cases with no payloads

unboxed can only be applied when there is exactly one case with payloads, and that case takes exactly one argument

Some of those checks are possible statically. Not all of them are implemented.
Some checks cannot if one wants to have user-level nullable, null, undefined types with pattern matching. E.g. null type could take null as an argument.

* Add tagged unions example from chatgpt.

* Use custom tags.

* Remove unused set_tag from compiler internals.

* Add support for @tag(...) to customize the property used for the tag.

* Document places needing restriction.

* Add support for @as(true) and @as(false)

Author: cristianoc

CHANGELOG.md

@@ -30,6 +30,7 @@ Make uncurried functions a subtype of curried functions, and allow application f
 The `make` function of components is generated as an uncurried function.
 Use best effort to determine the config when formatting a file.
 https://github.com/rescript-lang/rescript-compiler/pull/5968 https://github.com/rescript-lang/rescript-compiler/pull/6080 https://github.com/rescript-lang/rescript-compiler/pull/6086 https://github.com/rescript-lang/rescript-compiler/pull/6087
+- Customization of runtime representation of variants. This is work in progress. E.g. some restrictions on the input. See comments of the form "TODO: put restriction on the variant definitions allowed, to make sure this never happens". https://github.com/rescript-lang/rescript-compiler/pull/6095
 
 #### :boom: Breaking Change
 

jscomp/core/j.ml

@@ -151,17 +151,7 @@ and expression_desc =
   (* | Caml_uninitialized_obj of expression * expression *)
   (* [tag] and [size] tailed  for [Obj.new_block] *)
 
-  (* For setter, it still return the value of expression,
-     we can not use
-     {[
-       type 'a access = Get | Set of 'a
-     ]}
-     in another module, since it will break our code generator
-     [Caml_block_tag] can return [undefined],
-     you have to use [E.tag] in a safe way
-  *)
-  | Caml_block_tag of expression
-  (* | Caml_block_set_tag of expression * expression *)
+  | Caml_block_tag of expression * string (* e.tag *)
   (* | Caml_block_set_length of expression * expression *)
   (* It will just fetch tag, to make it safe, when creating it,
      we need apply "|0", we don't do it in the
@@ -254,7 +244,7 @@ and case_clause = {
   comment : string option;
 }
 
-and string_clause = string * case_clause
+and string_clause = Lambda.as_value * case_clause
 and int_clause = int * case_clause
 
 and statement_desc =

jscomp/core/js_analyzer.ml

@@ -101,10 +101,9 @@ let rec no_side_effect_expression_desc (x : J.expression_desc) =
   | Optional_block (x, _) -> no_side_effect x
   | Object kvs -> Ext_list.for_all_snd kvs no_side_effect
   | String_append (a, b) | Seq (a, b) -> no_side_effect a && no_side_effect b
-  | Length (e, _) | Caml_block_tag e | Typeof e -> no_side_effect e
+  | Length (e, _) | Caml_block_tag (e, _) | Typeof e -> no_side_effect e
   | Bin (op, a, b) -> op <> Eq && no_side_effect a && no_side_effect b
   | Js_not _ | Cond _ | FlatCall _ | Call _ | New _ | Raw_js_code _
-  (* | Caml_block_set_tag _  *)
   (* actually true? *) ->
       false
   | Await _ -> false

jscomp/core/js_dump.ml

@@ -762,6 +762,9 @@ and expression_desc cxt ~(level : int) f x : cxt =
           | Lit n -> Ext_list.mem_string p.optional_labels n
           | Symbol_name -> false
         in
+        let tag_name = match Ast_attributes.process_tag_name p.attrs with
+        | None -> L.tag
+        | Some s -> s in
         let tails =
           match p.optional_labels with
           | [] -> tails
@@ -771,11 +774,19 @@ and expression_desc cxt ~(level : int) f x : cxt =
               | Undefined when is_optional f -> None
               | _ -> Some (f, x))
           in
-        (Js_op.Lit L.tag, E.str p.name) :: tails
+        ( Js_op.Lit tag_name, (* TAG:xx for inline records *)
+          match Ast_attributes.process_as_value p.attrs with
+          | None -> E.str p.name
+          | Some as_value -> E.as_value as_value )
+        :: tails
       in
       expression_desc cxt ~level f (Object objs)
   | Caml_block (el, _, tag, Blk_constructor p) ->
       let not_is_cons = p.name <> Literals.cons in
+      let as_value = Ast_attributes.process_as_value p.attrs in
+      let tag_name = match Ast_attributes.process_tag_name p.attrs with
+        | None -> L.tag
+        | Some s -> s in
       let objs =
         let tails =
           Ext_list.mapi_append el
@@ -789,14 +800,20 @@ and expression_desc cxt ~(level : int) f x : cxt =
              [ (name_symbol, E.str p.name) ]
             else [])
         in
-        if not_is_cons = false && p.num_nonconst = 1 then tails
+        if (as_value = Some AsUnboxed || not_is_cons = false) && p.num_nonconst = 1 then tails
         else
-          ( Js_op.Lit L.tag,
-            E.str p.name
-          )
+          ( Js_op.Lit tag_name, (* TAG:xx *) 
+            match as_value with
+            | None -> E.str p.name
+            | Some as_value -> E.as_value as_value )
           :: tails
       in
-      expression_desc cxt ~level f (Object objs)
+      let exp = match objs with
+        | [(_, e)] when as_value = Some AsUnboxed -> e.expression_desc
+        | _ when as_value = Some AsUnboxed -> assert false (* should not happen *)
+        (* TODO: put restriction on the variant definitions allowed, to make sure this never happens. *)
+        | _ -> J.Object objs in
+      expression_desc cxt ~level f exp
   | Caml_block
       ( _,
         _,
@@ -806,11 +823,11 @@ and expression_desc cxt ~(level : int) f x : cxt =
       assert false
   | Caml_block (el, mutable_flag, _tag, Blk_tuple) ->
       expression_desc cxt ~level f (Array (el, mutable_flag))
-  | Caml_block_tag e ->
+  | Caml_block_tag (e, tag) ->
       P.group f 1 (fun _ ->
           let cxt = expression ~level:15 cxt f e in
           P.string f L.dot;
-          P.string f L.tag;
+          P.string f tag;
           cxt)
   | Array_index (e, p) ->
       P.cond_paren_group f (level > 15) 1 (fun _ ->
@@ -1188,8 +1205,10 @@ 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 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
+          let pp_as_value f (as_value: Lambda.as_value) =
+            let e = E.as_value as_value in
+            ignore @@ expression_desc cxt ~level:0 f e.expression_desc in
+          let cxt = loop_case_clauses cxt f pp_as_value cc in
           match def with
           | None -> cxt
           | Some def ->

jscomp/core/js_exp_make.ml

@@ -316,6 +316,19 @@ let small_int i : t =
   | 248 -> obj_int_tag_literal
   | i -> int (Int32.of_int i)
 
+let true_ : t = { comment = None; expression_desc = Bool true }
+let false_ : t = { comment = None; expression_desc = Bool false }
+let bool v = if v then true_ else false_
+
+let as_value = function
+  | Lambda.AsString s -> str s ~delim:DStarJ
+  | AsInt i -> small_int i
+  | AsBool b -> bool b
+  | AsNull -> nil
+  | AsUndefined -> undefined
+  | AsUnboxed -> assert false (* Should not emit tags for unboxed *)
+  (* TODO: put restriction on the variant definitions allowed, to make sure this never happens. *)
+
 let array_index ?comment (e0 : t) (e1 : t) : t =
   match (e0.expression_desc, e1.expression_desc) with
   | Array (l, _), Number (Int { i; _ })
@@ -540,13 +553,6 @@ let obj ?comment properties : t =
 (* currently only in method call, no dependency introduced
 *)
 
-(* Static_index .....................**)
-
-(* var (Jident.create_js "true") *)
-let true_ : t = { comment = None; expression_desc = Bool true }
-let false_ : t = { comment = None; expression_desc = Bool false }
-let bool v = if v then true_ else false_
-
 (** Arith operators *)
 (* Static_index .....................**)
 
@@ -762,8 +768,26 @@ let string_equal ?comment (e0 : t) (e1 : t) : t =
 let is_type_number ?comment (e : t) : t =
   string_equal ?comment (typeof e) (str "number")
 
-let is_tag (e : t) : t =
-  { expression_desc = Bin (NotEqEq, typeof e, str "object"); comment=None }
+let is_tag ?(has_null_undefined_other=(false, false, false)) (e : t) : t =
+  let (has_null, has_undefined, has_other) = has_null_undefined_other in
+  if has_null && (has_undefined = false) && (has_other = false) then (* null *)
+    { expression_desc = Bin (EqEqEq, e, nil); comment=None }
+  else if has_null && has_undefined && has_other=false then (* null + undefined *)
+    { J.expression_desc = Bin
+      (Or,
+        { expression_desc = Bin (EqEqEq, e, nil); comment=None },
+        { expression_desc = Bin (EqEqEq, e, undefined); comment=None }
+      ); comment=None }
+  else if has_null=false && has_undefined && has_other=false then (* undefined *)
+    { expression_desc = Bin (EqEqEq, e, undefined); comment=None }
+  else if has_null then (* (null + undefined + other) || (null + other) *)
+    { J.expression_desc = Bin
+      (Or,
+        { expression_desc = Bin (EqEqEq, e, nil); comment=None },
+        { expression_desc = Bin (NotEqEq, typeof e, str "object"); comment=None }
+      ); comment=None }
+  else (* (undefiled + other) || other *)
+    { 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")
@@ -775,8 +799,8 @@ let is_type_object (e : t) : t = string_equal (typeof e) (str "object")
    call plain [dot]
 *)
 
-let tag ?comment e : t =
-  { expression_desc = Caml_block_tag e; comment }
+let tag ?comment ?(name=Js_dump_lit.tag) e : t =
+  { expression_desc = Caml_block_tag (e, name); comment }
 
 (* according to the compiler, [Btype.hash_variant],
    it's reduced to 31 bits for hash

jscomp/core/js_exp_make.mli

@@ -185,6 +185,8 @@ val assign_by_exp : t -> t -> t -> t
 
 val assign : ?comment:string -> t -> t -> t
 
+val as_value : Lambda.as_value -> t
+
 val triple_equal : ?comment:string -> t -> t -> t
 (* TODO: reduce [triple_equal] use *)
 
@@ -199,7 +201,8 @@ val eq_null_undefined_boolean : ?comment:string -> t -> t -> t
 val neq_null_undefined_boolean : ?comment:string -> t -> t -> t
 
 val is_type_number : ?comment:string -> t -> t
-val is_tag : t -> t
+
+val is_tag : ?has_null_undefined_other:(bool * bool * bool) -> t -> t
 
 val is_type_string : ?comment:string -> t -> t
 
@@ -304,7 +307,7 @@ val unit : t
 
 val undefined : t
 
-val tag : ?comment:string -> J.expression -> t
+val tag : ?comment:string -> ?name:string -> J.expression -> t
 
 (** Note that this is coupled with how we encode block, if we use the 
     `Object.defineProperty(..)` since the array already hold the length,

jscomp/core/js_fold.ml

@@ -162,7 +162,7 @@ class fold =
           let _self = list (fun _self -> _self#expression) _self _x0 in
           let _self = _self#expression _x2 in
           _self
-      | Caml_block_tag _x0 ->
+      | Caml_block_tag (_x0, _tag) ->
           let _self = _self#expression _x0 in
           _self
       | Number _ -> _self

jscomp/core/js_of_lam_variant.ml

@@ -39,8 +39,8 @@ let eval (arg : J.expression) (dispatches : (string * string) list) : E.t =
         E.of_block
           [
             S.string_switch arg
-              (Ext_list.map dispatches (fun (i, r) ->
-                   ( i,
+              (Ext_list.map dispatches (fun (s, r) ->
+                   ( Lambda.AsString s,
                      J.
                        {
                          switch_body = [ S.return_stmt (E.str r) ];
@@ -79,8 +79,8 @@ let eval_as_event (arg : J.expression)
                 [
                   S.string_switch
                     (E.poly_var_tag_access arg)
-                    (Ext_list.map dispatches (fun (i, r) ->
-                         ( i,
+                    (Ext_list.map dispatches (fun (s, r) ->
+                         ( Lambda.AsString s,
                            J.
                              {
                                switch_body = [ S.return_stmt (E.str r) ];
@@ -107,8 +107,8 @@ let eval_as_int (arg : J.expression) (dispatches : (string * int) list) : E.t =
         E.of_block
           [
             S.string_switch arg
-              (Ext_list.map dispatches (fun (i, r) ->
-                   ( i,
+              (Ext_list.map dispatches (fun (s, r) ->
+                   ( Lambda.AsString s,
                      J.
                        {
                          switch_body =

jscomp/core/js_record_fold.ml

@@ -168,7 +168,7 @@ let expression_desc : 'a. ('a, expression_desc) fn =
       let st = list _self.expression _self st _x0 in
       let st = _self.expression _self st _x2 in
       st
-  | Caml_block_tag _x0 ->
+  | Caml_block_tag (_x0, _tag) ->
       let st = _self.expression _self st _x0 in
       st
   | Number _ -> st

jscomp/core/js_record_iter.ml

@@ -128,7 +128,7 @@ let expression_desc : expression_desc fn =
   | Caml_block (_x0, _x1, _x2, _x3) ->
       list _self.expression _self _x0;
       _self.expression _self _x2
-  | Caml_block_tag _x0 -> _self.expression _self _x0
+  | Caml_block_tag (_x0, _tag) -> _self.expression _self _x0
   | Number _ -> ()
   | Object _x0 -> property_map _self _x0
   | Undefined -> ()

jscomp/core/js_record_map.ml

@@ -166,9 +166,9 @@ let expression_desc : expression_desc fn =
       let _x0 = list _self.expression _self _x0 in
       let _x2 = _self.expression _self _x2 in
       Caml_block (_x0, _x1, _x2, _x3)
-  | Caml_block_tag _x0 ->
+  | Caml_block_tag (_x0, tag) ->
       let _x0 = _self.expression _self _x0 in
-      Caml_block_tag _x0
+      Caml_block_tag (_x0, tag)
   | Number _ as v -> v
   | Object _x0 ->
       let _x0 = property_map _self _x0 in

jscomp/core/js_stmt_make.ml

@@ -129,13 +129,16 @@ let int_switch ?(comment : string option)
 
 let string_switch ?(comment : string option)
     ?(declaration : (J.property * Ident.t) option) ?(default : J.block option)
-    (e : J.expression) (clauses : (string * J.case_clause) list) : t =
+    (e : J.expression) (clauses : (Lambda.as_value * J.case_clause) list) : t =
   match e.expression_desc with
   | Str {txt} -> (
       let continuation =
         match
           Ext_list.find_opt clauses (fun (switch_case, x) ->
-              if switch_case = txt then Some x.switch_body else None)
+            match switch_case with
+            | AsString s ->
+              if s = txt then Some x.switch_body else None
+            | AsInt _ | AsBool _ | AsNull | AsUnboxed | AsUndefined -> None)
         with
         | Some case -> case
         | None -> ( match default with Some x -> x | None -> assert false)

jscomp/core/js_stmt_make.mli

@@ -77,7 +77,7 @@ val string_switch :
   ?declaration:Lam_compat.let_kind * Ident.t ->
   ?default:J.block ->
   J.expression ->
-  (string * J.case_clause) list ->
+  (Lambda.as_value * J.case_clause) list ->
   t
 
 val declare_variable :