{-
(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(..)
        , conLikeConLikeName
        , isVanillaConLike
        , conLikeArity
        , conLikeFieldLabels
        , conLikeConInfo
        , conLikeInstOrigArgTys
        , conLikeUserTyVarBinders
        , conLikeExTyCoVars
        , conLikeName
        , conLikeStupidTheta
        , conLikeImplBangs
        , conLikeFullSig
        , conLikeResTy
        , conLikeFieldType
        , conLikesWithFields
        , conLikeIsInfix
        , conLikeHasBuilder
    ) where

import GHC.Prelude

import GHC.Core.DataCon
import GHC.Core.Multiplicity
import GHC.Core.PatSyn
import GHC.Core.TyCo.Rep (Type, ThetaType)
import GHC.Core.Type(mkTyConApp)
import GHC.Types.Unique
import GHC.Types.Name
import GHC.Types.Name.Reader
import GHC.Types.Basic

import GHC.Types.GREInfo
import GHC.Types.Var
import GHC.Utils.Misc
import GHC.Utils.Outputable

import Data.Maybe( isJust )
import qualified Data.Data as Data
import qualified Data.List as List

{-
************************************************************************
*                                                                      *
\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

conLikeConLikeName :: ConLike -> ConLikeName
conLikeConLikeName :: ConLike -> ConLikeName
conLikeConLikeName (RealDataCon DataCon
dc) = Name -> ConLikeName
DataConName (DataCon -> Name
dataConName DataCon
dc)
conLikeConLikeName (PatSynCon   PatSyn
ps) = Name -> ConLikeName
PatSynName  (PatSyn -> Name
patSynName  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

-- | The 'ConInfo' (arity and field labels) associated to a 'ConLike'.
conLikeConInfo :: ConLike -> ConInfo
conLikeConInfo :: ConLike -> ConInfo
conLikeConInfo ConLike
con =
  Int -> [FieldLabel] -> ConInfo
mkConInfo (ConLike -> Int
conLikeArity ConLike
con) (ConLike -> [FieldLabel]
conLikeFieldLabels ConLike
con)

-- | 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]   -- ConLikes containing the fields
                      , [ConLike] ) -- ConLikes not containing the fields
conLikesWithFields :: [ConLike] -> [FieldLabelString] -> ([ConLike], [ConLike])
conLikesWithFields [ConLike]
con_likes [FieldLabelString]
lbls = (ConLike -> Bool) -> [ConLike] -> ([ConLike], [ConLike])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition 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