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