From d38a30cb5e7a946f7a5e02fb6e601d2d37ea4374 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Sun, 22 Apr 2007 21:10:49 +0000 Subject: [PATCH] Improve depth-cutoff for printing HsSyn in error messages MERGE TO STABLE The "user style" in Outputable allows us to elide large expressions when printing HsSyn, printing "..." instead. This is done by calling Outputable.pprDeeper. But there was no mechanism for trimming very long lists, which occur when using do-notation or explicit lists. This patch fixes the problem, by adding Outputable.pprDeeperList. I also made some of the pretty-printing in HsExpr rather more vigorous about increasing the depth; in particular, pprParendExpr. This should make debug prints shorter. --- compiler/hsSyn/HsExpr.lhs | 32 ++++++++++++++++++-------------- compiler/utils/Outputable.lhs | 16 +++++++++++++++- 2 files changed, 33 insertions(+), 15 deletions(-) diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index d4cb80e..2be1ee6 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -274,10 +274,14 @@ instance OutputableBndr id => Outputable (HsExpr id) where \end{code} \begin{code} +-- pprExpr and pprLExpr call pprDeeper; +-- the underscore versions do not pprExpr :: OutputableBndr id => HsExpr id -> SDoc - pprExpr e = pprDeeper (ppr_expr e) +pprLExpr :: OutputableBndr id => LHsExpr id -> SDoc +pprLExpr e = pprDeeper (ppr_expr (unLoc e)) + pprBinds :: OutputableBndr id => HsLocalBinds id -> SDoc pprBinds b = pprDeeper (ppr b) @@ -364,13 +368,13 @@ ppr_expr (HsLet binds expr) ppr_expr (HsDo do_or_list_comp stmts body _) = pprDo do_or_list_comp stmts body ppr_expr (ExplicitList _ exprs) - = brackets (fsep (punctuate comma (map ppr_lexpr exprs))) + = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs))) ppr_expr (ExplicitPArr _ exprs) - = pa_brackets (fsep (punctuate comma (map ppr_lexpr exprs))) + = pa_brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs))) ppr_expr (ExplicitTuple exprs boxity) - = tupleParens boxity (sep (punctuate comma (map ppr_lexpr exprs))) + = tupleParens boxity (pprDeeperList sep (punctuate comma (map ppr_lexpr exprs))) ppr_expr (RecordCon con_id con_expr rbinds) = pp_rbinds (ppr con_id) rbinds @@ -457,9 +461,9 @@ Parenthesize unless very simple: pprParendExpr :: OutputableBndr id => LHsExpr id -> SDoc pprParendExpr expr = let - pp_as_was = ppr_lexpr expr - -- Using ppr_expr here avoids the call to 'deeper' - -- Not sure if that's always right. + pp_as_was = pprLExpr expr + -- Using pprLExpr makes sure that we go 'deeper' + -- I think that is usually (always?) right in case unLoc expr of HsLit l -> ppr l @@ -473,7 +477,6 @@ pprParendExpr expr HsPar _ -> pp_as_was HsBracket _ -> pp_as_was HsBracketOut _ [] -> pp_as_was - _ -> parens pp_as_was \end{code} @@ -562,7 +565,7 @@ recBindFields (HsRecordBinds rbinds) = [unLoc field | (field,_) <- rbinds] pp_rbinds :: OutputableBndr id => SDoc -> HsRecordBinds id -> SDoc pp_rbinds thing (HsRecordBinds rbinds) = hang thing - 4 (braces (sep (punctuate comma (map (pp_rbind) rbinds)))) + 4 (braces (pprDeeperList sep (punctuate comma (map (pp_rbind) rbinds)))) where pp_rbind (v, e) = hsep [pprBndr LetBind (unLoc v), char '=', ppr e] \end{code} @@ -666,9 +669,10 @@ pprMatch ctxt (Match pats maybe_ty grhss) pprGRHSs :: OutputableBndr id => HsMatchContext id -> GRHSs id -> SDoc pprGRHSs ctxt (GRHSs grhss binds) - = vcat (map (pprGRHS ctxt . unLoc) grhss) - $$ - (if isEmptyLocalBinds binds then empty + = pprDeeper + (vcat (map (pprGRHS ctxt . unLoc) grhss) + $$ + if isEmptyLocalBinds binds then empty else text "where" $$ nest 4 (pprBinds binds)) pprGRHS :: OutputableBndr id => HsMatchContext id -> GRHS id -> SDoc @@ -791,8 +795,8 @@ pprStmt (ParStmt stmtss) = hsep (map (\stmts -> ptext SLIT("| ") <> ppr pprStmt (RecStmt segment _ _ _ _) = ptext SLIT("rec") <+> braces (vcat (map ppr segment)) pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> LHsExpr id -> SDoc -pprDo DoExpr stmts body = ptext SLIT("do") <+> (vcat (map ppr stmts) $$ ppr body) -pprDo (MDoExpr _) stmts body = ptext SLIT("mdo") <+> (vcat (map ppr stmts) $$ ppr body) +pprDo DoExpr stmts body = ptext SLIT("do") <+> pprDeeperList vcat (map ppr stmts ++ [ppr body]) +pprDo (MDoExpr _) stmts body = ptext SLIT("mdo") <+> pprDeeperList vcat (map ppr stmts ++ [ppr body]) pprDo ListComp stmts body = pprComp brackets stmts body pprDo PArrComp stmts body = pprComp pa_brackets stmts body pprDo other stmts body = panic "pprDo" -- PatGuard, ParStmtCxt diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index ad6548b..4f8d320 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -14,7 +14,8 @@ module Outputable ( BindingSite(..), PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, - getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper, pprSetDepth, + getPprStyle, withPprStyle, withPprStyleDoc, + pprDeeper, pprDeeperList, pprSetDepth, codeStyle, userStyle, debugStyle, dumpStyle, asmStyle, ifPprDebug, qualName, qualModule, mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle, @@ -188,6 +189,19 @@ pprDeeper d (PprUser q (PartWay 0)) = Pretty.text "..." pprDeeper d (PprUser q (PartWay n)) = d (PprUser q (PartWay (n-1))) pprDeeper d other_sty = d other_sty +pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc +-- Truncate a list that list that is longer than the current depth +pprDeeperList f ds (PprUser q (PartWay n)) + | n==0 = Pretty.text "..." + | otherwise = f (go 0 ds) (PprUser q (PartWay (n-1))) + where + go i [] = [] + go i (d:ds) | i >= n = [text "...."] + | otherwise = d : go (i+1) ds + +pprDeeperList f ds other_sty + = f ds other_sty + pprSetDepth :: Int -> SDoc -> SDoc pprSetDepth n d (PprUser q _) = d (PprUser q (PartWay n)) pprSetDepth n d other_sty = d other_sty -- 1.7.10.4