Commit fa362ab5 authored by Ian Lynagh's avatar Ian Lynagh
Browse files

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
parent dff06f8e
......@@ -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}
......@@ -10,6 +10,7 @@ module GHC (
-- * Initialisation
defaultErrorHandler,
defaultCleanupHandler,
prettyPrintGhcErrors,
-- * GHC Monad
Ghc, GhcT, GhcMonad(..), HscEnv,
......
......@@ -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"
......
......@@ -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)
......
......@@ -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
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment