X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=bc20d3d8d9bc90b6245ec89ac8498d2880e0bf9f;hb=ee2571bd2a80683d33cf65a01942bc8be50a5e33;hp=f0619d842f598898f7e83413320d47701534b895;hpb=b410846772e0ee630b82df31990bf9805b2d1849;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index f0619d8..bc20d3d 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -13,7 +13,6 @@ module TcTyClsDecls (
 #include "HsVersions.h"
 
 import HsSyn
-import HsTypes
 import HscTypes
 import BuildTyCl
 import TcUnify
@@ -36,10 +35,8 @@ import IdInfo
 import Var
 import VarSet
 import Name
-import OccName
 import Outputable
 import Maybes
-import Monad
 import Unify
 import Util
 import SrcLoc
@@ -51,8 +48,8 @@ import Unique		( mkBuiltinUnique )
 import BasicTypes
 
 import Bag
+import Control.Monad
 import Data.List
-import Control.Monad    ( mplus )
 \end{code}
 
 
@@ -293,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))
        }}
@@ -337,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
@@ -590,7 +587,8 @@ kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})
 	; return (decl {tcdTyVars = tvs, tcdCtxt = ctxt', tcdCons = cons'}) }
   where
     -- doc comments are typechecked to Nothing here
-    kc_con_decl (ConDecl name expl ex_tvs ex_ctxt details res _) 
+    kc_con_decl con_decl@(ConDecl { con_name = name, con_qvars = ex_tvs
+                                  , con_cxt = ex_ctxt, con_details = details, con_res = res })
       = addErrCtxt (dataConCtxt name)	$ 
         kcHsTyVars ex_tvs $ \ex_tvs' -> do
         do { ex_ctxt' <- kcHsContext ex_ctxt
@@ -598,7 +596,8 @@ kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})
            ; res'     <- case res of
                 ResTyH98 -> return ResTyH98
                 ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') }
-           ; return (ConDecl name expl ex_tvs' ex_ctxt' details' res' Nothing) }
+           ; return (con_decl { con_qvars = ex_tvs', con_cxt = ex_ctxt'
+                              , con_details = details', con_res = res' }) }
 
     kc_con_details (PrefixCon btys) 
 	= do { btys' <- mapM kc_larg_ty btys 
@@ -691,9 +690,6 @@ tcTyClDecl1 _calc_isrec
   ; idx_tys <- doptM Opt_TypeFamilies
   ; checkTc idx_tys $ badFamInstDecl tc_name
 
-        -- Check for no type indices
-  ; checkTc (not (null tvs)) (noIndexTypes tc_name)
-
   ; tycon <- buildSynTyCon tc_name tvs' (OpenSynTyCon kind Nothing) kind Nothing
   ; return [ATyCon tycon]
   }
@@ -712,9 +708,6 @@ tcTyClDecl1 _calc_isrec
   ; idx_tys <- doptM Opt_TypeFamilies
   ; checkTc idx_tys $ badFamInstDecl tc_name
 
-        -- Check for no type indices
-  ; checkTc (not (null tvs)) (noIndexTypes tc_name)
-
   ; tycon <- buildAlgTyCon tc_name final_tvs [] 
 	       mkOpenDataTyConRhs Recursive False True Nothing
   ; return [ATyCon tycon]
@@ -829,7 +822,8 @@ tcConDecl :: Bool 		-- True <=> -funbox-strict_fields
 	  -> TcM DataCon
 
 tcConDecl unbox_strict existential_ok rep_tycon res_tmpl 	-- Data types
-	  (ConDecl name _ tvs ctxt details res_ty _)
+	  (ConDecl {con_name =name, con_qvars = tvs, con_cxt = ctxt
+                   , con_details = details, con_res = res_ty })
   = addErrCtxt (dataConCtxt name)	$ 
     tcTyVarBndrs tvs			$ \ tvs' -> do 
     { ctxt' <- tcHsKindedContext ctxt
@@ -1263,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)
 
@@ -1497,11 +1498,6 @@ badSigTyDecl tc_name
 	   quotes (ppr tc_name)
 	 , nest 2 (parens $ ptext (sLit "Use -XKindSignatures to allow kind signatures")) ]
 
-noIndexTypes :: Name -> SDoc
-noIndexTypes tc_name
-  = ptext (sLit "Type family constructor") <+> quotes (ppr tc_name)
-    <+> ptext (sLit "must have at least one type index parameter")
-
 badFamInstDecl :: Outputable a => a -> SDoc
 badFamInstDecl tc_name
   = vcat [ ptext (sLit "Illegal family instance for") <+>