Several TH/quasiquote changes

[ghc-hetmet.git] / compiler / typecheck / TcTyClsDecls.lhs

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 0e59f01..9c3abc5 100644 (file)
--- 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}
 
@@ -249,8 +249,8 @@ tcFamInstDecl (L loc decl)
   =    -- Prime error recovery, set source location
     setSrcSpan loc                             $
     tcAddDeclCtxt decl                         $
-    do { -- type families require -XTypeFamilies and can't be in an
-        -- hs-boot file
+    do { -- type family instances require -XTypeFamilies
+        -- and can't (currently) be in an hs-boot file
        ; type_families <- doptM Opt_TypeFamilies
        ; is_boot  <- tcIsHsBoot          -- Are we compiling an hs-boot file?
        ; checkTc type_families $ badFamInstDecl (tcdLName decl)
@@ -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)