Commit d38a30cb authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

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.
parent 618380a7
......@@ -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
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment