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

Fix Trac #3263: don't print Hpc tick stuff unless -dppr-debug is on

In general, when pretty-printing HsSyn, we omit the extra info added by GHC
(type appplications and abstractions, etc) when printing stuff for the user.
But we weren't applying that guideline to the HsTick stuff for Hpc.  This
patch adds the necessary tests.
parent 1f56fae4
......@@ -271,28 +271,38 @@ ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) = pprPatBind pat
ppr_monobind (VarBind { var_id = var, var_rhs = rhs }) = pprBndr CaseBind var <+> equals <+> pprExpr (unLoc rhs)
ppr_monobind (FunBind { fun_id = fun, fun_infix = inf,
fun_matches = matches,
fun_tick = tick }) =
(case tick of
Nothing -> empty
Just t -> text "-- tick id = " <> ppr t
) $$ pprFunBind (unLoc fun) inf matches
fun_tick = tick })
= pprTicks empty (case tick of
Nothing -> empty
Just t -> text "-- tick id = " <> ppr t)
$$ pprFunBind (unLoc fun) inf matches
ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_dicts = dictvars,
abs_exports = exports, abs_binds = val_binds })
= sep [ptext (sLit "AbsBinds"),
brackets (interpp'SP tyvars),
brackets (interpp'SP dictvars),
brackets (sep (punctuate comma (map ppr_exp exports)))]
$$
nest 2 ( vcat [pprBndr LetBind x | (_,x,_,_) <- exports]
-- Print type signatures
$$ pprLHsBinds val_binds )
= sep [ptext (sLit "AbsBinds"),
brackets (interpp'SP tyvars),
brackets (interpp'SP dictvars),
brackets (sep (punctuate comma (map ppr_exp exports)))]
$$
nest 2 ( vcat [pprBndr LetBind x | (_,x,_,_) <- exports]
-- Print type signatures
$$ pprLHsBinds val_binds )
where
ppr_exp (tvs, gbl, lcl, prags)
= vcat [ppr gbl <+> ptext (sLit "<=") <+> ppr tvs <+> ppr lcl,
nest 2 (vcat (map (pprPrag gbl) prags))]
\end{code}
\begin{code}
pprTicks :: SDoc -> SDoc -> SDoc
-- Print stuff about ticks only when -dppr-debug is on, to avoid
-- them appearing in error messages (from the desugarer); see Trac # 3263
pprTicks pp_no_debug pp_when_debug
= getPprStyle (\ sty -> if debugStyle sty then pp_when_debug
else pp_no_debug)
\end{code}
%************************************************************************
%* *
Implicit parameter bindings
......
......@@ -469,21 +469,24 @@ ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _)))
= hsep [ptext (sLit "proc"), ppr pat, ptext (sLit "->"), ppr cmd]
ppr_expr (HsTick tickId vars exp)
= hcat [ptext (sLit "tick<"),
ppr tickId,
ptext (sLit ">("),
hsep (map pprHsVar vars),
ppr exp,
ptext (sLit ")")]
= pprTicks (ppr exp) $
hcat [ptext (sLit "tick<"),
ppr tickId,
ptext (sLit ">("),
hsep (map pprHsVar vars),
ppr exp,
ptext (sLit ")")]
ppr_expr (HsBinTick tickIdTrue tickIdFalse exp)
= hcat [ptext (sLit "bintick<"),
= pprTicks (ppr exp) $
hcat [ptext (sLit "bintick<"),
ppr tickIdTrue,
ptext (sLit ","),
ppr tickIdFalse,
ptext (sLit ">("),
ppr exp,ptext (sLit ")")]
ppr_expr (HsTickPragma externalSrcLoc exp)
= hcat [ptext (sLit "tickpragma<"),
= pprTicks (ppr exp) $
hcat [ptext (sLit "tickpragma<"),
ppr externalSrcLoc,
ptext (sLit ">("),
ppr exp,
......
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