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

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

{-# LANGUAGE CPP #-}

module ConLike (
          ConLike(..)
        , conLikeArity
        , conLikeFieldLabels
        , conLikeInstOrigArgTys
        , conLikeExTyCoVars
        , conLikeName
        , conLikeStupidTheta
        , conLikeWrapId_maybe
        , conLikeImplBangs
        , conLikeFullSig
        , conLikeResTy
        , conLikeFieldType
        , conLikesWithFields
        , conLikeIsInfix
    ) where

#include "HsVersions.h"

import GhcPrelude

import DataCon
import PatSyn
import Outputable
import Unique
import Util
import Name
import BasicTypes
import TyCoRep (Type, ThetaType)
import Var
import Type (mkTyConApp)

import qualified Data.Data as Data

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

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

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

instance Eq ConLike where
    == :: ConLike -> ConLike -> Bool
(==) = ConLike -> ConLike -> Bool
eqConLike

eqConLike :: ConLike -> ConLike -> Bool
eqConLike :: ConLike -> ConLike -> Bool
eqConLike x :: ConLike
x y :: 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 Unique.

instance Uniquable ConLike where
    getUnique :: ConLike -> Unique
getUnique (RealDataCon dc :: DataCon
dc) = DataCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique DataCon
dc
    getUnique (PatSynCon ps :: PatSyn
ps)   = PatSyn -> Unique
forall a. Uniquable a => a -> Unique
getUnique PatSyn
ps

instance NamedThing ConLike where
    getName :: ConLike -> Name
getName (RealDataCon dc :: DataCon
dc) = DataCon -> Name
forall a. NamedThing a => a -> Name
getName DataCon
dc
    getName (PatSynCon ps :: PatSyn
ps)   = PatSyn -> Name
forall a. NamedThing a => a -> Name
getName PatSyn
ps

instance Outputable ConLike where
    ppr :: ConLike -> SDoc
ppr (RealDataCon dc :: DataCon
dc) = DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
dc
    ppr (PatSynCon ps :: PatSyn
ps) = PatSyn -> SDoc
forall a. Outputable a => a -> SDoc
ppr PatSyn
ps

instance OutputableBndr ConLike where
    pprInfixOcc :: ConLike -> SDoc
pprInfixOcc (RealDataCon dc :: DataCon
dc) = DataCon -> SDoc
forall a. OutputableBndr a => a -> SDoc
pprInfixOcc DataCon
dc
    pprInfixOcc (PatSynCon ps :: PatSyn
ps) = PatSyn -> SDoc
forall a. OutputableBndr a => a -> SDoc
pprInfixOcc PatSyn
ps
    pprPrefixOcc :: ConLike -> SDoc
pprPrefixOcc (RealDataCon dc :: DataCon
dc) = DataCon -> SDoc
forall a. OutputableBndr a => a -> SDoc
pprPrefixOcc DataCon
dc
    pprPrefixOcc (PatSynCon ps :: 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 _   = String -> Constr
abstractConstr "ConLike"
    gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ConLike
gunfold _ _  = String -> Constr -> c ConLike
forall a. HasCallStack => String -> a
error "gunfold"
    dataTypeOf :: ConLike -> DataType
dataTypeOf _ = String -> DataType
mkNoRepType "ConLike"

-- | Number of arguments
conLikeArity :: ConLike -> Arity
conLikeArity :: ConLike -> Int
conLikeArity (RealDataCon data_con :: DataCon
data_con) = DataCon -> Int
dataConSourceArity DataCon
data_con
conLikeArity (PatSynCon pat_syn :: PatSyn
pat_syn)    = PatSyn -> Int
patSynArity PatSyn
pat_syn

-- | Names of fields used for selectors
conLikeFieldLabels :: ConLike -> [FieldLabel]
conLikeFieldLabels :: ConLike -> [FieldLabel]
conLikeFieldLabels (RealDataCon data_con :: DataCon
data_con) = DataCon -> [FieldLabel]
dataConFieldLabels DataCon
data_con
conLikeFieldLabels (PatSynCon pat_syn :: 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] -> [Type]
conLikeInstOrigArgTys :: ConLike -> [Type] -> [Type]
conLikeInstOrigArgTys (RealDataCon data_con :: DataCon
data_con) tys :: [Type]
tys =
    DataCon -> [Type] -> [Type]
dataConInstOrigArgTys DataCon
data_con [Type]
tys
conLikeInstOrigArgTys (PatSynCon pat_syn :: PatSyn
pat_syn) tys :: [Type]
tys =
    PatSyn -> [Type] -> [Type]
patSynInstArgTys PatSyn
pat_syn [Type]
tys

-- | Existentially quantified type/coercion variables
conLikeExTyCoVars :: ConLike -> [TyCoVar]
conLikeExTyCoVars :: ConLike -> [TyCoVar]
conLikeExTyCoVars (RealDataCon dcon1 :: DataCon
dcon1) = DataCon -> [TyCoVar]
dataConExTyCoVars DataCon
dcon1
conLikeExTyCoVars (PatSynCon psyn1 :: PatSyn
psyn1)   = PatSyn -> [TyCoVar]
patSynExTyVars PatSyn
psyn1

conLikeName :: ConLike -> Name
conLikeName :: ConLike -> Name
conLikeName (RealDataCon data_con :: DataCon
data_con) = DataCon -> Name
dataConName DataCon
data_con
conLikeName (PatSynCon pat_syn :: 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 data_con :: DataCon
data_con) = DataCon -> [Type]
dataConStupidTheta DataCon
data_con
conLikeStupidTheta (PatSynCon {})         = []

-- | Returns the `Id` of the wrapper. This is also known as the builder in
-- some contexts. The value is Nothing only in the case of unidirectional
-- pattern synonyms.
conLikeWrapId_maybe :: ConLike -> Maybe Id
conLikeWrapId_maybe :: ConLike -> Maybe TyCoVar
conLikeWrapId_maybe (RealDataCon data_con :: DataCon
data_con) = TyCoVar -> Maybe TyCoVar
forall a. a -> Maybe a
Just (TyCoVar -> Maybe TyCoVar) -> TyCoVar -> Maybe TyCoVar
forall a b. (a -> b) -> a -> b
$ DataCon -> TyCoVar
dataConWrapId DataCon
data_con
conLikeWrapId_maybe (PatSynCon pat_syn :: PatSyn
pat_syn)    = (TyCoVar, Bool) -> TyCoVar
forall a b. (a, b) -> a
fst ((TyCoVar, Bool) -> TyCoVar)
-> Maybe (TyCoVar, Bool) -> Maybe TyCoVar
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PatSyn -> Maybe (TyCoVar, Bool)
patSynBuilder PatSyn
pat_syn

-- | Returns the strictness information for each constructor
conLikeImplBangs :: ConLike -> [HsImplBang]
conLikeImplBangs :: ConLike -> [HsImplBang]
conLikeImplBangs (RealDataCon data_con :: DataCon
data_con) = DataCon -> [HsImplBang]
dataConImplBangs DataCon
data_con
conLikeImplBangs (PatSynCon pat_syn :: 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 con :: DataCon
con) tys :: [Type]
tys = TyCon -> [Type] -> Type
mkTyConApp (DataCon -> TyCon
dataConTyCon DataCon
con) [Type]
tys
conLikeResTy (PatSynCon ps :: PatSyn
ps)    tys :: [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 DataCon
                  , ThetaType, ThetaType, [Type], Type)
conLikeFullSig :: ConLike
-> ([TyCoVar], [TyCoVar], [EqSpec], [Type], [Type], [Type], Type)
conLikeFullSig (RealDataCon con :: DataCon
con) =
  let (univ_tvs :: [TyCoVar]
univ_tvs, ex_tvs :: [TyCoVar]
ex_tvs, eq_spec :: [EqSpec]
eq_spec, theta :: [Type]
theta, arg_tys :: [Type]
arg_tys, res_ty :: Type
res_ty) = DataCon -> ([TyCoVar], [TyCoVar], [EqSpec], [Type], [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, [], [Type]
arg_tys, Type
res_ty)
conLikeFullSig (PatSynCon pat_syn :: PatSyn
pat_syn) =
 let (univ_tvs :: [TyCoVar]
univ_tvs, req :: [Type]
req, ex_tvs :: [TyCoVar]
ex_tvs, prov :: [Type]
prov, arg_tys :: [Type]
arg_tys, res_ty :: Type
res_ty) = PatSyn -> ([TyCoVar], [Type], [TyCoVar], [Type], [Type], Type)
patSynSig PatSyn
pat_syn
 -- eqSpec is empty
 in ([TyCoVar]
univ_tvs, [TyCoVar]
ex_tvs, [], [Type]
prov, [Type]
req, [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 ps :: PatSyn
ps) label :: FieldLabelString
label = PatSyn -> FieldLabelString -> Type
patSynFieldType PatSyn
ps FieldLabelString
label
conLikeFieldType (RealDataCon dc :: DataCon
dc) label :: 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 con_likes :: [ConLike]
con_likes lbls :: [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 dc :: 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 dc :: ConLike
dc lbl :: FieldLabelString
lbl = (FieldLabel -> Bool) -> [FieldLabel] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\ fl :: FieldLabel
fl -> FieldLabel -> FieldLabelString
forall a. FieldLbl a -> 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 dc :: DataCon
dc) = DataCon -> Bool
dataConIsInfix DataCon
dc
conLikeIsInfix (PatSynCon ps :: PatSyn
ps)   = PatSyn -> Bool
patSynIsInfix  PatSyn
ps