[commit: ghc] master: Pretty-print the following TyThings via their IfaceDecl counterpart: * AnId * ACoAxiom * AConLike (065c35a)
Johan Tibell
johan.tibell at gmail.com
Thu Mar 13 20:15:27 UTC 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, <git at git.haskell.org> wrote:
> Repository : ssh://git@git.haskell.org/ghc
>
> On branch : master
> Link :
> http://ghc.haskell.org/trac/ghc/changeset/065c35a9d6d48060c8fac8d755833349ce58b35b/ghc
>
> >---------------------------------------------------------------
>
> commit 065c35a9d6d48060c8fac8d755833349ce58b35b
> 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
>
>
> >---------------------------------------------------------------
>
> 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 at haskell.org
> http://www.haskell.org/mailman/listinfo/ghc-commits
>
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://www.haskell.org/pipermail/ghc-devs/attachments/20140313/d192b1e1/attachment-0001.html>
More information about the ghc-devs
mailing list