Re: [commit: ghc] master: Pretty-print the following TyThings via their IfaceDecl counterpart: * AnId * ACoAxiom * AConLike (065c35a)

Yes:-( I'll unbreak them later today. On Mar 14, 2014 4:16 AM, "Johan Tibell" wrote:

Could these changes be related to the validate failures I just posted about on the mailing list?

On Thu, Mar 13, 2014 at 2:21 PM, wrote:

...

Repository : ssh://git@git.haskell.org/ghc

On branch : master Link : http://ghc.haskell.org/trac/ghc/changeset/065c35a9d6d48060c8fac8d755833349ce...

...

---------------------------------------------------------------

commit 065c35a9d6d48060c8fac8d755833349ce58b35b Author: Dr. ERDI Gergo Date: Thu Mar 13 21:18:39 2014 +0800

Pretty-print the following TyThings via their IfaceDecl counterpart: * AnId * ACoAxiom * AConLike

...

---------------------------------------------------------------

065c35a9d6d48060c8fac8d755833349ce58b35b compiler/iface/IfaceSyn.lhs | 2 +- compiler/iface/MkIface.lhs | 10 +++++++- compiler/main/PprTyThing.hs | 59 ++++++++++--------------------------------- 3 files changed, 23 insertions(+), 48 deletions(-)

diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 8ca8582..7484b37 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -1100,7 +1100,7 @@ pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, sep (map ppr sigs)])

pprIfaceDecl (IfaceAxiom {ifName = name, ifTyCon = tycon, ifAxBranches = branches }) - = hang (ptext (sLit "axiom") <+> ppr name <> colon) + = hang (ptext (sLit "axiom") <+> ppr name <> dcolon) 2 (vcat $ map (pprAxBranch $ Just tycon) branches)

pprIfaceDecl (IfacePatSyn { ifName = name, ifPatHasWrapper = has_wrap, diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 0af9af6..51df08c 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1461,7 +1461,7 @@ tyThingToIfaceDecl (AnId id) = idToIfaceDecl id tyThingToIfaceDecl (ATyCon tycon) = tyConToIfaceDecl emptyTidyEnv tycon tyThingToIfaceDecl (ACoAxiom ax) = coAxiomToIfaceDecl ax tyThingToIfaceDecl (AConLike cl) = case cl of - RealDataCon dc -> pprPanic "toIfaceDecl" (ppr dc) -- Should be trimmed out earlier + RealDataCon dc -> dataConToIfaceDecl dc -- for ppr purposes only PatSynCon ps -> patSynToIfaceDecl ps

-------------------------- @@ -1477,6 +1477,14 @@ idToIfaceDecl id ifIdInfo = toIfaceIdInfo (idInfo id) }

-------------------------- +dataConToIfaceDecl :: DataCon -> IfaceDecl +dataConToIfaceDecl dataCon + = IfaceId { ifName = getOccName dataCon, + ifType = toIfaceType (dataConUserType dataCon), + ifIdDetails = IfVanillaId, + ifIdInfo = NoInfo } + +-------------------------- patSynToIfaceDecl :: PatSyn -> IfaceDecl patSynToIfaceDecl ps = IfacePatSyn { ifName = getOccName . getName $ ps diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs index 27e7390..fb92b5a 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -23,20 +23,18 @@ module PprTyThing ( ) where

import TypeRep ( TyThing(..) ) -import ConLike import DataCon -import PatSyn import Id import TyCon import Class -import Coercion( pprCoAxiom, pprCoAxBranch ) +import Coercion( pprCoAxBranch ) import CoAxiom( CoAxiom(..), brListMap ) import HscTypes( tyThingParent_maybe ) -import HsBinds( pprPatSynSig ) import Type( tidyTopType, tidyOpenType, splitForAllTys, funResultTy ) import Kind( synTyConResKind ) import TypeRep( pprTvBndrs, pprForAll, suppressKinds ) import TysPrim( alphaTyVars ) +import MkIface ( tyThingToIfaceDecl ) import TcType import Name import VarEnv( emptyTidyEnv ) @@ -44,7 +42,6 @@ import StaticFlags( opt_PprStyle_Debug ) import DynFlags import Outputable import FastString -import Data.Maybe

-- ----------------------------------------------------------------------------- -- Pretty-printing entities that we get from the GHC API @@ -76,7 +73,7 @@ pprTyThingLoc tyThing

-- | Pretty-prints a 'TyThing'. pprTyThing :: TyThing -> SDoc -pprTyThing thing = ppr_ty_thing showAll thing +pprTyThing thing = ppr_ty_thing (Just showAll) thing

-- | Pretty-prints a 'TyThing' in context: that is, if the entity -- is a data constructor, record selector, or class method, then @@ -88,7 +85,7 @@ pprTyThingInContext thing where go ss thing = case tyThingParent_maybe thing of Just parent -> go (getName thing : ss) parent - Nothing -> ppr_ty_thing ss thing + Nothing -> ppr_ty_thing (Just ss) thing

-- | Like 'pprTyThingInContext', but adds the defining location. pprTyThingInContextLoc :: TyThing -> SDoc @@ -100,21 +97,17 @@ pprTyThingInContextLoc tyThing -- the function is equivalent to 'pprTyThing' but for type constructors -- and classes it prints only the header part of the declaration. pprTyThingHdr :: TyThing -> SDoc -pprTyThingHdr (AnId id) = pprId id -pprTyThingHdr (AConLike conLike) = case conLike of - RealDataCon dataCon -> pprDataConSig dataCon - PatSynCon patSyn -> pprPatSyn patSyn -pprTyThingHdr (ATyCon tyCon) = pprTyConHdr tyCon -pprTyThingHdr (ACoAxiom ax) = pprCoAxiom ax +pprTyThingHdr = ppr_ty_thing Nothing

------------------------ -ppr_ty_thing :: ShowSub -> TyThing -> SDoc -ppr_ty_thing _ (AnId id) = pprId id -ppr_ty_thing _ (AConLike conLike) = case conLike of - RealDataCon dataCon -> pprDataConSig dataCon - PatSynCon patSyn -> pprPatSyn patSyn -ppr_ty_thing ss (ATyCon tyCon) = pprTyCon ss tyCon -ppr_ty_thing _ (ACoAxiom ax) = pprCoAxiom ax +-- NOTE: We pretty-print 'TyThing' via 'IfaceDecl' so that we can reuse the +-- 'TyCon' tidying happening in 'tyThingToIfaceDecl'. See #8776 for details. +ppr_ty_thing :: Maybe ShowSub -> TyThing -> SDoc +ppr_ty_thing mss tyThing = case tyThing of + ATyCon tyCon -> case mss of + Nothing -> pprTyConHdr tyCon + Just ss -> pprTyCon ss tyCon + _ -> ppr $ tyThingToIfaceDecl tyThing

pprTyConHdr :: TyCon -> SDoc pprTyConHdr tyCon @@ -143,10 +136,6 @@ pprTyConHdr tyCon | isAlgTyCon tyCon = pprThetaArrowTy (tyConStupidTheta tyCon) | otherwise = empty -- Returns 'empty' if null theta

-pprDataConSig :: DataCon -> SDoc -pprDataConSig dataCon - = ppr_bndr dataCon <+> dcolon <+> pprTypeForUser (dataConUserType dataCon) - pprClassHdr :: Class -> SDoc pprClassHdr cls = sdocWithDynFlags $ \dflags -> @@ -158,28 +147,6 @@ pprClassHdr cls where (tvs, funDeps) = classTvsFds cls

-pprId :: Var -> SDoc -pprId ident - = hang (ppr_bndr ident <+> dcolon) - 2 (pprTypeForUser (idType ident)) - -pprPatSyn :: PatSyn -> SDoc -pprPatSyn patSyn - = pprPatSynSig ident is_bidir args (pprTypeForUser rhs_ty) prov req - where - ident = patSynId patSyn - is_bidir = isJust $ patSynWrapper patSyn - - args = fmap pprParendType (patSynTyDetails patSyn) - prov = pprThetaOpt prov_theta - req = pprThetaOpt req_theta - - pprThetaOpt [] = Nothing - pprThetaOpt theta = Just $ pprTheta theta - - (_univ_tvs, _ex_tvs, (prov_theta, req_theta)) = patSynSig patSyn - rhs_ty = patSynType patSyn - pprTypeForUser :: Type -> SDoc -- We do two things here. -- a) We tidy the type, regardless

_______________________________________________ ghc-commits mailing list ghc-commits@haskell.org http://www.haskell.org/mailman/listinfo/ghc-commits