Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/9c889adc05ce9f16b20abb35db417e52e615e249 >--------------------------------------------------------------- commit 9c889adc05ce9f16b20abb35db417e52e615e249 Author: Simon Peyton Jones <[email protected]> Date: Mon Aug 22 07:59:52 2011 +0100 Pretty-printing improvements in HsSyn >--------------------------------------------------------------- compiler/hsSyn/HsBinds.lhs | 30 ++++++++++++++++-------------- compiler/hsSyn/HsDecls.lhs | 34 +++++++++++++++++++--------------- 2 files changed, 35 insertions(+), 29 deletions(-) diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index 4b06737..f07a764 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -191,40 +191,42 @@ instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsLocalBindsLR instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsValBindsLR idL idR) where ppr (ValBindsIn binds sigs) - = pprValBindsForUser binds sigs + = 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 - pprValBindsForUser (unionManyBags (map snd sccs)) sigs + pprLHsBindsForUser (unionManyBags (map snd sccs)) sigs where ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds pp_rec Recursive = ptext (sLit "rec") pp_rec NonRecursive = ptext (sLit "nonrec") --- *not* pprLHsBinds because we don't want braces; 'let' and --- 'where' include a list of HsBindGroups and we don't want --- several groups of bindings each with braces around. --- Sort by location before printing -pprValBindsForUser :: (OutputableBndr idL, OutputableBndr idR, OutputableBndr id2) +pprLHsBinds :: (OutputableBndr idL, OutputableBndr idR) => LHsBindsLR idL idR -> SDoc +pprLHsBinds binds + | isEmptyLHsBinds binds = empty + | otherwise = lbrace <+> pprDeeperList vcat (map ppr (bagToList binds)) <+> rbrace + +pprLHsBindsForUser :: (OutputableBndr idL, OutputableBndr idR, OutputableBndr id2) => LHsBindsLR idL idR -> [LSig id2] -> SDoc -pprValBindsForUser binds sigs +-- 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 +-- with braces around +-- b) Sort by location before printing +-- c) Include signatures +pprLHsBindsForUser binds sigs = pprDeeperList vcat (map snd (sort_by_loc decls)) where decls :: [(SrcSpan, SDoc)] decls = [(loc, ppr sig) | L loc sig <- sigs] ++ - [(loc, ppr bind) | L loc bind <- bagToList binds] + [(loc, ppr bind) | L loc bind <- bagToList binds] sort_by_loc decls = sortLe (\(l1,_) (l2,_) -> l1 <= l2) decls -pprLHsBinds :: (OutputableBndr idL, OutputableBndr idR) => LHsBindsLR idL idR -> SDoc -pprLHsBinds binds - | isEmptyLHsBinds binds = empty - | otherwise = lbrace <+> pprDeeperList vcat (map ppr (bagToList binds)) <+> rbrace - ------------ emptyLocalBinds :: HsLocalBindsLR a b emptyLocalBinds = EmptyLocalBinds diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index e17d421..41c7a6e 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -73,6 +73,7 @@ import Util import SrcLoc import FastString +import Bag import Control.Monad ( liftM ) import Data.Data hiding (TyCon) import Data.Maybe ( isJust ) @@ -639,17 +640,13 @@ instance OutputableBndr name = top_matter | otherwise -- Laid out - = sep [hsep [top_matter, ptext (sLit "where {")], - nest 4 (sep [ sep (map ppr_semi ats) - , sep (map ppr_semi sigs) - , pprLHsBinds methods - , char '}'])] + = hang (hsep [top_matter, ptext (sLit "where")]) + 2 (bracesSp (sep [ vcat (map ppr ats) + , pprLHsBindsForUser methods sigs ])) where - top_matter = ptext (sLit "class") - <+> pp_decl_head (unLoc context) lclas tyvars Nothing - <+> pprFundeps (map unLoc fds) - ppr_semi :: Outputable a => a -> SDoc - ppr_semi decl = ppr decl <> semi + top_matter = ptext (sLit "class") + <+> pp_decl_head (unLoc context) lclas tyvars Nothing + <+> pprFundeps (map unLoc fds) pp_decl_head :: OutputableBndr name => HsContext name @@ -818,17 +815,24 @@ data InstDecl name deriving (Data, Typeable) instance (OutputableBndr name) => Outputable (InstDecl name) where + ppr (InstDecl inst_ty binds sigs ats) + | null sigs && null ats && isEmptyBag binds -- No "where" part + = top_matter - ppr (InstDecl inst_ty binds uprags ats) - = vcat [hsep [ptext (sLit "instance"), ppr inst_ty, ptext (sLit "where")] - , nest 4 $ vcat (map ppr ats) - , nest 4 $ vcat (map ppr uprags) - , nest 4 $ pprLHsBinds binds ] + | otherwise -- Laid out + = hang (top_matter <+> ptext (sLit "where")) + 2 (bracesSp (vcat [ vcat (map ppr ats) + , pprLHsBindsForUser binds sigs ])) + where + top_matter = ptext (sLit "instance") <+> ppr inst_ty -- Extract the declarations of associated types from an instance -- 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} %************************************************************************ _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
