From feb584b7ffd49827ff2b6e716965cfdcd344570e Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Wed, 20 Sep 2006 18:38:35 +0000 Subject: [PATCH] Check that AT instance is in a class Mon Sep 18 19:16:40 EDT 2006 Manuel M T Chakravarty * Check that AT instance is in a class Sat Aug 26 21:49:56 EDT 2006 Manuel M T Chakravarty * Check that AT instance is in a class --- compiler/typecheck/TcInstDcls.lhs | 33 ++++++++++++++++++++++++++++----- compiler/typecheck/TcTyClsDecls.lhs | 8 +++++--- compiler/types/TyCon.lhs | 35 ++++++++++++++++++++++++++--------- 3 files changed, 59 insertions(+), 17 deletions(-) diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 2a51661..e12f234 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -28,9 +28,10 @@ import TcHsType ( kcHsSigType, tcHsKindedType ) import TcUnify ( checkSigTyVars ) import TcSimplify ( tcSimplifySuperClasses ) import Type ( zipOpenTvSubst, substTheta, mkTyConApp, mkTyVarTy, - splitFunTys, TyThing ) + splitFunTys, TyThing(ATyCon) ) import Coercion ( mkSymCoercion ) -import TyCon ( TyCon, newTyConCo, tyConTyVars ) +import TyCon ( TyCon, tyConName, newTyConCo, tyConTyVars, + isAssocTyCon, tyConFamInst_maybe ) import DataCon ( classDataCon, dataConTyCon, dataConInstArgTys ) import Class ( classBigSig ) import Var ( TyVar, Id, idName, idType, tyVarKind ) @@ -38,7 +39,8 @@ import Id ( mkSysLocal ) import UniqSupply ( uniqsFromSupply, splitUniqSupply ) import MkId ( mkDictFunId ) import Name ( Name, getSrcLoc ) -import Maybe ( catMaybes ) +import Maybe ( isNothing, fromJust, catMaybes ) +import Monad ( when ) import SrcLoc ( srcLocSpan, unLoc, noLoc, Located(..), srcSpanStart ) import ListSetOps ( minusList ) import Outputable @@ -147,8 +149,8 @@ tcInstDecls1 tycl_decls inst_decls -- (1) Do the ordinary instance declarations and instances of -- indexed types ; let { idxty_decls = filter (isIdxTyDecl . unLoc) tycl_decls } - ; local_info_tycons <- mappM tcLocalInstDecl1 inst_decls - ; idxty_info_tycons <- mappM tcIdxTyInstDecl idxty_decls + ; local_info_tycons <- mappM tcLocalInstDecl1 inst_decls + ; idxty_info_tycons <- mappM tcIdxTyInstDeclTL idxty_decls ; let { (local_infos, local_tycons) = unzip local_info_tycons @@ -186,6 +188,27 @@ tcInstDecls1 tycl_decls inst_decls generic_inst_info ++ deriv_inst_info ++ local_idxty_info, deriv_binds) }}}}} + where + -- Make sure that toplevel type instance are not for associated types. + -- !!!TODO: Need to perform this check for the InstInfo structures of type + -- functions, too. + tcIdxTyInstDeclTL ldecl@(L loc decl) = + do { (info, tything) <- tcIdxTyInstDecl ldecl + ; setSrcSpan loc $ + when (isAssocFamily tything) $ + addErr $ assocInClassErr (tcdName decl) + ; return (info, tything) + } + isAssocFamily (Just (ATyCon tycon)) = + case tyConFamInst_maybe tycon of + Nothing -> panic "isAssocFamily: no family?!?" + Just (fam, _) -> isAssocTyCon fam + isAssocFamily (Just _ ) = panic "isAssocFamily: no tycon?!?" + isAssocFamily Nothing = False + +assocInClassErr name = + ptext SLIT("Associated type must be inside class instance") <+> + quotes (ppr name) addInsts :: [InstInfo] -> TcM a -> TcM a addInsts infos thing_inside diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 7f6baf8..0934919 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -51,7 +51,7 @@ import TyCon ( TyCon, AlgTyConRhs( AbstractTyCon, OpenDataTyCon, tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon, isOpenTyCon, tyConStupidTheta, synTyConRhs, isSynTyCon, tyConName, - isNewTyCon, tyConKind ) + isNewTyCon, tyConKind, makeTyConAssoc, isAssocTyCon ) import DataCon ( DataCon, dataConUserType, dataConName, dataConFieldLabels, dataConTyCon, dataConAllTyVars, dataConFieldType, dataConResTys ) @@ -620,7 +620,7 @@ tcTyClDecl1 _calc_isrec -- Check that we don't use kind signatures without Glasgow extensions ; checkTc gla_exts $ badSigTyDecl tc_name - ; return [ATyCon (buildSynTyCon tc_name tvs' (OpenSynTyCon kind))] + ; return [ATyCon $ buildSynTyCon tc_name tvs' (OpenSynTyCon kind)] } -- kind signature for an indexed data type @@ -707,7 +707,7 @@ tcTyClDecl1 calc_isrec { ctxt' <- tcHsKindedContext ctxt ; fds' <- mappM (addLocM tc_fundep) fundeps ; atss <- mappM (addLocM (tcTyClDecl1 (const Recursive))) ats - ; let ats' = concat atss + ; let ats' = map makeTyThingAssoc . concat $ atss ; sig_stuff <- tcClassSigs class_name sigs meths ; clas <- fixM (\ clas -> let -- This little knot is just so we can get @@ -726,6 +726,8 @@ tcTyClDecl1 calc_isrec tc_fundep (tvs1, tvs2) = do { tvs1' <- mappM tcLookupTyVar tvs1 ; ; tvs2' <- mappM tcLookupTyVar tvs2 ; ; return (tvs1', tvs2') } + makeTyThingAssoc (ATyCon tycon) = ATyCon (makeTyConAssoc tycon) + makeTyThingAssoc _ = panic "makeTyThingAssoc" tcTyClDecl1 calc_isrec diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index 5ded0a8..40cfa06 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -15,7 +15,8 @@ module TyCon( isFunTyCon, isUnLiftedTyCon, isProductTyCon, isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, - isEnumerationTyCon, isGadtSyntaxTyCon, isOpenTyCon, + isEnumerationTyCon, isGadtSyntaxTyCon, isOpenTyCon, isAssocTyCon, + makeTyConAssoc, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity, isRecursiveTyCon, newTyConRep, newTyConRhs, newTyConCo, isHiBootTyCon, isSuperKindTyCon, @@ -94,11 +95,14 @@ data TyCon tyConName :: Name, tyConKind :: Kind, tyConArity :: Arity, - + tyConTyVars :: [TyVar], -- Scopes over (a) the algTcStupidTheta -- (b) the cached types in -- algTyConRhs.NewTyCon -- But not over the data constructors + + tyConIsAssoc :: Bool, -- for families: declared in a class? + algTcSelIds :: [Id], -- Its record selectors (empty if none) algTcGadtSyntax :: Bool, -- True <=> the data type was declared using GADT syntax @@ -133,13 +137,14 @@ data TyCon } | SynTyCon { - tyConUnique :: Unique, - tyConName :: Name, - tyConKind :: Kind, - tyConArity :: Arity, - - tyConTyVars :: [TyVar], -- Bound tyvars - synTcRhs :: SynTyConRhs -- Expanded type in here + tyConUnique :: Unique, + tyConName :: Name, + tyConKind :: Kind, + tyConArity :: Arity, + + tyConTyVars :: [TyVar], -- Bound tyvars + tyConIsAssoc :: Bool, -- for families: declared in a class? + synTcRhs :: SynTyConRhs -- Expanded type in here } | PrimTyCon { -- Primitive types; cannot be defined in Haskell @@ -399,6 +404,7 @@ mkAlgTyCon name kind tyvars stupid rhs sel_ids parent is_rec gen_info gadt_syn tyConKind = kind, tyConArity = length tyvars, tyConTyVars = tyvars, + tyConIsAssoc = False, algTcStupidTheta = stupid, algTcRhs = rhs, algTcSelIds = sel_ids, @@ -468,6 +474,7 @@ mkSynTyCon name kind tyvars rhs tyConKind = kind, tyConArity = length tyvars, tyConTyVars = tyvars, + tyConIsAssoc = False, synTcRhs = rhs } @@ -573,6 +580,16 @@ isOpenTyCon (AlgTyCon {algTcRhs = OpenDataTyCon }) = True isOpenTyCon (AlgTyCon {algTcRhs = OpenNewTyCon }) = True isOpenTyCon _ = False +isAssocTyCon :: TyCon -> Bool +isAssocTyCon (AlgTyCon { tyConIsAssoc = isAssoc }) = isAssoc +isAssocTyCon (SynTyCon { tyConIsAssoc = isAssoc }) = isAssoc +isAssocTyCon _ = False + +makeTyConAssoc :: TyCon -> TyCon +makeTyConAssoc tc@(AlgTyCon {}) = tc { tyConIsAssoc = True } +makeTyConAssoc tc@(SynTyCon {}) = tc { tyConIsAssoc = True } +makeTyConAssoc tc = pprPanic "makeTyConAssoc" (ppr tc) + isTupleTyCon :: TyCon -> Bool -- The unit tycon didn't used to be classed as a tuple tycon -- but I thought that was silly so I've undone it -- 1.7.10.4