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 (RealDataCon con) = isVanillaDataCon con
isVanillaConLike (PatSynCon ps ) = isVanillaPatSyn ps
instance Eq ConLike where
(==) = eqConLike
eqConLike :: ConLike -> ConLike -> Bool
eqConLike x y = getUnique x == getUnique y
instance Uniquable ConLike where
getUnique (RealDataCon dc) = getUnique dc
getUnique (PatSynCon ps) = getUnique ps
instance NamedThing ConLike where
getName (RealDataCon dc) = getName dc
getName (PatSynCon ps) = getName ps
instance Outputable ConLike where
ppr (RealDataCon dc) = ppr dc
ppr (PatSynCon ps) = ppr ps
instance OutputableBndr ConLike where
pprInfixOcc (RealDataCon dc) = pprInfixOcc dc
pprInfixOcc (PatSynCon ps) = pprInfixOcc ps
pprPrefixOcc (RealDataCon dc) = pprPrefixOcc dc
pprPrefixOcc (PatSynCon ps) = pprPrefixOcc ps
instance Data.Data ConLike where
toConstr _ = abstractConstr "ConLike"
gunfold _ _ = error "gunfold"
dataTypeOf _ = mkNoRepType "ConLike"
conLikeArity :: ConLike -> Arity
conLikeArity (RealDataCon data_con) = dataConSourceArity data_con
conLikeArity (PatSynCon pat_syn) = patSynArity pat_syn
conLikeFieldLabels :: ConLike -> [FieldLabel]
conLikeFieldLabels (RealDataCon data_con) = dataConFieldLabels data_con
conLikeFieldLabels (PatSynCon pat_syn) = patSynFieldLabels pat_syn
conLikeInstOrigArgTys :: ConLike -> [Type] -> [Scaled Type]
conLikeInstOrigArgTys (RealDataCon data_con) tys =
dataConInstOrigArgTys data_con tys
conLikeInstOrigArgTys (PatSynCon pat_syn) tys =
map unrestricted $ patSynInstArgTys pat_syn tys
conLikeUserTyVarBinders :: ConLike -> [InvisTVBinder]
conLikeUserTyVarBinders (RealDataCon data_con) =
dataConUserTyVarBinders data_con
conLikeUserTyVarBinders (PatSynCon pat_syn) =
patSynUnivTyVarBinders pat_syn ++ patSynExTyVarBinders pat_syn
conLikeExTyCoVars :: ConLike -> [TyCoVar]
conLikeExTyCoVars (RealDataCon dcon1) = dataConExTyCoVars dcon1
conLikeExTyCoVars (PatSynCon psyn1) = patSynExTyVars psyn1
conLikeName :: ConLike -> Name
conLikeName (RealDataCon data_con) = dataConName data_con
conLikeName (PatSynCon pat_syn) = patSynName pat_syn
conLikeStupidTheta :: ConLike -> ThetaType
conLikeStupidTheta (RealDataCon data_con) = dataConStupidTheta data_con
conLikeStupidTheta (PatSynCon {}) = []
conLikeHasBuilder :: ConLike -> Bool
conLikeHasBuilder (RealDataCon {}) = True
conLikeHasBuilder (PatSynCon pat_syn) = isJust (patSynBuilder pat_syn)
conLikeImplBangs :: ConLike -> [HsImplBang]
conLikeImplBangs (RealDataCon data_con) = dataConImplBangs data_con
conLikeImplBangs (PatSynCon pat_syn) =
replicate (patSynArity pat_syn) HsLazy
conLikeResTy :: ConLike -> [Type] -> Type
conLikeResTy (RealDataCon con) tys = mkTyConApp (dataConTyCon con) tys
conLikeResTy (PatSynCon ps) tys = patSynInstResTy ps tys
conLikeFullSig :: ConLike
-> ([TyVar], [TyCoVar], [EqSpec]
, ThetaType, ThetaType, [Scaled Type], Type)
conLikeFullSig (RealDataCon con) =
let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) = dataConFullSig con
in (univ_tvs, ex_tvs, eq_spec, theta, [], arg_tys, res_ty)
conLikeFullSig (PatSynCon pat_syn) =
let (univ_tvs, req, ex_tvs, prov, arg_tys, res_ty) = patSynSig pat_syn
in (univ_tvs, ex_tvs, [], prov, req, arg_tys, res_ty)
conLikeFieldType :: ConLike -> FieldLabelString -> Type
conLikeFieldType (PatSynCon ps) label = patSynFieldType ps label
conLikeFieldType (RealDataCon dc) label = dataConFieldType dc label
conLikesWithFields :: [ConLike] -> [FieldLabelString] -> [ConLike]
conLikesWithFields con_likes lbls = filter has_flds con_likes
where has_flds dc = all (has_fld dc) lbls
has_fld dc lbl = any (\ fl -> flLabel fl == lbl) (conLikeFieldLabels dc)
conLikeIsInfix :: ConLike -> Bool
conLikeIsInfix (RealDataCon dc) = dataConIsInfix dc
conLikeIsInfix (PatSynCon ps) = patSynIsInfix ps