Only promote *non-existential* data constructors

I don't konw how this was left out before; Trac #7347.

In fixing this I did the usual round of refactoring.  In particular, I
cached the fact that a DataCon can be promoted in the DataCon
itself (the dcPromoted field).

4 files changed, 42 insertions, 39 deletions

diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs
index a504c5bbe7..6b918dbc08 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 19b5cfe405..3db325afb9 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -1364,7 +1364,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
@@ -1374,7 +1374,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 78e1f74b4d..5071b33e9a 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 5919779703..88fbb3a7e9 100644
--- a/compiler/types/TyCon.lhs
+++ b/compiler/types/TyCon.lhs
@@ -607,7 +607,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)