different constructor counts

Author: zth

compiler/ml/ctype.ml

@@ -3726,7 +3726,31 @@ let rec subtype_rec env trace t1 t2 cstrs =
           | Ok () ->
             let c1_len = List.length c1 in
             if c1_len > List.length c2 then
-              (trace, t1, t2, !univar_pairs, None) :: cstrs
+              let c1_constructor_names =
+                c1 |> List.map (fun c -> c.cd_id.name)
+              in
+              let c2_constructor_names =
+                c2 |> List.map (fun c -> c.cd_id.name)
+              in
+              let incompatible_constructor_names =
+                c1_constructor_names
+                |> List.filter (fun name ->
+                       not (List.mem name c2_constructor_names))
+              in
+              ( trace,
+                t1,
+                t2,
+                !univar_pairs,
+                Some
+                  (Variant_configurations_mismatch
+                     {
+                       left_variant_name = p1;
+                       right_variant_name = p2;
+                       issue =
+                         Incompatible_constructor_count
+                           {constructor_names = incompatible_constructor_names};
+                     }) )
+              :: cstrs
             else
               let constructor_map = Hashtbl.create c1_len in
               c2

compiler/ml/printtyp.ml

@@ -1612,6 +1612,31 @@ let print_variant_configuration_issue ppf
       "@,\
        @ Fix this by making sure the variants either have the exact same \
        @{<info>@tag@} configuration, or no @{<info>@tag@} at all."
+  | Incompatible_constructor_count {constructor_names} ->
+    let total_constructor_count = List.length constructor_names in
+    let constructor_names_to_print = constructor_names |> List.take 3 in
+    let not_printed_constructor_count =
+      total_constructor_count - List.length constructor_names_to_print
+    in
+    fprintf ppf
+      "@ @{<info>%s@} has %i constructor%s that @{<info>%s@} does not have: "
+      (Path.name left_variant_name)
+      total_constructor_count
+      (if total_constructor_count = 1 then "" else "s")
+      (Path.name right_variant_name);
+
+    constructor_names_to_print
+    |> List.iteri (fun index name ->
+           if index = 0 then () else fprintf ppf ", ";
+           fprintf ppf "@{<info>%s@}" name);
+    if not_printed_constructor_count > 0 then
+      fprintf ppf " (+%i more)" not_printed_constructor_count;
+
+    fprintf ppf
+      "@ Therefore, it is not possible for @{<info>%s@} to represent \
+       @{<info>%s@}."
+      (Path.name right_variant_name)
+      (Path.name left_variant_name)
 
 let report_subtyping_error ppf env tr1 txt1 tr2 ctx =
   wrap_printing_env env (fun () ->

compiler/ml/variant_coercion.ml

@@ -176,6 +176,7 @@ 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}
+  | Incompatible_constructor_count of {constructor_names: string list}
 
 let variant_configuration_can_be_coerced2 (a1 : Parsetree.attributes)
     (a2 : Parsetree.attributes) =

tests/build_tests/super_errors/expected/variant_to_variant_different_constructor_counts.res.expected

@@ -0,0 +1,13 @@
+
+  We've found a bug for you!
+  /.../fixtures/variant_to_variant_different_constructor_counts.res:6:10-15
+
+  4 │ let x: x = One(true)
+  5 │ 
+  6 │ let y = (x :> y)
+  7 │ 
+
+  Type x is not a subtype of y 
+
+  x has 4 constructors that y does not have: Two, Three, Four (+1 more)
+  Therefore, it is not possible for y to represent x.

tests/build_tests/super_errors/fixtures/variant_to_variant_different_constructor_counts.res

@@ -0,0 +1,6 @@
+type x = One(bool) | Two | Three | Four | Five
+type y = One(bool)
+
+let x: x = One(true)
+
+let y = (x :> y)