[commit: ghc] ghc-7.2: Improve pretty printing of Core (fixes #5325) (739fde1)

[Ian Lynagh]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : ghc-7.2

http://hackage.haskell.org/trac/ghc/changeset/739fde1cd7860c37d71f90fd295eb54a559a5f93

>---------------------------------------------------------------

commit 739fde1cd7860c37d71f90fd295eb54a559a5f93
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Fri Jul 15 12:08:43 2011 +0100

    Improve pretty printing of Core (fixes #5325)

>---------------------------------------------------------------

 compiler/coreSyn/PprCore.lhs |   30 ++++++++++++++++--------------
 1 files changed, 16 insertions(+), 14 deletions(-)

diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs
index bd6cdf4..58a940c 100644
--- a/compiler/coreSyn/PprCore.lhs
+++ b/compiler/coreSyn/PprCore.lhs
@@ -271,38 +271,39 @@ instance OutputableBndr Var where
 pprCoreBinder :: BindingSite -> Var -> SDoc
 pprCoreBinder LetBind binder
   | isTyVar binder = pprKindedTyVarBndr binder
-  | otherwise      = pprTypedBinder binder $$ 
+  | otherwise      = pprTypedLetBinder binder $$ 
 		     ppIdInfo binder (idInfo binder)
 
 -- Lambda bound type variables are preceded by "@"
 pprCoreBinder bind_site bndr 
   = getPprStyle $ \ sty ->
-    pprTypedLCBinder bind_site (debugStyle sty) bndr
+    pprTypedLamBinder bind_site (debugStyle sty) bndr
 
 pprUntypedBinder :: Var -> SDoc
 pprUntypedBinder binder
   | isTyVar binder = ptext (sLit "@") <+> ppr binder	-- NB: don't print kind
   | otherwise      = pprIdBndr binder
 
-pprTypedLCBinder :: BindingSite -> Bool -> Var -> SDoc
+pprTypedLamBinder :: BindingSite -> Bool -> Var -> SDoc
 -- For lambda and case binders, show the unfolding info (usually none)
-pprTypedLCBinder bind_site debug_on var
+pprTypedLamBinder bind_site debug_on var
   | not debug_on && isDeadBinder var    = char '_'
   | not debug_on, CaseBind <- bind_site = pprUntypedBinder var  -- No parens, no kind info
+  | opt_SuppressAll                     = pprUntypedBinder var  -- Suppress the signature
   | isTyVar var                         = parens (pprKindedTyVarBndr var)
   | otherwise = parens (hang (pprIdBndr var) 
                            2 (vcat [ dcolon <+> pprType (idType var), pp_unf]))
-              where
-		unf_info = unfoldingInfo (idInfo var)
-                pp_unf | hasSomeUnfolding unf_info = ptext (sLit "Unf=") <> ppr unf_info
-                       | otherwise                 = empty
+  where
+    unf_info = unfoldingInfo (idInfo var)
+    pp_unf | hasSomeUnfolding unf_info = ptext (sLit "Unf=") <> ppr unf_info
+           | otherwise                 = empty
 
-pprTypedBinder :: Var -> SDoc
+pprTypedLetBinder :: Var -> SDoc
 -- Print binder with a type or kind signature (not paren'd)
-pprTypedBinder binder
-  | isTyVar binder		= pprKindedTyVarBndr binder
-  | opt_SuppressTypeSignatures	= empty
-  | otherwise			= hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder))
+pprTypedLetBinder binder
+  | isTyVar binder	       = pprKindedTyVarBndr binder
+  | opt_SuppressTypeSignatures = pprIdBndr binder
+  | otherwise		       = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder))
 
 pprKindedTyVarBndr :: TyVar -> SDoc
 -- Print a type variable binder with its kind (but not if *)
@@ -459,7 +460,8 @@ pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn,
                 ru_bndrs = tpl_vars, ru_args = tpl_args,
                 ru_rhs = rhs })
   = hang (doubleQuotes (ftext name) <+> ppr act)
-       4 (sep [ptext (sLit "forall") <+> braces (sep (map pprTypedBinder tpl_vars)),
+       4 (sep [ptext (sLit "forall") <+> 
+                  sep (map (pprCoreBinder LambdaBind) tpl_vars) <> dot,
                nest 2 (ppr fn <+> sep (map pprArg tpl_args)),
                nest 2 (ptext (sLit "=") <+> pprCoreExpr rhs)
             ])