module GHC.Core.ConLike (
ConLike(..)
, conLikeArity
, conLikeFieldLabels
, conLikeInstOrigArgTys
, conLikeUserTyVarBinders
, conLikeExTyCoVars
, conLikeName
, conLikeStupidTheta
, conLikeWrapId_maybe
, conLikeImplBangs
, conLikeFullSig
, conLikeResTy
, conLikeFieldType
, conLikesWithFields
, conLikeIsInfix
) where
#include "HsVersions.h"
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 qualified Data.Data as Data
data ConLike = RealDataCon DataCon
| PatSynCon PatSyn
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 {}) = []
conLikeWrapId_maybe :: ConLike -> Maybe Id
conLikeWrapId_maybe (RealDataCon data_con) = Just $ dataConWrapId data_con
conLikeWrapId_maybe (PatSynCon pat_syn) = fst <$> 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