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

13 Mar 2014

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


    

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

Johan Tibell

Dr. ÉRDI Gergő

Joachim Breitner

Dr. ERDI Gergo

tags

participants (4)