X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=ca4f2c5ecd098e9afbd1c105c4faaf1bef78ec94;hp=393f4ff484c73715901ff63eb8431702111ef8d1;hb=HEAD;hpb=a6f2d598e1e7760d334d1b5ea0b7745e66835e11 diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 393f4ff..ca4f2c5 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -7,7 +7,8 @@ TcTyClsDecls: Typecheck type and class declarations \begin{code} module TcTyClsDecls ( - tcTyAndClassDecls, tcFamInstDecl, mkRecSelBinds + tcTyAndClassDecls, kcDataDecl, tcConDecls, mkRecSelBinds, + checkValidTyCon, dataDeclChecks, badFamInstDecl ) where #include "HsVersions.h" @@ -25,17 +26,16 @@ import TcMType import TcType import TysWiredIn ( unitTy ) import Type -import Generics import Class import TyCon import DataCon import Id -import MkId ( mkDefaultMethodId ) import MkCore ( rEC_SEL_ERROR_ID ) import IdInfo import Var import VarSet import Name +import NameEnv import Outputable import Maybes import Unify @@ -60,370 +60,107 @@ import Data.List %* * %************************************************************************ -Dealing with a group -~~~~~~~~~~~~~~~~~~~~ -Consider a mutually-recursive group, binding -a type constructor T and a class C. - -Step 1: getInitialKind - Construct a KindEnv by binding T and C to a kind variable - -Step 2: kcTyClDecl - In that environment, do a kind check - -Step 3: Zonk the kinds - -Step 4: buildTyConOrClass - Construct an environment binding T to a TyCon and C to a Class. - a) Their kinds comes from zonking the relevant kind variable - b) Their arity (for synonyms) comes direct from the decl - c) The funcional dependencies come from the decl - d) The rest comes a knot-tied binding of T and C, returned from Step 4 - e) The variances of the tycons in the group is calculated from - the knot-tied stuff - -Step 5: tcTyClDecl1 - In this environment, walk over the decls, constructing the TyCons and Classes. - This uses in a strict way items (a)-(c) above, which is why they must - be constructed in Step 4. Feed the results back to Step 4. - For this step, pass the is-recursive flag as the wimp-out flag - to tcTyClDecl1. - - -Step 6: Extend environment - We extend the type environment with bindings not only for the TyCons and Classes, - but also for their "implicit Ids" like data constructors and class selectors - -Step 7: checkValidTyCl - For a recursive group only, check all the decls again, just - to check all the side conditions on validity. We could not - do this before because we were in a mutually recursive knot. - -Identification of recursive TyCons -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to -@TyThing@s. - -Identifying a TyCon as recursive serves two purposes - -1. Avoid infinite types. Non-recursive newtypes are treated as -"transparent", like type synonyms, after the type checker. If we did -this for all newtypes, we'd get infinite types. So we figure out for -each newtype whether it is "recursive", and add a coercion if so. In -effect, we are trying to "cut the loops" by identifying a loop-breaker. - -2. Avoid infinite unboxing. This is nothing to do with newtypes. -Suppose we have - data T = MkT Int T - f (MkT x t) = f t -Well, this function diverges, but we don't want the strictness analyser -to diverge. But the strictness analyser will diverge because it looks -deeper and deeper into the structure of T. (I believe there are -examples where the function does something sane, and the strictness -analyser still diverges, but I can't see one now.) - -Now, concerning (1), the FC2 branch currently adds a coercion for ALL -newtypes. I did this as an experiment, to try to expose cases in which -the coercions got in the way of optimisations. If it turns out that we -can indeed always use a coercion, then we don't risk recursive types, -and don't need to figure out what the loop breakers are. - -For newtype *families* though, we will always have a coercion, so they -are always loop breakers! So you can easily adjust the current -algorithm by simply treating all newtype families as loop breakers (and -indeed type families). I think. - \begin{code} -tcTyAndClassDecls :: ModDetails -> [LTyClDecl Name] + +tcTyAndClassDecls :: ModDetails + -> [[LTyClDecl Name]] -- Mutually-recursive groups in dependency order -> TcM (TcGblEnv, -- Input env extended by types and classes -- and their implicit Ids,DataCons - HsValBinds Name, -- Renamed bindings for record selectors - [Id]) -- Default method ids - + HsValBinds Name) -- Renamed bindings for record selectors -- Fails if there are any errors -tcTyAndClassDecls boot_details allDecls +tcTyAndClassDecls boot_details decls_s = checkNoErrs $ -- The code recovers internally, but if anything gave rise to -- an error we'd better stop now, to avoid a cascade - do { -- Omit instances of type families; they are handled together - -- with the *heads* of class instances - ; let decls = filter (not . isFamInstDecl . unLoc) allDecls - - -- First check for cyclic type synonysm or classes - -- See notes with checkCycleErrs - ; checkCycleErrs decls - ; mod <- getModule - ; traceTc "tcTyAndCl" (ppr mod) - ; (syn_tycons, alg_tyclss) <- fixM (\ ~(_rec_syn_tycons, rec_alg_tyclss) -> - do { let { -- Seperate ordinary synonyms from all other type and - -- class declarations and add all associated type - -- declarations from type classes. The latter is - -- required so that the temporary environment for the - -- knot includes all associated family declarations. - ; (syn_decls, alg_decls) = partition (isSynDecl . unLoc) - decls - ; alg_at_decls = concatMap addATs alg_decls - } - -- Extend the global env with the knot-tied results - -- for data types and classes - -- - -- We must populate the environment with the loop-tied - -- T's right away, because the kind checker may "fault - -- in" some type constructors that recursively - -- mention T - ; let gbl_things = mkGlobalThings alg_at_decls rec_alg_tyclss - ; tcExtendRecEnv gbl_things $ do - - -- Kind-check the declarations - { (kc_syn_decls, kc_alg_decls) <- kcTyClDecls syn_decls alg_decls - - ; let { -- Calculate rec-flag - ; calc_rec = calcRecFlags boot_details rec_alg_tyclss - ; tc_decl = addLocM (tcTyClDecl calc_rec) } - - -- Type-check the type synonyms, and extend the envt - ; syn_tycons <- tcSynDecls kc_syn_decls - ; tcExtendGlobalEnv syn_tycons $ do - - -- Type-check the data types and classes - { alg_tyclss <- mapM tc_decl kc_alg_decls - ; return (syn_tycons, concat alg_tyclss) - }}}) - -- Finished with knot-tying now - -- Extend the environment with the finished things - ; tcExtendGlobalEnv (syn_tycons ++ alg_tyclss) $ do - - -- Perform the validity check - { traceTc "ready for validity check" empty - ; mapM_ (addLocM checkValidTyCl) decls + do { let tyclds_s = map (filterOut (isFamInstDecl . unLoc)) decls_s + -- Remove family instance decls altogether + -- They are dealt with by TcInstDcls + + ; tyclss <- fixM $ \ rec_tyclss -> + tcExtendRecEnv (zipRecTyClss tyclds_s rec_tyclss) $ + -- We must populate the environment with the loop-tied + -- T's right away (even before kind checking), because + -- the kind checker may "fault in" some type constructors + -- that recursively mention T + + do { -- Kind-check in dependency order + -- See Note [Kind checking for type and class decls] + kc_decls <- kcTyClDecls tyclds_s + + -- And now build the TyCons/Classes + ; let rec_flags = calcRecFlags boot_details rec_tyclss + ; concatMapM (tcTyClDecl rec_flags) kc_decls } + + ; tcExtendGlobalEnv tyclss $ do + { -- Perform the validity check + -- We can do this now because we are done with the recursive knot + traceTc "ready for validity check" empty + ; mapM_ (addLocM checkValidTyCl) (concat tyclds_s) ; traceTc "done" empty - + -- Add the implicit things; - -- we want them in the environment because + -- we want them in the environment because -- they may be mentioned in interface files -- NB: All associated types and their implicit things will be added a -- second time here. This doesn't matter as the definitions are -- the same. - ; let { implicit_things = concatMap implicitTyThings alg_tyclss - ; rec_sel_binds = mkRecSelBinds alg_tyclss - ; dm_ids = mkDefaultMethodIds alg_tyclss } - ; traceTc "Adding types and classes" $ vcat - [ ppr alg_tyclss - , text "and" <+> ppr implicit_things ] - ; env <- tcExtendGlobalEnv implicit_things getGblEnv - ; return (env, rec_sel_binds, dm_ids) } - } - where - -- Pull associated types out of class declarations, to tie them into the - -- knot above. - -- NB: We put them in the same place in the list as `tcTyClDecl' will - -- eventually put the matching `TyThing's. That's crucial; otherwise, - -- the two argument lists of `mkGlobalThings' don't match up. - addATs decl@(L _ (ClassDecl {tcdATs = ats})) = decl : ats - addATs decl = [decl] - -mkGlobalThings :: [LTyClDecl Name] -- The decls - -> [TyThing] -- Knot-tied, in 1-1 correspondence with the decls - -> [(Name,TyThing)] --- Driven by the Decls, and treating the TyThings lazily --- make a TypeEnv for the new things -mkGlobalThings decls things - = map mk_thing (decls `zipLazy` things) + ; let { implicit_things = concatMap implicitTyThings tyclss + ; rec_sel_binds = mkRecSelBinds [tc | ATyCon tc <- tyclss] + ; dm_ids = mkDefaultMethodIds tyclss } + + ; env <- tcExtendGlobalEnv implicit_things $ + tcExtendGlobalValEnv dm_ids $ + getGblEnv + ; return (env, rec_sel_binds) } } + +zipRecTyClss :: [[LTyClDecl Name]] + -> [TyThing] -- Knot-tied + -> [(Name,TyThing)] +-- Build a name-TyThing mapping for the things bound by decls +-- being careful not to look at the [TyThing] +-- The TyThings in the result list must have a visible ATyCon/AClass, +-- because typechecking types (in, say, tcTyClDecl) looks at this outer constructor +zipRecTyClss decls_s rec_things + = [ get decl | decls <- decls_s, L _ decl <- flattenATs decls ] where - mk_thing (L _ (ClassDecl {tcdLName = L _ name}), ~(AClass cl)) - = (name, AClass cl) - mk_thing (L _ decl, ~(ATyCon tc)) - = (tcdName decl, ATyCon tc) + rec_type_env :: TypeEnv + rec_type_env = mkTypeEnv rec_things + + get :: TyClDecl Name -> (Name, TyThing) + get (ClassDecl {tcdLName = L _ name}) = (name, AClass cl) + where + Just (AClass cl) = lookupTypeEnv rec_type_env name + get decl = (name, ATyCon tc) + where + name = tcdName decl + Just (ATyCon tc) = lookupTypeEnv rec_type_env name \end{code} %************************************************************************ %* * - Type checking family instances + Kind checking %* * %************************************************************************ -Family instances are somewhat of a hybrid. They are processed together with -class instance heads, but can contain data constructors and hence they share a -lot of kinding and type checking code with ordinary algebraic data types (and -GADTs). +Note [Kind checking for type and class decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Kind checking is done thus: -\begin{code} -tcFamInstDecl :: TopLevelFlag -> LTyClDecl Name -> TcM TyThing -tcFamInstDecl top_lvl (L loc decl) - = -- Prime error recovery, set source location - setSrcSpan loc $ - tcAddDeclCtxt decl $ - do { -- type family instances require -XTypeFamilies - -- and can't (currently) be in an hs-boot file - ; type_families <- xoptM Opt_TypeFamilies - ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? - ; checkTc type_families $ badFamInstDecl (tcdLName decl) - ; checkTc (not is_boot) $ badBootFamInstDeclErr - - -- Perform kind and type checking - ; 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" -tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name}) - = kcIdxTyPats decl $ \k_tvs k_typats resKind family -> - do { -- check that the family declaration is for a synonym - checkTc (isFamilyTyCon family) (notFamily family) - ; checkTc (isSynTyCon family) (wrongKindOfFamily family) - - ; -- (1) kind check the right-hand side of the type equation - ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk) - -- ToDo: the ExpKind could be better - - -- we need the exact same number of type parameters as the family - -- declaration - ; let famArity = tyConArity family - ; checkTc (length k_typats == famArity) $ - wrongNumberOfParmsErr famArity - - -- (2) type check type equation - ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars - ; t_typats <- mapM tcHsKindedType k_typats - ; t_rhs <- tcHsKindedType k_rhs - - -- (3) check the well-formedness of the instance - ; checkValidTypeInst t_typats t_rhs - - -- (4) construct representation tycon - ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc - ; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs) - (typeKind t_rhs) - NoParentTyCon (Just (family, t_typats)) - }} - - -- "newtype instance" and "data instance" -tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, - tcdCons = cons}) - = kcIdxTyPats decl $ \k_tvs k_typats resKind fam_tycon -> - do { -- check that the family declaration is for the right kind - checkTc (isFamilyTyCon fam_tycon) (notFamily fam_tycon) - ; checkTc (isAlgTyCon fam_tycon) (wrongKindOfFamily fam_tycon) - - ; -- (1) kind check the data declaration as usual - ; k_decl <- kcDataDecl decl k_tvs - ; let k_ctxt = tcdCtxt k_decl - k_cons = tcdCons k_decl - - -- result kind must be '*' (otherwise, we have too few patterns) - ; checkTc (isLiftedTypeKind resKind) $ tooFewParmsErr (tyConArity fam_tycon) - - -- (2) type check indexed data type declaration - ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars - ; unbox_strict <- doptM Opt_UnboxStrictFields - - -- kind check the type indexes and the context - ; t_typats <- mapM tcHsKindedType k_typats - ; stupid_theta <- tcHsKindedContext k_ctxt - - -- (3) Check that - -- (a) left-hand side contains no type family applications - -- (vanilla synonyms are fine, though, and we checked for - -- foralls earlier) - ; mapM_ checkTyFamFreeness t_typats - - -- Check that we don't use GADT syntax in H98 world - ; gadt_ok <- xoptM Opt_GADTs - ; checkTc (gadt_ok || consUseH98Syntax cons) (badGadtDecl tc_name) - - -- (b) a newtype has exactly one constructor - ; checkTc (new_or_data == DataType || isSingleton k_cons) $ - newtypeConError tc_name (length k_cons) - - -- (4) construct representation tycon - ; 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 - ; data_cons <- tcConDecls unbox_strict ex_ok rep_tycon - (t_tvs, orig_res_ty) k_cons - ; tc_rhs <- - case new_or_data of - DataType -> return (mkDataTyConRhs data_cons) - NewType -> ASSERT( not (null data_cons) ) - mkNewTyConRhs rep_tc_name rep_tycon (head data_cons) - ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive - False h98_syntax NoParentTyCon (Just (fam_tycon, t_typats)) - -- We always assume that indexed types are recursive. Why? - -- (1) Due to their open nature, we can never be sure that a - -- further instance might not introduce a new recursive - -- dependency. (2) They are always valid loop breakers as - -- they involve a coercion. - }) - }} - where - h98_syntax = case cons of -- All constructors have same shape - L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False - _ -> True - -tcFamInstDecl1 d = pprPanic "tcFamInstDecl1" (ppr d) - --- Kind checking of indexed types --- - - --- Kind check type patterns and kind annotate the embedded type variables. --- --- * Here we check that a type instance matches its kind signature, but we do --- not check whether there is a pattern for each type index; the latter --- check is only required for type synonym instances. - -kcIdxTyPats :: TyClDecl Name - -> ([LHsTyVarBndr Name] -> [LHsType Name] -> Kind -> TyCon -> TcM a) - -- ^^kinded tvs ^^kinded ty pats ^^res kind - -> TcM a -kcIdxTyPats decl thing_inside - = kcHsTyVars (tcdTyVars decl) $ \tvs -> - do { let tc_name = tcdLName decl - ; fam_tycon <- tcLookupLocatedTyCon tc_name - ; let { (kinds, resKind) = splitKindFunTys (tyConKind fam_tycon) - ; hs_typats = fromJust $ tcdTyPats decl } - - -- we may not have more parameters than the kind indicates - ; checkTc (length kinds >= length hs_typats) $ - tooManyParmsErr (tcdLName decl) - - -- type functions can have a higher-kinded result - ; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind - ; typats <- zipWithM kcCheckLHsType hs_typats - [ EK kind (EkArg (ppr tc_name) n) - | (kind,n) <- kinds `zip` [1..]] - ; thing_inside tvs typats resultKind fam_tycon - } -\end{code} + 1. Make up a kind variable for each parameter of the *data* type, + and class, decls, and extend the kind environment (which is in + the TcLclEnv) + 2. Dependency-analyse the type *synonyms* (which must be non-recursive), + and kind-check them in dependency order. Extend the kind envt. -%************************************************************************ -%* * - Kind checking -%* * -%************************************************************************ + 3. Kind check the data type and class decls + +Synonyms are treated differently to data type and classes, +because a type synonym can be an unboxed type + type Foo = Int# +and a kind variable can't unify with UnboxedTypeKind +So we infer their kinds in dependency order We need to kind check all types in the mutually recursive group before we know the kind of the type variables. For example: @@ -459,48 +196,52 @@ instances of families altogether in the following. However, we need to include the kinds of associated families into the construction of the initial kind environment. (This is handled by `allDecls'). + \begin{code} -kcTyClDecls :: [LTyClDecl Name] -> [Located (TyClDecl Name)] - -> TcM ([LTyClDecl Name], [Located (TyClDecl Name)]) -kcTyClDecls syn_decls alg_decls - = do { -- First extend the kind env with each data type, class, and - -- indexed type, mapping them to a type variable - let initialKindDecls = concat [allDecls decl | L _ decl <- alg_decls] - ; alg_kinds <- mapM getInitialKind initialKindDecls - ; tcExtendKindEnv alg_kinds $ do - - -- Now kind-check the type synonyms, in dependency order - -- We do these differently to data type and classes, - -- because a type synonym can be an unboxed type - -- type Foo = Int# - -- and a kind variable can't unify with UnboxedTypeKind - -- So we infer their kinds in dependency order - { (kc_syn_decls, syn_kinds) <- kcSynDecls (calcSynCycles syn_decls) - ; tcExtendKindEnv syn_kinds $ do - - -- Now kind-check the data type, class, and kind signatures, - -- returning kind-annotated decls; we don't kind-check - -- instances of indexed types yet, but leave this to - -- `tcInstDecls1' - { kc_alg_decls <- mapM (wrapLocM kcTyClDecl) - (filter (not . isFamInstDecl . unLoc) alg_decls) - - ; return (kc_syn_decls, kc_alg_decls) }}} +kcTyClDecls :: [[LTyClDecl Name]] -> TcM [LTyClDecl Name] +kcTyClDecls [] = return [] +kcTyClDecls (decls : decls_s) = do { (tcl_env, kc_decls1) <- kcTyClDecls1 decls + ; kc_decls2 <- setLclEnv tcl_env (kcTyClDecls decls_s) + ; return (kc_decls1 ++ kc_decls2) } + +kcTyClDecls1 :: [LTyClDecl Name] -> TcM (TcLclEnv, [LTyClDecl Name]) +kcTyClDecls1 decls + = do { -- Omit instances of type families; they are handled together + -- with the *heads* of class instances + ; let (syn_decls, alg_decls) = partition (isSynDecl . unLoc) decls + alg_at_decls = flattenATs alg_decls + + ; mod <- getModule + ; traceTc "tcTyAndCl" (ptext (sLit "module") <+> ppr mod $$ vcat (map ppr decls)) + + -- First check for cyclic classes + ; checkClassCycleErrs alg_decls + + -- Kind checking; see Note [Kind checking for type and class decls] + ; alg_kinds <- mapM getInitialKind alg_at_decls + ; tcExtendKindEnv alg_kinds $ do + + { (kc_syn_decls, tcl_env) <- kcSynDecls (calcSynCycles syn_decls) + ; setLclEnv tcl_env $ do + { kc_alg_decls <- mapM (wrapLocM kcTyClDecl) alg_decls + + -- Kind checking done for this group, so zonk the kind variables + -- See Note [Kind checking for type and class decls] + ; mapM_ (zonkTcKindToKind . snd) alg_kinds + + ; return (tcl_env, kc_syn_decls ++ kc_alg_decls) } } } + +flattenATs :: [LTyClDecl Name] -> [LTyClDecl Name] +flattenATs decls = concatMap flatten decls where - -- get all declarations relevant for determining the initial kind - -- environment - allDecls (decl@ClassDecl {tcdATs = ats}) = decl : [ at - | L _ at <- ats - , isFamilyDecl at] - allDecls decl | isFamInstDecl decl = [] - | otherwise = [decl] + flatten decl@(L _ (ClassDecl {tcdATs = ats})) = decl : ats + flatten decl = [decl] ------------------------------------------------------------------------- -getInitialKind :: TyClDecl Name -> TcM (Name, TcKind) +getInitialKind :: LTyClDecl Name -> TcM (Name, TcKind) -- Only for data type, class, and indexed type declarations -- Get as much info as possible from the data, class, or indexed type decl, -- so as to maximise usefulness of error messages -getInitialKind decl +getInitialKind (L _ decl) = do { arg_kinds <- mapM (mk_arg_kind . unLoc) (tyClDeclTyVars decl) ; res_kind <- mk_res_kind decl ; return (tcdName decl, mkArrowKinds arg_kinds res_kind) } @@ -518,13 +259,13 @@ getInitialKind decl ---------------- kcSynDecls :: [SCC (LTyClDecl Name)] -> TcM ([LTyClDecl Name], -- Kind-annotated decls - [(Name,TcKind)]) -- Kind bindings + TcLclEnv) -- Kind bindings kcSynDecls [] - = return ([], []) + = do { tcl_env <- getLclEnv; return ([], tcl_env) } kcSynDecls (group : groups) - = do { (decl, nk) <- kcSynDecl group - ; (decls, nks) <- tcExtendKindEnv [nk] (kcSynDecls groups) - ; return (decl:decls, nk:nks) } + = do { (decl, nk) <- kcSynDecl group + ; (decls, tcl_env) <- tcExtendKindEnv [nk] (kcSynDecls groups) + ; return (decl:decls, tcl_env) } ---------------- kcSynDecl :: SCC (LTyClDecl Name) @@ -567,6 +308,8 @@ kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats}) where kc_sig (TypeSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty ; return (TypeSig nm op_ty') } + kc_sig (GenericSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty + ; return (GenericSig nm op_ty') } kc_sig other_sig = return other_sig kcTyClDecl decl@(ForeignType {}) @@ -675,31 +418,11 @@ kcFamilyDecl _ d = pprPanic "kcFamilyDecl" (ppr d) %************************************************************************ \begin{code} -tcSynDecls :: [LTyClDecl Name] -> TcM [TyThing] -tcSynDecls [] = return [] -tcSynDecls (decl : decls) - = do { syn_tc <- addLocM tcSynDecl decl - ; syn_tcs <- tcExtendGlobalEnv [syn_tc] (tcSynDecls decls) - ; return (syn_tc : syn_tcs) } +tcTyClDecl :: (Name -> RecFlag) -> LTyClDecl Name -> TcM [TyThing] - -- "type" -tcSynDecl :: TyClDecl Name -> TcM TyThing -tcSynDecl - (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty}) - = tcTyVarBndrs tvs $ \ tvs' -> do - { traceTc "tcd1" (ppr tc_name) - ; rhs_ty' <- tcHsKindedType rhs_ty - ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty') - (typeKind rhs_ty') NoParentTyCon Nothing - ; return (ATyCon tycon) - } -tcSynDecl d = pprPanic "tcSynDecl" (ppr d) - --------------------- -tcTyClDecl :: (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing] - -tcTyClDecl calc_isrec decl - = tcAddDeclCtxt decl (tcTyClDecl1 NoParentTyCon calc_isrec decl) +tcTyClDecl calc_isrec (L loc decl) + = setSrcSpan loc $ tcAddDeclCtxt decl $ + tcTyClDecl1 NoParentTyCon calc_isrec decl -- "type family" declarations tcTyClDecl1 :: TyConParent -> (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing] @@ -733,53 +456,46 @@ tcTyClDecl1 parent _calc_isrec ; checkTc idx_tys $ badFamInstDecl tc_name ; tycon <- buildAlgTyCon tc_name final_tvs [] - DataFamilyTyCon Recursive False True + DataFamilyTyCon Recursive True parent Nothing ; return [ATyCon tycon] } + -- "type" +tcTyClDecl1 _parent _calc_isrec + (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty}) + = ASSERT( isNoParent _parent ) + tcTyVarBndrs tvs $ \ tvs' -> do + { traceTc "tcd1" (ppr tc_name) + ; rhs_ty' <- tcHsKindedType rhs_ty + ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty') + (typeKind rhs_ty') NoParentTyCon Nothing + ; return [ATyCon tycon] } + -- "newtype" and "data" -- NB: not used for newtype/data instances (whether associated or not) -tcTyClDecl1 parent calc_isrec +tcTyClDecl1 _parent calc_isrec (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs, tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons}) - = tcTyVarBndrs tvs $ \ tvs' -> do + = ASSERT( isNoParent _parent ) + tcTyVarBndrs tvs $ \ tvs' -> do { extra_tvs <- tcDataKindSig mb_ksig ; let final_tvs = tvs' ++ extra_tvs ; stupid_theta <- tcHsKindedContext ctxt - ; want_generic <- xoptM Opt_Generics - ; unbox_strict <- doptM Opt_UnboxStrictFields - ; empty_data_decls <- xoptM Opt_EmptyDataDecls ; kind_signatures <- xoptM Opt_KindSignatures ; existential_ok <- xoptM Opt_ExistentialQuantification ; gadt_ok <- xoptM Opt_GADTs ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? ; let ex_ok = existential_ok || gadt_ok -- Data cons can have existential context - -- Check that we don't use GADT syntax in H98 world - ; checkTc (gadt_ok || h98_syntax) (badGadtDecl tc_name) - -- Check that we don't use kind signatures without Glasgow extensions ; checkTc (kind_signatures || isNothing mb_ksig) (badSigTyDecl tc_name) - -- Check that the stupid theta is empty for a GADT-style declaration - ; checkTc (null stupid_theta || h98_syntax) (badStupidTheta tc_name) + ; dataDeclChecks tc_name new_or_data stupid_theta cons - -- Check that a newtype has exactly one constructor - -- Do this before checking for empty data decls, so that - -- we don't suggest -XEmptyDataDecls for newtypes - ; checkTc (new_or_data == DataType || isSingleton cons) - (newtypeConError tc_name (length cons)) - - -- Check that there's at least one condecl, - -- or else we're reading an hs-boot file, or -XEmptyDataDecls - ; checkTc (not (null cons) || empty_data_decls || is_boot) - (emptyConDeclsErr tc_name) - ; tycon <- fixM (\ tycon -> do { let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs) - ; data_cons <- tcConDecls unbox_strict ex_ok - tycon (final_tvs, res_ty) cons + ; data_cons <- tcConDecls ex_ok tycon (final_tvs, res_ty) cons ; tc_rhs <- if null cons && is_boot -- In a hs-boot file, empty cons means then return AbstractTyCon -- "don't know"; hence Abstract @@ -788,8 +504,7 @@ tcTyClDecl1 parent 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) (not h98_syntax) - parent Nothing + (not h98_syntax) NoParentTyCon Nothing }) ; return [ATyCon tycon] } @@ -801,10 +516,11 @@ tcTyClDecl1 _parent calc_isrec (ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs, tcdCtxt = ctxt, tcdMeths = meths, tcdFDs = fundeps, tcdSigs = sigs, tcdATs = ats} ) - = tcTyVarBndrs tvs $ \ tvs' -> do + = ASSERT( isNoParent _parent ) + tcTyVarBndrs tvs $ \ tvs' -> do { ctxt' <- tcHsKindedContext ctxt ; fds' <- mapM (addLocM tc_fundep) fundeps - ; sig_stuff <- tcClassSigs class_name sigs meths + ; (sig_stuff, gen_dm_env) <- tcClassSigs class_name sigs meths ; clas <- fixM $ \ clas -> do { let -- This little knot is just so we can get -- hold of the name of the class TyCon, which we @@ -817,7 +533,18 @@ tcTyClDecl1 _parent calc_isrec ; buildClass False {- Must include unfoldings for selectors -} class_name tvs' ctxt' fds' (concat atss') sig_stuff tc_isrec } - ; return (AClass clas : map ATyCon (classATs clas)) + + ; let gen_dm_ids = [ AnId (mkExportedLocalId gen_dm_name gen_dm_ty) + | (sel_id, GenDefMeth gen_dm_name) <- classOpItems clas + , let gen_dm_tau = expectJust "tcTyClDecl1" $ + lookupNameEnv gen_dm_env (idName sel_id) + , let gen_dm_ty = mkSigmaTy tvs' + [mkClassPred clas (mkTyVarTys tvs')] + gen_dm_tau + ] + class_ats = map ATyCon (classATs clas) + + ; return (AClass clas : gen_dm_ids ++ class_ats ) -- NB: Order is important due to the call to `mkGlobalThings' when -- tying the the type and class declaration type checking knot. } @@ -832,31 +559,53 @@ tcTyClDecl1 _ _ tcTyClDecl1 _ _ d = pprPanic "tcTyClDecl1" (ppr d) +dataDeclChecks :: Name -> NewOrData -> ThetaType -> [LConDecl Name] -> TcM () +dataDeclChecks tc_name new_or_data stupid_theta cons + = do { -- Check that we don't use GADT syntax in H98 world + gadtSyntax_ok <- xoptM Opt_GADTSyntax + ; let h98_syntax = consUseH98Syntax cons + ; checkTc (gadtSyntax_ok || h98_syntax) (badGadtDecl tc_name) + + -- Check that the stupid theta is empty for a GADT-style declaration + ; checkTc (null stupid_theta || h98_syntax) (badStupidTheta tc_name) + + -- Check that a newtype has exactly one constructor + -- Do this before checking for empty data decls, so that + -- we don't suggest -XEmptyDataDecls for newtypes + ; checkTc (new_or_data == DataType || isSingleton cons) + (newtypeConError tc_name (length cons)) + + -- Check that there's at least one condecl, + -- or else we're reading an hs-boot file, or -XEmptyDataDecls + ; empty_data_decls <- xoptM Opt_EmptyDataDecls + ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? + ; checkTc (not (null cons) || empty_data_decls || is_boot) + (emptyConDeclsErr tc_name) } + ----------------------------------- -tcConDecls :: Bool -> Bool -> TyCon -> ([TyVar], Type) +tcConDecls :: Bool -> TyCon -> ([TyVar], Type) -> [LConDecl Name] -> TcM [DataCon] -tcConDecls unbox ex_ok rep_tycon res_tmpl cons - = mapM (addLocM (tcConDecl unbox ex_ok rep_tycon res_tmpl)) cons +tcConDecls ex_ok rep_tycon res_tmpl cons + = mapM (addLocM (tcConDecl ex_ok rep_tycon res_tmpl)) cons -tcConDecl :: Bool -- True <=> -funbox-strict_fields - -> Bool -- True <=> -XExistentialQuantificaton or -XGADTs +tcConDecl :: Bool -- True <=> -XExistentialQuantificaton or -XGADTs -> TyCon -- Representation tycon -> ([TyVar], Type) -- Return type template (with its template tyvars) -> ConDecl Name -> TcM DataCon -tcConDecl unbox_strict existential_ok rep_tycon res_tmpl -- Data types - (ConDecl {con_name =name, con_qvars = tvs, con_cxt = ctxt +tcConDecl existential_ok rep_tycon res_tmpl -- Data types + con@(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 - ; checkTc (existential_ok || (null tvs && null (unLoc ctxt))) + ; checkTc (existential_ok || conRepresentibleWithH98Syntax con) (badExistential name) ; (univ_tvs, ex_tvs, eq_preds, res_ty') <- tcResultType res_tmpl tvs' res_ty ; let tc_datacon is_infix field_lbls btys - = do { (arg_tys, stricts) <- mapAndUnzipM (tcConArg unbox_strict) btys + = do { (arg_tys, stricts) <- mapAndUnzipM tcConArg btys ; buildDataCon (unLoc name) is_infix stricts field_lbls univ_tvs ex_tvs eq_preds ctxt' arg_tys @@ -946,14 +695,26 @@ consUseH98Syntax (L _ (ConDecl { con_res = ResTyGADT _ }) : _) = False consUseH98Syntax _ = True -- All constructors have same shape +conRepresentibleWithH98Syntax :: ConDecl Name -> Bool +conRepresentibleWithH98Syntax + (ConDecl {con_qvars = tvs, con_cxt = ctxt, con_res = ResTyH98 }) + = null tvs && null (unLoc ctxt) +conRepresentibleWithH98Syntax + (ConDecl {con_qvars = tvs, con_cxt = ctxt, con_res = ResTyGADT (L _ t) }) + = null (unLoc ctxt) && f t (map (hsTyVarName . unLoc) tvs) + where -- Each type variable should be used exactly once in the + -- result type, and the result type must just be the type + -- constructor applied to type variables + f (HsAppTy (L _ t1) (L _ (HsTyVar v2))) vs + = (v2 `elem` vs) && f t1 (delete v2 vs) + f (HsTyVar _) [] = True + f _ _ = False + ------------------- -tcConArg :: Bool -- True <=> -funbox-strict_fields - -> LHsType Name - -> TcM (TcType, HsBang) -tcConArg unbox_strict bty +tcConArg :: LHsType Name -> TcM (TcType, HsBang) +tcConArg bty = do { arg_ty <- tcHsBangType bty - ; let bang = getBangStrictness bty - ; let strict_mark = chooseBoxingStrategy unbox_strict arg_ty bang + ; strict_mark <- chooseBoxingStrategy arg_ty (getBangStrictness bty) ; return (arg_ty, strict_mark) } -- We attempt to unbox/unpack a strict field when either: @@ -962,13 +723,19 @@ tcConArg unbox_strict bty -- -- We have turned off unboxing of newtypes because coercions make unboxing -- and reboxing more complicated -chooseBoxingStrategy :: Bool -> TcType -> HsBang -> HsBang -chooseBoxingStrategy unbox_strict_fields arg_ty bang +chooseBoxingStrategy :: TcType -> HsBang -> TcM HsBang +chooseBoxingStrategy arg_ty bang = case bang of - HsNoBang -> HsNoBang - HsUnpack -> can_unbox HsUnpackFailed arg_ty - HsStrict | unbox_strict_fields -> can_unbox HsStrict arg_ty - | otherwise -> HsStrict + HsNoBang -> return HsNoBang + HsStrict -> do { unbox_strict <- doptM Opt_UnboxStrictFields + ; if unbox_strict then return (can_unbox HsStrict arg_ty) + else return HsStrict } + HsUnpack -> do { omit_prags <- doptM Opt_OmitInterfacePragmas + -- Do not respect UNPACK pragmas if OmitInterfacePragmas is on + -- See Trac #5252: unpacking means we must not conceal the + -- representation of the argument type + ; if omit_prags then return HsStrict + else return (can_unbox HsUnpackFailed arg_ty) } HsUnpackFailed -> pprPanic "chooseBoxingStrategy" (ppr arg_ty) -- Source code never has shtes where @@ -1022,8 +789,8 @@ Validity checking is done once the mutually-recursive knot has been tied, so we can look at things freely. \begin{code} -checkCycleErrs :: [LTyClDecl Name] -> TcM () -checkCycleErrs tyclss +checkClassCycleErrs :: [LTyClDecl Name] -> TcM () +checkClassCycleErrs tyclss | null cls_cycles = return () | otherwise @@ -1042,8 +809,11 @@ checkValidTyCl decl ; traceTc "Validity of" (ppr thing) ; case thing of ATyCon tc -> checkValidTyCon tc - AClass cl -> checkValidClass cl - _ -> panic "checkValidTyCl" + AClass cl -> do { checkValidClass cl + ; mapM_ (addLocM checkValidTyCl) (tcdATs decl) } + AnId _ -> return () -- Generic default methods are checked + -- with their parent class + _ -> panic "checkValidTyCl" ; traceTc "Done validity of" (ppr thing) } @@ -1168,14 +938,14 @@ checkNewDataCon con -- One argument ; checkTc (null eq_spec) (newtypePredError con) -- Return type is (T a b c) - ; checkTc (null ex_tvs && null eq_theta && null dict_theta) (newtypeExError con) + ; checkTc (null ex_tvs && null theta) (newtypeExError con) -- No existentials ; checkTc (not (any isBanged (dataConStrictMarks con))) (newtypeStrictError con) -- No strictness } where - (_univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, _res_ty) = dataConFullSig con + (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig con ------------------------------- checkValidClass :: Class -> TcM () @@ -1203,7 +973,7 @@ checkValidClass cls where (tyvars, fundeps, theta, _, _, op_stuff) = classExtraBigSig cls unary = isSingleton tyvars - no_generics = null [() | (_, GenDefMeth) <- op_stuff] + no_generics = null [() | (_, (GenDefMeth _)) <- op_stuff] check_op constrained_class_methods (sel_id, dm) = addErrCtxt (classOpCtxt sel_id tau) $ do @@ -1224,10 +994,10 @@ checkValidClass cls ; checkTc (tyVarsOfType tau `intersectsVarSet` grown_tyvars) (noClassTyVarErr cls sel_id) - -- Check that for a generic method, the type of - -- the method is sufficiently simple - ; checkTc (dm /= GenDefMeth || validGenericMethodType tau) - (badGenericMethodType op_name op_ty) + ; case dm of + GenDefMeth dm_name -> do { dm_id <- tcLookupId dm_name + ; checkValidType (FunSigCtxt op_name) (idType dm_id) } + _ -> return () } where op_name = idName sel_id @@ -1255,7 +1025,7 @@ checkValidClass cls mkDefaultMethodIds :: [TyThing] -> [Id] -- See Note [Default method Ids and Template Haskell] mkDefaultMethodIds things - = [ mkDefaultMethodId sel_id dm_name + = [ mkExportedLocalId dm_name (idType sel_id) | AClass cls <- things , (sel_id, DefMeth dm_name) <- classOpItems cls ] \end{code} @@ -1277,16 +1047,16 @@ 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 +mkRecSelBinds :: [TyCon] -> 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 -mkRecSelBinds ty_things +mkRecSelBinds tycons = ValBindsOut [(NonRecursive, b) | b <- binds] sigs where (sigs, binds) = unzip rec_sels rec_sels = map mkRecSelBind [ (tc,fld) - | ATyCon tc <- ty_things + | tc <- tycons , fld <- tyConFields tc ] mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, LHsBinds Name) @@ -1493,12 +1263,6 @@ genericMultiParamErr clas = ptext (sLit "The multi-parameter class") <+> quotes (ppr clas) <+> ptext (sLit "cannot have generic methods") -badGenericMethodType :: Name -> Kind -> SDoc -badGenericMethodType op op_ty - = hang (ptext (sLit "Generic method type is too complex")) - 2 (vcat [ppr op <+> dcolon <+> ppr op_ty, - ptext (sLit "You can only use type variables, arrows, lists, and tuples")]) - recSynErr :: [LTyClDecl Name] -> TcRn () recSynErr syn_decls = setSrcSpan (getLoc (head sorted_decls)) $ @@ -1536,7 +1300,7 @@ badGadtDecl tc_name badExistential :: Located Name -> SDoc badExistential con_name = hang (ptext (sLit "Data constructor") <+> quotes (ppr con_name) <+> - ptext (sLit "has existential type variables, or a context")) + ptext (sLit "has existential type variables, a context, or a specialised result type")) 2 (parens $ ptext (sLit "Use -XExistentialQuantification or -XGADTs to allow this")) badStupidTheta :: Name -> SDoc @@ -1580,39 +1344,6 @@ badFamInstDecl tc_name quotes (ppr tc_name) , nest 2 (parens $ ptext (sLit "Use -XTypeFamilies to allow indexed type families")) ] -tooManyParmsErr :: Located Name -> SDoc -tooManyParmsErr tc_name - = ptext (sLit "Family instance has too many parameters:") <+> - quotes (ppr tc_name) - -tooFewParmsErr :: Arity -> SDoc -tooFewParmsErr arity - = ptext (sLit "Family instance has too few parameters; expected") <+> - ppr arity - -wrongNumberOfParmsErr :: Arity -> SDoc -wrongNumberOfParmsErr exp_arity - = ptext (sLit "Number of parameters must match family declaration; expected") - <+> ppr exp_arity - -badBootFamInstDeclErr :: SDoc -badBootFamInstDeclErr - = ptext (sLit "Illegal family instance in hs-boot file") - -notFamily :: TyCon -> SDoc -notFamily tycon - = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tycon) - , nest 2 $ parens (ppr tycon <+> ptext (sLit "is not an indexed type family"))] - -wrongKindOfFamily :: TyCon -> SDoc -wrongKindOfFamily family - = ptext (sLit "Wrong category of family instance; declaration was for a") - <+> kindOfFamily - where - kindOfFamily | isSynTyCon family = ptext (sLit "type synonym") - | isAlgTyCon family = ptext (sLit "data type") - | otherwise = pprPanic "wrongKindOfFamily" (ppr family) - emptyConDeclsErr :: Name -> SDoc emptyConDeclsErr tycon = sep [quotes (ppr tycon) <+> ptext (sLit "has no constructors"),