module GHC.Core.Class (
Class,
ClassOpItem,
ClassATItem(..), ATValidityInfo(..),
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
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.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, ATValidityInfo))
data ATValidityInfo
= NoATVI
| ATVI SrcSpan [Type]
type ClassMinimalDef = BooleanFormula Name
data ClassBody
= AbstractClass
| ConcreteClass {
ClassBody -> [PredType]
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]
-> [PredType]
-> [TyVar]
-> [ClassATItem]
-> [ClassOpItem]
-> ClassMinimalDef
-> TyCon
-> Class
mkClass Name
cls_name [TyVar]
tyvars [FunDep TyVar]
fds [PredType]
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 :: [PredType]
cls_sc_theta = [PredType]
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
<+> 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 (PredType, ATValidityInfo)
_ <- [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 -> [PredType]
classSCTheta (Class { classBody :: Class -> ClassBody
classBody = ConcreteClass { cls_sc_theta :: ClassBody -> [PredType]
cls_sc_theta = [PredType]
theta_stuff }})
= [PredType]
theta_stuff
classSCTheta Class
_ = []
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], [PredType], [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 -> [PredType]
cls_sc_theta = [PredType]
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, [PredType]
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 -> [PredType]
cls_sc_theta = [PredType]
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, [PredType]
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
empty
pprDefMethInfo (Just (Name
n, DefMethSpec PredType
VanillaDM)) = String -> SDoc
text String
"Default method" SDoc -> SDoc -> SDoc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n
pprDefMethInfo (Just (Name
n, GenericDM PredType
ty)) = String -> SDoc
text String
"Generic default method"
SDoc -> SDoc -> SDoc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> PredType -> SDoc
pprType PredType
ty
pprFundeps :: Outputable a => [FunDep a] -> SDoc
pprFundeps :: forall a. Outputable a => [FunDep a] -> SDoc
pprFundeps [] = SDoc
empty
pprFundeps [FunDep a]
fds = [SDoc] -> SDoc
hsep (SDoc
vbar SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
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
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"