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.

3 files changed, 30 insertions, 22 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