content: {-
  (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
          , conLikeVisArity
          , conLikeFieldLabels
          , conLikeConInfo
          , conLikeInstOrigArgTys
          , conLikeUserTyVarBinders
          , conLikeExTyCoVars
          , conLikeName
          , conLikeStupidTheta
          , conLikeImplBangs
          , conLikeFullSig
          , conLikeResTy
          , conLikeFieldType
          , 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.TyCon (tyConDataCons)
  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
  
  {-
  ************************************************************************
  *                                                                      *
  \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 (RealDataCon con) = isVanillaDataCon con
  isVanillaConLike (PatSynCon   ps ) = isVanillaPatSyn  ps
  
  conLikeConLikeName :: ConLike -> ConLikeName
  conLikeConLikeName (RealDataCon dc) = DataConName (dataConName dc)
  conLikeConLikeName (PatSynCon   ps) = PatSynName  (patSynName  ps)
  
  {-
  ************************************************************************
  *                                                                      *
  \subsection{Instances}
  *                                                                      *
  ************************************************************************
  -}
  
  instance Eq ConLike where
      (==) = eqConLike
  
  eqConLike :: ConLike -> ConLike -> Bool
  eqConLike x y = getUnique x == getUnique 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 (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
      -- don't traverse?
      toConstr _   = abstractConstr "ConLike"
      gunfold _ _  = error "gunfold"
      dataTypeOf _ = mkNoRepType "ConLike"
  
  -- | Number of value arguments
  conLikeArity :: ConLike -> Arity
  conLikeArity (RealDataCon data_con) = dataConSourceArity data_con
  conLikeArity (PatSynCon pat_syn)    = patSynArity pat_syn
  
  -- | Number of visible arguments
  conLikeVisArity :: ConLike -> VisArity
  conLikeVisArity (RealDataCon data_con) = dataConVisArity data_con
  conLikeVisArity (PatSynCon pat_syn)    = patSynVisArity pat_syn
  
  -- | Names of fields used for selectors
  conLikeFieldLabels :: ConLike -> [FieldLabel]
  conLikeFieldLabels (RealDataCon data_con) = dataConFieldLabels data_con
  conLikeFieldLabels (PatSynCon pat_syn)    = patSynFieldLabels pat_syn
  
  -- | The 'ConInfo' (arity and field labels) associated to a 'ConLike'.
  conLikeConInfo :: ConLike -> ConInfo
  conLikeConInfo con =
    mkConInfo (conLikeConLikeInfo con) (conLikeArity con) (conLikeFieldLabels con)
  
  -- | Compute a 'ConLikeInfo' from a 'ConLike'.
  conLikeConLikeInfo :: ConLike -> ConLikeInfo
  conLikeConLikeInfo (RealDataCon con)
    = ConIsData { conLikeDataCons = getName <$> tyConDataCons (dataConTyCon con) }
  conLikeConLikeInfo (PatSynCon {})
    = ConIsPatSyn
  
  -- | Returns just the instantiated /value/ argument types of a 'ConLike',
  -- (excluding dictionary args)
  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
  
  -- | '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 -> [TyVarBinder]
  conLikeUserTyVarBinders (RealDataCon data_con) =
      dataConUserTyVarBinders data_con
  conLikeUserTyVarBinders (PatSynCon pat_syn) =
      tyVarSpecToBinders $
      patSynUnivTyVarBinders pat_syn ++ patSynExTyVarBinders pat_syn
      -- The order here is because of the order in `GHC.Tc.TyCl.PatSyn`.
  
  -- | Existentially quantified type/coercion variables
  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
  
  -- | 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 (RealDataCon data_con) = dataConStupidTheta data_con
  conLikeStupidTheta (PatSynCon {})         = []
  
  -- | 'conLikeHasBuilder' returns True except for
  -- uni-directional pattern synonyms, which have no builder
  conLikeHasBuilder :: ConLike -> Bool
  conLikeHasBuilder (RealDataCon {})    = True
  conLikeHasBuilder (PatSynCon pat_syn) = isJust (patSynBuilder pat_syn)
  
  -- | Returns the strictness information for each constructor
  conLikeImplBangs :: ConLike -> [HsImplBang]
  conLikeImplBangs (RealDataCon data_con) = dataConImplBangs data_con
  conLikeImplBangs (PatSynCon pat_syn)    =
      replicate (patSynArity pat_syn) HsLazy
  
  -- | Returns the type of the whole pattern
  conLikeResTy :: ConLike -> [Type] -> Type
  conLikeResTy (RealDataCon con) tys = mkTyConApp (dataConTyCon con) tys
  conLikeResTy (PatSynCon ps)    tys = patSynInstResTy ps 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 (RealDataCon con) =
    let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) = dataConFullSig con
    -- Required theta is empty as normal data cons require no additional
    -- constraints for a match
    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
   -- eqSpec is empty
   in (univ_tvs, ex_tvs, [], prov, req, arg_tys, res_ty)
  
  -- | Extract the type for any given labelled field of the 'ConLike'
  conLikeFieldType :: ConLike -> FieldLabelString -> Type
  conLikeFieldType (PatSynCon ps) label = patSynFieldType ps label
  conLikeFieldType (RealDataCon dc) label = dataConFieldType dc label
  
  conLikeIsInfix :: ConLike -> Bool
  conLikeIsInfix (RealDataCon dc) = dataConIsInfix dc
  conLikeIsInfix (PatSynCon ps)   = patSynIsInfix  ps
  