Commit 4c5464f9 authored by Ian Lynagh's avatar Ian Lynagh

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.
parent 778ca5de
......@@ -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]
~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment