[commit: ghc] master: Change how pprPanic works (fa362ab)

[Ian Lynagh]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/fa362ab59b9c17afcbd71318cffc873ea224449e

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

commit fa362ab59b9c17afcbd71318cffc873ea224449e
Author: Ian Lynagh <igloo at earth.li>
Date:   Mon Jun 11 17:25:08 2012 +0100

    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    |   11 +++++++++++
 compiler/main/GHC.hs          |    1 +
 compiler/utils/Outputable.lhs |    5 +++--
 compiler/utils/Panic.lhs      |   12 +++++++++++-
 ghc/Main.hs                   |    3 +++
 5 files changed, 29 insertions(+), 3 deletions(-)

diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index 5eaaa8d..d694c28 100644
--- a/compiler/main/ErrUtils.lhs
+++ b/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}
 
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index dca108b..97b02be 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -10,6 +10,7 @@ module GHC (
         -- * Initialisation
         defaultErrorHandler,
         defaultCleanupHandler,
+        prettyPrintGhcErrors,
 
         -- * GHC Monad
         Ghc, GhcT, GhcMonad(..), HscEnv,
diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index 9076913..25fa15e 100644
--- a/compiler/utils/Outputable.lhs
+++ b/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"
diff --git a/compiler/utils/Panic.lhs b/compiler/utils/Panic.lhs
index 42594c8..019eec3 100644
--- a/compiler/utils/Panic.lhs
+++ b/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)
 
diff --git a/ghc/Main.hs b/ghc/Main.hs
index a8202f2..ce4c628 100644
--- a/ghc/Main.hs
+++ b/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