X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=126113168361bd1ab9de8ec9eebfaf2eef7c59d3;hb=60789c09584c8a12fa27289605221942fb05764d;hp=f0619d842f598898f7e83413320d47701534b895;hpb=b410846772e0ee630b82df31990bf9805b2d1849;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index f0619d8..1261131 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} @@ -252,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) @@ -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 @@ -484,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 @@ -516,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)) }) @@ -524,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) @@ -569,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 @@ -590,7 +585,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 +594,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 @@ -634,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) @@ -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 @@ -935,7 +929,8 @@ tcConArg :: Bool -- True <=> -funbox-strict_fields tcConArg unbox_strict bty = do { arg_ty <- tcHsBangType bty ; let bang = getBangStrictness bty - ; return (arg_ty, chooseBoxingStrategy unbox_strict arg_ty bang) } + ; strict_mark <- chooseBoxingStrategy unbox_strict arg_ty bang + ; return (arg_ty, strict_mark) } -- We attempt to unbox/unpack a strict field when either: -- (i) The field is marked '!!', or @@ -943,14 +938,16 @@ tcConArg unbox_strict bty -- -- We have turned off unboxing of newtypes because coercions make unboxing -- and reboxing more complicated -chooseBoxingStrategy :: Bool -> TcType -> HsBang -> StrictnessMark +chooseBoxingStrategy :: Bool -> TcType -> HsBang -> TcM StrictnessMark chooseBoxingStrategy unbox_strict_fields arg_ty bang = case bang of - HsNoBang -> NotMarkedStrict + HsNoBang -> return NotMarkedStrict + HsUnbox | can_unbox arg_ty -> return MarkedUnboxed + | otherwise -> do { addWarnTc cant_unbox_msg + ; return MarkedStrict } HsStrict | unbox_strict_fields - && can_unbox arg_ty -> MarkedUnboxed - HsUnbox | can_unbox arg_ty -> MarkedUnboxed - _ -> MarkedStrict + , can_unbox arg_ty -> return MarkedUnboxed + _ -> return MarkedStrict where -- we can unbox if the type is a chain of newtypes with a product tycon -- at the end @@ -962,6 +959,8 @@ chooseBoxingStrategy unbox_strict_fields arg_ty bang (if isNewTyCon arg_tycon then can_unbox (newTyConInstRhs arg_tycon tycon_args) else True) + + cant_unbox_msg = ptext (sLit "Ignoring unusable UNPACK pragma") \end{code} Note [Recursive unboxing] @@ -1263,12 +1262,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 +1503,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") <+>