Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : ghc-7.2
http://hackage.haskell.org/trac/ghc/changeset/53e91bb6f5e778b51b6027ef634dc58b1357be12 >--------------------------------------------------------------- commit 53e91bb6f5e778b51b6027ef634dc58b1357be12 Author: Ian Lynagh <[email protected]> Date: Sun Jul 3 03:11:32 2011 +0100 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. >--------------------------------------------------------------- compiler/main/DynFlags.hs | 31 ++++++++++++++++++------------- compiler/main/ErrUtils.lhs | 9 ++++++--- compiler/main/GHC.hs | 12 ++++++------ ghc/Main.hs | 3 +-- utils/ghctags/Main.hs | 4 ++-- 5 files changed, 33 insertions(+), 26 deletions(-) diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 8b963b6..89617f5 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -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] ~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index a0a9f0e..60e1376 100644 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.lhs @@ -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 diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 8f5c894..b73df73 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -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 diff --git a/ghc/Main.hs b/ghc/Main.hs index 71a45f8..4a91acd 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -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 diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs index 4ba8157..fafd63e 100644 --- a/utils/ghctags/Main.hs +++ b/utils/ghctags/Main.hs @@ -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 _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
