module GHC.Core.ConLike (
ConLike(..)
, isVanillaConLike
, conLikeArity
, conLikeFieldLabels
, conLikeInstOrigArgTys
, conLikeUserTyVarBinders
, conLikeExTyCoVars
, conLikeName
, conLikeStupidTheta
, conLikeImplBangs
, conLikeFullSig
, conLikeResTy
, conLikeFieldType
, conLikesWithFields
, conLikeIsInfix
, conLikeHasBuilder
) where
import GHC.Prelude
import GHC.Core.DataCon
import GHC.Core.PatSyn
import GHC.Utils.Outputable
import GHC.Types.Unique
import GHC.Utils.Misc
import GHC.Types.Name
import GHC.Types.Basic
import GHC.Core.TyCo.Rep (Type, ThetaType)
import GHC.Types.Var
import GHC.Core.Type(mkTyConApp)
import GHC.Core.Multiplicity
import Data.Maybe( isJust )
import qualified Data.Data as Data
data ConLike = RealDataCon DataCon
| PatSynCon PatSyn
isVanillaConLike :: ConLike -> Bool
isVanillaConLike :: ConLike -> Bool
isVanillaConLike (RealDataCon DataCon
con) = DataCon -> Bool
isVanillaDataCon DataCon
con
isVanillaConLike (PatSynCon PatSyn
ps ) = PatSyn -> Bool
isVanillaPatSyn PatSyn
ps
instance Eq ConLike where
== :: ConLike -> ConLike -> Bool
(==) = ConLike -> ConLike -> Bool
eqConLike
eqConLike :: ConLike -> ConLike -> Bool
eqConLike :: ConLike -> ConLike -> Bool
eqConLike ConLike
x ConLike
y = ConLike -> Unique
forall a. Uniquable a => a -> Unique
getUnique ConLike
x Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== ConLike -> Unique
forall a. Uniquable a => a -> Unique
getUnique ConLike
y
instance Uniquable ConLike where
getUnique :: ConLike -> Unique
getUnique (RealDataCon DataCon
dc) = DataCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique DataCon
dc
getUnique (PatSynCon PatSyn
ps) = PatSyn -> Unique
forall a. Uniquable a => a -> Unique
getUnique PatSyn
ps
instance NamedThing ConLike where
getName :: ConLike -> Name
getName (RealDataCon DataCon
dc) = DataCon -> Name
forall a. NamedThing a => a -> Name
getName DataCon
dc
getName (PatSynCon PatSyn
ps) = PatSyn -> Name
forall a. NamedThing a => a -> Name
getName PatSyn
ps
instance Outputable ConLike where
ppr :: ConLike -> SDoc
ppr (RealDataCon DataCon
dc) = DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
dc
ppr (PatSynCon PatSyn
ps) = PatSyn -> SDoc
forall a. Outputable a => a -> SDoc
ppr PatSyn
ps
instance OutputableBndr ConLike where
pprInfixOcc :: ConLike -> SDoc
pprInfixOcc (RealDataCon DataCon
dc) = DataCon -> SDoc
forall a. OutputableBndr a => a -> SDoc
pprInfixOcc DataCon
dc
pprInfixOcc (PatSynCon PatSyn
ps) = PatSyn -> SDoc
forall a. OutputableBndr a => a -> SDoc
pprInfixOcc PatSyn
ps
pprPrefixOcc :: ConLike -> SDoc
pprPrefixOcc (RealDataCon DataCon
dc) = DataCon -> SDoc
forall a. OutputableBndr a => a -> SDoc
pprPrefixOcc DataCon
dc
pprPrefixOcc (PatSynCon PatSyn
ps) = PatSyn -> SDoc
forall a. OutputableBndr a => a -> SDoc
pprPrefixOcc PatSyn
ps
instance Data.Data ConLike where
toConstr :: ConLike -> Constr
toConstr ConLike
_ = String -> Constr
abstractConstr String
"ConLike"
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ConLike
gunfold forall b r. Data b => c (b -> r) -> c r
_ forall r. r -> c r
_ = String -> Constr -> c ConLike
forall a. HasCallStack => String -> a
error String
"gunfold"
dataTypeOf :: ConLike -> DataType
dataTypeOf ConLike
_ = String -> DataType
mkNoRepType String
"ConLike"
conLikeArity :: ConLike -> Arity
conLikeArity :: ConLike -> Int
conLikeArity (RealDataCon DataCon
data_con) = DataCon -> Int
dataConSourceArity DataCon
data_con
conLikeArity (PatSynCon PatSyn
pat_syn) = PatSyn -> Int
patSynArity PatSyn
pat_syn
conLikeFieldLabels :: ConLike -> [FieldLabel]
conLikeFieldLabels :: ConLike -> [FieldLabel]
conLikeFieldLabels (RealDataCon DataCon
data_con) = DataCon -> [FieldLabel]
dataConFieldLabels DataCon
data_con
conLikeFieldLabels (PatSynCon PatSyn
pat_syn) = PatSyn -> [FieldLabel]
patSynFieldLabels PatSyn
pat_syn
conLikeInstOrigArgTys :: ConLike -> [Type] -> [Scaled Type]
conLikeInstOrigArgTys :: ConLike -> [Type] -> [Scaled Type]
conLikeInstOrigArgTys (RealDataCon DataCon
data_con) [Type]
tys =
DataCon -> [Type] -> [Scaled Type]
dataConInstOrigArgTys DataCon
data_con [Type]
tys
conLikeInstOrigArgTys (PatSynCon PatSyn
pat_syn) [Type]
tys =
(Type -> Scaled Type) -> [Type] -> [Scaled Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Scaled Type
forall a. a -> Scaled a
unrestricted ([Type] -> [Scaled Type]) -> [Type] -> [Scaled Type]
forall a b. (a -> b) -> a -> b
$ PatSyn -> [Type] -> [Type]
patSynInstArgTys PatSyn
pat_syn [Type]
tys
conLikeUserTyVarBinders :: ConLike -> [InvisTVBinder]
conLikeUserTyVarBinders :: ConLike -> [InvisTVBinder]
conLikeUserTyVarBinders (RealDataCon DataCon
data_con) =
DataCon -> [InvisTVBinder]
dataConUserTyVarBinders DataCon
data_con
conLikeUserTyVarBinders (PatSynCon PatSyn
pat_syn) =
PatSyn -> [InvisTVBinder]
patSynUnivTyVarBinders PatSyn
pat_syn [InvisTVBinder] -> [InvisTVBinder] -> [InvisTVBinder]
forall a. [a] -> [a] -> [a]
++ PatSyn -> [InvisTVBinder]
patSynExTyVarBinders PatSyn
pat_syn
conLikeExTyCoVars :: ConLike -> [TyCoVar]
conLikeExTyCoVars :: ConLike -> [TyCoVar]
conLikeExTyCoVars (RealDataCon DataCon
dcon1) = DataCon -> [TyCoVar]
dataConExTyCoVars DataCon
dcon1
conLikeExTyCoVars (PatSynCon PatSyn
psyn1) = PatSyn -> [TyCoVar]
patSynExTyVars PatSyn
psyn1
conLikeName :: ConLike -> Name
conLikeName :: ConLike -> Name
conLikeName (RealDataCon DataCon
data_con) = DataCon -> Name
dataConName DataCon
data_con
conLikeName (PatSynCon PatSyn
pat_syn) = PatSyn -> Name
patSynName PatSyn
pat_syn
conLikeStupidTheta :: ConLike -> ThetaType
conLikeStupidTheta :: ConLike -> [Type]
conLikeStupidTheta (RealDataCon DataCon
data_con) = DataCon -> [Type]
dataConStupidTheta DataCon
data_con
conLikeStupidTheta (PatSynCon {}) = []
conLikeHasBuilder :: ConLike -> Bool
conLikeHasBuilder :: ConLike -> Bool
conLikeHasBuilder (RealDataCon {}) = Bool
True
conLikeHasBuilder (PatSynCon PatSyn
pat_syn) = Maybe (Name, Type, Bool) -> Bool
forall a. Maybe a -> Bool
isJust (PatSyn -> Maybe (Name, Type, Bool)
patSynBuilder PatSyn
pat_syn)
conLikeImplBangs :: ConLike -> [HsImplBang]
conLikeImplBangs :: ConLike -> [HsImplBang]
conLikeImplBangs (RealDataCon DataCon
data_con) = DataCon -> [HsImplBang]
dataConImplBangs DataCon
data_con
conLikeImplBangs (PatSynCon PatSyn
pat_syn) =
Int -> HsImplBang -> [HsImplBang]
forall a. Int -> a -> [a]
replicate (PatSyn -> Int
patSynArity PatSyn
pat_syn) HsImplBang
HsLazy
conLikeResTy :: ConLike -> [Type] -> Type
conLikeResTy :: ConLike -> [Type] -> Type
conLikeResTy (RealDataCon DataCon
con) [Type]
tys = TyCon -> [Type] -> Type
mkTyConApp (DataCon -> TyCon
dataConTyCon DataCon
con) [Type]
tys
conLikeResTy (PatSynCon PatSyn
ps) [Type]
tys = PatSyn -> [Type] -> Type
patSynInstResTy PatSyn
ps [Type]
tys
conLikeFullSig :: ConLike
-> ([TyVar], [TyCoVar]
, [EqSpec]
, ThetaType
, ThetaType
, [Scaled Type]
, Type )
conLikeFullSig :: ConLike
-> ([TyCoVar], [TyCoVar], [EqSpec], [Type], [Type], [Scaled Type],
Type)
conLikeFullSig (RealDataCon DataCon
con) =
let ([TyCoVar]
univ_tvs, [TyCoVar]
ex_tvs, [EqSpec]
eq_spec, [Type]
theta, [Scaled Type]
arg_tys, Type
res_ty) = DataCon
-> ([TyCoVar], [TyCoVar], [EqSpec], [Type], [Scaled Type], Type)
dataConFullSig DataCon
con
in ([TyCoVar]
univ_tvs, [TyCoVar]
ex_tvs, [EqSpec]
eq_spec, [Type]
theta, [], [Scaled Type]
arg_tys, Type
res_ty)
conLikeFullSig (PatSynCon PatSyn
pat_syn) =
let ([TyCoVar]
univ_tvs, [Type]
req, [TyCoVar]
ex_tvs, [Type]
prov, [Scaled Type]
arg_tys, Type
res_ty) = PatSyn
-> ([TyCoVar], [Type], [TyCoVar], [Type], [Scaled Type], Type)
patSynSig PatSyn
pat_syn
in ([TyCoVar]
univ_tvs, [TyCoVar]
ex_tvs, [], [Type]
prov, [Type]
req, [Scaled Type]
arg_tys, Type
res_ty)
conLikeFieldType :: ConLike -> FieldLabelString -> Type
conLikeFieldType :: ConLike -> FieldLabelString -> Type
conLikeFieldType (PatSynCon PatSyn
ps) FieldLabelString
label = PatSyn -> FieldLabelString -> Type
patSynFieldType PatSyn
ps FieldLabelString
label
conLikeFieldType (RealDataCon DataCon
dc) FieldLabelString
label = DataCon -> FieldLabelString -> Type
dataConFieldType DataCon
dc FieldLabelString
label
conLikesWithFields :: [ConLike] -> [FieldLabelString] -> [ConLike]
conLikesWithFields :: [ConLike] -> [FieldLabelString] -> [ConLike]
conLikesWithFields [ConLike]
con_likes [FieldLabelString]
lbls = (ConLike -> Bool) -> [ConLike] -> [ConLike]
forall a. (a -> Bool) -> [a] -> [a]
filter ConLike -> Bool
has_flds [ConLike]
con_likes
where has_flds :: ConLike -> Bool
has_flds ConLike
dc = (FieldLabelString -> Bool) -> [FieldLabelString] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (ConLike -> FieldLabelString -> Bool
has_fld ConLike
dc) [FieldLabelString]
lbls
has_fld :: ConLike -> FieldLabelString -> Bool
has_fld ConLike
dc FieldLabelString
lbl = (FieldLabel -> Bool) -> [FieldLabel] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\ FieldLabel
fl -> FieldLabel -> FieldLabelString
flLabel FieldLabel
fl FieldLabelString -> FieldLabelString -> Bool
forall a. Eq a => a -> a -> Bool
== FieldLabelString
lbl) (ConLike -> [FieldLabel]
conLikeFieldLabels ConLike
dc)
conLikeIsInfix :: ConLike -> Bool
conLikeIsInfix :: ConLike -> Bool
conLikeIsInfix (RealDataCon DataCon
dc) = DataCon -> Bool
dataConIsInfix DataCon
dc
conLikeIsInfix (PatSynCon PatSyn
ps) = PatSyn -> Bool
patSynIsInfix PatSyn
ps