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.

Author: cristianoc

jscomp/core/js_dump.ml

@@ -774,13 +774,13 @@ and expression_desc cxt ~(level : int) f x : cxt =
         ( Js_op.Lit L.tag,
           match Ast_attributes.process_as_value p.attrs with
           | None -> E.str p.name
-          | Some (AsString s) -> E.str s
-          | Some (AsInt i) -> E.small_int i )
+          | 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 objs =
         let tails =
           Ext_list.mapi_append el
@@ -794,16 +794,19 @@ 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,
-            match Ast_attributes.process_as_value p.attrs with
+            match as_value with
             | None -> E.str p.name
-            | Some (AsString s) -> E.str s
-            | Some (AsInt i) -> E.small_int i )
+            | 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 *)
+        | _ -> J.Object objs in
+      expression_desc cxt ~level f exp
   | Caml_block
       ( _,
         _,
@@ -1195,12 +1198,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 (as_value: Lambda.as_value) =
-            let e = match as_value with
-              | AsString txt -> E.str txt ~delim:DStarJ
-              | AsInt i -> E.small_int i 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_string cc 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,13 @@ let small_int i : t =
   | 248 -> obj_int_tag_literal
   | i -> int (Int32.of_int i)
 
+let as_value = function
+  | Lambda.AsString s -> str s ~delim:DStarJ
+  | AsInt i -> small_int i
+  | AsNull -> nil
+  | AsUndefined -> undefined
+  | AsUnboxed -> assert false (* Should not emit tags for unboxed *)
+
 let array_index ?comment (e0 : t) (e1 : t) : t =
   match (e0.expression_desc, e1.expression_desc) with
   | Array (l, _), Number (Int { i; _ })
@@ -762,8 +769,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")

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
 

jscomp/core/js_stmt_make.ml

@@ -138,7 +138,7 @@ let string_switch ?(comment : string option)
             match switch_case with
             | AsString s ->
               if s = txt then Some x.switch_body else None
-            | AsInt _ -> None)
+            | AsInt _ | AsNull | AsUnboxed | AsUndefined -> None)
         with
         | Some case -> case
         | None -> ( match default with Some x -> x | None -> assert false)

jscomp/core/lam_compile.ml

@@ -144,6 +144,18 @@ let get_const_name i (sw_names : Lambda.switch_names option) =
 let get_block_name i (sw_names : Lambda.switch_names option) =
   match sw_names with None -> None | Some { blocks } -> Some blocks.(i)
 
+
+let has_null_undefined_other (sw_names : Lambda.switch_names option) =
+  let (null, undefined, other) = (ref false, ref false, ref false) in
+  (match sw_names with
+  | None -> ()
+  | Some { consts } ->
+    Ext_array.iter consts (fun x -> match x.as_value with
+      | Some AsUndefined -> undefined := true
+      | Some AsNull -> null := true
+      | _ -> other := true));
+  (!null, !undefined, !other)
+
 let no_effects_const = lazy true
 (* let has_effects_const = lazy false *)
 
@@ -632,7 +644,7 @@ and compile_switch (switch_arg : Lam.t) (sw : Lam.lambda_switch)
         else
           (* [e] will be used twice  *)
           let dispatch e =
-            S.if_ (E.is_tag e)
+            S.if_ (E.is_tag ~has_null_undefined_other:(has_null_undefined_other sw_names) e)
               (compile_cases cxt e sw_consts sw_num_default get_const_name)
               (* default still needed, could simplified*)
               ~else_:
@@ -667,9 +679,7 @@ and compile_switch (switch_arg : Lam.t) (sw : Lam.lambda_switch)
 and compile_string_cases cxt switch_exp table default =
   compile_general_cases
     (fun _ -> None)
-    (fun (as_value: Lambda.as_value) -> match as_value with
-      | AsString s -> E.str s ~delim:DStarJ
-      | AsInt i -> E.small_int i)
+    E.as_value
     E.string_equal cxt
     (fun ?default ?declaration e clauses ->
       S.string_switch ?default ?declaration e clauses)

jscomp/core/lam_compile_const.ml

@@ -50,9 +50,7 @@ and translate (x : Lam_constant.t) : J.expression =
   | Const_int { i; comment = Pt_constructor {cstr_name={name; as_value=None}}} when name <> "[]" ->
       E.str name
   | Const_int { i; comment = Pt_constructor {cstr_name={as_value = Some as_value}}}  ->
-    ( match as_value with
-      | AsString s -> E.str s
-      | AsInt i -> E.small_int i)
+      E.as_value as_value
   | 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

jscomp/frontend/ast_attributes.ml

@@ -334,12 +334,39 @@ let iter_process_bs_string_or_int_as (attrs : Parsetree.attributes) =
       | _ -> ());
   !st
 
-let process_as_value attrs : Lambda.as_value option =
-  match iter_process_bs_string_or_int_as attrs with
-  | None -> None
-  | Some (Str (s, _)) -> Some (AsString s)
-  | Some (Int i) -> Some (AsInt i)
-
+let process_as_value (attrs : t) =
+  let st : Lambda.as_value option ref = ref None in
+  Ext_list.iter attrs (fun (({ txt; loc }, payload) as attr) ->
+      match txt with
+      | "bs.as" | "as" ->
+          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 (AsString s));
+            (match Ast_payload.is_single_int payload with
+            | None -> ()
+            | Some i ->
+                Bs_ast_invariant.mark_used_bs_attribute attr;
+                st := Some (AsInt i));
+            (match Ast_payload.is_single_ident payload with
+            | None -> ()
+            | Some Lident "null" ->
+                Bs_ast_invariant.mark_used_bs_attribute attr;
+                st := Some AsNull
+            | Some Lident "undefined" ->
+                Bs_ast_invariant.mark_used_bs_attribute attr;
+                st := Some AsUndefined
+            | Some Lident "unboxed" ->
+                Bs_ast_invariant.mark_used_bs_attribute attr;
+                st := Some AsUnboxed
+            |  Some _ -> Bs_syntaxerr.err loc InvalidVariantAsAnnotation);
+            if !st = None then Bs_syntaxerr.err loc InvalidVariantAsAnnotation
+          )
+          else Bs_syntaxerr.err loc Duplicated_bs_as
+      | _ -> ());
+  !st
 
 let locg = Location.none
 (* let bs : attr

jscomp/frontend/ast_payload.ml

@@ -69,6 +69,20 @@ let is_single_int (x : t) : int option =
       Some (int_of_string name)
   | _ -> None
 
+let is_single_ident (x : t) = match x with
+  | PStr
+      [
+        {
+          pstr_desc =
+            Pstr_eval
+              ({ pexp_desc = Pexp_ident lid }, _);
+          _;
+        };
+      ] ->
+      Some lid.txt
+  | _ -> None
+
+
 let raw_as_string_exp_exn ~(kind : Js_raw_info.raw_kind) ?is_function (x : t) :
     Parsetree.expression option =
   match x with

jscomp/frontend/ast_payload.mli

@@ -39,6 +39,8 @@ val is_single_string_as_ast : t -> Parsetree.expression option
 
 val is_single_int : t -> int option
 
+val is_single_ident : t -> Longident.t option
+
 val raw_as_string_exp_exn :
   kind:Js_raw_info.raw_kind ->
   ?is_function:bool ref ->

jscomp/frontend/bs_syntaxerr.ml

@@ -51,6 +51,7 @@ type error =
   | Optional_in_uncurried_bs_attribute
   | Bs_this_simple_pattern
   | Bs_uncurried_arity_too_large
+  | InvalidVariantAsAnnotation
 
 let pp_error fmt err =
   Format.pp_print_string fmt
@@ -80,7 +81,7 @@ let pp_error fmt err =
     | Duplicated_bs_deriving -> "duplicate bs.deriving attribute"
     | Conflict_attributes -> "conflicting attributes "
     | Expect_string_literal -> "expect string literal "
-    | Duplicated_bs_as -> "duplicate %@as "
+    | Duplicated_bs_as -> "duplicate @as "
     | Expect_int_literal -> "expect int literal "
     | Expect_int_or_string_or_json_literal ->
         "expect int, string literal or json literal {json|text here|json} "
@@ -96,7 +97,10 @@ let pp_error fmt err =
          each constructor must have an argument."
     | Conflict_ffi_attribute str -> "Conflicting attributes: " ^ str
     | Bs_this_simple_pattern ->
-        "%@this expect its pattern variable to be simple form")
+        "%@this expect its pattern variable to be simple form"
+    | InvalidVariantAsAnnotation ->
+      "A variant case annotation @as(...) must be a string or integer or null"
+    )
 
 type exn += Error of Location.t * error
 

jscomp/frontend/bs_syntaxerr.mli

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

jscomp/ml/lambda.ml

@@ -38,7 +38,7 @@ type record_repr =
   | Record_regular
   | Record_optional
 
-type as_value = AsString of string | AsInt of int
+type as_value = AsString of string | AsInt of int | AsNull | AsUndefined | AsUnboxed
 type cstr_name = {name: string; as_value: as_value option}
 
 type tag_info = 

jscomp/ml/lambda.mli

@@ -38,7 +38,7 @@ type record_repr =
   | Record_regular 
   | Record_optional
 
-type as_value = AsString of string | AsInt of int
+type as_value = AsString of string | AsInt of int | AsNull | AsUndefined | AsUnboxed
 type cstr_name = {name:string; as_value: as_value option}
 
 type tag_info = 

jscomp/ml/matching.ml

@@ -1330,7 +1330,11 @@ let make_constr_matching p def ctx = function
   | ((arg, _mut) :: argl) ->
       let cstr = pat_as_constr p in
       let newargs =
-        if cstr.cstr_inlined <> None then
+        if cstr.cstr_inlined <> None ||
+          Ext_list.exists cstr.cstr_attributes (function
+            | ({txt="as"}, PStr [{pstr_desc = Pstr_eval
+                ({pexp_desc = Pexp_ident {txt= Lident "unboxed"}}, _)}]) -> true
+            | _ -> false) then
           (arg, Alias) :: argl
         else match cstr.cstr_tag with
         | Cstr_block _ when