%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1998
%
\section[DataCon]{@DataCon@: Data Constructors}
\begin{code}
module DataCon (
DataCon, DataConRep(..), HsBang(..), StrictnessMark(..),
ConTag,
mkDataCon, fIRST_TAG,
buildAlgTyCon,
dataConRepType, dataConSig, dataConFullSig,
dataConName, dataConIdentity, dataConTag, dataConTyCon,
dataConOrigTyCon, dataConUserType,
dataConUnivTyVars, dataConExTyVars, dataConAllTyVars,
dataConEqSpec, eqSpecPreds, dataConTheta,
dataConStupidTheta,
dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy,
dataConInstOrigArgTys, dataConRepArgTys,
dataConFieldLabels, dataConFieldType,
dataConStrictMarks,
dataConSourceArity, dataConRepArity, dataConRepRepArity,
dataConIsInfix,
dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitIds,
dataConRepStrictness, dataConRepBangs, dataConBoxer,
isNullarySrcDataCon, isNullaryRepDataCon, isTupleDataCon, isUnboxedTupleCon,
isVanillaDataCon, classDataCon, dataConCannotMatch,
isBanged, isMarkedStrict, eqHsBang,
promoteKind, promoteDataCon, promoteDataCon_maybe
) where
#include "HsVersions.h"
import MkId( DataConBoxer )
import Type
import TypeRep( Type(..) )
import PrelNames( liftedTypeKindTyConKey )
import ForeignCall( CType )
import Coercion
import Kind
import Unify
import TyCon
import Class
import Name
import Var
import Outputable
import Unique
import ListSetOps
import Util
import BasicTypes
import FastString
import Module
import VarEnv
import qualified Data.Data as Data
import qualified Data.Typeable
import Data.Maybe
import Data.Char
import Data.Word
\end{code}
Data constructor representation
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider the following Haskell data type declaration
data T = T !Int ![Int]
Using the strictness annotations, GHC will represent this as
data T = T Int# [Int]
That is, the Int has been unboxed. Furthermore, the Haskell source construction
T e1 e2
is translated to
case e1 of { I# x ->
case e2 of { r ->
T x r }}
That is, the first argument is unboxed, and the second is evaluated. Finally,
pattern matching is translated too:
case e of { T a b -> ... }
becomes
case e of { T a' b -> let a = I# a' in ... }
To keep ourselves sane, we name the different versions of the data constructor
differently, as follows.
Note [Data Constructor Naming]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Each data constructor C has two, and possibly up to four, Names associated with it:
OccName Name space Name of Notes
---------------------------------------------------------------------------
The "data con itself" C DataName DataCon In dom( GlobalRdrEnv )
The "worker data con" C VarName Id The worker
The "wrapper data con" $WC VarName Id The wrapper
The "newtype coercion" :CoT TcClsName TyCon
EVERY data constructor (incl for newtypes) has the former two (the
data con itself, and its worker. But only some data constructors have a
wrapper (see Note [The need for a wrapper]).
Each of these three has a distinct Unique. The "data con itself" name
appears in the output of the renamer, and names the Haskell-source
data constructor. The type checker translates it into either the wrapper Id
(if it exists) or worker Id (otherwise).
The data con has one or two Ids associated with it:
The "worker Id", is the actual data constructor.
* Every data constructor (newtype or data type) has a worker
* The worker is very like a primop, in that it has no binding.
* For a *data* type, the worker *is* the data constructor;
it has no unfolding
* For a *newtype*, the worker has a compulsory unfolding which
does a cast, e.g.
newtype T = MkT Int
The worker for MkT has unfolding
\\(x:Int). x `cast` sym CoT
Here CoT is the type constructor, witnessing the FC axiom
axiom CoT : T = Int
The "wrapper Id", \$WC, goes as follows
* Its type is exactly what it looks like in the source program.
* It is an ordinary function, and it gets a top-level binding
like any other function.
* The wrapper Id isn't generated for a data type if there is
nothing for the wrapper to do. That is, if its defn would be
\$wC = C
Note [The need for a wrapper]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Why might the wrapper have anything to do? Two reasons:
* Unboxing strict fields (with -funbox-strict-fields)
data T = MkT !(Int,Int)
\$wMkT :: (Int,Int) -> T
\$wMkT (x,y) = MkT x y
Notice that the worker has two fields where the wapper has
just one. That is, the worker has type
MkT :: Int -> Int -> T
* Equality constraints for GADTs
data T a where { MkT :: a -> T [a] }
The worker gets a type with explicit equality
constraints, thus:
MkT :: forall a b. (a=[b]) => b -> T a
The wrapper has the programmer-specified type:
\$wMkT :: a -> T [a]
\$wMkT a x = MkT [a] a [a] x
The third argument is a coerion
[a] :: [a]~[a]
INVARIANT: the dictionary constructor for a class
never has a wrapper.
A note about the stupid context
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Data types can have a context:
data (Eq a, Ord b) => T a b = T1 a b | T2 a
and that makes the constructors have a context too
(notice that T2's context is "thinned"):
T1 :: (Eq a, Ord b) => a -> b -> T a b
T2 :: (Eq a) => a -> T a b
Furthermore, this context pops up when pattern matching
(though GHC hasn't implemented this, but it is in H98, and
I've fixed GHC so that it now does):
f (T2 x) = x
gets inferred type
f :: Eq a => T a b -> a
I say the context is "stupid" because the dictionaries passed
are immediately discarded -- they do nothing and have no benefit.
It's a flaw in the language.
Up to now [March 2002] I have put this stupid context into the
type of the "wrapper" constructors functions, T1 and T2, but
that turned out to be jolly inconvenient for generics, and
record update, and other functions that build values of type T
(because they don't have suitable dictionaries available).
So now I've taken the stupid context out. I simply deal with
it separately in the type checker on occurrences of a
constructor, either in an expression or in a pattern.
[May 2003: actually I think this decision could evasily be
reversed now, and probably should be. Generics could be
disabled for types with a stupid context; record updates now
(H98) needs the context too; etc. It's an unforced change, so
I'm leaving it for now --- but it does seem odd that the
wrapper doesn't include the stupid context.]
[July 04] With the advent of generalised data types, it's less obvious
what the "stupid context" is. Consider
C :: forall a. Ord a => a -> a -> T (Foo a)
Does the C constructor in Core contain the Ord dictionary? Yes, it must:
f :: T b -> Ordering
f = /\b. \x:T b.
case x of
C a (d:Ord a) (p:a) (q:a) -> compare d p q
Note that (Foo a) might not be an instance of Ord.
%************************************************************************
%* *
\subsection{Data constructors}
%* *
%************************************************************************
\begin{code}
data DataCon
= MkData {
dcName :: Name,
dcUnique :: Unique,
dcTag :: ConTag,
dcVanilla :: Bool,
dcUnivTyVars :: [TyVar],
dcExTyVars :: [TyVar],
dcEqSpec :: [(TyVar,Type)],
dcOtherTheta :: ThetaType,
dcStupidTheta :: ThetaType,
dcOrigArgTys :: [Type],
dcOrigResTy :: Type,
dcArgBangs :: [HsBang],
dcFields :: [FieldLabel],
dcWorkId :: Id,
dcRep :: DataConRep,
dcRepArity :: Arity,
dcSourceArity :: Arity,
dcRepTyCon :: TyCon,
dcRepType :: Type,
dcInfix :: Bool,
dcPromoted :: Maybe TyCon
}
deriving Data.Typeable.Typeable
data DataConRep
= NoDataConRep
| DCR { dcr_wrap_id :: Id
, dcr_boxer :: DataConBoxer
, dcr_arg_tys :: [Type]
, dcr_stricts :: [StrictnessMark]
, dcr_bangs :: [HsBang]
}
data HsBang
= HsUserBang
(Maybe Bool)
Bool
| HsNoBang
| HsUnpack
(Maybe Coercion)
| HsStrict
deriving (Data.Data, Data.Typeable)
data StrictnessMark = MarkedStrict | NotMarkedStrict
\end{code}
Note [Data con representation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The dcRepType field contains the type of the representation of a contructor
This may differ from the type of the contructor *Id* (built
by MkId.mkDataConId) for two reasons:
a) the constructor Id may be overloaded, but the dictionary isn't stored
e.g. data Eq a => T a = MkT a a
b) the constructor may store an unboxed version of a strict field.
Here's an example illustrating both:
data Ord a => T a = MkT Int! a
Here
T :: Ord a => Int -> a -> T a
but the rep type is
Trep :: Int# -> a -> T a
Actually, the unboxed part isn't implemented yet!
Note [Bangs on data constructor arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
data T = MkT !Int {-# UNPACK #-} !Int Bool
Its dcArgBangs field records the *users* specifications, in this case
[ HsUserBang Nothing True
, HsUserBang (Just True) True
, HsNoBang]
See the declaration of HsBang in BasicTypes
The dcr_bangs field of the dcRep field records the *actual, decided*
representation of the data constructor. Without -O this might be
[HsStrict, HsStrict, HsNoBang]
With -O it might be
[HsStrict, HsUnpack, HsNoBang]
With -funbox-small-strict-fields it might be
[HsUnpack, HsUnpack, HsNoBang]
For imported data types, the dcArgBangs field is just the same as the
dcr_bangs field; we don't know what the user originally said.
%************************************************************************
%* *
\subsection{Instances}
%* *
%************************************************************************
\begin{code}
instance Eq DataCon where
a == b = getUnique a == getUnique b
a /= b = getUnique a /= getUnique b
instance Ord DataCon where
a <= b = getUnique a <= getUnique b
a < b = getUnique a < getUnique b
a >= b = getUnique a >= getUnique b
a > b = getUnique a > getUnique b
compare a b = getUnique a `compare` getUnique b
instance Uniquable DataCon where
getUnique = dcUnique
instance NamedThing DataCon where
getName = dcName
instance Outputable DataCon where
ppr con = ppr (dataConName con)
instance OutputableBndr DataCon where
pprInfixOcc con = pprInfixName (dataConName con)
pprPrefixOcc con = pprPrefixName (dataConName con)
instance Data.Data DataCon where
toConstr _ = abstractConstr "DataCon"
gunfold _ _ = error "gunfold"
dataTypeOf _ = mkNoRepType "DataCon"
instance Outputable HsBang where
ppr HsNoBang = empty
ppr (HsUserBang prag bang) = pp_unpk prag <+> ppWhen bang (char '!')
ppr (HsUnpack Nothing) = ptext (sLit "Unpk")
ppr (HsUnpack (Just co)) = ptext (sLit "Unpk") <> parens (ppr co)
ppr HsStrict = ptext (sLit "SrictNotUnpacked")
pp_unpk :: Maybe Bool -> SDoc
pp_unpk Nothing = empty
pp_unpk (Just True) = ptext (sLit "{-# UNPACK #-}")
pp_unpk (Just False) = ptext (sLit "{-# NOUNPACK #-}")
instance Outputable StrictnessMark where
ppr MarkedStrict = ptext (sLit "!")
ppr NotMarkedStrict = empty
eqHsBang :: HsBang -> HsBang -> Bool
eqHsBang HsNoBang HsNoBang = True
eqHsBang HsStrict HsStrict = True
eqHsBang (HsUserBang u1 b1) (HsUserBang u2 b2) = u1==u2 && b1==b2
eqHsBang (HsUnpack Nothing) (HsUnpack Nothing) = True
eqHsBang (HsUnpack (Just c1)) (HsUnpack (Just c2)) = eqType (coercionType c1) (coercionType c2)
eqHsBang _ _ = False
isBanged :: HsBang -> Bool
isBanged HsNoBang = False
isBanged (HsUserBang Nothing bang) = bang
isBanged _ = True
isMarkedStrict :: StrictnessMark -> Bool
isMarkedStrict NotMarkedStrict = False
isMarkedStrict _ = True
\end{code}
%************************************************************************
%* *
\subsection{Construction}
%* *
%************************************************************************
\begin{code}
mkDataCon :: Name
-> Bool
-> [HsBang]
-> [FieldLabel]
-> [TyVar]
-> [TyVar]
-> [(TyVar,Type)]
-> ThetaType
-> [Type]
-> Type
-> TyCon
-> ThetaType
-> Id
-> DataConRep
-> DataCon
mkDataCon name declared_infix
arg_stricts
fields
univ_tvs ex_tvs
eq_spec theta
orig_arg_tys orig_res_ty rep_tycon
stupid_theta work_id rep
= con
where
is_vanilla = null ex_tvs && null eq_spec && null theta
con = MkData {dcName = name, dcUnique = nameUnique name,
dcVanilla = is_vanilla, dcInfix = declared_infix,
dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs,
dcEqSpec = eq_spec,
dcOtherTheta = theta,
dcStupidTheta = stupid_theta,
dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty,
dcRepTyCon = rep_tycon,
dcArgBangs = arg_stricts,
dcFields = fields, dcTag = tag, dcRepType = rep_ty,
dcWorkId = work_id,
dcRep = rep,
dcSourceArity = length orig_arg_tys,
dcRepArity = length rep_arg_tys,
dcPromoted = mb_promoted }
tag = assoc "mkDataCon" (tyConDataCons rep_tycon `zip` [fIRST_TAG..]) con
rep_arg_tys = dataConRepArgTys con
rep_ty = mkForAllTys univ_tvs $ mkForAllTys ex_tvs $
mkFunTys rep_arg_tys $
mkTyConApp rep_tycon (mkTyVarTys univ_tvs)
mb_promoted
| isJust (promotableTyCon_maybe rep_tycon)
= Just (mkPromotedDataCon con name (getUnique name) prom_kind roles)
| otherwise
= Nothing
prom_kind = promoteType (dataConUserType con)
roles = map (const Nominal) (univ_tvs ++ ex_tvs) ++
map (const Representational) orig_arg_tys
eqSpecPreds :: [(TyVar,Type)] -> ThetaType
eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv) ty | (tv,ty) <- spec ]
\end{code}
Note [Unpack equality predicates]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If we have a GADT with a contructor C :: (a~[b]) => b -> T a
we definitely want that equality predicate *unboxed* so that it
takes no space at all. This is easily done: just give it
an UNPACK pragma. The rest of the unpack/repack code does the
heavy lifting. This one line makes every GADT take a word less
space for each equality predicate, so it's pretty important!
\begin{code}
dataConName :: DataCon -> Name
dataConName = dcName
dataConTag :: DataCon -> ConTag
dataConTag = dcTag
dataConTyCon :: DataCon -> TyCon
dataConTyCon = dcRepTyCon
dataConOrigTyCon :: DataCon -> TyCon
dataConOrigTyCon dc
| Just (tc, _) <- tyConFamInst_maybe (dcRepTyCon dc) = tc
| otherwise = dcRepTyCon dc
dataConRepType :: DataCon -> Type
dataConRepType = dcRepType
dataConIsInfix :: DataCon -> Bool
dataConIsInfix = dcInfix
dataConUnivTyVars :: DataCon -> [TyVar]
dataConUnivTyVars = dcUnivTyVars
dataConExTyVars :: DataCon -> [TyVar]
dataConExTyVars = dcExTyVars
dataConAllTyVars :: DataCon -> [TyVar]
dataConAllTyVars (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs })
= univ_tvs ++ ex_tvs
dataConEqSpec :: DataCon -> [(TyVar,Type)]
dataConEqSpec = dcEqSpec
dataConTheta :: DataCon -> ThetaType
dataConTheta (MkData { dcEqSpec = eq_spec, dcOtherTheta = theta })
= eqSpecPreds eq_spec ++ theta
dataConWorkId :: DataCon -> Id
dataConWorkId dc = dcWorkId dc
dataConWrapId_maybe :: DataCon -> Maybe Id
dataConWrapId_maybe dc = case dcRep dc of
NoDataConRep -> Nothing
DCR { dcr_wrap_id = wrap_id } -> Just wrap_id
dataConWrapId :: DataCon -> Id
dataConWrapId dc = case dcRep dc of
NoDataConRep-> dcWorkId dc
DCR { dcr_wrap_id = wrap_id } -> wrap_id
dataConImplicitIds :: DataCon -> [Id]
dataConImplicitIds (MkData { dcWorkId = work, dcRep = rep})
= case rep of
NoDataConRep -> [work]
DCR { dcr_wrap_id = wrap } -> [wrap,work]
dataConFieldLabels :: DataCon -> [FieldLabel]
dataConFieldLabels = dcFields
dataConFieldType :: DataCon -> FieldLabel -> Type
dataConFieldType con label
= case lookup label (dcFields con `zip` dcOrigArgTys con) of
Just ty -> ty
Nothing -> pprPanic "dataConFieldType" (ppr con <+> ppr label)
dataConStrictMarks :: DataCon -> [HsBang]
dataConStrictMarks = dcArgBangs
dataConSourceArity :: DataCon -> Arity
dataConSourceArity (MkData { dcSourceArity = arity }) = arity
dataConRepArity :: DataCon -> Arity
dataConRepArity (MkData { dcRepArity = arity }) = arity
dataConRepRepArity :: DataCon -> RepArity
dataConRepRepArity dc = typeRepArity (dataConRepArity dc) (dataConRepType dc)
isNullarySrcDataCon :: DataCon -> Bool
isNullarySrcDataCon dc = null (dcOrigArgTys dc)
isNullaryRepDataCon :: DataCon -> Bool
isNullaryRepDataCon dc = dataConRepArity dc == 0
dataConRepStrictness :: DataCon -> [StrictnessMark]
dataConRepStrictness dc = case dcRep dc of
NoDataConRep -> [NotMarkedStrict | _ <- dataConRepArgTys dc]
DCR { dcr_stricts = strs } -> strs
dataConRepBangs :: DataCon -> [HsBang]
dataConRepBangs dc = case dcRep dc of
NoDataConRep -> dcArgBangs dc
DCR { dcr_bangs = bangs } -> bangs
dataConBoxer :: DataCon -> Maybe DataConBoxer
dataConBoxer (MkData { dcRep = DCR { dcr_boxer = boxer } }) = Just boxer
dataConBoxer _ = Nothing
dataConSig :: DataCon -> ([TyVar], ThetaType, [Type], Type)
dataConSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs,
dcEqSpec = eq_spec, dcOtherTheta = theta,
dcOrigArgTys = arg_tys, dcOrigResTy = res_ty})
= (univ_tvs ++ ex_tvs, eqSpecPreds eq_spec ++ theta, arg_tys, res_ty)
dataConFullSig :: DataCon
-> ([TyVar], [TyVar], [(TyVar,Type)], ThetaType, [Type], Type)
dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs,
dcEqSpec = eq_spec, dcOtherTheta = theta,
dcOrigArgTys = arg_tys, dcOrigResTy = res_ty})
= (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty)
dataConOrigResTy :: DataCon -> Type
dataConOrigResTy dc = dcOrigResTy dc
dataConStupidTheta :: DataCon -> ThetaType
dataConStupidTheta dc = dcStupidTheta dc
dataConUserType :: DataCon -> Type
dataConUserType (MkData { dcUnivTyVars = univ_tvs,
dcExTyVars = ex_tvs, dcEqSpec = eq_spec,
dcOtherTheta = theta, dcOrigArgTys = arg_tys,
dcOrigResTy = res_ty })
= mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $
mkFunTys theta $
mkFunTys arg_tys $
res_ty
dataConInstArgTys :: DataCon
-> [Type]
-> [Type]
dataConInstArgTys dc@(MkData {dcUnivTyVars = univ_tvs, dcEqSpec = eq_spec,
dcExTyVars = ex_tvs}) inst_tys
= ASSERT2( length univ_tvs == length inst_tys
, ptext (sLit "dataConInstArgTys") <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys)
ASSERT2( null ex_tvs && null eq_spec, ppr dc )
map (substTyWith univ_tvs inst_tys) (dataConRepArgTys dc)
dataConInstOrigArgTys
:: DataCon
-> [Type]
-> [Type]
dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys,
dcUnivTyVars = univ_tvs,
dcExTyVars = ex_tvs}) inst_tys
= ASSERT2( length tyvars == length inst_tys
, ptext (sLit "dataConInstOrigArgTys") <+> ppr dc $$ ppr tyvars $$ ppr inst_tys )
map (substTyWith tyvars inst_tys) arg_tys
where
tyvars = univ_tvs ++ ex_tvs
\end{code}
\begin{code}
dataConOrigArgTys :: DataCon -> [Type]
dataConOrigArgTys dc = dcOrigArgTys dc
dataConRepArgTys :: DataCon -> [Type]
dataConRepArgTys (MkData { dcRep = rep
, dcEqSpec = eq_spec
, dcOtherTheta = theta
, dcOrigArgTys = orig_arg_tys })
= case rep of
NoDataConRep -> ASSERT( null eq_spec ) theta ++ orig_arg_tys
DCR { dcr_arg_tys = arg_tys } -> arg_tys
\end{code}
\begin{code}
dataConIdentity :: DataCon -> [Word8]
dataConIdentity dc = bytesFS (packageIdFS (modulePackageId mod)) ++
fromIntegral (ord ':') : bytesFS (moduleNameFS (moduleName mod)) ++
fromIntegral (ord '.') : bytesFS (occNameFS (nameOccName name))
where name = dataConName dc
mod = ASSERT( isExternalName name ) nameModule name
\end{code}
\begin{code}
isTupleDataCon :: DataCon -> Bool
isTupleDataCon (MkData {dcRepTyCon = tc}) = isTupleTyCon tc
isUnboxedTupleCon :: DataCon -> Bool
isUnboxedTupleCon (MkData {dcRepTyCon = tc}) = isUnboxedTupleTyCon tc
isVanillaDataCon :: DataCon -> Bool
isVanillaDataCon dc = dcVanilla dc
\end{code}
\begin{code}
classDataCon :: Class -> DataCon
classDataCon clas = case tyConDataCons (classTyCon clas) of
(dict_constr:no_more) -> ASSERT( null no_more ) dict_constr
[] -> panic "classDataCon"
\end{code}
\begin{code}
dataConCannotMatch :: [Type] -> DataCon -> Bool
dataConCannotMatch tys con
| null theta = False
| all isTyVarTy tys = False
| otherwise
= typesCantMatch [(Type.substTy subst ty1, Type.substTy subst ty2)
| (ty1, ty2) <- concatMap predEqs theta ]
where
dc_tvs = dataConUnivTyVars con
theta = dataConTheta con
subst = ASSERT2( length dc_tvs == length tys, ppr con $$ ppr dc_tvs $$ ppr tys )
zipTopTvSubst dc_tvs tys
predEqs pred = case classifyPredType pred of
EqPred ty1 ty2 -> [(ty1, ty2)]
TuplePred ts -> concatMap predEqs ts
_ -> []
\end{code}
%************************************************************************
%* *
Building an algebraic data type
%* *
%************************************************************************
\begin{code}
buildAlgTyCon :: Name
-> [TyVar]
-> [Role]
-> Maybe CType
-> ThetaType
-> AlgTyConRhs
-> RecFlag
-> Bool
-> Bool
-> TyConParent
-> TyCon
buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs
is_rec is_promotable gadt_syn parent
= tc
where
kind = mkPiKinds ktvs liftedTypeKind
tc = mkAlgTyCon tc_name kind ktvs roles cType stupid_theta
rhs parent is_rec gadt_syn
mb_promoted_tc
mb_promoted_tc
| is_promotable = Just (mkPromotedTyCon tc (promoteKind kind))
| otherwise = Nothing
\end{code}
%************************************************************************
%* *
Promoting of data types to the kind level
%* *
%************************************************************************
These two 'promoted..' functions are here because
* They belong together
* 'prmoteDataCon' depends on DataCon stuff
\begin{code}
promoteDataCon :: DataCon -> TyCon
promoteDataCon (MkData { dcPromoted = Just tc }) = tc
promoteDataCon dc = pprPanic "promoteDataCon" (ppr dc)
promoteDataCon_maybe :: DataCon -> Maybe TyCon
promoteDataCon_maybe (MkData { dcPromoted = mb_tc }) = mb_tc
\end{code}
Note [Promoting a Type to a Kind]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppsoe we have a data constructor D
D :: forall (a:*). Maybe a -> T a
We promote this to be a type constructor 'D:
'D :: forall (k:BOX). 'Maybe k -> 'T k
The transformation from type to kind is done by promoteType
* Convert forall (a:*) to forall (k:BOX), and substitute
* Ensure all foralls are at the top (no higher rank stuff)
* Ensure that all type constructors mentioned (Maybe and T
in the example) are promotable; that is, they have kind
* -> ... -> * -> *
\begin{code}
promoteType :: Type -> Kind
promoteType ty
= mkForAllTys kvs (go rho)
where
(tvs, rho) = splitForAllTys ty
kvs = [ mkKindVar (tyVarName tv) superKind | tv <- tvs ]
env = zipVarEnv tvs kvs
go (TyConApp tc tys) | Just prom_tc <- promotableTyCon_maybe tc
= mkTyConApp prom_tc (map go tys)
go (FunTy arg res) = mkArrowKind (go arg) (go res)
go (TyVarTy tv) | Just kv <- lookupVarEnv env tv
= TyVarTy kv
go _ = panic "promoteType"
promoteKind :: Kind -> SuperKind
promoteKind (TyConApp tc [])
| tc `hasKey` liftedTypeKindTyConKey = superKind
promoteKind (FunTy arg res) = FunTy (promoteKind arg) (promoteKind res)
promoteKind k = pprPanic "promoteKind" (ppr k)
\end{code}