Merge pull request #11753 from sheaf/mark-logProgress

Mark output in LogProgress

Author: mergify[bot]

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