Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/7653eaad932c24e477028ad3b3ec58ba59aa2bce >--------------------------------------------------------------- commit 7653eaad932c24e477028ad3b3ec58ba59aa2bce Author: Simon Peyton Jones <[email protected]> Date: Tue Aug 23 13:43:12 2011 +0100 Minor wibbles to pretty-printing HsSyn Mainly affecting how declarations are printed Ie by default: laid out with no braces >--------------------------------------------------------------- compiler/hsSyn/HsBinds.lhs | 21 ++++++++++++++++----- compiler/hsSyn/HsDecls.lhs | 15 ++++++--------- compiler/main/PprTyThing.hs | 24 +++++++++++++----------- 3 files changed, 35 insertions(+), 25 deletions(-) diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index f07a764..0a8ff7a 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -191,14 +191,14 @@ instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsLocalBindsLR instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsValBindsLR idL idR) where ppr (ValBindsIn binds sigs) - = pprLHsBindsForUser binds sigs + = pprDeclList (pprLHsBindsForUser binds sigs) ppr (ValBindsOut sccs sigs) = getPprStyle $ \ sty -> if debugStyle sty then -- Print with sccs showing vcat (map ppr sigs) $$ vcat (map ppr_scc sccs) else - pprLHsBindsForUser (unionManyBags (map snd sccs)) sigs + pprDeclList (pprLHsBindsForUser (unionManyBags (map snd sccs)) sigs) where ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds pp_rec Recursive = ptext (sLit "rec") @@ -207,10 +207,10 @@ instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsValBindsLR id pprLHsBinds :: (OutputableBndr idL, OutputableBndr idR) => LHsBindsLR idL idR -> SDoc pprLHsBinds binds | isEmptyLHsBinds binds = empty - | otherwise = lbrace <+> pprDeeperList vcat (map ppr (bagToList binds)) <+> rbrace + | otherwise = pprDeclList (map ppr (bagToList binds)) pprLHsBindsForUser :: (OutputableBndr idL, OutputableBndr idR, OutputableBndr id2) - => LHsBindsLR idL idR -> [LSig id2] -> SDoc + => LHsBindsLR idL idR -> [LSig id2] -> [SDoc] -- pprLHsBindsForUser is different to pprLHsBinds because -- a) No braces: 'let' and 'where' include a list of HsBindGroups -- and we don't want several groups of bindings each @@ -218,7 +218,7 @@ pprLHsBindsForUser :: (OutputableBndr idL, OutputableBndr idR, OutputableBndr id -- b) Sort by location before printing -- c) Include signatures pprLHsBindsForUser binds sigs - = pprDeeperList vcat (map snd (sort_by_loc decls)) + = map snd (sort_by_loc decls) where decls :: [(SrcSpan, SDoc)] @@ -227,6 +227,17 @@ pprLHsBindsForUser binds sigs sort_by_loc decls = sortLe (\(l1,_) (l2,_) -> l1 <= l2) decls +pprDeclList :: [SDoc] -> SDoc -- Braces with a space +-- Print a bunch of declarations +-- One could choose { d1; d2; ... }, using 'sep' +-- or d1 +-- d2 +-- .. +-- using vcat +-- At the moment we chose the latter +-- Also we do the 'pprDeeperList' thing. +pprDeclList ds = pprDeeperList vcat ds + ------------ emptyLocalBinds :: HsLocalBindsLR a b emptyLocalBinds = EmptyLocalBinds diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index 41c7a6e..5015838 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -640,9 +640,9 @@ instance OutputableBndr name = top_matter | otherwise -- Laid out - = hang (hsep [top_matter, ptext (sLit "where")]) - 2 (bracesSp (sep [ vcat (map ppr ats) - , pprLHsBindsForUser methods sigs ])) + = vcat [ top_matter <+> ptext (sLit "where") + , nest 2 $ pprDeclList (map ppr ats ++ + pprLHsBindsForUser methods sigs) ] where top_matter = ptext (sLit "class") <+> pp_decl_head (unLoc context) lclas tyvars Nothing @@ -820,9 +820,9 @@ instance (OutputableBndr name) => Outputable (InstDecl name) where = top_matter | otherwise -- Laid out - = hang (top_matter <+> ptext (sLit "where")) - 2 (bracesSp (vcat [ vcat (map ppr ats) - , pprLHsBindsForUser binds sigs ])) + = vcat [ top_matter <+> ptext (sLit "where") + , nest 2 $ pprDeclList (map ppr ats ++ + pprLHsBindsForUser binds sigs) ] where top_matter = ptext (sLit "instance") <+> ppr inst_ty @@ -830,9 +830,6 @@ instance (OutputableBndr name) => Outputable (InstDecl name) where -- instDeclATs :: [LInstDecl name] -> [LTyClDecl name] instDeclATs inst_decls = [at | L _ (InstDecl _ _ _ ats) <- inst_decls, at <- ats] - -bracesSp :: SDoc -> SDoc -- Braces with a space -bracesSp d = lbrace <+> d <+> rbrace \end{code} %************************************************************************ diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs index 1ca1ac7..d97fd96 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -64,13 +64,6 @@ pprTyThingLoc pefas tyThing pprTyThing :: PrintExplicitForalls -> TyThing -> SDoc pprTyThing pefas thing = ppr_ty_thing pefas showAll thing -ppr_ty_thing :: PrintExplicitForalls -> ShowSub -> TyThing -> SDoc -ppr_ty_thing pefas _ (AnId id) = pprId pefas id -ppr_ty_thing pefas _ (ADataCon dataCon) = pprDataConSig pefas dataCon -ppr_ty_thing pefas ss (ATyCon tyCon) = pprTyCon pefas ss tyCon -ppr_ty_thing _ _ (ACoAxiom ax) = pprCoAxiom ax -ppr_ty_thing pefas ss (AClass cls) = pprClass pefas ss cls - -- | Pretty-prints a 'TyThing' in context: that is, if the entity -- is a data constructor, record selector, or class method, then -- the entity's parent declaration is pretty-printed with irrelevant @@ -99,6 +92,14 @@ pprTyThingHdr pefas (ATyCon tyCon) = pprTyConHdr pefas tyCon pprTyThingHdr _ (ACoAxiom ax) = pprCoAxiom ax pprTyThingHdr pefas (AClass cls) = pprClassHdr pefas cls +------------------------ +ppr_ty_thing :: PrintExplicitForalls -> ShowSub -> TyThing -> SDoc +ppr_ty_thing pefas _ (AnId id) = pprId pefas id +ppr_ty_thing pefas _ (ADataCon dataCon) = pprDataConSig pefas dataCon +ppr_ty_thing pefas ss (ATyCon tyCon) = pprTyCon pefas ss tyCon +ppr_ty_thing _ _ (ACoAxiom ax) = pprCoAxiom ax +ppr_ty_thing pefas ss (AClass cls) = pprClass pefas ss cls + pprTyConHdr :: PrintExplicitForalls -> TyCon -> SDoc pprTyConHdr _ tyCon | Just (fam_tc, tys) <- tyConFamInst_maybe tyCon @@ -223,13 +224,14 @@ pprDataConDecl pefas ss gadt_style dataCon pprClass :: PrintExplicitForalls -> ShowSub -> GHC.Class -> SDoc pprClass pefas ss cls - | null methods + | null methods && null assoc_ts = pprClassHdr pefas cls | otherwise - = hang (pprClassHdr pefas cls <+> ptext (sLit "where")) - 2 (vcat (ppr_trim (map show_at assoc_ts ++ map show_meth methods))) + = vcat [ pprClassHdr pefas cls <+> ptext (sLit "where") + , nest 2 (vcat $ ppr_trim $ + map show_at assoc_ts ++ map show_meth methods)] where - methods = GHC.classMethods cls + methods = GHC.classMethods cls assoc_ts = GHC.classATs cls show_meth id | showSub ss id = Just (pprClassMethod pefas id) | otherwise = Nothing _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
