From 53569e145c8ff8af89303742f261302fdcd98f04 Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Wed, 20 Sep 2006 18:39:37 +0000 Subject: [PATCH] Checking conformance of AT indexes with instance heads Mon Sep 18 19:18:18 EDT 2006 Manuel M T Chakravarty * Checking conformance of AT indexes with instance heads Wed Aug 30 20:13:52 EDT 2006 Manuel M T Chakravarty * Checking conformance of AT indexes with instance heads --- compiler/typecheck/TcInstDcls.lhs | 157 ++++++++++++++++++++++++++++------- compiler/typecheck/TcTyClsDecls.lhs | 23 +++-- compiler/types/TyCon.lhs | 44 ++++++---- 3 files changed, 175 insertions(+), 49 deletions(-) diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 7ee5284..3449766 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -14,9 +14,11 @@ import TcTyClsDecls ( tcIdxTyInstDecl ) import TcClassDcl ( tcMethodBind, mkMethodBind, badMethodErr, badATErr, omittedATWarn, tcClassDecl2, getGenericInstances ) import TcRnMonad -import TcMType ( tcSkolSigType, checkValidInstance, checkValidInstHead ) -import TcType ( mkClassPred, tcSplitSigmaTy, tcSplitDFunHead, - SkolemInfo(InstSkol), tcSplitDFunTy, mkFunTy ) +import TcMType ( tcSkolSigType, checkValidInstance, + checkValidInstHead ) +import TcType ( TcType, mkClassPred, tcSplitSigmaTy, + tcSplitDFunHead, SkolemInfo(InstSkol), + tcSplitDFunTy, mkFunTy ) import Inst ( newDictBndr, newDictBndrs, instToId, showLIE, getOverlapFlag, tcExtendLocalInstEnv ) import InstEnv ( mkLocalInstance, instanceDFunId ) @@ -28,23 +30,28 @@ import TcHsType ( kcHsSigType, tcHsKindedType ) import TcUnify ( checkSigTyVars ) import TcSimplify ( tcSimplifySuperClasses ) import Type ( zipOpenTvSubst, substTheta, mkTyConApp, mkTyVarTy, - splitFunTys, TyThing(ATyCon) ) + splitFunTys, TyThing(ATyCon), isTyVarTy, tcEqType, + substTys, emptyTvSubst, extendTvSubst ) import Coercion ( mkSymCoercion ) import TyCon ( TyCon, tyConName, newTyConCo, tyConTyVars, - isAssocTyCon, tyConFamInst_maybe ) + isTyConAssoc, tyConFamInst_maybe, + assocTyConArgPoss_maybe ) import DataCon ( classDataCon, dataConTyCon, dataConInstArgTys ) -import Class ( classBigSig, classATs ) -import Var ( TyVar, Id, idName, idType, tyVarKind ) +import Class ( Class, classBigSig, classATs ) +import Var ( TyVar, Id, idName, idType, tyVarKind, tyVarName ) +import VarEnv ( rnBndrs2, mkRnEnv2, emptyInScopeSet ) import Id ( mkSysLocal ) import UniqSupply ( uniqsFromSupply, splitUniqSupply ) import MkId ( mkDictFunId ) -import Name ( Name, getSrcLoc ) -import NameSet ( NameSet, addListToNameSet, emptyNameSet, - minusNameSet, nameSetToList ) +import Name ( Name, getSrcLoc, nameOccName ) +import NameSet ( addListToNameSet, emptyNameSet, minusNameSet, + nameSetToList ) import Maybe ( isNothing, fromJust, catMaybes ) import Monad ( when ) +import List ( find ) import DynFlags ( DynFlag(Opt_WarnMissingMethods) ) -import SrcLoc ( srcLocSpan, unLoc, noLoc, Located(..), srcSpanStart ) +import SrcLoc ( srcLocSpan, unLoc, noLoc, Located(..), srcSpanStart, + getLoc) import ListSetOps ( minusList ) import Outputable import Bag @@ -149,8 +156,8 @@ tcInstDecls1 tycl_decls inst_decls -- (they recover, so that we get more than one error each -- round) - -- (1) Do the ordinary instance declarations and instances of - -- indexed types + -- (1) Do class 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 tcIdxTyInstDeclTL idxty_decls @@ -205,13 +212,13 @@ tcInstDecls1 tycl_decls inst_decls isAssocFamily (Just (ATyCon tycon)) = case tyConFamInst_maybe tycon of Nothing -> panic "isAssocFamily: no family?!?" - Just (fam, _) -> isAssocTyCon fam + Just (fam, _) -> isTyConAssoc fam isAssocFamily (Just _ ) = panic "isAssocFamily: no tycon?!?" isAssocFamily Nothing = False assocInClassErr name = - ptext SLIT("Associated type must be inside class instance") <+> - quotes (ppr name) + ptext SLIT("Associated type") <+> quotes (ppr name) <+> + ptext SLIT("must be inside a class instance") addInsts :: [InstInfo] -> TcM a -> TcM a addInsts infos thing_inside @@ -247,7 +254,8 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats)) -- Now, check the validity of the instance. ; (clas, inst_tys) <- checkValidInstHead tau ; checkValidInstance tyvars theta clas inst_tys - ; checkValidOrMissingAT clas + ; checkValidAndMissingATs clas (tyvars, inst_tys) + (zip ats idxty_info_tycons) -- Finally, construct the Core representation of the instance. -- (This no longer includes the associated types.) @@ -264,20 +272,99 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats)) catMaybes idxty_tycons) } where - checkValidOrMissingAT clas - = do { let classDefATs = addListToNameSet emptyNameSet - . map tyConName - . classATs - $ clas - definedATs = addListToNameSet emptyNameSet - . map (tcdName . unLoc) - $ ats - omitted = classDefATs `minusNameSet` definedATs - excess = definedATs `minusNameSet` classDefATs - ; mapM_ (addErrTc . badATErr clas) (nameSetToList excess) + -- We pass in the source form and the type checked form of the ATs. We + -- really need the source form only to be able to produce more informative + -- error messages. + checkValidAndMissingATs :: Class + -> ([TyVar], [TcType]) -- instance types + -> [(LTyClDecl Name, -- source form of AT + (Maybe InstInfo, -- Core form for type + Maybe TyThing))] -- Core form for data + -> TcM () + checkValidAndMissingATs clas inst_tys ats + = do { -- Issue a warning for each class AT that is not defined in this + -- instance. + ; let classDefATs = listToNameSet . map tyConName . classATs $ clas + definedATs = listToNameSet . map (tcdName.unLoc.fst) $ ats + omitted = classDefATs `minusNameSet` definedATs ; warn <- doptM Opt_WarnMissingMethods ; mapM_ (warnTc warn . omittedATWarn) (nameSetToList omitted) + + -- Ensure that all AT indexes that correspond to class parameters + -- coincide with the types in the instance head. All remaining + -- AT arguments must be variables. Also raise an error for any + -- type instances that are not associated with this class. + ; mapM_ (checkIndexes clas inst_tys) ats } + + checkIndexes _ _ (hsAT, (Nothing, Nothing)) = + return () -- skip, we already had an error here + checkIndexes clas inst_tys (hsAT, (Just _ , Nothing )) = + panic "do impl for AT syns" -- !!!TODO: also call checkIndexes' + checkIndexes clas inst_tys (hsAT, (Nothing , Just (ATyCon tycon))) = + checkIndexes' clas inst_tys hsAT + (tyConTyVars tycon, + snd . fromJust . tyConFamInst_maybe $ tycon) + checkIndexes _ _ _ = panic "checkIndexes" + + checkIndexes' clas (instTvs, instTys) hsAT (atTvs, atTys) + = let atName = tcdName . unLoc $ hsAT + in + setSrcSpan (getLoc hsAT) $ + addErrCtxt (atInstCtxt atName) $ + case find ((atName ==) . tyConName) (classATs clas) of + Nothing -> addErrTc $ badATErr clas atName -- not in this class + Just atDecl -> + case assocTyConArgPoss_maybe atDecl of + Nothing -> panic "checkIndexes': AT has no args poss?!?" + Just poss -> + + -- The following is tricky! We need to deal with three + -- complications: (1) The AT possibly only uses a subset of + -- the class parameters as indexes and those it uses may be in + -- a different order; (2) the AT may have extra arguments, + -- which must be type variables; and (3) variables in AT and + -- instance head will be different `Name's even if their + -- source lexemes are identical. + -- + -- Re (1), `poss' contains a permutation vector to extract the + -- class parameters in the right order. + -- + -- Re (2), we wrap the (permuted) class parameters in a Maybe + -- type and use Nothing for any extra AT arguments. (First + -- equation of `checkIndex' below.) + -- + -- Re (3), we replace any type variable in the AT parameters + -- that has the same source lexeme as some variable in the + -- instance types with the instance type variable sharing its + -- source lexeme. + -- + let relevantInstTys = map (instTys !!) poss + instArgs = map Just relevantInstTys ++ + repeat Nothing -- extra arguments + renaming = substSameTyVar atTvs instTvs + in + zipWithM_ checkIndex (substTys renaming atTys) instArgs + + checkIndex ty Nothing + | isTyVarTy ty = return () + | otherwise = addErrTc $ mustBeVarArgErr ty + checkIndex ty (Just instTy) + | ty `tcEqType` instTy = return () + | otherwise = addErrTc $ wrongATArgErr ty instTy + + listToNameSet = addListToNameSet emptyNameSet + + substSameTyVar [] _ = emptyTvSubst + substSameTyVar (tv:tvs) replacingTvs = + let replacement = case find (tv `sameLexeme`) replacingTvs of + Nothing -> mkTyVarTy tv + Just rtv -> mkTyVarTy rtv + -- + tv1 `sameLexeme` tv2 = + nameOccName (tyVarName tv1) == nameOccName (tyVarName tv2) + in + extendTvSubst (substSameTyVar tvs replacingTvs) tv replacement \end{code} @@ -741,4 +828,18 @@ instDeclCtxt2 dfun_ty inst_decl_ctxt doc = ptext SLIT("In the instance declaration for") <+> quotes doc superClassCtxt = ptext SLIT("When checking the super-classes of an instance declaration") + +atInstCtxt name = ptext SLIT("In the associated type instance for") <+> + quotes (ppr name) + +mustBeVarArgErr ty = + sep [ ptext SLIT("Arguments that do not correspond to a class parameter") + , ptext SLIT("must be variables:") <+> ppr ty + ] + +wrongATArgErr ty instTy = + sep [ ptext SLIT("Type indexes must match class instance head") + , ptext SLIT("Found") <+> ppr ty <+> ptext SLIT("but expected") <+> + ppr instTy + ] \end{code} diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 0934919..e83d77f 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -17,7 +17,7 @@ import HsSyn ( TyClDecl(..), HsConDetails(..), HsTyVarBndr(..), hsTyVarName, LHsTyVarBndr, LHsType, HsType(..), mkHsAppTy ) -import HsTypes ( HsBang(..), getBangStrictness ) +import HsTypes ( HsBang(..), getBangStrictness, hsLTyVarNames ) import BasicTypes ( RecFlag(..), StrictnessMark(..) ) import HscTypes ( implicitTyThings, ModDetails ) import BuildTyCl ( buildClass, buildAlgTyCon, buildSynTyCon, buildDataCon, @@ -51,7 +51,7 @@ import TyCon ( TyCon, AlgTyConRhs( AbstractTyCon, OpenDataTyCon, tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon, isOpenTyCon, tyConStupidTheta, synTyConRhs, isSynTyCon, tyConName, - isNewTyCon, tyConKind, makeTyConAssoc, isAssocTyCon ) + isNewTyCon, tyConKind, setTyConArgPoss ) import DataCon ( DataCon, dataConUserType, dataConName, dataConFieldLabels, dataConTyCon, dataConAllTyVars, dataConFieldType, dataConResTys ) @@ -59,11 +59,11 @@ import Var ( TyVar, idType, idName ) import VarSet ( elemVarSet, mkVarSet ) import Name ( Name, getSrcLoc ) import Outputable -import Maybe ( isJust, fromJust, isNothing ) +import Maybe ( isJust, fromJust, isNothing, catMaybes ) import Maybes ( expectJust ) import Unify ( tcMatchTys, tcMatchTyX ) import Util ( zipLazy, isSingleton, notNull, sortLe ) -import List ( partition ) +import List ( partition, elemIndex ) import SrcLoc ( Located(..), unLoc, getLoc, srcLocSpan ) import ListSetOps ( equivClasses, minusList ) import List ( delete ) @@ -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' = map makeTyThingAssoc . concat $ atss + ; let ats' = zipWith setTyThingPoss atss (map (tcdTyVars . unLoc) ats) ; sig_stuff <- tcClassSigs class_name sigs meths ; clas <- fixM (\ clas -> let -- This little knot is just so we can get @@ -726,8 +726,17 @@ 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" + + setTyThingPoss [ATyCon tycon] atTyVars = + let classTyVars = hsLTyVarNames tvs + poss = catMaybes + . map (`elemIndex` classTyVars) + . hsLTyVarNames + $ atTyVars + -- There will be no Nothing, as we already passed renaming + in + ATyCon (setTyConArgPoss tycon poss) + setTyThingPoss _ _ = panic "setTyThingPoss" tcTyClDecl1 calc_isrec diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index 40cfa06..15be3e2 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -15,8 +15,8 @@ module TyCon( isFunTyCon, isUnLiftedTyCon, isProductTyCon, isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, - isEnumerationTyCon, isGadtSyntaxTyCon, isOpenTyCon, isAssocTyCon, - makeTyConAssoc, + isEnumerationTyCon, isGadtSyntaxTyCon, isOpenTyCon, + assocTyConArgPoss_maybe, isTyConAssoc, setTyConArgPoss, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity, isRecursiveTyCon, newTyConRep, newTyConRhs, newTyConCo, isHiBootTyCon, isSuperKindTyCon, @@ -68,6 +68,7 @@ import Class ( Class ) import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed ) import Name ( Name, nameUnique, NamedThing(getName) ) import PrelNames ( Unique, Uniquable(..) ) +import Maybe ( isJust ) import Maybes ( orElse ) import Outputable import FastString @@ -101,7 +102,12 @@ data TyCon -- algTyConRhs.NewTyCon -- But not over the data constructors - tyConIsAssoc :: Bool, -- for families: declared in a class? + tyConArgPoss :: Maybe [Int], -- for associated families: for each + -- tyvar in the AT decl, gives the + -- position of that tyvar in the class + -- argument list (starting from 0). + -- NB: Length is less than tyConArity + -- if higher kind signature. algTcSelIds :: [Id], -- Its record selectors (empty if none) @@ -143,7 +149,14 @@ data TyCon tyConArity :: Arity, tyConTyVars :: [TyVar], -- Bound tyvars - tyConIsAssoc :: Bool, -- for families: declared in a class? + + tyConArgPoss :: Maybe [Int], -- for associated families: for each + -- tyvar in the AT decl, gives the + -- position of that tyvar in the class + -- argument list (starting from 0). + -- NB: Length is less than tyConArity + -- if higher kind signature. + synTcRhs :: SynTyConRhs -- Expanded type in here } @@ -404,7 +417,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, + tyConArgPoss = Nothing, algTcStupidTheta = stupid, algTcRhs = rhs, algTcSelIds = sel_ids, @@ -474,7 +487,7 @@ mkSynTyCon name kind tyvars rhs tyConKind = kind, tyConArity = length tyvars, tyConTyVars = tyvars, - tyConIsAssoc = False, + tyConArgPoss = Nothing, synTcRhs = rhs } @@ -580,15 +593,18 @@ 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 +assocTyConArgPoss_maybe :: TyCon -> Maybe [Int] +assocTyConArgPoss_maybe (AlgTyCon { tyConArgPoss = poss }) = poss +assocTyConArgPoss_maybe (SynTyCon { tyConArgPoss = poss }) = poss +assocTyConArgPoss_maybe _ = Nothing + +isTyConAssoc :: TyCon -> Bool +isTyConAssoc = isJust . assocTyConArgPoss_maybe -makeTyConAssoc :: TyCon -> TyCon -makeTyConAssoc tc@(AlgTyCon {}) = tc { tyConIsAssoc = True } -makeTyConAssoc tc@(SynTyCon {}) = tc { tyConIsAssoc = True } -makeTyConAssoc tc = pprPanic "makeTyConAssoc" (ppr tc) +setTyConArgPoss :: TyCon -> [Int] -> TyCon +setTyConArgPoss tc@(AlgTyCon {}) poss = tc { tyConArgPoss = Just poss } +setTyConArgPoss tc@(SynTyCon {}) poss = tc { tyConArgPoss = Just poss } +setTyConArgPoss tc _ = pprPanic "setTyConArgPoss" (ppr tc) isTupleTyCon :: TyCon -> Bool -- The unit tycon didn't used to be classed as a tuple tycon -- 1.7.10.4