feat: support @mel.as in variant definitions

jscomp/common/lam_constant.ml

@@ -26,21 +26,25 @@ open Import
 
 type pointer_info =
   | None
-  | Pt_constructor of {
-      name : string;
-      const : int;
-      non_const : int;
-      attributes : Parsetree.attributes;
-    }
+  | Pt_constructor of { name : Lambda.cstr_name; const : int; non_const : int }
   | Pt_assertfalse
   | Some of string
 
-let string_of_pointer_info (x : pointer_info) : string option =
+let comment_of_pointer_info (x : pointer_info) : string option =
   match x with
-  | Some name | Pt_constructor { name; _ } -> Some name
+  | Some name -> Some name
+  | Pt_constructor { name = { Lambda.name; _ }; _ } -> Some name
   | Pt_assertfalse -> Some "assert_false"
   | None -> None
 
+let modifier_of_pointer_info (x : pointer_info) : Lambda.as_modifier option =
+  match x with
+  | Pt_constructor { name = { as_modifier = Some modifier; _ }; _ } ->
+      Some modifier
+  | Pt_constructor { name = { as_modifier = None; _ }; _ }
+  | Pt_assertfalse | Some _ | None ->
+      None
+
 type t =
   | Const_js_null
   | Const_js_undefined

jscomp/common/lam_constant.mli

@@ -22,18 +22,16 @@
  * along with this program; if not, write to the Free Software
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
 
+open Import
+
 type pointer_info =
   | None
-  | Pt_constructor of {
-      name : string;
-      const : int;
-      non_const : int;
-      attributes : Parsetree.attributes;
-    }
+  | Pt_constructor of { name : Lambda.cstr_name; const : int; non_const : int }
   | Pt_assertfalse
   | Some of string
 
-val string_of_pointer_info : pointer_info -> string option
+val modifier_of_pointer_info : pointer_info -> Lambda.as_modifier option
+val comment_of_pointer_info : pointer_info -> string option
 
 type t =
   | Const_js_null

jscomp/common/lam_tag_info.ml

@@ -39,6 +39,7 @@ type t =
       name : string;
       num_nonconst : int;
       fields : string array;
+      attributes : Parsetree.attributes;
     }
   | Blk_constructor of {
       name : string;

jscomp/core/ast_payload.mli

@@ -26,7 +26,7 @@ open Import
 
 type t = Parsetree.payload
 (** A utility module used when destructuring parsetree attributes, used for
-    compiling FFI attributes and built-in ppx  *)
+    compiling FFI attributes and built-in ppx *)
 
 type action = string Asttypes.loc * Parsetree.expression option
 

jscomp/core/j.ml

@@ -262,7 +262,7 @@ and case_clause = {
   comment : string option;
 }
 
-and string_clause = string * case_clause
+and string_clause = Lambda.as_modifier * case_clause
 and int_clause = int * case_clause
 
 and statement_desc =

jscomp/core/js_dump.ml

@@ -790,38 +790,48 @@ and expression_desc cxt ~(level : int) x : cxt =
             (if !Js_config.debug then [ (name_symbol, E.str p.name) ] else [])
             (fun i -> Js_op.Lit i)
         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
+        let as_value =
+          Lam_constant_convert.modifier ~name:p.name p.attributes
+        in
+        ( Js_op.Lit L.tag,
+          {
+            (match as_value.as_modifier with
+            | Some modifier -> E.as_value modifier
+            | None -> tag)
+            with
+            comment = Some as_value.name;
+          } )
+        :: tails
       in
-      if p.num_nonconst = 1 && not !Js_config.debug then
-        pp_comment_option cxt (Some p.name);
       expression_desc cxt ~level (Object objs)
   | Caml_block (el, _, tag, Blk_constructor p) ->
-      let not_is_cons = not (Js_op_util.is_cons p.name) in
+      let is_cons = Js_op_util.is_cons p.name in
       let objs =
         let tails =
           List.mapi
             ~f:(fun i e ->
               (Js_op.Lit (E.variant_pos ~constr:p.name (Int32.of_int i)), e))
             el
           @
-          if !Js_config.debug && not_is_cons then
+          if !Js_config.debug && not is_cons then
             [ (name_symbol, E.str p.name) ]
           else []
         in
-        if p.num_nonconst = 1 then tails
+        if is_cons && p.num_nonconst = 1 then tails
         else
+          let as_value =
+            Lam_constant_convert.modifier ~name:p.name p.attributes
+          in
           ( Js_op.Lit L.tag,
-            if !Js_config.debug then tag else { tag with comment = Some p.name }
-          )
+            {
+              (match as_value.as_modifier with
+              | Some modifier -> E.as_value modifier
+              | None -> tag)
+              with
+              comment = Some as_value.name;
+            } )
           :: tails
       in
-      if p.num_nonconst = 1 && (not !Js_config.debug) && not_is_cons then
-        pp_comment_option cxt (Some p.name);
       expression_desc cxt ~level (Object objs)
   | Caml_block (_, _, _, (Blk_module_export | Blk_na _)) -> assert false
   | Caml_block (el, mutable_flag, _tag, (Blk_tuple | Blk_class | Blk_array)) ->
@@ -1188,7 +1198,9 @@ and statement_desc top cxt (s : J.statement_desc) : cxt =
       brace_vgroup cxt 1 (fun _ ->
           let cxt =
             loop_case_clauses cxt
-              (fun cxt s -> Js_dump_string.pp_string cxt.pp s)
+              (fun cxt as_value ->
+                let e = E.as_value as_value in
+                ignore @@ expression_desc cxt ~level:0 e.expression_desc)
               cc
           in
           match def with

jscomp/core/js_exp_make.ml

@@ -300,6 +300,20 @@ let small_int i : t =
   | 248 -> obj_int_tag_literal
   | i -> int (Int32.of_int i)
 
+(* var (Jident.create_js "true") *)
+let true_ : t = make_expression (Bool true)
+let false_ : t = make_expression (Bool false)
+let bool v = if v then true_ else false_
+
+let as_value ?comment modifier =
+  {
+    (match modifier with
+    | Lambda.String s -> str s (* ~delim:DStarJ *)
+    | Int i -> small_int i)
+    with
+    comment;
+  }
+
 let array_index ?loc ?comment (e0 : t) (e1 : t) : t =
   match (e0.expression_desc, e1.expression_desc) with
   | Array (l, _), Number (Int { i; _ })
@@ -509,13 +523,6 @@ let obj ?loc ?comment properties : t =
 (* currently only in method call, no dependency introduced
 *)
 
-(* Static_index .....................*)
-
-(* var (Jident.create_js "true") *)
-let true_ : t = make_expression (Bool true)
-let false_ : t = make_expression (Bool false)
-let bool v = if v then true_ else false_
-
 (** Arith operators *)
 (* Static_index .....................**)
 
@@ -747,6 +754,13 @@ let string_equal ?loc ?comment (e0 : t) (e1 : t) : t =
 let is_type_number ?loc ?comment (e : t) : t =
   string_equal ?loc ?comment (typeof e) (str "number")
 
+(* XXX(anmonteiro): this needs to change if we ever allow `[@mel.as ..]`
+   payloads to have types other than string or number *)
+let is_tag (e : t) : t =
+  or_ ~comment:"tag"
+    (string_equal (typeof e) (str "number"))
+    (string_equal (typeof e) (str "string"))
+
 let is_type_string ?loc ?comment (e : t) : t =
   string_equal ?loc ?comment (typeof e) (str "string")
 
@@ -755,10 +769,7 @@ let is_type_string ?loc ?comment (e : t) : t =
    call plain [dot]
 *)
 
-let tag ?loc ?comment e : t =
-  make_expression
-    (Bin
-       (Bor, make_expression ?loc ?comment (Caml_block_tag e), zero_int_literal))
+let tag ?loc ?comment e : t = make_expression ?loc ?comment (Caml_block_tag e)
 
 (* according to the compiler, [Btype.hash_variant],
    it's reduced to 31 bits for hash

jscomp/core/js_exp_make.mli

@@ -175,6 +175,7 @@ val assign_by_int : ?loc:Location.t -> ?comment:string -> t -> int32 -> t -> t
 
 val assign_by_exp : t -> t -> t -> t
 val assign : ?loc:Location.t -> ?comment:string -> t -> t -> t
+val as_value : ?comment:string -> Import.Lambda.as_modifier -> t
 val triple_equal : ?loc:Location.t -> ?comment:string -> t -> t -> t
 (* TODO: reduce [triple_equal] use *)
 
@@ -189,6 +190,7 @@ val neq_null_undefined_boolean :
   ?loc:Location.t -> ?comment:string -> t -> t -> t
 
 val is_type_number : ?loc:Location.t -> ?comment:string -> t -> t
+val is_tag : t -> t
 val is_type_string : ?loc:Location.t -> ?comment:string -> t -> t
 val typeof : ?loc:Location.t -> ?comment:string -> t -> t
 val to_int32 : ?loc:Location.t -> ?comment:string -> t -> t

jscomp/core/js_of_lam_variant.ml

@@ -40,7 +40,7 @@ let eval (arg : J.expression) (dispatches : (string * string) list) : E.t =
             S.string_switch arg
               (List.map
                  ~f:(fun (i, r) ->
-                   ( i,
+                   ( Lambda.String i,
                      J.
                        {
                          switch_body = [ S.return_stmt (E.str r) ];
@@ -74,7 +74,7 @@ let eval_as_event (arg : J.expression)
                     (E.poly_var_tag_access arg)
                     (List.map
                        ~f:(fun (i, r) ->
-                         ( i,
+                         ( Lambda.String i,
                            J.
                              {
                                switch_body = [ S.return_stmt (E.str r) ];
@@ -110,7 +110,7 @@ let eval_as_int (arg : J.expression) (dispatches : (string * int) list) : E.t =
             S.string_switch arg
               (List.map
                  ~f:(fun (i, r) ->
-                   ( i,
+                   ( Lambda.String i,
                      J.
                        {
                          switch_body =

jscomp/core/js_stmt_make.ml

@@ -131,14 +131,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 : J.string_clause list) : t =
   match e.expression_desc with
   | Str (_, txt) | Unicode txt -> (
       let continuation =
         match
           List.find_map
             ~f:(fun (switch_case, (x : J.case_clause)) ->
-              if switch_case = txt then Some x.switch_body else None)
+              match switch_case with
+              | Lambda.String s -> if s = txt then Some x.switch_body else None
+              | Int _ -> None)
             clauses
         with
         | Some case -> case

jscomp/core/js_stmt_make.mli

@@ -22,6 +22,8 @@
  * along with this program; if not, write to the Free Software
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
 
+open Import
+
 (** Creator utilities for the [J] module *)
 
 type t = J.statement
@@ -77,7 +79,7 @@ val string_switch :
   ?declaration:Lam_group.let_kind * Ident.t ->
   ?default:J.block ->
   J.expression ->
-  (string * J.case_clause) list ->
+  (Lambda.as_modifier * J.case_clause) list ->
   t
 
 val declare_variable :