Fix PR#7330

(Cherry-picked from trunk, b4b21d6af0032de5ac973ecc4fedeb6763eccf9c.)

Changes

@@ -350,6 +350,9 @@ OCaml 4.04.0:
 - PR#7285: Relaxed value restriction broken with principal
   (Jacques Garrigue, report by Leo White)
 
+- PR#7330: Missing exhaustivity check for extensible variant
+  (Jacques Garrigue, report by Elarnon *)
+
 - PR#7165, GPR#494: uncaught exception on invalid lexer directive
   (Gabriel Scherer, report by KC Sivaramakrishnan using afl-fuzz)
 

testsuite/tests/typing-extensions/open_types.ml

@@ -115,3 +115,11 @@ let f = function
   | _::_::_ -> 3
   | [] -> 2
 ;; (* warn *)
+
+
+(* PR#7330: exhaustiveness with GADTs *)
+
+type t = ..
+type t += IPair : (int * int) -> t ;;
+
+let f = function IPair (i, j) -> Format.sprintf "(%d, %d)" i j ;; (* warn *)

testsuite/tests/typing-extensions/open_types.ml.reference

@@ -93,4 +93,15 @@ Here is an example of a case that is not matched:
 Matching over values of extensible variant types (the *extension* above)
 must include a wild card pattern in order to be exhaustive.
 val f : foo list -> int = <fun>
+#           type t = ..
+type t += IPair : (int * int) -> t
+#   Characters 9-63:
+  let f = function IPair (i, j) -> Format.sprintf "(%d, %d)" i j ;; (* warn *)
+          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+*extension*
+Matching over values of extensible variant types (the *extension* above)
+must include a wild card pattern in order to be exhaustive.
+val f : t -> string = <fun>
 # 

typing/parmatch.ml

@@ -173,7 +173,7 @@ let rec pretty_val ppf v =
     | [] ->
   match v.pat_desc with
   | Tpat_any -> fprintf ppf "_"
-  | Tpat_var (x,_) -> Ident.print ppf x
+  | Tpat_var (x,_) -> fprintf ppf "%s" (Ident.name x)
   | Tpat_constant c -> fprintf ppf "%s" (pretty_const c)
   | Tpat_tuple vs ->
       fprintf ppf "@[(%a)@]" (pretty_vals ",") vs
@@ -781,10 +781,10 @@ let build_other_constant proj make first next p env =
 *)
 
 let build_other ext env = match env with
-| ({pat_desc = Tpat_construct (lid,
-      ({cstr_tag=Cstr_extension _} as c),_)},_) :: _ ->
-    let c = {c with cstr_name = "*extension*"} in
-      make_pat (Tpat_construct(lid, c, [])) Ctype.none Env.empty
+| ({pat_desc = Tpat_construct (lid, {cstr_tag=Cstr_extension _},_)},_) :: _ ->
+        (* let c = {c with cstr_name = "*extension*"} in *) (* PR#7330 *)
+        make_pat (Tpat_var (Ident.create "*extension*",
+                            {lid with txt="*extension*"})) Ctype.none Env.empty
 | ({pat_desc = Tpat_construct _} as p,_) :: _ ->
     begin match ext with
     | Some ext when Path.same ext (get_type_path p.pat_type p.pat_env) ->
@@ -1697,6 +1697,8 @@ module Conv = struct
       match pat.pat_desc with
         Tpat_or (pa,pb,_) ->
           mkpat (Ppat_or (loop pa, loop pb))
+      | Tpat_var (_, ({txt="*extension*"} as nm)) -> (* PR#7330 *)
+          mkpat (Ppat_var nm)
       | Tpat_any
       | Tpat_var _ ->
           mkpat Ppat_any
@@ -1743,7 +1745,7 @@ end
 let contains_extension pat =
   let r = ref false in
   let rec loop = function
-      {pat_desc=Tpat_construct(_, {cstr_name="*extension*"}, _)} ->
+      {pat_desc=Tpat_var (_, {txt="*extension*"})} ->
         r := true
     | p -> Typedtree.iter_pattern_desc loop p.pat_desc
   in loop pat; !r
@@ -1778,9 +1780,14 @@ let do_check_partial ?pred exhaust loc casel pss = match pss with
         let v =
           match pred with
           | Some pred ->
-              if false then Some u else
               let (pattern,constrs,labels) = Conv.conv u in
-              pred constrs labels pattern
+              let u' = pred constrs labels pattern in
+              (* pretty_pat u;
+              begin match u' with
+                None -> prerr_endline ": impossible"
+              | Some _ -> prerr_endline ": possible"
+              end; *)
+              u'
           | None -> Some u
         in
         begin match v with

typing/typecore.ml

@@ -1006,8 +1006,10 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env
           ~explode sp expected_ty k
       else k' Tpat_any
   | Ppat_var name ->
-      assert (constrs = None);
-      let id = enter_variable loc name expected_ty in
+      let id = (* PR#7330 *)
+        if name.txt = "*extension*" then Ident.create name.txt else
+        enter_variable loc name expected_ty
+      in
       rp k {
         pat_desc = Tpat_var (id, name);
         pat_loc = loc; pat_extra=[];