From a1899edb87b3192f192980f392680df05f50f104 Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Wed, 20 Sep 2006 18:41:03 +0000 Subject: [PATCH] Fixed two bugs concerning fanilies Mon Sep 18 19:34:38 EDT 2006 Manuel M T Chakravarty * Fixed two bugs concerning fanilies Mon Sep 4 20:59:49 EDT 2006 Manuel M T Chakravarty * Fixed two bugs concerning fanilies --- compiler/iface/LoadIface.lhs | 24 ++++++++++++++++--- compiler/iface/TcIface.lhs | 26 +++++++++++++++++---- compiler/rename/RnSource.lhs | 43 ++++++++++++++++++++++++++--------- compiler/typecheck/TcTyClsDecls.lhs | 6 +++-- 4 files changed, 79 insertions(+), 20 deletions(-) diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index f9e9114..d3dbd0d 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -35,6 +35,8 @@ import HscTypes ( ModIface(..), TyThing, IfaceExport, Usage(..), import BasicTypes ( Version, initialVersion, Fixity(..), FixityDirection(..), isMarkedStrict ) import TcRnMonad +import Type ( TyThing(..) ) +import Class ( classATs ) import PrelNames ( gHC_PRIM ) import PrelInfo ( ghcPrimExports ) @@ -269,6 +271,10 @@ badDepMsg mod -- each binder with the right package info in it -- All subsequent lookups, including crucially lookups during typechecking -- the declaration itself, will find the fully-glorious Name +-- +-- We handle ATs specially. They are not main declarations, but also not +-- implict things (in particular, adding them to `implicitTyThings' would mess +-- things up in the renaming/type checking of source programs). ----------------------------------------------------- addDeclsToPTE :: PackageTypeEnv -> [(Name,TyThing)] -> PackageTypeEnv @@ -292,7 +298,9 @@ loadDecl ignore_prags mod (_version, decl) = do { -- Populate the name cache with final versions of all -- the names associated with the decl main_name <- mk_new_bndr mod Nothing (ifName decl) - ; implicit_names <- mapM (mk_new_bndr mod (Just main_name)) (ifaceDeclSubBndrs decl) + ; implicit_names <- mapM (mk_new_bndr mod (Just main_name)) + (ifaceDeclSubBndrs decl) + ; at_names <- mapM (mk_new_bndr mod Nothing) (atNames decl) -- Typecheck the thing, lazily -- NB. firstly, the laziness is there in case we never need the @@ -304,9 +312,13 @@ loadDecl ignore_prags mod (_version, decl) ; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing] lookup n = case lookupOccEnv mini_env (getOccName n) of Just thing -> thing - Nothing -> pprPanic "loadDecl" (ppr main_name <+> ppr n $$ ppr (stripped_decl) ) + Nothing -> + pprPanic "loadDecl" (ppr main_name <+> + ppr n $$ ppr (stripped_decl)) - ; returnM ((main_name, thing) : [(n, lookup n) | n <- implicit_names]) } + ; returnM $ (main_name, thing) : [(n, lookup n) | n <- implicit_names] + ++ zip at_names (atThings thing) + } -- We build a list from the *known* names, with (lookup n) thunks -- as the TyThings. That way we can extend the PTE without poking the -- thunks @@ -324,6 +336,12 @@ loadDecl ignore_prags mod (_version, decl) (importedSrcLoc (showSDoc (ppr (moduleName mod)))) -- ToDo: qualify with the package name if necessary + atNames (IfaceClass {ifATs = ats}) = [ifName at | at <- ats] + atNames _ = [] + + atThings (AClass cla) = [ATyCon at | at <- classATs cla] + atThings _ = [] + doc = ptext SLIT("Declaration for") <+> ppr (ifName decl) discardDeclPrags :: IfaceDecl -> IfaceDecl diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 2831c2d..6c197cc 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -31,7 +31,7 @@ import Type ( liftedTypeKind, splitTyConApp, mkTyConApp, mkTyVarTys, ThetaType ) import TypeRep ( Type(..), PredType(..) ) import TyCon ( TyCon, tyConName, SynTyConRhs(..), - AlgTyConParent(..) ) + AlgTyConParent(..), setTyConArgPoss ) import HscTypes ( ExternalPackageState(..), TyThing(..), tyThingClass, tyThingTyCon, ModIface(..), ModDetails(..), HomeModInfo(..), @@ -69,6 +69,8 @@ import SrcLoc ( noSrcLoc ) import Util ( zipWithEqual, equalLength, splitAtList ) import DynFlags ( DynFlag(..), isOneShot ) +import List ( elemIndex) +import Maybe ( catMaybes ) import Monad ( liftM ) \end{code} @@ -393,8 +395,9 @@ tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, ; return (ATyCon (buildSynTyCon tc_name tyvars rhs)) } -tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bndrs, - ifFDs = rdr_fds, ifSigs = rdr_sigs, +tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, + ifTyVars = tv_bndrs, ifFDs = rdr_fds, + ifATs = rdr_ats, ifSigs = rdr_sigs, ifRec = tc_isrec }) -- ToDo: in hs-boot files we should really treat abstract classes specially, -- as we do abstract tycons @@ -403,7 +406,9 @@ tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bnd ; ctxt <- tcIfaceCtxt rdr_ctxt ; sigs <- mappM tc_sig rdr_sigs ; fds <- mappM tc_fd rdr_fds - ; cls <- buildClass cls_name tyvars ctxt fds sigs tc_isrec + ; ats' <- mappM tcIfaceDecl rdr_ats + ; let ats = zipWith setTyThingPoss ats' (map ifTyVars rdr_ats) + ; cls <- buildClass cls_name tyvars ctxt fds ats sigs tc_isrec ; return (AClass cls) } where tc_sig (IfaceClassOp occ dm rdr_ty) @@ -420,6 +425,19 @@ tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bnd ; tvs2' <- mappM 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/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 606139b..8f4c1d3 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -506,7 +506,9 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, = ASSERT( isNothing sig ) -- In normal H98 form, kind signature on the -- data type is syntactically illegal bindTyVarsRn data_doc tyvars $ \ tyvars' -> - do { tycon' <- lookupLocatedTopBndrRn tycon + do { tycon' <- if isIdxTyDecl tydecl + then lookupLocatedOccRn tycon -- may be imported family + else lookupLocatedTopBndrRn tycon ; context' <- rnContext data_doc context ; typats' <- rnTyPats data_doc typatsMaybe ; (derivs', deriv_fvs) <- rn_derivs derivs @@ -519,11 +521,17 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, delFVs (map hsLTyVarName tyvars') $ extractHsCtxtTyNames context' `plusFV` plusFVs (map conDeclFVs condecls') `plusFV` - deriv_fvs) } + deriv_fvs `plusFV` + (if isIdxTyDecl tydecl + then unitFV (unLoc tycon') -- type instance => use + else emptyFVs)) + } | otherwise -- GADT = ASSERT( none typatsMaybe ) -- GADTs cannot have type patterns for now - do { tycon' <- lookupLocatedTopBndrRn tycon + do { tycon' <- if isIdxTyDecl tydecl + then lookupLocatedOccRn tycon -- may be imported family + else lookupLocatedTopBndrRn tycon ; checkTc (null (unLoc context)) (badGadtStupidTheta tycon) ; tyvars' <- bindTyVarsRn data_doc tyvars (\ tyvars' -> return tyvars') @@ -537,8 +545,12 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon', tcdTyVars = tyvars', tcdTyPats = Nothing, tcdKindSig = sig, tcdCons = condecls', tcdDerivs = derivs'}, - plusFVs (map conDeclFVs condecls') `plusFV` deriv_fvs) } - + plusFVs (map conDeclFVs condecls') `plusFV` + deriv_fvs `plusFV` + (if isIdxTyDecl tydecl + then unitFV (unLoc tycon') -- type instance => use + else emptyFVs)) + } where is_vanilla = case condecls of -- Yuk [] -> True @@ -561,15 +573,22 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, rnTyClDecl (tydecl@TyFunction {}) = rnTySig tydecl bindTyVarsRn -rnTyClDecl (TySynonym {tcdLName = name, tcdTyVars = tyvars, - tcdTyPats = typatsMaybe, tcdSynRhs = ty}) +rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars, + tcdTyPats = typatsMaybe, tcdSynRhs = ty}) = bindTyVarsRn syn_doc tyvars $ \ tyvars' -> - do { name' <- lookupLocatedTopBndrRn name + do { name' <- if isIdxTyDecl tydecl + then lookupLocatedOccRn name -- may be imported family + else lookupLocatedTopBndrRn name ; typats' <- rnTyPats syn_doc typatsMaybe ; (ty', fvs) <- rnHsTypeFVs syn_doc ty ; returnM (TySynonym {tcdLName = name', tcdTyVars = tyvars', tcdTyPats = typats', tcdSynRhs = ty'}, - delFVs (map hsLTyVarName tyvars') fvs) } + delFVs (map hsLTyVarName tyvars') $ + fvs `plusFV` + (if isIdxTyDecl tydecl + then unitFV (unLoc name') -- type instance => use + else emptyFVs)) + } where syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name) @@ -756,7 +775,8 @@ rnTySig (tydecl@TyData {tcdCtxt = context, tcdLName = tycon, tcdTyPats = Nothing, tcdKindSig = sig, tcdCons = [], tcdDerivs = Nothing}, delFVs (map hsLTyVarName tyvars') $ - extractHsCtxtTyNames context') } } + extractHsCtxtTyNames context') + } } where rnTySig (tydecl@TyFunction {tcdLName = tycon, tcdTyVars = tyvars, @@ -767,7 +787,8 @@ rnTySig (tydecl@TyFunction {tcdLName = tycon, tcdTyVars = tyvars, ; tycon' <- lookupLocatedTopBndrRn tycon ; returnM (TyFunction {tcdLName = tycon', tcdTyVars = tyvars', tcdIso = tcdIso tydecl, tcdKind = sig}, - emptyFVs) } } + emptyFVs) + } } ksig_doc tycon = text "In the kind signature for" <+> quotes (ppr tycon) needOneIdx = text "Kind signature requires at least one type index" diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 278ffe8..95e172c 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -737,6 +737,9 @@ tcTyClDecl1 calc_isrec ; tvs2' <- mappM 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 @@ -746,8 +749,7 @@ tcTyClDecl1 calc_isrec -- There will be no Nothing, as we already passed renaming in ATyCon (setTyConArgPoss tycon poss) - setTyThingPoss _ _ = panic "setTyThingPoss" - + setTyThingPoss _ _ = panic "TcTyClsDecls.setTyThingPoss" tcTyClDecl1 calc_isrec (ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name}) -- 1.7.10.4