ensure that variant spreads are compliant with the underlying variant…

…s runtime configuration, and get some basic error reporting going

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_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_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_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,7 @@ type error =
   | Bad_unboxed_attribute of string
   | Boxed_and_unboxed
   | Nonrec_gadt
+  | Variant_runtime_representation_mismatch of Variant_coercion.variant_error
 
 open Typedtree
 
@@ -1323,7 +1324,11 @@ let transl_type_decl env rec_flag sdecl_list =
         {sdecl with
          ptype_name; ptype_kind = Ptype_abstract; ptype_manifest = None})
       fixed_types
-    @ (sdecl_list |> Variant_type_spread.expand_variant_spreads env)
+    @ (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))
+    )
   in
 
   (* Create identifiers. *)
@@ -2126,6 +2131,32 @@ 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")
+
 
 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};
+            }))

jscomp/ml/variant_type_spread.ml

@@ -31,7 +31,14 @@ let expand_variant_spreads (env : Env.t)
                               Typetexp.find_type env ptyp_loc loc.txt
                             in
                             match type_decl with
-                            | {type_kind = Type_variant cstrs} ->
+                            | {type_kind = Type_variant cstrs; type_attributes}
+                              ->
+                              Variant_coercion
+                              .variant_configuration_can_be_coerced_raises
+                                ~is_spread_context:true ~left_loc:loc.loc
+                                ~left_attributes:type_attributes
+                                ~right_attributes:sdecl.ptype_attributes
+                                ~right_loc:sdecl.ptype_loc;
                               (* We add back the spread constructor here so the type checker
                                  helps us resolve its type (we'll obviously filter this out
                                  at a later stage). We also append the type identifier so we
@@ -78,7 +85,11 @@ let expand_variant_spreads (env : Env.t)
                                               cstr.cd_loc;
                                         }))
                             | _ -> [c]
-                          with _ ->
+                          with
+                          | Variant_coercion.VariantConfigurationError _ as err
+                            ->
+                            raise err
+                          | _ ->
                             (* Did not find type. Can't spread here, report as error that types need to be known before hand. *)
                             [c])
                         | _ -> [c])
@@ -98,7 +109,7 @@ let remove_is_spread_attribute (attr : Parsetree.attribute) =
   | {txt = "res.constructor_from_spread"}, PStr [] -> false
   | _ -> false
 
-(* Add dummy arguments of the right length to constructors that comes 
+(* Add dummy arguments of the right length to constructors that comes
    from spreads, and that has arguments. *)
 let expand_dummy_constructor_args (sdecl_list : Parsetree.type_declaration list)
     (decls : (Ident.t * Types.type_declaration) list) =