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

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

    {-# LANGUAGE CPP #-}

    module GHC.Core.ConLike (
              ConLike(..)
            , isVanillaConLike
            , conLikeArity
            , conLikeFieldLabels
            , conLikeInstOrigArgTys
            , conLikeUserTyVarBinders
            , conLikeExTyCoVars
            , conLikeName
            , conLikeStupidTheta
            , conLikeImplBangs
            , conLikeFullSig
            , conLikeResTy
            , conLikeFieldType
            , conLikesWithFields
            , conLikeIsInfix
            , conLikeHasBuilder
        ) 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 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.
    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], [EqSpec]
                       -- Why tyvars for universal but tycovars for existential?
                       -- See Note [Existential coercion variables] in GHC.Core.DataCon
                      , 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
      -- 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