[commit: ghc] : Use my own pPrintBndr rather than the noisy pprBndr (81a8c51)

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

On branch  : 

http://hackage.haskell.org/trac/ghc/changeset/81a8c515ddd92c30dac6704a95e57b59aadc41ee

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

commit 81a8c515ddd92c30dac6704a95e57b59aadc41ee
Author: Max Bolingbroke <[email protected]>
Date:   Wed Aug 3 13:29:50 2011 +0100

    Use my own pPrintBndr rather than the noisy pprBndr

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

 compiler/supercompile/Supercompile/Core/Syntax.hs  |   25 ++++++++++++-------
 .../Supercompile/Evaluator/Residualise.hs          |    4 +-
 2 files changed, 18 insertions(+), 11 deletions(-)

diff --git a/compiler/supercompile/Supercompile/Core/Syntax.hs b/compiler/supercompile/Supercompile/Core/Syntax.hs
index a1bd47f..d8a1730 100644
--- a/compiler/supercompile/Supercompile/Core/Syntax.hs
+++ b/compiler/supercompile/Supercompile/Core/Syntax.hs
@@ -8,7 +8,7 @@ import Supercompile.Utilities
 import Supercompile.StaticFlags
 
 import DataCon  (DataCon)
-import Var      (TyVar, Var, varName, isTyVar)
+import Var      (TyVar, Var, varName, isTyVar, varType)
 import Name     (Name, nameOccName)
 import OccName  (occNameString)
 import Id       (Id)
@@ -19,6 +19,13 @@ import PrimOp   (PrimOp)
 import PprCore  ()
 
 
+-- NB: don't use GHC's pprBndr because its way too noisy, printing unfoldings etc
+pPrintBndr :: BindingSite -> Var -> SDoc
+pPrintBndr bs x = prettyParen needs_parens $ ppr x <+> text "::" <+> ppr (varType x)
+  where needs_parens = case bs of LambdaBind -> True
+                                  CaseBind   -> True
+                                  LetBind    -> False
+
 data AltCon = DataAlt DataCon [TyVar] [CoVar] [Id] | LiteralAlt Literal | DefaultAlt
             deriving (Eq, Show)
 
@@ -92,7 +99,7 @@ data ValueF ann = Indirect Id -- NB: for the avoidance of doubt, these cannot be
 
 instance Outputable AltCon where
     pprPrec prec altcon = case altcon of
-        DataAlt dc as qs xs -> prettyParen (prec >= appPrec) $ ppr dc <+> hsep (map (pprBndr CaseBind) as ++ map (pprBndr CaseBind) qs ++ map (pprBndr CaseBind) xs)
+        DataAlt dc as qs xs -> prettyParen (prec >= appPrec) $ ppr dc <+> hsep (map (pPrintBndr CaseBind) as ++ map (pPrintBndr CaseBind) qs ++ map (pPrintBndr CaseBind) xs)
         LiteralAlt l        -> pPrint l
         DefaultAlt          -> text "_"
 
@@ -118,19 +125,19 @@ pPrintPrecApp prec e1 e2 = prettyParen (prec >= appPrec) $ pPrintPrec opPrec e1
 pPrintPrecPrimOp :: (Outputable a, Outputable b, Outputable c) => Rational -> a -> [b] -> [c] -> SDoc
 pPrintPrecPrimOp prec pop as xs = pPrintPrecApps prec (PrettyFunction (\prec -> pPrintPrecApps prec pop as)) xs
 
-pPrintPrecCase :: (Outputable a, OutputableBndr b, Outputable c, Outputable d) => Rational -> a -> b -> [(c, d)] -> SDoc
-pPrintPrecCase prec e x alts = prettyParen (prec > noPrec) $ hang (text "case" <+> pPrintPrec noPrec e <+> text "of" <+> pprBndr CaseBind x) 2 $ vcat (map (pPrintPrecAlt noPrec) alts)
+pPrintPrecCase :: (Outputable a, Outputable b, Outputable c) => Rational -> a -> Var -> [(b, c)] -> SDoc
+pPrintPrecCase prec e x alts = prettyParen (prec > noPrec) $ hang (text "case" <+> pPrintPrec noPrec e <+> text "of" <+> pPrintBndr CaseBind x) 2 $ vcat (map (pPrintPrecAlt noPrec) alts)
 
 pPrintPrecAlt :: (Outputable a, Outputable b) => Rational -> (a, b) -> SDoc
 pPrintPrecAlt _ (alt_con, alt_e) = hang (pPrintPrec noPrec alt_con <+> text "->") 2 (pPrintPrec noPrec alt_e)
 
-pPrintPrecLet :: (OutputableBndr a, Outputable b, Outputable c) => Rational -> a -> b -> c -> SDoc
-pPrintPrecLet prec x e e_body = prettyParen (prec > noPrec) $ hang (text "let") 2 (pprBndr LetBind x <+> text "=" <+> pPrintPrec noPrec e) $$ text "in" <+> pPrintPrec noPrec e_body
+pPrintPrecLet :: (Outputable a, Outputable b) => Rational -> Var -> a -> b -> SDoc
+pPrintPrecLet prec x e e_body = prettyParen (prec > noPrec) $ hang (text "let") 2 (pPrintBndr LetBind x <+> text "=" <+> pPrintPrec noPrec e) $$ text "in" <+> pPrintPrec noPrec e_body
 
-pPrintPrecLetRec :: (OutputableBndr a, Outputable b, Outputable c) => Rational -> [(a, b)] -> c -> SDoc
+pPrintPrecLetRec :: (Outputable a, Outputable b) => Rational -> [(Var, a)] -> b -> SDoc
 pPrintPrecLetRec prec xes e_body
   | [] <- xes = pPrintPrec prec e_body
-  | otherwise = prettyParen (prec > noPrec) $ hang (text "letrec") 2 (vcat [pprBndr LetBind x <+> text "=" <+> pPrintPrec noPrec e | (x, e) <- xes]) $$ text "in" <+> pPrintPrec noPrec e_body
+  | otherwise = prettyParen (prec > noPrec) $ hang (text "letrec") 2 (vcat [pPrintBndr LetBind x <+> text "=" <+> pPrintPrec noPrec e | (x, e) <- xes]) $$ text "in" <+> pPrintPrec noPrec e_body
 
 instance (Functor ann, Outputable1 ann) => Outputable (ValueF ann) where
     pprPrec prec v = case v of
@@ -145,7 +152,7 @@ instance (Functor ann, Outputable1 ann) => Outputable (ValueF ann) where
         Coercion co        -> pPrintPrec prec co
 
 pPrintPrecLam :: Outputable a => Rational -> [Var] -> a -> SDoc
-pPrintPrecLam prec xs e = prettyParen (prec > noPrec) $ text "\\" <> hsep [pprBndr LambdaBind y | y <- xs] <+> text "->" <+> pPrintPrec noPrec e
+pPrintPrecLam prec xs e = prettyParen (prec > noPrec) $ text "\\" <> hsep [pPrintBndr LambdaBind y | y <- xs] <+> text "->" <+> pPrintPrec noPrec e
 
 pPrintPrecApps :: (Outputable a, Outputable b) => Rational -> a -> [b] -> SDoc
 pPrintPrecApps prec e1 es2 = prettyParen (not (null es2) && prec >= appPrec) $ pPrintPrec opPrec e1 <+> hsep (map (pPrintPrec appPrec) es2)
diff --git a/compiler/supercompile/Supercompile/Evaluator/Residualise.hs b/compiler/supercompile/Supercompile/Evaluator/Residualise.hs
index 3106ee7..f81f6f1 100644
--- a/compiler/supercompile/Supercompile/Evaluator/Residualise.hs
+++ b/compiler/supercompile/Supercompile/Evaluator/Residualise.hs
@@ -55,12 +55,12 @@ residualiseStackFrame _   (CastIt co')                e  = (([], []), e `cast` c
 
 
 pPrintHeap :: Heap -> SDoc
-pPrintHeap (Heap h ids) = pPrint $ map (first (PrettyDoc . pprBndr LetBind)) $ floats_static_h ++ [(x, asPrettyFunction1 e) | (x, e) <- floats_nonstatic_h]
+pPrintHeap (Heap h ids) = pPrint $ map (first (PrettyDoc . pPrintBndr LetBind)) $ floats_static_h ++ [(x, asPrettyFunction1 e) | (x, e) <- floats_nonstatic_h]
   where (floats_static_h, floats_nonstatic_h) = residualisePureHeap ids h
 
 pPrintFullState :: State -> SDoc
 pPrintFullState = pPrintFullUnnormalisedState . denormalise
 
 pPrintFullUnnormalisedState :: UnnormalisedState -> SDoc
-pPrintFullUnnormalisedState state = text "Deeds:" <+> pPrint deeds $$ pPrint (map (first (PrettyDoc . pprBndr LetBind)) floats_static) $$ pPrint e
+pPrintFullUnnormalisedState state = text "Deeds:" <+> pPrint deeds $$ pPrint (map (first (PrettyDoc . pPrintBndr LetBind)) floats_static) $$ pPrint e
   where (deeds, floats_static, e) = residualiseUnnormalisedState state