<div dir="ltr">Could these changes be related to the validate failures I just posted about on the mailing list?</div><div class="gmail_extra"><br><br><div class="gmail_quote">On Thu, Mar 13, 2014 at 2:21 PM, <span dir="ltr"><<a href="mailto:git@git.haskell.org" target="_blank">git@git.haskell.org</a>></span> wrote:<br>
<blockquote class="gmail_quote" style="margin:0 0 0 .8ex;border-left:1px #ccc solid;padding-left:1ex">Repository : ssh://<a href="http://git@git.haskell.org/ghc" target="_blank">git@git.haskell.org/ghc</a><br>
<br>
On branch : master<br>
Link : <a href="http://ghc.haskell.org/trac/ghc/changeset/065c35a9d6d48060c8fac8d755833349ce58b35b/ghc" target="_blank">http://ghc.haskell.org/trac/ghc/changeset/065c35a9d6d48060c8fac8d755833349ce58b35b/ghc</a><br>
<br>
>---------------------------------------------------------------<br>
<br>
commit 065c35a9d6d48060c8fac8d755833349ce58b35b<br>
Author: Dr. ERDI Gergo <<a href="mailto:gergo@erdi.hu">gergo@erdi.hu</a>><br>
Date: Thu Mar 13 21:18:39 2014 +0800<br>
<br>
Pretty-print the following TyThings via their IfaceDecl counterpart:<br>
* AnId<br>
* ACoAxiom<br>
* AConLike<br>
<br>
<br>
>---------------------------------------------------------------<br>
<br>
065c35a9d6d48060c8fac8d755833349ce58b35b<br>
compiler/iface/IfaceSyn.lhs | 2 +-<br>
compiler/iface/MkIface.lhs | 10 +++++++-<br>
compiler/main/PprTyThing.hs | 59 ++++++++++---------------------------------<br>
3 files changed, 23 insertions(+), 48 deletions(-)<br>
<br>
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs<br>
index 8ca8582..7484b37 100644<br>
--- a/compiler/iface/IfaceSyn.lhs<br>
+++ b/compiler/iface/IfaceSyn.lhs<br>
@@ -1100,7 +1100,7 @@ pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,<br>
sep (map ppr sigs)])<br>
<br>
pprIfaceDecl (IfaceAxiom {ifName = name, ifTyCon = tycon, ifAxBranches = branches })<br>
- = hang (ptext (sLit "axiom") <+> ppr name <> colon)<br>
+ = hang (ptext (sLit "axiom") <+> ppr name <> dcolon)<br>
2 (vcat $ map (pprAxBranch $ Just tycon) branches)<br>
<br>
pprIfaceDecl (IfacePatSyn { ifName = name, ifPatHasWrapper = has_wrap,<br>
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs<br>
index 0af9af6..51df08c 100644<br>
--- a/compiler/iface/MkIface.lhs<br>
+++ b/compiler/iface/MkIface.lhs<br>
@@ -1461,7 +1461,7 @@ tyThingToIfaceDecl (AnId id) = idToIfaceDecl id<br>
tyThingToIfaceDecl (ATyCon tycon) = tyConToIfaceDecl emptyTidyEnv tycon<br>
tyThingToIfaceDecl (ACoAxiom ax) = coAxiomToIfaceDecl ax<br>
tyThingToIfaceDecl (AConLike cl) = case cl of<br>
- RealDataCon dc -> pprPanic "toIfaceDecl" (ppr dc) -- Should be trimmed out earlier<br>
+ RealDataCon dc -> dataConToIfaceDecl dc -- for ppr purposes only<br>
PatSynCon ps -> patSynToIfaceDecl ps<br>
<br>
--------------------------<br>
@@ -1477,6 +1477,14 @@ idToIfaceDecl id<br>
ifIdInfo = toIfaceIdInfo (idInfo id) }<br>
<br>
--------------------------<br>
+dataConToIfaceDecl :: DataCon -> IfaceDecl<br>
+dataConToIfaceDecl dataCon<br>
+ = IfaceId { ifName = getOccName dataCon,<br>
+ ifType = toIfaceType (dataConUserType dataCon),<br>
+ ifIdDetails = IfVanillaId,<br>
+ ifIdInfo = NoInfo }<br>
+<br>
+--------------------------<br>
patSynToIfaceDecl :: PatSyn -> IfaceDecl<br>
patSynToIfaceDecl ps<br>
= IfacePatSyn { ifName = getOccName . getName $ ps<br>
diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs<br>
index 27e7390..fb92b5a 100644<br>
--- a/compiler/main/PprTyThing.hs<br>
+++ b/compiler/main/PprTyThing.hs<br>
@@ -23,20 +23,18 @@ module PprTyThing (<br>
) where<br>
<br>
import TypeRep ( TyThing(..) )<br>
-import ConLike<br>
import DataCon<br>
-import PatSyn<br>
import Id<br>
import TyCon<br>
import Class<br>
-import Coercion( pprCoAxiom, pprCoAxBranch )<br>
+import Coercion( pprCoAxBranch )<br>
import CoAxiom( CoAxiom(..), brListMap )<br>
import HscTypes( tyThingParent_maybe )<br>
-import HsBinds( pprPatSynSig )<br>
import Type( tidyTopType, tidyOpenType, splitForAllTys, funResultTy )<br>
import Kind( synTyConResKind )<br>
import TypeRep( pprTvBndrs, pprForAll, suppressKinds )<br>
import TysPrim( alphaTyVars )<br>
+import MkIface ( tyThingToIfaceDecl )<br>
import TcType<br>
import Name<br>
import VarEnv( emptyTidyEnv )<br>
@@ -44,7 +42,6 @@ import StaticFlags( opt_PprStyle_Debug )<br>
import DynFlags<br>
import Outputable<br>
import FastString<br>
-import Data.Maybe<br>
<br>
-- -----------------------------------------------------------------------------<br>
-- Pretty-printing entities that we get from the GHC API<br>
@@ -76,7 +73,7 @@ pprTyThingLoc tyThing<br>
<br>
-- | Pretty-prints a 'TyThing'.<br>
pprTyThing :: TyThing -> SDoc<br>
-pprTyThing thing = ppr_ty_thing showAll thing<br>
+pprTyThing thing = ppr_ty_thing (Just showAll) thing<br>
<br>
-- | Pretty-prints a 'TyThing' in context: that is, if the entity<br>
-- is a data constructor, record selector, or class method, then<br>
@@ -88,7 +85,7 @@ pprTyThingInContext thing<br>
where<br>
go ss thing = case tyThingParent_maybe thing of<br>
Just parent -> go (getName thing : ss) parent<br>
- Nothing -> ppr_ty_thing ss thing<br>
+ Nothing -> ppr_ty_thing (Just ss) thing<br>
<br>
-- | Like 'pprTyThingInContext', but adds the defining location.<br>
pprTyThingInContextLoc :: TyThing -> SDoc<br>
@@ -100,21 +97,17 @@ pprTyThingInContextLoc tyThing<br>
-- the function is equivalent to 'pprTyThing' but for type constructors<br>
-- and classes it prints only the header part of the declaration.<br>
pprTyThingHdr :: TyThing -> SDoc<br>
-pprTyThingHdr (AnId id) = pprId id<br>
-pprTyThingHdr (AConLike conLike) = case conLike of<br>
- RealDataCon dataCon -> pprDataConSig dataCon<br>
- PatSynCon patSyn -> pprPatSyn patSyn<br>
-pprTyThingHdr (ATyCon tyCon) = pprTyConHdr tyCon<br>
-pprTyThingHdr (ACoAxiom ax) = pprCoAxiom ax<br>
+pprTyThingHdr = ppr_ty_thing Nothing<br>
<br>
------------------------<br>
-ppr_ty_thing :: ShowSub -> TyThing -> SDoc<br>
-ppr_ty_thing _ (AnId id) = pprId id<br>
-ppr_ty_thing _ (AConLike conLike) = case conLike of<br>
- RealDataCon dataCon -> pprDataConSig dataCon<br>
- PatSynCon patSyn -> pprPatSyn patSyn<br>
-ppr_ty_thing ss (ATyCon tyCon) = pprTyCon ss tyCon<br>
-ppr_ty_thing _ (ACoAxiom ax) = pprCoAxiom ax<br>
+-- NOTE: We pretty-print 'TyThing' via 'IfaceDecl' so that we can reuse the<br>
+-- 'TyCon' tidying happening in 'tyThingToIfaceDecl'. See #8776 for details.<br>
+ppr_ty_thing :: Maybe ShowSub -> TyThing -> SDoc<br>
+ppr_ty_thing mss tyThing = case tyThing of<br>
+ ATyCon tyCon -> case mss of<br>
+ Nothing -> pprTyConHdr tyCon<br>
+ Just ss -> pprTyCon ss tyCon<br>
+ _ -> ppr $ tyThingToIfaceDecl tyThing<br>
<br>
pprTyConHdr :: TyCon -> SDoc<br>
pprTyConHdr tyCon<br>
@@ -143,10 +136,6 @@ pprTyConHdr tyCon<br>
| isAlgTyCon tyCon = pprThetaArrowTy (tyConStupidTheta tyCon)<br>
| otherwise = empty -- Returns 'empty' if null theta<br>
<br>
-pprDataConSig :: DataCon -> SDoc<br>
-pprDataConSig dataCon<br>
- = ppr_bndr dataCon <+> dcolon <+> pprTypeForUser (dataConUserType dataCon)<br>
-<br>
pprClassHdr :: Class -> SDoc<br>
pprClassHdr cls<br>
= sdocWithDynFlags $ \dflags -><br>
@@ -158,28 +147,6 @@ pprClassHdr cls<br>
where<br>
(tvs, funDeps) = classTvsFds cls<br>
<br>
-pprId :: Var -> SDoc<br>
-pprId ident<br>
- = hang (ppr_bndr ident <+> dcolon)<br>
- 2 (pprTypeForUser (idType ident))<br>
-<br>
-pprPatSyn :: PatSyn -> SDoc<br>
-pprPatSyn patSyn<br>
- = pprPatSynSig ident is_bidir args (pprTypeForUser rhs_ty) prov req<br>
- where<br>
- ident = patSynId patSyn<br>
- is_bidir = isJust $ patSynWrapper patSyn<br>
-<br>
- args = fmap pprParendType (patSynTyDetails patSyn)<br>
- prov = pprThetaOpt prov_theta<br>
- req = pprThetaOpt req_theta<br>
-<br>
- pprThetaOpt [] = Nothing<br>
- pprThetaOpt theta = Just $ pprTheta theta<br>
-<br>
- (_univ_tvs, _ex_tvs, (prov_theta, req_theta)) = patSynSig patSyn<br>
- rhs_ty = patSynType patSyn<br>
-<br>
pprTypeForUser :: Type -> SDoc<br>
-- We do two things here.<br>
-- a) We tidy the type, regardless<br>
<br>
_______________________________________________<br>
ghc-commits mailing list<br>
<a href="mailto:ghc-commits@haskell.org">ghc-commits@haskell.org</a><br>
<a href="http://www.haskell.org/mailman/listinfo/ghc-commits" target="_blank">http://www.haskell.org/mailman/listinfo/ghc-commits</a><br>
</blockquote></div><br></div>