From f94a8dbd393b518679807a359ca27d0f3418a3a5 Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Wed, 20 Sep 2006 18:35:03 +0000 Subject: [PATCH] Make sure ATs are included into the temporary env for tc knot tying Mon Sep 18 19:03:31 EDT 2006 Manuel M T Chakravarty * Make sure ATs are included into the temporary env for tc knot tying Wed Aug 16 17:52:40 EDT 2006 Manuel M T Chakravarty * Make sure ATs are included into the temporary env for tc knot tying --- compiler/main/HscTypes.lhs | 5 ++-- compiler/typecheck/TcTyClsDecls.lhs | 48 +++++++++++++++++++++++------------ 2 files changed, 34 insertions(+), 19 deletions(-) diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 29e440e..2c8780c 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -82,7 +82,7 @@ import CoreSyn ( CoreBind ) import Id ( Id ) import Type ( TyThing(..) ) -import Class ( Class, classSelIds, classTyCon, classATs ) +import Class ( Class, classSelIds, classTyCon ) import TyCon ( TyCon, tyConSelIds, tyConDataCons, isNewTyCon, newTyConCo ) import DataCon ( dataConImplicitIds ) import PrelNames ( gHC_PRIM ) @@ -633,8 +633,7 @@ implicitTyThings (ATyCon tc) = implicitNewCoTyCon tc ++ -- For classes, add the class TyCon too (and its extras) -- and the class selector Ids implicitTyThings (AClass cl) = map AnId (classSelIds cl) ++ - extras_plus (ATyCon (classTyCon cl)) ++ - map ATyCon (classATs cl) + extras_plus (ATyCon (classTyCon cl)) -- For data cons add the worker and wrapper (if any) diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 9137ece..ccefb00 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -166,22 +166,30 @@ tcTyAndClassDecls boot_details allDecls ; mod <- getModule ; traceTc (text "tcTyAndCl" <+> ppr mod) ; (syn_tycons, alg_tyclss) <- fixM (\ ~(rec_syn_tycons, rec_alg_tyclss) -> - do { let { -- Calculate variances and rec-flag + do { let { -- Seperate ordinary synonyms from all other type and + -- class declarations and add all associated type + -- declarations from type classes. The latter is + -- required so that the temporary environment for the + -- knot includes all associated family declarations. ; (syn_decls, alg_decls) = partition (isSynDecl . unLoc) - decls } + decls + ; alg_at_decls = concatMap addATs alg_decls + } -- Extend the global env with the knot-tied results -- for data types and classes -- - -- We must populate the environment with the loop-tied T's right - -- away, because the kind checker may "fault in" some type - -- constructors that recursively mention T - ; let { gbl_things = mkGlobalThings alg_decls rec_alg_tyclss } + -- We must populate the environment with the loop-tied + -- T's right away, because the kind checker may "fault + -- in" some type constructors that recursively + -- mention T + ; let gbl_things = mkGlobalThings alg_at_decls rec_alg_tyclss ; tcExtendRecEnv gbl_things $ do -- Kind-check the declarations { (kc_syn_decls, kc_alg_decls) <- kcTyClDecls syn_decls alg_decls - ; let { calc_rec = calcRecFlags boot_details rec_alg_tyclss + ; let { -- Calculate rec-flag + ; calc_rec = calcRecFlags boot_details rec_alg_tyclss ; tc_decl = addLocM (tcTyClDecl calc_rec) } -- Type-check the type synonyms, and extend the envt ; syn_tycons <- tcSynDecls kc_syn_decls @@ -189,7 +197,7 @@ tcTyAndClassDecls boot_details allDecls -- Type-check the data types and classes { alg_tyclss <- mappM tc_decl kc_alg_decls - ; return (syn_tycons, alg_tyclss) + ; return (syn_tycons, concat alg_tyclss) }}}) -- Finished with knot-tying now -- Extend the environment with the finished things @@ -204,9 +212,13 @@ tcTyAndClassDecls boot_details allDecls -- we want them in the environment because -- they may be mentioned in interface files ; let { implicit_things = concatMap implicitTyThings alg_tyclss } - ; traceTc ((text "Adding" <+> ppr alg_tyclss) $$ (text "and" <+> ppr implicit_things)) + ; traceTc ((text "Adding" <+> ppr alg_tyclss) + $$ (text "and" <+> ppr implicit_things)) ; tcExtendGlobalEnv implicit_things getGblEnv }} + where + addATs decl@(L _ (ClassDecl {tcdATs = ats})) = decl : ats + addATs decl = [decl] mkGlobalThings :: [LTyClDecl Name] -- The decls -> [TyThing] -- Knot-tied, in 1-1 correspondence with the decls @@ -591,7 +603,7 @@ tcSynDecl ; return (ATyCon (buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty'))) } -------------------- -tcTyClDecl :: (Name -> RecFlag) -> TyClDecl Name -> TcM TyThing +tcTyClDecl :: (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing] tcTyClDecl calc_isrec decl = tcAddDeclCtxt decl (tcTyClDecl1 calc_isrec decl) @@ -605,7 +617,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 @@ -627,7 +639,7 @@ tcTyClDecl1 _calc_isrec DataType -> OpenDataTyCon NewType -> OpenNewTyCon) Recursive False True - ; return (ATyCon tycon) + ; return [ATyCon tycon] } tcTyClDecl1 calc_isrec @@ -675,7 +687,7 @@ tcTyClDecl1 calc_isrec ; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs is_rec (want_generic && canDoGenerics data_cons) h98_syntax }) - ; return (ATyCon tycon) + ; return [ATyCon tycon] } where is_rec = calc_isrec tc_name @@ -690,7 +702,8 @@ tcTyClDecl1 calc_isrec = tcTyVarBndrs tvs $ \ tvs' -> do { ctxt' <- tcHsKindedContext ctxt ; fds' <- mappM (addLocM tc_fundep) fundeps - ; ats' <- mappM (addLocM (tcTyClDecl1 (const Recursive))) ats + ; atss <- mappM (addLocM (tcTyClDecl1 (const Recursive))) ats + ; let ats' = concat atss ; sig_stuff <- tcClassSigs class_name sigs meths ; clas <- fixM (\ clas -> let -- This little knot is just so we can get @@ -701,7 +714,10 @@ tcTyClDecl1 calc_isrec in buildClass class_name tvs' ctxt' fds' ats' sig_stuff tc_isrec) - ; return (AClass clas) } + ; return (AClass clas : ats') + -- NB: Order is important due to the call to `mkGlobalThings' when + -- tying the the type and class declaration type checking knot. + } where tc_fundep (tvs1, tvs2) = do { tvs1' <- mappM tcLookupTyVar tvs1 ; ; tvs2' <- mappM tcLookupTyVar tvs2 ; @@ -710,7 +726,7 @@ tcTyClDecl1 calc_isrec tcTyClDecl1 calc_isrec (ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name}) - = returnM (ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0)) + = returnM [ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0)] ----------------------------------- tcConDecl :: Bool -- True <=> -funbox-strict_fields -- 1.7.10.4