never executed always true always false
    1 {-
    2 (c) The University of Glasgow 2006
    3 (c) The GRASP/AQUA Project, Glasgow University, 1998
    4 
    5 \section[ConLike]{@ConLike@: Constructor-like things}
    6 -}
    7 
    8 
    9 
   10 module GHC.Core.ConLike (
   11           ConLike(..)
   12         , isVanillaConLike
   13         , conLikeArity
   14         , conLikeFieldLabels
   15         , conLikeInstOrigArgTys
   16         , conLikeUserTyVarBinders
   17         , conLikeExTyCoVars
   18         , conLikeName
   19         , conLikeStupidTheta
   20         , conLikeImplBangs
   21         , conLikeFullSig
   22         , conLikeResTy
   23         , conLikeFieldType
   24         , conLikesWithFields
   25         , conLikeIsInfix
   26         , conLikeHasBuilder
   27     ) where
   28 
   29 import GHC.Prelude
   30 
   31 import GHC.Core.DataCon
   32 import GHC.Core.PatSyn
   33 import GHC.Utils.Outputable
   34 import GHC.Types.Unique
   35 import GHC.Utils.Misc
   36 import GHC.Types.Name
   37 import GHC.Types.Basic
   38 import GHC.Core.TyCo.Rep (Type, ThetaType)
   39 import GHC.Types.Var
   40 import GHC.Core.Type(mkTyConApp)
   41 import GHC.Core.Multiplicity
   42 
   43 import Data.Maybe( isJust )
   44 import qualified Data.Data as Data
   45 
   46 {-
   47 ************************************************************************
   48 *                                                                      *
   49 \subsection{Constructor-like things}
   50 *                                                                      *
   51 ************************************************************************
   52 -}
   53 
   54 -- | A constructor-like thing
   55 data ConLike = RealDataCon DataCon
   56              | PatSynCon PatSyn
   57 
   58 -- | Is this a \'vanilla\' constructor-like thing
   59 -- (no existentials, no provided constraints)?
   60 isVanillaConLike :: ConLike -> Bool
   61 isVanillaConLike (RealDataCon con) = isVanillaDataCon con
   62 isVanillaConLike (PatSynCon   ps ) = isVanillaPatSyn  ps
   63 
   64 {-
   65 ************************************************************************
   66 *                                                                      *
   67 \subsection{Instances}
   68 *                                                                      *
   69 ************************************************************************
   70 -}
   71 
   72 instance Eq ConLike where
   73     (==) = eqConLike
   74 
   75 eqConLike :: ConLike -> ConLike -> Bool
   76 eqConLike x y = getUnique x == getUnique y
   77 
   78 -- There used to be an Ord ConLike instance here that used Unique for ordering.
   79 -- It was intentionally removed to prevent determinism problems.
   80 -- See Note [Unique Determinism] in GHC.Types.Unique.
   81 
   82 instance Uniquable ConLike where
   83     getUnique (RealDataCon dc) = getUnique dc
   84     getUnique (PatSynCon ps)   = getUnique ps
   85 
   86 instance NamedThing ConLike where
   87     getName (RealDataCon dc) = getName dc
   88     getName (PatSynCon ps)   = getName ps
   89 
   90 instance Outputable ConLike where
   91     ppr (RealDataCon dc) = ppr dc
   92     ppr (PatSynCon ps) = ppr ps
   93 
   94 instance OutputableBndr ConLike where
   95     pprInfixOcc (RealDataCon dc) = pprInfixOcc dc
   96     pprInfixOcc (PatSynCon ps) = pprInfixOcc ps
   97     pprPrefixOcc (RealDataCon dc) = pprPrefixOcc dc
   98     pprPrefixOcc (PatSynCon ps) = pprPrefixOcc ps
   99 
  100 instance Data.Data ConLike where
  101     -- don't traverse?
  102     toConstr _   = abstractConstr "ConLike"
  103     gunfold _ _  = error "gunfold"
  104     dataTypeOf _ = mkNoRepType "ConLike"
  105 
  106 -- | Number of arguments
  107 conLikeArity :: ConLike -> Arity
  108 conLikeArity (RealDataCon data_con) = dataConSourceArity data_con
  109 conLikeArity (PatSynCon pat_syn)    = patSynArity pat_syn
  110 
  111 -- | Names of fields used for selectors
  112 conLikeFieldLabels :: ConLike -> [FieldLabel]
  113 conLikeFieldLabels (RealDataCon data_con) = dataConFieldLabels data_con
  114 conLikeFieldLabels (PatSynCon pat_syn)    = patSynFieldLabels pat_syn
  115 
  116 -- | Returns just the instantiated /value/ argument types of a 'ConLike',
  117 -- (excluding dictionary args)
  118 conLikeInstOrigArgTys :: ConLike -> [Type] -> [Scaled Type]
  119 conLikeInstOrigArgTys (RealDataCon data_con) tys =
  120     dataConInstOrigArgTys data_con tys
  121 conLikeInstOrigArgTys (PatSynCon pat_syn) tys =
  122     map unrestricted $ patSynInstArgTys pat_syn tys
  123 
  124 -- | 'TyVarBinder's for the type variables of the 'ConLike'. For pattern
  125 -- synonyms, this will always consist of the universally quantified variables
  126 -- followed by the existentially quantified type variables. For data
  127 -- constructors, the situation is slightly more complicated—see
  128 -- @Note [DataCon user type variable binders]@ in "GHC.Core.DataCon".
  129 conLikeUserTyVarBinders :: ConLike -> [InvisTVBinder]
  130 conLikeUserTyVarBinders (RealDataCon data_con) =
  131     dataConUserTyVarBinders data_con
  132 conLikeUserTyVarBinders (PatSynCon pat_syn) =
  133     patSynUnivTyVarBinders pat_syn ++ patSynExTyVarBinders pat_syn
  134     -- The order here is because of the order in `GHC.Tc.TyCl.PatSyn`.
  135 
  136 -- | Existentially quantified type/coercion variables
  137 conLikeExTyCoVars :: ConLike -> [TyCoVar]
  138 conLikeExTyCoVars (RealDataCon dcon1) = dataConExTyCoVars dcon1
  139 conLikeExTyCoVars (PatSynCon psyn1)   = patSynExTyVars psyn1
  140 
  141 conLikeName :: ConLike -> Name
  142 conLikeName (RealDataCon data_con) = dataConName data_con
  143 conLikeName (PatSynCon pat_syn)    = patSynName pat_syn
  144 
  145 -- | The \"stupid theta\" of the 'ConLike', such as @data Eq a@ in:
  146 --
  147 -- > data Eq a => T a = ...
  148 -- It is empty for `PatSynCon` as they do not allow such contexts.
  149 conLikeStupidTheta :: ConLike -> ThetaType
  150 conLikeStupidTheta (RealDataCon data_con) = dataConStupidTheta data_con
  151 conLikeStupidTheta (PatSynCon {})         = []
  152 
  153 -- | 'conLikeHasBuilder' returns True except for
  154 -- uni-directional pattern synonyms, which have no builder
  155 conLikeHasBuilder :: ConLike -> Bool
  156 conLikeHasBuilder (RealDataCon {})    = True
  157 conLikeHasBuilder (PatSynCon pat_syn) = isJust (patSynBuilder pat_syn)
  158 
  159 -- | Returns the strictness information for each constructor
  160 conLikeImplBangs :: ConLike -> [HsImplBang]
  161 conLikeImplBangs (RealDataCon data_con) = dataConImplBangs data_con
  162 conLikeImplBangs (PatSynCon pat_syn)    =
  163     replicate (patSynArity pat_syn) HsLazy
  164 
  165 -- | Returns the type of the whole pattern
  166 conLikeResTy :: ConLike -> [Type] -> Type
  167 conLikeResTy (RealDataCon con) tys = mkTyConApp (dataConTyCon con) tys
  168 conLikeResTy (PatSynCon ps)    tys = patSynInstResTy ps tys
  169 
  170 -- | The \"full signature\" of the 'ConLike' returns, in order:
  171 --
  172 -- 1) The universally quantified type variables
  173 --
  174 -- 2) The existentially quantified type/coercion variables
  175 --
  176 -- 3) The equality specification
  177 --
  178 -- 4) The provided theta (the constraints provided by a match)
  179 --
  180 -- 5) The required theta (the constraints required for a match)
  181 --
  182 -- 6) The original argument types (i.e. before
  183 --    any change of the representation of the type)
  184 --
  185 -- 7) The original result type
  186 conLikeFullSig :: ConLike
  187                -> ([TyVar], [TyCoVar], [EqSpec]
  188                    -- Why tyvars for universal but tycovars for existential?
  189                    -- See Note [Existential coercion variables] in GHC.Core.DataCon
  190                   , ThetaType, ThetaType, [Scaled Type], Type)
  191 conLikeFullSig (RealDataCon con) =
  192   let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) = dataConFullSig con
  193   -- Required theta is empty as normal data cons require no additional
  194   -- constraints for a match
  195   in (univ_tvs, ex_tvs, eq_spec, theta, [], arg_tys, res_ty)
  196 conLikeFullSig (PatSynCon pat_syn) =
  197  let (univ_tvs, req, ex_tvs, prov, arg_tys, res_ty) = patSynSig pat_syn
  198  -- eqSpec is empty
  199  in (univ_tvs, ex_tvs, [], prov, req, arg_tys, res_ty)
  200 
  201 -- | Extract the type for any given labelled field of the 'ConLike'
  202 conLikeFieldType :: ConLike -> FieldLabelString -> Type
  203 conLikeFieldType (PatSynCon ps) label = patSynFieldType ps label
  204 conLikeFieldType (RealDataCon dc) label = dataConFieldType dc label
  205 
  206 
  207 -- | The ConLikes that have *all* the given fields
  208 conLikesWithFields :: [ConLike] -> [FieldLabelString] -> [ConLike]
  209 conLikesWithFields con_likes lbls = filter has_flds con_likes
  210   where has_flds dc = all (has_fld dc) lbls
  211         has_fld dc lbl = any (\ fl -> flLabel fl == lbl) (conLikeFieldLabels dc)
  212 
  213 conLikeIsInfix :: ConLike -> Bool
  214 conLikeIsInfix (RealDataCon dc) = dataConIsInfix dc
  215 conLikeIsInfix (PatSynCon ps)   = patSynIsInfix  ps