diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs
index d46759c7fdfde142c1d700be7a913bf333813752..c82f018962cbbd818b0b999817b65a234f396ab7 100644
--- a/compiler/basicTypes/DataCon.lhs
+++ b/compiler/basicTypes/DataCon.lhs
@@ -45,8 +45,8 @@ module DataCon (
deepSplitProductType_maybe,
-- ** Promotion related functions
- promoteType, isPromotableType, isPromotableTyCon,
- buildPromotedTyCon, buildPromotedDataCon,
+ isPromotableTyCon, promoteTyCon,
+ promoteDataCon, promoteDataCon_maybe
) where
#include "HsVersions.h"
@@ -386,9 +386,11 @@ data DataCon
-- An entirely separate wrapper function is built in TcTyDecls
dcIds :: DataConIds,
- dcInfix :: Bool -- True <=> declared infix
+ dcInfix :: Bool, -- True <=> declared infix
-- Used for Template Haskell and 'deriving' only
-- The actual fixity is stored elsewhere
+
+ dcPromoted :: Maybe TyCon -- The promoted TyCon if this DataCon is promotable
}
deriving Data.Typeable.Typeable
@@ -519,10 +521,7 @@ mkDataCon name declared_infix
-- so the error is detected properly... it's just that asaertions here
-- are a little dodgy.
- = -- ASSERT( not (any isEqPred theta) )
- -- We don't currently allow any equality predicates on
- -- a data constructor (apart from the GADT ones in eq_spec)
- con
+ = con
where
is_vanilla = null ex_tvs && null eq_spec && null theta
con = MkData {dcName = name, dcUnique = nameUnique name,
@@ -537,7 +536,8 @@ mkDataCon name declared_infix
dcStrictMarks = arg_stricts,
dcRepStrictness = rep_arg_stricts,
dcFields = fields, dcTag = tag, dcRepType = ty,
- dcIds = ids }
+ dcIds = ids,
+ dcPromoted = mb_promoted }
-- Strictness marks for source-args
-- *after unboxing choices*,
@@ -559,6 +559,16 @@ mkDataCon name declared_infix
mkFunTys rep_arg_tys $
mkTyConApp rep_tycon (mkTyVarTys univ_tvs)
+ mb_promoted
+ | is_vanilla -- No existentials or context
+ , all (isLiftedTypeKind . tyVarKind) univ_tvs
+ , all isPromotableType orig_arg_tys
+ = Just (mkPromotedDataCon con name (getUnique name) prom_kind arity)
+ | otherwise
+ = Nothing
+ prom_kind = promoteType (dataConUserType con)
+ arity = dataConSourceArity con
+
eqSpecPreds :: [(TyVar,Type)] -> ThetaType
eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv) ty | (tv,ty) <- spec ]
@@ -978,24 +988,22 @@ computeRep stricts tys
%* *
%************************************************************************
-These two 'buildPromoted..' functions are here because
+These two 'promoted..' functions are here because
* They belong together
- * 'buildPromotedTyCon' is used by promoteType
- * 'buildPromotedTyCon' depends on DataCon stuff
+ * 'promoteTyCon' is used by promoteType
+ * 'prmoteDataCon' depends on DataCon stuff
\begin{code}
-buildPromotedTyCon :: TyCon -> TyCon
-buildPromotedTyCon tc
- = mkPromotedTyCon tc (promoteKind (tyConKind tc))
+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
-buildPromotedDataCon :: DataCon -> TyCon
-buildPromotedDataCon dc
- = ASSERT ( isPromotableType ty )
- mkPromotedDataCon dc (getName dc) (getUnique dc) kind arity
- where
- ty = dataConUserType dc
- kind = promoteType ty
- arity = dataConSourceArity dc
+promoteTyCon :: TyCon -> TyCon
+promoteTyCon tc
+ = mkPromotedTyCon tc (promoteKind (tyConKind tc))
\end{code}
Note [Promoting a Type to a Kind]
@@ -1017,16 +1025,11 @@ The transformation from type to kind is done by promoteType
\begin{code}
isPromotableType :: Type -> Bool
-isPromotableType ty
- = all (isLiftedTypeKind . tyVarKind) tvs
- && go rho
- where
- (tvs, rho) = splitForAllTys ty
- go (TyConApp tc tys) | Just n <- isPromotableTyCon tc
- = tys `lengthIs` n && all go tys
- go (FunTy arg res) = go arg && go res
- go (TyVarTy tvar) = tvar `elem` tvs
- go _ = False
+isPromotableType (TyConApp tc tys)
+ | Just n <- isPromotableTyCon tc = tys `lengthIs` n && all isPromotableType tys
+isPromotableType (FunTy arg res) = isPromotableType arg && isPromotableType res
+isPromotableType (TyVarTy {}) = True
+isPromotableType _ = False
-- If tc's kind is [ *^n -> * ] returns [ Just n ], else returns [ Nothing ]
isPromotableTyCon :: TyCon -> Maybe Int
@@ -1048,7 +1051,7 @@ promoteType ty
kvs = [ mkKindVar (tyVarName tv) superKind | tv <- tvs ]
env = zipVarEnv tvs kvs
- go (TyConApp tc tys) = mkTyConApp (buildPromotedTyCon tc) (map go tys)
+ go (TyConApp tc tys) = mkTyConApp (promoteTyCon tc) (map go tys)
go (FunTy arg res) = mkArrowKind (go arg) (go res)
go (TyVarTy tv) | Just kv <- lookupVarEnv env tv
= TyVarTy kv
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 55b997853c2cc9f1446ec9781ffac7a1866ca327..ae7abf41b998d8811c60d0faea67adcd71b2dc3a 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -1362,7 +1362,7 @@ tcIfaceTyCon (IfaceTc name)
; case thing of -- A "type constructor" can be a promoted data constructor
-- c.f. Trac #5881
ATyCon tc -> return tc
- ADataCon dc -> return (buildPromotedDataCon dc)
+ ADataCon dc -> return (promoteDataCon dc)
_ -> pprPanic "tcIfaceTyCon" (ppr name $$ ppr thing) }
tcIfaceKindCon :: IfaceTyCon -> IfL TyCon
@@ -1372,7 +1372,7 @@ tcIfaceKindCon (IfaceTc name)
-- c.f. Trac #5881
ATyCon tc
| isSuperKind (tyConKind tc) -> return tc -- Mainly just '*' or 'AnyK'
- | otherwise -> return (buildPromotedTyCon tc)
+ | otherwise -> return (promoteTyCon tc)
_ -> pprPanic "tcIfaceKindCon" (ppr name $$ ppr thing) }
diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs
index 78e1f74b4d9833616e2506e513175d57068f954f..5071b33e9a55b5a8c612de165782ea2492983c6e 100644
--- a/compiler/prelude/TysWiredIn.lhs
+++ b/compiler/prelude/TysWiredIn.lhs
@@ -322,10 +322,10 @@ tupleTyCon UnboxedTuple i = fst (unboxedTupleArr ! i)
tupleTyCon ConstraintTuple i = fst (factTupleArr ! i)
promotedTupleTyCon :: TupleSort -> Arity -> TyCon
-promotedTupleTyCon sort i = buildPromotedTyCon (tupleTyCon sort i)
+promotedTupleTyCon sort i = promoteTyCon (tupleTyCon sort i)
promotedTupleDataCon :: TupleSort -> Arity -> TyCon
-promotedTupleDataCon sort i = buildPromotedDataCon (tupleCon sort i)
+promotedTupleDataCon sort i = promoteDataCon (tupleCon sort i)
tupleCon :: TupleSort -> Arity -> DataCon
tupleCon sort i | i > mAX_TUPLE_SIZE = snd (mk_tuple sort i) -- Build one specially
@@ -605,7 +605,7 @@ mkPromotedListTy :: Type -> Type
mkPromotedListTy ty = mkTyConApp promotedListTyCon [ty]
promotedListTyCon :: TyCon
-promotedListTyCon = buildPromotedTyCon listTyCon
+promotedListTyCon = promoteTyCon listTyCon
nilDataCon :: DataCon
nilDataCon = pcDataCon nilDataConName alpha_tyvar [] listTyCon
diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
index 147e16dbe1dbc3ab03bf3bb91cee8f14e754c1c4..5398adc8f1fdea0f519089527926b539b4e682a5 100644
--- a/compiler/types/TyCon.lhs
+++ b/compiler/types/TyCon.lhs
@@ -595,7 +595,7 @@ via the PromotedTyCon alternative in TyCon.
kind signature on the forall'd variable; so the tc_kind field of
PromotedTyCon is not identical to the dataConUserType of the
DataCon. But it's the same modulo changing the variable kinds,
- done by Kind.promoteType.
+ done by DataCon.promoteType.
* Small note: We promote the *user* type of the DataCon. Eg
data T = MkT {-# UNPACK #-} !(Bool, Bool)