Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch :
http://hackage.haskell.org/trac/ghc/changeset/10f7674e46d3e80bef7cd1ad5d252c0b8f127924 >--------------------------------------------------------------- commit 10f7674e46d3e80bef7cd1ad5d252c0b8f127924 Author: Max Bolingbroke <batterseapo...@hotmail.com> 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 _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
