defaultErrorHandler now only takes LogAction
authorIan Lynagh <igloo@earth.li>
Sun, 3 Jul 2011 02:11:32 +0000 (03:11 +0100)
committerIan Lynagh <igloo@earth.li>
Sun, 3 Jul 2011 12:57:53 +0000 (13:57 +0100)
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
compiler/main/ErrUtils.lhs
compiler/main/GHC.hs
ghc/Main.hs
utils/ghctags/Main.hs

index 8b963b6..89617f5 100644 (file)
@@ -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]
 ~~~~~~~~~~~~~~~~~~~~~~~
index a0a9f0e..60e1376 100644 (file)
@@ -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
index 8f5c894..b73df73 100644 (file)
@@ -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
index 71a45f8..4a91acd 100644 (file)
@@ -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
 
index 4ba8157..fafd63e 100644 (file)
@@ -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