From 7998a24404ffa577a3c303e37e4cfe0baf846454 Mon Sep 17 00:00:00 2001
From: "simonpj@microsoft.com" <unknown>
Date: Wed, 15 Sep 2010 07:02:55 +0000
Subject: [PATCH] Improve HsSyn pretty printing

---
 compiler/basicTypes/SrcLoc.lhs |    2 +-
 compiler/hsSyn/HsBinds.lhs     |   46 ++++++++++++++++++++++++++++------------
 compiler/hsSyn/HsExpr.lhs      |    8 +++----
 3 files changed, 37 insertions(+), 19 deletions(-)

diff --git a/compiler/basicTypes/SrcLoc.lhs b/compiler/basicTypes/SrcLoc.lhs
index 8bed6c1..d3db866 100644
--- a/compiler/basicTypes/SrcLoc.lhs
+++ b/compiler/basicTypes/SrcLoc.lhs
@@ -491,7 +491,7 @@ instance Functor Located where
   fmap f (L l e) = L l (f e)
 
 instance Outputable e => Outputable (Located e) where
-  ppr (L l e) = ifPprDebug (braces (pprUserSpan False l)) <> ppr e
+  ppr (L l e) = ifPprDebug (braces (pprUserSpan False l)) $$ ppr e
 		-- Print spans without the file name etc
 \end{code}
 
diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index f8afd26..92b050a 100644
--- a/compiler/hsSyn/HsBinds.lhs
+++ b/compiler/hsSyn/HsBinds.lhs
@@ -277,18 +277,23 @@ instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsBindLR idL id
 
 ppr_monobind :: (OutputableBndr idL, OutputableBndr idR) => HsBindLR idL idR -> SDoc
 
-ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })      = pprPatBind pat grhss
-ppr_monobind (VarBind { var_id = var, var_rhs = rhs })         = pprBndr CaseBind var <+> equals <+> pprExpr (unLoc rhs)
+ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })
+  = pprPatBind pat grhss
+ppr_monobind (VarBind { var_id = var, var_rhs = rhs })    
+  = sep [pprBndr CaseBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)]
 ppr_monobind (FunBind { fun_id = fun, fun_infix = inf,
+	     	        fun_co_fn = wrap, 
 			fun_matches = matches,
 		        fun_tick = tick })
   = pprTicks empty (case tick of 
 			Nothing -> empty
 			Just t  -> text "-- tick id = " <> ppr t)
     $$  pprFunBind (unLoc fun) inf matches
+    $$  ifPprDebug (ppr wrap)
 
-ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars, 
-			 abs_exports = exports, abs_binds = val_binds })
+ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars 
+		       , abs_exports = exports, abs_binds = val_binds
+                       , abs_ev_binds = ev_binds })
   = sep [ptext (sLit "AbsBinds"),
   	 brackets (interpp'SP tyvars),
   	 brackets (interpp'SP dictvars),
@@ -297,6 +302,8 @@ ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars,
     nest 2 ( vcat [pprBndr LetBind x | (_,x,_,_) <- exports]
   			-- Print type signatures
   	     $$ pprLHsBinds val_binds )
+    $$
+    ifPprDebug (ppr ev_binds)
   where
     ppr_exp (tvs, gbl, lcl, prags)
 	= vcat [ppr gbl <+> ptext (sLit "<=") <+> ppr tvs <+> ppr lcl,
@@ -521,17 +528,28 @@ instance Outputable HsWrapper where
 pprHsWrapper :: SDoc -> HsWrapper -> SDoc
 -- In debug mode, print the wrapper
 -- otherwise just print what's inside
-pprHsWrapper it wrap
-  = getPprStyle (\ s -> if debugStyle s then (help it wrap) else it)
+pprHsWrapper doc wrap
+  = getPprStyle (\ s -> if debugStyle s then (help (add_parens doc) wrap False) else doc)
   where
-    help it WpHole            = it
-    help it (WpCompose f1 f2) = help (help it f2) f1
-    help it (WpCast co)   = sep [it, nest 2 (ptext (sLit "`cast`") <+> pprParendType co)]
-    help it (WpEvApp id)  = sep [it, nest 2 (ppr id)]
-    help it (WpTyApp ty)  = sep [it, ptext (sLit "@") <+> pprParendType ty]
-    help it (WpEvLam id)  = sep [ptext (sLit "\\") <> pprBndr LambdaBind id <> dot, it]
-    help it (WpTyLam tv)  = sep [ptext (sLit "/\\") <> pprBndr LambdaBind tv <> dot, it]
-    help it (WpLet binds) = sep [ptext (sLit "let") <+> braces (ppr binds), it]
+    help :: (Bool -> SDoc) -> HsWrapper -> Bool -> SDoc
+    -- True  <=> appears in function application position
+    -- False <=> appears as body of let or lambda
+    help it WpHole             = it
+    help it (WpCompose f1 f2)  = help (help it f2) f1
+    help it (WpCast co)   = add_parens $ sep [it False, nest 2 (ptext (sLit "|>") 
+                                                 <+> pprParendType co)]
+    help it (WpEvApp id)  = no_parens  $ sep [it True, nest 2 (ppr id)]
+    help it (WpTyApp ty)  = no_parens  $ sep [it True, ptext (sLit "@") <+> pprParendType ty]
+    help it (WpEvLam id)  = add_parens $ sep [ ptext (sLit "\\") <> pp_bndr id, it False]
+    help it (WpTyLam tv)  = add_parens $ sep [ptext (sLit "/\\") <> pp_bndr tv, it False]
+    help it (WpLet binds) = add_parens $ sep [ptext (sLit "let") <+> braces (ppr binds), it False]
+
+    pp_bndr v = pprBndr LambdaBind v <> dot
+
+    add_parens, no_parens :: SDoc -> Bool -> SDoc
+    add_parens d True  = parens d
+    add_parens d False = d
+    no_parens d _ = d
 
 instance Outputable TcEvBinds where
   ppr (TcEvBinds v) = ppr v
diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index 245631d..0d7dd71 100644
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -748,16 +748,16 @@ pprFunBind fun inf matches = pprMatches (FunRhs fun inf) matches
 pprPatBind :: (OutputableBndr bndr, OutputableBndr id)
            => LPat bndr -> GRHSs id -> SDoc
 pprPatBind pat ty@(grhss)
- = sep [ppr pat, nest 4 (pprGRHSs (PatBindRhs `asTypeOf` idType ty) grhss)]
+ = sep [ppr pat, nest 2 (pprGRHSs (PatBindRhs `asTypeOf` idType ty) grhss)]
 --avoid using PatternSignatures for stage1 code portability
  where idType :: GRHSs id -> HsMatchContext id; idType = undefined
 
 
 pprMatch :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> Match idR -> SDoc
 pprMatch ctxt (Match pats maybe_ty grhss)
-  = herald <+> sep [sep (map pprParendLPat other_pats),
-                    ppr_maybe_ty,
-                    nest 2 (pprGRHSs ctxt grhss)]
+  = sep [ sep (herald : map (nest 2 . pprParendLPat) other_pats)
+        , nest 2 ppr_maybe_ty
+        , nest 2 (pprGRHSs ctxt grhss) ]
   where
     (herald, other_pats)
         = case ctxt of
-- 
1.7.10.4