Commit e01fffc6 authored by Ian Lynagh's avatar Ian Lynagh

defaultErrorHandler now only takes LogAction

It used to take a whole DynFlags, but that meant we had to
create a DynFlags with (panic "No settings") for settings, as
we didn't have any real settings.

Now we just pass the LogAction, which is all that it actually needed.
The default is exported from DynFlags as defaultLogAction.
parent 8837193a
......@@ -13,6 +13,7 @@ module DynFlags (
-- * Dynamic flags and associated configuration types
DynFlag(..),
ExtensionFlag(..),
LogAction,
glasgowExtsFlags,
dopt,
dopt_set,
......@@ -50,6 +51,7 @@ module DynFlags (
-- ** Manipulating DynFlags
defaultDynFlags, -- Settings -> DynFlags
initDynFlags, -- DynFlags -> IO DynFlags
defaultLogAction,
getOpts, -- DynFlags -> (DynFlags -> [a]) -> [a]
getVerbFlags,
......@@ -545,7 +547,7 @@ data DynFlags = DynFlags {
extensionFlags :: [ExtensionFlag],
-- | Message output action: use "ErrUtils" instead of this if you can
log_action :: Severity -> SrcSpan -> PprStyle -> Message -> IO (),
log_action :: LogAction,
haddockOptions :: Maybe String
}
......@@ -863,20 +865,23 @@ defaultDynFlags mySettings =
safeHaskell = Sf_None,
extensions = [],
extensionFlags = flattenExtensionFlags Nothing [],
log_action = \severity srcSpan style msg ->
case severity of
SevOutput -> printSDoc msg style
SevInfo -> printErrs msg style
SevFatal -> printErrs msg style
_ -> do
hPutChar stderr '\n'
printErrs (mkLocMessage srcSpan msg) style
-- careful (#2302): printErrs prints in UTF-8, whereas
-- converting to string first and using hPutStr would
-- just emit the low 8 bits of each unicode char.
log_action = defaultLogAction
}
type LogAction = Severity -> SrcSpan -> PprStyle -> Message -> IO ()
defaultLogAction :: LogAction
defaultLogAction severity srcSpan style msg
= case severity of
SevOutput -> printSDoc msg style
SevInfo -> printErrs msg style
SevFatal -> printErrs msg style
_ -> do hPutChar stderr '\n'
printErrs (mkLocMessage srcSpan msg) style
-- careful (#2302): printErrs prints in UTF-8, whereas
-- converting to string first and using hPutStr would
-- just emit the low 8 bits of each unicode char.
{-
Note [Verbosity levels]
~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -24,7 +24,7 @@ module ErrUtils (
-- * Messages during compilation
putMsg, putMsgWith,
errorMsg,
fatalErrorMsg,
fatalErrorMsg, fatalErrorMsg',
compilationProgressMsg,
showPass,
debugTraceMsg,
......@@ -36,7 +36,7 @@ import Bag ( Bag, bagToList, isEmptyBag, emptyBag )
import Util ( sortLe )
import Outputable
import SrcLoc
import DynFlags ( DynFlags(..), DynFlag(..), dopt )
import DynFlags
import StaticFlags ( opt_ErrorSpans )
import System.Exit ( ExitCode(..), exitWith )
......@@ -296,7 +296,10 @@ errorMsg :: DynFlags -> Message -> IO ()
errorMsg dflags msg = log_action dflags SevError noSrcSpan defaultErrStyle msg
fatalErrorMsg :: DynFlags -> Message -> IO ()
fatalErrorMsg dflags msg = log_action dflags SevFatal noSrcSpan defaultErrStyle msg
fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) msg
fatalErrorMsg' :: LogAction -> Message -> IO ()
fatalErrorMsg' la msg = la SevFatal noSrcSpan defaultErrStyle msg
compilationProgressMsg :: DynFlags -> String -> IO ()
compilationProgressMsg dflags msg
......
......@@ -319,23 +319,23 @@ import Prelude hiding (init)
-- Unless you want to handle exceptions yourself, you should wrap this around
-- the top level of your program. The default handlers output the error
-- message(s) to stderr and exit cleanly.
defaultErrorHandler :: (ExceptionMonad m, MonadIO m) => DynFlags -> m a -> m a
defaultErrorHandler dflags inner =
defaultErrorHandler :: (ExceptionMonad m, MonadIO m) => LogAction -> m a -> m a
defaultErrorHandler la inner =
-- top-level exception handler: any unrecognised exception is a compiler bug.
ghandle (\exception -> liftIO $ do
hFlush stdout
case fromException exception of
-- an IO exception probably isn't our fault, so don't panic
Just (ioe :: IOException) ->
fatalErrorMsg dflags (text (show ioe))
fatalErrorMsg' la (text (show ioe))
_ -> case fromException exception of
Just UserInterrupt -> exitWith (ExitFailure 1)
Just StackOverflow ->
fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
fatalErrorMsg' la (text "stack overflow: use +RTS -K<size> to increase it")
_ -> case fromException exception of
Just (ex :: ExitCode) -> throw ex
_ ->
fatalErrorMsg dflags
fatalErrorMsg' la
(text (show (Panic (show exception))))
exitWith (ExitFailure 1)
) $
......@@ -347,7 +347,7 @@ defaultErrorHandler dflags inner =
case ge of
PhaseFailed _ code -> exitWith code
Signal _ -> exitWith (ExitFailure 1)
_ -> do fatalErrorMsg dflags (text (show ge))
_ -> do fatalErrorMsg' la (text (show ge))
exitWith (ExitFailure 1)
) $
inner
......
......@@ -78,8 +78,7 @@ import Data.Maybe
main :: IO ()
main = do
hSetBuffering stdout NoBuffering
let defaultErrorHandlerDynFlags = defaultDynFlags (panic "No settings")
GHC.defaultErrorHandler defaultErrorHandlerDynFlags $ do
GHC.defaultErrorHandler defaultLogAction $ do
-- 1. extract the -B flag from the args
argv0 <- getArgs
......
......@@ -11,7 +11,7 @@ import HscTypes ( msHsFilePath )
import Name ( getOccString )
--import ErrUtils ( printBagOfErrors )
import Panic ( panic )
import DynFlags ( defaultDynFlags )
import DynFlags ( defaultLogAction )
import Bag
import Exception
import FastString
......@@ -102,7 +102,7 @@ main = do
then Just `liftM` openFile "TAGS" openFileMode
else return Nothing
GHC.defaultErrorHandler (defaultDynFlags (panic "No settings")) $
GHC.defaultErrorHandler defaultLogAction $
runGhc (Just ghc_topdir) $ do
--liftIO $ print "starting up session"
dflags <- getSessionDynFlags
......
Markdown is supported
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