Pass DynFlags to the LogAction

A side-effect is that we can no longer use the LogAction in
defaultErrorHandler, as we don't have DynFlags at that point.
But all that defaultErrorHandler did is to print Strings as
SevFatal, so now it takes a 'FatalMessager' instead.

compiler/deSugar/Coverage.lhs

@@ -110,7 +110,7 @@ addTicksToBinds dflags mod mod_loc exports tyCons binds =
      modBreaks <- mkModBreaks count entries
 
      doIfSet_dyn dflags Opt_D_dump_ticked $
-         log_action dflags SevDump noSrcSpan defaultDumpStyle
+         log_action dflags dflags SevDump noSrcSpan defaultDumpStyle
              (pprLHsBinds binds1)
    
      return (binds1, HpcInfo count hashNo, modBreaks)

compiler/ghci/Debugger.hs

@@ -163,7 +163,7 @@ showTerm term = do
                       -- XXX: this tries to disable logging of errors
                       -- does this still do what it is intended to do
                       -- with the changed error handling and logging?
-           let noop_log _ _ _ _ = return ()
+           let noop_log _ _ _ _ _ = return ()
                expr = "show " ++ showSDoc (ppr bname)
            _ <- GHC.setSessionDynFlags dflags{log_action=noop_log}
            txt_ <- withExtendedLinkEnv [(bname, val)]

compiler/ghci/Linker.lhs

@@ -238,7 +238,7 @@ filterNameMap mods env
 showLinkerState :: DynFlags -> IO ()
 showLinkerState dflags
   = do pls <- readIORef v_PersistentLinkerState >>= readMVar
-       log_action dflags SevDump noSrcSpan defaultDumpStyle
+       log_action dflags dflags SevDump noSrcSpan defaultDumpStyle
                  (vcat [text "----- Linker state -----",
                         text "Pkgs:" <+> ppr (pkgs_loaded pls),
                         text "Objs:" <+> ppr (objs_loaded pls),
@@ -330,7 +330,7 @@ classifyLdInput dflags f
   | isObjectFilename f = return (Just (Object f))
   | isDynLibFilename f = return (Just (DLLPath f))
   | otherwise          = do
-        log_action dflags SevInfo noSrcSpan defaultUserStyle
+        log_action dflags dflags SevInfo noSrcSpan defaultUserStyle
             (text ("Warning: ignoring unrecognised input `" ++ f ++ "'"))
         return Nothing
 

compiler/iface/BinIface.hs

@@ -86,7 +86,7 @@ readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath
 readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do
     let printer :: SDoc -> IO ()
         printer = case traceBinIFaceReading of
-                      TraceBinIFaceReading -> \sd -> log_action dflags SevOutput noSrcSpan defaultDumpStyle sd
+                      TraceBinIFaceReading -> \sd -> log_action dflags dflags SevOutput noSrcSpan defaultDumpStyle sd
                       QuietBinIFaceReading -> \_ -> return ()
         wantedGot :: Outputable a => String -> a -> a -> IO ()
         wantedGot what wanted got =

compiler/iface/LoadIface.lhs

@@ -645,7 +645,7 @@ showIface hsc_env filename = do
    iface <- initTcRnIf 's' hsc_env () () $
        readBinIface IgnoreHiWay TraceBinIFaceReading filename
    let dflags = hsc_dflags hsc_env
-   log_action dflags SevDump noSrcSpan defaultDumpStyle (pprModIface iface)
+   log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (pprModIface iface)
 \end{code}
 
 \begin{code}

compiler/main/CodeOutput.lhs

@@ -57,7 +57,7 @@ codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC
                 { showPass dflags "CmmLint"
                 ; let lints = map (cmmLint (targetPlatform dflags)) flat_abstractC
                 ; case firstJusts lints of
-                        Just err -> do { log_action dflags SevDump noSrcSpan defaultDumpStyle err
+                        Just err -> do { log_action dflags dflags SevDump noSrcSpan defaultDumpStyle err
                                        ; ghcExit dflags 1
                                        }
                         Nothing  -> return ()

compiler/main/DriverPipeline.hs

@@ -1493,7 +1493,7 @@ mkExtraObjToLinkIntoBinary dflags = do
                                         _ -> True
 
    when (dopt Opt_NoHsMain dflags && have_rts_opts_flags) $ do
-      log_action dflags SevInfo noSrcSpan defaultUserStyle
+      log_action dflags dflags SevInfo noSrcSpan defaultUserStyle
           (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$
            text "    Call hs_init_ghc() from your main() function to set these options.")
 

compiler/main/DynFlags.hs

@@ -17,7 +17,7 @@ module DynFlags (
         WarningFlag(..),
         ExtensionFlag(..),
         Language(..),
-        LogAction, FlushOut(..), FlushErr(..),
+        FatalMessager, LogAction, FlushOut(..), FlushErr(..),
         ProfAuto(..),
         glasgowExtsFlags,
         dopt,
@@ -67,6 +67,7 @@ module DynFlags (
         -- ** Manipulating DynFlags
         defaultDynFlags,                -- Settings -> DynFlags
         initDynFlags,                   -- DynFlags -> IO DynFlags
+        defaultFatalMessager,
         defaultLogAction,
         defaultLogActionHPrintDoc,
         defaultFlushOut,
@@ -965,10 +966,14 @@ defaultDynFlags mySettings =
         llvmVersion = panic "defaultDynFlags: No llvmVersion"
       }
 
-type LogAction = Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()
+type FatalMessager = String -> IO ()
+type LogAction = DynFlags -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()
+
+defaultFatalMessager :: FatalMessager
+defaultFatalMessager = hPutStrLn stderr
 
 defaultLogAction :: LogAction
-defaultLogAction severity srcSpan style msg
+defaultLogAction _ severity srcSpan style msg
     = case severity of
       SevOutput -> printSDoc msg style
       SevDump   -> hPrintDump stdout msg
@@ -1005,7 +1010,7 @@ printInfoForUser = printSevForUser SevInfo
 
 printSevForUser :: Severity -> DynFlags -> PrintUnqualified -> SDoc -> IO ()
 printSevForUser sev dflags unqual doc
-    = log_action dflags sev noSrcSpan (mkUserStyle unqual AllTheWay) doc
+    = log_action dflags dflags sev noSrcSpan (mkUserStyle unqual AllTheWay) doc
 
 {-
 Note [Verbosity levels]

compiler/main/ErrUtils.lhs

@@ -25,7 +25,7 @@ module ErrUtils (
         --  * Messages during compilation
         putMsg, putMsgWith,
         errorMsg,
-        fatalErrorMsg, fatalErrorMsg',
+        fatalErrorMsg, fatalErrorMsg', fatalErrorMsg'',
         compilationProgressMsg,
         showPass,
         debugTraceMsg,
@@ -165,7 +165,7 @@ pprLocErrMsg (ErrMsg { errMsgSpans     = spans
 printMsgBag :: DynFlags -> Bag ErrMsg -> IO ()
 printMsgBag dflags bag
   = sequence_ [ let style = mkErrStyle unqual
-                in log_action dflags sev s style (d $$ e)
+                in log_action dflags dflags sev s style (d $$ e)
               | ErrMsg { errMsgSpans     = s:_,
                          errMsgShortDoc  = d,
                          errMsgSeverity  = sev,
@@ -201,7 +201,7 @@ doIfSet_dyn dflags flag action | dopt flag dflags = action
 dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO ()
 dumpIfSet dflags flag hdr doc
   | not flag   = return ()
-  | otherwise  = log_action dflags SevDump noSrcSpan defaultDumpStyle (mkDumpDoc hdr doc)
+  | otherwise  = log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (mkDumpDoc hdr doc)
 
 dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
 dumpIfSet_dyn dflags flag hdr doc
@@ -252,7 +252,7 @@ dumpSDoc dflags dflag hdr doc
 
             -- write the dump to stdout
             Nothing
-                 -> log_action dflags SevDump noSrcSpan defaultDumpStyle (mkDumpDoc hdr doc)
+                 -> log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (mkDumpDoc hdr doc)
 
 
 -- | Choose where to put a dump file based on DynFlags
@@ -305,34 +305,37 @@ ifVerbose dflags val act
   | otherwise               = return ()
 
 putMsg :: DynFlags -> MsgDoc -> IO ()
-putMsg dflags msg = log_action dflags SevInfo noSrcSpan defaultUserStyle msg
+putMsg dflags msg = log_action dflags dflags SevInfo noSrcSpan defaultUserStyle msg
 
 putMsgWith :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
 putMsgWith dflags print_unqual msg
-  = log_action dflags SevInfo noSrcSpan sty msg
+  = log_action dflags dflags SevInfo noSrcSpan sty msg
   where
     sty = mkUserStyle print_unqual AllTheWay
 
 errorMsg :: DynFlags -> MsgDoc -> IO ()
-errorMsg dflags msg = log_action dflags SevError noSrcSpan defaultErrStyle msg
+errorMsg dflags msg = log_action dflags dflags SevError noSrcSpan defaultErrStyle msg
 
 fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()
-fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) msg
+fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) dflags msg
 
-fatalErrorMsg' :: LogAction -> MsgDoc -> IO ()
-fatalErrorMsg' la msg = la SevFatal noSrcSpan defaultErrStyle msg
+fatalErrorMsg' :: LogAction -> DynFlags -> MsgDoc -> IO ()
+fatalErrorMsg' la dflags msg = la dflags SevFatal noSrcSpan defaultErrStyle msg
+
+fatalErrorMsg'' :: FatalMessager -> String -> IO ()
+fatalErrorMsg'' fm msg = fm msg
 
 compilationProgressMsg :: DynFlags -> String -> IO ()
 compilationProgressMsg dflags msg
-  = ifVerbose dflags 1 (log_action dflags SevOutput noSrcSpan defaultUserStyle (text msg))
+  = ifVerbose dflags 1 (log_action dflags dflags SevOutput noSrcSpan defaultUserStyle (text msg))
 
 showPass :: DynFlags -> String -> IO ()
 showPass dflags what
-  = ifVerbose dflags 2 (log_action dflags SevInfo noSrcSpan defaultUserStyle (text "***" <+> text what <> colon))
+  = ifVerbose dflags 2 (log_action dflags dflags SevInfo noSrcSpan defaultUserStyle (text "***" <+> text what <> colon))
 
 debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO ()
 debugTraceMsg dflags val msg
-  = ifVerbose dflags val (log_action dflags SevInfo noSrcSpan defaultDumpStyle msg)
+  = ifVerbose dflags val (log_action dflags dflags SevInfo noSrcSpan defaultDumpStyle msg)
 
 prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a
 prettyPrintGhcErrors _

compiler/main/GHC.hs

@@ -334,24 +334,24 @@ import Prelude hiding (init)
 -- the top level of your program.  The default handlers output the error
 -- message(s) to stderr and exit cleanly.
 defaultErrorHandler :: (ExceptionMonad m, MonadIO m)
-                    => LogAction -> FlushOut -> m a -> m a
-defaultErrorHandler la (FlushOut flushOut) inner =
+                    => FatalMessager -> FlushOut -> m a -> m a
+defaultErrorHandler fm (FlushOut flushOut) inner =
   -- top-level exception handler: any unrecognised exception is a compiler bug.
   ghandle (\exception -> liftIO $ do
            flushOut
            case fromException exception of
                 -- an IO exception probably isn't our fault, so don't panic
                 Just (ioe :: IOException) ->
-                  fatalErrorMsg' la (text (show ioe))
+                  fatalErrorMsg'' fm (show ioe)
                 _ -> case fromException exception of
                      Just UserInterrupt -> exitWith (ExitFailure 1)
                      Just StackOverflow ->
-                         fatalErrorMsg' la (text "stack overflow: use +RTS -K<size> to increase it")
+                         fatalErrorMsg'' fm "stack overflow: use +RTS -K<size> to increase it"
                      _ -> case fromException exception of
                           Just (ex :: ExitCode) -> throw ex
                           _ ->
-                              fatalErrorMsg' la
-                                  (text (show (Panic (show exception))))
+                              fatalErrorMsg'' fm
+                                  (show (Panic (show exception)))
            exitWith (ExitFailure 1)
          ) $
 
@@ -362,7 +362,7 @@ defaultErrorHandler la (FlushOut flushOut) inner =
                 case ge of
                      PhaseFailed _ code -> exitWith code
                      Signal _ -> exitWith (ExitFailure 1)
-                     _ -> do fatalErrorMsg' la (text (show ge))
+                     _ -> do fatalErrorMsg'' fm (show ge)
                              exitWith (ExitFailure 1)
             ) $
   inner

compiler/main/SysTools.lhs

@@ -851,10 +851,10 @@ builderMainLoop dflags filter_fn pgm real_args mb_env = do
               msg <- readChan chan
               case msg of
                 BuildMsg msg -> do
-                  log_action dflags SevInfo noSrcSpan defaultUserStyle msg
+                  log_action dflags dflags SevInfo noSrcSpan defaultUserStyle msg
                   loop chan hProcess t p exitcode
                 BuildError loc msg -> do
-                  log_action dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg
+                  log_action dflags dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg
                   loop chan hProcess t p exitcode
                 EOF ->
                   loop chan hProcess (t-1) p exitcode

compiler/main/TidyPgm.lhs

@@ -380,7 +380,7 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
           -- Print one-line size info
         ; let cs = coreBindsStats tidy_binds
         ; when (dopt Opt_D_dump_core_stats dflags)
-               (log_action dflags SevDump noSrcSpan defaultDumpStyle
+               (log_action dflags dflags SevDump noSrcSpan defaultDumpStyle
                           (ptext (sLit "Tidy size (terms,types,coercions)")
                            <+> ppr (moduleName mod) <> colon
                            <+> int (cs_tm cs)

compiler/simplCore/CoreMonad.lhs

@@ -189,7 +189,7 @@ displayLintResults :: DynFlags -> CoreToDo
                    -> IO ()
 displayLintResults dflags pass warns errs binds
   | not (isEmptyBag errs)
-  = do { log_action dflags Err.SevDump noSrcSpan defaultDumpStyle
+  = do { log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle
            (vcat [ banner "errors", Err.pprMessageBag errs
                  , ptext (sLit "*** Offending Program ***")
                  , pprCoreBindings binds
@@ -204,7 +204,7 @@ displayLintResults dflags pass warns errs binds
 	-- group.  Only afer a round of simplification are they unravelled.
   , not opt_NoDebugOutput
   , showLintWarnings pass
-  = log_action dflags Err.SevDump noSrcSpan defaultDumpStyle
+  = log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle
         (banner "warnings" $$ Err.pprMessageBag warns)
 
   | otherwise = return ()

compiler/simplCore/SimplCore.lhs

@@ -429,7 +429,7 @@ ruleCheckPass current_phase pat guts = do
     rb <- getRuleBase
     dflags <- getDynFlags
     liftIO $ Err.showPass dflags "RuleCheck"
-    liftIO $ log_action dflags Err.SevDump noSrcSpan defaultDumpStyle
+    liftIO $ log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle
                  (ruleCheckProgram current_phase pat rb (mg_binds guts))
     return guts
 

compiler/simplStg/SimplStg.lhs

@@ -46,7 +46,7 @@ stg2stg dflags module_name binds
 	; us <- mkSplitUniqSupply 'g'
 
 	; doIfSet_dyn dflags Opt_D_verbose_stg2stg 
-		      (log_action dflags SevDump noSrcSpan defaultDumpStyle (text "VERBOSE STG-TO-STG:"))
+		      (log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (text "VERBOSE STG-TO-STG:"))
 
 	; (binds', us', ccs) <- end_pass us "Stg2Stg" ([],[],[]) binds
 

compiler/typecheck/TcRnMonad.lhs

@@ -1226,7 +1226,7 @@ failIfM msg
   = do  { env <- getLclEnv
         ; let full_msg = (if_loc env <> colon) $$ nest 2 msg
         ; dflags <- getDynFlags
-        ; liftIO (log_action dflags SevFatal noSrcSpan defaultErrStyle full_msg)
+        ; liftIO (log_action dflags dflags SevFatal noSrcSpan defaultErrStyle full_msg)
         ; failM }
 
 --------------------
@@ -1257,7 +1257,7 @@ forkM_maybe doc thing_inside
                           dflags <- getDynFlags
                           let msg = hang (text "forkM failed:" <+> doc)
                                        2 (text (show exn))
-                          liftIO $ log_action dflags SevFatal noSrcSpan defaultErrStyle msg
+                          liftIO $ log_action dflags dflags SevFatal noSrcSpan defaultErrStyle msg
 
                     ; traceIf (text "} ending fork (badly)" <+> doc)
                     ; return Nothing }

ghc/Main.hs

@@ -79,7 +79,7 @@ main :: IO ()
 main = do
    hSetBuffering stdout NoBuffering
    hSetBuffering stderr NoBuffering
-   GHC.defaultErrorHandler defaultLogAction defaultFlushOut $ do
+   GHC.defaultErrorHandler defaultFatalMessager defaultFlushOut $ do
     -- 1. extract the -B flag from the args
     argv0 <- getArgs
 

utils/ghctags/Main.hs

@@ -11,7 +11,7 @@ import HscTypes         ( msHsFilePath )
 import Name             ( getOccString )
 --import ErrUtils         ( printBagOfErrors )
 import Panic            ( panic )
-import DynFlags         ( defaultLogAction, defaultFlushOut )
+import DynFlags         ( defaultFatalMessager, defaultFlushOut )
 import Bag
 import Exception
 import FastString
@@ -105,7 +105,7 @@ main = do
                      then Just `liftM` openFile "TAGS" openFileMode
                      else return Nothing
 
-  GHC.defaultErrorHandler defaultLogAction defaultFlushOut $
+  GHC.defaultErrorHandler defaultFatalMessager defaultFlushOut $
     runGhc (Just ghc_topdir) $ do
       --liftIO $ print "starting up session"
       dflags <- getSessionDynFlags