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

Pretty-printing improvements in HsSyn

parent cd3d6f88
...@@ -191,40 +191,42 @@ instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsLocalBindsLR ...@@ -191,40 +191,42 @@ instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsLocalBindsLR
instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsValBindsLR idL idR) where instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsValBindsLR idL idR) where
ppr (ValBindsIn binds sigs) ppr (ValBindsIn binds sigs)
= pprValBindsForUser binds sigs = pprLHsBindsForUser binds sigs
ppr (ValBindsOut sccs sigs) ppr (ValBindsOut sccs sigs)
= getPprStyle $ \ sty -> = getPprStyle $ \ sty ->
if debugStyle sty then -- Print with sccs showing if debugStyle sty then -- Print with sccs showing
vcat (map ppr sigs) $$ vcat (map ppr_scc sccs) vcat (map ppr sigs) $$ vcat (map ppr_scc sccs)
else else
pprValBindsForUser (unionManyBags (map snd sccs)) sigs pprLHsBindsForUser (unionManyBags (map snd sccs)) sigs
where where
ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds
pp_rec Recursive = ptext (sLit "rec") pp_rec Recursive = ptext (sLit "rec")
pp_rec NonRecursive = ptext (sLit "nonrec") pp_rec NonRecursive = ptext (sLit "nonrec")
-- *not* pprLHsBinds because we don't want braces; 'let' and pprLHsBinds :: (OutputableBndr idL, OutputableBndr idR) => LHsBindsLR idL idR -> SDoc
-- 'where' include a list of HsBindGroups and we don't want pprLHsBinds binds
-- several groups of bindings each with braces around. | isEmptyLHsBinds binds = empty
-- Sort by location before printing | otherwise = lbrace <+> pprDeeperList vcat (map ppr (bagToList binds)) <+> rbrace
pprValBindsForUser :: (OutputableBndr idL, OutputableBndr idR, OutputableBndr id2)
pprLHsBindsForUser :: (OutputableBndr idL, OutputableBndr idR, OutputableBndr id2)
=> LHsBindsLR idL idR -> [LSig id2] -> SDoc => 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)) = pprDeeperList vcat (map snd (sort_by_loc decls))
where where
decls :: [(SrcSpan, SDoc)] decls :: [(SrcSpan, SDoc)]
decls = [(loc, ppr sig) | L loc sig <- sigs] ++ 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 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 :: HsLocalBindsLR a b
emptyLocalBinds = EmptyLocalBinds emptyLocalBinds = EmptyLocalBinds
......
...@@ -73,6 +73,7 @@ import Util ...@@ -73,6 +73,7 @@ import Util
import SrcLoc import SrcLoc
import FastString import FastString
import Bag
import Control.Monad ( liftM ) import Control.Monad ( liftM )
import Data.Data hiding (TyCon) import Data.Data hiding (TyCon)
import Data.Maybe ( isJust ) import Data.Maybe ( isJust )
...@@ -639,17 +640,13 @@ instance OutputableBndr name ...@@ -639,17 +640,13 @@ instance OutputableBndr name
= top_matter = top_matter
| otherwise -- Laid out | otherwise -- Laid out
= sep [hsep [top_matter, ptext (sLit "where {")], = hang (hsep [top_matter, ptext (sLit "where")])
nest 4 (sep [ sep (map ppr_semi ats) 2 (bracesSp (sep [ vcat (map ppr ats)
, sep (map ppr_semi sigs) , pprLHsBindsForUser methods sigs ]))
, pprLHsBinds methods
, char '}'])]
where where
top_matter = ptext (sLit "class") top_matter = ptext (sLit "class")
<+> pp_decl_head (unLoc context) lclas tyvars Nothing <+> pp_decl_head (unLoc context) lclas tyvars Nothing
<+> pprFundeps (map unLoc fds) <+> pprFundeps (map unLoc fds)
ppr_semi :: Outputable a => a -> SDoc
ppr_semi decl = ppr decl <> semi
pp_decl_head :: OutputableBndr name pp_decl_head :: OutputableBndr name
=> HsContext name => HsContext name
...@@ -818,17 +815,24 @@ data InstDecl name ...@@ -818,17 +815,24 @@ data InstDecl name
deriving (Data, Typeable) deriving (Data, Typeable)
instance (OutputableBndr name) => Outputable (InstDecl name) where 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) | otherwise -- Laid out
= vcat [hsep [ptext (sLit "instance"), ppr inst_ty, ptext (sLit "where")] = hang (top_matter <+> ptext (sLit "where"))
, nest 4 $ vcat (map ppr ats) 2 (bracesSp (vcat [ vcat (map ppr ats)
, nest 4 $ vcat (map ppr uprags) , pprLHsBindsForUser binds sigs ]))
, nest 4 $ pprLHsBinds binds ] where
top_matter = ptext (sLit "instance") <+> ppr inst_ty
-- Extract the declarations of associated types from an instance -- Extract the declarations of associated types from an instance
-- --
instDeclATs :: [LInstDecl name] -> [LTyClDecl name] instDeclATs :: [LInstDecl name] -> [LTyClDecl name]
instDeclATs inst_decls = [at | L _ (InstDecl _ _ _ ats) <- inst_decls, at <- ats] 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} \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