X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=229e9971616e74564390abd1cd3b5c0efe3fb54c;hp=738d36f6bd5f72b3dd219586652c9f0b1865efc4;hb=836b1e90821aacc9d1e09fe78085f911597274c8;hpb=d436c70d43fb905c63220040168295e473f4b90a diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 738d36f..229e997 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} @@ -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) @@ -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 @@ -481,7 +481,7 @@ getInitialKind decl ; res_kind <- mk_res_kind decl ; return (tcdName decl, mkArrowKinds arg_kinds res_kind) } where - mk_arg_kind (UserTyVar _) = newKindVar + mk_arg_kind (UserTyVar _ _) = newKindVar mk_arg_kind (KindedTyVar _ kind) = return kind mk_res_kind (TyFamily { tcdKind = Just kind }) = return kind @@ -513,7 +513,7 @@ kcSynDecl (AcyclicSCC (L loc decl)) <+> brackets (ppr k_tvs)) ; (k_rhs, rhs_kind) <- kcLHsType (tcdSynRhs decl) ; traceTc (text "kcd2" <+> ppr (unLoc (tcdLName decl))) - ; let tc_kind = foldr (mkArrowKind . kindedTyVarKind) rhs_kind k_tvs + ; let tc_kind = foldr (mkArrowKind . hsTyVarKind . unLoc) rhs_kind k_tvs ; return (L loc (decl { tcdTyVars = k_tvs, tcdSynRhs = k_rhs }), (unLoc (tcdLName decl), tc_kind)) }) @@ -521,10 +521,6 @@ kcSynDecl (CyclicSCC decls) = do { recSynErr decls; failM } -- Fail here to avoid error cascade -- of out-of-scope tycons -kindedTyVarKind :: LHsTyVarBndr Name -> Kind -kindedTyVarKind (L _ (KindedTyVar _ k)) = k -kindedTyVarKind x = pprPanic "kindedTyVarKind" (ppr x) - ------------------------------------------------------------------------ kcTyClDecl :: TyClDecl Name -> TcM (TyClDecl Name) -- Not used for type synonyms (see kcSynDecl) @@ -566,14 +562,16 @@ kcTyClDeclBody decl thing_inside = tcAddDeclCtxt decl $ do { tc_ty_thing <- tcLookupLocated (tcdLName decl) ; let tc_kind = case tc_ty_thing of - AThing k -> k - _ -> pprPanic "kcTyClDeclBody" (ppr tc_ty_thing) + AThing k -> k + _ -> pprPanic "kcTyClDeclBody" (ppr tc_ty_thing) (kinds, _) = splitKindFunTys tc_kind hs_tvs = tcdTyVars decl kinded_tvs = ASSERT( length kinds >= length hs_tvs ) - [ L loc (KindedTyVar (hsTyVarName tv) k) - | (L loc tv, k) <- zip hs_tvs kinds] - ; tcExtendKindEnvTvs kinded_tvs (thing_inside kinded_tvs) } + zipWith add_kind hs_tvs kinds + ; tcExtendKindEnvTvs kinded_tvs thing_inside } + where + add_kind (L loc (UserTyVar n _)) k = L loc (UserTyVar n k) + add_kind (L loc (KindedTyVar n _)) k = L loc (KindedTyVar n k) -- Kind check a data declaration, assuming that we already extended the -- kind environment with the type variables of the left-hand side (these @@ -633,11 +631,13 @@ kcFamilyDecl classTvs decl@(TyFamily {tcdKind = kind}) -- default result kind is '*' } where - unifyClassParmKinds (L _ (KindedTyVar n k)) - | Just classParmKind <- lookup n classTyKinds = unifyKind k classParmKind - | otherwise = return () - unifyClassParmKinds x = pprPanic "kcFamilyDecl/unifyClassParmKinds" (ppr x) - classTyKinds = [(n, k) | L _ (KindedTyVar n k) <- classTvs] + unifyClassParmKinds (L _ tv) + | (n,k) <- hsTyVarNameKind tv + , Just classParmKind <- lookup n classTyKinds + = unifyKind k classParmKind + | otherwise = return () + classTyKinds = [hsTyVarNameKind tv | L _ tv <- classTvs] + kcFamilyDecl _ (TySynonym {}) -- type family defaults = panic "TcTyClsDecls.kcFamilyDecl: not implemented yet" kcFamilyDecl _ d = pprPanic "kcFamilyDecl" (ppr d) @@ -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)