Outputable: Add pprTraceException
authorBen Gamari <ben@smart-cactus.org>
Thu, 19 Oct 2017 17:25:51 +0000 (13:25 -0400)
committerBen Gamari <ben@smart-cactus.org>
Thu, 19 Oct 2017 20:43:24 +0000 (16:43 -0400)
compiler/utils/Outputable.hs

index c79cbc5..95960f5 100644 (file)
@@ -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.