fix PR#5332

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

5 files changed, 74 insertions, 25 deletions

diff --git a/testsuite/tests/typing-gadts/pr5332.ml b/testsuite/tests/typing-gadts/pr5332.ml
new file mode 100644
index 000000000..ef70e5a1a
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr5332.ml
@@ -0,0 +1,17 @@
+type ('env, 'a) var =
+ | Zero : ('a * 'env, 'a) var
+ | Succ : ('env, 'a) var -> ('b * 'env, 'a) var
+;;
+type ('env, 'a) typ =
+ | Tint : ('env, int) typ
+ | Tbool : ('env, bool) typ
+ | Tvar : ('env, 'a) var -> ('env, 'a) typ
+;;
+let f : type env a. (env, a) typ -> (env, a) typ -> int = fun ta tb ->
+ match ta, tb with
+   | Tint, Tint -> 0
+   | Tbool, Tbool -> 1
+   | Tvar var, tb -> 2
+;;
+let x = f Tint (Tvar Zero)
+;;
diff --git a/testsuite/tests/typing-gadts/pr5332.ml.reference b/testsuite/tests/typing-gadts/pr5332.ml.reference
new file mode 100644
index 000000000..4d8f4b933
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr5332.ml.reference
@@ -0,0 +1,19 @@
+
+#       type ('a, 'b) var =
+    Zero : ('c * 'd, 'c) var
+  | Succ : ('f, 'g) var -> ('e * 'f, 'g) var
+#         type ('a, 'b) typ =
+    Tint : ('c, int) typ
+  | Tbool : ('d, bool) typ
+  | Tvar : ('e, 'f) var -> ('e, 'f) typ
+#           Characters 72-156:
+  .match ta, tb with
+     | Tint, Tint -> 0
+     | Tbool, Tbool -> 1
+     | Tvar var, tb -> 2
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+(Tbool, Tvar _)
+val f : ('a, 'b) typ -> ('a, 'b) typ -> int = <fun>
+#   Exception: Match_failure ("", 9, 1).
+# 
diff --git a/testsuite/tests/typing-gadts/test.ml b/testsuite/tests/typing-gadts/test.ml
index e79361acf..46e0590c3 100644
--- a/testsuite/tests/typing-gadts/test.ml
+++ b/testsuite/tests/typing-gadts/test.ml
@@ -235,7 +235,7 @@ let f (type a) (x : a t) y =
   r
 ;;
 let f (type a) (x : a t) (y : a) =
-  match x with Int -> y
+  match x with Int -> y (* should return an int! *)
 ;;
 
 (* Pattern matching *)
diff --git a/testsuite/tests/typing-gadts/test.ml.principal.reference b/testsuite/tests/typing-gadts/test.ml.principal.reference
index 6db24e1a5..3c2f106e3 100644
--- a/testsuite/tests/typing-gadts/test.ml.principal.reference
+++ b/testsuite/tests/typing-gadts/test.ml.principal.reference
@@ -158,6 +158,17 @@ Error: This pattern matches values of type 'a array
                            ^^^^^^^
 Error: This pattern matches values of type 'a array
        but a pattern was expected which matches values of type a
-#                       type ('a, 'b) pair = { left : 'a; right : 'b; }
+#                       Characters 92-334:
+  ..match {left=x; right=y} with
+    | {left=_; right=A z} -> z
+    | {left=_; right=B z} -> if z then 1 else 2
+    | {left=_; right=C z} -> truncate z
+    | {left=TE TC; right=D [|1.0|]} -> 14
+    | {left=TA; right=D 0} -> -1
+    | {left=TA; right=D z} -> z
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+{left=TE TA; right=D [| _ |]}
+type ('a, 'b) pair = { left : 'a; right : 'b; }
 val f : 'a ty -> 'a t -> int = <fun>
 # 
diff --git a/typing/parmatch.ml b/typing/parmatch.ml
index 23ad23ac1..518f6f3b5 100644
--- a/typing/parmatch.ml
+++ b/typing/parmatch.ml
@@ -907,7 +907,10 @@ let build_other_gadt ext env =
           | _ -> fatal_error "Parmatch.get_tag" in
         let all_tags =  List.map (fun (p,_) -> get_tag p) env in
 	let cnstrs  = complete_constrs p all_tags in
-	List.map (pat_of_constr p) cnstrs
+	let pats = List.map (pat_of_constr p) cnstrs in
+        (* List.iter (Format.eprintf "%a@." top_pretty) pats;
+           Format.eprintf "@.@."; *)
+        pats
     | _ -> assert false
 	  
 (*
@@ -1060,7 +1063,7 @@ let combinations f lst lst' =
   let rec iter =
     function
 	[] -> []
-      | x :: xs -> iter2 x lst'
+      | x :: xs -> iter2 x lst' @ iter xs
   in
   iter lst
     
@@ -1680,13 +1683,11 @@ let check_partial_all v casel =
 
 
 (* conversion from Typedtree.pattern to Parsetree.pattern list *)
-module Conv = 
-struct
+module Conv = struct
   open Parsetree
   let mkpat desc = 
     {ppat_desc = desc;
      ppat_loc = Location.none}
-;;
 
   let rec select : 'a list list -> 'a list list = 
     function
@@ -1695,27 +1696,26 @@ struct
 	  List.map
 	    (fun lst -> x :: lst)
 	    (select ys)
-	    @
-	      select (xs::ys)
+	  @
+	    select (xs::ys)
       | _ -> []
-;;
 
-let name_counter = ref 0 
-let fresh () = 
-  let current = !name_counter in 
-  name_counter := !name_counter + 1;
-  "#$%^@*@" ^ string_of_int current
+  let name_counter = ref 0 
+  let fresh () = 
+    let current = !name_counter in 
+    name_counter := !name_counter + 1;
+    "#$%^@*@" ^ string_of_int current
 
   let conv (typed: Typedtree.pattern) : 
       Parsetree.pattern list * 
-	 (string,Types.constructor_description) Hashtbl.t * 
-	 (string,Types.label_description) Hashtbl.t
+      (string,Types.constructor_description) Hashtbl.t * 
+      (string,Types.label_description) Hashtbl.t
       = 
     let constrs = Hashtbl.create 0 in 
     let labels = Hashtbl.create 0 in 
     let rec loop pat = 
       match pat.pat_desc with
-	Tpat_or (a,b,_) ->
+        Tpat_or (a,b,_) ->
 	  loop a @ loop b
       | Tpat_any | Tpat_constant _ | Tpat_var _ ->
 	  [mkpat Ppat_any]
@@ -1734,7 +1734,7 @@ let fresh () =
 	      [mkpat (Ppat_construct(Longident.Lident id, None, false))]
           | _ ->
 	      List.map 
-		(fun lst ->
+	        (fun lst ->
 		  let arg = 
 		    match lst with
 		      [] -> assert false
@@ -1742,7 +1742,8 @@ let fresh () =
 		    | _ -> Some (mkpat (Ppat_tuple lst))
 		  in
 		  mkpat (Ppat_construct(Longident.Lident id, arg, false)))
-		results end
+	        results
+          end
       | Tpat_variant(label,p_opt,row_desc) ->
 	  begin match p_opt with
 	  | None ->
@@ -1750,9 +1751,10 @@ let fresh () =
 	  | Some p ->
 	      let results = loop p in 
 	      List.map
-		(fun p ->
+	        (fun p ->
 		  mkpat (Ppat_variant(label, Some p)))
-		results end
+	        results
+          end
       | Tpat_record subpatterns ->
 	  let pats = 
 	    select
@@ -1761,9 +1763,9 @@ let fresh () =
 	  let label_idents = 
 	    List.map 
 	      (fun (lbl,_) -> 
-		let id = fresh () in 
-		Hashtbl.add labels id lbl;
-		Longident.Lident id)  
+	        let id = fresh () in 
+	        Hashtbl.add labels id lbl;
+	        Longident.Lident id)  
 	      subpatterns
 	  in 
 	  List.map