module GHC.Types.TyThing
( TyThing (..)
, MonadThings (..)
, mkATyCon
, mkAnId
, pprShortTyThing
, pprTyThingCategory
, tyThingCategory
, implicitTyThings
, implicitConLikeThings
, implicitClassThings
, implicitTyConThings
, implicitCoTyCon
, isImplicitTyThing
, tyThingParent_maybe
, tyThingsTyCoVars
, tyThingAvailInfo
, tyThingTyCon
, tyThingCoAxiom
, tyThingDataCon
, tyThingConLike
, tyThingId
)
where
import GHC.Prelude
import GHC.Types.Name
import GHC.Types.Var
import GHC.Types.Var.Set
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Avail
import GHC.Core.Class
import GHC.Core.DataCon
import GHC.Core.ConLike
import GHC.Core.PatSyn
import GHC.Core.TyCo.FVs
import GHC.Core.TyCon
import GHC.Core.Coercion.Axiom
import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Utils.Panic
import Control.Monad ( liftM )
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Class
data TyThing
= AnId Id
| AConLike ConLike
| ATyCon TyCon
| ACoAxiom (CoAxiom Branched)
instance Outputable TyThing where
ppr :: TyThing -> SDoc
ppr = TyThing -> SDoc
pprShortTyThing
instance NamedThing TyThing where
getName :: TyThing -> Name
getName (AnId Id
id) = Id -> Name
forall a. NamedThing a => a -> Name
getName Id
id
getName (ATyCon TyCon
tc) = TyCon -> Name
forall a. NamedThing a => a -> Name
getName TyCon
tc
getName (ACoAxiom CoAxiom Branched
cc) = CoAxiom Branched -> Name
forall a. NamedThing a => a -> Name
getName CoAxiom Branched
cc
getName (AConLike ConLike
cl) = ConLike -> Name
conLikeName ConLike
cl
mkATyCon :: TyCon -> TyThing
mkATyCon :: TyCon -> TyThing
mkATyCon = TyCon -> TyThing
ATyCon
mkAnId :: Id -> TyThing
mkAnId :: Id -> TyThing
mkAnId = Id -> TyThing
AnId
pprShortTyThing :: TyThing -> SDoc
pprShortTyThing :: TyThing -> SDoc
pprShortTyThing TyThing
thing
= TyThing -> SDoc
pprTyThingCategory TyThing
thing SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyThing -> Name
forall a. NamedThing a => a -> Name
getName TyThing
thing))
pprTyThingCategory :: TyThing -> SDoc
pprTyThingCategory :: TyThing -> SDoc
pprTyThingCategory = String -> SDoc
forall doc. IsLine doc => String -> doc
text (String -> SDoc) -> (TyThing -> String) -> TyThing -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
capitalise (String -> String) -> (TyThing -> String) -> TyThing -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyThing -> String
tyThingCategory
tyThingCategory :: TyThing -> String
tyThingCategory :: TyThing -> String
tyThingCategory (ATyCon TyCon
tc)
| TyCon -> Bool
isClassTyCon TyCon
tc = String
"class"
| Bool
otherwise = String
"type constructor"
tyThingCategory (ACoAxiom CoAxiom Branched
_) = String
"coercion axiom"
tyThingCategory (AnId Id
_) = String
"identifier"
tyThingCategory (AConLike (RealDataCon DataCon
_)) = String
"data constructor"
tyThingCategory (AConLike (PatSynCon PatSyn
_)) = String
"pattern synonym"
implicitTyThings :: TyThing -> [TyThing]
implicitTyThings :: TyThing -> [TyThing]
implicitTyThings (AnId Id
_) = []
implicitTyThings (ACoAxiom CoAxiom Branched
_cc) = []
implicitTyThings (ATyCon TyCon
tc) = TyCon -> [TyThing]
implicitTyConThings TyCon
tc
implicitTyThings (AConLike ConLike
cl) = ConLike -> [TyThing]
implicitConLikeThings ConLike
cl
implicitConLikeThings :: ConLike -> [TyThing]
implicitConLikeThings :: ConLike -> [TyThing]
implicitConLikeThings (RealDataCon DataCon
dc)
= DataCon -> [TyThing]
dataConImplicitTyThings DataCon
dc
implicitConLikeThings (PatSynCon {})
= []
implicitClassThings :: Class -> [TyThing]
implicitClassThings :: Class -> [TyThing]
implicitClassThings Class
cl
=
(TyCon -> TyThing) -> [TyCon] -> [TyThing]
forall a b. (a -> b) -> [a] -> [b]
map TyCon -> TyThing
ATyCon (Class -> [TyCon]
classATs Class
cl) [TyThing] -> [TyThing] -> [TyThing]
forall a. [a] -> [a] -> [a]
++
(Id -> TyThing) -> [Id] -> [TyThing]
forall a b. (a -> b) -> [a] -> [b]
map Id -> TyThing
AnId (Class -> [Id]
classAllSelIds Class
cl)
implicitTyConThings :: TyCon -> [TyThing]
implicitTyConThings :: TyCon -> [TyThing]
implicitTyConThings TyCon
tc
= [TyThing]
class_stuff [TyThing] -> [TyThing] -> [TyThing]
forall a. [a] -> [a] -> [a]
++
TyCon -> [TyThing]
implicitCoTyCon TyCon
tc [TyThing] -> [TyThing] -> [TyThing]
forall a. [a] -> [a] -> [a]
++
[TyThing]
datacon_stuff
where
class_stuff :: [TyThing]
class_stuff = case TyCon -> Maybe Class
tyConClass_maybe TyCon
tc of
Maybe Class
Nothing -> []
Just Class
cl -> Class -> [TyThing]
implicitClassThings Class
cl
datacon_stuff :: [TyThing]
datacon_stuff :: [TyThing]
datacon_stuff
| TyCon -> Bool
isTypeDataTyCon TyCon
tc = [TyCon -> TyThing
ATyCon (DataCon -> TyCon
promoteDataCon DataCon
dc) | DataCon
dc <- [DataCon]
cons]
| Bool
otherwise
= [TyThing
ty_thing | DataCon
dc <- [DataCon]
cons,
TyThing
ty_thing <- ConLike -> TyThing
AConLike (DataCon -> ConLike
RealDataCon DataCon
dc) TyThing -> [TyThing] -> [TyThing]
forall a. a -> [a] -> [a]
:
DataCon -> [TyThing]
dataConImplicitTyThings DataCon
dc]
cons :: [DataCon]
cons :: [DataCon]
cons = TyCon -> [DataCon]
tyConDataCons TyCon
tc
implicitCoTyCon :: TyCon -> [TyThing]
implicitCoTyCon :: TyCon -> [TyThing]
implicitCoTyCon TyCon
tc
| Just CoAxiom Unbranched
co <- TyCon -> Maybe (CoAxiom Unbranched)
newTyConCo_maybe TyCon
tc = [CoAxiom Branched -> TyThing
ACoAxiom (CoAxiom Branched -> TyThing) -> CoAxiom Branched -> TyThing
forall a b. (a -> b) -> a -> b
$ CoAxiom Unbranched -> CoAxiom Branched
forall (br :: BranchFlag). CoAxiom br -> CoAxiom Branched
toBranchedAxiom CoAxiom Unbranched
co]
| Just CoAxiom Branched
co <- TyCon -> Maybe (CoAxiom Branched)
isClosedSynFamilyTyConWithAxiom_maybe TyCon
tc
= [CoAxiom Branched -> TyThing
ACoAxiom CoAxiom Branched
co]
| Bool
otherwise = []
isImplicitTyThing :: TyThing -> Bool
isImplicitTyThing :: TyThing -> Bool
isImplicitTyThing (AConLike ConLike
cl) = case ConLike
cl of
RealDataCon {} -> Bool
True
PatSynCon {} -> Bool
False
isImplicitTyThing (AnId Id
id) = Id -> Bool
isImplicitId Id
id
isImplicitTyThing (ATyCon TyCon
tc) = TyCon -> Bool
isImplicitTyCon TyCon
tc
isImplicitTyThing (ACoAxiom CoAxiom Branched
ax) = CoAxiom Branched -> Bool
forall (br :: BranchFlag). CoAxiom br -> Bool
isImplicitCoAxiom CoAxiom Branched
ax
tyThingParent_maybe :: TyThing -> Maybe TyThing
tyThingParent_maybe :: TyThing -> Maybe TyThing
tyThingParent_maybe (AConLike ConLike
cl) = case ConLike
cl of
RealDataCon DataCon
dc -> TyThing -> Maybe TyThing
forall a. a -> Maybe a
Just (TyCon -> TyThing
ATyCon (DataCon -> TyCon
dataConTyCon DataCon
dc))
PatSynCon{} -> Maybe TyThing
forall a. Maybe a
Nothing
tyThingParent_maybe (ATyCon TyCon
tc)
|
Just DataCon
dc <- TyCon -> Maybe DataCon
isPromotedDataCon_maybe TyCon
tc
, let parent_tc :: TyCon
parent_tc = DataCon -> TyCon
dataConTyCon DataCon
dc
, TyCon -> Bool
isTypeDataTyCon TyCon
parent_tc
= TyThing -> Maybe TyThing
forall a. a -> Maybe a
Just (TyCon -> TyThing
ATyCon TyCon
parent_tc)
| Just TyCon
tc <- TyCon -> Maybe TyCon
tyConAssoc_maybe TyCon
tc
= TyThing -> Maybe TyThing
forall a. a -> Maybe a
Just (TyCon -> TyThing
ATyCon TyCon
tc)
| Bool
otherwise
= Maybe TyThing
forall a. Maybe a
Nothing
tyThingParent_maybe (AnId Id
id) = case Id -> IdDetails
idDetails Id
id of
RecSelId { sel_tycon :: IdDetails -> RecSelParent
sel_tycon = RecSelData TyCon
tc } ->
TyThing -> Maybe TyThing
forall a. a -> Maybe a
Just (TyCon -> TyThing
ATyCon TyCon
tc)
RecSelId { sel_tycon :: IdDetails -> RecSelParent
sel_tycon = RecSelPatSyn PatSyn
ps } ->
TyThing -> Maybe TyThing
forall a. a -> Maybe a
Just (ConLike -> TyThing
AConLike (PatSyn -> ConLike
PatSynCon PatSyn
ps))
ClassOpId Class
cls ->
TyThing -> Maybe TyThing
forall a. a -> Maybe a
Just (TyCon -> TyThing
ATyCon (Class -> TyCon
classTyCon Class
cls))
IdDetails
_other -> Maybe TyThing
forall a. Maybe a
Nothing
tyThingParent_maybe TyThing
_other = Maybe TyThing
forall a. Maybe a
Nothing
tyThingsTyCoVars :: [TyThing] -> TyCoVarSet
tyThingsTyCoVars :: [TyThing] -> TyCoVarSet
tyThingsTyCoVars [TyThing]
tts =
[TyCoVarSet] -> TyCoVarSet
unionVarSets ([TyCoVarSet] -> TyCoVarSet) -> [TyCoVarSet] -> TyCoVarSet
forall a b. (a -> b) -> a -> b
$ (TyThing -> TyCoVarSet) -> [TyThing] -> [TyCoVarSet]
forall a b. (a -> b) -> [a] -> [b]
map TyThing -> TyCoVarSet
ttToVarSet [TyThing]
tts
where
ttToVarSet :: TyThing -> TyCoVarSet
ttToVarSet (AnId Id
id) = Type -> TyCoVarSet
tyCoVarsOfType (Type -> TyCoVarSet) -> Type -> TyCoVarSet
forall a b. (a -> b) -> a -> b
$ Id -> Type
idType Id
id
ttToVarSet (AConLike ConLike
cl) = case ConLike
cl of
RealDataCon DataCon
dc -> Type -> TyCoVarSet
tyCoVarsOfType (Type -> TyCoVarSet) -> Type -> TyCoVarSet
forall a b. (a -> b) -> a -> b
$ DataCon -> Type
dataConRepType DataCon
dc
PatSynCon{} -> TyCoVarSet
emptyVarSet
ttToVarSet (ATyCon TyCon
tc)
= case TyCon -> Maybe Class
tyConClass_maybe TyCon
tc of
Just Class
cls -> ([Id] -> TyCoVarSet
mkVarSet ([Id] -> TyCoVarSet) -> (Class -> [Id]) -> Class -> TyCoVarSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Id], [FunDep Id]) -> [Id]
forall a b. (a, b) -> a
fst (([Id], [FunDep Id]) -> [Id])
-> (Class -> ([Id], [FunDep Id])) -> Class -> [Id]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> ([Id], [FunDep Id])
classTvsFds) Class
cls
Maybe Class
Nothing -> Type -> TyCoVarSet
tyCoVarsOfType (Type -> TyCoVarSet) -> Type -> TyCoVarSet
forall a b. (a -> b) -> a -> b
$ TyCon -> Type
tyConKind TyCon
tc
ttToVarSet (ACoAxiom CoAxiom Branched
_) = TyCoVarSet
emptyVarSet
tyThingAvailInfo :: TyThing -> [AvailInfo]
tyThingAvailInfo :: TyThing -> [AvailInfo]
tyThingAvailInfo (ATyCon TyCon
t)
= case TyCon -> Maybe Class
tyConClass_maybe TyCon
t of
Just Class
c -> [Name -> [Name] -> [FieldLabel] -> AvailInfo
availTC Name
n ((Name
n Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: (Id -> Name) -> [Id] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Name
forall a. NamedThing a => a -> Name
getName (Class -> [Id]
classMethods Class
c)
[Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ (TyCon -> Name) -> [TyCon] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyCon -> Name
forall a. NamedThing a => a -> Name
getName (Class -> [TyCon]
classATs Class
c))) [] ]
where n :: Name
n = Class -> Name
forall a. NamedThing a => a -> Name
getName Class
c
Maybe Class
Nothing -> [Name -> [Name] -> [FieldLabel] -> AvailInfo
availTC Name
n (Name
n Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: (DataCon -> Name) -> [DataCon] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> Name
forall a. NamedThing a => a -> Name
getName [DataCon]
dcs) [FieldLabel]
flds]
where n :: Name
n = TyCon -> Name
forall a. NamedThing a => a -> Name
getName TyCon
t
dcs :: [DataCon]
dcs = TyCon -> [DataCon]
tyConDataCons TyCon
t
flds :: [FieldLabel]
flds = TyCon -> [FieldLabel]
tyConFieldLabels TyCon
t
tyThingAvailInfo (AConLike (PatSynCon PatSyn
p))
= Name -> AvailInfo
avail (PatSyn -> Name
forall a. NamedThing a => a -> Name
getName PatSyn
p) AvailInfo -> [AvailInfo] -> [AvailInfo]
forall a. a -> [a] -> [a]
: (FieldLabel -> AvailInfo) -> [FieldLabel] -> [AvailInfo]
forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> AvailInfo
availField (PatSyn -> [FieldLabel]
patSynFieldLabels PatSyn
p)
tyThingAvailInfo TyThing
t
= [Name -> AvailInfo
avail (TyThing -> Name
forall a. NamedThing a => a -> Name
getName TyThing
t)]
tyThingTyCon :: HasDebugCallStack => TyThing -> TyCon
tyThingTyCon :: HasDebugCallStack => TyThing -> TyCon
tyThingTyCon (ATyCon TyCon
tc) = TyCon
tc
tyThingTyCon TyThing
other = String -> SDoc -> TyCon
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tyThingTyCon" (TyThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyThing
other)
tyThingCoAxiom :: HasDebugCallStack => TyThing -> CoAxiom Branched
tyThingCoAxiom :: HasDebugCallStack => TyThing -> CoAxiom Branched
tyThingCoAxiom (ACoAxiom CoAxiom Branched
ax) = CoAxiom Branched
ax
tyThingCoAxiom TyThing
other = String -> SDoc -> CoAxiom Branched
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tyThingCoAxiom" (TyThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyThing
other)
tyThingDataCon :: HasDebugCallStack => TyThing -> DataCon
tyThingDataCon :: HasDebugCallStack => TyThing -> DataCon
tyThingDataCon (AConLike (RealDataCon DataCon
dc)) = DataCon
dc
tyThingDataCon TyThing
other = String -> SDoc -> DataCon
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tyThingDataCon" (TyThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyThing
other)
tyThingConLike :: HasDebugCallStack => TyThing -> ConLike
tyThingConLike :: HasDebugCallStack => TyThing -> ConLike
tyThingConLike (AConLike ConLike
dc) = ConLike
dc
tyThingConLike TyThing
other = String -> SDoc -> ConLike
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tyThingConLike" (TyThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyThing
other)
tyThingId :: HasDebugCallStack => TyThing -> Id
tyThingId :: HasDebugCallStack => TyThing -> Id
tyThingId (AnId Id
id) = Id
id
tyThingId (AConLike (RealDataCon DataCon
dc)) = DataCon -> Id
dataConWrapId DataCon
dc
tyThingId TyThing
other = String -> SDoc -> Id
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tyThingId" (TyThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyThing
other)
class Monad m => MonadThings m where
lookupThing :: Name -> m TyThing
lookupId :: Name -> m Id
lookupId = (TyThing -> Id) -> m TyThing -> m Id
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM HasDebugCallStack => TyThing -> Id
TyThing -> Id
tyThingId (m TyThing -> m Id) -> (Name -> m TyThing) -> Name -> m Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> m TyThing
forall (m :: * -> *). MonadThings m => Name -> m TyThing
lookupThing
lookupDataCon :: Name -> m DataCon
lookupDataCon = (TyThing -> DataCon) -> m TyThing -> m DataCon
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM HasDebugCallStack => TyThing -> DataCon
TyThing -> DataCon
tyThingDataCon (m TyThing -> m DataCon)
-> (Name -> m TyThing) -> Name -> m DataCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> m TyThing
forall (m :: * -> *). MonadThings m => Name -> m TyThing
lookupThing
lookupTyCon :: Name -> m TyCon
lookupTyCon = (TyThing -> TyCon) -> m TyThing -> m TyCon
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM HasDebugCallStack => TyThing -> TyCon
TyThing -> TyCon
tyThingTyCon (m TyThing -> m TyCon) -> (Name -> m TyThing) -> Name -> m TyCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> m TyThing
forall (m :: * -> *). MonadThings m => Name -> m TyThing
lookupThing
instance MonadThings m => MonadThings (ReaderT s m) where
lookupThing :: Name -> ReaderT s m TyThing
lookupThing = m TyThing -> ReaderT s m TyThing
forall (m :: * -> *) a. Monad m => m a -> ReaderT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m TyThing -> ReaderT s m TyThing)
-> (Name -> m TyThing) -> Name -> ReaderT s m TyThing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> m TyThing
forall (m :: * -> *). MonadThings m => Name -> m TyThing
lookupThing