X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=bc20d3d8d9bc90b6245ec89ac8498d2880e0bf9f;hp=738d36f6bd5f72b3dd219586652c9f0b1865efc4;hb=1e50fd4185479a62e02d987bdfcb1c62712859ca;hpb=d436c70d43fb905c63220040168295e473f4b90a

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 738d36f..bc20d3d 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -37,7 +37,6 @@ import VarSet
 import Name
 import Outputable
 import Maybes
-import Monad
 import Unify
 import Util
 import SrcLoc
@@ -49,6 +48,7 @@ import Unique		( mkBuiltinUnique )
 import BasicTypes
 
 import Bag
+import Control.Monad
 import Data.List
 \end{code}
 
@@ -290,7 +290,7 @@ tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name})
        ; checkValidTypeInst t_typats t_rhs
 
          -- (4) construct representation tycon
-       ; rep_tc_name <- newFamInstTyConName tc_name loc
+       ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
        ; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs) 
                        (typeKind t_rhs) (Just (family, t_typats))
        }}
@@ -334,7 +334,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
 	         newtypeConError tc_name (length k_cons)
 
          -- (4) construct representation tycon
-       ; rep_tc_name <- newFamInstTyConName tc_name loc
+       ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
        ; let ex_ok = True	-- Existentials ok for type families!
        ; fixM (\ rep_tycon -> do 
 	     { let orig_res_ty = mkTyConApp fam_tycon t_typats
@@ -1257,12 +1257,19 @@ 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))]
 
-    unit_rhs = L loc $ ExplicitTuple [] Boxed
+	-- 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 = mkLHsTupleExpr []
     msg_lit = HsStringPrim $ mkFastString $ 
               occNameString (getOccName sel_name)