module Class (
Class,
ClassOpItem,
ClassATItem(..),
ClassMinimalDef,
DefMethInfo, pprDefMethInfo,
FunDep, pprFundeps, pprFunDep,
mkClass, mkAbstractClass, classTyVars, classArity,
classKey, className, classATs, classATItems, classTyCon, classMethods,
classOpItems, classBigSig, classExtraBigSig, classTvsFds, classSCTheta,
classAllSelIds, classSCSelId, classSCSelIds, classMinimalDef, classHasFds,
isAbstractClass,
) where
#include "HsVersions.h"
import GhcPrelude
import TyCon ( TyCon )
import TyCoRep ( Type, PredType )
import TyCoPpr ( pprType )
import Var
import Name
import BasicTypes
import Unique
import Util
import SrcLoc
import Outputable
import BooleanFormula (BooleanFormula, mkTrue)
import qualified Data.Data as Data
data Class
= Class {
classTyCon :: TyCon,
className :: Name,
classKey :: Unique,
classTyVars :: [TyVar],
classFunDeps :: [FunDep TyVar],
classBody :: ClassBody
}
type FunDep a = ([a],[a])
type ClassOpItem = (Id, DefMethInfo)
type DefMethInfo = Maybe (Name, DefMethSpec Type)
data ClassATItem
= ATI TyCon
(Maybe (Type, SrcSpan))
type ClassMinimalDef = BooleanFormula Name
data ClassBody
= AbstractClass
| ConcreteClass {
cls_sc_theta :: [PredType],
cls_sc_sel_ids :: [Id],
cls_ats :: [ClassATItem],
cls_ops :: [ClassOpItem],
cls_min_def :: ClassMinimalDef
}
classMinimalDef :: Class -> ClassMinimalDef
classMinimalDef Class{ classBody = ConcreteClass{ cls_min_def = d } } = d
classMinimalDef _ = mkTrue
mkClass :: Name -> [TyVar]
-> [FunDep TyVar]
-> [PredType] -> [Id]
-> [ClassATItem]
-> [ClassOpItem]
-> ClassMinimalDef
-> TyCon
-> Class
mkClass cls_name tyvars fds super_classes superdict_sels at_stuff
op_stuff mindef tycon
= Class { classKey = nameUnique cls_name,
className = cls_name,
classTyVars = tyvars,
classFunDeps = fds,
classBody = ConcreteClass {
cls_sc_theta = super_classes,
cls_sc_sel_ids = superdict_sels,
cls_ats = at_stuff,
cls_ops = op_stuff,
cls_min_def = mindef
},
classTyCon = tycon }
mkAbstractClass :: Name -> [TyVar]
-> [FunDep TyVar]
-> TyCon
-> Class
mkAbstractClass cls_name tyvars fds tycon
= Class { classKey = nameUnique cls_name,
className = cls_name,
classTyVars = tyvars,
classFunDeps = fds,
classBody = AbstractClass,
classTyCon = tycon }
classArity :: Class -> Arity
classArity clas = length (classTyVars clas)
classAllSelIds :: Class -> [Id]
classAllSelIds c@(Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels }})
= sc_sels ++ classMethods c
classAllSelIds c = ASSERT( null (classMethods c) ) []
classSCSelIds :: Class -> [Id]
classSCSelIds (Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels }})
= sc_sels
classSCSelIds c = ASSERT( null (classMethods c) ) []
classSCSelId :: Class -> Int -> Id
classSCSelId (Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels } }) n
= ASSERT( n >= 0 && lengthExceeds sc_sels n )
sc_sels !! n
classSCSelId c n = pprPanic "classSCSelId" (ppr c <+> ppr n)
classMethods :: Class -> [Id]
classMethods (Class { classBody = ConcreteClass { cls_ops = op_stuff } })
= [op_sel | (op_sel, _) <- op_stuff]
classMethods _ = []
classOpItems :: Class -> [ClassOpItem]
classOpItems (Class { classBody = ConcreteClass { cls_ops = op_stuff }})
= op_stuff
classOpItems _ = []
classATs :: Class -> [TyCon]
classATs (Class { classBody = ConcreteClass { cls_ats = at_stuff } })
= [tc | ATI tc _ <- at_stuff]
classATs _ = []
classATItems :: Class -> [ClassATItem]
classATItems (Class { classBody = ConcreteClass { cls_ats = at_stuff }})
= at_stuff
classATItems _ = []
classSCTheta :: Class -> [PredType]
classSCTheta (Class { classBody = ConcreteClass { cls_sc_theta = theta_stuff }})
= theta_stuff
classSCTheta _ = []
classTvsFds :: Class -> ([TyVar], [FunDep TyVar])
classTvsFds c = (classTyVars c, classFunDeps c)
classHasFds :: Class -> Bool
classHasFds (Class { classFunDeps = fds }) = not (null fds)
classBigSig :: Class -> ([TyVar], [PredType], [Id], [ClassOpItem])
classBigSig (Class {classTyVars = tyvars,
classBody = AbstractClass})
= (tyvars, [], [], [])
classBigSig (Class {classTyVars = tyvars,
classBody = ConcreteClass {
cls_sc_theta = sc_theta,
cls_sc_sel_ids = sc_sels,
cls_ops = op_stuff
}})
= (tyvars, sc_theta, sc_sels, op_stuff)
classExtraBigSig :: Class -> ([TyVar], [FunDep TyVar], [PredType], [Id], [ClassATItem], [ClassOpItem])
classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps,
classBody = AbstractClass})
= (tyvars, fundeps, [], [], [], [])
classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps,
classBody = ConcreteClass {
cls_sc_theta = sc_theta, cls_sc_sel_ids = sc_sels,
cls_ats = ats, cls_ops = op_stuff
}})
= (tyvars, fundeps, sc_theta, sc_sels, ats, op_stuff)
isAbstractClass :: Class -> Bool
isAbstractClass Class{ classBody = AbstractClass } = True
isAbstractClass _ = False
instance Eq Class where
c1 == c2 = classKey c1 == classKey c2
c1 /= c2 = classKey c1 /= classKey c2
instance Uniquable Class where
getUnique c = classKey c
instance NamedThing Class where
getName clas = className clas
instance Outputable Class where
ppr c = ppr (getName c)
pprDefMethInfo :: DefMethInfo -> SDoc
pprDefMethInfo Nothing = empty
pprDefMethInfo (Just (n, VanillaDM)) = text "Default method" <+> ppr n
pprDefMethInfo (Just (n, GenericDM ty)) = text "Generic default method"
<+> ppr n <+> dcolon <+> pprType ty
pprFundeps :: Outputable a => [FunDep a] -> SDoc
pprFundeps [] = empty
pprFundeps fds = hsep (vbar : punctuate comma (map pprFunDep fds))
pprFunDep :: Outputable a => FunDep a -> SDoc
pprFunDep (us, vs) = hsep [interppSP us, arrow, interppSP vs]
instance Data.Data Class where
toConstr _ = abstractConstr "Class"
gunfold _ _ = error "gunfold"
dataTypeOf _ = mkNoRepType "Class"