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.

18 files changed, 52 insertions, 44 deletions

diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index ca5ef9ac88..d9d1718177 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/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)
diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
index ab028f603d..0fdc7a29f6 100644
--- a/compiler/ghci/Debugger.hs
+++ b/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)]
diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs
index e6f49e1781..3f36cfd8a0 100644
--- a/compiler/ghci/Linker.lhs
+++ b/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
 
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index a69656533c..5d1c48f183 100644
--- a/compiler/iface/BinIface.hs
+++ b/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 =
diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs
index 9445808b13..eaf8ef56f8 100644
--- a/compiler/iface/LoadIface.lhs
+++ b/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}
diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs
index c869ded308..b2c201cb41 100644
--- a/compiler/main/CodeOutput.lhs
+++ b/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 ()
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index deaa9bbbfe..87092c1d89 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/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.")
 
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index c45bb2df95..874737143a 100644
--- a/compiler/main/DynFlags.hs
+++ b/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]
diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index a89293fb61..eeb5e91c8a 100644
--- a/compiler/main/ErrUtils.lhs
+++ b/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 _
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 97b02be07c..5f9eb7c428 100644
--- a/compiler/main/GHC.hs
+++ b/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
diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs
index 848e02d47d..e44338918a 100644
--- a/compiler/main/SysTools.lhs
+++ b/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
diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index 6caae2db05..5cd3f76250 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/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)
diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs
index 8c5978f495..cd5b6472aa 100644
--- a/compiler/simplCore/CoreMonad.lhs
+++ b/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 ()
diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs
index a90fc0ca68..41ff505727 100644
--- a/compiler/simplCore/SimplCore.lhs
+++ b/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
 
diff --git a/compiler/simplStg/SimplStg.lhs b/compiler/simplStg/SimplStg.lhs
index 8493d9c275..d5024ab2e0 100644
--- a/compiler/simplStg/SimplStg.lhs
+++ b/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
 
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 659d43838f..c1bdd66bcd 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/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 }
diff --git a/ghc/Main.hs b/ghc/Main.hs
index 5a51c38d92..616309009b 100644
--- a/ghc/Main.hs
+++ b/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
 
diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs
index f63e039f39..3c7e216345 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         ( 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