Nicer pretty printing for tuple kinds

6 files changed, 39 insertions, 26 deletions

diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs
index d46759c7fd..a504c5bbe7 100644
--- a/compiler/basicTypes/DataCon.lhs
+++ b/compiler/basicTypes/DataCon.lhs
@@ -37,7 +37,7 @@ module DataCon (
 	dataConRepStrictness,
 	
 	-- ** Predicates on DataCons
-	isNullarySrcDataCon, isNullaryRepDataCon, isTupleCon, isUnboxedTupleCon,
+	isNullarySrcDataCon, isNullaryRepDataCon, isTupleDataCon, isUnboxedTupleCon,
 	isVanillaDataCon, classDataCon, dataConCannotMatch,
 
         -- * Splitting product types
@@ -838,8 +838,8 @@ dataConIdentity dc = bytesFS (packageIdFS (modulePackageId mod)) ++
 \end{code}
 
 \begin{code}
-isTupleCon :: DataCon -> Bool
-isTupleCon (MkData {dcRepTyCon = tc}) = isTupleTyCon tc
+isTupleDataCon :: DataCon -> Bool
+isTupleDataCon (MkData {dcRepTyCon = tc}) = isTupleTyCon tc
 	
 isUnboxedTupleCon :: DataCon -> Bool
 isUnboxedTupleCon (MkData {dcRepTyCon = tc}) = isUnboxedTupleTyCon tc
diff --git a/compiler/basicTypes/DataCon.lhs-boot b/compiler/basicTypes/DataCon.lhs-boot
index 3477a4b2e4..94bf889325 100644
--- a/compiler/basicTypes/DataCon.lhs-boot
+++ b/compiler/basicTypes/DataCon.lhs-boot
@@ -1,9 +1,11 @@
 \begin{code}
 module DataCon where
 import Name( Name )
+import {-# SOURCE #-} TyCon( TyCon )
 
 data DataCon
 dataConName      :: DataCon -> Name
+dataConTyCon     :: DataCon -> TyCon
 isVanillaDataCon :: DataCon -> Bool
 instance Eq DataCon
 instance Ord DataCon
diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs
index 75c3d11b91..ad590ae8d8 100644
--- a/compiler/deSugar/Check.lhs
+++ b/compiler/deSugar/Check.lhs
@@ -529,7 +529,7 @@ similar) at the same time that we create the constructors.
 
 You can tell tuple constructors using
 \begin{verbatim}
-        Id.isTupleCon
+        Id.isTupleDataCon
 \end{verbatim}
 You can see if one constructor is infix with this clearer code :-))))))))))
 \begin{verbatim}
diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index 334c3a5c36..419647bd12 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -1376,10 +1376,10 @@ reify_kc_app :: TyCon -> [TypeRep.Kind] -> TcM TH.Kind
 reify_kc_app kc kis
   = fmap (foldl TH.AppT r_kc) (mapM reifyKind kis)
   where
-    r_kc | isPromotedTyCon kc &&
-           isTupleTyCon (promotedTyCon kc)  = TH.TupleT (tyConArity kc)
-         | kc `hasKey` listTyConKey         = TH.ListT
-         | otherwise                        = TH.ConT (reifyName kc)
+    r_kc | Just tc <- isPromotedTyCon_maybe kc
+         , isTupleTyCon tc          = TH.TupleT (tyConArity kc)
+         | kc `hasKey` listTyConKey = TH.ListT
+         | otherwise                = TH.ConT (reifyName kc)
 
 reifyCxt :: [PredType] -> TcM [TH.Pred]
 reifyCxt   = mapM reifyPred
@@ -1410,8 +1410,8 @@ reify_tc_app tc tys
   where
     arity = tyConArity tc
     r_tc | isTupleTyCon tc            = if isPromotedDataCon tc
-                                          then TH.PromotedTupleT arity
-                                          else TH.TupleT arity
+                                        then TH.PromotedTupleT arity
+                                        else TH.TupleT arity
          | tc `hasKey` listTyConKey   = TH.ListT
          | tc `hasKey` nilDataConKey  = TH.PromotedNilT
          | tc `hasKey` consDataConKey = TH.PromotedConsT
diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
index 147e16dbe1..1d9dffe48f 100644
--- a/compiler/types/TyCon.lhs
+++ b/compiler/types/TyCon.lhs
@@ -42,6 +42,7 @@ module TyCon(
         isDecomposableTyCon,
         isForeignTyCon, 
         isPromotedDataCon, isPromotedTyCon,
+        isPromotedDataCon_maybe, isPromotedTyCon_maybe,
 
         isInjectiveTyCon,
         isDataTyCon, isProductTyCon, isEnumerationTyCon,
@@ -71,7 +72,6 @@ module TyCon(
         algTyConRhs,
         newTyConRhs, newTyConEtadRhs, unwrapNewTyCon_maybe,
         tupleTyConBoxity, tupleTyConSort, tupleTyConArity,
-        promotedDataCon, promotedTyCon,
 
         -- ** Manipulating TyCons
         tcExpandTyCon_maybe, coreExpandTyCon_maybe,
@@ -1183,25 +1183,25 @@ isForeignTyCon :: TyCon -> Bool
 isForeignTyCon (PrimTyCon {tyConExtName = Just _}) = True
 isForeignTyCon _                                   = False
 
--- | Is this a PromotedDataCon?
-isPromotedDataCon :: TyCon -> Bool
-isPromotedDataCon (PromotedDataCon {}) = True
-isPromotedDataCon _                    = False
-
 -- | Is this a PromotedTyCon?
 isPromotedTyCon :: TyCon -> Bool
 isPromotedTyCon (PromotedTyCon {}) = True
 isPromotedTyCon _                  = False
 
--- | Retrieves the promoted DataCon if this is a PromotedDataTyCon;
--- Panics otherwise
-promotedDataCon :: TyCon -> DataCon
-promotedDataCon = dataCon
+-- | Retrieves the promoted TyCon if this is a PromotedTyCon;
+isPromotedTyCon_maybe :: TyCon -> Maybe TyCon
+isPromotedTyCon_maybe (PromotedTyCon { ty_con = tc }) = Just tc
+isPromotedTyCon_maybe _ = Nothing
 
--- | Retrieves the promoted TypeCon if this is a PromotedTypeTyCon;
--- Panics otherwise
-promotedTyCon :: TyCon -> TyCon
-promotedTyCon = ty_con
+-- | Is this a PromotedDataCon?
+isPromotedDataCon :: TyCon -> Bool
+isPromotedDataCon (PromotedDataCon {}) = True
+isPromotedDataCon _                    = False
+
+-- | Retrieves the promoted DataCon if this is a PromotedDataCon;
+isPromotedDataCon_maybe :: TyCon -> Maybe DataCon
+isPromotedDataCon_maybe (PromotedDataCon { dataCon = dc }) = Just dc
+isPromotedDataCon_maybe _ = Nothing
 
 -- | Identifies implicit tycons that, in particular, do not go into interface
 -- files (because they are implicitly reconstructed when the interface is
diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs
index 327ac78d71..00416154f2 100644
--- a/compiler/types/TypeRep.lhs
+++ b/compiler/types/TypeRep.lhs
@@ -53,7 +53,7 @@ module TypeRep (
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} DataCon( DataCon, dataConName )
+import {-# SOURCE #-} DataCon( DataCon, dataConTyCon, dataConName )
 import {-# SOURCE #-} Type( noParenPred, isPredTy ) -- Transitively pulls in a LOT of stuff, better to break the loop
 
 -- friends:
@@ -668,8 +668,19 @@ pprTcApp p pp tc tys
   = pprPromotionQuote tc <>
     tupleParens (tupleTyConSort tc) (sep (punctuate comma (map (pp TopPrec) tys)))
 
+  | Just dc <- isPromotedDataCon_maybe tc
+  , let dc_tc = dataConTyCon dc
+  , isTupleTyCon dc_tc 
+  , let arity = tyConArity dc_tc    -- E.g. 3 for (,,) k1 k2 k3 t1 t2 t3
+        ty_args = drop arity tys    -- Drop the kind args
+  , ty_args `lengthIs` arity        -- Result is saturated
+  = pprPromotionQuote tc <>
+    (tupleParens (tupleTyConSort dc_tc) $
+     sep (punctuate comma (map (pp TopPrec) ty_args)))
+
   | not opt_PprStyle_Debug
-  , tc `hasKey` eqTyConKey -- We need to special case the type equality TyCon because
+  , getUnique tc `elem` [eqTyConKey, eqPrimTyConKey] 
+                           -- We need to special case the type equality TyCons because
   , [_, ty1,ty2] <- tys    -- with kind polymorphism it has 3 args, so won't get printed infix
                            -- With -dppr-debug switch this off so we can see the kind
   = pprInfixApp p pp (ppr tc) ty1 ty2