[commit: ghc] : Improve pretty-printing of binders in Core (show their types) (10f7674)

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

On branch  : 

http://hackage.haskell.org/trac/ghc/changeset/10f7674e46d3e80bef7cd1ad5d252c0b8f127924

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

commit 10f7674e46d3e80bef7cd1ad5d252c0b8f127924
Author: Max Bolingbroke <[email protected]>
Date:   Sun Jul 31 22:19:47 2011 +0100

    Improve pretty-printing of binders in Core (show their types)

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

 compiler/supercompile/Supercompile/Core/Syntax.hs  |   17 +++++++++--------
 .../Supercompile/Evaluator/Residualise.hs          |    6 +++---
 2 files changed, 12 insertions(+), 11 deletions(-)

diff --git a/compiler/supercompile/Supercompile/Core/Syntax.hs b/compiler/supercompile/Supercompile/Core/Syntax.hs
index e3cdd6a..2080822 100644
--- a/compiler/supercompile/Supercompile/Core/Syntax.hs
+++ b/compiler/supercompile/Supercompile/Core/Syntax.hs
@@ -16,6 +16,7 @@ import Literal  (Literal)
 import Type     (Type, mkTyVarTy)
 import Coercion (CoVar, Coercion, mkReflCo)
 import PrimOp   (PrimOp)
+import PprCore  ()
 
 import Data.Traversable (Traversable(traverse))
 
@@ -92,7 +93,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 (pPrintPrec appPrec) as ++ map (pPrintPrec appPrec) qs ++ map (pPrintPrec appPrec) xs)
+        DataAlt dc as qs xs -> prettyParen (prec >= appPrec) $ ppr dc <+> hsep (map (pprBndr CaseBind) as ++ map (pprBndr CaseBind) qs ++ map (pprBndr CaseBind) xs)
         LiteralAlt l        -> pPrint l
         DefaultAlt          -> text "_"
 
@@ -118,19 +119,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, Outputable 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" <+> pPrintPrec noPrec x) 2 $ vcat (map (pPrintPrecAlt noPrec) alts)
+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)
 
 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 :: (Outputable a, Outputable b, Outputable c) => Rational -> a -> b -> c -> SDoc
-pPrintPrecLet prec x e e_body = prettyParen (prec > noPrec) $ hang (text "let") 2 (pPrintPrec noPrec x <+> text "=" <+> pPrintPrec noPrec e) $$ text "in" <+> pPrintPrec noPrec e_body
+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
 
-pPrintPrecLetRec :: (Outputable a, Outputable b, Outputable c) => Rational -> [(a, b)] -> c -> SDoc
+pPrintPrecLetRec :: (OutputableBndr a, Outputable b, Outputable c) => Rational -> [(a, b)] -> c -> SDoc
 pPrintPrecLetRec prec xes e_body
   | [] <- xes = pPrintPrec prec e_body
-  | otherwise = prettyParen (prec > noPrec) $ hang (text "letrec") 2 (vcat [pPrintPrec noPrec x <+> text "=" <+> pPrintPrec noPrec e | (x, e) <- xes]) $$ text "in" <+> pPrintPrec noPrec 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
 
 instance (Functor ann, Outputable1 ann) => Outputable (ValueF ann) where
     pprPrec prec v = case v of
@@ -145,7 +146,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 [pPrintPrec appPrec y | y <- xs] <+> text "->" <+> pPrintPrec noPrec e
+pPrintPrecLam prec xs e = prettyParen (prec > noPrec) $ text "\\" <> hsep [pprBndr 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 0976b0a..d3bb76f 100644
--- a/compiler/supercompile/Supercompile/Evaluator/Residualise.hs
+++ b/compiler/supercompile/Supercompile/Evaluator/Residualise.hs
@@ -1,4 +1,4 @@
-module Supercompile.Evaluator.Residualise (residualiseState, pPrintHeap, pPrintFullState, pPrintFullUnnormalisedState) where
+module Supercompile.Evaluator.Residualise (residualiseState, residualiseHeapBinding, pPrintHeap, pPrintFullState, pPrintFullUnnormalisedState) where
 
 import Supercompile.Evaluator.Deeds
 import Supercompile.Evaluator.Syntax
@@ -55,12 +55,12 @@ residualiseStackFrame _   (CastIt co')                e  = (([], []), e `cast` c
 
 
 pPrintHeap :: Heap -> SDoc
-pPrintHeap (Heap h ids) = pPrint $ floats_static_h ++ [(x, asPrettyFunction1 e) | (x, e) <- floats_nonstatic_h]
+pPrintHeap (Heap h ids) = pPrint $ map (first (PrettyDoc . pprBndr 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 (M.fromList floats_static) $$ pPrint e
+pPrintFullUnnormalisedState state = text "Deeds:" <+> pPrint deeds $$ pPrint (map (first (PrettyDoc . pprBndr LetBind)) floats_static) $$ pPrint e
   where (deeds, floats_static, e) = residualiseUnnormalisedState state