Introduce untagged variants. (rescript-lang#6103)

* Towards prototyping untagged variants.

Just disable the type error for now.

* First few examples working.

* No need for @as(unboxed) anymore.

* Move type defs around.

* Unify type definitions for untagged.

* Example of boolean config.

* Add handling of float.

* Add example with 2 object types.

* Add partial treatment of unknown. wip

* Clean up names of types.

* Rename: literal

* More renaming.

* rename: Block

* Handle unknown case.

* Add Object.

* Add typeof to body of switch.

* Complete classification of blocks.

* Check that the type def is in one of the forms allowed.

* Fix well-formedness test

no other blocks when there's an unknown

* rename

* More renaming.

* Add specific function compile_untagged_cases

* Add example with only blocks.

* Add support for array types.

* Simplify well-formedness check.

* Add Json example.

And add built-in knowledge that Js.Dict.t is an object.

* Fix instanceof array.

* flip

* Fix compilation of unknown.

* Add untagged variant support to genType.

* Update CHANGELOG.md

Author: cristianoc

CHANGELOG.md

@@ -31,6 +31,7 @@ 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
+- Introduce untagged variants https://github.com/rescript-lang/rescript-compiler/pull/6103
 
 #### :boom: Breaking Change
 

jscomp/core/j.ml

@@ -76,7 +76,7 @@ and for_ident = ident
 and for_direction = Js_op.direction_flag
 and property_map = (property_name * expression) list
 and length_object = Js_op.length_object
-and delim = External_arg_spec.delim = | DNone | DStarJ | DJson
+and delim = External_arg_spec.delim = | DNone | DStarJ | DNoQuotes
 
 and expression_desc =
   | Length of expression * length_object
@@ -244,7 +244,7 @@ and case_clause = {
   comment : string option;
 }
 
-and string_clause = Lambda.as_value * case_clause
+and string_clause = Lambda.literal * case_clause
 and int_clause = int * case_clause
 
 and statement_desc =

jscomp/core/js_dump.ml

@@ -600,7 +600,7 @@ and expression_desc cxt ~(level : int) f x : cxt =
       let () =
         match delim with
         | DStarJ -> P.string f ("\"" ^ txt ^ "\"")
-        | DJson -> P.string f txt
+        | DNoQuotes -> P.string f txt
         | DNone -> Js_dump_string.pp_string f txt
       in
       cxt
@@ -751,6 +751,7 @@ and expression_desc cxt ~(level : int) f x : cxt =
   | Caml_block (el, _, _, ((Blk_extension | Blk_record_ext _) as ext)) ->
       expression_desc cxt ~level f (exn_block_as_obj ~stack:false el ext)
   | Caml_block (el, _, tag, Blk_record_inlined p) ->
+      let untagged = Ast_attributes.process_untagged p.attrs in
       let objs =
         let tails =
           Ext_list.combine_array_append p.fields el
@@ -774,16 +775,20 @@ and expression_desc cxt ~(level : int) f x : cxt =
               | Undefined when is_optional f -> None
               | _ -> Some (f, x))
           in
-        ( 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
+        if untagged then
+          tails
+        else
+          (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 literal -> E.literal literal )
+          :: 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 literal = Ast_attributes.process_as_value p.attrs in
+      let untagged = Ast_attributes.process_untagged p.attrs in
       let tag_name = match Ast_attributes.process_tag_name p.attrs with
         | None -> L.tag
         | Some s -> s in
@@ -800,17 +805,17 @@ and expression_desc cxt ~(level : int) f x : cxt =
              [ (name_symbol, E.str p.name) ]
             else [])
         in
-        if (as_value = Some AsUnboxed || not_is_cons = false) && p.num_nonconst = 1 then tails
+        if untagged || (not_is_cons = false) && p.num_nonconst = 1 then tails
         else
           ( Js_op.Lit tag_name, (* TAG:xx *) 
-            match as_value with
+            match literal with
             | None -> E.str p.name
-            | Some as_value -> E.as_value as_value )
+            | Some literal -> E.literal literal )
           :: tails
       in
       let exp = match objs with
-        | [(_, e)] when as_value = Some AsUnboxed -> e.expression_desc
-        | _ when as_value = Some AsUnboxed -> assert false (* should not happen *)
+        | [(_, e)] when untagged -> e.expression_desc
+        | _ when untagged -> 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
@@ -1205,8 +1210,8 @@ 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_as_value f (as_value: Lambda.as_value) =
-            let e = E.as_value as_value in
+          let pp_as_value f (literal: Lambda.literal) =
+            let e = E.literal literal 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

jscomp/core/js_exp_make.ml

@@ -173,6 +173,9 @@ let typeof ?comment (e : t) : t =
   | Bool _ -> str ?comment L.js_type_boolean
   | _ -> { expression_desc = Typeof e; comment }
 
+let instanceof ?comment (e0 : t) (e1: t) : t =
+  { expression_desc = Bin (InstanceOf, e0, e1); comment }
+
 let new_ ?comment e0 args : t =
   { expression_desc = New (e0, Some args); comment }
 
@@ -328,15 +331,21 @@ let zero_float_lit : t =
 let float_mod ?comment e1 e2 : J.expression =
   { comment; expression_desc = Bin (Mod, e1, e2) }
 
-let as_value = function
-  | Lambda.AsString s -> str s ~delim:DStarJ
-  | AsInt i -> small_int i
-  | AsFloat f -> float f
-  | 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 literal = function
+  | Lambda.String s -> str s ~delim:DStarJ
+  | Int i -> small_int i
+  | Float f -> float f
+  | Bool b -> bool b
+  | Null -> nil
+  | Undefined -> undefined
+  | Block IntType -> str "number"
+  | Block FloatType -> str "number"
+  | Block StringType -> str "string"
+  | Block Array -> str "Array" ~delim:DNoQuotes
+  | Block Object -> str "object"
+  | Block Unknown ->
+    (* TODO: clean up pattern mathing algo whih confuses literal with blocks *)
+    assert false
 
 let array_index ?comment (e0 : t) (e1 : t) : t =
   match (e0.expression_desc, e1.expression_desc) with
@@ -762,7 +771,35 @@ 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 ?(has_null_undefined_other=(false, false, false)) (e : t) : t =
+let rec is_a_literal_case ~(literal_cases : Lambda.literal list) ~block_cases (e:t) : t =
+  let is_literal_case (l:Lambda.literal) : t = bin EqEqEq e (literal l) in
+  let is_block_case (c:Lambda.block_type) : t = match c with
+  | StringType -> bin NotEqEq (typeof e) (str "string")
+  | IntType -> bin NotEqEq (typeof e) (str "number")
+  | FloatType -> bin NotEqEq (typeof e) (str "number")
+  | Array ->  not (bin InstanceOf e (str "Array" ~delim:DNoQuotes))
+  | Object ->  { expression_desc = Bin (NotEqEq, typeof e, str "object"); comment=None }
+  | Unknown ->
+    (* We don't know the type of unknown, so we need to express:
+       this is not one of the literals *)
+    (match literal_cases with
+      | [] ->
+        (* this should not happen *)
+        assert false
+      | l1 :: others ->
+        let is_literal_1 = is_literal_case l1 in
+        Ext_list.fold_right others is_literal_1 (fun literal_n acc ->
+          bin Or (is_literal_case literal_n) acc
+        )
+    )
+  in
+  match block_cases with
+  | [c] -> is_block_case c
+  | c1 :: (_::_ as rest) ->
+    bin And (is_block_case c1) (is_a_literal_case ~literal_cases ~block_cases:rest e)
+  | [] -> assert false
+
+let is_int_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 }

jscomp/core/js_exp_make.mli

@@ -185,7 +185,7 @@ val assign_by_exp : t -> t -> t -> t
 
 val assign : ?comment:string -> t -> t -> t
 
-val as_value : Lambda.as_value -> t
+val literal : Lambda.literal -> t
 
 val triple_equal : ?comment:string -> t -> t -> t
 (* TODO: reduce [triple_equal] use *)
@@ -202,13 +202,16 @@ val neq_null_undefined_boolean : ?comment:string -> t -> t -> t
 
 val is_type_number : ?comment:string -> t -> t
 
-val is_tag : ?has_null_undefined_other:(bool * bool * bool) -> t -> t
+val is_int_tag : ?has_null_undefined_other:(bool * bool * bool) -> t -> t
+
+val is_a_literal_case : literal_cases:Lambda.literal list -> block_cases:Lambda.block_type list -> t -> t
 
 val is_type_string : ?comment:string -> t -> t
 
 val is_type_object : t -> t
 
 val typeof : ?comment:string -> t -> t
+val instanceof : ?comment:string -> t -> t -> t
 
 val to_int32 : ?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
               (Ext_list.map dispatches (fun (s, r) ->
-                   ( Lambda.AsString s,
+                   ( Lambda.String s,
                      J.
                        {
                          switch_body = [ S.return_stmt (E.str r) ];
@@ -80,7 +80,7 @@ let eval_as_event (arg : J.expression)
                   S.string_switch
                     (E.poly_var_tag_access arg)
                     (Ext_list.map dispatches (fun (s, r) ->
-                         ( Lambda.AsString s,
+                         ( Lambda.String s,
                            J.
                              {
                                switch_body = [ S.return_stmt (E.str r) ];
@@ -108,7 +108,7 @@ let eval_as_int (arg : J.expression) (dispatches : (string * int) list) : E.t =
           [
             S.string_switch arg
               (Ext_list.map dispatches (fun (s, r) ->
-                   ( Lambda.AsString s,
+                   ( Lambda.String s,
                      J.
                        {
                          switch_body =

jscomp/core/js_op.ml

@@ -48,6 +48,7 @@ type binop =
   | Mul
   | Div
   | Mod
+  | InstanceOf
 
 (**
    note that we don't need raise [Div_by_zero] in ReScript

jscomp/core/js_op_util.ml

@@ -34,7 +34,7 @@ let op_prec (op : Js_op.binop) =
   | Or -> (3, 3, 3)
   | And -> (4, 4, 4)
   | EqEqEq | NotEqEq -> (8, 8, 9)
-  | Gt | Ge | Lt | Le (* | InstanceOf *) -> (9, 9, 10)
+  | Gt | Ge | Lt | Le | InstanceOf -> (9, 9, 10)
   | Bor -> (5, 5, 5)
   | Bxor -> (6, 6, 6)
   | Band -> (7, 7, 7)
@@ -73,7 +73,7 @@ let op_str (op : Js_op.binop) =
   | Le -> "<="
   | Gt -> ">"
   | Ge -> ">="
-(* | InstanceOf -> "instanceof" *)
+  | InstanceOf -> "instanceof"
 
 let op_int_str (op : Js_op.int_op) =
   match op with

jscomp/core/js_stmt_make.ml

@@ -129,16 +129,18 @@ 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 : (Lambda.as_value * J.case_clause) list) : t =
+    (e : J.expression) (clauses : (Lambda.literal * J.case_clause) list) : t =
   match e.expression_desc with
   | Str {txt} -> (
       let continuation =
         match
           Ext_list.find_opt clauses (fun (switch_case, x) ->
             match switch_case with
-            | AsString s ->
+            | String s ->
               if s = txt then Some x.switch_body else None
-            | AsInt _  | AsFloat _| AsBool _ | AsNull | AsUnboxed | AsUndefined -> None)
+            | Int _  | Float _| Bool _ | Null
+            | Undefined
+            | Block _ -> 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 ->
-  (Lambda.as_value * J.case_clause) list ->
+  (Lambda.literal * J.case_clause) list ->
   t
 
 val declare_variable :