Variant type spreads (#6316)

* parse ... in variants

* initial implementation of expanding variant type spreads

* transfer attributes

* comments and clarifications

* ensure that variant spreads are compliant with the underlying variants runtime configuration, and get some basic error reporting going

* proper error reporting for non-discoverable types

* report errors on duplicate constructors in spreads

* error on type parameters in variant type spreads

* make inline records work when spreading variants

Author: zth

jscomp/build_tests/super_errors/expected/variant_spread_duplicate_constructors.res.expected

@@ -0,0 +1,11 @@
+
+  We've found a bug for you!
+  /.../fixtures/variant_spread_duplicate_constructors.res:3:22
+
+  1 │ type a = One | Two
+  2 │ type b = Two | Three
+  3 │ type c = | ...a | ...b | Four
+  4 │ 
+
+  Variant b has a constructor named Two, but a constructor named Two already exists in the variant it's spread into.
+  You cannot spread variants with overlapping constructors.

jscomp/build_tests/super_errors/expected/variant_spread_inline_records.res.expected

@@ -0,0 +1,10 @@
+
+  We've found a bug for you!
+  /.../fixtures/variant_spread_inline_records.res:4:16-30
+
+  2 │ type b = | ...a | Three
+  3 │ 
+  4 │ let b: b = One({name: "hello"})
+
+  Some required record fields are missing:
+  age. If this is a component, add the missing props.

jscomp/build_tests/super_errors/expected/variant_spread_recursive.res.expected

@@ -0,0 +1,8 @@
+
+  We've found a bug for you!
+  /.../fixtures/variant_spread_recursive.res:1:65
+
+  1 │ type rec a = One | Two | Three and b = Four | Five and c = | ...a | ...b
+  2 │ 
+
+  This type could not be found. It's only possible to spread variants that are known as the spread happens. This means for example that you can't spread variants in recursive definitions.

jscomp/build_tests/super_errors/expected/variant_spread_tag_missing.res.expected

@@ -0,0 +1,9 @@
+
+  We've found a bug for you!
+  /.../fixtures/variant_spread_tag_missing.res:2:15
+
+  1 │ @tag("kind") type a = One(int) | Two(string)
+  2 │ type b = | ...a | Three(bool)
+  3 │ 
+
+  The @tag attribute does not match for this variant and the variant where this is spread. Both variants must have the same @tag attribute configuration, or no @tag attribute at all.

jscomp/build_tests/super_errors/expected/variant_spread_tag_value_mismatch.res.expected

@@ -0,0 +1,9 @@
+
+  We've found a bug for you!
+  /.../fixtures/variant_spread_tag_value_mismatch.res:2:28
+
+  1 │ @tag("kind") type a = One(int) | Two(string)
+  2 │ @tag("name") type b = | ...a | Three(bool)
+  3 │ 
+
+  The @tag attribute does not match for this variant and the variant where this is spread. Both variants must have the same @tag attribute configuration, or no @tag attribute at all.

jscomp/build_tests/super_errors/expected/variant_spread_type_parameters.res.expected

@@ -0,0 +1,8 @@
+
+  We've found a bug for you!
+  /.../fixtures/variant_spread_type_parameters.res:2:15
+
+  1 │ type a<'a> = One | Two('a)
+  2 │ type b = | ...a<int> | Three
+
+  Type parameters are not supported in variant type spreads.

jscomp/build_tests/super_errors/expected/variant_spread_unboxed_mismatch.res.expected

@@ -0,0 +1,9 @@
+
+  We've found a bug for you!
+  /.../fixtures/variant_spread_unboxed_mismatch.res:2:15
+
+  1 │ @unboxed type a = One(int) | Two(string)
+  2 │ type b = | ...a | Three(bool)
+  3 │ 
+
+  This variant is unboxed, but the variant where this is spread is not. Both variants unboxed configuration must match.

jscomp/build_tests/super_errors/fixtures/variant_spread_duplicate_constructors.res

@@ -0,0 +1,3 @@
+type a = One | Two
+type b = Two | Three
+type c = | ...a | ...b | Four

jscomp/build_tests/super_errors/fixtures/variant_spread_inline_records.res

@@ -0,0 +1,4 @@
+type a = One({name: string, age: int}) | Two
+type b = | ...a | Three
+
+let b: b = One({name: "hello"})

jscomp/build_tests/super_errors/fixtures/variant_spread_recursive.res

@@ -0,0 +1 @@
+type rec a = One | Two | Three and b = Four | Five and c = | ...a | ...b

jscomp/build_tests/super_errors/fixtures/variant_spread_tag_missing.res

@@ -0,0 +1,2 @@
+@tag("kind") type a = One(int) | Two(string)
+type b = | ...a | Three(bool)

jscomp/build_tests/super_errors/fixtures/variant_spread_tag_value_mismatch.res

@@ -0,0 +1,2 @@
+@tag("kind") type a = One(int) | Two(string)
+@tag("name") type b = | ...a | Three(bool)

jscomp/build_tests/super_errors/fixtures/variant_spread_type_parameters.res

@@ -0,0 +1,2 @@
+type a<'a> = One | Two('a)
+type b = | ...a<int> | Three

jscomp/build_tests/super_errors/fixtures/variant_spread_unboxed_mismatch.res

@@ -0,0 +1,2 @@
+@unboxed type a = One(int) | Two(string)
+type b = | ...a | Three(bool)

jscomp/ml/typedecl.ml

@@ -53,6 +53,8 @@ type error =
   | Bad_unboxed_attribute of string
   | Boxed_and_unboxed
   | Nonrec_gadt
+  | Variant_runtime_representation_mismatch of Variant_coercion.variant_error
+  | Variant_spread_fail of Variant_type_spread.variant_type_spread_error
 
 open Typedtree
 
@@ -379,34 +381,109 @@ let transl_declaration ~typeRecordAsObject env sdecl id =
         let copy_tag_attr_from_decl attr =
           let tag_attrs = Ext_list.filter sdecl.ptype_attributes (fun ({txt}, _) -> txt = "tag" || txt = Ast_untagged_variants.untagged) in
           if tag_attrs = [] then attr else tag_attrs @ attr in
+        let constructors_from_variant_spreads = Hashtbl.create 10 in
         let make_cstr scstr =
           let name = Ident.create scstr.pcd_name.txt in
           let targs, tret_type, args, ret_type, _cstr_params =
             make_constructor env (Path.Pident id) params
                              scstr.pcd_args scstr.pcd_res
           in
-          let tcstr =
-            { cd_id = name;
-              cd_name = scstr.pcd_name;
-              cd_args = targs;
-              cd_res = tret_type;
-              cd_loc = scstr.pcd_loc;
-              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 |> copy_tag_attr_from_decl }
-          in
+          if String.starts_with scstr.pcd_name.txt ~prefix:"..." then (
+            (* Any constructor starting with "..." represents a variant type spread, and
+               will have the spread variant itself as a single argument.
+
+               We pull that variant type out, and then track the type of each of its
+               constructors, so that we can replace our dummy constructors added before 
+               type checking  with the realtypes for each constructor.
+               *)
+            (match args with
+            | Cstr_tuple [spread_variant] -> (
+              match Ctype.extract_concrete_typedecl env spread_variant with
+              | (_, _, {type_kind=Type_variant constructors}) -> (
+                constructors |> List.iter(fun (c: Types.constructor_declaration) ->
+                  Hashtbl.add constructors_from_variant_spreads c.cd_id.name c)
+              )
+              | _ -> ()
+            )
+            | _ -> ()); 
+              None)
+          else (
+          (* Check if this constructor is from a variant spread. If so, we need to replace 
+             its type with the right type we've pulled from the type checked spread variant
+             itself. *)
+          let tcstr, cstr = match Hashtbl.find_opt constructors_from_variant_spreads (Ident.name name) with
+          | Some cstr ->
+            let tcstr =
+              {
+                cd_id = name;
+                cd_name = scstr.pcd_name;
+                cd_args =
+                  (match cstr.cd_args with
+                  | Cstr_tuple args ->
+                    Cstr_tuple
+                      (args
+                      |> List.map (fun texpr : Typedtree.core_type ->
+                             {
+                               ctyp_attributes = cstr.cd_attributes;
+                               ctyp_loc = cstr.cd_loc;
+                               ctyp_env = env;
+                               ctyp_type = texpr;
+                               ctyp_desc = Ttyp_any;
+                               (* This is fine because the type checker seems to only look at `ctyp_type` for type checking. *)
+                             }))
+                  | Cstr_record lbls ->
+                    Cstr_record
+                      (lbls
+                      |> List.map
+                           (fun (l : Types.label_declaration) : Typedtree.label_declaration
+                           ->
+                             {
+                               ld_id = l.ld_id;
+                               ld_name = Location.mkloc (Ident.name l.ld_id) l.ld_loc;
+                               ld_mutable = l.ld_mutable;
+                               ld_type =
+                                 {
+                                   ctyp_desc = Ttyp_any;
+                                   ctyp_type = l.ld_type;
+                                   ctyp_env = env;
+                                   ctyp_loc = l.ld_loc;
+                                   ctyp_attributes = [];
+                                 };
+                               ld_loc = l.ld_loc;
+                               ld_attributes = l.ld_attributes;
+                             })));
+                cd_res = tret_type;
+                (* This is also strictly wrong, but is fine because the type checker does not look at this field. *)
+                cd_loc = scstr.pcd_loc;
+                cd_attributes = scstr.pcd_attributes |> copy_tag_attr_from_decl;
+              }
+            in            
             tcstr, cstr
+          | None ->
+            let tcstr =
+              { cd_id = name;
+                cd_name = scstr.pcd_name;
+                cd_args = targs;
+                cd_res = tret_type;
+                cd_loc = scstr.pcd_loc;
+                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 |> copy_tag_attr_from_decl }
+            in
+            tcstr, cstr
+          in Some (tcstr, cstr)
+          )
         in
         let make_cstr scstr =
           Builtin_attributes.warning_scope scstr.pcd_attributes
             (fun () -> make_cstr scstr)
         in
-        let tcstrs, cstrs = List.split (List.map make_cstr scstrs) in
+        let tcstrs, cstrs = List.split (List.filter_map make_cstr scstrs) in
         let isUntaggedDef = Ast_untagged_variants.has_untagged sdecl.ptype_attributes in
         Ast_untagged_variants.check_well_formed ~env ~isUntaggedDef cstrs;
         Ttype_variant tcstrs, Type_variant cstrs, sdecl
@@ -1270,7 +1347,12 @@ let transl_type_decl env rec_flag sdecl_list =
         {sdecl with
          ptype_name; ptype_kind = Ptype_abstract; ptype_manifest = None})
       fixed_types
-    @ sdecl_list
+    @ (try 
+        sdecl_list |> Variant_type_spread.expand_variant_spreads env 
+      with 
+      | Variant_coercion.VariantConfigurationError ((VariantError {left_loc}) as err) -> raise(Error(left_loc, Variant_runtime_representation_mismatch err))
+      | Variant_type_spread.VariantTypeSpreadError (loc, err) -> raise(Error(loc, Variant_spread_fail err))
+    )
   in
 
   (* Create identifiers. *)
@@ -1324,6 +1406,7 @@ let transl_type_decl env rec_flag sdecl_list =
     List.map2 transl_declaration sdecl_list (List.map id_slots id_list) in
   let decls =
     List.map (fun tdecl -> (tdecl.typ_id, tdecl.typ_type)) tdecls in
+  let sdecl_list = Variant_type_spread.expand_dummy_constructor_args sdecl_list decls in
   current_slot := None;
   (* Check for duplicates *)
   check_duplicates sdecl_list;
@@ -2072,6 +2155,40 @@ let report_error ppf = function
   | Nonrec_gadt ->
       fprintf ppf
         "@[GADT case syntax cannot be used in a 'nonrec' block.@]"
+  | Variant_runtime_representation_mismatch
+      (Variant_coercion.VariantError
+        {is_spread_context; error = Variant_coercion.Untagged {left_is_unboxed}})
+    ->
+    let other_variant_text =
+      if is_spread_context then "the variant where this is spread"
+      else "the other variant"
+    in
+    fprintf ppf "@[%s.@]"
+      ("This variant is "
+      ^ (if left_is_unboxed then "unboxed" else "not unboxed")
+      ^ ", but " ^ other_variant_text
+      ^ " is not. Both variants unboxed configuration must match")
+  | Variant_runtime_representation_mismatch
+      (Variant_coercion.VariantError
+        {is_spread_context; error = Variant_coercion.TagName _}) ->
+    let other_variant_text =
+      if is_spread_context then "the variant where this is spread"
+      else "the other variant"
+    in
+    fprintf ppf "@[%s.@]"
+      ("The @tag attribute does not match for this variant and "
+      ^ other_variant_text
+      ^ ". Both variants must have the same @tag attribute configuration, or no \
+        @tag attribute at all")
+  | Variant_spread_fail Variant_type_spread.CouldNotFindType ->
+    fprintf ppf "@[This type could not be found. It's only possible to spread variants that are known as the spread happens. This means for example that you can't spread variants in recursive definitions.@]"
+  | Variant_spread_fail Variant_type_spread.HasTypeParams ->
+    fprintf ppf "@[Type parameters are not supported in variant type spreads.@]"
+  | Variant_spread_fail Variant_type_spread.DuplicateConstructor 
+    {variant_with_overlapping_constructor; overlapping_constructor_name} ->
+    fprintf ppf "@[Variant %s has a constructor named %s, but a constructor named %s already exists in the variant it's spread into.@ You cannot spread variants with overlapping constructors.@]" 
+      variant_with_overlapping_constructor overlapping_constructor_name overlapping_constructor_name
+  
 
 let () =
   Location.register_error_of_exn

jscomp/ml/variant_coercion.ml

@@ -40,6 +40,20 @@ let variant_representation_matches (c1_attrs : Parsetree.attributes)
   | Some s1, Some s2 when s1 = s2 -> true
   | _ -> false
 
+type variant_configuration_error =
+  | Untagged of {left_is_unboxed: bool}
+  | TagName of {left_tag: string option; right_tag: string option}
+
+type variant_error =
+  | VariantError of {
+      left_loc: Location.t;
+      right_loc: Location.t;
+      error: variant_configuration_error;
+      is_spread_context: bool;
+    }
+
+exception VariantConfigurationError of variant_error
+
 let variant_configuration_can_be_coerced (a1 : Parsetree.attributes)
     (a2 : Parsetree.attributes) =
   let unboxed =
@@ -62,3 +76,39 @@ let variant_configuration_can_be_coerced (a1 : Parsetree.attributes)
       | _ -> false
     in
     if not tag then false else true
+
+let variant_configuration_can_be_coerced_raises ~is_spread_context ~left_loc
+    ~right_loc ~(left_attributes : Parsetree.attributes)
+    ~(right_attributes : Parsetree.attributes) =
+  (match
+     ( Ast_untagged_variants.process_untagged left_attributes,
+       Ast_untagged_variants.process_untagged right_attributes )
+   with
+  | true, true | false, false -> ()
+  | left, _right ->
+    raise
+      (VariantConfigurationError
+         (VariantError
+            {
+              is_spread_context;
+              left_loc;
+              right_loc;
+              error = Untagged {left_is_unboxed = left};
+            })));
+
+  match
+    ( Ast_untagged_variants.process_tag_name left_attributes,
+      Ast_untagged_variants.process_tag_name right_attributes )
+  with
+  | Some host_tag, Some spread_tag when host_tag = spread_tag -> ()
+  | None, None -> ()
+  | left_tag, right_tag ->
+    raise
+      (VariantConfigurationError
+         (VariantError
+            {
+              is_spread_context;
+              left_loc;
+              right_loc;
+              error = TagName {left_tag; right_tag};
+            }))