X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=049276d4c5a1f9f857de5c90e36a7c82ee4bf34c;hb=5b49434484d86b2dfad682d5eb26ef7f3e2e2b56;hp=0e59f0167bdcc7f05a5ef792c5cc2a0aa81b7a66;hpb=a62da487378d873399d2dedb85fc0d546fa911d8;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 0e59f01..049276d 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -1257,11 +1257,18 @@ mkRecSelBind (tycon, sel_name)
     -- Add catch-all default case unless the case is exhaustive
     -- We do this explicitly so that we get a nice error message that
     -- mentions this particular record selector
-    deflt | length cons_w_field == length all_cons = []
+    deflt | not (any is_unused all_cons) = []
 	  | otherwise = [mkSimpleMatch [nlWildPat] 
 	    	      	    (nlHsApp (nlHsVar (getName rEC_SEL_ERROR_ID))
     	      		    	     (nlHsLit msg_lit))]
 
+	-- Do not add a default case unless there are unmatched
+	-- constructors.  We must take account of GADTs, else we
+	-- get overlap warning messages from the pattern-match checker
+    is_unused con = not (con `elem` cons_w_field 
+			 || dataConCannotMatch inst_tys con)
+    inst_tys = tyConAppArgs data_ty
+
     unit_rhs = L loc $ ExplicitTuple [] Boxed
     msg_lit = HsStringPrim $ mkFastString $ 
               occNameString (getOccName sel_name)