diff --git a/Cabal/src/Distribution/Utils/LogProgress.hs b/Cabal/src/Distribution/Utils/LogProgress.hs index b8484eecc14..5f3ada889bf 100644 --- a/Cabal/src/Distribution/Utils/LogProgress.hs +++ b/Cabal/src/Distribution/Utils/LogProgress.hs @@ -16,11 +16,11 @@ import Prelude () import Distribution.Simple.Utils import Distribution.Utils.Progress import Distribution.Verbosity -import System.IO (hPutStrLn) +import System.IO (hFlush, hPutStr, hPutStrLn) import Text.PrettyPrint type CtxMsg = Doc -type LogMsg = Doc +data LogMsg = WarnMsg Doc | InfoMsg Doc type ErrMsg = Doc data LogEnv = LogEnv @@ -55,10 +55,19 @@ runLogProgress verbosity (LogProgress m) = , le_context = [] } step_fn :: LogMsg -> IO a -> IO a - step_fn doc go = do + step_fn (WarnMsg doc) go = do + -- Log the warning to the stderr handle, but flush the stdout handle first, + -- to prevent interleaving (see Distribution.Simple.Utils.warnMessage). + let h = verbosityErrorHandle verbosity + flags = verbosityFlags verbosity + hFlush (verbosityChosenOutputHandle verbosity) + hPutStr h $ withOutputMarker flags (render doc ++ "\n") + go + step_fn (InfoMsg doc) go = do + -- Don't mark 'infoProgress' messages (mostly Backpack internals) hPutStrLn (verbosityChosenOutputHandle verbosity) (render doc) go - fail_fn :: Doc -> IO a + fail_fn :: ErrMsg -> IO a fail_fn doc = do dieNoWrap verbosity (render doc) @@ -67,13 +76,15 @@ warnProgress :: Doc -> LogProgress () warnProgress s = LogProgress $ \env -> when (verbosityLevel (le_verbosity env) >= Normal) $ stepProgress $ - hang (text "Warning:") 4 (formatMsg (le_context env) s) + WarnMsg $ + hang (text "Warning:") 4 (formatMsg (le_context env) s) -- | Output an informational trace message in 'LogProgress'. infoProgress :: Doc -> LogProgress () infoProgress s = LogProgress $ \env -> when (verbosityLevel (le_verbosity env) >= Verbose) $ - stepProgress s + stepProgress $ + InfoMsg s -- | Fail the computation with an error message. dieProgress :: Doc -> LogProgress a