[commit: ghc] master: Outputable: Add pprTraceException (afc04b2)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/afc04b2689e5b936ecc8689c194a0ed2c0a2e6da/ghc

>---------------------------------------------------------------

commit afc04b2689e5b936ecc8689c194a0ed2c0a2e6da
Author: Ben Gamari <ben at smart-cactus.org>
Date:   Thu Oct 19 13:25:51 2017 -0400

    Outputable: Add pprTraceException


>---------------------------------------------------------------

afc04b2689e5b936ecc8689c194a0ed2c0a2e6da
 compiler/utils/Outputable.hs | 12 +++++++++++-
 1 file changed, 11 insertions(+), 1 deletion(-)

diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs
index c79cbc5..95960f5 100644
--- a/compiler/utils/Outputable.hs
+++ b/compiler/utils/Outputable.hs
@@ -81,8 +81,9 @@ module Outputable (
         -- * Error handling and debugging utilities
         pprPanic, pprSorry, assertPprPanic, pprPgmError,
         pprTrace, pprTraceDebug, pprTraceIt, warnPprTrace, pprSTrace,
+        pprTraceException,
         trace, pgmError, panic, sorry, assertPanic,
-        pprDebugAndThen, callStackDoc
+        pprDebugAndThen, callStackDoc,
     ) where
 
 import GhcPrelude
@@ -126,6 +127,8 @@ import Data.List (intersperse)
 import GHC.Fingerprint
 import GHC.Show         ( showMultiLineString )
 import GHC.Stack        ( callStack, prettyCallStack )
+import Control.Monad.IO.Class
+import Exception
 
 {-
 ************************************************************************
@@ -1168,6 +1171,13 @@ pprTrace str doc x
 pprTraceIt :: Outputable a => String -> a -> a
 pprTraceIt desc x = pprTrace desc (ppr x) x
 
+-- | @pprTraceException desc x action@ runs action, printing a message
+-- if it throws an exception.
+pprTraceException :: ExceptionMonad m => String -> SDoc -> m a -> m a
+pprTraceException heading doc =
+    handleGhcException $ \exc -> liftIO $ do
+        putStrLn $ showSDocDump unsafeGlobalDynFlags (sep [text heading, nest 2 doc])
+        throwGhcExceptionIO exc
 
 -- | If debug output is on, show some 'SDoc' on the screen along
 -- with a call stack when available.