[commit: ghc] ghc-7.2: defaultErrorHandler now only takes LogAction (53e91bb)
Ian Lynagh
igloo at earth.li
Tue Jul 5 17:28:15 CEST 2011
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 <igloo at earth.li>
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
More information about the Cvs-ghc
mailing list