module GHC.Core.Class (
Class,
ClassOpItem,
ClassATItem(..), TyFamEqnValidityInfo(..),
ClassMinimalDef,
DefMethInfo, pprDefMethInfo,
FunDep, pprFundeps, pprFunDep,
mkClass, mkAbstractClass, classTyVars, classArity,
classKey, className, classATs, classATItems, classTyCon, classMethods,
classOpItems, classBigSig, classExtraBigSig, classTvsFds, classSCTheta,
classHasSCs, classAllSelIds, classSCSelId, classSCSelIds, classMinimalDef,
classHasFds, isAbstractClass,
) where
import GHC.Prelude
import {-# SOURCE #-} GHC.Core.TyCon ( TyCon )
import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type, PredType )
import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType )
import GHC.Types.Var
import GHC.Types.Name
import GHC.Types.Basic
import GHC.Types.Unique
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Types.SrcLoc
import GHC.Types.Var.Set
import GHC.Utils.Outputable
import GHC.Data.BooleanFormula (BooleanFormula, mkTrue)
import qualified Data.Data as Data
data Class
= Class {
Class -> TyCon
classTyCon :: TyCon,
Class -> Name
className :: Name,
Class -> Unique
classKey :: Unique,
Class -> [TyVar]
classTyVars :: [TyVar],
Class -> [FunDep TyVar]
classFunDeps :: [FunDep TyVar],
Class -> ClassBody
classBody :: ClassBody
}
type FunDep a = ([a],[a])
type ClassOpItem = (Id, DefMethInfo)
type DefMethInfo = Maybe (Name, DefMethSpec Type)
data ClassATItem
= ATI TyCon
(Maybe (Type, TyFamEqnValidityInfo))
data TyFamEqnValidityInfo
= NoVI
| VI
{ TyFamEqnValidityInfo -> SrcSpan
vi_loc :: SrcSpan
, TyFamEqnValidityInfo -> [TyVar]
vi_qtvs :: [TcTyVar]
, TyFamEqnValidityInfo -> TyVarSet
vi_non_user_tvs :: TyVarSet
, TyFamEqnValidityInfo -> [Type]
vi_pats :: [Type]
, TyFamEqnValidityInfo -> Type
vi_rhs :: Type
}
type ClassMinimalDef = BooleanFormula Name
data ClassBody
= AbstractClass
| ConcreteClass {
ClassBody -> [Type]
cls_sc_theta :: [PredType],
ClassBody -> [TyVar]
cls_sc_sel_ids :: [Id],
ClassBody -> [ClassATItem]
cls_ats :: [ClassATItem],
ClassBody -> [ClassOpItem]
cls_ops :: [ClassOpItem],
ClassBody -> ClassMinimalDef
cls_min_def :: ClassMinimalDef
}
classMinimalDef :: Class -> ClassMinimalDef
classMinimalDef :: Class -> ClassMinimalDef
classMinimalDef Class{ classBody :: Class -> ClassBody
classBody = ConcreteClass{ cls_min_def :: ClassBody -> ClassMinimalDef
cls_min_def = ClassMinimalDef
d } } = ClassMinimalDef
d
classMinimalDef Class
_ = ClassMinimalDef
forall a. BooleanFormula a
mkTrue
mkClass :: Name -> [TyVar]
-> [FunDep TyVar]
-> [PredType] -> [Id]
-> [ClassATItem]
-> [ClassOpItem]
-> ClassMinimalDef
-> TyCon
-> Class
mkClass :: Name
-> [TyVar]
-> [FunDep TyVar]
-> [Type]
-> [TyVar]
-> [ClassATItem]
-> [ClassOpItem]
-> ClassMinimalDef
-> TyCon
-> Class
mkClass Name
cls_name [TyVar]
tyvars [FunDep TyVar]
fds [Type]
super_classes [TyVar]
superdict_sels [ClassATItem]
at_stuff
[ClassOpItem]
op_stuff ClassMinimalDef
mindef TyCon
tycon
= Class { classKey :: Unique
classKey = Name -> Unique
nameUnique Name
cls_name,
className :: Name
className = Name
cls_name,
classTyVars :: [TyVar]
classTyVars = [TyVar]
tyvars,
classFunDeps :: [FunDep TyVar]
classFunDeps = [FunDep TyVar]
fds,
classBody :: ClassBody
classBody = ConcreteClass {
cls_sc_theta :: [Type]
cls_sc_theta = [Type]
super_classes,
cls_sc_sel_ids :: [TyVar]
cls_sc_sel_ids = [TyVar]
superdict_sels,
cls_ats :: [ClassATItem]
cls_ats = [ClassATItem]
at_stuff,
cls_ops :: [ClassOpItem]
cls_ops = [ClassOpItem]
op_stuff,
cls_min_def :: ClassMinimalDef
cls_min_def = ClassMinimalDef
mindef
},
classTyCon :: TyCon
classTyCon = TyCon
tycon }
mkAbstractClass :: Name -> [TyVar]
-> [FunDep TyVar]
-> TyCon
-> Class
mkAbstractClass :: Name -> [TyVar] -> [FunDep TyVar] -> TyCon -> Class
mkAbstractClass Name
cls_name [TyVar]
tyvars [FunDep TyVar]
fds TyCon
tycon
= Class { classKey :: Unique
classKey = Name -> Unique
nameUnique Name
cls_name,
className :: Name
className = Name
cls_name,
classTyVars :: [TyVar]
classTyVars = [TyVar]
tyvars,
classFunDeps :: [FunDep TyVar]
classFunDeps = [FunDep TyVar]
fds,
classBody :: ClassBody
classBody = ClassBody
AbstractClass,
classTyCon :: TyCon
classTyCon = TyCon
tycon }
classArity :: Class -> Arity
classArity :: Class -> Int
classArity Class
clas = [TyVar] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Class -> [TyVar]
classTyVars Class
clas)
classAllSelIds :: Class -> [Id]
classAllSelIds :: Class -> [TyVar]
classAllSelIds c :: Class
c@(Class { classBody :: Class -> ClassBody
classBody = ConcreteClass { cls_sc_sel_ids :: ClassBody -> [TyVar]
cls_sc_sel_ids = [TyVar]
sc_sels }})
= [TyVar]
sc_sels [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ Class -> [TyVar]
classMethods Class
c
classAllSelIds Class
c = Bool -> [TyVar] -> [TyVar]
forall a. HasCallStack => Bool -> a -> a
assert ([TyVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Class -> [TyVar]
classMethods Class
c) ) []
classSCSelIds :: Class -> [Id]
classSCSelIds :: Class -> [TyVar]
classSCSelIds (Class { classBody :: Class -> ClassBody
classBody = ConcreteClass { cls_sc_sel_ids :: ClassBody -> [TyVar]
cls_sc_sel_ids = [TyVar]
sc_sels }})
= [TyVar]
sc_sels
classSCSelIds Class
c = Bool -> [TyVar] -> [TyVar]
forall a. HasCallStack => Bool -> a -> a
assert ([TyVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Class -> [TyVar]
classMethods Class
c) ) []
classSCSelId :: Class -> Int -> Id
classSCSelId :: Class -> Int -> TyVar
classSCSelId (Class { classBody :: Class -> ClassBody
classBody = ConcreteClass { cls_sc_sel_ids :: ClassBody -> [TyVar]
cls_sc_sel_ids = [TyVar]
sc_sels } }) Int
n
= Bool -> [TyVar] -> [TyVar]
forall a. HasCallStack => Bool -> a -> a
assert (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& [TyVar] -> Int -> Bool
forall a. [a] -> Int -> Bool
lengthExceeds [TyVar]
sc_sels Int
n )
[TyVar]
sc_sels [TyVar] -> Int -> TyVar
forall a. HasCallStack => [a] -> Int -> a
!! Int
n
classSCSelId Class
c Int
n = String -> SDoc -> TyVar
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"classSCSelId" (Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
c SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
n)
classMethods :: Class -> [Id]
classMethods :: Class -> [TyVar]
classMethods (Class { classBody :: Class -> ClassBody
classBody = ConcreteClass { cls_ops :: ClassBody -> [ClassOpItem]
cls_ops = [ClassOpItem]
op_stuff } })
= [TyVar
op_sel | (TyVar
op_sel, DefMethInfo
_) <- [ClassOpItem]
op_stuff]
classMethods Class
_ = []
classOpItems :: Class -> [ClassOpItem]
classOpItems :: Class -> [ClassOpItem]
classOpItems (Class { classBody :: Class -> ClassBody
classBody = ConcreteClass { cls_ops :: ClassBody -> [ClassOpItem]
cls_ops = [ClassOpItem]
op_stuff }})
= [ClassOpItem]
op_stuff
classOpItems Class
_ = []
classATs :: Class -> [TyCon]
classATs :: Class -> [TyCon]
classATs (Class { classBody :: Class -> ClassBody
classBody = ConcreteClass { cls_ats :: ClassBody -> [ClassATItem]
cls_ats = [ClassATItem]
at_stuff } })
= [TyCon
tc | ATI TyCon
tc Maybe (Type, TyFamEqnValidityInfo)
_ <- [ClassATItem]
at_stuff]
classATs Class
_ = []
classATItems :: Class -> [ClassATItem]
classATItems :: Class -> [ClassATItem]
classATItems (Class { classBody :: Class -> ClassBody
classBody = ConcreteClass { cls_ats :: ClassBody -> [ClassATItem]
cls_ats = [ClassATItem]
at_stuff }})
= [ClassATItem]
at_stuff
classATItems Class
_ = []
classSCTheta :: Class -> [PredType]
classSCTheta :: Class -> [Type]
classSCTheta (Class { classBody :: Class -> ClassBody
classBody = ConcreteClass { cls_sc_theta :: ClassBody -> [Type]
cls_sc_theta = [Type]
theta_stuff }})
= [Type]
theta_stuff
classSCTheta Class
_ = []
classHasSCs :: Class -> Bool
classHasSCs :: Class -> Bool
classHasSCs Class
cls = Bool -> Bool
not ([Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Class -> [Type]
classSCTheta Class
cls))
classTvsFds :: Class -> ([TyVar], [FunDep TyVar])
classTvsFds :: Class -> ([TyVar], [FunDep TyVar])
classTvsFds Class
c = (Class -> [TyVar]
classTyVars Class
c, Class -> [FunDep TyVar]
classFunDeps Class
c)
classHasFds :: Class -> Bool
classHasFds :: Class -> Bool
classHasFds (Class { classFunDeps :: Class -> [FunDep TyVar]
classFunDeps = [FunDep TyVar]
fds }) = Bool -> Bool
not ([FunDep TyVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FunDep TyVar]
fds)
classBigSig :: Class -> ([TyVar], [PredType], [Id], [ClassOpItem])
classBigSig :: Class -> ([TyVar], [Type], [TyVar], [ClassOpItem])
classBigSig (Class {classTyVars :: Class -> [TyVar]
classTyVars = [TyVar]
tyvars,
classBody :: Class -> ClassBody
classBody = ClassBody
AbstractClass})
= ([TyVar]
tyvars, [], [], [])
classBigSig (Class {classTyVars :: Class -> [TyVar]
classTyVars = [TyVar]
tyvars,
classBody :: Class -> ClassBody
classBody = ConcreteClass {
cls_sc_theta :: ClassBody -> [Type]
cls_sc_theta = [Type]
sc_theta,
cls_sc_sel_ids :: ClassBody -> [TyVar]
cls_sc_sel_ids = [TyVar]
sc_sels,
cls_ops :: ClassBody -> [ClassOpItem]
cls_ops = [ClassOpItem]
op_stuff
}})
= ([TyVar]
tyvars, [Type]
sc_theta, [TyVar]
sc_sels, [ClassOpItem]
op_stuff)
classExtraBigSig :: Class -> ([TyVar], [FunDep TyVar], [PredType], [Id], [ClassATItem], [ClassOpItem])
(Class {classTyVars :: Class -> [TyVar]
classTyVars = [TyVar]
tyvars, classFunDeps :: Class -> [FunDep TyVar]
classFunDeps = [FunDep TyVar]
fundeps,
classBody :: Class -> ClassBody
classBody = ClassBody
AbstractClass})
= ([TyVar]
tyvars, [FunDep TyVar]
fundeps, [], [], [], [])
classExtraBigSig (Class {classTyVars :: Class -> [TyVar]
classTyVars = [TyVar]
tyvars, classFunDeps :: Class -> [FunDep TyVar]
classFunDeps = [FunDep TyVar]
fundeps,
classBody :: Class -> ClassBody
classBody = ConcreteClass {
cls_sc_theta :: ClassBody -> [Type]
cls_sc_theta = [Type]
sc_theta, cls_sc_sel_ids :: ClassBody -> [TyVar]
cls_sc_sel_ids = [TyVar]
sc_sels,
cls_ats :: ClassBody -> [ClassATItem]
cls_ats = [ClassATItem]
ats, cls_ops :: ClassBody -> [ClassOpItem]
cls_ops = [ClassOpItem]
op_stuff
}})
= ([TyVar]
tyvars, [FunDep TyVar]
fundeps, [Type]
sc_theta, [TyVar]
sc_sels, [ClassATItem]
ats, [ClassOpItem]
op_stuff)
isAbstractClass :: Class -> Bool
isAbstractClass :: Class -> Bool
isAbstractClass Class{ classBody :: Class -> ClassBody
classBody = ClassBody
AbstractClass } = Bool
True
isAbstractClass Class
_ = Bool
False
instance Eq Class where
Class
c1 == :: Class -> Class -> Bool
== Class
c2 = Class -> Unique
classKey Class
c1 Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Class -> Unique
classKey Class
c2
Class
c1 /= :: Class -> Class -> Bool
/= Class
c2 = Class -> Unique
classKey Class
c1 Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
/= Class -> Unique
classKey Class
c2
instance Uniquable Class where
getUnique :: Class -> Unique
getUnique Class
c = Class -> Unique
classKey Class
c
instance NamedThing Class where
getName :: Class -> Name
getName Class
clas = Class -> Name
className Class
clas
instance Outputable Class where
ppr :: Class -> SDoc
ppr Class
c = Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Class -> Name
forall a. NamedThing a => a -> Name
getName Class
c)
pprDefMethInfo :: DefMethInfo -> SDoc
pprDefMethInfo :: DefMethInfo -> SDoc
pprDefMethInfo DefMethInfo
Nothing = SDoc
forall doc. IsOutput doc => doc
empty
pprDefMethInfo (Just (Name
n, DefMethSpec Type
VanillaDM)) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Default method" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n
pprDefMethInfo (Just (Name
n, GenericDM Type
ty)) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Generic default method"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
pprType Type
ty
pprFundeps :: Outputable a => [FunDep a] -> SDoc
pprFundeps :: forall a. Outputable a => [FunDep a] -> SDoc
pprFundeps [] = SDoc
forall doc. IsOutput doc => doc
empty
pprFundeps [FunDep a]
fds = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep (SDoc
forall doc. IsLine doc => doc
vbar SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma ((FunDep a -> SDoc) -> [FunDep a] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map FunDep a -> SDoc
forall a. Outputable a => FunDep a -> SDoc
pprFunDep [FunDep a]
fds))
pprFunDep :: Outputable a => FunDep a -> SDoc
pprFunDep :: forall a. Outputable a => FunDep a -> SDoc
pprFunDep ([a]
us, [a]
vs) = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [[a] -> SDoc
forall a. Outputable a => [a] -> SDoc
interppSP [a]
us, SDoc
arrow, [a] -> SDoc
forall a. Outputable a => [a] -> SDoc
interppSP [a]
vs]
instance Data.Data Class where
toConstr :: Class -> Constr
toConstr Class
_ = String -> Constr
abstractConstr String
"Class"
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Class
gunfold forall b r. Data b => c (b -> r) -> c r
_ forall r. r -> c r
_ = String -> Constr -> c Class
forall a. HasCallStack => String -> a
error String
"gunfold"
dataTypeOf :: Class -> DataType
dataTypeOf Class
_ = String -> DataType
mkNoRepType String
"Class"