Minor wibbles to pretty-printing HsSyn

Mainly affecting how declarations are printed
Ie by default: laid out with no braces

3 files changed, 35 insertions, 25 deletions

diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index f07a7642d3..0a8ff7a21c 100644
--- a/compiler/hsSyn/HsBinds.lhs
+++ b/compiler/hsSyn/HsBinds.lhs
@@ -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
diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index 41c7a6ebb2..50158385e7 100644
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -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}
 
 %************************************************************************
diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs
index 1ca1ac7918..d97fd961eb 100644
--- a/compiler/main/PprTyThing.hs
+++ b/compiler/main/PprTyThing.hs
@@ -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