Relax the level handling when unifying row fields (ocaml#9064)

Changes

@@ -56,6 +56,9 @@ Working version
   may not match the one in bytecode.
   (Nicolás Ojeda Bär, report by Pierre Chambart, review by Gabriel Scherer)
 
+- #9064: Relax the level handling when unifying row fields
+  (Leo White, review by Jacques Garrigue)
+
 OCaml 4.10.0
 ------------
 

testsuite/tests/typing-gadts/or_patterns.ml

@@ -281,13 +281,7 @@ let simple_merged_annotated_under_poly_variant (type a) (pair : a t * a) =
 ;;
 
 [%%expect{|
-Line 3, characters 19-20:
-3 |   | `Foo ( IntLit, 3
-                       ^
-Error: This pattern matches values of type int
-       but a pattern was expected which matches values of type a = int
-       This instance of int is ambiguous:
-       it would escape the scope of its equation
+val simple_merged_annotated_under_poly_variant : 'a t * 'a -> unit = <fun>
 |}]
 
 let simple_merged_annotated_under_poly_variant_annotated (type a) pair =

typing/ctype.ml

@@ -2901,7 +2901,7 @@ and unify_row env row1 row2 =
     set_more row1 r2;
     List.iter
       (fun (l,f1,f2) ->
-        try unify_row_field env fixed1 fixed2 more l f1 f2
+        try unify_row_field env fixed1 fixed2 rm1 rm2 l f1 f2
         with Unify trace ->
           raise Trace.( Unify( Variant (Incompatible_types_for l) :: trace ))
       )
@@ -2914,7 +2914,7 @@ and unify_row env row1 row2 =
     set_type_desc rm1 md1; set_type_desc rm2 md2; raise exn
   end
 
-and unify_row_field env fixed1 fixed2 more l f1 f2 =
+and unify_row_field env fixed1 fixed2 rm1 rm2 l f1 f2 =
   let f1 = row_field_repr f1 and f2 = row_field_repr f2 in
   let if_not_fixed (pos,fixed) f =
     match fixed with
@@ -2949,13 +2949,13 @@ and unify_row_field env fixed1 fixed2 more l f1 f2 =
             List.iter (unify env t1) tl;
             !e1 <> None || !e2 <> None
         end in
-      if redo then unify_row_field env fixed1 fixed2 more l f1 f2 else
+      if redo then unify_row_field env fixed1 fixed2 rm1 rm2 l f1 f2 else
       let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in
       let rec remq tl = function [] -> []
         | ty :: tl' ->
             if List.memq ty tl then remq tl tl' else ty :: remq tl tl'
       in
-      let tl2' = remq tl2 tl1 and tl1' = remq tl1 tl2 in
+      let tl1' = remq tl2 tl1 and tl2' = remq tl1 tl2 in
       (* PR#6744 *)
       let split_univars =
         List.partition
@@ -2972,13 +2972,18 @@ and unify_row_field env fixed1 fixed2 more l f1 f2 =
       end;
       (* Is this handling of levels really principal? *)
       List.iter (fun ty ->
-        let rm = repr more in
+        let rm = repr rm2 in
         update_level !env rm.level ty;
         update_scope rm.scope ty;
-      ) (tl1' @ tl2');
+      ) tl1';
+      List.iter (fun ty ->
+        let rm = repr rm1 in
+        update_level !env rm.level ty;
+        update_scope rm.scope ty;
+      ) tl2';
       let e = ref None in
-      let f1' = Reither(c1 || c2, tl1', m1 || m2, e)
-      and f2' = Reither(c1 || c2, tl2', m1 || m2, e) in
+      let f1' = Reither(c1 || c2, tl2', m1 || m2, e)
+      and f2' = Reither(c1 || c2, tl1', m1 || m2, e) in
       set_row_field e1 f1'; set_row_field e2 f2';
   | Reither(_, _, false, e1), Rabsent ->
       if_not_fixed first (fun () -> set_row_field e1 f2)
@@ -2988,7 +2993,7 @@ and unify_row_field env fixed1 fixed2 more l f1 f2 =
   | Reither(false, tl, _, e1), Rpresent(Some t2) ->
       if_not_fixed first (fun () ->
           set_row_field e1 f2;
-          let rm = repr more in
+          let rm = repr rm1 in
           update_level !env rm.level t2;
           update_scope rm.scope t2;
           (try List.iter (fun t1 -> unify env t1 t2) tl
@@ -2997,7 +3002,7 @@ and unify_row_field env fixed1 fixed2 more l f1 f2 =
   | Rpresent(Some t1), Reither(false, tl, _, e2) ->
       if_not_fixed second (fun () ->
           set_row_field e2 f1;
-          let rm = repr more in
+          let rm = repr rm2 in
           update_level !env rm.level t1;
           update_scope rm.scope t1;
           (try List.iter (unify env t1) tl