summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/main/DynFlags.hs31
-rw-r--r--compiler/main/ErrUtils.lhs9
-rw-r--r--compiler/main/GHC.hs12
-rw-r--r--ghc/Main.hs3
-rw-r--r--utils/ghctags/Main.hs4
5 files changed, 33 insertions, 26 deletions
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 8b963b6b58..89617f5a9c 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 a0a9f0e3b3..60e1376420 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 8f5c894ac2..b73df73fc1 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 71a45f8a9a..4a91acd3b9 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 4ba8157dcc..fafd63eabb 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
View Lorry Controller Status