From 14a3631d5b7a49fef47a221f548dc7d021810de9 Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Wed, 20 Sep 2006 18:46:45 +0000 Subject: [PATCH] ATs are now implicitTyThings Mon Sep 18 19:36:03 EDT 2006 Manuel M T Chakravarty * ATs are now implicitTyThings Tue Sep 5 21:09:54 EDT 2006 Manuel M T Chakravarty * ATs are now implicitTyThings --- compiler/iface/LoadIface.lhs | 16 ++++------------ compiler/main/HscTypes.lhs | 7 ++++--- compiler/typecheck/TcTyClsDecls.lhs | 8 ++++++++ 3 files changed, 16 insertions(+), 15 deletions(-) diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index c91aa63..21332fa 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -301,7 +301,6 @@ loadDecl ignore_prags mod (_version, decl) main_name <- mk_new_bndr mod Nothing (ifName decl) ; implicit_names <- mapM (mk_new_bndr mod (Just main_name)) (ifaceDeclSubBndrs decl) - ; at_names <- mapM (mk_new_bndr mod (Just main_name)) (atNames decl) -- Typecheck the thing, lazily -- NB. firstly, the laziness is there in case we never need the @@ -318,7 +317,6 @@ loadDecl ignore_prags mod (_version, decl) ppr n $$ ppr (stripped_decl)) ; 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 @@ -337,12 +335,6 @@ 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 @@ -364,12 +356,12 @@ ifaceDeclSubBndrs :: IfaceDecl -> [OccName] -- -- If you change this, make sure you change HscTypes.implicitTyThings in sync -ifaceDeclSubBndrs IfaceClass { ifCtxt = sc_ctxt, - ifName = cls_occ, - ifSigs = sigs } +ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, + ifSigs = sigs, ifATs = ats }) = co_occs ++ [tc_occ, dc_occ, dcww_occ] ++ - [op | IfaceClassOp op _ _ <- sigs] ++ + [op | IfaceClassOp op _ _ <- sigs] ++ + [ifName at | at <- ats ] ++ [mkSuperDictSelOcc n cls_occ | n <- [1..n_ctxt]] where n_ctxt = length sc_ctxt diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index b142d19..e7df0ba 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 ) +import Class ( Class, classSelIds, classATs, classTyCon ) import TyCon ( TyCon, tyConSelIds, tyConDataCons, isNewTyCon, newTyConCo_maybe, tyConFamilyCoercion_maybe ) import DataCon ( dataConImplicitIds ) @@ -634,10 +634,11 @@ implicitTyThings (ATyCon tc) = implicitCoTyCon tc ++ (tyConDataCons tc) -- For classes, add the class TyCon too (and its extras) - -- and the class selector Ids + -- and the class selector Ids and the associated types (they don't + -- have extras as these are only the family decls) implicitTyThings (AClass cl) = map AnId (classSelIds cl) ++ + map ATyCon (classATs cl) ++ extras_plus (ATyCon (classTyCon cl)) - -- For data cons add the worker and wrapper (if any) implicitTyThings (ADataCon dc) = map AnId (dataConImplicitIds dc) diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 9065d28..c9dee4b 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -213,12 +213,20 @@ tcTyAndClassDecls boot_details allDecls -- Add the implicit things; -- we want them in the environment because -- they may be mentioned in interface files + -- NB: All associated types and their implicit things will be added a + -- second time here. This doesn't matter as the definitions are + -- the same. ; let { implicit_things = concatMap implicitTyThings alg_tyclss } ; traceTc ((text "Adding" <+> ppr alg_tyclss) $$ (text "and" <+> ppr implicit_things)) ; tcExtendGlobalEnv implicit_things getGblEnv }} where + -- Pull associated types out of class declarations, to tie them into the + -- knot above. + -- NB: We put them in the same place in the list as `tcTyClDecl' will + -- eventually put the matching `TyThing's. That's crucial; otherwise, + -- the two argument lists of `mkGlobalThings' don't match up. addATs decl@(L _ (ClassDecl {tcdATs = ats})) = decl : ats addATs decl = [decl] -- 1.7.10.4