Commit 7653eaad authored by Simon Peyton Jones's avatar Simon Peyton Jones

Minor wibbles to pretty-printing HsSyn

Mainly affecting how declarations are printed
Ie by default: laid out with no braces
parent 1ed5fabe
......@@ -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
......
......@@ -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}
%************************************************************************
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment