From 46934dd87e13143ec2e97f075309a9e2c0945889 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Tue, 30 Dec 2008 16:44:32 +0000 Subject: [PATCH] Avoid nasty name clash with associated data types (fixes Trac #2888) The main bug was in TcHsType; see Note [Avoid name clashes for associated data types]. However I did a bit of re-factoring while I was abouut it. I'm still a but unhappy with the use of TyCon.setTyConArgPoss; it'd be better to construct the TyCon correctly in the first place. But that means passing an extra parameter to tcTyDecl1... maybe we should do this. --- compiler/iface/BuildTyCl.lhs | 9 ++++- compiler/iface/TcIface.lhs | 15 +------- compiler/typecheck/TcHsType.lhs | 24 +++++++++++-- compiler/typecheck/TcInstDcls.lhs | 19 +++++++---- compiler/typecheck/TcTyClsDecls.lhs | 37 +++++++++----------- compiler/types/TyCon.lhs | 64 +++++++++++++++++++---------------- 6 files changed, 95 insertions(+), 73 deletions(-) diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index 6f56d4f..b8c04d3 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -8,7 +8,7 @@ module BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass, mkAbstractTyConRhs, mkOpenDataTyConRhs, - mkNewTyConRhs, mkDataTyConRhs + mkNewTyConRhs, mkDataTyConRhs, setAssocFamilyPermutation ) where #include "HsVersions.h" @@ -175,6 +175,13 @@ mkNewTyConRhs tycon_name tycon con eta_reduce tvs ty = (reverse tvs, ty) +setAssocFamilyPermutation :: [TyVar] -> TyThing -> TyThing +setAssocFamilyPermutation clas_tvs (ATyCon tc) + = ATyCon (setTyConArgPoss clas_tvs tc) +setAssocFamilyPermutation _clas_tvs other + = pprPanic "setAssocFamilyPermutation" (ppr other) + + ------------------------------------------------------ buildDataCon :: Name -> Bool -> [StrictnessMark] diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 7f74cf2..28b0311 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -427,7 +427,7 @@ tcIfaceDecl ignore_prags ; sigs <- mapM tc_sig rdr_sigs ; fds <- mapM tc_fd rdr_fds ; ats' <- mapM (tcIfaceDecl ignore_prags) rdr_ats - ; let ats = zipWith setTyThingPoss ats' (map ifTyVars rdr_ats) + ; let ats = map (setAssocFamilyPermutation tyvars) ats' ; cls <- buildClass ignore_prags cls_name tyvars ctxt fds ats sigs tc_isrec ; return (AClass cls) } where @@ -445,19 +445,6 @@ tcIfaceDecl ignore_prags ; tvs2' <- mapM tcIfaceTyVar tvs2 ; return (tvs1', tvs2') } - -- For each AT argument compute the position of the corresponding class - -- parameter in the class head. This will later serve as a permutation - -- vector when checking the validity of instance declarations. - setTyThingPoss (ATyCon tycon) atTyVars = - let classTyVars = map fst tv_bndrs - poss = catMaybes - . map ((`elemIndex` classTyVars) . fst) - $ atTyVars - -- There will be no Nothing, as we already passed renaming - in - ATyCon (setTyConArgPoss tycon poss) - setTyThingPoss _ _ = panic "TcIface.setTyThingPoss" - tcIfaceDecl _ (IfaceForeign {ifName = rdr_name, ifExtName = ext_name}) = do { name <- lookupIfaceTop rdr_name ; return (ATyCon (mkForeignTyCon name ext_name diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 8ea9b13..e158763 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -677,15 +677,17 @@ tcDataKindSig (Just kind) ; us <- newUniqueSupply ; let uniqs = uniqsFromSupply us ; return [ mk_tv span uniq str kind - | ((kind, str), uniq) <- arg_kinds `zip` names `zip` uniqs ] } + | ((kind, str), uniq) <- arg_kinds `zip` dnames `zip` uniqs ] } where (arg_kinds, res_kind) = splitKindFunTys kind mk_tv loc uniq str kind = mkTyVar name kind where name = mkInternalName uniq occ loc occ = mkOccName tvName str + + dnames = map ('$' :) names -- Note [Avoid name clashes for associated data types] - names :: [String] -- a,b,c...aa,ab,ac etc + names :: [String] names = [ c:cs | cs <- "" : names, c <- ['a'..'z'] ] badKindSig :: Kind -> SDoc @@ -694,6 +696,24 @@ badKindSig kind 2 (ppr kind) \end{code} +Note [Avoid name clashes for associated data types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider class C a b where + data D b :: * -> * +When typechecking the decl for D, we'll invent an extra type variable for D, +to fill out its kind. We *don't* want this type variable to be 'a', because +in an .hi file we'd get + class C a b where + data D b a +which makes it look as if there are *two* type indices. But there aren't! +So we use $a instead, which cannot clash with a user-written type variable. +Remember that type variable binders in interface files are just FastStrings, +not proper Names. + +(The tidying phase can't help here because we don't tidy TyCons. Another +alternative would be to record the number of indexing parameters in the +interface file.) + %************************************************************************ %* * diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 14c96ae..baa7515 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -461,11 +461,11 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) ; mapM_ (checkIndexes clas inst_tys) ats } - checkIndexes clas inst_tys (hsAT, ATyCon tycon) = + checkIndexes clas inst_tys (hsAT, ATyCon tycon) -- !!!TODO: check that this does the Right Thing for indexed synonyms, too! - checkIndexes' clas inst_tys hsAT - (tyConTyVars tycon, - snd . fromJust . tyConFamInst_maybe $ tycon) + = checkIndexes' clas inst_tys hsAT + (tyConTyVars tycon, + snd . fromJust . tyConFamInst_maybe $ tycon) checkIndexes _ _ _ = panic "checkIndexes" checkIndexes' clas (instTvs, instTys) hsAT (atTvs, atTys) @@ -475,8 +475,8 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) 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 + Just atycon -> + case assocTyConArgPoss_maybe atycon of Nothing -> panic "checkIndexes': AT has no args poss?!?" Just poss -> @@ -487,6 +487,13 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) -- 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. + -- + -- e.g. class C a b c where + -- data D b a :: * -> * -- NB (1) b a, omits c + -- instance C [x] Bool Char where + -- data D Bool [x] v = MkD x [v] -- NB (2) v + -- -- NB (3) the x in 'instance C...' have differnt + -- -- Names to x's in 'data D...' -- -- Re (1), `poss' contains a permutation vector to extract the -- class parameters in the right order. diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 69a984d..2d68a6e 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -667,17 +667,18 @@ tcTyClDecl calc_isrec decl tcTyClDecl1 :: (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing] tcTyClDecl1 _calc_isrec (TyFamily {tcdFlavour = TypeFamily, - tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = Just kind}) - -- NB: kind at latest - -- added during - -- kind checking + tcdLName = L _ tc_name, tcdTyVars = tvs, + tcdKind = Just kind}) -- NB: kind at latest added during kind checking = tcTyVarBndrs tvs $ \ tvs' -> do { traceTc (text "type family: " <+> ppr tc_name) - ; idx_tys <- doptM Opt_TypeFamilies -- Check that we don't use families without -XTypeFamilies + ; 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] } @@ -691,11 +692,14 @@ tcTyClDecl1 _calc_isrec ; extra_tvs <- tcDataKindSig mb_kind ; let final_tvs = tvs' ++ extra_tvs -- we may not need these - ; idx_tys <- doptM Opt_TypeFamilies -- Check that we don't use families without -XTypeFamilies + ; 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] @@ -771,7 +775,7 @@ tcTyClDecl1 calc_isrec ; atss <- mapM (addLocM (tcTyClDecl1 (const Recursive))) ats -- NB: 'ats' only contains "type family" and "data family" -- declarations as well as type family defaults - ; let ats' = zipWith setTyThingPoss atss (map (tcdTyVars . unLoc) ats) + ; let ats' = map (setAssocFamilyPermutation tvs') (concat atss) ; sig_stuff <- tcClassSigs class_name sigs meths ; clas <- fixM (\ clas -> let -- This little knot is just so we can get @@ -792,20 +796,6 @@ tcTyClDecl1 calc_isrec ; tvs2' <- mapM tcLookupTyVar tvs2 ; ; return (tvs1', tvs2') } - -- For each AT argument compute the position of the corresponding class - -- parameter in the class head. This will later serve as a permutation - -- vector when checking the validity of instance declarations. - 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 "TcTyClsDecls.setTyThingPoss" - tcTyClDecl1 _ (ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name}) = return [ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0)] @@ -1312,6 +1302,11 @@ 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") <+> diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index 256b141..fdd21be 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -13,6 +13,7 @@ module TyCon( AlgTyConRhs(..), visibleDataCons, TyConParent(..), SynTyConRhs(..), + AssocFamilyPermutation, -- ** Constructing TyCons mkAlgTyCon, @@ -92,6 +93,7 @@ import Maybes import Outputable import FastString import Constants +import Data.List( elemIndex ) \end{code} %************************************************************************ @@ -260,17 +262,7 @@ data AlgTyConRhs -- > data T b :: * | OpenTyCon { - - otArgPoss :: Maybe [Int] - -- ^ @Nothing@ iff this is a top-level indexed type family. - -- @Just ns@ iff this is an associated (not top-level) family - -- - -- In the latter case, for each 'TyVar' in the associated type declaration, - -- @ns@ gives the position of that tyvar in the class argument list (starting - -- from 0). - -- - -- NB: The length of this list is less than the accompanying 'tyConArity' iff - -- we have a higher kind signature. + otArgPoss :: AssocFamilyPermutation } -- | Information about those 'TyCon's derived from a @data@ declaration. This includes @@ -316,6 +308,18 @@ data AlgTyConRhs -- again check Trac #1072. } +type AssocFamilyPermutation + = Maybe [Int] -- Nothing for *top-level* type families + -- For *associated* type families, gives the position + -- of that 'TyVar' in the class argument list (0-indexed) + -- e.g. class C a b c where { type F c a :: *->* } + -- Then we get Just [2,0] + -- For *synonyms*, the length of the list is identical to + -- the TyCon's arity + -- For *data types*, the length may be smaller than the + -- TyCon's arity; e.g. class C a where { data D a :: *->* } + -- here D gets arity 2 + -- | Extract those 'DataCon's that we are able to learn about. Note that visibility in this sense does not -- correspond to visibility in the context of any particular user program! visibleDataCons :: AlgTyConRhs -> [DataCon] @@ -369,16 +373,10 @@ okParent _ (FamilyTyCon fam_tc tys _co_tc) = tyConArity fam_tc == length t -- | Information pertaining to the expansion of a type synonym (@type@) data SynTyConRhs - = OpenSynTyCon Kind - (Maybe [Int]) -- ^ A Type family synonym. The /result/ 'Kind' is - -- given for associated families, and in this case the - -- list of @Int@s is not empty, and for each 'TyVar' in - -- the associated type declaration, it gives the position - -- of that 'TyVar' in the class argument list (starting - -- from 0). - -- - -- NB: The length of this list will be less than 'tyConArity' iff - -- the family has a higher kind signature. + = OpenSynTyCon -- e.g. type family F x y :: * -> * + Kind -- Kind of the "rhs"; ie *excluding type indices* + -- In the example, the kind is (*->*) + AssocFamilyPermutation | SynonymTyCon Type -- ^ The synonym mentions head type variables. It acts as a -- template for the expansion when the 'TyCon' is applied to some @@ -836,14 +834,22 @@ assocTyConArgPoss_maybe _ = Nothing isTyConAssoc :: TyCon -> Bool isTyConAssoc = isJust . assocTyConArgPoss_maybe --- | Sets up a 'TyVar' to family argument-list mapping in the given 'TyCon' if it is --- an open 'TyCon'. Panics otherwise -setTyConArgPoss :: TyCon -> [Int] -> TyCon -setTyConArgPoss tc@(AlgTyCon { algTcRhs = rhs }) poss = - tc { algTcRhs = rhs {otArgPoss = Just poss} } -setTyConArgPoss tc@(SynTyCon { synTcRhs = OpenSynTyCon ki _ }) poss = - tc { synTcRhs = OpenSynTyCon ki (Just poss) } -setTyConArgPoss tc _ = pprPanic "setTyConArgPoss" (ppr tc) +-- | Set the AssocFamilyPermutation structure in an +-- associated data or type synonym. The [TyVar] are the +-- class type variables. Remember, the tyvars of an associated +-- data/type are a subset of the class tyvars; except that an +-- associated data type can have extra type variables at the +-- end (see Note [Avoid name clashes for associated data types] in TcHsType) +setTyConArgPoss :: [TyVar] -> TyCon -> TyCon +setTyConArgPoss clas_tvs tc + = case tc of + AlgTyCon { algTcRhs = rhs } -> tc { algTcRhs = rhs {otArgPoss = Just ps} } + SynTyCon { synTcRhs = OpenSynTyCon ki _ } -> tc { synTcRhs = OpenSynTyCon ki (Just ps) } + _ -> pprPanic "setTyConArgPoss" (ppr tc) + where + ps = catMaybes [tv `elemIndex` clas_tvs | tv <- tyConTyVars tc] + -- We will get Nothings for the "extra" type variables in an + -- associated data type -- 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