Fix PR#6235 + keep typing of pattern cases independent in principal mode

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@14285 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

5 files changed, 87 insertions, 6 deletions

diff --git a/Changes b/Changes
index 5f8320e304..b611717a47 100644
--- a/Changes
+++ b/Changes
@@ -6,6 +6,11 @@ Next version:
 Other libraries:
 * Labltk: removed from the distribution, now available as a third-party library
 
+Type system:
+* Keep typing of pattern cases independent in principal mode
+  (i.e. information from previous cases is no longer used when typing
+  patterns; cf. PR6235' in typing-warnings/records.ml)
+
 Language features:
 - Attributes and extension nodes
 
@@ -53,6 +58,7 @@ Bug fixes:
 - PR#6173: Typing error message is worse that before
 - PR#6174: OCaml compiler loops on an example using GADTs (non -rectypes)
 - PR#6216: inlining of GADT matches generates invalid assembly
+- PR#6235: Issue with type information flowing through a variant pattern
 
 
 OCaml 4.01.0:
diff --git a/testsuite/tests/typing-warnings/records.ml b/testsuite/tests/typing-warnings/records.ml
index 61a21cebb6..59a45549d0 100644
--- a/testsuite/tests/typing-warnings/records.ml
+++ b/testsuite/tests/typing-warnings/records.ml
@@ -158,3 +158,23 @@ module Shadow2 = struct
   open M  (* this open shadows label 'x' *)
   let y = {x = ""}
 end;;
+
+(* PR#6235 *)
+
+module P6235 = struct
+  type t = { loc : string; }
+  type v = { loc : string; x : int; }
+  type u = [ `Key of t ]
+  let f (u : u) = match u with `Key {loc} -> loc
+end;;
+
+(* Remove interaction between branches *)
+
+module P6235' = struct
+  type t = { loc : string; }
+  type v = { loc : string; x : int; }
+  type u = [ `Key of t ]
+  let f = function
+    | (_ : u) when false -> ""
+    |`Key {loc} -> loc
+end;;
diff --git a/testsuite/tests/typing-warnings/records.ml.principal.reference b/testsuite/tests/typing-warnings/records.ml.principal.reference
index 322f31e71f..c208dee25d 100644
--- a/testsuite/tests/typing-warnings/records.ml.principal.reference
+++ b/testsuite/tests/typing-warnings/records.ml.principal.reference
@@ -270,4 +270,32 @@ module Shadow2 :
     module M : sig type s = { x : string; } end
     val y : M.s
   end
+#                 Characters 167-170:
+    let f (u : u) = match u with `Key {loc} -> loc
+                                       ^^^
+Warning 42: this use of loc required disambiguation.
+module P6235 :
+  sig
+    type t = { loc : string; }
+    type v = { loc : string; x : int; }
+    type u = [ `Key of t ]
+    val f : u -> string
+  end
+#                     Characters 219-224:
+      |`Key {loc} -> loc
+            ^^^^^
+Warning 41: these field labels belong to several types: v t
+The first one was selected. Please disambiguate if this is wrong.
+Characters 219-224:
+      |`Key {loc} -> loc
+            ^^^^^
+Warning 9: the following labels are not bound in this record pattern:
+x
+Either bind these labels explicitly or add '; _' to the pattern.
+Characters 214-224:
+      |`Key {loc} -> loc
+       ^^^^^^^^^^
+Error: This pattern matches values of type [? `Key of v ]
+       but a pattern was expected which matches values of type u
+       Types for tag `Key are incompatible
 # 
diff --git a/testsuite/tests/typing-warnings/records.ml.reference b/testsuite/tests/typing-warnings/records.ml.reference
index 4dde3848a0..2853439c65 100644
--- a/testsuite/tests/typing-warnings/records.ml.reference
+++ b/testsuite/tests/typing-warnings/records.ml.reference
@@ -265,4 +265,26 @@ module Shadow2 :
     module M : sig type s = { x : string; } end
     val y : M.s
   end
+#                 Characters 167-170:
+    let f (u : u) = match u with `Key {loc} -> loc
+                                       ^^^
+Warning 42: this use of loc required disambiguation.
+module P6235 :
+  sig
+    type t = { loc : string; }
+    type v = { loc : string; x : int; }
+    type u = [ `Key of t ]
+    val f : u -> string
+  end
+#                     Characters 220-223:
+      |`Key {loc} -> loc
+             ^^^
+Warning 42: this use of loc required disambiguation.
+module P6235' :
+  sig
+    type t = { loc : string; }
+    type v = { loc : string; x : int; }
+    type u = [ `Key of t ]
+    val f : u -> string
+  end
 # 
diff --git a/typing/typecore.ml b/typing/typecore.ml
index edbf555047..644b2ae110 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -1050,16 +1050,21 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
         pat_attributes = sp.ppat_attributes;
         pat_env = !env }
   | Ppat_variant(l, sarg) ->
-      let arg = may_map (fun p -> type_pat p (newvar())) sarg in
-      let arg_type = match arg with None -> [] | Some arg -> [arg.pat_type]  in
+      let arg_type = match sarg with None -> [] | Some _ -> [newvar()] in
       let row = { row_fields =
-                    [l, Reither(arg = None, arg_type, true, ref None)];
+                    [l, Reither(sarg = None, arg_type, true, ref None)];
                   row_bound = ();
                   row_closed = false;
                   row_more = newvar ();
                   row_fixed = false;
                   row_name = None } in
       unify_pat_types loc !env (newty (Tvariant row)) expected_ty;
+      let arg =
+        (* PR#6235: propagate type information *)
+        match sarg, arg_type with
+          Some p, [ty] -> Some (type_pat p ty)
+        | _            -> None
+      in
       rp {
         pat_desc = Tpat_variant(l, arg, ref {row with row_more = newvar()});
         pat_loc = loc; pat_extra=[];
@@ -3325,11 +3330,12 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist : Typedt
             { pat with pat_type = instance env pat.pat_type }
           end else pat
         in
-        unify_pat env pat ty_arg';
         (pat, (ext_env, unpacks)))
       caselist in
-  (* Check for polymorphic variants to close *)
+  (* Unify cases (delayed to keep it order-free) *)
   let patl = List.map fst pat_env_list in
+  List.iter (fun pat -> unify_pat env pat ty_arg') patl;
+  (* Check for polymorphic variants to close *)
   if List.exists has_variants patl then begin
     Parmatch.pressure_variants env patl;
     List.iter (iter_pattern finalize_variant) patl
@@ -3337,7 +3343,6 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist : Typedt
   (* `Contaminating' unifications start here *)
   List.iter (fun f -> f()) !pattern_force;
   (* Post-processing and generalization *)
-  let patl = List.map fst pat_env_list in
   List.iter (iter_pattern (fun {pat_type=t} -> unify_var env t (newvar())))
     patl;
   List.iter (fun pat -> unify_pat env pat (instance env ty_arg)) patl;