X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=8989d431044eb7b79f968cc574142a0363f05502;hp=f0619d842f598898f7e83413320d47701534b895;hb=1a9245caefb80a3c4c5965aaacdf9a607e792e1c;hpb=b410846772e0ee630b82df31990bf9805b2d1849 diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index f0619d8..8989d43 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -7,13 +7,12 @@ TcTyClsDecls: Typecheck type and class declarations \begin{code} module TcTyClsDecls ( - tcTyAndClassDecls, tcFamInstDecl, mkAuxBinds + tcTyAndClassDecls, tcFamInstDecl, mkRecSelBinds ) where #include "HsVersions.h" import HsSyn -import HsTypes import HscTypes import BuildTyCl import TcUnify @@ -31,15 +30,13 @@ import Class import TyCon import DataCon import Id -import MkId ( rEC_SEL_ERROR_ID ) +import MkId ( rEC_SEL_ERROR_ID, mkDefaultMethodId ) 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} @@ -139,7 +136,9 @@ indeed type families). I think. tcTyAndClassDecls :: ModDetails -> [LTyClDecl Name] -> TcM (TcGblEnv, -- Input env extended by types and classes -- and their implicit Ids,DataCons - HsValBinds Name) -- Renamed bindings for record selectors + HsValBinds Name, -- Renamed bindings for record selectors + [Id]) -- Default method ids + -- Fails if there are any errors tcTyAndClassDecls boot_details allDecls @@ -205,11 +204,12 @@ tcTyAndClassDecls boot_details allDecls -- second time here. This doesn't matter as the definitions are -- the same. ; let { implicit_things = concatMap implicitTyThings alg_tyclss - ; aux_binds = mkAuxBinds alg_tyclss } + ; rec_sel_binds = mkRecSelBinds alg_tyclss + ; dm_ids = mkDefaultMethodIds alg_tyclss } ; traceTc ((text "Adding" <+> ppr alg_tyclss) $$ (text "and" <+> ppr implicit_things)) ; env <- tcExtendGlobalEnv implicit_things getGblEnv - ; return (env, aux_binds) } + ; return (env, rec_sel_binds, dm_ids) } } where -- Pull associated types out of class declarations, to tie them into the @@ -247,13 +247,13 @@ lot of kinding and type checking code with ordinary algebraic data types (and GADTs). \begin{code} -tcFamInstDecl :: LTyClDecl Name -> TcM TyThing -tcFamInstDecl (L loc decl) +tcFamInstDecl :: TopLevelFlag -> LTyClDecl Name -> TcM TyThing +tcFamInstDecl top_lvl (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) @@ -263,8 +263,26 @@ tcFamInstDecl (L loc decl) ; tc <- tcFamInstDecl1 decl ; checkValidTyCon tc -- Remember to check validity; -- no recursion to worry about here + + -- Check that toplevel type instances are not for associated types. + ; when (isTopLevel top_lvl && isAssocFamily tc) + (addErr $ assocInClassErr (tcdName decl)) + ; return (ATyCon tc) } +isAssocFamily :: TyCon -> Bool -- Is an assocaited type +isAssocFamily tycon + = case tyConFamInst_maybe tycon of + Nothing -> panic "isAssocFamily: no family?!?" + Just (fam, _) -> isTyConAssoc fam + +assocInClassErr :: Name -> SDoc +assocInClassErr name + = ptext (sLit "Associated type") <+> quotes (ppr name) <+> + ptext (sLit "must be inside a class instance") + + + tcFamInstDecl1 :: TyClDecl Name -> TcM TyCon -- "type instance" @@ -293,7 +311,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 +355,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 +502,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 +534,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 +542,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 +583,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 +606,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 +615,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 +652,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 +711,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 +729,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] @@ -770,7 +784,7 @@ tcTyClDecl1 calc_isrec NewType -> ASSERT( not (null data_cons) ) mkNewTyConRhs tc_name tycon (head data_cons) ; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs is_rec - (want_generic && canDoGenerics data_cons) h98_syntax Nothing + (want_generic && canDoGenerics data_cons) (not h98_syntax) Nothing }) ; return [ATyCon tycon] } @@ -829,7 +843,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 @@ -931,11 +946,12 @@ consUseH98Syntax _ = True ------------------- tcConArg :: Bool -- True <=> -funbox-strict_fields -> LHsType Name - -> TcM (TcType, StrictnessMark) + -> TcM (TcType, HsBang) tcConArg unbox_strict bty = do { arg_ty <- tcHsBangType bty ; let bang = getBangStrictness bty - ; return (arg_ty, chooseBoxingStrategy unbox_strict arg_ty bang) } + ; let 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,27 +959,47 @@ 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 -> HsBang chooseBoxingStrategy unbox_strict_fields arg_ty bang = case bang of - HsNoBang -> NotMarkedStrict - HsStrict | unbox_strict_fields - && can_unbox arg_ty -> MarkedUnboxed - HsUnbox | can_unbox arg_ty -> MarkedUnboxed - _ -> MarkedStrict + HsNoBang -> HsNoBang + HsUnpack -> can_unbox HsUnpackFailed arg_ty + HsStrict | unbox_strict_fields -> can_unbox HsStrict arg_ty + | otherwise -> HsStrict + HsUnpackFailed -> pprPanic "chooseBoxingStrategy" (ppr arg_ty) + -- Source code never has shtes where - -- we can unbox if the type is a chain of newtypes with a product tycon - -- at the end - can_unbox arg_ty = case splitTyConApp_maybe arg_ty of - Nothing -> False - Just (arg_tycon, tycon_args) -> - not (isRecursiveTyCon arg_tycon) && -- Note [Recusive unboxing] - isProductTyCon arg_tycon && - (if isNewTyCon arg_tycon then - can_unbox (newTyConInstRhs arg_tycon tycon_args) - else True) + can_unbox :: HsBang -> TcType -> HsBang + -- Returns HsUnpack if we can unpack arg_ty + -- fail_bang if we know what arg_ty is but we can't unpack it + -- HsStrict if it's abstract, so we don't know whether or not we can unbox it + can_unbox fail_bang arg_ty + = case splitTyConApp_maybe arg_ty of + Nothing -> fail_bang + + Just (arg_tycon, tycon_args) + | isAbstractTyCon arg_tycon -> HsStrict + -- See Note [Don't complain about UNPACK on abstract TyCons] + | not (isRecursiveTyCon arg_tycon) -- Note [Recusive unboxing] + , isProductTyCon arg_tycon + -- We can unbox if the type is a chain of newtypes + -- with a product tycon at the end + -> if isNewTyCon arg_tycon + then can_unbox fail_bang (newTyConInstRhs arg_tycon tycon_args) + else HsUnpack + + | otherwise -> fail_bang \end{code} +Note [Don't complain about UNPACK on abstract TyCons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We are going to complain about UnpackFailed, but if we say + data T = MkT {-# UNPACK #-} !Wobble +and Wobble is a newtype imported from a module that was compiled +without optimisation, we don't want to complain. Because it might +be fine when optimsation is on. I think this happens when Haddock +is working over (say) GHC souce files. + Note [Recursive unboxing] ~~~~~~~~~~~~~~~~~~~~~~~~~ Be careful not to try to unbox this! @@ -1111,9 +1147,15 @@ checkValidDataCon tc con -- Reason: it's really the argument of an equality constraint ; checkValidType ctxt (dataConUserType con) ; when (isNewTyCon tc) (checkNewDataCon con) + ; mapM_ check_bang (dataConStrictMarks con `zip` [1..]) } where ctxt = ConArgCtxt (dataConName con) + check_bang (HsUnpackFailed, n) = addWarnTc (cant_unbox_msg n) + check_bang _ = return () + + cant_unbox_msg n = sep [ ptext (sLit "Ignoring unusable UNPACK pragma on the") + , speakNth n <+> ptext (sLit "argument of") <+> quotes (ppr con)] ------------------------------- checkNewDataCon :: DataCon -> TcM () @@ -1125,7 +1167,7 @@ checkNewDataCon con -- Return type is (T a b c) ; checkTc (null ex_tvs && null eq_theta && null dict_theta) (newtypeExError con) -- No existentials - ; checkTc (not (any isMarkedStrict (dataConStrictMarks con))) + ; checkTc (not (any isBanged (dataConStrictMarks con))) (newtypeStrictError con) -- No strictness } @@ -1207,11 +1249,36 @@ checkValidClass cls %************************************************************************ \begin{code} -mkAuxBinds :: [TyThing] -> HsValBinds Name +mkDefaultMethodIds :: [TyThing] -> [Id] +-- See Note [Default method Ids and Template Haskell] +mkDefaultMethodIds things + = [ mkDefaultMethodId sel_id dm_name + | AClass cls <- things + , (sel_id, DefMeth dm_name) <- classOpItems cls ] +\end{code} + +Note [Default method Ids and Template Haskell] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (Trac #4169): + class Numeric a where + fromIntegerNum :: a + fromIntegerNum = ... + + ast :: Q [Dec] + ast = [d| instance Numeric Int |] + +When we typecheck 'ast' we have done the first pass over the class decl +(in tcTyClDecls), but we have not yet typechecked the default-method +declarations (becuase they can mention value declarations). So we +must bring the default method Ids into scope first (so they can be seen +when typechecking the [d| .. |] quote, and typecheck them later. + +\begin{code} +mkRecSelBinds :: [TyThing] -> HsValBinds Name -- NB We produce *un-typechecked* bindings, rather like 'deriving' -- This makes life easier, because the later type checking will add -- all necessary type abstractions and applications -mkAuxBinds ty_things +mkRecSelBinds ty_things = ValBindsOut [(NonRecursive, b) | b <- binds] sigs where (sigs, binds) = unzip rec_sels @@ -1263,12 +1330,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 +1571,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") <+>