switch to 'pat -> .' and add P/Texp_unreachablegadt-warnings

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

36 files changed, 111 insertions, 98 deletions

diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml
index 1bdeef8ea7..0683821c27 100644
--- a/bytecomp/matching.ml
+++ b/bytecomp/matching.ml
@@ -2948,6 +2948,7 @@ let check_partial is_mutable is_lazy pat_act_list = function
   | Partial -> Partial
   | Total ->
       if
+        pat_act_list = [] ||  (* allow empty case list *)
         List.exists
           (fun (pats, lam) ->
             is_mutable pats && (is_guarded lam || is_lazy pats))
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index 6b43989130..49f27d8ae7 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -26,6 +26,7 @@ type error =
   | Illegal_letrec_expr
   | Free_super_var
   | Unknown_builtin_primitive of string
+  | Unreachable_reached
 
 exception Error of Location.t * error
 
@@ -956,6 +957,8 @@ and transl_exp0 e =
           cl_env = e.exp_env;
           cl_attributes = [];
          }
+  | Texp_unreachable ->
+      raise (Error (e.exp_loc, Unreachable_reached))
 
 and transl_list expr_list =
   List.map transl_exp expr_list
@@ -971,6 +974,8 @@ and transl_case {c_lhs; c_guard; c_rhs} =
   c_lhs, transl_guard c_guard c_rhs
 
 and transl_cases cases =
+  let cases =
+    List.filter (fun c -> c.c_rhs.exp_desc <> Texp_unreachable) cases in
   List.map transl_case cases
 
 and transl_case_try {c_lhs; c_guard; c_rhs} =
@@ -985,9 +990,14 @@ and transl_case_try {c_lhs; c_guard; c_rhs} =
       c_lhs, transl_guard c_guard c_rhs
 
 and transl_cases_try cases =
+  let cases =
+    List.filter (fun c -> c.c_rhs.exp_desc <> Texp_unreachable) cases in
   List.map transl_case_try cases
 
 and transl_tupled_cases patl_expr_list =
+  let patl_expr_list =
+    List.filter (fun (_,_,e) -> e.exp_desc <> Texp_unreachable)
+      patl_expr_list in
   List.map (fun (patl, guard, expr) -> (patl, transl_guard guard expr))
     patl_expr_list
 
@@ -1241,7 +1251,9 @@ let report_error ppf = function
       fprintf ppf
         "Ancestor names can only be used to select inherited methods"
   | Unknown_builtin_primitive prim_name ->
-    fprintf ppf  "Unknown builtin primitive \"%s\"" prim_name
+      fprintf ppf "Unknown builtin primitive \"%s\"" prim_name
+  | Unreachable_reached ->
+      fprintf ppf "Unreachable expression was reached"
 
 let () =
   Location.register_error_of_exn
diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli
index 75ba9fcf02..a02de11862 100644
--- a/bytecomp/translcore.mli
+++ b/bytecomp/translcore.mli
@@ -32,6 +32,7 @@ type error =
   | Illegal_letrec_expr
   | Free_super_var
   | Unknown_builtin_primitive of string
+  | Unreachable_reached
 
 exception Error of Location.t * error
 
diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml
index 0c7357f34d..276603d846 100644
--- a/parsing/ast_helper.ml
+++ b/parsing/ast_helper.ml
@@ -115,19 +115,13 @@ module Exp = struct
   let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a)
   let open_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_open (a, b, c))
   let extension ?loc ?attrs a = mk ?loc ?attrs (Pexp_extension a)
+  let unreachable ?loc ?attrs () = mk ?loc ?attrs Pexp_unreachable
 
   let case lhs ?guard rhs =
     {
      pc_lhs = lhs;
      pc_guard = guard;
-     pc_rhs = Some rhs;
-    }
-
-  let case_lhs lhs =
-    {
-     pc_lhs = lhs;
-     pc_guard = None;
-     pc_rhs = None;
+     pc_rhs = rhs;
     }
 end
 
diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli
index 1b42a24034..90c5bf9a2e 100644
--- a/parsing/ast_helper.mli
+++ b/parsing/ast_helper.mli
@@ -139,9 +139,9 @@ module Exp:
     val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression
     val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> expression -> expression
     val extension: ?loc:loc -> ?attrs:attrs -> extension -> expression
+    val unreachable: ?loc:loc -> ?attrs:attrs -> unit -> expression
 
     val case: pattern -> ?guard:expression -> expression -> case
-    val case_lhs: pattern -> case
   end
 
 (** Value declarations *)
diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml
index 12298c96c9..05823a7ee8 100644
--- a/parsing/ast_mapper.ml
+++ b/parsing/ast_mapper.ml
@@ -376,6 +376,7 @@ module E = struct
     | Pexp_open (ovf, lid, e) ->
         open_ ~loc ~attrs ovf (map_loc sub lid) (sub.expr sub e)
     | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x)
+    | Pexp_unreachable -> unreachable ~loc ~attrs ()
 end
 
 module P = struct
@@ -600,7 +601,7 @@ let default_mapper =
          {
            pc_lhs = this.pat this pc_lhs;
            pc_guard = map_opt (this.expr this) pc_guard;
-           pc_rhs = map_opt (this.expr this) pc_rhs;
+           pc_rhs = this.expr this pc_rhs;
          }
       );
 
diff --git a/parsing/parser.mly b/parsing/parser.mly
index 3f20e46d2c..2f8d65f84c 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -1490,8 +1490,8 @@ match_case:
       { Exp.case $1 $3 }
   | pattern WHEN seq_expr MINUSGREATER seq_expr
       { Exp.case $1 ~guard:$3 $5 }
-  | pattern MINUSGREATER UNDERSCORE
-      { Exp.case_lhs $1 }
+  | pattern MINUSGREATER DOT
+      { Exp.case $1 (Exp.unreachable ~loc:(rhs_loc 3) ())}
 ;
 fun_def:
     MINUSGREATER seq_expr                       { $2 }
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index d9a4d7cd01..95dbd4f83c 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -320,12 +320,14 @@ and expression_desc =
         *)
   | Pexp_extension of extension
         (* [%id] *)
+  | Pexp_unreachable
+        (* . *)
 
 and case =   (* (P -> E) or (P when E0 -> E) *)
     {
      pc_lhs: pattern;
      pc_guard: expression option;
-     pc_rhs: expression option;
+     pc_rhs: expression;
     }
 
 (* Value descriptions *)
diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml
index def0099718..bf563edb71 100644
--- a/parsing/pprintast.ml
+++ b/parsing/pprintast.ml
@@ -614,6 +614,8 @@ class printer  ()= object(self:'self)
     | Pexp_variant (l,Some eo) ->
         pp f "@[<2>`%s@;%a@]" l  self#simple_expr eo
     | Pexp_extension e -> self#extension f e
+    | Pexp_unreachable ->
+        pp f "."
     | _ -> self#expression1 f x
   method expression1 f x =
     if x.pexp_attributes <> [] then self#expression f x
@@ -1341,15 +1343,9 @@ class printer  ()= object(self:'self)
 
   method case_list f l : unit =
     let aux f {pc_lhs; pc_guard; pc_rhs} =
-      match pc_rhs with
-      | Some pc_rhs ->
-          pp f "@;| @[<2>%a%a@;->@;%a@]"
-            self#pattern pc_lhs
-            (self#option self#expression ~first:"@;when@;") pc_guard
-            self#under_pipe#expression pc_rhs
-      | None ->
-          pp f "@;| @[<2>%a@;-> _@]"
-            self#pattern pc_lhs
+      pp f "@;| @[<2>%a%a@;->@;%a@]"
+        self#pattern pc_lhs (self#option self#expression ~first:"@;when@;")
+        pc_guard self#under_pipe#expression pc_rhs
     in
     self#list aux f l ~sep:""
   method label_x_expression_param f (l,e) =
diff --git a/parsing/printast.ml b/parsing/printast.ml
index 9aa10b6751..8297ac9ef4 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -365,6 +365,8 @@ and expression i ppf x =
   | Pexp_extension (s, arg) ->
       line i ppf "Pexp_extension \"%s\"\n" s.txt;
       payload i ppf arg
+  | Pexp_unreachable ->
+      line i ppf "Pexp_unreachable"
 
 and value_description i ppf x =
   line i ppf "value_description %a %a\n" fmt_string_loc
@@ -842,7 +844,7 @@ and case i ppf {pc_lhs; pc_guard; pc_rhs} =
   | None -> ()
   | Some g -> line (i+1) ppf "<when>\n"; expression (i + 2) ppf g
   end;
-  option (i+1) expression ppf pc_rhs;
+  expression (i+1) ppf pc_rhs;
 
 and value_binding i ppf x =
   line i ppf "<def>\n";
diff --git a/testsuite/tests/typing-gadts/omega07.ml b/testsuite/tests/typing-gadts/omega07.ml
index 472cbc9e11..ddd7133cfd 100644
--- a/testsuite/tests/typing-gadts/omega07.ml
+++ b/testsuite/tests/typing-gadts/omega07.ml
@@ -204,7 +204,7 @@ let rec diff : type a b. (a,b) le -> a nat -> b nat -> (a,b) diff =
   | NZ, m, LeZ _ -> Diff (m, PlusZ m)
   | NS x, NS y, LeS q ->
       (match diff q x y with Diff (m, p) -> Diff (m, PlusS p))
-  | _ -> _
+  | _ -> .
 ;;
 
 let rec diff : type a b. (a,b) le -> b nat -> (a,b) diff =
diff --git a/testsuite/tests/typing-gadts/pr5332.ml b/testsuite/tests/typing-gadts/pr5332.ml
index 6473ca6265..862706326f 100644
--- a/testsuite/tests/typing-gadts/pr5332.ml
+++ b/testsuite/tests/typing-gadts/pr5332.ml
@@ -12,7 +12,7 @@ let f : type env a. (env, a) typ -> (env, a) typ -> int = fun ta tb ->
    | Tint, Tint -> 0
    | Tbool, Tbool -> 1
    | Tvar var, tb -> 2
-   | _ -> _   (* error *)
+   | _ -> .   (* error *)
 ;;
 (* let x = f Tint (Tvar Zero) ;; *)
 
diff --git a/testsuite/tests/typing-gadts/pr5332.ml.reference b/testsuite/tests/typing-gadts/pr5332.ml.reference
index 2e943424d9..10656769d1 100644
--- a/testsuite/tests/typing-gadts/pr5332.ml.reference
+++ b/testsuite/tests/typing-gadts/pr5332.ml.reference
@@ -7,7 +7,7 @@
   | Tbool : ('env, bool) typ
   | Tvar : ('env, 'a) var -> ('env, 'a) typ
 #             Characters 162-163:
-     | _ -> _   (* error *)
+     | _ -> .   (* error *)
        ^
 Error: This match case could not be refuted.
        Here is an example of value that would reach it: (Tint, Tvar Zero)
diff --git a/testsuite/tests/typing-gadts/pr6163.ml b/testsuite/tests/typing-gadts/pr6163.ml
index 8258e0819b..dc5bb8c67e 100644
--- a/testsuite/tests/typing-gadts/pr6163.ml
+++ b/testsuite/tests/typing-gadts/pr6163.ml
@@ -11,5 +11,5 @@ let f (Aux x) =
   | Succ (Succ Zero) -> "2"
   | Succ (Succ (Succ Zero)) -> "3"
   | Succ (Succ (Succ (Succ Zero))) -> "4"
-  | _ -> _
+  | _ -> .  (* error *)
 ;;
diff --git a/testsuite/tests/typing-gadts/pr6163.ml.principal.reference b/testsuite/tests/typing-gadts/pr6163.ml.principal.reference
index fd34007b82..c19965bfc6 100644
--- a/testsuite/tests/typing-gadts/pr6163.ml.principal.reference
+++ b/testsuite/tests/typing-gadts/pr6163.ml.principal.reference
@@ -6,7 +6,7 @@
       [ `Succ of [< [< [< [ `Zero ] pre_nat ] pre_nat ] pre_nat ] ] nat -> 
       aux
 #                 Characters 162-163:
-    | _ -> _
+    | _ -> .  (* error *)
       ^
 Error: This match case could not be refuted.
        Here is an example of value that would reach it:
diff --git a/testsuite/tests/typing-gadts/pr6163.ml.reference b/testsuite/tests/typing-gadts/pr6163.ml.reference
index fd34007b82..c19965bfc6 100644
--- a/testsuite/tests/typing-gadts/pr6163.ml.reference
+++ b/testsuite/tests/typing-gadts/pr6163.ml.reference
@@ -6,7 +6,7 @@
       [ `Succ of [< [< [< [ `Zero ] pre_nat ] pre_nat ] pre_nat ] ] nat -> 
       aux
 #                 Characters 162-163:
-    | _ -> _
+    | _ -> .  (* error *)
       ^
 Error: This match case could not be refuted.
        Here is an example of value that would reach it:
diff --git a/testsuite/tests/typing-gadts/test.ml b/testsuite/tests/typing-gadts/test.ml
index 076920baeb..cfd14a2055 100644
--- a/testsuite/tests/typing-gadts/test.ml
+++ b/testsuite/tests/typing-gadts/test.ml
@@ -129,7 +129,7 @@ module PR6437 = struct
   let rec f : type g1 g2. (g1, g2) ctx * g1 var -> g2 var = function
     | Cons g, O -> O
     | Cons g, S n -> S (f (g, n))
-    | _ -> _
+    | _ -> .
   (*| Nil, _ -> (assert false) *)  (* warns, but shouldn't *)
 end;;
 
diff --git a/testsuite/tests/typing-gadts/test.ml.principal.reference b/testsuite/tests/typing-gadts/test.ml.principal.reference
index a2d931d2e6..671f7af1ef 100644
--- a/testsuite/tests/typing-gadts/test.ml.principal.reference
+++ b/testsuite/tests/typing-gadts/test.ml.principal.reference
@@ -71,7 +71,7 @@ module PR6862 :
     let g : int t -> int = function I -> 1 | _ -> 2 (* no warning *)
                                              ^
 Warning 51: this match case is unreachable.
-Consider replacing it with '<pat> -> _'
+Consider replacing it with a refutation case '<pat> -> .'
 module PR6220 :
   sig
     type 'a t = I : int t | F : float t
diff --git a/testsuite/tests/typing-gadts/test.ml.reference b/testsuite/tests/typing-gadts/test.ml.reference
index 096ca071b3..5c0eb39cb0 100644
--- a/testsuite/tests/typing-gadts/test.ml.reference
+++ b/testsuite/tests/typing-gadts/test.ml.reference
@@ -71,7 +71,7 @@ module PR6862 :
     let g : int t -> int = function I -> 1 | _ -> 2 (* no warning *)
                                              ^
 Warning 51: this match case is unreachable.
-Consider replacing it with '<pat> -> _'
+Consider replacing it with a refutation case '<pat> -> .'
 module PR6220 :
   sig
     type 'a t = I : int t | F : float t
diff --git a/testsuite/tests/typing-warnings/exhaustiveness.ml b/testsuite/tests/typing-warnings/exhaustiveness.ml
index 0e3f5cbe20..57aac3f13c 100644
--- a/testsuite/tests/typing-warnings/exhaustiveness.ml
+++ b/testsuite/tests/typing-warnings/exhaustiveness.ml
@@ -82,7 +82,7 @@ let harder : (zero succ, zero succ, zero succ) plus option -> bool =
   function None -> false
 ;;
 let harder : (zero succ, zero succ, zero succ) plus option  -> bool =
-  function None -> false | Some (PlusS _) -> _
+  function None -> false | Some (PlusS _) -> .
 ;;
 let inv_zero : type a b c d. (a,b,c) plus -> (c,d,zero) plus -> bool =
   fun p1 p2 ->
@@ -94,4 +94,4 @@ let inv_zero : type a b c d. (a,b,c) plus -> (c,d,zero) plus -> bool =
 (* Empty match *)
 
 type _ t = Int : int t;;
-let f (x : bool t) = match x with _ -> _;;
+let f (x : bool t) = match x with _ -> . ;;
diff --git a/testsuite/tests/typing-warnings/exhaustiveness.ml.reference b/testsuite/tests/typing-warnings/exhaustiveness.ml.reference
index 890b918012..a8b3f4418f 100644
--- a/testsuite/tests/typing-warnings/exhaustiveness.ml.reference
+++ b/testsuite/tests/typing-warnings/exhaustiveness.ml.reference
@@ -20,7 +20,7 @@ Characters 172-200:
      | _, _, _, _, _, _, _, G, _, _ -> 1
        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Warning 51: this match case is unreachable.
-Consider replacing it with '<pat> -> _'
+Consider replacing it with a refutation case '<pat> -> .'
 val f :
   'a t * 'b t * 'c t * 'd t * 'e t * 'f t * 'g t * v * ('a, 'b, 'c, 'd) u *
   ('e, 'f, 'g, 'g) u -> int = <fun>
@@ -33,19 +33,19 @@ Characters 62-63:
   let f (x : int t) = match x with A -> 1 | _ -> 2;; (* warn *)
                                             ^
 Warning 51: this match case is unreachable.
-Consider replacing it with '<pat> -> _'
+Consider replacing it with a refutation case '<pat> -> .'
 val f : int t -> int = <fun>
 # Characters 53-54:
   let f (x : unit t option) = match x with None -> 1 | _ -> 2 ;; (* warn? *)
                                                        ^
 Warning 51: this match case is unreachable.
-Consider replacing it with '<pat> -> _'
+Consider replacing it with a refutation case '<pat> -> .'
 val f : unit t option -> int = <fun>
 # Characters 53-59:
   let f (x : unit t option) = match x with None -> 1 | Some _ -> 2 ;; (* warn *)
                                                        ^^^^^^
 Warning 51: this match case is unreachable.
-Consider replacing it with '<pat> -> _'
+Consider replacing it with a refutation case '<pat> -> .'
 val f : unit t option -> int = <fun>
 # val f : int t option -> int = <fun>
 # Characters 27-49:
diff --git a/tools/depend.ml b/tools/depend.ml
index c788eb2ec5..b9c84368e7 100644
--- a/tools/depend.ml
+++ b/tools/depend.ml
@@ -201,6 +201,7 @@ let rec add_expr bv exp =
   | Pexp_pack m -> add_module bv m
   | Pexp_open (_ovf, m, e) -> open_module bv m.txt; add_expr bv e
   | Pexp_extension _ -> ()
+  | Pexp_unreachable -> ()
 
 and add_cases bv cases =
   List.iter (add_case bv) cases
@@ -208,7 +209,7 @@ and add_cases bv cases =
 and add_case bv {pc_lhs; pc_guard; pc_rhs} =
   let bv = add_pattern bv pc_lhs in
   add_opt add_expr bv pc_guard;
-  add_opt add_expr bv pc_rhs
+  add_expr bv pc_rhs
 
 and add_bindings recf bv pel =
   let bv' = List.fold_left (fun bv x -> add_pattern bv x.pvb_pat) bv pel in
diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml
index 18e4681e2a..69af5f5bc0 100644
--- a/tools/ocamlprof.ml
+++ b/tools/ocamlprof.ml
@@ -153,15 +153,14 @@ let rec rewrite_patexp_list iflag l =
 and rewrite_cases iflag l =
   List.iter
     (fun pc ->
-      rewrite_exp_opt iflag pc.pc_guard;
-      rewrite_exp_opt iflag pc.pc_rhs)
+      begin match pc.pc_guard with
+      | None -> ()
+      | Some g -> rewrite_exp iflag g
+      end;
+      rewrite_exp iflag pc.pc_rhs
+    )
     l
 
-and rewrite_exp_opt iflag o =
-  match o with
-    None -> ()
-  | Some e -> rewrite_exp iflag e
-
 and rewrite_labelexp_list iflag l =
   rewrite_exp_list iflag (List.map snd l)
 
@@ -188,7 +187,7 @@ and rw_exp iflag sexp =
       rewrite_cases iflag caselist
 
   | Pexp_fun (_, _, p, e) ->
-      let l = [{pc_lhs=p; pc_guard=None; pc_rhs=Some e}] in
+      let l = [{pc_lhs=p; pc_guard=None; pc_rhs=e}] in
       if !instr_fun then
         rewrite_function iflag l
       else
@@ -295,6 +294,7 @@ and rw_exp iflag sexp =
   | Pexp_open (_ovf, _, e) -> rewrite_exp iflag e
   | Pexp_pack (smod) -> rewrite_mod iflag smod
   | Pexp_extension _ -> ()
+  | Pexp_unreachable -> ()
 
 and rewrite_ifbody iflag ghost sifbody =
   if !instr_if && not ghost then
@@ -306,19 +306,17 @@ and rewrite_ifbody iflag ghost sifbody =
 and rewrite_annotate_exp_list l =
   List.iter
     (function
-     | {pc_guard=Some scond; pc_rhs=Some sbody} ->
+     | {pc_guard=Some scond; pc_rhs=sbody} ->
          insert_profile rw_exp scond;
          insert_profile rw_exp sbody;
-     | {pc_rhs=Some {pexp_desc = Pexp_constraint(sbody, _)}}
-         (* let f x : t = e *)
+     | {pc_rhs={pexp_desc = Pexp_constraint(sbody, _)}} (* let f x : t = e *)
         -> insert_profile rw_exp sbody
-     | {pc_rhs=Some sexp} -> insert_profile rw_exp sexp
-     | {pc_rhs=None} -> ())
+     | {pc_rhs=sexp} -> insert_profile rw_exp sexp)
     l
 
 and rewrite_function iflag = function
   | [{pc_lhs=_; pc_guard=None;
-      pc_rhs=Some ({pexp_desc = (Pexp_function _|Pexp_fun _)} as sexp)}] ->
+      pc_rhs={pexp_desc = (Pexp_function _|Pexp_fun _)} as sexp}] ->
         rewrite_exp iflag sexp
   | l -> rewrite_funmatching l
 
diff --git a/typing/parmatch.ml b/typing/parmatch.ml
index f1715923ab..16f51e252c 100644
--- a/typing/parmatch.ml
+++ b/typing/parmatch.ml
@@ -1907,7 +1907,7 @@ let do_check_fragile_gadt = do_check_fragile_param exhaust_gadt
 
 let check_unused pred tdefs casel =
   if Warnings.is_active Warnings.Unused_match
-  || List.exists (fun c -> c.c_rhs = None) casel then
+  || List.exists (fun c -> c.c_rhs.exp_desc = Texp_unreachable) casel then
     let rec do_rec pref = function
       | [] -> ()
       | {c_lhs=q; c_guard; c_rhs} :: rem ->
@@ -1917,7 +1917,7 @@ let check_unused pred tdefs casel =
                   get_mins le_pats (List.filter (compats qs) pref) in
               (* First look for redundant or partially redundant patterns *)
               let r = every_satisfiables (make_rows pss) (make_row qs) in
-              let refute = (c_rhs = None) in
+              let refute = (c_rhs.exp_desc = Texp_unreachable) in
               (* Do not warn for unused _ -> _ *)
               if r = Unused && refute && q.pat_desc = Tpat_any then () else
               let r =
diff --git a/typing/parmatch.mli b/typing/parmatch.mli
index b245724baf..89ab101821 100644
--- a/typing/parmatch.mli
+++ b/typing/parmatch.mli
@@ -62,13 +62,13 @@ val check_partial_gadt:
     ((string, constructor_description) Hashtbl.t ->
      (string, label_description) Hashtbl.t ->
      Parsetree.pattern -> pattern option) ->
-    Location.t -> case_pat list -> partial
+    Location.t -> case list -> partial
 val check_unused:
     (bool ->
      (string, constructor_description) Hashtbl.t ->
      (string, label_description) Hashtbl.t ->
      Parsetree.pattern -> pattern option) ->
-    Env.t -> case_pat list -> unit
+    Env.t -> case list -> unit
 
 (* Irrefutability tests *)
 val irrefutable : pattern -> bool
diff --git a/typing/printtyped.ml b/typing/printtyped.ml
index 8270b6d8a8..ff0de30358 100644
--- a/typing/printtyped.ml
+++ b/typing/printtyped.ml
@@ -377,6 +377,8 @@ and expression i ppf x =
   | Texp_pack me ->
       line i ppf "Texp_pack";
       module_expr i ppf me
+  | Texp_unreachable ->
+      line i ppf "Texp_unreachable"
 
 and value_description i ppf x =
   line i ppf "value_description %a %a\n" fmt_ident x.val_id fmt_location x.val_loc;
diff --git a/typing/tast_mapper.ml b/typing/tast_mapper.ml
index 7c7c774bb5..cddfd3e484 100644
--- a/typing/tast_mapper.ml
+++ b/typing/tast_mapper.ml
@@ -328,6 +328,8 @@ let expr sub x =
         Texp_object (sub.class_structure sub cl, sl)
     | Texp_pack mexpr ->
         Texp_pack (sub.module_expr sub mexpr)
+    | Texp_unreachable ->
+        Texp_unreachable
   in
   {x with exp_extra; exp_desc; exp_env}
 
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index 6beeff6f22..73d4732998 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -957,8 +957,9 @@ and class_expr cl_num val_env met_env scl =
         | _ -> true
       in
       let partial =
+        let dummy = type_exp val_env (Ast_helper.Exp.unreachable ()) in
         Typecore.check_partial val_env pat.pat_type pat.pat_loc
-          [{c_lhs = pat; c_guard = None; c_rhs = None}]
+          [{c_lhs = pat; c_guard = None; c_rhs = dummy}]
       in
       Ctype.raise_nongen_level ();
       let cl = class_expr cl_num val_env' met_env scl' in
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 30e9119344..aa2112c874 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -172,10 +172,11 @@ let iter_expression f e =
     | Pexp_letmodule (_, me, e) -> expr e; module_expr me
     | Pexp_object { pcstr_fields = fs } -> List.iter class_field fs
     | Pexp_pack me -> module_expr me
+    | Pexp_unreachable -> ()
 
   and case {pc_lhs = _; pc_guard; pc_rhs} =
     may expr pc_guard;
-    may expr pc_rhs
+    expr pc_rhs
 
   and binding x =
     expr x.pvb_expr
@@ -245,7 +246,7 @@ let all_idents_cases el =
   List.iter
     (fun cp ->
       may (iter_expression f) cp.pc_guard;
-      may (iter_expression f) cp.pc_rhs
+      iter_expression f cp.pc_rhs
     )
     el;
   Hashtbl.fold (fun x () rest -> x :: rest) idents []
@@ -615,7 +616,7 @@ end) = struct
   open Name
 
   let get_type_path env d =
-    match (get_type d).desc with
+    match (repr (get_type d)).desc with
     | Tconstr(p, _, _) -> p
     | _ -> assert false
 
@@ -1504,7 +1505,7 @@ let rec final_subexpression sexp =
   | Pexp_sequence (_, e)
   | Pexp_try (e, _)
   | Pexp_ifthenelse (_, e, _)
-  | Pexp_match (_, {pc_rhs=Some e} :: _)
+  | Pexp_match (_, {pc_rhs=e} :: _)
     -> final_subexpression e
   | _ -> sexp
 
@@ -1631,9 +1632,9 @@ let rec type_approx env sexp =
   | Pexp_fun (p, _, _, e) ->
       let ty = if is_optional p then type_option (newvar ()) else newvar () in
       newty (Tarrow(p, ty, type_approx env e, Cok))
-  | Pexp_function ({pc_rhs=Some e}::_) ->
+  | Pexp_function ({pc_rhs=e}::_) ->
       newty (Tarrow(Nolabel, newvar (), type_approx env e, Cok))
-  | Pexp_match (_, {pc_rhs=Some e}::_) -> type_approx env e
+  | Pexp_match (_, {pc_rhs=e}::_) -> type_approx env e
   | Pexp_try (e, _) -> type_approx env e
   | Pexp_tuple l -> newty (Ttuple(List.map (type_approx env) l))
   | Pexp_ifthenelse (_,e,_) -> type_approx env e
@@ -2838,6 +2839,13 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
   | Pexp_extension ext ->
       raise (Error_forward (Typetexp.error_of_extension ext))
 
+  | Pexp_unreachable ->
+      re { exp_desc = Texp_unreachable;
+           exp_loc = loc; exp_extra = [];
+           exp_type = instance env ty_expected;
+           exp_attributes = sexp.pexp_attributes;
+           exp_env = env }
+
 and type_function ?in_function loc attrs env ty_expected l caselist =
   let (loc_fun, ty_fun) =
     match in_function with Some p -> p
@@ -3620,9 +3628,10 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
     List.map
       (fun {pc_lhs; pc_guard; pc_rhs} ->
         let loc =
-          match pc_rhs with
-          | None -> pc_lhs.ppat_loc
-          | Some e -> e.pexp_loc
+          let open Location in
+          match pc_guard with
+          | None -> pc_rhs.pexp_loc
+          | Some g -> {pc_rhs.pexp_loc with loc_start=g.pexp_loc.loc_start}
         in
         if !Clflags.principal then begin_def (); (* propagation of pattern *)
         let scope = Some (Annot.Idef loc) in
@@ -3664,10 +3673,6 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
   let cases =
     List.map2
       (fun (pat, (ext_env, unpacks)) {pc_lhs; pc_guard; pc_rhs} ->
-        match pc_guard, pc_rhs with
-        | None, None -> { c_lhs = pat; c_guard = None; c_rhs = None}
-        | Some _, None -> assert false
-        | _, Some pc_rhs ->
         let sexp = wrap_unpacks pc_rhs unpacks in
         let ty_res' =
           if !Clflags.principal then begin
@@ -3692,14 +3697,14 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
         {
          c_lhs = pat;
          c_guard = guard;
-         c_rhs = Some {exp with exp_type = instance env ty_res'}
+         c_rhs = {exp with exp_type = instance env ty_res'}
         }
       )
       pat_env_list caselist
   in
   if !Clflags.principal || has_gadts then begin
     let ty_res' = instance env ty_res in
-    List.iter (fun c -> may (fun e -> unify_exp env e ty_res') c.c_rhs) cases
+    List.iter (fun c -> unify_exp env c.c_rhs ty_res') cases
   end;
   let partial =
     if partial_flag then
@@ -3720,11 +3725,6 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
     (* Ensure that existential types do not escape *)
     unify_exp_types loc env (instance env ty_res) (newvar ()) ;
   end;
-  let cases = Misc.filter_map
-      (function {c_rhs=None} -> None
-        | {c_lhs;c_guard;c_rhs=Some c_rhs} -> Some{c_lhs;c_guard;c_rhs}) cases
-  in
-  if cases = [] then [], Partial else
   cases, partial
 
 (* Typing of let bindings *)
@@ -3893,10 +3893,10 @@ and type_let ?(check = fun s -> Warnings.Unused_var s)
   && Warnings.is_active Warnings.Unused_rec_flag then
     Location.prerr_warning (List.hd spat_sexp_list).pvb_pat.ppat_loc
       Warnings.Unused_rec_flag;
-  List.iter
-    (fun pat ->
-      ignore(check_partial env pat.pat_type pat.pat_loc [case pat None]))
-    pat_list;
+  List.iter2
+    (fun pat exp ->
+      ignore(check_partial env pat.pat_type pat.pat_loc [case pat exp]))
+    pat_list exp_list;
   end_def();
   List.iter2
     (fun pat exp ->
diff --git a/typing/typecore.mli b/typing/typecore.mli
index d6aa126d10..e842f8ff66 100644
--- a/typing/typecore.mli
+++ b/typing/typecore.mli
@@ -43,7 +43,7 @@ val type_self_pattern:
         Env.t * Env.t * Env.t
 val check_partial:
         ?lev:int -> Env.t -> type_expr ->
-	Location.t -> Typedtree.case_pat list -> Typedtree.partial
+	Location.t -> Typedtree.case list -> Typedtree.partial
 val type_expect:
         ?in_function:(Location.t * type_expr) ->
         Env.t -> Parsetree.expression -> type_expr -> Typedtree.expression
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
index 0ba2027545..b57deb4925 100644
--- a/typing/typedtree.ml
+++ b/typing/typedtree.ml
@@ -105,22 +105,19 @@ and expression_desc =
   | Texp_lazy of expression
   | Texp_object of class_structure * string list
   | Texp_pack of module_expr
+  | Texp_unreachable
 
 and meth =
     Tmeth_name of string
   | Tmeth_val of Ident.t
 
-and case = expression case_expr
-
-and 'rhs case_expr =
+and case =
     {
      c_lhs: pattern;
      c_guard: expression option;
-     c_rhs: 'rhs;
+     c_rhs: expression;
     }
 
-and case_pat = expression option case_expr
-
 (* Value expressions for the class language *)
 
 and class_expr =
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index 46d5f4ccdc..9fdcd26058 100644
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -104,22 +104,19 @@ and expression_desc =
   | Texp_lazy of expression
   | Texp_object of class_structure * string list
   | Texp_pack of module_expr
+  | Texp_unreachable
 
 and meth =
     Tmeth_name of string
   | Tmeth_val of Ident.t
 
-and case = expression case_expr
-
-and 'rhs case_expr =
+and case =
     {
      c_lhs: pattern;
      c_guard: expression option;
-     c_rhs: 'rhs;
+     c_rhs: expression;
     }
 
-and case_pat = expression option case_expr
-
 (* Value expressions for the class language *)
 
 and class_expr =
diff --git a/typing/typedtreeIter.ml b/typing/typedtreeIter.ml
index 8de50d711b..574ebef441 100644
--- a/typing/typedtreeIter.ml
+++ b/typing/typedtreeIter.ml
@@ -345,6 +345,8 @@ module MakeIterator(Iter : IteratorArgument) : sig
             iter_class_structure cl
         | Texp_pack (mexpr) ->
             iter_module_expr mexpr
+        | Texp_unreachable ->
+            ()
       end;
       Iter.leave_expression exp;
 
diff --git a/typing/typedtreeMap.ml b/typing/typedtreeMap.ml
index e6c05de591..8431fac05a 100644
--- a/typing/typedtreeMap.ml
+++ b/typing/typedtreeMap.ml
@@ -377,6 +377,8 @@ module MakeMap(Map : MapArgument) = struct
           Texp_object (map_class_structure cl, string_list)
         | Texp_pack (mexpr) ->
           Texp_pack (map_module_expr mexpr)
+        | Texp_unreachable ->
+          Texp_unreachable
     in
     let exp_extra = List.map map_exp_extra exp.exp_extra in
     Map.leave_expression {
diff --git a/typing/untypeast.ml b/typing/untypeast.ml
index 62085d24dd..88c3f8435c 100644
--- a/typing/untypeast.ml
+++ b/typing/untypeast.ml
@@ -329,7 +329,7 @@ let case sub {c_lhs; c_guard; c_rhs} =
   {
    pc_lhs = sub.pat sub c_lhs;
    pc_guard = map_opt (sub.expr sub) c_guard;
-   pc_rhs = Some (sub.expr sub c_rhs);
+   pc_rhs = sub.expr sub c_rhs;
   }
 
 let value_binding sub vb =
@@ -444,6 +444,8 @@ let expression sub exp =
         Pexp_object (sub.class_structure sub cl)
     | Texp_pack (mexpr) ->
         Pexp_pack (sub.module_expr sub mexpr)
+    | Texp_unreachable ->
+        Pexp_unreachable
   in
   List.fold_right (exp_extra sub) exp.exp_extra
     (Exp.mk ~loc ~attrs desc)
diff --git a/utils/warnings.ml b/utils/warnings.ml
index 6ecdf382c9..44d5d2785c 100644
--- a/utils/warnings.ml
+++ b/utils/warnings.ml
@@ -392,7 +392,7 @@ let message = function
       Printf.sprintf "expected tailcall"
   | Unreachable_case ->
       "this match case is unreachable.\n\
-       Consider replacing it with '<pat> -> _'"
+       Consider replacing it with a refutation case '<pat> -> .'"
 ;;
 
 let nerrors = ref 0;;