[commit: ghc] wip/T8776: Pretty-print the following TyThings via their IfaceDecl counterpart: * AnId * ACoAxiom * AConLike (1ea0229)
git at git.haskell.org
git at git.haskell.org
Thu Mar 13 13:18:51 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/T8776
Link : http://ghc.haskell.org/trac/ghc/changeset/1ea02299a6a46f8badf54740e3ee14b015f81546/ghc
>---------------------------------------------------------------
commit 1ea02299a6a46f8badf54740e3ee14b015f81546
Author: Dr. ERDI Gergo <gergo at erdi.hu>
Date: Thu Mar 13 21:18:39 2014 +0800
Pretty-print the following TyThings via their IfaceDecl counterpart:
* AnId
* ACoAxiom
* AConLike
>---------------------------------------------------------------
1ea02299a6a46f8badf54740e3ee14b015f81546
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
More information about the ghc-commits
mailing list