From 9c889adc05ce9f16b20abb35db417e52e615e249 Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simonpj@microsoft.com>
Date: Mon, 22 Aug 2011 07:59:52 +0100
Subject: [PATCH] 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 4b06737d6e..f07a7642d3 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 e17d421fe5..41c7a6ebb2 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}
 
 %************************************************************************
-- 
GitLab