Commit 40260383 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Nicer pretty printing for tuple kinds

parent b660cc0b
......@@ -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
......
\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
......
......@@ -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}
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment