Commit 53569e14 authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.
Browse files

Checking conformance of AT indexes with instance heads

Mon Sep 18 19:18:18 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Checking conformance of AT indexes with instance heads
  Wed Aug 30 20:13:52 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
    * Checking conformance of AT indexes with instance heads
parent b2376468
......@@ -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}
......@@ -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
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment