{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1998

\section[ConLike]{@ConLike@: Constructor-like things}
-}



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

{-
************************************************************************
*                                                                      *
\subsection{Constructor-like things}
*                                                                      *
************************************************************************
-}

-- | A constructor-like thing
data ConLike = RealDataCon DataCon
             | PatSynCon PatSyn

-- | Is this a \'vanilla\' constructor-like thing
-- (no existentials, no provided constraints)?
isVanillaConLike :: ConLike -> Bool
isVanillaConLike :: ConLike -> Bool
isVanillaConLike (RealDataCon DataCon
con) = DataCon -> Bool
isVanillaDataCon DataCon
con
isVanillaConLike (PatSynCon   PatSyn
ps ) = PatSyn -> Bool
isVanillaPatSyn  PatSyn
ps

{-
************************************************************************
*                                                                      *
\subsection{Instances}
*                                                                      *
************************************************************************
-}

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

-- There used to be an Ord ConLike instance here that used Unique for ordering.
-- It was intentionally removed to prevent determinism problems.
-- See Note [Unique Determinism] in GHC.Types.Unique.

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
    -- don't traverse?
    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"

-- | Number of arguments
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

-- | Names of fields used for selectors
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

-- | Returns just the instantiated /value/ argument types of a 'ConLike',
-- (excluding dictionary args)
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

-- | 'TyVarBinder's for the type variables of the 'ConLike'. For pattern
-- synonyms, this will always consist of the universally quantified variables
-- followed by the existentially quantified type variables. For data
-- constructors, the situation is slightly more complicated—see
-- @Note [DataCon user type variable binders]@ in "GHC.Core.DataCon".
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
    -- The order here is because of the order in `GHC.Tc.TyCl.PatSyn`.

-- | Existentially quantified type/coercion variables
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

-- | The \"stupid theta\" of the 'ConLike', such as @data Eq a@ in:
--
-- > data Eq a => T a = ...
-- It is empty for `PatSynCon` as they do not allow such contexts.
-- See @Note [The stupid context]@ in "GHC.Core.DataCon".
conLikeStupidTheta :: ConLike -> ThetaType
conLikeStupidTheta :: ConLike -> [Type]
conLikeStupidTheta (RealDataCon DataCon
data_con) = DataCon -> [Type]
dataConStupidTheta DataCon
data_con
conLikeStupidTheta (PatSynCon {})         = []

-- | 'conLikeHasBuilder' returns True except for
-- uni-directional pattern synonyms, which have no builder
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)

-- | Returns the strictness information for each constructor
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

-- | Returns the type of the whole pattern
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

-- | The \"full signature\" of the 'ConLike' returns, in order:
--
-- 1) The universally quantified type variables
--
-- 2) The existentially quantified type/coercion variables
--
-- 3) The equality specification
--
-- 4) The provided theta (the constraints provided by a match)
--
-- 5) The required theta (the constraints required for a match)
--
-- 6) The original argument types (i.e. before
--    any change of the representation of the type)
--
-- 7) The original result type
conLikeFullSig :: ConLike
               -> ([TyVar], [TyCoVar]
                   -- Why tyvars for universal but tycovars for existential?
                   -- See Note [Existential coercion variables] in GHC.Core.DataCon
                  , [EqSpec]
                  , ThetaType      -- Provided theta
                  , ThetaType      -- Required theta
                  , [Scaled Type]  -- Arguments
                  , Type )         -- Result
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
  -- Required theta is empty as normal data cons require no additional
  -- constraints for a match
  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
 -- eqSpec is empty
 in ([TyCoVar]
univ_tvs, [TyCoVar]
ex_tvs, [], [Type]
prov, [Type]
req, [Scaled Type]
arg_tys, Type
res_ty)

-- | Extract the type for any given labelled field of the 'ConLike'
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


-- | The ConLikes that have *all* the given fields
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