From a9db145ff5b02ad9c79fcef44898a37254cc6c1a Mon Sep 17 00:00:00 2001
From: "simonpj@microsoft.com" <unknown>
Date: Thu, 15 Oct 2009 11:44:37 +0000
Subject: [PATCH] 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.
---
 compiler/hsSyn/HsBinds.lhs |   36 +++++++++++++++++++++++-------------
 compiler/hsSyn/HsExpr.lhs  |   19 +++++++++++--------
 2 files changed, 34 insertions(+), 21 deletions(-)

diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index 702e736..0cf7966 100644
--- a/compiler/hsSyn/HsBinds.lhs
+++ b/compiler/hsSyn/HsBinds.lhs
@@ -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
diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index 3654de1..cdf7322 100644
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -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,
-- 
1.7.10.4