Change how pprPanic works

We now include the String and the SDoc in the exception, and don't
flatten them into a String until near the top-level

compiler/main/ErrUtils.lhs

@@ -29,13 +29,17 @@ module ErrUtils (
         compilationProgressMsg,
         showPass,
         debugTraceMsg,
+
+        prettyPrintGhcErrors,
     ) where
 
 #include "HsVersions.h"
 
 import Bag              ( Bag, bagToList, isEmptyBag, emptyBag )
+import Exception
 import Util
 import Outputable
+import Panic
 import FastString
 import SrcLoc
 import DynFlags
@@ -329,5 +333,12 @@ showPass dflags what
 debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO ()
 debugTraceMsg dflags val msg
   = ifVerbose dflags val (log_action dflags SevInfo noSrcSpan defaultDumpStyle msg)
+
+prettyPrintGhcErrors :: ExceptionMonad m => m a -> m a
+prettyPrintGhcErrors = ghandle $ \e -> case e of
+                                       PprPanic str doc ->
+                                           pprDebugAndThen panic str doc
+                                       _ ->
+                                           throw e
 \end{code}
 

compiler/main/GHC.hs

@@ -10,6 +10,7 @@ module GHC (
         -- * Initialisation
         defaultErrorHandler,
         defaultCleanupHandler,
+        prettyPrintGhcErrors,
 
         -- * GHC Monad
         Ghc, GhcT, GhcMonad(..), HscEnv,

compiler/utils/Outputable.lhs

@@ -67,7 +67,8 @@ module Outputable (
         -- * Error handling and debugging utilities
         pprPanic, pprSorry, assertPprPanic, pprPanicFastInt, pprPgmError,
         pprTrace, pprDefiniteTrace, warnPprTrace,
-        trace, pgmError, panic, sorry, panicFastInt, assertPanic
+        trace, pgmError, panic, sorry, panicFastInt, assertPanic,
+        pprDebugAndThen,
     ) where
 
 import {-# SOURCE #-}   Module( Module, ModuleName, moduleName )
@@ -904,7 +905,7 @@ plural _   = char 's'
 
 pprPanic :: String -> SDoc -> a
 -- ^ Throw an exception saying "bug in GHC"
-pprPanic    = pprDebugAndThen panic
+pprPanic    = panicDoc
 
 pprSorry :: String -> SDoc -> a
 -- ^ Throw an exception saying "this isn't finished yet"

compiler/utils/Panic.lhs

@@ -14,6 +14,7 @@ module Panic (
      pgmError,
 
      panic, sorry, panicFastInt, assertPanic, trace,
+     panicDoc,
 
      Exception.Exception(..), showException, safeShowException, try, tryMost, throwTo,
 
@@ -22,9 +23,12 @@ module Panic (
 ) where
 #include "HsVersions.h"
 
+import {-# SOURCE #-} Outputable (SDoc)
+
 import Config
 import FastTypes
 import Exception
+
 import Control.Concurrent
 import Data.Dynamic
 #if __GLASGOW_HASKELL__ < 705
@@ -78,6 +82,7 @@ data GhcException
 
   -- | The 'impossible' happened.
   | Panic        String
+  | PprPanic     String SDoc
 
   -- | The user tickled something that's known not to work yet,
   --   but we're not counting it as a bug.
@@ -88,7 +93,7 @@ data GhcException
 
   -- | An error in the user's code, probably.
   | ProgramError String
-  deriving (Typeable, Eq)
+  deriving (Typeable)
 
 instance Exception GhcException
 
@@ -143,6 +148,8 @@ showGhcException exception
         InstallationError str   -> showString str
         Signal n                -> showString "signal: " . shows n
 
+        PprPanic  s _ ->
+            showGhcException (Panic (s ++ "\n<<details unavailable>>"))
         Panic s
          -> showString $
                 "panic! (the 'impossible' happened)\n"
@@ -185,6 +192,9 @@ panic    x = unsafeDupablePerformIO $ do
 panic    x = throwGhcException (Panic x)
 #endif
 
+panicDoc :: String -> SDoc -> a
+panicDoc x doc = throwGhcException (PprPanic x doc)
+
 sorry    x = throwGhcException (Sorry x)
 pgmError x = throwGhcException (ProgramError x)
 

ghc/Main.hs

@@ -78,6 +78,7 @@ import Data.Maybe
 main :: IO ()
 main = do
    hSetBuffering stdout NoBuffering
+   hSetBuffering stderr NoBuffering
    GHC.defaultErrorHandler defaultLogAction defaultFlushOut $ do
     -- 1. extract the -B flag from the args
     argv0 <- getArgs
@@ -166,6 +167,8 @@ main' postLoadMode dflags0 args flagWarnings = do
         -- Leftover ones are presumably files
   (dflags2, fileish_args, dynamicFlagWarnings) <- GHC.parseDynamicFlags dflags1a args
 
+  GHC.prettyPrintGhcErrors $ do
+
   let flagWarnings' = flagWarnings ++ dynamicFlagWarnings
 
   handleSourceError (\e -> do