variant configuration errors

Author: zth

compiler/ml/ctype.ml

@@ -83,6 +83,11 @@ type subtype_context =
       variant_name: Path.t;
       issues: Variant_coercion.variant_runtime_representation_issue list;
     }
+  | Variant_configurations_mismatch of {
+      left_variant_name: Path.t;
+      right_variant_name: Path.t;
+      issue: Variant_coercion.variant_configuration_issue;
+    }
 
 exception
   Subtype of
@@ -3587,7 +3592,9 @@ let rec subtype_rec env trace t1 t2 cstrs =
         when Asttypes.Noloc.same_arg_label l1 l2 ->
         let cstrs = subtype_rec env ((t2, t1) :: trace) t2 t1 cstrs in
         subtype_rec env ((u1, u2) :: trace) u1 u2 cstrs
-      | Ttuple tl1, Ttuple tl2 -> subtype_list env trace tl1 tl2 cstrs
+      | Ttuple tl1, Ttuple tl2 ->
+        (* TODO(subtype-errors) Tuple as context *)
+        subtype_list env trace tl1 tl2 cstrs
       | Tconstr (p1, [], _), Tconstr (p2, [], _) when Path.same p1 p2 -> cstrs
       | Tconstr (p1, _tl1, _abbrev1), _
         when generic_abbrev env p1 && safe_abbrev env t1 ->
@@ -3624,6 +3631,7 @@ let rec subtype_rec env trace t1 t2 cstrs =
         subtype_rec env trace (expand_abbrev_opt env t1) t2 cstrs
       | Tconstr (p1, [], _), Tconstr (p2, [], _)
         when Path.same p1 Predef.path_int && Path.same p2 Predef.path_float ->
+        (* Int can always be coerced to float *)
         cstrs
       | Tconstr (path, [], _), Tconstr (_, [], _)
         when Variant_coercion.can_coerce_primitive path
@@ -3699,15 +3707,23 @@ let rec subtype_rec env trace t1 t2 cstrs =
         match
           (extract_concrete_typedecl env t1, extract_concrete_typedecl env t2)
         with
-        | ( (_, _, {type_kind = Type_variant c1; type_attributes = t1attrs}),
-            (_, _, {type_kind = Type_variant c2; type_attributes = t2attrs}) )
-          ->
-          if
-            Variant_coercion.variant_configuration_can_be_coerced t1attrs
+        | ( (p1, _, {type_kind = Type_variant c1; type_attributes = t1attrs}),
+            (p2, _, {type_kind = Type_variant c2; type_attributes = t2attrs}) )
+          -> (
+          match
+            Variant_coercion.variant_configuration_can_be_coerced2 t1attrs
               t2attrs
-            = false
-          then (trace, t1, t2, !univar_pairs, None) :: cstrs
-          else
+          with
+          | Error issue ->
+            ( trace,
+              t1,
+              t2,
+              !univar_pairs,
+              Some
+                (Variant_configurations_mismatch
+                   {left_variant_name = p1; right_variant_name = p2; issue}) )
+            :: cstrs
+          | Ok () ->
             let c1_len = List.length c1 in
             if c1_len > List.length c2 then
               (trace, t1, t2, !univar_pairs, None) :: cstrs
@@ -3767,7 +3783,7 @@ let rec subtype_rec env trace t1 t2 cstrs =
                          else false
                        | _ -> false)
               then cstrs
-              else (trace, t1, t2, !univar_pairs, None) :: cstrs
+              else (trace, t1, t2, !univar_pairs, None) :: cstrs)
         | ( (_, _, {type_kind = Type_record (fields1, repr1)}),
             (_, _, {type_kind = Type_record (fields2, repr2)}) ) ->
           let same_repr =

compiler/ml/ctype.mli

@@ -32,6 +32,11 @@ type subtype_context =
       variant_name: Path.t;
       issues: Variant_coercion.variant_runtime_representation_issue list;
     }
+  | Variant_configurations_mismatch of {
+      left_variant_name: Path.t;
+      right_variant_name: Path.t;
+      issue: Variant_coercion.variant_configuration_issue;
+    }
 
 exception Unify of (type_expr * type_expr) list
 exception Tags of label * label

compiler/ml/printtyp.ml

@@ -1576,6 +1576,43 @@ let print_variant_runtime_representation_issue ppf variant_name
        a runtime representation of @{<info>%s@}."
       (Path.name variant_name)
       (Path.name expected_typename)
+
+let print_variant_configuration_issue ppf
+    (issue : Variant_coercion.variant_configuration_issue) ~left_variant_name
+    ~right_variant_name =
+  match issue with
+  | Unboxed_config_not_matching {left_unboxed; right_unboxed} ->
+    fprintf ppf
+      "@ The variants have different @{<info>@unboxed@} configurations.";
+    let print_unboxed_status ppf unboxed name =
+      fprintf ppf "@ - Variant @{<info>%s@} is @{<error>%s@}unboxed."
+        (Path.name name)
+        (if unboxed then "not " else "")
+    in
+    print_unboxed_status ppf left_unboxed left_variant_name;
+    print_unboxed_status ppf right_unboxed right_variant_name;
+    fprintf ppf
+      "@,\
+       @ Fix this by making sure the variants either both have, or don't have, \
+       the @{<info>@unboxed@} attribute."
+  | Tag_name_not_matching {left_tag; right_tag} ->
+    fprintf ppf "@ The variants have different @{<info>@tag@} configurations.";
+    let print_tag ppf tag variant_name =
+      match tag with
+      | Some tag ->
+        fprintf ppf "@ - @{<info>%s@} has tag @{<info>%s@}."
+          (Path.name variant_name) tag
+      | None ->
+        fprintf ppf "@ - @{<info>%s@} has no explicit tag."
+          (Path.name variant_name)
+    in
+    print_tag ppf left_tag left_variant_name;
+    print_tag ppf right_tag right_variant_name;
+    fprintf ppf
+      "@,\
+       @ Fix this by making sure the variants either have the exact same \
+       @{<info>@tag@} configuration, or no @{<info>@tag@} at all."
+
 let report_subtyping_error ppf env tr1 txt1 tr2 ctx =
   wrap_printing_env env (fun () ->
       reset ();
@@ -1618,7 +1655,11 @@ let report_subtyping_error ppf env tr1 txt1 tr2 ctx =
             (fun issue ->
               fprintf ppf "@ ";
               print_variant_runtime_representation_issue ppf variant_name issue)
-            issues);
+            issues
+        | Variant_configurations_mismatch
+            {left_variant_name; right_variant_name; issue} ->
+          print_variant_configuration_issue ppf issue ~left_variant_name
+            ~right_variant_name);
         fprintf ppf "@]"
       | None -> ())
 

compiler/ml/variant_coercion.ml

@@ -173,6 +173,37 @@ type variant_error =
 
 exception VariantConfigurationError of variant_error
 
+type variant_configuration_issue =
+  | Unboxed_config_not_matching of {left_unboxed: bool; right_unboxed: bool}
+  | Tag_name_not_matching of {left_tag: string option; right_tag: string option}
+
+let variant_configuration_can_be_coerced2 (a1 : Parsetree.attributes)
+    (a2 : Parsetree.attributes) =
+  let unboxed =
+    match
+      ( Ast_untagged_variants.process_untagged a1,
+        Ast_untagged_variants.process_untagged a2 )
+    with
+    | true, true | false, false -> Ok ()
+    | left, right ->
+      Error
+        (Unboxed_config_not_matching
+           {left_unboxed = left; right_unboxed = right})
+  in
+  let tag =
+    match
+      ( Ast_untagged_variants.process_tag_name a1,
+        Ast_untagged_variants.process_tag_name a2 )
+    with
+    | Some tag1, Some tag2 when tag1 = tag2 -> Ok ()
+    | None, None -> Ok ()
+    | tag1, tag2 ->
+      Error (Tag_name_not_matching {left_tag = tag1; right_tag = tag2})
+  in
+  match (unboxed, tag) with
+  | Ok (), Ok () -> Ok ()
+  | Error e, _ | _, Error e -> Error e
+
 let variant_configuration_can_be_coerced (a1 : Parsetree.attributes)
     (a2 : Parsetree.attributes) =
   let unboxed =

tests/build_tests/super_errors/expected/variant_to_variant_coercion_tag.res.expected

@@ -7,4 +7,10 @@
   6 │ let y = (x :> y)
   7 │ 
 
-  Type x is not a subtype of y
+  Type x is not a subtype of y 
+
+  The variants have different @tag configurations.
+  - x has tag kind.
+  - y has no explicit tag.
+  
+  Fix this by making sure the variants either have the exact same @tag configuration, or no @tag at all.

tests/build_tests/super_errors/expected/variant_to_variant_coercion_unboxed.res.expected

@@ -7,4 +7,10 @@
   6 │ let y = (x :> y)
   7 │ 
 
-  Type x is not a subtype of y
+  Type x is not a subtype of y 
+
+  The variants have different @unboxed configurations.
+  - Variant x is not unboxed.
+  - Variant y is unboxed.
+  
+  Fix this by making sure the variants either both have, or don't have, the @unboxed attribute.