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

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
}
rnIfaceDecl d@IfaceClass{} = do
name <- rnIfaceGlobal (ifName d)
ctxt <- mapM rnIfaceType (ifCtxt d)
binders <- mapM rnIfaceTyConBinder (ifBinders d)
ats <- mapM rnIfaceAT (ifATs d)
sigs <- mapM rnIfaceClassOp (ifSigs d)
return d { ifName = name
, ifCtxt = ctxt
body <- rnIfaceClassBody (ifBody d)
return d { ifName = name
, ifBinders = binders
, ifATs = ats
, ifSigs = sigs
, ifBody = body
}
rnIfaceDecl d@IfaceAxiom{} = do
name <- rnIfaceNeverExported (ifName d)
......@@ -491,6 +487,14 @@ rnIfaceDecl d@IfacePatSyn{} = do
, 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 (IfaceClosedSynFamilyTyCon (Just (n, axs)))
= IfaceClosedSynFamilyTyCon . Just <$> ((,) <$> rnIfaceNeverExported n
......
......@@ -298,15 +298,28 @@ type TcMethInfo -- A temporary intermediate, to communicate
buildClass :: Name -- Name of the class/tycon (they have the same Name)
-> [TyConBinder] -- Of the tycon
-> [Role] -> ThetaType
-> [Role]
-> [FunDep TyVar] -- Functional dependencies
-> [ClassATItem] -- Associated types
-> [TcMethInfo] -- Method info
-> ClassMinimalDef -- Minimal complete definition
-- Super classes, associated types, method info, minimal complete def.
-- This is Nothing if the class is abstract.
-> Maybe (ThetaType, [ClassATItem], [TcMethInfo], ClassMinimalDef)
-> TcRnIf m n Class
buildClass tycon_name binders roles sc_theta
fds at_items sig_stuff mindef
buildClass tycon_name binders roles fds Nothing
= 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
do { traceIf (text "buildClass")
......@@ -365,12 +378,14 @@ buildClass tycon_name binders roles sc_theta
(mkTyConApp rec_tycon (mkTyVarTys univ_tvs))
rec_tycon
; rhs <- if use_newtype
then mkNewTyConRhs tycon_name rec_tycon dict_con
else if isCTupleTyConName tycon_name
then return (TupleTyCon { data_con = dict_con
, tup_sort = ConstraintTuple })
else return (mkDataTyConRhs [dict_con])
; rhs <- case () of
_ | use_newtype
-> mkNewTyConRhs tycon_name rec_tycon dict_con
| isCTupleTyConName tycon_name
-> return (TupleTyCon { data_con = dict_con
, tup_sort = ConstraintTuple })
| otherwise
-> return (mkDataTyConRhs [dict_con])
; let { tycon = mkClassTyCon tycon_name binders roles
rhs rec_clas tc_rep_name
......
......@@ -15,6 +15,7 @@ module IfaceSyn (
IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..),
IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..),
IfaceClassBody(..),
IfaceBang(..),
IfaceSrcBang(..), SrcUnpackedness(..), SrcStrictness(..),
IfaceAxBranch(..),
......@@ -138,14 +139,11 @@ data IfaceDecl
ifFamFlav :: IfaceFamTyConFlav,
ifFamInj :: Injectivity } -- injectivity information
| IfaceClass { ifCtxt :: IfaceContext, -- Superclasses
ifName :: IfaceTopBndr, -- Name of the class TyCon
| IfaceClass { ifName :: IfaceTopBndr, -- Name of the class TyCon
ifRoles :: [Role], -- Roles
ifBinders :: [IfaceTyConBinder],
ifFDs :: [FunDep IfLclName], -- Functional dependencies
ifATs :: [IfaceAT], -- Associated type families
ifSigs :: [IfaceClassOp], -- Method signatures
ifMinDef :: BooleanFormula IfLclName -- Minimal complete definition
ifFDs :: [FunDep IfLclName], -- Functional dependencies
ifBody :: IfaceClassBody -- Methods, superclasses, ATs
}
| IfaceAxiom { ifName :: IfaceTopBndr, -- Axiom name
......@@ -168,6 +166,17 @@ data IfaceDecl
ifPatTy :: IfaceType,
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
= IfNoParent
......@@ -389,10 +398,15 @@ ifaceDeclImplicitBndrs (IfaceData {ifName = tc_name, ifCons = cons })
IfNewTyCon cd -> mkNewTyCoOcc (occName tc_name) : ifaceConDeclImplicitBndrs cd
IfDataTyCon cds -> concatMap ifaceConDeclImplicitBndrs cds
ifaceDeclImplicitBndrs (IfaceClass { ifCtxt = sc_ctxt
, ifName = cls_tc_name
, ifSigs = sigs
, ifATs = ats })
ifaceDeclImplicitBndrs (IfaceClass { ifBody = IfAbstractClass })
= []
ifaceDeclImplicitBndrs (IfaceClass { ifName = cls_tc_name
, ifBody = IfConcreteClass {
ifClassCtxt = sc_ctxt,
ifSigs = sigs,
ifATs = ats
}})
= -- (possibly) newtype coercion
co_occs ++
-- data constructor (DataCon namespace)
......@@ -413,7 +427,7 @@ ifaceDeclImplicitBndrs (IfaceClass { ifCtxt = sc_ctxt
| otherwise = []
dcww_occ = mkDataConWorkerOcc dc_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 _ = []
......@@ -663,6 +677,13 @@ isIfaceDataInstance :: IfaceTyConParent -> Bool
isIfaceDataInstance IfNoParent = False
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
-- NB: pprIfaceDecl is also used for pretty-printing TyThings in GHCi
-- See Note [Pretty-printing TyThings] in PprTyThing
......@@ -718,17 +739,26 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
pp_extra = vcat [pprCType ctype]
pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs
, ifCtxt = context, ifName = clas
pprIfaceDecl ss (IfaceClass { ifName = clas
, ifRoles = roles
, ifFDs = fds, ifMinDef = minDef
, ifBinders = binders })
= vcat [ pprRoles
(== Nominal)
(pprPrefixIfDeclBndr (ss_how_much ss) (occName clas))
binders
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 { ifName = clas
, ifRoles = roles
, ifFDs = fds
, ifBinders = binders
, ifBody = IfConcreteClass {
ifATs = ats,
ifSigs = sigs,
ifClassCtxt = context,
ifMinDef = minDef
}})
= vcat [ pprClassRoles ss clas binders roles
, text "class" <+> pprIfaceDeclHead context ss clas binders Nothing
<+> pprFundeps fds <+> pp_where
, nest 2 (vcat [ vcat asocs, vcat dsigs
......@@ -1246,11 +1276,13 @@ freeNamesIfDecl d@IfaceFamily{} =
freeNamesIfFamFlav (ifFamFlav d) &&&
freeNamesIfTyVarBndrs (ifBinders d) &&&
freeNamesIfKind (ifResKind d)
freeNamesIfDecl d@IfaceClass{} =
freeNamesIfContext (ifCtxt d) &&&
freeNamesIfDecl d@IfaceClass{ ifBody = IfAbstractClass } =
freeNamesIfTyVarBndrs (ifBinders d)
freeNamesIfDecl d@IfaceClass{ ifBody = d'@IfConcreteClass{} } =
freeNamesIfTyVarBndrs (ifBinders d) &&&
fnList freeNamesIfAT (ifATs d) &&&
fnList freeNamesIfClsSig (ifSigs d)
freeNamesIfContext (ifClassCtxt d') &&&
fnList freeNamesIfAT (ifATs d') &&&
fnList freeNamesIfClsSig (ifSigs d')
freeNamesIfDecl d@IfaceAxiom{} =
freeNamesIfTc (ifTyCon d) &&&
fnList freeNamesIfAxBranch (ifAxBranches d)
......@@ -1566,7 +1598,18 @@ instance Binary IfaceDecl where
put_ bh a5
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
put_ bh a1
putIfaceTopBndr bh a2
......@@ -1598,6 +1641,18 @@ instance Binary IfaceDecl where
put_ bh a10
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
h <- getByte bh
case h of
......@@ -1638,7 +1693,17 @@ instance Binary IfaceDecl where
a6 <- get bh
a7 <- 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
a2 <- get bh
a3 <- get bh
......@@ -1656,6 +1721,16 @@ instance Binary IfaceDecl where
a10 <- get bh
a11 <- get bh
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])
instance Binary IfaceFamTyConFlav where
......
......@@ -931,7 +931,7 @@ declExtras fix_fn ann_fn rule_env inst_env fi_env decl
map ifDFun (lookupOccEnvL inst_env n))
(ann_fn n)
(map (id_extras . occName . ifConName) (visibleIfConDecls cons))
IfaceClass{ifSigs=sigs, ifATs=ats} ->
IfaceClass{ifBody = IfConcreteClass { ifSigs=sigs, ifATs=ats }} ->
IfaceClassExtras (fix_fn n)
(map ifDFun $ (concatMap at_extras ats)
++ lookupOccEnvL inst_env n)
......@@ -1668,19 +1668,25 @@ tyConToIfaceDecl env tycon
classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl)
classToIfaceDecl env clas
= ( env1
, IfaceClass { ifCtxt = tidyToIfaceContext env1 sc_theta,
ifName = getName tycon,
, IfaceClass { ifName = getName tycon,
ifRoles = tyConRoles (classTyCon clas),
ifBinders = toIfaceTyVarBinders tc_binders,
ifFDs = map toIfaceFD clas_fds,
ifATs = map toIfaceAT clas_ats,
ifSigs = map toIfaceClassOp op_stuff,
ifMinDef = fmap getOccFS (classMinimalDef clas) })
ifBody = body,
ifFDs = map toIfaceFD clas_fds })
where
(_, clas_fds, sc_theta, _, clas_ats, op_stuff)
= classExtraBigSig 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)
toIfaceAT :: ClassATItem -> IfaceAT
......
......@@ -208,7 +208,7 @@ typecheckIface iface
-- | Returns true if an 'IfaceDecl' is for @data T@ (an abstract data type)
isAbstractIfaceDecl :: IfaceDecl -> Bool
isAbstractIfaceDecl IfaceData{ ifCons = IfAbstractTyCon } = True
isAbstractIfaceDecl IfaceClass{ ifCtxt = [], ifSigs = [], ifATs = [] } = True
isAbstractIfaceDecl IfaceClass{ ifBody = IfAbstractClass } = True
isAbstractIfaceDecl IfaceFamily{ ifFamFlav = IfaceAbstractClosedSynFamilyTyCon } = True
isAbstractIfaceDecl _ = False
......@@ -223,21 +223,22 @@ ifMaybeRoles _ = Nothing
-- later.)
mergeIfaceDecl :: IfaceDecl -> IfaceDecl -> IfaceDecl
mergeIfaceDecl d1 d2
-- TODO: need to merge roles
| isAbstractIfaceDecl d1 = d2 `withRolesFrom` d1
| isAbstractIfaceDecl d2 = d1 `withRolesFrom` d2
| IfaceClass{ ifSigs = ops1, ifMinDef = bf1 } <- d1
, IfaceClass{ ifSigs = ops2, ifMinDef = bf2 } <- d2
| IfaceClass{ ifBody = IfConcreteClass { ifSigs = ops1, ifMinDef = bf1 } } <- d1
, IfaceClass{ ifBody = IfConcreteClass { ifSigs = ops2, ifMinDef = bf2 } } <- d2
= let ops = nameEnvElts $
plusNameEnv_C mergeIfaceClassOp
(mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops1 ])
(mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops2 ])
in d1 { ifSigs = ops
, ifMinDef = BF.mkOr [noLoc bf1, noLoc bf2]
} `withRolesFrom` d2
in d1 { ifBody = (ifBody d1) {
ifSigs = ops,
ifMinDef = BF.mkOr [noLoc bf1, noLoc bf2]
}
}
-- It doesn't matter; we'll check for consistency later when
-- we merge, see 'mergeSignatures'
| otherwise = d1 `withRolesFrom` d2
| otherwise = d1
withRolesFrom :: IfaceDecl -> IfaceDecl -> IfaceDecl
d1 `withRolesFrom` d2
......@@ -677,15 +678,27 @@ tc_iface_decl parent _ (IfaceFamily {ifName = tc_name,
= pprPanic "tc_iface_decl"
(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
(IfaceClass {ifCtxt = rdr_ctxt, ifName = tc_name,
(IfaceClass {ifName = tc_name,
ifRoles = roles,
ifBinders = binders,
ifFDs = rdr_fds,
ifATs = rdr_ats, ifSigs = rdr_sigs,
ifMinDef = mindef_occ })
-- ToDo: in hs-boot files we should really treat abstract classes specially,
-- as we do abstract tycons
ifBody = IfConcreteClass {
ifClassCtxt = rdr_ctxt,
ifATs = rdr_ats, ifSigs = rdr_sigs,
ifMinDef = mindef_occ
}})
= bindIfaceTyConBinders binders $ \ binders' -> do
{ traceIf (text "tc-iface-class1" <+> ppr tc_name)
; ctxt <- mapM tc_sc rdr_ctxt
......@@ -697,7 +710,7 @@ tc_iface_decl _parent ignore_prags
; cls <- fixM $ \ cls -> do
{ ats <- mapM (tc_at cls) rdr_ats
; 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)) }
where
tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred)
......@@ -746,10 +759,6 @@ tc_iface_decl _parent ignore_prags
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]
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
, ifAxBranches = branches, ifRole = role })
= do { tc_tycon <- tcIfaceTyCon tc
......@@ -794,6 +803,11 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = name
tc_pr (nm, b) = do { id <- forkM (ppr nm) (tcIfaceExtId nm)
; 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 if_branches = foldlM tc_ax_branch [] if_branches
......
......@@ -981,11 +981,7 @@ checkBootTyCon is_boot tc1 tc2
-- Checks kind of class
check (eqListBy eqFD clas_fds1 clas_fds2)
(text "The functional dependencies do not match") `andThenCheck`
checkUnless (null sc_theta1 && null op_stuff1 && null ats1) $
-- Above tests for an "abstract" class.
-- This is duplicated in 'isAbstractIfaceDecl'
-- and also below near
-- Note [Constraint synonym implements abstract class]
checkUnless (isAbstractTyCon tc1) $
check (eqListBy (eqTypeX env) sc_theta1 sc_theta2)
(text "The class constraints do not match") `andThenCheck`
checkListBy eqSig op_stuff1 op_stuff2 (text "methods") `andThenCheck`
......@@ -1001,26 +997,15 @@ checkBootTyCon is_boot tc1 tc2
check (eqTypeX env syn_rhs1 syn_rhs2) empty -- nothing interesting to say
-- This allows abstract 'data T a' to be implemented using 'type T = ...'
-- and abstract 'class K a' to be implement using 'type K = ...'
-- See Note [Synonyms implement abstract data]
| not is_boot -- don't support for hs-boot yet
, isAbstractTyCon tc1
, Just (tvs, ty) <- synTyConDefn_maybe tc2
, Just (tc2', args) <- tcSplitTyConApp_maybe ty
= checkSynAbsData tvs ty tc2' args
-- This allows abstract 'class C a' to be implemented using 'type C = ...'
-- This was originally requested in #12679.
-- See Note [Synonyms implement abstract data]
| not is_boot -- don't support for hs-boot yet
, Just c1 <- tyConClass_maybe tc1
, let (_, _clas_fds1, sc_theta1, _, ats1, op_stuff1)
= classExtraBigSig c1
-- Is it abstract?
, null sc_theta1 && null op_stuff1 && null ats1
, Just (tvs, ty) <- synTyConDefn_maybe tc2
, Just (tc2', args) <- tcSplitTyConApp_maybe ty
= checkSynAbsData tvs ty tc2' args
-- TODO: We really should check if the fundeps are satisfied, but
-- TODO: When it's a synonym implementing a class, we really
-- should check if the fundeps are satisfied, but
-- there is not an obvious way to do this for a constraint synonym.
-- So for now, let it all through (it won't cause segfaults, anyway).
-- Tracked at #12704.
......
......@@ -763,10 +763,15 @@ tcTyClDecl1 _parent roles_info
; sig_stuff <- tcClassSigs class_name sigs meths
; at_stuff <- tcClassATs class_name clas ats at_defs
; mindef <- tcClassMinimalDef class_name sigs sig_stuff
; clas <- buildClass
class_name binders roles ctxt'
fds' at_stuff
sig_stuff mindef
-- TODO: Allow us to distinguish between abstract class,
-- and concrete class with no methods (maybe by
-- specifying a trailing where or not
; is_boot <- tcIsHsBootOrSig
; let body | is_boot, null ctxt', null at_stuff, null sig_stuff
= Nothing
| otherwise
= Just (ctxt', at_stuff, sig_stuff, mindef)
; clas <- buildClass class_name binders roles fds' body
; traceTc "tcClassDecl" (ppr fundeps $$ ppr binders $$
ppr fds')
; return clas }
......
......@@ -14,7 +14,7 @@ module Class (
FunDep, pprFundeps, pprFunDep,
mkClass, classTyVars, classArity,
mkClass, mkAbstractClass, classTyVars, classArity,
classKey, className, classATs, classATItems, classTyCon, classMethods,
classOpItems, classBigSig, classExtraBigSig, classTvsFds, classSCTheta,
classAllSelIds, classSCSelId, classMinimalDef, classHasFds,
......@@ -34,7 +34,7 @@ import SrcLoc
import PrelNames ( eqTyConKey, coercibleTyConKey, typeableClassKey,
heqTyConKey )
import Outputable
import BooleanFormula (BooleanFormula)
import BooleanFormula (BooleanFormula, mkTrue)
import qualified Data.Data as Data
......@@ -62,21 +62,8 @@ data Class
classFunDeps :: [FunDep TyVar], -- The functional dependencies
-- Superclasses: eg: (F a ~ b, F b ~ G a, Eq a, Show b)
-- We need value-level selectors for both the dictionary
-- superclasses and the equality superclasses
classSCTheta :: [PredType], -- Immediate superclasses,
classSCSels :: [Id], -- Selector functions to extract the
-- superclasses from a
-- dictionary of this class
-- Associated types
classATStuff :: [ClassATItem], -- Associated type families
-- Class operations (methods, not superclasses)
classOpStuff :: [ClassOpItem], -- Ordered by tag
classBody :: ClassBody -- Superclasses, ATs, methods
-- Minimal complete definition
classMinimalDef :: ClassMinimalDef
}
-- | e.g.
......@@ -110,6 +97,31 @@ data ClassATItem
type ClassMinimalDef = BooleanFormula Name -- Required methods
data ClassBody
= AbstractClass
| ConcreteClass {
-- Superclasses: eg: (F a ~ b, F b ~ G a, Eq a, Show b)
-- We need value-level selectors for both the dictionary
-- superclasses and the equality superclasses
classSCThetaStuff :: [PredType], -- Immediate superclasses,
classSCSels :: [Id], -- Selector functions to extract the
-- superclasses from a
-- dictionary of this class
-- Associated types
classATStuff :: [ClassATItem], -- Associated type families
-- Class operations (methods, not superclasses)
classOpStuff :: [ClassOpItem], -- Ordered by tag
-- Minimal complete definition
classMinimalDefStuff :: ClassMinimalDef
}
-- TODO: maybe super classes should be allowed in abstract class definitions
classMinimalDef :: Class -> ClassMinimalDef
classMinimalDef Class{ classBody = ConcreteClass{ classMinimalDefStuff = d } } = d
classMinimalDef _ = mkTrue -- TODO: make sure this is the right direction
{-
Note [Associated type defaults]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -164,11 +176,28 @@ mkClass cls_name tyvars fds super_classes superdict_sels at_stuff
-- But it takes a module loop to assert it here
classTyVars = tyvars,
classFunDeps = fds,
classSCTheta = super_classes,
classSCSels = superdict_sels,
classATStuff = at_stuff,
classOpStuff = op_stuff,
classMinimalDef = mindef,
classBody = ConcreteClass {
classSCThetaStuff = super_classes,
classSCSels = superdict_sels,
classATStuff = at_stuff,
classOpStuff = op_stuff,
classMinimalDefStuff = mindef
},
classTyCon = tycon }
mkAbstractClass :: Name -> [TyVar]
-> [FunDep TyVar]
-> TyCon
-> Class
mkAbstractClass cls_name tyvars fds tycon
= Class { classKey = nameUnique cls_name,
className = cls_name,
-- NB: tyConName tycon = cls_name,
-- But it takes a module loop to assert it here
classTyVars = tyvars,
classFunDeps = fds,
classBody = AbstractClass,
classTyCon = tycon }
{-
......@@ -206,30 +235,43 @@ classArity clas = length (classTyVars clas)
classAllSelIds :: Class -> [Id]
-- Both superclass-dictionary and method selectors
classAllSelIds c@(Class {classSCSels = sc_sels})
classAllSelIds c@(Class { classBody = ConcreteClass { classSCSels = sc_sels }})
= sc_sels ++ classMethods c
classAllSelIds c = ASSERT( null (classMethods c) ) []
classSCSelId :: Class -> Int -> Id
-- Get the n'th superclass selector Id
-- where n is 0-indexed, and counts
-- *all* superclasses including equalities
classSCSelId (Class { classSCSels = sc_sels }) n