swaps and moves

14 files changed, 647 insertions, 112 deletions

diff --git a/.depend b/.depend
index 724b59ec60..693a10560a 100644
--- a/.depend
+++ b/.depend
@@ -66,6 +66,16 @@ utils/diffing.cmx : \
     utils/diffing.cmi
 utils/diffing.cmi : \
     utils/misc.cmi
+utils/diffing_with_keys.cmo : \
+    utils/misc.cmi \
+    utils/diffing.cmi \
+    utils/diffing_with_keys.cmi
+utils/diffing_with_keys.cmx : \
+    utils/misc.cmx \
+    utils/diffing.cmx \
+    utils/diffing_with_keys.cmi
+utils/diffing_with_keys.cmi : \
+    utils/diffing.cmi
 utils/domainstate.cmo : \
     utils/domainstate.cmi
 utils/domainstate.cmx : \
@@ -697,6 +707,8 @@ typing/includecore.cmo : \
     typing/ident.cmi \
     typing/errortrace.cmi \
     typing/env.cmi \
+    utils/diffing_with_keys.cmi \
+    utils/diffing.cmi \
     typing/ctype.cmi \
     parsing/builtin_attributes.cmi \
     typing/btype.cmi \
@@ -713,6 +725,8 @@ typing/includecore.cmx : \
     typing/ident.cmx \
     typing/errortrace.cmx \
     typing/env.cmx \
+    utils/diffing_with_keys.cmx \
+    utils/diffing.cmx \
     typing/ctype.cmx \
     parsing/builtin_attributes.cmx \
     typing/btype.cmx \
@@ -726,7 +740,8 @@ typing/includecore.cmi : \
     parsing/location.cmi \
     typing/ident.cmi \
     typing/errortrace.cmi \
-    typing/env.cmi
+    typing/env.cmi \
+    utils/diffing_with_keys.cmi
 typing/includemod.cmo : \
     typing/types.cmi \
     typing/typedtree.cmi \
diff --git a/compilerlibs/Makefile.compilerlibs b/compilerlibs/Makefile.compilerlibs
index 65129efdb4..d08b08d146 100644
--- a/compilerlibs/Makefile.compilerlibs
+++ b/compilerlibs/Makefile.compilerlibs
@@ -45,7 +45,8 @@ UTILS = \
   utils/domainstate.cmo \
   utils/binutils.cmo \
   utils/lazy_backtrack.cmo \
-  utils/diffing.cmo
+  utils/diffing.cmo \
+  utils/diffing_with_keys.cmo
 UTILS_CMI =
 
 PARSING = \
diff --git a/dune b/dune
index b4cb01421f..771582247f 100644
--- a/dune
+++ b/dune
@@ -45,7 +45,7 @@
    config build_path_prefix_map misc identifiable numbers arg_helper clflags
    profile terminfo ccomp warnings consistbl strongly_connected_components
    targetint load_path int_replace_polymorphic_compare binutils local_store
-   lazy_backtrack diffing
+   lazy_backtrack diffing diffing_with_keys
 
    ;; PARSING
    location longident docstrings syntaxerr ast_helper camlinternalMenhirLib
diff --git a/testsuite/tests/typing-misc/records.ml b/testsuite/tests/typing-misc/records.ml
index b14ae0c214..5f0a486a4d 100644
--- a/testsuite/tests/typing-misc/records.ml
+++ b/testsuite/tests/typing-misc/records.ml
@@ -267,6 +267,5 @@ Line 1, characters 0-30:
 1 | type perm = d = {y:int; x:int}
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: This variant or record definition does not match that of type d
-       1. Fields have different names, x and y.
-       2. Fields have different names, y and x.
+       Fields x and y have been swapped.
 |}]
diff --git a/testsuite/tests/typing-misc/variant.ml b/testsuite/tests/typing-misc/variant.ml
index 7196640bb1..b48142cd6d 100644
--- a/testsuite/tests/typing-misc/variant.ml
+++ b/testsuite/tests/typing-misc/variant.ml
@@ -124,8 +124,7 @@ Line 1, characters 0-35:
 1 | type perm = d = Y of int | X of int
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: This variant or record definition does not match that of type d
-       1. Constructors have different names, X and Y.
-       2. Constructors have different names, Y and X.
+       Constructors X and Y have been swapped.
 |}]
 
 module M : sig
diff --git a/testsuite/tests/typing-modules/records_errors_test.ml b/testsuite/tests/typing-modules/records_errors_test.ml
index d926812b5b..ef327db4eb 100644
--- a/testsuite/tests/typing-modules/records_errors_test.ml
+++ b/testsuite/tests/typing-modules/records_errors_test.ml
@@ -287,6 +287,218 @@ Error: Signature mismatch:
            g : unit;
          }
        3. An extra field, beta, is provided in the first declaration.
-       6. A field, e, is missing in the first declaration.
-       9. An extra field, phi, is provided in the first declaration.
+       5. A field, e, is missing in the first declaration.
+       8. An extra field, phi, is provided in the first declaration.
+|}]
+
+
+(** Multiple errors *)
+
+module M : sig
+  type t = { a:int; e:int; c:int; d:int; b:int }
+end = struct
+  type t = { alpha:int; b:int; c:int; d:int; e:int }
+end
+[%%expect {|
+Lines 5-7, characters 6-3:
+5 | ......struct
+6 |   type t = { alpha:int; b:int; c:int; d:int; e:int }
+7 | end
+Error: Signature mismatch:
+       Modules do not match:
+         sig
+           type t = { alpha : int; b : int; c : int; d : int; e : int; }
+         end
+       is not included in
+         sig type t = { a : int; e : int; c : int; d : int; b : int; } end
+       Type declarations do not match:
+         type t = { alpha : int; b : int; c : int; d : int; e : int; }
+       is not included in
+         type t = { a : int; e : int; c : int; d : int; b : int; }
+       1. Fields have different names, alpha and a.
+       2<->5. Fields b and e have been swapped.
+|}]
+
+
+module M: sig
+  type t = { a:int; b:int; c:int; d:int; e:int; f:float }
+end =
+struct
+  type t = { b:int; c:int; d:int; e:int; a:int; f:int }
+end
+[%%expect {|
+Lines 4-6, characters 0-3:
+4 | struct
+5 |   type t = { b:int; c:int; d:int; e:int; a:int; f:int }
+6 | end
+Error: Signature mismatch:
+       Modules do not match:
+         sig
+           type t = { b : int; c : int; d : int; e : int; a : int; f : int; }
+         end
+       is not included in
+         sig
+           type t = {
+             a : int;
+             b : int;
+             c : int;
+             d : int;
+             e : int;
+             f : float;
+           }
+         end
+       Type declarations do not match:
+         type t = { b : int; c : int; d : int; e : int; a : int; f : int; }
+       is not included in
+         type t = { a : int; b : int; c : int; d : int; e : int; f : float; }
+       1->5. Field a has been moved from position 1 to 5.
+       6. Fields do not match:
+         f : int;
+       is not the same as:
+         f : float;
+       The type int is not equal to the type float
+|}]
+
+(** Existential types introduce equations that must be taken in account
+    when diffing
+*)
+
+
+module Eq : sig
+  type t = A: { a:'a; b:'b; x:'a } -> t
+end = struct
+  type t = A: { a:'a; b:'b; x:'x } -> t
+end
+[%%expect {|
+Lines 8-10, characters 6-3:
+ 8 | ......struct
+ 9 |   type t = A: { a:'a; b:'b; x:'x } -> t
+10 | end
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = A : { a : 'a; b : 'b; x : 'x; } -> t end
+       is not included in
+         sig type t = A : { a : 'a; b : 'b; x : 'a; } -> t end
+       Type declarations do not match:
+         type t = A : { a : 'a; b : 'b; x : 'x; } -> t
+       is not included in
+         type t = A : { a : 'a; b : 'b; x : 'a; } -> t
+       Constructors do not match:
+         A : { a : 'a; b : 'b; x : 'x; } -> t
+       is not the same as:
+         A : { a : 'a; b : 'b; x : 'a; } -> t
+       Fields do not match:
+         x : 'x;
+       is not the same as:
+         x : 'a;
+       The type 'x is not equal to the type 'a
+|}]
+
+
+module Not_a_swap: sig
+  type t = A: { x:'a; a:'a; b:'b; y:'b} -> t
+end = struct
+  type t = A: { y:'a; a:'a; b:'b; x:'b} -> t
+end
+[%%expect {|
+Lines 3-5, characters 6-3:
+3 | ......struct
+4 |   type t = A: { y:'a; a:'a; b:'b; x:'b} -> t
+5 | end
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = A : { y : 'a; a : 'a; b : 'b; x : 'b; } -> t end
+       is not included in
+         sig type t = A : { x : 'a; a : 'a; b : 'b; y : 'b; } -> t end
+       Type declarations do not match:
+         type t = A : { y : 'a; a : 'a; b : 'b; x : 'b; } -> t
+       is not included in
+         type t = A : { x : 'a; a : 'a; b : 'b; y : 'b; } -> t
+       Constructors do not match:
+         A : { y : 'a; a : 'a; b : 'b; x : 'b; } -> t
+       is not the same as:
+         A : { x : 'a; a : 'a; b : 'b; y : 'b; } -> t
+       1. Fields have different names, y and x.
+       4. Fields have different names, x and y.
+|}]
+
+module Swap: sig
+  type t = A: { x:'a; a:'a; b:'b; y:'b} -> t
+end = struct
+  type t = A: { y:'b; a:'a; b:'b; x:'a} -> t
+end
+[%%expect {|
+Lines 3-5, characters 6-3:
+3 | ......struct
+4 |   type t = A: { y:'b; a:'a; b:'b; x:'a} -> t
+5 | end
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = A : { y : 'b; a : 'a; b : 'b; x : 'a; } -> t end
+       is not included in
+         sig type t = A : { x : 'a; a : 'a; b : 'b; y : 'b; } -> t end
+       Type declarations do not match:
+         type t = A : { y : 'b; a : 'a; b : 'b; x : 'a; } -> t
+       is not included in
+         type t = A : { x : 'a; a : 'a; b : 'b; y : 'b; } -> t
+       Constructors do not match:
+         A : { y : 'b; a : 'a; b : 'b; x : 'a; } -> t
+       is not the same as:
+         A : { x : 'a; a : 'a; b : 'b; y : 'b; } -> t
+       Fields x and y have been swapped.
+|}]
+
+
+module Not_a_move: sig
+  type t = A: { a:'a; b:'b; x:'b} -> t
+end = struct
+  type t = A: { x:'a; a:'a; b:'b} -> t
+end
+[%%expect {|
+Lines 3-5, characters 6-3:
+3 | ......struct
+4 |   type t = A: { x:'a; a:'a; b:'b} -> t
+5 | end
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = A : { x : 'a; a : 'a; b : 'b; } -> t end
+       is not included in
+         sig type t = A : { a : 'a; b : 'b; x : 'b; } -> t end
+       Type declarations do not match:
+         type t = A : { x : 'a; a : 'a; b : 'b; } -> t
+       is not included in
+         type t = A : { a : 'a; b : 'b; x : 'b; } -> t
+       Constructors do not match:
+         A : { x : 'a; a : 'a; b : 'b; } -> t
+       is not the same as:
+         A : { a : 'a; b : 'b; x : 'b; } -> t
+       1. An extra field, x, is provided in the first declaration.
+       3. A field, x, is missing in the first declaration.
+|}]
+
+
+module Move: sig
+  type t = A: { a:'a; b:'b; x:'b} -> t
+end = struct
+  type t = A: { x:'b; a:'a; b:'b} -> t
+end
+[%%expect {|
+Lines 3-5, characters 6-3:
+3 | ......struct
+4 |   type t = A: { x:'b; a:'a; b:'b} -> t
+5 | end
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = A : { x : 'b; a : 'a; b : 'b; } -> t end
+       is not included in
+         sig type t = A : { a : 'a; b : 'b; x : 'b; } -> t end
+       Type declarations do not match:
+         type t = A : { x : 'b; a : 'a; b : 'b; } -> t
+       is not included in
+         type t = A : { a : 'a; b : 'b; x : 'b; } -> t
+       Constructors do not match:
+         A : { x : 'b; a : 'a; b : 'b; } -> t
+       is not the same as:
+         A : { a : 'a; b : 'b; x : 'b; } -> t
+       Field x has been moved from position 3 to 1.
 |}]
diff --git a/testsuite/tests/typing-modules/variants_errors_test.ml b/testsuite/tests/typing-modules/variants_errors_test.ml
index 1e74e3c85e..253bc080e2 100644
--- a/testsuite/tests/typing-modules/variants_errors_test.ml
+++ b/testsuite/tests/typing-modules/variants_errors_test.ml
@@ -320,6 +320,93 @@ Error: Signature mismatch:
        is not included in
          type t = A | B | C | D | E | F | G
        3. An extra constructor, Beta, is provided in the first declaration.
-       6. A constructor, E, is missing in the first declaration.
-       9. An extra constructor, Phi, is provided in the first declaration.
+       5. A constructor, E, is missing in the first declaration.
+       8. An extra constructor, Phi, is provided in the first declaration.
+|}]
+
+
+(** Swaps and moves *)
+
+module Swap : sig
+  type t =
+    | A
+    | E
+    | C
+    | D
+    | B
+end = struct
+  type t =
+    | Alpha
+    | B
+    | C
+    | D
+    | E
+end
+[%%expect {|
+Lines 10-17, characters 6-3:
+10 | ......struct
+11 |   type t =
+12 |     | Alpha
+13 |     | B
+14 |     | C
+15 |     | D
+16 |     | E
+17 | end
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = Alpha | B | C | D | E end
+       is not included in
+         sig type t = A | E | C | D | B end
+       Type declarations do not match:
+         type t = Alpha | B | C | D | E
+       is not included in
+         type t = A | E | C | D | B
+       1. Constructors have different names, Alpha and A.
+       2<->5. Constructors B and E have been swapped.
+|}]
+
+
+module Move: sig
+  type t =
+    | A of int
+    | B
+    | C
+    | D
+    | E
+    | F
+end = struct
+  type t =
+    | A of float
+    | B
+    | D
+    | E
+    | F
+    | C
+end
+[%%expect {|
+Lines 9-17, characters 6-3:
+ 9 | ......struct
+10 |   type t =
+11 |     | A of float
+12 |     | B
+13 |     | D
+14 |     | E
+15 |     | F
+16 |     | C
+17 | end
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = A of float | B | D | E | F | C end
+       is not included in
+         sig type t = A of int | B | C | D | E | F end
+       Type declarations do not match:
+         type t = A of float | B | D | E | F | C
+       is not included in
+         type t = A of int | B | C | D | E | F
+       1. Constructors do not match:
+         A of float
+       is not the same as:
+         A of int
+       The type float is not equal to the type int
+       3->6. Constructor C has been moved from position 3 to 6.
 |}]
diff --git a/typing/includecore.ml b/typing/includecore.ml
index e200401c5c..c474f61c27 100644
--- a/typing/includecore.ml
+++ b/typing/includecore.ml
@@ -137,14 +137,8 @@ type label_mismatch =
   | Type of Errortrace.equality_error
   | Mutability of position
 
-type field_mismatch =
-  | Kind_mismatch of
-      Types.label_declaration * Types.label_declaration * label_mismatch
-  | Name_mismatch of { types_match:bool; left:Ident.t; right:Ident.t }
-
 type record_change =
-  (Types.label_declaration, Types.label_declaration,
-   type_expr list * type_expr list,field_mismatch) Diffing.change
+  (Types.label_declaration, label_mismatch) Diffing_with_keys.change
 
 type record_mismatch =
   | Label_mismatch of record_change list
@@ -157,12 +151,6 @@ type constructor_mismatch =
   | Kind of position
   | Explicit_return_type of position
 
-type variant_mismatch =
-  | Constructor_mismatch of Types.constructor_declaration
-                            * Types.constructor_declaration
-                            * constructor_mismatch
-  | Constructor_names of { types_match:bool; left:Ident.t; right:Ident.t }
-
 type extension_constructor_mismatch =
   | Constructor_privacy
   | Constructor_mismatch of Ident.t
@@ -182,8 +170,8 @@ type private_object_mismatch =
   | Types of Errortrace.equality_error
 
 type variant_change =
-  (Types.constructor_declaration, Types.constructor_declaration,
-   label, variant_mismatch) Diffing.change
+  (Types.constructor_declaration, constructor_mismatch)
+    Diffing_with_keys.change
 
 type type_mismatch =
   | Arity
@@ -258,44 +246,45 @@ let report_label_mismatch first second env ppf err =
         (String.capitalize_ascii (choose ord first second))
         (choose_other ord first second)
 
-let pp_record_diff first second prefix decl env ppf
-    (_, (x: record_change) as px) =
+let pp_record_diff first second prefix decl env ppf (x : record_change) =
   match x with
-  | Diffing.Keep _ -> ()
-  | Diffing.Delete cd ->
+  | Delete cd ->
       Format.fprintf ppf "%aAn extra field, %s, is provided in %s %s."
-        prefix px (Ident.name cd.ld_id) first decl
-  | Diffing.Insert cd ->
+        prefix x (Ident.name cd.delete.ld_id) first decl
+  | Insert cd ->
       Format.fprintf  ppf "%aA field, %s, is missing in %s %s."
-        prefix px (Ident.name cd.ld_id) first decl
-  | Diffing.Change (_,_, Kind_mismatch (lbl1, lbl2, err)) ->
+        prefix x (Ident.name cd.insert.ld_id) first decl
+  | Change Type {got=lbl1; expected=lbl2; reason} ->
       Format.fprintf ppf
         "@[<hv>%aFields do not match:@;<1 2>\
          %a@ is not the same as:\
          @;<1 2>%a@ %a@]"
-        prefix px
+        prefix x
         Printtyp.label lbl1
         Printtyp.label lbl2
-        (report_label_mismatch first second env) err
-    | Diffing.Change (_,_, Name_mismatch {left; right; _ }) ->
-        Format.fprintf ppf "%aFields have different names, %s and %s."
-          prefix px (Ident.name left) (Ident.name right)
+        (report_label_mismatch first second env) reason
+  | Change Name n ->
+      Format.fprintf ppf "%aFields have different names, %s and %s."
+        prefix x n.got n.expected
+  | Swap sw ->
+      Format.fprintf ppf "%aFields %s and %s have been swapped."
+        prefix x sw.first sw.last
+  | Move {name; got; expected } ->
+      Format.fprintf ppf
+        "@[<2>%aField %s has been moved@ from@ position %d@ to %d.@]"
+        prefix x name expected got
 
 let report_patch pr_diff first second decl env ppf patch =
   let nl ppf () = Format.fprintf ppf "@," in
-  let filtered_diff =
-    List.filter (function (_,Diffing.Keep _) -> false | _ -> true ) @@
-    List.mapi (fun n x -> 1+n,x) patch
-  in
   let no_prefix _ppf _ = () in
-  match filtered_diff with
+  match patch with
   | [ elt ] ->
       Format.fprintf ppf "@[<hv>%a@]"
         (pr_diff first second no_prefix decl env) elt
   | _ ->
-      let pp_diff = pr_diff first second Diffing.prefix decl env in
+      let pp_diff = pr_diff first second Diffing_with_keys.prefix decl env in
       Format.fprintf ppf "@[<hv>%a@]"
-        (Format.pp_print_list ~pp_sep:nl pp_diff) filtered_diff
+        (Format.pp_print_list ~pp_sep:nl pp_diff) patch
 
 let report_record_mismatch first second decl env ppf err =
   let pr fmt = Format.fprintf ppf fmt in
@@ -323,28 +312,35 @@ let report_constructor_mismatch first second decl env ppf err =
         (String.capitalize_ascii (choose ord first second))
         (choose_other ord first second)
 
-let pp_variant_diff first second prefix decl env ppf (_, (x:variant_change) as px) =
+let pp_variant_diff first second prefix decl env ppf (x : variant_change) =
   match x with
-  | Diffing.Keep _ -> ()
-  | Diffing.Delete cd ->
+  | Delete cd ->
       Format.fprintf ppf  "%aAn extra constructor, %s, is provided in %s %s."
-        prefix px (Ident.name cd.cd_id) first decl
-  | Diffing.Insert cd ->
+        prefix x (Ident.name cd.delete.cd_id) first decl
+  | Insert cd ->
       Format.fprintf ppf "%aA constructor, %s, is missing in %s %s."
-        prefix px (Ident.name cd.cd_id) first decl
-  | Diffing.Change (_,_, Constructor_mismatch (c1, c2, err)) ->
+        prefix x (Ident.name cd.insert.cd_id) first decl
+  | Change Type {got; expected; reason} ->
       Format.fprintf ppf
         "@[<hv>%aConstructors do not match:@;<1 2>\
          %a@ is not the same as:\
          @;<1 2>%a@ %a@]"
-        prefix px
-        Printtyp.constructor c1
-        Printtyp.constructor c2
-        (report_constructor_mismatch first second decl env) err
-  | Diffing.Change (_,_, Constructor_names {left; right; _ }) ->
+        prefix x
+        Printtyp.constructor got
+        Printtyp.constructor expected
+        (report_constructor_mismatch first second decl env) reason
+  | Change Name n ->
       Format.fprintf ppf
         "%aConstructors have different names, %s and %s."
-        prefix px (Ident.name left) (Ident.name right)
+        prefix x n.got n.expected
+  | Swap sw ->
+      Format.fprintf ppf
+        "%aConstructors %s and %s have been swapped."
+        prefix x sw.first sw.last
+  | Move {name; got; expected} ->
+      Format.fprintf ppf
+        "@[<2>%aConstructor %s has been moved@ from@ position %d@ to %d.@]"
+        prefix x name expected got
 
 let report_extension_constructor_mismatch first second decl env ppf err =
   let pr fmt = Format.fprintf ppf fmt in
@@ -464,45 +460,58 @@ module Record_diffing = struct
                 rem1 rem2
         end
 
-  let update d (params1,params2 as st) =
-    match (d:record_change) with
-    | Diffing.(Insert _ | Change _ | Delete _) -> st
-    | Diffing.Keep (x,y,_) -> x.ld_type::params1, y.ld_type::params2
+  let update
+      (d:(int * Types.label_declaration as 'a,'a,_,_) Diffing.change)
+      (params1,params2 as st) =
+    match d with
+    | Insert _ | Change _ | Delete _ -> st
+    | Keep (x,y,_) ->
+        (* We need to add equality between existential type parameters
+           (in inline records) *)
+        (snd x).ld_type::params1, (snd y).ld_type::params2
 
   let test _loc env (params1,params2)
-      (lbl1:Types.label_declaration)
-      (lbl2:Types.label_declaration) =
-    if Ident.name lbl1.ld_id <> Ident.name lbl2.ld_id then
+      (pos, lbl1: _ * Types.label_declaration)
+      (_, lbl2: _ * Types.label_declaration)
+    =
+    let name1, name2 = Ident.name lbl1.ld_id, Ident.name lbl2.ld_id in
+    if  name1 <> name2 then
       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})
+      Error
+        (Diffing_with_keys.Name {types_match; pos; got=name1; expected=name2})
     else
       match compare_labels env params1 params2 lbl1 lbl2 with
-      | Some r ->
-          Error (Kind_mismatch (lbl1, lbl2, r))
-      | None -> Ok (lbl1.ld_type::params1,lbl2.ld_type::params2)
+      | Some reason ->
+          Error (
+            Diffing_with_keys.Type {pos; got=lbl1; expected=lbl2; reason}
+          )
+      | None -> Ok ()
 
   let weight = function
     | Diffing.Insert _ -> 10
     | Diffing.Delete _ -> 10
     | Diffing.Keep _ -> 0
-    | Diffing.Change (_,_,Name_mismatch t ) ->
+    | Diffing.Change (_,_,Diffing_with_keys.Name t ) ->
         if t.types_match then 10 else 15
     | Diffing.Change _ -> 10
 
-
+  let key (x: Types.label_declaration) = Ident.name x.ld_id
   let diffing loc env params1 params2 cstrs_1 cstrs_2 =
     let test = test loc env in
-    Diffing.diff
-      ~weight
-      ~test
-      ~update (params1,params2)
-      (Array.of_list cstrs_1)
-      (Array.of_list cstrs_2)
-
+    let cstrs_1 = Diffing_with_keys.with_pos cstrs_1 in
+    let cstrs_2 = Diffing_with_keys.with_pos cstrs_2 in
+    let raw = Diffing.diff
+        ~weight
+        ~test
+        ~update (params1,params2)
+        (Array.of_list cstrs_1)
+        (Array.of_list cstrs_2)
+    in
+    Diffing_with_keys.refine ~key ~update ~test (params1,params2) raw
 
   let compare ~loc env params1 params2 l r =
     if equal ~loc env params1 params2 l r then
@@ -510,6 +519,7 @@ module Record_diffing = struct
     else
       Some (diffing loc env params1 params2 l r)
 
+
   let compare_with_representation ~loc env params1 params2 l r rep1 rep2 =
     if not (equal ~loc env params1 params2 l r) then
       let patch = diffing loc env params1 params2 l r in
@@ -596,38 +606,44 @@ module Variant_diffing = struct
     | Diffing.Insert _ -> 10
     | Diffing.Delete _ -> 10
     | Diffing.Keep _ -> 0
-    | Diffing.Change (_,_,Constructor_names t) ->
+    | Diffing.Change (_,_,Diffing_with_keys.Name 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
+      (pos,cd1: _ * Types.constructor_declaration)
+      (_,cd2: _ * Types.constructor_declaration) =
+    let name1, name2 = Ident.name cd1.cd_id, Ident.name cd2.cd_id in
+    if  name1 <> name2 then
       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})
+      Error
+        (Diffing_with_keys.Name {types_match; pos; got=name1; expected=name2})
     else
       match compare_constructors ~loc env params1 params2
               cd1.cd_res cd2.cd_res cd1.cd_args cd2.cd_args with
-      | Some r ->
-          Error (Constructor_mismatch (cd1, cd2, r))
+      | Some reason ->
+          Error (Diffing_with_keys.Type {pos; got=cd1; expected=cd2; reason})
       | None -> Ok (Ident.name cd1.cd_id)
 
   let diffing loc env params1 params2 cstrs_1 cstrs_2 =
     let test = test loc env params1 params2 in
-    Diffing.diff
+    let cstrs_1 = Diffing_with_keys.with_pos cstrs_1 in
+    let cstrs_2 = Diffing_with_keys.with_pos cstrs_2 in
+    let raw = Diffing.diff
       ~weight
       ~test
       ~update ()
       (Array.of_list cstrs_1)
       (Array.of_list cstrs_2)
-
+    in
+    let key (x:Types.constructor_declaration) = Ident.name x.cd_id in
+    Diffing_with_keys.refine ~key ~update ~test () raw
 
   let compare ~loc env params1 params2 l r =
     if equal ~loc env params1 params2 l r then
diff --git a/typing/includecore.mli b/typing/includecore.mli
index e700caef97..9d13273e5c 100644
--- a/typing/includecore.mli
+++ b/typing/includecore.mli
@@ -47,15 +47,8 @@ type label_mismatch =
   | Type of Errortrace.equality_error
   | Mutability of position
 
-type field_mismatch =
-  | Kind_mismatch of
-      Types.label_declaration * Types.label_declaration * label_mismatch
-  | Name_mismatch of { types_match:bool; left:Ident.t; right:Ident.t }
-
-
 type record_change =
-  (Types.label_declaration, Types.label_declaration,
-   type_expr list * type_expr list, field_mismatch) Diffing.change
+  (Types.label_declaration, label_mismatch) Diffing_with_keys.change
 
 type record_mismatch =
   | Label_mismatch of record_change list
@@ -68,12 +61,6 @@ type constructor_mismatch =
   | Kind of position
   | Explicit_return_type of position
 
-type variant_mismatch =
-  | Constructor_mismatch of Types.constructor_declaration
-                            * Types.constructor_declaration
-                            * constructor_mismatch
-  | Constructor_names of { types_match:bool; left:Ident.t; right:Ident.t }
-
 type extension_constructor_mismatch =
   | Constructor_privacy
   | Constructor_mismatch of Ident.t
@@ -81,8 +68,8 @@ type extension_constructor_mismatch =
                             * extension_constructor
                             * constructor_mismatch
 type variant_change =
-  (Types.constructor_declaration, Types.constructor_declaration,
-   Asttypes.label, variant_mismatch) Diffing.change
+  (Types.constructor_declaration, constructor_mismatch)
+    Diffing_with_keys.change
 
 type private_variant_mismatch =
   | Only_outer_closed
diff --git a/typing/includemod_errorprinter.ml b/typing/includemod_errorprinter.ml
index 0bdda19921..bc71279b0a 100644
--- a/typing/includemod_errorprinter.ml
+++ b/typing/includemod_errorprinter.ml
@@ -373,7 +373,7 @@ module Functor_suberror = struct
   (** Print the list of params with style *)
   let pretty_params sep proj printer patch =
     let elt (x,param) =
-      let sty = Diffing.style x in
+      let sty = Diffing.(style @@ classify x) in
       Format.dprintf "%a%t%a"
         Format.pp_open_stag (Misc.Color.Style sty)
         (printer param)
@@ -524,7 +524,7 @@ module Functor_suberror = struct
     Location.msg "%a%a%a%a@[<hv 2>%t@]%a"
       Format.pp_print_tab ()
       Format.pp_open_tbox ()
-      Diffing.prefix (pos, diff)
+      Diffing.prefix (pos, Diffing.classify diff)
       Format.pp_set_tab ()
       (Printtyp.wrap_printing_env env ~error:true
          (fun () -> sub ~expansion_token env diff)
diff --git a/utils/diffing.ml b/utils/diffing.ml
index badec4e30f..6aa9ca6413 100644
--- a/utils/diffing.ml
+++ b/utils/diffing.ml
@@ -370,11 +370,23 @@ let variadic_diff ~weight ~test ~(update:_ update) state line column =
   |> construct_patch
 
 
+type change_kind =
+  | Deletion
+  | Insertion
+  | Modification
+  | Preservation
+
+let classify = function
+  | Delete _ -> Deletion
+  | Insert _ -> Insertion
+  | Change _ -> Modification
+  | Keep _ -> Preservation
+
 let style = function
-  | Keep _ -> Misc.Color.[ FG Green ]
-  | Delete _ -> Misc.Color.[ FG Red; Bold]
-  | Insert _ -> Misc.Color.[ FG Red; Bold]
-  | Change _ -> Misc.Color.[ FG Magenta; Bold]
+  | Preservation -> Misc.Color.[ FG Green ]
+  | Deletion -> Misc.Color.[ FG Red; Bold]
+  | Insertion -> Misc.Color.[ FG Red; Bold]
+  | Modification -> Misc.Color.[ FG Magenta; Bold]
 
 let prefix ppf (pos, p) =
   let sty = style p in
diff --git a/utils/diffing.mli b/utils/diffing.mli
index 93502667d2..8c68a1e3f2 100644
--- a/utils/diffing.mli
+++ b/utils/diffing.mli
@@ -66,6 +66,7 @@ type ('left, 'right, 'eq, 'diff) change =
   | Keep of 'left * 'right * 'eq
   | Change of 'left * 'right * 'diff
 
+
 val map :
   ('l1 -> 'l2) -> ('r1 -> 'r2) ->
   ('l1, 'r1, 'eq, 'diff) change ->
@@ -115,5 +116,14 @@ val variadic_diff :
 val default_weight : _ change -> int
 
 (** Printing default function *)
-val prefix: Format.formatter -> (int *  _ change) -> unit
-val style: _ change -> Misc.Color.style list
+type change_kind =
+  | Deletion
+  | Insertion
+  | Modification
+  | Preservation
+
+val classify: _ change -> change_kind
+val prefix: Format.formatter -> (int * change_kind) -> unit
+val style: change_kind -> Misc.Color.style list
+
+(** Enriched analysis in presence of keys *)
diff --git a/utils/diffing_with_keys.ml b/utils/diffing_with_keys.ml
new file mode 100644
index 0000000000..3e0a95f0fe
--- /dev/null
+++ b/utils/diffing_with_keys.ml
@@ -0,0 +1,143 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Florian Angeletti, projet Cambium, Inria Paris             *)
+(*                                                                        *)
+(*   Copyright 2021 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+
+type 'a with_pos = int * 'a
+let with_pos l = List.mapi (fun n x -> n+1,x) l
+let pos (x,_) = x
+let data (_,x) = x
+let mk_pos pos data = pos, data
+
+type ('a,'b) mismatch =
+  | Name of {pos:int; got:string; expected:string; types_match:bool}
+  | Type of {pos:int; got:'a; expected:'a; reason:'b}
+
+type ('a,'b) change =
+  | Change of ('a,'b) mismatch
+  | Swap of { pos: int * int; first: string; last: string }
+  | Move of {name:string; got:int; expected:int}
+  | Insert of {pos:int; insert:'a}
+  | Delete of {pos:int; delete:'a}
+
+let prefix ppf x =
+  let kind = match x with
+    | Change _ | Swap _ | Move _ -> Diffing.Modification
+    | Insert _ -> Diffing.Insertion
+    | Delete _ -> Diffing.Deletion
+  in
+  let style k ppf inner =
+    let sty = Diffing.style k in
+    Format.pp_open_stag ppf (Misc.Color.Style sty);
+    Format.kfprintf (fun ppf -> Format.pp_close_stag ppf () ) ppf inner
+  in
+  match x with
+  | Change (Name {pos; _ } | Type {pos; _})
+  | Insert { pos; _ } | Delete { pos; _ } ->
+      style kind ppf "%i. " pos
+  | Swap { pos = left, right; _ } ->
+      style kind ppf "%i<->%i. " left right
+  | Move { got; expected; _ } ->
+      style kind ppf "%i->%i. " expected got
+
+module Swap = Map.Make(struct
+    type t = string * string
+    let compare: t -> t -> int = Stdlib.compare
+  end)
+module Move = Misc.Stdlib.String.Map
+
+type ('a,'state) partial_edge =
+  | Left of int * 'state * 'a
+  | Right of int * 'state * 'a
+  | Both of 'state * 'a * 'a
+
+let edge key state x y =
+  let kx, ky = key (data x), key (data y) in
+  if kx <= ky then
+    (kx,ky), Left (pos x, state, (x,y))
+  else
+    (ky,kx), Right(pos x,state, (x,y))
+
+let add_edge ex ey = match ex, ey with
+  | ex, None -> Some ex
+  | Left (lpos, lstate, l), Some Right (rpos, rstate,r)
+  | Right (rpos, rstate,r), Some Left (lpos, lstate, l) ->
+      let state = if lpos < rpos then rstate else lstate in
+      Some (Both (state,l,r))
+  | Both _ as b, _ | _, Some (Both _ as b)  -> Some b
+  | l, _ -> Some l
+
+let exchanges ~update ~key state changes =
+  let add (state,(swaps,moves)) d =
+    update d state,
+    match d with
+    | Diffing.Change (x,y,_) ->
+        let k, edge = edge key state x y in
+        Swap.update k (add_edge edge) swaps, moves
+    | Diffing.Insert nx ->
+        let k = key (data nx) in
+        let edge = Right (pos nx, state,nx) in
+        swaps, Move.update k (add_edge edge) moves
+    | Diffing.Delete nx ->
+        let k, edge = key (data nx), Left (pos nx, state, nx) in
+        swaps, Move.update k (add_edge edge) moves
+    | _ -> swaps, moves
+  in
+  List.fold_left add (state,(Swap.empty,Move.empty)) changes
+
+
+let swap key test swaps x y =
+  let kx, ky = key (data x), key (data y) in
+  let key = if kx <= ky then kx, ky else ky, kx in
+  match Swap.find_opt key swaps with
+  | None | Some (Left _ | Right _)-> None
+  | Some Both (state, (ll,lr),(rl,rr)) ->
+      match test state ll rr,  test state lr rl with
+      | Ok _, Ok _ ->
+          Some (mk_pos (pos ll) kx, mk_pos (pos rl) ky)
+      | Error _, _ | _, Error _ -> None
+
+let move key test moves x =
+  let name = key (data x) in
+  match Move.find_opt name moves with
+  | None | Some (Left _ | Right _)-> None
+  | Some Both (state,got,expected) ->
+      match test state got expected with
+      | Ok _ ->
+          Some (Move {name; got=pos got; expected=pos expected})
+      | Error _ -> None
+
+let refine ~key ~update ~test state patch =
+  let _, (swaps, moves) = exchanges ~key ~update state patch in
+  let filter = function
+    | Diffing.Keep _ -> None
+    | Diffing.Insert x ->
+        begin match move key test moves x with
+        | Some _ as move -> move
+        | None -> Some (Insert {pos=pos x;insert=data x})
+        end
+    | Diffing.Delete x ->
+        begin match move key test moves x with
+        | Some _ -> None
+        | None -> Some (Delete {pos=pos x;delete=data x})
+        end
+    | Diffing.Change(x,y, reason) ->
+        match swap key test swaps x y with
+        | Some ((pos1,first),(pos2,last)) ->
+            if pos x = pos1 then
+              Some (Swap { pos = pos1, pos2; first; last})
+            else None
+        | None -> Some (Change reason)
+  in
+  List.filter_map filter patch
diff --git a/utils/diffing_with_keys.mli b/utils/diffing_with_keys.mli
new file mode 100644
index 0000000000..1b6270e539
--- /dev/null
+++ b/utils/diffing_with_keys.mli
@@ -0,0 +1,54 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Florian Angeletti, projet Cambium, Inria Paris             *)
+(*                                                                        *)
+(*   Copyright 2021 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(**
+
+   When diffing lists where each element has a distinct key, we can refine
+   the diffing patch by introducing two composite edit moves: swaps and moves.
+
+   [Swap]s exchange the position of two elements. [Swap] cost is set to
+   [2 * change - epsilon].
+   [Move]s change the position of one element. [Move] cost is set to
+   [delete + addition - epsilon].
+
+   When the cost [delete + addition] is greater than [change] and with those
+   specific weights, the optimal patch with [Swap]s and [Move]s can be computed
+   directly and cheaply from the original optimal patch.
+
+*)
+
+type 'a with_pos = int * 'a
+val with_pos: 'a list -> 'a with_pos list
+
+type ('a,'b) mismatch =
+  | Name of {pos:int; got:string; expected:string; types_match:bool}
+  | Type of {pos:int; got:'a; expected:'a; reason:'b}
+
+type ('a,'b) change =
+  | Change of ('a,'b) mismatch
+  | Swap of { pos: int * int; first: string; last: string }
+  | Move of {name:string; got:int; expected:int}
+  | Insert of {pos:int; insert:'a}
+  | Delete of {pos:int; delete:'a}
+
+val refine:
+  key:('a -> string) ->
+  update:('ch -> 'state -> 'state) ->
+  test:('state -> 'a with_pos -> 'a with_pos -> (_, _) result) ->
+  'state ->
+  (('a with_pos,'a with_pos,_,('a,'b) mismatch) Diffing.change as 'ch) list ->
+  ('a, 'b) change list
+
+val prefix: Format.formatter -> ('a,'b) change -> unit