Commit 9c889adc authored by Simon Peyton Jones's avatar Simon Peyton Jones

Pretty-printing improvements in HsSyn

parent cd3d6f88
......@@ -191,26 +191,33 @@ 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
......@@ -220,11 +227,6 @@ pprValBindsForUser binds sigs
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
......
......@@ -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
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}
%************************************************************************
......
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