diffing: adjust weight for fields and constructors

testsuite/tests/typing-misc/records.ml

@@ -241,8 +241,12 @@ Line 1, characters 0-31:
 1 | type wrong_type = d = {x:float}
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: This variant or record definition does not match that of type d
-       1. An extra field, x, is provided in the original definition.
-       2. Fields have different names, y and x.
+       1. Fields do not match:
+         x : int;
+       is not compatible with:
+         x : float;
+       The types are not equal.
+       2. An extra field, y, is provided in the original definition.
 |}]
 
 type unboxed = d = {x:float} [@@unboxed]

testsuite/tests/typing-misc/variant.ml

@@ -96,8 +96,12 @@ Line 1, characters 0-32:
 1 | type wrong_type = d = X of float
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: This variant or record definition does not match that of type d
-       1. An extra constructor, X, is provided in the original definition.
-       2. Constructors have different names, Y and X.
+       1. Constructors do not match:
+         X of int
+       is not compatible with:
+         X of float
+       The types are not equal.
+       2. An extra constructor, Y, is provided in the original definition.
 |}]
 
 type unboxed = d = X of float [@@unboxed]

typing/includecore.ml

@@ -141,7 +141,7 @@ type label_mismatch =
 type field_mismatch =
   | Kind_mismatch of
       Types.label_declaration * Types.label_declaration * label_mismatch
-  | Name_mismatch of Ident.t * Ident.t
+  | Name_mismatch of { types_match:bool; left:Ident.t; right:Ident.t }
 
 type record_change =
   (Types.label_declaration, Types.label_declaration,
@@ -162,7 +162,7 @@ type variant_mismatch =
   | Constructor_mismatch of Types.constructor_declaration
                             * Types.constructor_declaration
                             * constructor_mismatch
-  | Constructor_names of Ident.t * Ident.t
+  | Constructor_names of { types_match:bool; left:Ident.t; right:Ident.t }
 
 type extension_constructor_mismatch =
   | Constructor_privacy
@@ -215,9 +215,9 @@ let pp_record_diff first second prefix decl ppf (_, (x: record_change) as px) =
         Printtyp.label lbl1
         Printtyp.label lbl2
         (report_label_mismatch first second) err
-    | Diffing.Change (_,_, Name_mismatch (name1, name2)) ->
+    | Diffing.Change (_,_, Name_mismatch {left; right; _ }) ->
         Format.fprintf ppf "%aFields have different names, %s and %s."
-          prefix px (Ident.name name1) (Ident.name name2)
+          prefix px (Ident.name left) (Ident.name right)
 
 
 let report_patch pr_diff first second decl ppf patch =
@@ -279,10 +279,10 @@ let pp_variant_diff first second prefix decl ppf (_, (x:variant_change) as px) =
         Printtyp.constructor c1
         Printtyp.constructor c2
         (report_constructor_mismatch first second decl) err
-  | Diffing.Change (_,_, Constructor_names (name1, name2)) ->
+  | Diffing.Change (_,_, Constructor_names {left; right; _ }) ->
       Format.fprintf ppf
         "%aConstructors have different names, %s and %s."
-        prefix px (Ident.name name1) (Ident.name name2)
+        prefix px (Ident.name left) (Ident.name right)
 
 let report_extension_constructor_mismatch first second decl ppf err =
   let pr fmt = Format.fprintf ppf fmt in
@@ -369,17 +369,31 @@ module Record_diffing = struct
       (lbl1:Types.label_declaration)
       (lbl2:Types.label_declaration) =
     if Ident.name lbl1.ld_id <> Ident.name lbl2.ld_id then
-      Error (Name_mismatch (lbl1.ld_id, lbl2.ld_id))
+      let types_match =
+        match compare_labels env params1 params2 lbl1 lbl2 with
+        | Some _ -> false
+        | None -> true
+      in
+      Error (Name_mismatch {types_match; left=lbl1.ld_id; right=lbl2.ld_id})
     else
       match compare_labels env params1 params2 lbl1 lbl2 with
       | Some r ->
           Error (Kind_mismatch (lbl1, lbl2, r))
       | None -> Ok ()
 
+  let weight = function
+    | Diffing.Insert _ -> 10
+    | Diffing.Delete _ -> 10
+    | Diffing.Keep _ -> 0
+    | Diffing.Change (_,_,Name_mismatch t ) ->
+        if t.types_match then 10 else 15
+    | Diffing.Change _ -> 10
+
+
   let diffing loc env params1 params2 cstrs_1 cstrs_2 =
     let test = test loc env params1 params2 in
     Diffing.diff
-      ~weight:Diffing.default_weight
+      ~weight
       ~test
       ~update ()
       (Array.of_list cstrs_1)
@@ -457,11 +471,26 @@ module Variant_diffing = struct
 
   let update _ () = ()
 
+  let weight = function
+    | Diffing.Insert _ -> 10
+    | Diffing.Delete _ -> 10
+    | Diffing.Keep _ -> 0
+    | Diffing.Change (_,_,Constructor_names t) ->
+        if t.types_match then 10 else 15
+    | Diffing.Change _ -> 10
+
+
   let test loc env params1 params2 ()
       (cd1:Types.constructor_declaration)
       (cd2:Types.constructor_declaration): (_,variant_mismatch) result =
     if Ident.name cd1.cd_id <> Ident.name cd2.cd_id then
-      Error (Constructor_names (cd1.cd_id, cd2.cd_id))
+      let types_match =
+        match compare_constructors ~loc env params1 params2
+                cd1.cd_res cd2.cd_res cd1.cd_args cd2.cd_args with
+        | Some _ -> false
+        | None -> true
+      in
+      Error (Constructor_names { types_match; left=cd1.cd_id; right=cd2.cd_id})
     else
       match compare_constructors ~loc env params1 params2
               cd1.cd_res cd2.cd_res cd1.cd_args cd2.cd_args with
@@ -472,7 +501,7 @@ module Variant_diffing = struct
   let diffing loc env params1 params2 cstrs_1 cstrs_2 =
     let test = test loc env params1 params2 in
     Diffing.diff
-      ~weight:Diffing.default_weight
+      ~weight
       ~test
       ~update ()
       (Array.of_list cstrs_1)

typing/includecore.mli

@@ -29,7 +29,8 @@ type label_mismatch =
 type field_mismatch =
   | Kind_mismatch of
       Types.label_declaration * Types.label_declaration * label_mismatch
-  | Name_mismatch of Ident.t * Ident.t
+  | Name_mismatch of { types_match:bool; left:Ident.t; right:Ident.t }
+
 
 type record_change =
   (Types.label_declaration, Types.label_declaration,
@@ -50,7 +51,7 @@ type variant_mismatch =
   | Constructor_mismatch of Types.constructor_declaration
                             * Types.constructor_declaration
                             * constructor_mismatch
-  | Constructor_names of Ident.t * Ident.t
+  | Constructor_names of { types_match:bool; left:Ident.t; right:Ident.t }
 
 type extension_constructor_mismatch =
   | Constructor_privacy