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.Hs.Extension (GhcRn)
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.Types.SrcLoc
import GHC.Types.Var.Set
import GHC.Utils.Outputable
import Language.Haskell.Syntax.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 GhcRn
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 p. BooleanFormula p
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"