diff options
| -rw-r--r-- | compiler/main/ErrUtils.lhs | 11 | ||||
| -rw-r--r-- | compiler/main/GHC.hs | 1 | ||||
| -rw-r--r-- | compiler/utils/Outputable.lhs | 5 | ||||
| -rw-r--r-- | compiler/utils/Panic.lhs | 12 | ||||
| -rw-r--r-- | ghc/Main.hs | 3 |
5 files changed, 29 insertions, 3 deletions
diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index 5eaaa8d5bc..d694c28d12 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 dca108b8c5..97b02be07c 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 9076913751..25fa15e18d 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 42594c8109..019eec387e 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 a8202f2853..ce4c62822f 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 |