diff options
Diffstat (limited to 'compiler/iface')
-rw-r--r-- | compiler/iface/BinIface.hs | 15 | ||||
-rw-r--r-- | compiler/iface/BuildTyCl.lhs | 7 | ||||
-rw-r--r-- | compiler/iface/IfaceSyn.lhs | 36 | ||||
-rw-r--r-- | compiler/iface/MkIface.lhs | 13 | ||||
-rw-r--r-- | compiler/iface/TcIface.lhs | 14 |
5 files changed, 72 insertions, 13 deletions
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 26b3d9c886..c9c9918cdc 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -1456,6 +1456,21 @@ instance Binary IfaceConDecl where a10 <- get bh return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) +instance Binary IfaceAT where + put_ bh (IfaceAT dec defs) = do + put_ bh dec + put_ bh defs + get bh = do dec <- get bh + defs <- get bh + return (IfaceAT dec defs) + +instance Binary IfaceATDefault where + put_ bh (IfaceATD tvs pat_tys ty) = do + put_ bh tvs + put_ bh pat_tys + put_ bh ty + get bh = liftM3 IfaceATD (get bh) (get bh) (get bh) + instance Binary IfaceClassOp where put_ bh (IfaceClassOp n def ty) = do put_ bh (occNameFS n) diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index 7f2ade20cd..98fb19eb82 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -231,12 +231,12 @@ buildClass :: Bool -- True <=> do not include unfoldings -- Used when importing a class without -O -> Name -> [TyVar] -> ThetaType -> [FunDep TyVar] -- Functional dependencies - -> [TyThing] -- Associated types + -> [ClassATItem] -- Associated types -> [TcMethInfo] -- Method info -> RecFlag -- Info for type constructor -> TcRnIf m n Class -buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec +buildClass no_unf class_name tvs sc_theta fds at_items sig_stuff tc_isrec = do { traceIf (text "buildClass") ; tycon_name <- newImplicitBinder class_name mkClassTyConOcc ; datacon_name <- newImplicitBinder class_name mkClassDataConOcc @@ -308,10 +308,9 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec -- [If we don't make it a recursive newtype, we'll expand the -- newtype like a synonym, but that will lead to an infinite -- type] - ; atTyCons = [tycon | ATyCon tycon <- ats] ; result = mkClass class_name tvs fds - sc_theta sc_sel_ids atTyCons + sc_theta sc_sel_ids at_items op_items tycon } ; traceIf (text "buildClass" <+> ppr tycon) diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index eb09c2f10f..9e48480766 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -7,7 +7,8 @@ module IfaceSyn ( module IfaceType, - IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..), + IfaceDecl(..), IfaceClassOp(..), IfaceAT(..), IfaceATDefault(..), + IfaceConDecl(..), IfaceConDecls(..), IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..), IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..), @@ -87,7 +88,7 @@ data IfaceDecl ifName :: OccName, -- Name of the class ifTyVars :: [IfaceTvBndr], -- Type variables ifFDs :: [FunDep FastString], -- Functional dependencies - ifATs :: [IfaceDecl], -- Associated type families + ifATs :: [IfaceAT], -- Associated type families ifSigs :: [IfaceClassOp], -- Method signatures ifRec :: RecFlag -- Is newtype/datatype associated -- with the class recursive? @@ -102,6 +103,16 @@ data IfaceClassOp = IfaceClassOp OccName DefMethSpec IfaceType -- Just False => ordinary polymorphic default method -- Just True => generic default method +data IfaceAT = IfaceAT IfaceDecl [IfaceATDefault] + -- Nothing => no default associated type instance + -- Just ds => default associated type instance from these templates + +data IfaceATDefault = IfaceATD [IfaceTvBndr] [IfaceType] IfaceType + -- Each associated type default template is a triple of: + -- 1. TyVars of the RHS and family arguments (including the class TVs) + -- 3. The instantiated family arguments + -- 2. The RHS of the synonym + data IfaceConDecls = IfAbstractTyCon Bool -- c.f TyCon.AbstractTyCon | IfOpenDataTyCon -- Open data family @@ -383,7 +394,7 @@ ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, -- no wrapper (class dictionaries never have a wrapper) [dc_occ, dcww_occ] ++ -- associated types - [ifName at | at <- ats ] ++ + [ifName at | IfaceAT at _ <- ats ] ++ -- superclass selectors [mkSuperDictSelOcc n cls_occ | n <- [1..n_ctxt]] ++ -- operation selectors @@ -466,6 +477,12 @@ pprFamily (Just famInst) = ptext (sLit "FamilyInstance:") <+> ppr famInst instance Outputable IfaceClassOp where ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty +instance Outputable IfaceAT where + ppr (IfaceAT d defs) = hang (ppr d) 2 (vcat (map ppr defs)) + +instance Outputable IfaceATDefault where + ppr (IfaceATD tvs pat_tys ty) = ppr tvs <+> hsep (map ppr pat_tys) <+> char '=' <+> ppr ty + pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc pprIfaceDeclHead context thing tyvars = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing), @@ -701,7 +718,7 @@ freeNamesIfDecl d@IfaceSyn{} = freeNamesIfDecl d@IfaceClass{} = freeNamesIfTvBndrs (ifTyVars d) &&& freeNamesIfContext (ifCtxt d) &&& - freeNamesIfDecls (ifATs d) &&& + fnList freeNamesIfAT (ifATs d) &&& fnList freeNamesIfClsSig (ifSigs d) freeNamesIfIdDetails :: IfaceIdDetails -> NameSet @@ -722,8 +739,15 @@ freeNamesIfTcFam Nothing = freeNamesIfContext :: IfaceContext -> NameSet freeNamesIfContext = fnList freeNamesIfPredType -freeNamesIfDecls :: [IfaceDecl] -> NameSet -freeNamesIfDecls = fnList freeNamesIfDecl +freeNamesIfAT :: IfaceAT -> NameSet +freeNamesIfAT (IfaceAT decl defs) + = freeNamesIfDecl decl &&& + fnList fn_at_def defs + where + fn_at_def (IfaceATD tvs pat_tys ty) + = freeNamesIfTvBndrs tvs &&& + fnList freeNamesIfType pat_tys &&& + freeNamesIfType ty freeNamesIfClsSig :: IfaceClassOp -> NameSet freeNamesIfClsSig (IfaceClassOp _n _dm ty) = freeNamesIfType ty diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index b73e00a731..b25d979970 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -744,7 +744,7 @@ declExtras fix_fn rule_env inst_env decl (map (id_extras . ifConOcc) (visibleIfConDecls cons)) IfaceClass{ifSigs=sigs, ifATs=ats} -> IfaceClassExtras (fix_fn n) - (map ifDFun $ (concatMap (lookupOccEnvL inst_env . ifName) ats) + (map ifDFun $ (concatMap at_extras ats) ++ lookupOccEnvL inst_env n) -- Include instances of the associated types -- as well as instances of the class (Trac #5147) @@ -754,6 +754,7 @@ declExtras fix_fn rule_env inst_env decl where n = ifName decl id_extras occ = (fix_fn occ, lookupOccEnvL rule_env occ) + at_extras (IfaceAT decl _) = lookupOccEnvL inst_env (ifName decl) -- -- When hashing an instance, we hash only the DFunId, because that @@ -1330,7 +1331,7 @@ tyThingToIfaceDecl (AClass clas) ifName = getOccName clas, ifTyVars = toIfaceTvBndrs clas_tyvars, ifFDs = map toIfaceFD clas_fds, - ifATs = map (tyThingToIfaceDecl . ATyCon) clas_ats, + ifATs = map toIfaceAT clas_ats, ifSigs = map toIfaceClassOp op_stuff, ifRec = boolToRecFlag (isRecursiveTyCon tycon) } where @@ -1338,6 +1339,14 @@ tyThingToIfaceDecl (AClass clas) = classExtraBigSig clas tycon = classTyCon clas + toIfaceAT :: ClassATItem -> IfaceAT + toIfaceAT (tc, defs) + = IfaceAT (tyThingToIfaceDecl (ATyCon tc)) + (map to_if_at_def defs) + where + to_if_at_def (ATD tvs pat_tys ty) + = IfaceATD (toIfaceTvBndrs tvs) (map toIfaceType pat_tys) (toIfaceType ty) + toIfaceClassOp (sel_id, def_meth) = ASSERT(sel_tyvars == clas_tyvars) IfaceClassOp (getOccName sel_id) (toDmSpec def_meth) (toIfaceType op_ty) diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index d0ce1b7349..9fbb59bd3e 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -479,7 +479,7 @@ tc_iface_decl _parent ignore_prags ; sigs <- mapM tc_sig rdr_sigs ; fds <- mapM tc_fd rdr_fds ; cls <- fixM $ \ cls -> do - { ats <- mapM (tc_iface_decl (AssocFamilyTyCon cls) ignore_prags) rdr_ats + { ats <- mapM (tc_at cls) rdr_ats ; buildClass ignore_prags cls_name tyvars ctxt fds ats sigs tc_isrec } ; return (AClass cls) } where @@ -491,6 +491,18 @@ tc_iface_decl _parent ignore_prags -- it mentions unless it's necessray to do so ; return (op_name, dm, op_ty) } + tc_at cls (IfaceAT tc_decl defs_decls) + = do tc <- tc_iface_tc_decl (AssocFamilyTyCon cls) tc_decl + defs <- mapM tc_iface_at_def defs_decls + return (tc, defs) + + tc_iface_tc_decl parent decl = do + ATyCon tc <- tc_iface_decl parent ignore_prags decl + return tc + + tc_iface_at_def (IfaceATD tvs pat_tys ty) = + bindIfaceTyVars_AT tvs $ \tvs' -> liftM2 (ATD tvs') (mapM tcIfaceType pat_tys) (tcIfaceType ty) + mk_doc op_name op_ty = ptext (sLit "Class op") <+> sep [ppr op_name, ppr op_ty] tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1 |