summaryrefslogtreecommitdiff
path: root/compiler/iface
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/iface')
-rw-r--r--compiler/iface/BinIface.hs15
-rw-r--r--compiler/iface/BuildTyCl.lhs7
-rw-r--r--compiler/iface/IfaceSyn.lhs36
-rw-r--r--compiler/iface/MkIface.lhs13
-rw-r--r--compiler/iface/TcIface.lhs14
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