Abstract out the hFlush calls in the GHC API

stdout/stderr might be closed, so we can't just hFlush them.
So we instead allow configuration in the same way that log_action
is configurable.

compiler/main/DynFlags.hs

@@ -16,7 +16,7 @@ module DynFlags (
         DynFlag(..),
         WarningFlag(..),
         ExtensionFlag(..),
-        LogAction,
+        LogAction, FlushOut(..), FlushErr(..),
         ProfAuto(..),
         glasgowExtsFlags,
         dopt,
@@ -62,6 +62,8 @@ module DynFlags (
         defaultDynFlags,                -- Settings -> DynFlags
         initDynFlags,                   -- DynFlags -> IO DynFlags
         defaultLogAction,
+        defaultFlushOut,
+        defaultFlushErr,
 
         getOpts,                        -- DynFlags -> (DynFlags -> [a]) -> [a]
         getVerbFlags,
@@ -129,7 +131,7 @@ import qualified Data.Map as Map
 import Data.Set (Set)
 import qualified Data.Set as Set
 import System.FilePath
-import System.IO        ( stderr, hPutChar )
+import System.IO
 
 import Data.IntSet (IntSet)
 import qualified Data.IntSet as IntSet
@@ -586,6 +588,8 @@ data DynFlags = DynFlags {
 
   -- | MsgDoc output action: use "ErrUtils" instead of this if you can
   log_action            :: LogAction,
+  flushOut              :: FlushOut,
+  flushErr              :: FlushErr,
 
   haddockOptions        :: Maybe String,
 
@@ -942,6 +946,8 @@ defaultDynFlags mySettings =
         extensions = [],
         extensionFlags = flattenExtensionFlags Nothing [],
         log_action = defaultLogAction,
+        flushOut = defaultFlushOut,
+        flushErr = defaultFlushErr,
         profAuto = NoProfAuto,
         llvmVersion = panic "defaultDynFlags: No llvmVersion"
       }
@@ -960,6 +966,16 @@ defaultLogAction severity srcSpan style msg
                    -- converting to string first and using hPutStr would
                    -- just emit the low 8 bits of each unicode char.
 
+newtype FlushOut = FlushOut (IO ())
+
+defaultFlushOut :: FlushOut
+defaultFlushOut = FlushOut $ hFlush stdout
+
+newtype FlushErr = FlushErr (IO ())
+
+defaultFlushErr :: FlushErr
+defaultFlushErr = FlushErr $ hFlush stderr
+
 {-
 Note [Verbosity levels]
 ~~~~~~~~~~~~~~~~~~~~~~~

compiler/main/GHC.hs

@@ -323,11 +323,12 @@ 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) => LogAction -> m a -> m a
-defaultErrorHandler la inner =
+defaultErrorHandler :: (ExceptionMonad m, MonadIO m)
+                    => LogAction -> FlushOut -> m a -> m a
+defaultErrorHandler la (FlushOut flushOut) inner =
   -- top-level exception handler: any unrecognised exception is a compiler bug.
   ghandle (\exception -> liftIO $ do
-           hFlush stdout
+           flushOut
            case fromException exception of
                 -- an IO exception probably isn't our fault, so don't panic
                 Just (ioe :: IOException) ->
@@ -347,7 +348,7 @@ defaultErrorHandler la inner =
   -- error messages propagated as exceptions
   handleGhcException
             (\ge -> liftIO $ do
-                hFlush stdout
+                flushOut
                 case ge of
                      PhaseFailed _ code -> exitWith code
                      Signal _ -> exitWith (ExitFailure 1)

compiler/main/SysTools.lhs

@@ -922,7 +922,8 @@ traceCmd dflags phase_name cmd_line action
  = do   { let verb = verbosity dflags
         ; showPass dflags phase_name
         ; debugTraceMsg dflags 3 (text cmd_line)
-        ; hFlush stderr
+        ; case flushErr dflags of
+              FlushErr io -> io
 
            -- And run it!
         ; action `catchIO` handle_exn verb

ghc/Main.hs

@@ -78,7 +78,7 @@ import Data.Maybe
 main :: IO ()
 main = do
    hSetBuffering stdout NoBuffering
-   GHC.defaultErrorHandler defaultLogAction $ do
+   GHC.defaultErrorHandler defaultLogAction 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 )
+import DynFlags         ( defaultLogAction, defaultFlushOut )
 import Bag
 import Exception
 import FastString
@@ -102,7 +102,7 @@ main = do
                      then Just `liftM` openFile "TAGS" openFileMode
                      else return Nothing
 
-  GHC.defaultErrorHandler defaultLogAction $
+  GHC.defaultErrorHandler defaultLogAction defaultFlushOut $
     runGhc (Just ghc_topdir) $ do
       --liftIO $ print "starting up session"
       dflags <- getSessionDynFlags