Merge pull request #1914 from trefis/subtype_row

MPR#7824

4 files changed, 84 insertions, 0 deletions

diff --git a/Changes b/Changes
index 4921d93121..0f70202342 100644
--- a/Changes
+++ b/Changes
@@ -9,6 +9,9 @@ OCaml 4.07 maintenance branch
   constructors doesn't cause the compiler to load more cmi files
   (Jérémie Dimino)
 
+- MPR#7824, GPR#1914: subtype_row: filter out absent fields when row is closed
+  (Leo White and Thomas Refis, report by talex, review by Jacques Garrigue)
+
 OCaml 4.07.0 (10 July 2018)
 ---------------------------
 
diff --git a/testsuite/tests/typing-polyvariants-bugs/ocamltests b/testsuite/tests/typing-polyvariants-bugs/ocamltests
index d589e6c1a9..5ea661d00c 100644
--- a/testsuite/tests/typing-polyvariants-bugs/ocamltests
+++ b/testsuite/tests/typing-polyvariants-bugs/ocamltests
@@ -3,4 +3,5 @@ pr4933_ok.ml
 pr5057_ok.ml
 pr5057a_bad.ml
 pr7199_ok.ml
+pr7824.ml
 privrowsabate_ok.ml
diff --git a/testsuite/tests/typing-polyvariants-bugs/pr7824.ml b/testsuite/tests/typing-polyvariants-bugs/pr7824.ml
new file mode 100644
index 0000000000..2592b4b50b
--- /dev/null
+++ b/testsuite/tests/typing-polyvariants-bugs/pr7824.ml
@@ -0,0 +1,78 @@
+(* TEST
+   * expect
+*)
+
+module Element : sig
+  type +'a t
+
+  val from_a  : [`A] t -> unit
+  val from_ab : [< `A | `B] t -> unit
+
+  val to_a  : unit -> [`A] t
+  val to_ab : unit -> [< `A | `B] t
+end = struct
+  type +'a t
+
+  let from_a x = assert false
+  let from_ab x = assert false
+
+  let to_a x = assert false
+  let to_ab x = assert false
+end ;;
+[%%expect{|
+module Element :
+  sig
+    type +'a t
+    val from_a : [ `A ] t -> unit
+    val from_ab : [< `A | `B ] t -> unit
+    val to_a : unit -> [ `A ] t
+    val to_ab : unit -> [< `A | `B ] t
+  end
+|}];;
+
+let f x =
+  Element.from_a x;
+  Element.from_ab x;
+  match [] with
+  | _::_ -> (x :> [`A | `C] Element.t)
+;;
+[%%expect{|
+Line _, characters 2-54:
+  ..match [] with
+    | _::_ -> (x :> [`A | `C] Element.t)
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+[]
+val f : [ `A ] Element.t -> [ `A | `C ] Element.t = <fun>
+|}];;
+
+type _ t = T : 'a -> 'a t
+
+let f x =
+  Element.from_a x;
+  Element.from_ab x;
+  match T () with
+  | T _ -> (x :> [`A | `C] Element.t)
+;;
+[%%expect{|
+type _ t = T : 'a -> 'a t
+val f : [ `A ] Element.t -> [ `A | `C ] Element.t = <fun>
+|}];;
+
+let f () =
+  let open Element in
+  let x = if true then to_ab () else to_a () in
+  (x :> [ `A | `C ] Element.t)
+;;
+[%%expect{|
+val f : unit -> [ `A | `C ] Element.t = <fun>
+|}];;
+
+let f () =
+  let open Element in
+  let x = if true then to_a () else to_ab () in
+  (x :> [ `A | `C ] Element.t)
+;;
+[%%expect{|
+val f : unit -> [ `A | `C ] Element.t = <fun>
+|}];;
diff --git a/typing/ctype.ml b/typing/ctype.ml
index f24e46d15a..9f21bf2913 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -4132,6 +4132,8 @@ and subtype_row env trace row1 row2 cstrs =
   let row1 = row_repr row1 and row2 = row_repr row2 in
   let r1, r2, pairs =
     merge_row_fields row1.row_fields row2.row_fields in
+  let r1 = if row2.row_closed then filter_row_fields false r1 else r1 in
+  let r2 = if row1.row_closed then filter_row_fields false r2 else r2 in
   let more1 = repr row1.row_more
   and more2 = repr row2.row_more in
   match more1.desc, more2.desc with