Refactor untagged variants (#6128)

* Refctor untagged variant files

Move closer to the type checker, and encapsulate logic inside Ast_untagged_variants

* rename

* Move more to untagged variant ast

* Move well-formedness check to the type checker.

So errors appear on type definition, not on first use of pattern matching.

CC @cknitt

* Move type defs from lambda.

* rename literal

* Rename cstr_name to literal.

* Check for duplicate literals.

CC @cknitt

* Apply duplicate literal check to normal variants too.

Author: cristianoc

jscomp/core/j.ml

@@ -244,7 +244,7 @@ and case_clause = {
   comment : string option;
 }
 
-and string_clause = Lambda.literal * case_clause
+and string_clause = Ast_untagged_variants.literal_type * case_clause
 and int_clause = int * case_clause
 
 and statement_desc =

jscomp/core/js_dump.ml

@@ -751,7 +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 untagged = Ast_untagged_variants.process_untagged p.attrs in
       let objs =
         let tails =
           Ext_list.combine_array_append p.fields el
@@ -763,7 +763,7 @@ 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
+        let tag_name = match Ast_untagged_variants.process_tag_name p.attrs with
         | None -> L.tag
         | Some s -> s in
         let tails =
@@ -779,17 +779,17 @@ and expression_desc cxt ~(level : int) f x : cxt =
           tails
         else
           (Js_op.Lit tag_name, (* TAG:xx for inline records *)
-            match Ast_attributes.process_as_value p.attrs with
+            match Ast_untagged_variants.process_literal_type 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 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
+      let literal = Ast_untagged_variants.process_literal_type p.attrs in
+      let untagged = Ast_untagged_variants.process_untagged p.attrs in
+      let tag_name = match Ast_untagged_variants.process_tag_name p.attrs with
         | None -> L.tag
         | Some s -> s in
       let objs =
@@ -1210,7 +1210,7 @@ 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 (literal: Lambda.literal) =
+          let pp_as_value f (literal: Ast_untagged_variants.literal_type) =
             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

jscomp/core/js_exp_make.ml

@@ -336,7 +336,7 @@ let float_mod ?comment e1 e2 : J.expression =
   { comment; expression_desc = Bin (Mod, e1, e2) }
 
 let literal = function
-  | Lambda.String s -> str s ~delim:DStarJ
+  | Ast_untagged_variants.String s -> str s ~delim:DStarJ
   | Int i -> small_int i
   | Float f -> float f
   | Bool b -> bool b
@@ -775,7 +775,7 @@ 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 rec is_a_literal_case ~(literal_cases : Lambda.literal list) ~block_cases (e:t) : t =
+let rec is_a_literal_case ~(literal_cases : Ast_untagged_variants.literal_type list) ~block_cases (e:t) : t =
   let literals_overlaps_with_string () = 
     Ext_list.exists literal_cases (function
       | String _ -> true
@@ -792,8 +792,8 @@ let rec is_a_literal_case ~(literal_cases : Lambda.literal list) ~block_cases (e
   let (!=) x y = bin NotEqEq x y in
   let (||) x y = bin Or x y in
   let (&&) x y = bin And x y in
-  let is_literal_case (l:Lambda.literal) : t =  e == (literal l) in
-  let is_not_block_case (c:Lambda.block_type) : t = match c with
+  let is_literal_case (l:Ast_untagged_variants.literal_type) : t =  e == (literal l) in
+  let is_not_block_case (c:Ast_untagged_variants.block_type) : t = match c with
   | StringType when literals_overlaps_with_string () = false  (* No overlap *) -> 
     (typeof e) != (str "string")
   | IntType when literals_overlaps_with_number () = false ->

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 literal : Lambda.literal -> t
+val literal : Ast_untagged_variants.literal_type -> t
 
 val triple_equal : ?comment:string -> t -> t -> t
 (* TODO: reduce [triple_equal] use *)
@@ -204,7 +204,7 @@ val is_type_number : ?comment:string -> 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_a_literal_case : literal_cases:Ast_untagged_variants.literal_type list -> block_cases:Ast_untagged_variants.block_type list -> t -> t
 
 val is_type_string : ?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.String s,
+                   ( Ast_untagged_variants.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.String s,
+                         ( Ast_untagged_variants.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.String s,
+                   ( Ast_untagged_variants.String s,
                      J.
                        {
                          switch_body =

jscomp/core/js_stmt_make.ml

@@ -129,7 +129,7 @@ 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.literal * J.case_clause) list) : t =
+    (e : J.expression) (clauses : (Ast_untagged_variants.literal_type * J.case_clause) list) : t =
   match e.expression_desc with
   | Str {txt} -> (
       let continuation =

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.literal * J.case_clause) list ->
+  (Ast_untagged_variants.literal_type * J.case_clause) list ->
   t
 
 val declare_variable :

jscomp/core/lam.ml

@@ -39,7 +39,7 @@ module Types = struct
     sw_blocks_full : bool;
     sw_blocks : (int * t) list;
     sw_failaction : t option;
-    sw_names : Lambda.switch_names option;
+    sw_names : Ast_untagged_variants.switch_names option;
   }
 
   and lfunction = {
@@ -116,7 +116,7 @@ module X = struct
     sw_blocks_full : bool;
     sw_blocks : (int * t) list;
     sw_failaction : t option;
-    sw_names : Lambda.switch_names option;
+    sw_names : Ast_untagged_variants.switch_names option;
   }
 
   and prim_info = Types.prim_info = {

jscomp/core/lam.mli

@@ -38,7 +38,7 @@ type lambda_switch = {
   sw_blocks_full : bool;
   sw_blocks : (int * t) list;
   sw_failaction : t option;
-  sw_names : Lambda.switch_names option;
+  sw_names : Ast_untagged_variants.switch_names option;
 }
 
 and apply = private { ap_func : t; ap_args : t list; ap_info : ap_info }

jscomp/core/lam_compile.ml

@@ -138,22 +138,22 @@ let default_action ~saturated failaction =
   | None -> Complete
   | Some x -> if saturated then Complete else Default x
 
-let get_const_name i (sw_names : Lambda.switch_names option) =
+let get_const_name i (sw_names : Ast_untagged_variants.switch_names option) =
   match sw_names with None -> None | Some { consts } -> Some consts.(i)
 
-let get_block i (sw_names : Lambda.switch_names option) =
+let get_block i (sw_names : Ast_untagged_variants.switch_names option) =
   match sw_names with None -> None | Some { blocks } -> Some blocks.(i)
 
-let get_tag_name (sw_names : Lambda.switch_names option) =
+let get_tag_name (sw_names : Ast_untagged_variants.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
+    (match Array.find_opt (fun {Ast_untagged_variants.tag_name} -> tag_name <> None) blocks with
     | Some {tag_name = Some s} -> s
     | _ -> Js_dump_lit.tag
     )
 
-let get_block_cases (sw_names : Lambda.switch_names option) =
+let get_block_cases (sw_names : Ast_untagged_variants.switch_names option) =
   let res = ref [] in
   (match sw_names with
   | None -> res := []
@@ -165,25 +165,25 @@ let get_block_cases (sw_names : Lambda.switch_names option) =
   );
   !res
 
-let get_literal_cases (sw_names : Lambda.switch_names option) =
+let get_literal_cases (sw_names : Ast_untagged_variants.switch_names option) =
   let res = ref [] in
   (match sw_names with
   | None -> res := []
   | Some { consts  } ->
     Ext_array.iter consts (function
-    | {literal = Some literal} -> res := literal :: !res
-    | {name; literal = None} -> res := String name :: !res
+    | {literal_type = Some literal} -> res := literal :: !res
+    | {name; literal_type = None} -> res := String name :: !res
     )
   );
   !res
 
 
-let has_null_undefined_other (sw_names : Lambda.switch_names option) =
+let has_null_undefined_other (sw_names : Ast_untagged_variants.switch_names option) =
   let (null, undefined, other) = (ref false, ref false, ref false) in
   (match sw_names with
   | None -> ()
   | Some { consts; blocks } ->
-    Ext_array.iter consts (fun x -> match x.literal with
+    Ext_array.iter consts (fun x -> match x.literal_type with
       | Some Undefined -> undefined := true
       | Some Null -> null := true
       | _ -> other := true);
@@ -500,7 +500,7 @@ and compile_recursive_lets cxt id_args : Js_output.t =
 
 and compile_general_cases :
       'a .
-      ('a -> Lambda.cstr_name option) ->
+      ('a -> Ast_untagged_variants.literal option) ->
       ('a -> J.expression) ->
       ('a option -> J.expression -> 'a option -> J.expression -> J.expression) ->
       Lam_compile_context.t ->
@@ -513,7 +513,7 @@ and compile_general_cases :
       ('a * Lam.t) list ->
       default_case ->
       J.block =
- fun (get_cstr_name : _ -> Lambda.cstr_name option) (make_exp : _ -> J.expression)
+ fun (get_cstr_name : _ -> Ast_untagged_variants.literal option) (make_exp : _ -> J.expression)
      (eq_exp : 'a option -> J.expression -> 'a option -> J.expression -> J.expression)
      (cxt : Lam_compile_context.t)
      (switch :
@@ -619,9 +619,9 @@ and compile_general_cases :
 and use_compile_literal_cases table get_name =
   List.fold_right (fun (i, lam) acc ->
     match get_name i, acc with
-    | Some {Lambda.literal = Some literal}, Some string_table ->
+    | Some {Ast_untagged_variants.literal_type = Some literal}, Some string_table ->
        Some ((literal, lam) :: string_table)
-    | Some {name; literal = None}, Some string_table -> Some ((String name, lam) :: string_table)
+    | Some {name; literal_type = None}, Some string_table -> Some ((String name, lam) :: string_table)
     | _, _ -> None
   ) table (Some [])
 and compile_cases ?(untagged=false) cxt (switch_exp : E.t) table default get_name =
@@ -634,7 +634,7 @@ and compile_cases ?(untagged=false) cxt (switch_exp : E.t) table default get_nam
       compile_general_cases get_name
         (fun i -> match get_name i with
           | None -> E.small_int i
-          | Some {literal = Some(String s)} -> E.str s
+          | Some {literal_type = Some(String s)} -> E.str s
           | Some {name} -> E.str name)
         (fun _ x _ y -> E.int_equal x y) cxt
         (fun ?default ?declaration e clauses ->
@@ -671,9 +671,9 @@ and compile_switch (switch_arg : Lam.t) (sw : Lam.lambda_switch)
   let get_block_name i = match get_block i with
     | None -> None
     | Some ({block_type = Some block_type} as block) ->
-      Some {block.cstr_name with literal = Some (Block block_type)}
-    | Some ({block_type = None; cstr_name}) ->
-      Some cstr_name in
+      Some {block.literal with literal_type = Some (Block block_type)}
+    | Some ({block_type = None; literal}) ->
+      Some literal in
   let tag_name = get_tag_name sw_names in
   let untagged = block_cases <> [] in
   let compile_whole (cxt : Lam_compile_context.t) =
@@ -744,7 +744,7 @@ and compile_untagged_cases cxt switch_exp table default =
   let literal = function
     | literal -> E.literal literal
   in
-  let add_runtime_type_check (literal: Lambda.literal) x y = match literal with
+  let add_runtime_type_check (literal: Ast_untagged_variants.literal_type) x y = match literal with
   | Block IntType
   | Block StringType
   | Block FloatType
@@ -754,14 +754,14 @@ and compile_untagged_cases cxt switch_exp table default =
     (* This should not happen because unknown must be the only non-literal case *)
     assert false 
   | Bool _ | Float _ | Int _ | String _ | Null | Undefined -> x in
-  let mk_eq (i : Lambda.literal option) x j y = match i, j with
+  let mk_eq (i : Ast_untagged_variants.literal_type option) x j y = match i, j with
     | Some literal, _ -> (* XX *)
       add_runtime_type_check literal x y
     | _, Some literal ->
       add_runtime_type_check literal y x
     | _ -> E.string_equal x y
   in
-  let is_array (l, _) = l = Lambda.Block Array in
+  let is_array (l, _) = l = Ast_untagged_variants.Block Array in
   let body ?default ?declaration e clauses =
     let array_clauses = Ext_list.filter clauses is_array in
     match array_clauses with
@@ -786,7 +786,7 @@ and compile_stringswitch l cases default (lambda_cxt : Lam_compile_context.t) =
       Be careful: we should avoid multiple evaluation of l,
       The [gen] can be elimiated when number of [cases] is less than 3
   *)
-  let cases = cases |> List.map (fun (s,l) -> Lambda.String s, l) in
+  let cases = cases |> List.map (fun (s,l) -> Ast_untagged_variants.String s, l) in
   match
     compile_lambda { lambda_cxt with continuation = NeedValue Not_tail } l
   with