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

Author: cristianoc

jscomp/core/j.ml

@@ -151,16 +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_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

jscomp/core/js_analyzer.ml

@@ -101,7 +101,7 @@ 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 _
   (* actually true? *) ->

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,7 +774,7 @@ and expression_desc cxt ~(level : int) f x : cxt =
               | Undefined when is_optional f -> None
               | _ -> Some (f, x))
           in
-        ( Js_op.Lit L.tag,
+        ( 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 )
@@ -781,6 +784,9 @@ and expression_desc cxt ~(level : int) f x : cxt =
   | 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
@@ -796,7 +802,7 @@ and expression_desc cxt ~(level : int) f x : cxt =
         in
         if (as_value = Some AsUnboxed || not_is_cons = false) && p.num_nonconst = 1 then tails
         else
-          ( Js_op.Lit L.tag,
+          ( Js_op.Lit tag_name, (* TAG:xx *) 
             match as_value with
             | None -> E.str p.name
             | Some as_value -> E.as_value as_value )
@@ -816,11 +822,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 _ ->

jscomp/core/js_exp_make.ml

@@ -800,8 +800,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

@@ -307,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_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/lam_compile.ml

@@ -141,9 +141,17 @@ let default_action ~saturated failaction =
 let get_const_name i (sw_names : Lambda.switch_names option) =
   match sw_names with None -> None | Some { consts } -> Some consts.(i)
 
-let get_block_name i (sw_names : Lambda.switch_names option) =
+let get_block i (sw_names : Lambda.switch_names option) =
   match sw_names with None -> None | Some { blocks } -> Some blocks.(i)
 
+let get_tag_name (sw_names : Lambda.switch_names option) =
+  match sw_names with
+  | None -> Js_dump_lit.tag
+  | Some { blocks } ->
+    (match Array.find_opt (fun {Lambda.tag_name} -> tag_name <> None) blocks with
+    | Some {tag_name = Some s} -> s
+    | _ -> Js_dump_lit.tag
+    )
 
 let has_null_undefined_other (sw_names : Lambda.switch_names option) =
   let (null, undefined, other) = (ref false, ref false, ref false) in
@@ -628,7 +636,11 @@ and compile_switch (switch_arg : Lam.t) (sw : Lam.lambda_switch)
     default_action ~saturated:sw_blocks_full sw_failaction
   in
   let get_const_name i = get_const_name i sw_names in
-  let get_block_name i = get_block_name i sw_names in
+  let get_block i = get_block i sw_names in
+  let get_block_name i = match get_block i with
+    | None -> None
+    | Some {cstr_name} -> Some cstr_name in
+  let tag_name = get_tag_name sw_names in
   let compile_whole (cxt : Lam_compile_context.t) =
     match
       compile_lambda { cxt with continuation = NeedValue Not_tail } switch_arg
@@ -638,7 +650,7 @@ and compile_switch (switch_arg : Lam.t) (sw : Lam.lambda_switch)
         block
         @
         if sw_consts_full && sw_consts = [] then
-          compile_cases cxt (E.tag e) sw_blocks sw_blocks_default get_block_name
+          compile_cases cxt (E.tag ~name:tag_name e) sw_blocks sw_blocks_default get_block_name
         else if sw_blocks_full && sw_blocks = [] then
           compile_cases cxt e sw_consts sw_num_default get_const_name
         else
@@ -648,7 +660,7 @@ and compile_switch (switch_arg : Lam.t) (sw : Lam.lambda_switch)
               (compile_cases cxt e sw_consts sw_num_default get_const_name)
               (* default still needed, could simplified*)
               ~else_:
-                (compile_cases cxt (E.tag e) sw_blocks sw_blocks_default
+                (compile_cases cxt (E.tag ~name:tag_name e) sw_blocks sw_blocks_default
                    get_block_name)
           in
           match e.expression_desc with

jscomp/core/lam_print.ml

@@ -320,7 +320,7 @@ let lambda ppf v =
             (fun (n, l) ->
               if !spc then fprintf ppf "@ " else spc := true;
               fprintf ppf "@[<hv 1>case tag %i %S:@ %a@]" n
-                (match sw.sw_names with None -> "" | Some x -> x.blocks.(n).name)
+                (match sw.sw_names with None -> "" | Some x -> x.blocks.(n).cstr_name.name)
                 lam l)
             sw.sw_blocks;
           match sw.sw_failaction with

jscomp/core/matching_polyfill.ml

@@ -30,11 +30,15 @@ let names_from_construct_pattern (pat : Typedtree.pattern) =
     let get_cstr_name (cstr: Types.constructor_declaration) =
       { Lambda.name = Ident.name cstr.cd_id;
         as_value = Ast_attributes.process_as_value cstr.cd_attributes } in
+    let get_tag_name (cstr: Types.constructor_declaration) =
+      Ast_attributes.process_tag_name cstr.cd_attributes in
+    let get_block cstr : Lambda.block =
+      {cstr_name = get_cstr_name cstr; tag_name = get_tag_name cstr} in
     let consts, blocks =
       Ext_list.fold_left cstrs ([], []) (fun (consts, blocks) cstr ->
           if is_nullary_variant cstr.cd_args then
             (get_cstr_name cstr :: consts, blocks)
-          else (consts, get_cstr_name cstr :: blocks))
+          else (consts, get_block cstr :: blocks))
     in
     Some
       {
@@ -48,7 +52,6 @@ let names_from_construct_pattern (pat : Typedtree.pattern) =
     | { type_kind = Type_abstract; type_manifest = Some t; _ } -> (
         match (Ctype.unalias t).desc with
         | Tconstr (pathn, _, _) ->
-            (* Format.eprintf "XXX path%d:%s path%d:%s@." n (Path.name path) (n+1) (Path.name pathn); *)
             resolve_path (n + 1) pathn
         | _ -> None)
     | { type_kind = Type_abstract; type_manifest = None; _ } -> None

jscomp/frontend/ast_attributes.ml

@@ -368,6 +368,23 @@ let process_as_value (attrs : t) =
       | _ -> ());
   !st
 
+let process_tag_name (attrs : t) =
+  let st = ref None in
+  Ext_list.iter attrs (fun (({ txt; loc }, payload) as attr) ->
+      match txt with
+      | "tag" ->
+          if !st = None then (
+            (match Ast_payload.is_single_string payload with
+            | None -> ()
+            | Some (s, _dec) ->
+                Bs_ast_invariant.mark_used_bs_attribute attr;
+                st := Some s);
+            if !st = None then Bs_syntaxerr.err loc InvalidVariantTagAnnotation
+          )
+          else Bs_syntaxerr.err loc Duplicated_bs_as
+      | _ -> ());
+  !st
+
 let locg = Location.none
 (* let bs : attr
    =  {txt = "bs" ; loc = locg}, Ast_payload.empty *)

jscomp/frontend/ast_attributes.mli

@@ -92,4 +92,6 @@ val rs_externals : t -> string list -> bool
 
 val process_send_pipe : t -> (Parsetree.core_type * t) option
 
-val process_as_value : t -> Lambda.as_value option
+val process_as_value : t -> Lambda.as_value option
+
+val process_tag_name : t -> string option

jscomp/frontend/bs_syntaxerr.ml

@@ -52,6 +52,7 @@ type error =
   | Bs_this_simple_pattern
   | Bs_uncurried_arity_too_large
   | InvalidVariantAsAnnotation
+  | InvalidVariantTagAnnotation
 
 let pp_error fmt err =
   Format.pp_print_string fmt
@@ -100,6 +101,8 @@ let pp_error fmt err =
         "%@this expect its pattern variable to be simple form"
     | InvalidVariantAsAnnotation ->
       "A variant case annotation @as(...) must be a string or integer or null"
+    | InvalidVariantTagAnnotation ->
+      "A variant tag annotation @tag(...) must be a string"
     )
 
 type exn += Error of Location.t * error

jscomp/frontend/bs_syntaxerr.mli

@@ -52,6 +52,7 @@ type error =
   | Bs_this_simple_pattern
   | Bs_uncurried_arity_too_large
   | InvalidVariantAsAnnotation
+  | InvalidVariantTagAnnotation
 
 val err : Location.t -> error -> 'a
 

jscomp/ml/datarepr.ml

@@ -142,7 +142,7 @@ let constructor_descrs ty_path decl cstrs =
           let representation =
             if decl.type_unboxed.unboxed
             then Record_unboxed true
-            else Record_inlined {tag = idx_nonconst; name = cstr_name; num_nonconsts = !num_nonconsts; optional_labels}
+            else Record_inlined {tag = idx_nonconst; name = cstr_name; num_nonconsts = !num_nonconsts; optional_labels; attrs = cd_attributes}
           in
           constructor_args decl.type_private cd_args cd_res
             (Path.Pdot (ty_path, cstr_name, Path.nopos)) representation

jscomp/ml/lambda.ml

@@ -99,9 +99,9 @@ let blk_record_ext =  ref (fun fields mutable_flag ->
     Blk_record_ext {fields = all_labels_info; mutable_flag }
   )
 
-let blk_record_inlined = ref (fun fields name num_nonconst optional_labels ~tag mutable_flag -> 
+let blk_record_inlined = ref (fun fields name num_nonconst optional_labels ~tag ~attrs mutable_flag -> 
   let fields = fields |> Array.map (fun (x,_) -> x.Types.lbl_name) in    
-  Blk_record_inlined {fields; name; num_nonconst; tag; mutable_flag; optional_labels; attrs = []}
+  Blk_record_inlined {fields; name; num_nonconst; tag; mutable_flag; optional_labels; attrs }
 ) 
 
 let ref_tag_info : tag_info = 
@@ -273,7 +273,8 @@ type function_attribute = {
   return_unit : bool;
   async : bool;
 }
-type switch_names = {consts: cstr_name array; blocks: cstr_name array}
+type block = {cstr_name: cstr_name; tag_name: string option}
+type switch_names = {consts: cstr_name array; blocks: block array}
 
 type lambda =
     Lvar of Ident.t

jscomp/ml/lambda.mli

@@ -90,6 +90,7 @@ val blk_record_inlined :
     int ->
     string list ->
     tag:int ->
+    attrs:Parsetree.attributes ->
     mutable_flag ->  
     tag_info
   ) ref
@@ -275,7 +276,8 @@ type function_attribute = {
   async : bool;
 }
 
-type switch_names = {consts: cstr_name array; blocks: cstr_name array}
+type block = {cstr_name: cstr_name; tag_name: string option}
+type switch_names = {consts: cstr_name array; blocks: block array}
 
 type lambda =
     Lvar of Ident.t

jscomp/ml/translcore.ml

@@ -1157,10 +1157,10 @@ and transl_record loc env fields repres opt_init_expr =
             | Record_optional_labels _ ->
                 Lconst
                   (Const_block (!Lambda.blk_record fields mut Record_optional, cl))
-            | Record_inlined { tag; name; num_nonconsts; optional_labels } ->
+            | Record_inlined { tag; name; num_nonconsts; optional_labels; attrs } ->
                 Lconst
                   (Const_block
-                     ( !Lambda.blk_record_inlined fields name num_nonconsts optional_labels ~tag
+                     ( !Lambda.blk_record_inlined fields name num_nonconsts optional_labels ~tag ~attrs
                          mut,
                        cl ))
             | Record_unboxed _ ->
@@ -1179,10 +1179,10 @@ and transl_record loc env fields repres opt_init_expr =
                     ll,
                     loc )
             | Record_float_unused -> assert false
-            | Record_inlined { tag; name; num_nonconsts; optional_labels } ->
+            | Record_inlined { tag; name; num_nonconsts; optional_labels; attrs } ->
                 Lprim
                   ( Pmakeblock
-                      (!Lambda.blk_record_inlined fields name num_nonconsts optional_labels ~tag
+                      (!Lambda.blk_record_inlined fields name num_nonconsts optional_labels ~tag ~attrs
                          mut),
                     ll,
                     loc )

jscomp/ml/typedecl.ml

@@ -379,6 +379,9 @@ let transl_declaration env sdecl id =
               raise(Error(sdecl.ptype_loc, Duplicate_constructor name));
             all_constrs := StringSet.add name !all_constrs)
           scstrs;
+        let copy_tag_attr_from_decl attr =
+          let tag_attr = Ext_list.filter sdecl.ptype_attributes (fun ({txt}, _) -> txt = "tag") in
+          if tag_attr = [] then attr else tag_attr @ attr in
         let make_cstr scstr =
           let name = Ident.create scstr.pcd_name.txt in
           let targs, tret_type, args, ret_type, _cstr_params =
@@ -391,14 +394,14 @@ let transl_declaration env sdecl id =
               cd_args = targs;
               cd_res = tret_type;
               cd_loc = scstr.pcd_loc;
-              cd_attributes = scstr.pcd_attributes }
+              cd_attributes = scstr.pcd_attributes |> copy_tag_attr_from_decl }
           in
           let cstr =
             { Types.cd_id = name;
               cd_args = args;
               cd_res = ret_type;
               cd_loc = scstr.pcd_loc;
-              cd_attributes = scstr.pcd_attributes }
+              cd_attributes = scstr.pcd_attributes |> copy_tag_attr_from_decl }
           in
             tcstr, cstr
         in

jscomp/ml/types.ml

@@ -154,7 +154,7 @@ and record_representation =
   | Record_float_unused                   (* Was: all fields are floats. Now: unused *)
   | Record_unboxed of bool                (* Unboxed single-field record, inlined or not *)
   | Record_inlined of                     (* Inlined record *)
-      { tag : int ; name : string; num_nonconsts : int; optional_labels : string list}
+      { tag : int ; name : string; num_nonconsts : int; optional_labels : string list; attrs: Parsetree.attributes}
   | Record_extension                      (* Inlined record under extension *)
   | Record_optional_labels of string list (* List of optional labels *)