record fields mismatch

zth · zth · commit 83bfd767a2f6 · 2025-05-21T17:58:02.000+02:00
diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml
@@ -94,6 +94,11 @@ type subtype_context =
       left_type_kind: type_kind;
       right_type_kind: type_kind;
     }
+  | Record_fields_mismatch of {
+      left_record_name: Path.t;
+      right_record_name: Path.t;
+      issues: Record_coercion.record_field_subtype_violation list;
+    }
 
 exception
   Subtype of
@@ -3762,9 +3767,9 @@ let rec subtype_rec env trace t1 t2 cstrs =
               c2
               |> List.iter (fun (c : Types.constructor_declaration) ->
                      Hashtbl.add constructor_map (Ident.name c.cd_id) c);
-              if
+              let field_subtype_violations =
                 c1
-                |> List.for_all (fun (c : Types.constructor_declaration) ->
+                |> List.filter_map (fun (c : Types.constructor_declaration) ->
                        match
                          ( c,
                            Hashtbl.find_opt constructor_map (Ident.name c.cd_id)
@@ -3783,17 +3788,18 @@ let rec subtype_rec env trace t1 t2 cstrs =
                            Variant_coercion.variant_representation_matches
                              c1_attributes c2_attributes
                          then
-                           (* TODO(subtype-errors) Inline record coercion check, piggy back on record coercion check *)
-                           let violation, tl1, tl2 =
+                           let violations, tl1, tl2 =
                              Record_coercion.check_record_fields fields1 fields2
                            in
-                           if violation then false
-                           else
+                           match violations with
+                           | [] -> (
                              try
                                let lst = subtype_list env trace tl1 tl2 cstrs in
-                               List.length lst = List.length cstrs
-                             with _ -> false
-                         else false
+                               if List.length lst = List.length cstrs then None
+                               else Some [ (* TODO(subtype-errors) *) ]
+                             with _ -> Some [ (* TODO(subtype-errors) *) ])
+                           | violations -> Some violations
+                         else Some [ (* TODO(subtype-errors) *) ]
                        | ( {
                              Types.cd_args = Cstr_tuple tl1;
                              cd_attributes = c1_attributes;
@@ -3809,14 +3815,16 @@ let rec subtype_rec env trace t1 t2 cstrs =
                          then
                            try
                              let lst = subtype_list env trace tl1 tl2 cstrs in
-                             List.length lst = List.length cstrs
-                           with _ -> false
-                         else false
-                       | _ -> false)
-              then cstrs
+                             if List.length lst = List.length cstrs then None
+                             else Some [ (* TODO(subtype-errors) *) ]
+                           with _ -> Some [ (* TODO(subtype-errors) *) ]
+                         else Some [ (* TODO(subtype-errors) *) ]
+                       | _ -> Some [ (* TODO(subtype-errors) *) ])
+              in
+              if field_subtype_violations = [] then cstrs
               else (trace, t1, t2, !univar_pairs, None) :: cstrs)
-        | ( (_, _, {type_kind = Type_record (fields1, repr1)}),
-            (_, _, {type_kind = Type_record (fields2, repr2)}) ) ->
+        | ( (p1, _, {type_kind = Type_record (fields1, repr1)}),
+            (p2, _, {type_kind = Type_record (fields2, repr2)}) ) ->
           (* TODO(subtype-errors) Record representation *)
           let same_repr =
             match (repr1, repr2) with
@@ -3828,10 +3836,22 @@ let rec subtype_rec env trace t1 t2 cstrs =
             | _ -> false
           in
           if same_repr then
-            let violation, tl1, tl2 =
+            let violations, tl1, tl2 =
               Record_coercion.check_record_fields fields1 fields2
             in
-            if violation then (trace, t1, t2, !univar_pairs, None) :: cstrs
+            if violations <> [] then
+              ( trace,
+                t1,
+                t2,
+                !univar_pairs,
+                Some
+                  (Record_fields_mismatch
+                     {
+                       left_record_name = p1;
+                       right_record_name = p2;
+                       issues = violations;
+                     }) )
+              :: cstrs
             else subtype_list env trace tl1 tl2 cstrs
           else (trace, t1, t2, !univar_pairs, None) :: cstrs
         | (p1, _, {type_kind = tk1}), (p2, _, {type_kind = tk2}) ->
@@ -3862,6 +3882,8 @@ let rec subtype_rec env trace t1 t2 cstrs =
       | Tvariant {row_closed = true; row_fields}, Tconstr (_, [], _)
         when extract_concrete_typedecl_opt env t2
              |> Variant_coercion.type_is_variant -> (
+        (* TODO(subtype-errors) Polyvariant to variant *)
+        (* TODO(subtype-errors) Add Variant to polyvariant while we're at it? *)
         match extract_concrete_typedecl env t2 with
         | _, _, {type_kind = Type_variant variant_constructors; type_attributes}
           -> (
diff --git a/compiler/ml/ctype.mli b/compiler/ml/ctype.mli
@@ -43,6 +43,11 @@ type subtype_context =
       left_type_kind: type_kind;
       right_type_kind: type_kind;
     }
+  | Record_fields_mismatch of {
+      left_record_name: Path.t;
+      right_record_name: Path.t;
+      issues: Record_coercion.record_field_subtype_violation list;
+    }
 
 exception Unify of (type_expr * type_expr) list
 exception Tags of label * label
diff --git a/compiler/ml/printtyp.ml b/compiler/ml/printtyp.ml
@@ -1642,6 +1642,51 @@ let print_variant_configuration_issue ppf
       (Path.name right_variant_name)
       (Path.name left_variant_name)
 
+let print_record_field_subtype_violation ppf
+    (issue : Record_coercion.record_field_subtype_violation) ~left_record_name
+    ~right_record_name =
+  match issue with
+  | Optional_mismatch {label; left_optional; right_optional} -> (
+    fprintf ppf "The field @{<info>%s@} " label;
+    match (left_optional, right_optional) with
+    | true, false ->
+      fprintf ppf
+        "is optional in record @{<info>%s@}, but is not optional in record \
+         @{<info>%s@}"
+        (Path.name left_record_name)
+        (Path.name right_record_name)
+    | false, true ->
+      fprintf ppf
+        "is not optional in record @{<info>%s@}, but is optional in record \
+         @{<info>%s@}"
+        (Path.name left_record_name)
+        (Path.name right_record_name)
+    | _ -> failwith "Invalid optional mismatch")
+  | Field_runtime_name_mismatch {label; left_as; right_as} ->
+    fprintf ppf "Field @{<info>%s@} runtime representation" label;
+    (match left_as with
+    | Some as_name ->
+      fprintf ppf
+        " is configured to be @{<info>\"%s\"@} (via the @as attribute)" as_name
+    | None -> fprintf ppf " is @{<info>\"%s\"@}" label);
+    fprintf ppf " in record @{<info>%s@}, but in record @{<info>%s@}"
+      (Path.name right_record_name)
+      (Path.name left_record_name);
+    (match right_as with
+    | Some as_name ->
+      fprintf ppf
+        " it is configured to be @{<info>\"%s\"@} (via the @as attribute)."
+        as_name
+    | None -> fprintf ppf " it is @{<info>\"%s\"@}." label);
+    fprintf ppf " Runtime representations must match."
+  | Field_missing {label} ->
+    fprintf ppf
+      "The field @{<info>%s@} is missing in record @{<info>%s@}, but present \
+       in record @{<info>%s@}"
+      label
+      (Path.name right_record_name)
+      (Path.name left_record_name)
+
 let report_subtyping_error ppf env tr1 txt1 tr2 ctx =
   wrap_printing_env env (fun () ->
       reset ();
@@ -1703,7 +1748,20 @@ let report_subtyping_error ppf env tr1 txt1 tr2 ctx =
           fprintf ppf "@ - @{<info>%s@} is %s" (Path.name left_typename)
             (type_kind_to_string left_type_kind);
           fprintf ppf "@ - @{<info>%s@} is %s" (Path.name right_typename)
-            (type_kind_to_string right_type_kind))
+            (type_kind_to_string right_type_kind)
+        | Record_fields_mismatch {left_record_name; right_record_name; issues}
+          ->
+          fprintf ppf
+            "@ The record @{<info>%s@} cannot be coerced to the record \
+             @{<info>%s@} because:"
+            (Path.name left_record_name)
+            (Path.name right_record_name);
+          List.iter
+            (fun issue ->
+              fprintf ppf "@ - ";
+              print_record_field_subtype_violation ppf issue ~left_record_name
+                ~right_record_name)
+            issues)
       | None -> ())
 
 let report_ambiguous_type_error ppf env (tp0, tp0') tpl txt1 txt2 txt3 =
diff --git a/compiler/ml/record_coercion.ml b/compiler/ml/record_coercion.ml
@@ -1,28 +1,60 @@
+type record_field_subtype_violation =
+  | Optional_mismatch of {
+      label: string;
+      left_optional: bool;
+      right_optional: bool;
+    }
+  | Field_runtime_name_mismatch of {
+      label: string;
+      left_as: string option;
+      right_as: string option;
+    }
+  | Field_missing of {label: string}
+
 let check_record_fields (fields1 : Types.label_declaration list)
     (fields2 : Types.label_declaration list) =
-  let violation = ref false in
+  let violations = ref [] in
+  let add_violation v = violations := v :: !violations in
   let label_decl_sub (acc1, acc2) (ld2 : Types.label_declaration) =
     match
       Ext_list.find_first fields1 (fun ld1 -> ld1.ld_id.name = ld2.ld_id.name)
     with
     | Some ld1 ->
       if ld1.ld_optional <> ld2.ld_optional then
         (* optional field can't be modified *)
-        violation := true;
+        add_violation
+          (Optional_mismatch
+             {
+               label = ld1.ld_id.name;
+               left_optional = ld1.ld_optional;
+               right_optional = ld2.ld_optional;
+             });
       let get_as (({txt}, payload) : Parsetree.attribute) =
         if txt = "as" then Ast_payload.is_single_string payload else None
       in
       let get_as_name (ld : Types.label_declaration) =
         match Ext_list.filter_map ld.ld_attributes get_as with
-        | [] -> ld.ld_id.name
-        | (s, _) :: _ -> s
+        | [] -> None
+        | (s, _) :: _ -> Some s
       in
-      if get_as_name ld1 <> get_as_name ld2 then violation := true;
+      let get_label_runtime_name (ld : Types.label_declaration) =
+        match get_as_name ld with
+        | None -> ld.ld_id.name
+        | Some s -> s
+      in
+      if get_label_runtime_name ld1 <> get_label_runtime_name ld2 then
+        add_violation
+          (Field_runtime_name_mismatch
+             {
+               label = ld1.ld_id.name;
+               left_as = get_as_name ld1;
+               right_as = get_as_name ld2;
+             });
       (ld1.ld_type :: acc1, ld2.ld_type :: acc2)
     | None ->
       (* field must be present *)
-      violation := true;
+      add_violation (Field_missing {label = ld2.ld_id.name});
       (acc1, acc2)
   in
   let tl1, tl2 = List.fold_left label_decl_sub ([], []) fields2 in
-  (!violation, tl1, tl2)
+  (!violations, tl1, tl2)
diff --git a/tests/build_tests/super_errors/expected/record_coercion_as_payload_mismatch_both.res.expected b/tests/build_tests/super_errors/expected/record_coercion_as_payload_mismatch_both.res.expected
@@ -0,0 +1,13 @@
+
+  [1;31mWe've found a bug for you![0m
+  [36m/.../fixtures/record_coercion_as_payload_mismatch_both.res[0m:[2m15:10-15[0m
+
+  13 [2m│[0m }
+  14 [2m│[0m 
+  [1;31m15[0m [2m│[0m let y = ([1;31mx :> y[0m)
+  16 [2m│[0m 
+
+  Type x is not a subtype of y 
+
+  The record [1;33mx[0m cannot be coerced to the record [1;33my[0m because:
+  - Field [1;33mx[0m runtime representation is configured to be [1;33m"z"[0m (via the @as attribute) in record [1;33my[0m, but in record [1;33mx[0m it is configured to be [1;33m"w"[0m (via the @as attribute). Runtime representations must match.
diff --git a/tests/build_tests/super_errors/expected/record_coercion_as_payload_mismatch_left.res.expected b/tests/build_tests/super_errors/expected/record_coercion_as_payload_mismatch_left.res.expected
@@ -0,0 +1,13 @@
+
+  [1;31mWe've found a bug for you![0m
+  [36m/.../fixtures/record_coercion_as_payload_mismatch_left.res[0m:[2m15:10-15[0m
+
+  13 [2m│[0m }
+  14 [2m│[0m 
+  [1;31m15[0m [2m│[0m let y = ([1;31mx :> y[0m)
+  16 [2m│[0m 
+
+  Type x is not a subtype of y 
+
+  The record [1;33mx[0m cannot be coerced to the record [1;33my[0m because:
+  - Field [1;33mx[0m runtime representation is configured to be [1;33m"z"[0m (via the @as attribute) in record [1;33my[0m, but in record [1;33mx[0m it is [1;33m"x"[0m. Runtime representations must match.
diff --git a/tests/build_tests/super_errors/expected/record_coercion_as_payload_mismatch_right.res.expected b/tests/build_tests/super_errors/expected/record_coercion_as_payload_mismatch_right.res.expected
@@ -0,0 +1,13 @@
+
+  [1;31mWe've found a bug for you![0m
+  [36m/.../fixtures/record_coercion_as_payload_mismatch_right.res[0m:[2m15:10-15[0m
+
+  13 [2m│[0m }
+  14 [2m│[0m 
+  [1;31m15[0m [2m│[0m let y = ([1;31mx :> y[0m)
+  16 [2m│[0m 
+
+  Type x is not a subtype of y 
+
+  The record [1;33mx[0m cannot be coerced to the record [1;33my[0m because:
+  - Field [1;33mx[0m runtime representation is [1;33m"x"[0m in record [1;33my[0m, but in record [1;33mx[0m it is configured to be [1;33m"z"[0m (via the @as attribute). Runtime representations must match.
diff --git a/tests/build_tests/super_errors/expected/record_coercion_missing_field.res.expected b/tests/build_tests/super_errors/expected/record_coercion_missing_field.res.expected
@@ -0,0 +1,13 @@
+
+  [1;31mWe've found a bug for you![0m
+  [36m/.../fixtures/record_coercion_missing_field.res[0m:[2m16:10-15[0m
+
+  14 [2m│[0m }
+  15 [2m│[0m 
+  [1;31m16[0m [2m│[0m let y = ([1;31mx :> y[0m)
+  17 [2m│[0m 
+
+  Type x is not a subtype of y 
+
+  The record [1;33mx[0m cannot be coerced to the record [1;33my[0m because:
+  - The field [1;33mz[0m is missing in record [1;33my[0m, but present in record [1;33mx[0m
diff --git a/tests/build_tests/super_errors/expected/record_coercion_optional_mismatch.res.expected b/tests/build_tests/super_errors/expected/record_coercion_optional_mismatch.res.expected
@@ -0,0 +1,13 @@
+
+  [1;31mWe've found a bug for you![0m
+  [36m/.../fixtures/record_coercion_optional_mismatch.res[0m:[2m14:10-15[0m
+
+  12 [2m│[0m }
+  13 [2m│[0m 
+  [1;31m14[0m [2m│[0m let y = ([1;31mx :> y[0m)
+  15 [2m│[0m 
+
+  Type x is not a subtype of y 
+
+  The record [1;33mx[0m cannot be coerced to the record [1;33my[0m because:
+  - The field [1;33mx[0m is optional in record [1;33mx[0m, but is not optional in record [1;33my[0m
diff --git a/tests/build_tests/super_errors/fixtures/record_coercion_as_payload_mismatch_both.res b/tests/build_tests/super_errors/fixtures/record_coercion_as_payload_mismatch_both.res
@@ -0,0 +1,15 @@
+type x = {
+  @as("z") x: int,
+  y: int,
+}
+type y = {
+  @as("w") x: int,
+  y: int,
+}
+
+let x: x = {
+  x: 1,
+  y: 1,
+}
+
+let y = (x :> y)
diff --git a/tests/build_tests/super_errors/fixtures/record_coercion_as_payload_mismatch_left.res b/tests/build_tests/super_errors/fixtures/record_coercion_as_payload_mismatch_left.res
@@ -0,0 +1,15 @@
+type x = {
+  @as("z") x: int,
+  y: int,
+}
+type y = {
+  x: int,
+  y: int,
+}
+
+let x: x = {
+  x: 1,
+  y: 1,
+}
+
+let y = (x :> y)
diff --git a/tests/build_tests/super_errors/fixtures/record_coercion_as_payload_mismatch_right.res b/tests/build_tests/super_errors/fixtures/record_coercion_as_payload_mismatch_right.res
@@ -0,0 +1,15 @@
+type x = {
+  x: int,
+  y: int,
+}
+type y = {
+  @as("z")x: int,
+  y: int,
+}
+
+let x: x = {
+  x: 1,
+  y: 1,
+}
+
+let y = (x :> y)
diff --git a/tests/build_tests/super_errors/fixtures/record_coercion_missing_field.res b/tests/build_tests/super_errors/fixtures/record_coercion_missing_field.res
diff --git a/tests/build_tests/super_errors/fixtures/record_coercion_optional_mismatch.res b/tests/build_tests/super_errors/fixtures/record_coercion_optional_mismatch.res

-Original file line number
+Diff line change
@@ @@ -0,0 +1,13 @@ @@
++
 +  [1;31mWe've found a bug for you![0m
 +  [36m/.../fixtures/record_coercion_as_payload_mismatch_both.res[0m:[2m15:10-15[0m
++
 +  13 [2m│[0m }
 +  14 [2m│[0m
 +  [1;31m15[0m [2m│[0m let y = ([1;31mx :> y[0m)
 +  16 [2m│[0m
++
 +  Type x is not a subtype of y
++
 +  The record [1;33mx[0m cannot be coerced to the record [1;33my[0m because:
 +  - Field [1;33mx[0m runtime representation is configured to be [1;33m"z"[0m (via the @as attribute) in record [1;33my[0m, but in record [1;33mx[0m it is configured to be [1;33m"w"[0m (via the @as attribute). Runtime representations must match.