Commit fb5cd9d6 authored by Edward Z. Yang's avatar Edward Z. Yang
Browse files

Properly represent abstract classes in Class and IfaceDecl

Summary:
Previously, abstract classes looked very much like normal
classes, except that they happened to have no methods,
superclasses or ATs, and they came from boot files.  This
patch gives abstract classes a proper representation in
Class and IfaceDecl, by moving the things which are never
defined for abstract classes into ClassBody/IfaceClassBody.

Because Class is abstract, this change had ~no disruption
to any of the code in GHC; if you ask about the methods of
an abstract class, we'll just give you an empty list.

This also fixes a bug where abstract type classes were incorrectly
treated as representationally injective (they're not!)

Fixes #13347

, and a TODO in the code.
Signed-off-by: default avatarEdward Z. Yang <ezyang@cs.stanford.edu>

Test Plan: validate

Reviewers: simonpj, bgamari, austin

Subscribers: goldfire, thomie

Differential Revision: https://phabricator.haskell.org/D3236
parent e7106861
...@@ -451,15 +451,11 @@ rnIfaceDecl d@IfaceFamily{} = do ...@@ -451,15 +451,11 @@ rnIfaceDecl d@IfaceFamily{} = do
} }
rnIfaceDecl d@IfaceClass{} = do rnIfaceDecl d@IfaceClass{} = do
name <- rnIfaceGlobal (ifName d) name <- rnIfaceGlobal (ifName d)
ctxt <- mapM rnIfaceType (ifCtxt d)
binders <- mapM rnIfaceTyConBinder (ifBinders d) binders <- mapM rnIfaceTyConBinder (ifBinders d)
ats <- mapM rnIfaceAT (ifATs d) body <- rnIfaceClassBody (ifBody d)
sigs <- mapM rnIfaceClassOp (ifSigs d)
return d { ifName = name return d { ifName = name
, ifCtxt = ctxt
, ifBinders = binders , ifBinders = binders
, ifATs = ats , ifBody = body
, ifSigs = sigs
} }
rnIfaceDecl d@IfaceAxiom{} = do rnIfaceDecl d@IfaceAxiom{} = do
name <- rnIfaceNeverExported (ifName d) name <- rnIfaceNeverExported (ifName d)
...@@ -491,6 +487,14 @@ rnIfaceDecl d@IfacePatSyn{} = do ...@@ -491,6 +487,14 @@ rnIfaceDecl d@IfacePatSyn{} = do
, ifPatTy = pat_ty , ifPatTy = pat_ty
} }
rnIfaceClassBody :: Rename IfaceClassBody
rnIfaceClassBody IfAbstractClass = return IfAbstractClass
rnIfaceClassBody d@IfConcreteClass{} = do
ctxt <- mapM rnIfaceType (ifClassCtxt d)
ats <- mapM rnIfaceAT (ifATs d)
sigs <- mapM rnIfaceClassOp (ifSigs d)
return d { ifClassCtxt = ctxt, ifATs = ats, ifSigs = sigs }
rnIfaceFamTyConFlav :: Rename IfaceFamTyConFlav rnIfaceFamTyConFlav :: Rename IfaceFamTyConFlav
rnIfaceFamTyConFlav (IfaceClosedSynFamilyTyCon (Just (n, axs))) rnIfaceFamTyConFlav (IfaceClosedSynFamilyTyCon (Just (n, axs)))
= IfaceClosedSynFamilyTyCon . Just <$> ((,) <$> rnIfaceNeverExported n = IfaceClosedSynFamilyTyCon . Just <$> ((,) <$> rnIfaceNeverExported n
......
...@@ -298,15 +298,28 @@ type TcMethInfo -- A temporary intermediate, to communicate ...@@ -298,15 +298,28 @@ type TcMethInfo -- A temporary intermediate, to communicate
buildClass :: Name -- Name of the class/tycon (they have the same Name) buildClass :: Name -- Name of the class/tycon (they have the same Name)
-> [TyConBinder] -- Of the tycon -> [TyConBinder] -- Of the tycon
-> [Role] -> ThetaType -> [Role]
-> [FunDep TyVar] -- Functional dependencies -> [FunDep TyVar] -- Functional dependencies
-> [ClassATItem] -- Associated types -- Super classes, associated types, method info, minimal complete def.
-> [TcMethInfo] -- Method info -- This is Nothing if the class is abstract.
-> ClassMinimalDef -- Minimal complete definition -> Maybe (ThetaType, [ClassATItem], [TcMethInfo], ClassMinimalDef)
-> TcRnIf m n Class -> TcRnIf m n Class
buildClass tycon_name binders roles sc_theta buildClass tycon_name binders roles fds Nothing
fds at_items sig_stuff mindef = fixM $ \ rec_clas -> -- Only name generation inside loop
do { traceIf (text "buildClass")
; tc_rep_name <- newTyConRepName tycon_name
; let univ_bndrs = mkDataConUnivTyVarBinders binders
univ_tvs = binderVars univ_bndrs
tycon = mkClassTyCon tycon_name binders roles
AbstractTyCon rec_clas tc_rep_name
result = mkAbstractClass tycon_name univ_tvs fds tycon
; traceIf (text "buildClass" <+> ppr tycon)
; return result }
buildClass tycon_name binders roles fds
(Just (sc_theta, at_items, sig_stuff, mindef))
= fixM $ \ rec_clas -> -- Only name generation inside loop = fixM $ \ rec_clas -> -- Only name generation inside loop
do { traceIf (text "buildClass") do { traceIf (text "buildClass")
...@@ -365,12 +378,14 @@ buildClass tycon_name binders roles sc_theta ...@@ -365,12 +378,14 @@ buildClass tycon_name binders roles sc_theta
(mkTyConApp rec_tycon (mkTyVarTys univ_tvs)) (mkTyConApp rec_tycon (mkTyVarTys univ_tvs))
rec_tycon rec_tycon
; rhs <- if use_newtype ; rhs <- case () of
then mkNewTyConRhs tycon_name rec_tycon dict_con _ | use_newtype
else if isCTupleTyConName tycon_name -> mkNewTyConRhs tycon_name rec_tycon dict_con
then return (TupleTyCon { data_con = dict_con | isCTupleTyConName tycon_name
-> return (TupleTyCon { data_con = dict_con
, tup_sort = ConstraintTuple }) , tup_sort = ConstraintTuple })
else return (mkDataTyConRhs [dict_con]) | otherwise
-> return (mkDataTyConRhs [dict_con])
; let { tycon = mkClassTyCon tycon_name binders roles ; let { tycon = mkClassTyCon tycon_name binders roles
rhs rec_clas tc_rep_name rhs rec_clas tc_rep_name
......
...@@ -15,6 +15,7 @@ module IfaceSyn ( ...@@ -15,6 +15,7 @@ module IfaceSyn (
IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..), IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..),
IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget, IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..), IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..),
IfaceClassBody(..),
IfaceBang(..), IfaceBang(..),
IfaceSrcBang(..), SrcUnpackedness(..), SrcStrictness(..), IfaceSrcBang(..), SrcUnpackedness(..), SrcStrictness(..),
IfaceAxBranch(..), IfaceAxBranch(..),
...@@ -138,14 +139,11 @@ data IfaceDecl ...@@ -138,14 +139,11 @@ data IfaceDecl
ifFamFlav :: IfaceFamTyConFlav, ifFamFlav :: IfaceFamTyConFlav,
ifFamInj :: Injectivity } -- injectivity information ifFamInj :: Injectivity } -- injectivity information
| IfaceClass { ifCtxt :: IfaceContext, -- Superclasses | IfaceClass { ifName :: IfaceTopBndr, -- Name of the class TyCon
ifName :: IfaceTopBndr, -- Name of the class TyCon
ifRoles :: [Role], -- Roles ifRoles :: [Role], -- Roles
ifBinders :: [IfaceTyConBinder], ifBinders :: [IfaceTyConBinder],
ifFDs :: [FunDep IfLclName], -- Functional dependencies ifFDs :: [FunDep IfLclName], -- Functional dependencies
ifATs :: [IfaceAT], -- Associated type families ifBody :: IfaceClassBody -- Methods, superclasses, ATs
ifSigs :: [IfaceClassOp], -- Method signatures
ifMinDef :: BooleanFormula IfLclName -- Minimal complete definition
} }
| IfaceAxiom { ifName :: IfaceTopBndr, -- Axiom name | IfaceAxiom { ifName :: IfaceTopBndr, -- Axiom name
...@@ -168,6 +166,17 @@ data IfaceDecl ...@@ -168,6 +166,17 @@ data IfaceDecl
ifPatTy :: IfaceType, ifPatTy :: IfaceType,
ifFieldLabels :: [FieldLabel] } ifFieldLabels :: [FieldLabel] }
-- See also 'ClassBody'
data IfaceClassBody
-- Abstract classes don't specify their body; they only occur in @hs-boot@ and
-- @hsig@ files.
= IfAbstractClass
| IfConcreteClass {
ifClassCtxt :: IfaceContext, -- Super classes
ifATs :: [IfaceAT], -- Associated type families
ifSigs :: [IfaceClassOp], -- Method signatures
ifMinDef :: BooleanFormula IfLclName -- Minimal complete definition
}
data IfaceTyConParent data IfaceTyConParent
= IfNoParent = IfNoParent
...@@ -389,10 +398,15 @@ ifaceDeclImplicitBndrs (IfaceData {ifName = tc_name, ifCons = cons }) ...@@ -389,10 +398,15 @@ ifaceDeclImplicitBndrs (IfaceData {ifName = tc_name, ifCons = cons })
IfNewTyCon cd -> mkNewTyCoOcc (occName tc_name) : ifaceConDeclImplicitBndrs cd IfNewTyCon cd -> mkNewTyCoOcc (occName tc_name) : ifaceConDeclImplicitBndrs cd
IfDataTyCon cds -> concatMap ifaceConDeclImplicitBndrs cds IfDataTyCon cds -> concatMap ifaceConDeclImplicitBndrs cds
ifaceDeclImplicitBndrs (IfaceClass { ifCtxt = sc_ctxt ifaceDeclImplicitBndrs (IfaceClass { ifBody = IfAbstractClass })
, ifName = cls_tc_name = []
, ifSigs = sigs
, ifATs = ats }) ifaceDeclImplicitBndrs (IfaceClass { ifName = cls_tc_name
, ifBody = IfConcreteClass {
ifClassCtxt = sc_ctxt,
ifSigs = sigs,
ifATs = ats
}})
= -- (possibly) newtype coercion = -- (possibly) newtype coercion
co_occs ++ co_occs ++
-- data constructor (DataCon namespace) -- data constructor (DataCon namespace)
...@@ -413,7 +427,7 @@ ifaceDeclImplicitBndrs (IfaceClass { ifCtxt = sc_ctxt ...@@ -413,7 +427,7 @@ ifaceDeclImplicitBndrs (IfaceClass { ifCtxt = sc_ctxt
| otherwise = [] | otherwise = []
dcww_occ = mkDataConWorkerOcc dc_occ dcww_occ = mkDataConWorkerOcc dc_occ
dc_occ = mkClassDataConOcc cls_tc_occ dc_occ = mkClassDataConOcc cls_tc_occ
is_newtype = n_sigs + n_ctxt == 1 -- Sigh is_newtype = n_sigs + n_ctxt == 1 -- Sigh (keep this synced with buildClass)
ifaceDeclImplicitBndrs _ = [] ifaceDeclImplicitBndrs _ = []
...@@ -663,6 +677,13 @@ isIfaceDataInstance :: IfaceTyConParent -> Bool ...@@ -663,6 +677,13 @@ isIfaceDataInstance :: IfaceTyConParent -> Bool
isIfaceDataInstance IfNoParent = False isIfaceDataInstance IfNoParent = False
isIfaceDataInstance _ = True isIfaceDataInstance _ = True
pprClassRoles :: ShowSub -> IfaceTopBndr -> [IfaceTyConBinder] -> [Role] -> SDoc
pprClassRoles ss clas binders roles =
pprRoles (== Nominal)
(pprPrefixIfDeclBndr (ss_how_much ss) (occName clas))
binders
roles
pprIfaceDecl :: ShowSub -> IfaceDecl -> SDoc pprIfaceDecl :: ShowSub -> IfaceDecl -> SDoc
-- NB: pprIfaceDecl is also used for pretty-printing TyThings in GHCi -- NB: pprIfaceDecl is also used for pretty-printing TyThings in GHCi
-- See Note [Pretty-printing TyThings] in PprTyThing -- See Note [Pretty-printing TyThings] in PprTyThing
...@@ -718,17 +739,26 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype, ...@@ -718,17 +739,26 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
pp_extra = vcat [pprCType ctype] pp_extra = vcat [pprCType ctype]
pprIfaceDecl ss (IfaceClass { ifName = clas
, ifRoles = roles
, ifFDs = fds
, ifBinders = binders
, ifBody = IfAbstractClass })
= vcat [ pprClassRoles ss clas binders roles
, text "class" <+> pprIfaceDeclHead [] ss clas binders Nothing
<+> pprFundeps fds ]
pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs pprIfaceDecl ss (IfaceClass { ifName = clas
, ifCtxt = context, ifName = clas
, ifRoles = roles , ifRoles = roles
, ifFDs = fds, ifMinDef = minDef , ifFDs = fds
, ifBinders = binders }) , ifBinders = binders
= vcat [ pprRoles , ifBody = IfConcreteClass {
(== Nominal) ifATs = ats,
(pprPrefixIfDeclBndr (ss_how_much ss) (occName clas)) ifSigs = sigs,
binders ifClassCtxt = context,
roles ifMinDef = minDef
}})
= vcat [ pprClassRoles ss clas binders roles
, text "class" <+> pprIfaceDeclHead context ss clas binders Nothing , text "class" <+> pprIfaceDeclHead context ss clas binders Nothing
<+> pprFundeps fds <+> pp_where <+> pprFundeps fds <+> pp_where
, nest 2 (vcat [ vcat asocs, vcat dsigs , nest 2 (vcat [ vcat asocs, vcat dsigs
...@@ -1246,11 +1276,13 @@ freeNamesIfDecl d@IfaceFamily{} = ...@@ -1246,11 +1276,13 @@ freeNamesIfDecl d@IfaceFamily{} =
freeNamesIfFamFlav (ifFamFlav d) &&& freeNamesIfFamFlav (ifFamFlav d) &&&
freeNamesIfTyVarBndrs (ifBinders d) &&& freeNamesIfTyVarBndrs (ifBinders d) &&&
freeNamesIfKind (ifResKind d) freeNamesIfKind (ifResKind d)
freeNamesIfDecl d@IfaceClass{} = freeNamesIfDecl d@IfaceClass{ ifBody = IfAbstractClass } =
freeNamesIfContext (ifCtxt d) &&& freeNamesIfTyVarBndrs (ifBinders d)
freeNamesIfDecl d@IfaceClass{ ifBody = d'@IfConcreteClass{} } =
freeNamesIfTyVarBndrs (ifBinders d) &&& freeNamesIfTyVarBndrs (ifBinders d) &&&
fnList freeNamesIfAT (ifATs d) &&& freeNamesIfContext (ifClassCtxt d') &&&
fnList freeNamesIfClsSig (ifSigs d) fnList freeNamesIfAT (ifATs d') &&&
fnList freeNamesIfClsSig (ifSigs d')
freeNamesIfDecl d@IfaceAxiom{} = freeNamesIfDecl d@IfaceAxiom{} =
freeNamesIfTc (ifTyCon d) &&& freeNamesIfTc (ifTyCon d) &&&
fnList freeNamesIfAxBranch (ifAxBranches d) fnList freeNamesIfAxBranch (ifAxBranches d)
...@@ -1566,7 +1598,18 @@ instance Binary IfaceDecl where ...@@ -1566,7 +1598,18 @@ instance Binary IfaceDecl where
put_ bh a5 put_ bh a5
put_ bh a6 put_ bh a6
put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7 a8) = do -- NB: Written in a funny way to avoid an interface change
put_ bh (IfaceClass {
ifName = a2,
ifRoles = a3,
ifBinders = a4,
ifFDs = a5,
ifBody = IfConcreteClass {
ifClassCtxt = a1,
ifATs = a6,
ifSigs = a7,
ifMinDef = a8
}}) = do
putByte bh 5 putByte bh 5
put_ bh a1 put_ bh a1
putIfaceTopBndr bh a2 putIfaceTopBndr bh a2
...@@ -1598,6 +1641,18 @@ instance Binary IfaceDecl where ...@@ -1598,6 +1641,18 @@ instance Binary IfaceDecl where
put_ bh a10 put_ bh a10
put_ bh a11 put_ bh a11
put_ bh (IfaceClass {
ifName = a1,
ifRoles = a2,
ifBinders = a3,
ifFDs = a4,
ifBody = IfAbstractClass }) = do
putByte bh 8
putIfaceTopBndr bh a1
put_ bh a2
put_ bh a3
put_ bh a4
get bh = do get bh = do
h <- getByte bh h <- getByte bh
case h of case h of
...@@ -1638,7 +1693,17 @@ instance Binary IfaceDecl where ...@@ -1638,7 +1693,17 @@ instance Binary IfaceDecl where
a6 <- get bh a6 <- get bh
a7 <- get bh a7 <- get bh
a8 <- get bh a8 <- get bh
return (IfaceClass a1 a2 a3 a4 a5 a6 a7 a8) return (IfaceClass {
ifName = a2,
ifRoles = a3,
ifBinders = a4,
ifFDs = a5,
ifBody = IfConcreteClass {
ifClassCtxt = a1,
ifATs = a6,
ifSigs = a7,
ifMinDef = a8
}})
6 -> do a1 <- getIfaceTopBndr bh 6 -> do a1 <- getIfaceTopBndr bh
a2 <- get bh a2 <- get bh
a3 <- get bh a3 <- get bh
...@@ -1656,6 +1721,16 @@ instance Binary IfaceDecl where ...@@ -1656,6 +1721,16 @@ instance Binary IfaceDecl where
a10 <- get bh a10 <- get bh
a11 <- get bh a11 <- get bh
return (IfacePatSyn a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) return (IfacePatSyn a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11)
8 -> do a1 <- getIfaceTopBndr bh
a2 <- get bh
a3 <- get bh
a4 <- get bh
return (IfaceClass {
ifName = a1,
ifRoles = a2,
ifBinders = a3,
ifFDs = a4,
ifBody = IfAbstractClass })
_ -> panic (unwords ["Unknown IfaceDecl tag:", show h]) _ -> panic (unwords ["Unknown IfaceDecl tag:", show h])
instance Binary IfaceFamTyConFlav where instance Binary IfaceFamTyConFlav where
......
...@@ -931,7 +931,7 @@ declExtras fix_fn ann_fn rule_env inst_env fi_env decl ...@@ -931,7 +931,7 @@ declExtras fix_fn ann_fn rule_env inst_env fi_env decl
map ifDFun (lookupOccEnvL inst_env n)) map ifDFun (lookupOccEnvL inst_env n))
(ann_fn n) (ann_fn n)
(map (id_extras . occName . ifConName) (visibleIfConDecls cons)) (map (id_extras . occName . ifConName) (visibleIfConDecls cons))
IfaceClass{ifSigs=sigs, ifATs=ats} -> IfaceClass{ifBody = IfConcreteClass { ifSigs=sigs, ifATs=ats }} ->
IfaceClassExtras (fix_fn n) IfaceClassExtras (fix_fn n)
(map ifDFun $ (concatMap at_extras ats) (map ifDFun $ (concatMap at_extras ats)
++ lookupOccEnvL inst_env n) ++ lookupOccEnvL inst_env n)
...@@ -1668,19 +1668,25 @@ tyConToIfaceDecl env tycon ...@@ -1668,19 +1668,25 @@ tyConToIfaceDecl env tycon
classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl) classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl)
classToIfaceDecl env clas classToIfaceDecl env clas
= ( env1 = ( env1
, IfaceClass { ifCtxt = tidyToIfaceContext env1 sc_theta, , IfaceClass { ifName = getName tycon,
ifName = getName tycon,
ifRoles = tyConRoles (classTyCon clas), ifRoles = tyConRoles (classTyCon clas),
ifBinders = toIfaceTyVarBinders tc_binders, ifBinders = toIfaceTyVarBinders tc_binders,
ifFDs = map toIfaceFD clas_fds, ifBody = body,
ifATs = map toIfaceAT clas_ats, ifFDs = map toIfaceFD clas_fds })
ifSigs = map toIfaceClassOp op_stuff,
ifMinDef = fmap getOccFS (classMinimalDef clas) })
where where
(_, clas_fds, sc_theta, _, clas_ats, op_stuff) (_, clas_fds, sc_theta, _, clas_ats, op_stuff)
= classExtraBigSig clas = classExtraBigSig clas
tycon = classTyCon clas tycon = classTyCon clas
body | isAbstractTyCon tycon = IfAbstractClass
| otherwise
= IfConcreteClass {
ifClassCtxt = tidyToIfaceContext env1 sc_theta,
ifATs = map toIfaceAT clas_ats,
ifSigs = map toIfaceClassOp op_stuff,
ifMinDef = fmap getOccFS (classMinimalDef clas)
}
(env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon) (env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)
toIfaceAT :: ClassATItem -> IfaceAT toIfaceAT :: ClassATItem -> IfaceAT
......
...@@ -208,7 +208,7 @@ typecheckIface iface ...@@ -208,7 +208,7 @@ typecheckIface iface
-- | Returns true if an 'IfaceDecl' is for @data T@ (an abstract data type) -- | Returns true if an 'IfaceDecl' is for @data T@ (an abstract data type)
isAbstractIfaceDecl :: IfaceDecl -> Bool isAbstractIfaceDecl :: IfaceDecl -> Bool
isAbstractIfaceDecl IfaceData{ ifCons = IfAbstractTyCon } = True isAbstractIfaceDecl IfaceData{ ifCons = IfAbstractTyCon } = True
isAbstractIfaceDecl IfaceClass{ ifCtxt = [], ifSigs = [], ifATs = [] } = True isAbstractIfaceDecl IfaceClass{ ifBody = IfAbstractClass } = True
isAbstractIfaceDecl IfaceFamily{ ifFamFlav = IfaceAbstractClosedSynFamilyTyCon } = True isAbstractIfaceDecl IfaceFamily{ ifFamFlav = IfaceAbstractClosedSynFamilyTyCon } = True
isAbstractIfaceDecl _ = False isAbstractIfaceDecl _ = False
...@@ -223,21 +223,22 @@ ifMaybeRoles _ = Nothing ...@@ -223,21 +223,22 @@ ifMaybeRoles _ = Nothing
-- later.) -- later.)
mergeIfaceDecl :: IfaceDecl -> IfaceDecl -> IfaceDecl mergeIfaceDecl :: IfaceDecl -> IfaceDecl -> IfaceDecl
mergeIfaceDecl d1 d2 mergeIfaceDecl d1 d2
-- TODO: need to merge roles
| isAbstractIfaceDecl d1 = d2 `withRolesFrom` d1 | isAbstractIfaceDecl d1 = d2 `withRolesFrom` d1
| isAbstractIfaceDecl d2 = d1 `withRolesFrom` d2 | isAbstractIfaceDecl d2 = d1 `withRolesFrom` d2
| IfaceClass{ ifSigs = ops1, ifMinDef = bf1 } <- d1 | IfaceClass{ ifBody = IfConcreteClass { ifSigs = ops1, ifMinDef = bf1 } } <- d1
, IfaceClass{ ifSigs = ops2, ifMinDef = bf2 } <- d2 , IfaceClass{ ifBody = IfConcreteClass { ifSigs = ops2, ifMinDef = bf2 } } <- d2
= let ops = nameEnvElts $ = let ops = nameEnvElts $
plusNameEnv_C mergeIfaceClassOp plusNameEnv_C mergeIfaceClassOp
(mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops1 ]) (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops1 ])
(mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops2 ]) (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops2 ])
in d1 { ifSigs = ops in d1 { ifBody = (ifBody d1) {
, ifMinDef = BF.mkOr [noLoc bf1, noLoc bf2] ifSigs = ops,
} `withRolesFrom` d2 ifMinDef = BF.mkOr [noLoc bf1, noLoc bf2]
}
}
-- It doesn't matter; we'll check for consistency later when -- It doesn't matter; we'll check for consistency later when
-- we merge, see 'mergeSignatures' -- we merge, see 'mergeSignatures'
| otherwise = d1 `withRolesFrom` d2 | otherwise = d1
withRolesFrom :: IfaceDecl -> IfaceDecl -> IfaceDecl withRolesFrom :: IfaceDecl -> IfaceDecl -> IfaceDecl
d1 `withRolesFrom` d2 d1 `withRolesFrom` d2
...@@ -677,15 +678,27 @@ tc_iface_decl parent _ (IfaceFamily {ifName = tc_name, ...@@ -677,15 +678,27 @@ tc_iface_decl parent _ (IfaceFamily {ifName = tc_name,
= pprPanic "tc_iface_decl" = pprPanic "tc_iface_decl"
(text "IfaceBuiltInSynFamTyCon in interface file") (text "IfaceBuiltInSynFamTyCon in interface file")
tc_iface_decl _parent _ignore_prags
(IfaceClass {ifName = tc_name,
ifRoles = roles,
ifBinders = binders,
ifFDs = rdr_fds,
ifBody = IfAbstractClass})
= bindIfaceTyConBinders binders $ \ binders' -> do
{ fds <- mapM tc_fd rdr_fds
; cls <- buildClass tc_name binders' roles fds Nothing
; return (ATyCon (classTyCon cls)) }
tc_iface_decl _parent ignore_prags tc_iface_decl _parent ignore_prags
(IfaceClass {ifCtxt = rdr_ctxt, ifName = tc_name, (IfaceClass {ifName = tc_name,
ifRoles = roles, ifRoles = roles,
ifBinders = binders, ifBinders = binders,
ifFDs = rdr_fds, ifFDs = rdr_fds,
ifBody = IfConcreteClass {
ifClassCtxt = rdr_ctxt,
ifATs = rdr_ats, ifSigs = rdr_sigs, ifATs = rdr_ats, ifSigs = rdr_sigs,
ifMinDef = mindef_occ }) ifMinDef = mindef_occ
-- ToDo: in hs-boot files we should really treat abstract classes specially, }})
-- as we do abstract tycons
= bindIfaceTyConBinders binders $ \ binders' -> do = bindIfaceTyConBinders binders $ \ binders' -> do
{ traceIf (text "tc-iface-class1" <+> ppr tc_name) { traceIf (text "tc-iface-class1" <+> ppr tc_name)
; ctxt <- mapM tc_sc rdr_ctxt ; ctxt <- mapM tc_sc rdr_ctxt
...@@ -697,7 +710,7 @@ tc_iface_decl _parent ignore_prags ...@@ -697,7 +710,7 @@ tc_iface_decl _parent ignore_prags
; cls <- fixM $ \ cls -> do ; cls <- fixM $ \ cls -> do
{ ats <- mapM (tc_at cls) rdr_ats { ats <- mapM (tc_at cls) rdr_ats
; traceIf (text "tc-iface-class4" <+> ppr tc_name) ; traceIf (text "tc-iface-class4" <+> ppr tc_name)
; buildClass tc_name binders' roles ctxt fds ats sigs mindef } ; buildClass tc_name binders' roles fds (Just (ctxt, ats, sigs, mindef)) }
; return (ATyCon (classTyCon cls)) } ; return (ATyCon (classTyCon cls)) }
where where
tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred) tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred)
...@@ -746,10 +759,6 @@ tc_iface_decl _parent ignore_prags ...@@ -746,10 +759,6 @@ tc_iface_decl _parent ignore_prags
mk_at_doc tc = text "Associated type" <+> ppr tc mk_at_doc tc = text "Associated type" <+> ppr tc
mk_op_doc op_name op_ty = text "Class op" <+> sep [ppr op_name, ppr op_ty] mk_op_doc op_name op_ty = text "Class op" <+> sep [ppr op_name, ppr op_ty]
tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1
; tvs2' <- mapM tcIfaceTyVar tvs2
; return (tvs1', tvs2') }
tc_iface_decl _ _ (IfaceAxiom { ifName = tc_name, ifTyCon = tc tc_iface_decl _ _ (IfaceAxiom { ifName = tc_name, ifTyCon = tc
, ifAxBranches = branches, ifRole = role }) , ifAxBranches = branches, ifRole = role })
= do { tc_tycon <- tcIfaceTyCon tc = do { tc_tycon <- tcIfaceTyCon tc
...@@ -794,6 +803,11 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = name ...@@ -794,6 +803,11 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = name
tc_pr (nm, b) = do { id <- forkM (ppr nm) (tcIfaceExtId nm) tc_pr (nm, b) = do { id <- forkM (ppr nm) (tcIfaceExtId nm)
; return (id, b) } ; return (id, b) }
tc_fd :: FunDep IfLclName -> IfL (FunDep TyVar)
tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1
; tvs2' <- mapM tcIfaceTyVar tvs2
; return (tvs1', tvs2') }
tc_ax_branches :: [IfaceAxBranch] -> IfL [CoAxBranch] tc_ax_branches :: [IfaceAxBranch] -> IfL [CoAxBranch]
tc_ax_branches if_branches = foldlM tc_ax_branch [] if_branches tc_ax_branches if_branches = foldlM tc_ax_branch [] if_branches
......
...@@ -981,11 +981,7 @@ checkBootTyCon is_boot tc1 tc2 ...@@ -981,11 +981,7 @@ checkBootTyCon is_boot tc1 tc2
-- Checks kind of class -- Checks kind of class
check (eqListBy eqFD clas_fds1 clas_fds2) check (eqListBy eqFD clas_fds1 clas_fds2)
(text "The functional dependencies do not match") `andThenCheck` (text "The functional dependencies do not match") `andThenCheck`
checkUnless (null sc_theta1 && null op_stuff1 && null ats1) $ checkUnless (isAbstractTyCon tc1) $
-- Above tests for an "abstract" class.
-- This is duplicated in 'isAbstractIfaceDecl'
-- and also below near
-- Note [Constraint synonym implements abstract class]
check (eqListBy (eqTypeX env) sc_theta1 sc_theta2) check (eqListBy (eqTypeX env) sc_theta1 sc_theta2)
(text "The class constraints do not match") `andThenCheck` (text "The class constraints do not match") `andThenCheck`
checkListBy eqSig op_stuff1 op_stuff2 (text "methods") `andThenCheck` checkListBy eqSig op_stuff1 op_stuff2 (text "methods") `andThenCheck`
...