recursive expansion for single cases

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/gadt-warnings@16496 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

testsuite/tests/typing-warnings/exhaustiveness.ml

@@ -24,3 +24,11 @@ let f (x : unit t option) = match x with None -> 1 | _ -> 2;; (* warn? *)
 let f (x : unit t option) = match x with None -> 1 | Some _ -> 2;; (* warn *)
 let f (x : int t option) = match x with None -> 1 | _ -> 2;;
 let f (x : int t option) = match x with None -> 1;; (* warn *)
+
+(* Example with record, type, single case *)
+
+type 'a box = Box of 'a
+type 'a pair = {left: 'a; right: 'a};;
+
+let f : (int t box pair * bool) option -> unit = function None -> ();;
+let f : (string t box pair * bool) option -> unit = function None -> ();;

testsuite/tests/typing-warnings/exhaustiveness.ml.reference

@@ -38,4 +38,14 @@ Warning 8: this pattern-matching is not exhaustive.
 Here is an example of a value that is not matched:
 Some A
 val f : int t option -> int = <fun>
+#         type 'a box = Box of 'a
+type 'a pair = { left : 'a; right : 'a; }
+#   Characters 50-69:
+  let f : (int t box pair * bool) option -> unit = function None -> ();;
+                                                   ^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+Some ({left=Box A; right=Box A}, _)
+val f : (int t box pair * bool) option -> unit = <fun>
+# val f : (string t box pair * bool) option -> unit = <fun>
 # 

typing/parmatch.ml

@@ -721,15 +721,23 @@ let pats_of_type ?(always=false) env ty =
   let ty' = Ctype.expand_head env ty in
   match ty'.desc with
   | Tconstr (path, _, _) ->
-      begin match Env.find_type path env with
-      | {type_kind = Type_variant cl}
-        when always || List.for_all (fun cd -> cd.Types.cd_res <> None) cl ->
+      begin match (Env.find_type path env).type_kind with
+      | Type_variant cl when always || List.length cl = 1 ||
+        List.for_all (fun cd -> cd.Types.cd_res <> None) cl ->
           let cstrs = fst (Env.find_type_descrs path env) in
-          List.map
-            (pat_of_constr {omega with pat_type=ty; pat_env=env})
-            cstrs
+          List.map (pat_of_constr (make_pat Tpat_any ty env)) cstrs
+      | Type_record (ldl, _) ->
+          let labels = snd (Env.find_type_descrs path env) in
+          let fields =
+            List.map (fun ld ->
+              mknoloc (Longident.Lident "?pat_of_label?"), ld, omega)
+              labels
+          in
+          [make_pat (Tpat_record (fields, Closed)) ty env]
       | _ -> [omega]
       end
+  | Ttuple tl ->
+      [make_pat (Tpat_tuple (omegas (List.length tl))) ty env]
   | _ -> [omega]
 
 let rec get_variant_constructors env ty =

typing/typecore.ml

@@ -967,8 +967,13 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env
         let (sp, constrs, labels) = Parmatch.ppat_of_type !env expected_ty in
 	if sp.ppat_desc = Parsetree.Ppat_any then k' Tpat_any else
         if mode = Inside_or then raise Need_backtrack else
+        let explode =
+          match sp.ppat_desc with
+            Parsetree.Ppat_or _ -> explode - 10
+          | _ -> explode - 1
+        in
         type_pat ~constrs:(Some constrs) ~labels:(Some labels)
-          ~explode:(explode-1) sp expected_ty k
+          ~explode sp expected_ty k
       else k' Tpat_any
   | Ppat_var name ->
       assert (constrs = None);
@@ -1353,11 +1358,11 @@ let partial_pred ~lev ?mode ?explode env expected_ty constrs labels p =
     None
 
 let check_partial ?(lev=get_current_level ()) env expected_ty =
-  Parmatch.check_partial_gadt (partial_pred ~lev ~explode:1 env expected_ty)
+  Parmatch.check_partial_gadt (partial_pred ~lev ~explode:10 env expected_ty)
 
 let check_unused ?(lev=get_current_level ()) env expected_ty =
   Parmatch.check_unused
-    (partial_pred ~lev ~mode:Split_or ~explode:1 env expected_ty) env
+    (partial_pred ~lev ~mode:Split_or ~explode:10 env expected_ty) env
 
 let rec iter3 f lst1 lst2 lst3 =
   match lst1,lst2,lst3 with