Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/4026038380ce70a54fd3764f1656baf7cd8df6ff >--------------------------------------------------------------- commit 4026038380ce70a54fd3764f1656baf7cd8df6ff Author: Simon Peyton Jones <[email protected]> Date: Fri Aug 31 18:09:51 2012 +0100 Nicer pretty printing for tuple kinds >--------------------------------------------------------------- compiler/basicTypes/DataCon.lhs | 6 +++--- compiler/basicTypes/DataCon.lhs-boot | 2 ++ compiler/deSugar/Check.lhs | 2 +- compiler/typecheck/TcSplice.lhs | 12 ++++++------ compiler/types/TyCon.lhs | 28 ++++++++++++++-------------- compiler/types/TypeRep.lhs | 15 +++++++++++++-- 6 files changed, 39 insertions(+), 26 deletions(-) diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index d46759c..a504c5b 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 3477a4b..94bf889 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 75c3d11..ad590ae 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 334c3a5..419647b 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 147e16d..1d9dffe 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 327ac78..0041615 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 _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
