Add the interleaved-output option/config value #3225

ChangeLog.md

@@ -25,6 +25,10 @@ Other enhancements:
   [#4068](https://github.com/commercialhaskell/stack/pull/4068).
 * Added new `--tar-dir` option to `stack sdist`, that allows to copy
   the resulting tarball to the specified directory.
+* Introduced the `--interleaved-output` command line option and
+  `build.interleaved-output` config value which causes multiple concurrent
+  builds to dump to stderr at the same time with a `packagename> ` prefix. See
+  [#3225](https://github.com/commercialhaskell/stack/issues/3225).
 
 Bug fixes:
 

doc/build_command.md

@@ -194,3 +194,9 @@ end up in a log file instead of on the console unless it contains errors or
 warnings, to avoid problems of interleaved output and decrease console noise.
 If you would like to see this content instead, you can use the `--dump-logs`
 command line option, or add `dump-logs: all` to your `stack.yaml` file.
+
+Alternatively, starting with Stack 1.8, you can pass `--interleaved-output` to
+see output of all packages being built scroll by in a streaming fashion. The
+output from each package built will be prefixed by the package name, e.g. `mtl>
+Building ...`. Note that, unlike the default output, this will include the
+output from dependencies being built, not just targets.

doc/yaml_configuration.md

@@ -787,6 +787,9 @@ build:
   reconfigure: false
   cabal-verbose: false
   split-objs: false
+
+  # Since 1.8
+  interleaved-output: false
 ```
 
 The meanings of these settings correspond directly with the CLI flags of the

src/Stack/Build/Execute.hs

@@ -11,6 +11,7 @@
 {-# LANGUAGE TypeFamilies          #-}
 {-# LANGUAGE ScopedTypeVariables   #-}
 {-# LANGUAGE RankNTypes            #-}
+{-# LANGUAGE TupleSections         #-}
 -- | Perform a build
 module Stack.Build.Execute
     ( printPlan
@@ -875,6 +876,12 @@ announceTask task x = logInfo $
     ": " <>
     RIO.display x
 
+-- | How we deal with output from GHC, either dumping to a log file or the
+-- console (with some prefix).
+data OutputType
+  = OTLogFile !(Path Abs File) !Handle
+  | OTConsole !Utf8Builder
+
 -- | This sets up a context for executing build steps which need to run
 -- Cabal (via a compiled Setup.hs).  In particular it does the following:
 --
@@ -901,15 +908,14 @@ withSingleContext :: forall env a. HasEnvConfig env
                      -> (ExcludeTHLoading -> [String] -> RIO env ())
                                                                -- Function to run Cabal with args
                      -> (Text -> RIO env ())             -- An 'announce' function, for different build phases
-                     -> Bool                                   -- Whether output should be directed to the console
-                     -> Maybe (Path Abs File, Handle)          -- Log file
+                     -> OutputType
                      -> RIO env a)
                   -> RIO env a
 withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffix inner0 =
     withPackage $ \package cabalfp pkgDir ->
-    withLogFile pkgDir package $ \mlogFile ->
-    withCabal package pkgDir mlogFile $ \cabal ->
-    inner0 package cabalfp pkgDir cabal announce console mlogFile
+    withOutputType pkgDir package $ \outputType ->
+    withCabal package pkgDir outputType $ \cabal ->
+    inner0 package cabalfp pkgDir cabal announce outputType
   where
     announce = announceTask task
 
@@ -944,8 +950,16 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffi
                 let cabalfp = dir </> cabalfpRel
                 inner package cabalfp dir
 
-    withLogFile pkgDir package inner
-        | console = inner Nothing
+    withOutputType pkgDir package inner
+        -- If the user requested interleaved output, dump to the console with a
+        -- prefix.
+        | boptsInterleavedOutput eeBuildOpts = inner $ OTConsole $ RIO.display (packageName package) <> "> "
+
+        -- Not in interleaved mode. When building a single wanted package, dump
+        -- to the console with no prefix.
+        | console = inner $ OTConsole mempty
+
+        -- Neither condition applies, dump to a file.
         | otherwise = do
             logPath <- buildLogPath package msuffix
             ensureDir (parent logPath)
@@ -957,15 +971,15 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffi
                     liftIO $ atomically $ writeTChan eeLogFiles (pkgDir, logPath)
                 _ -> return ()
 
-            withBinaryFile fp WriteMode $ \h -> inner (Just (logPath, h))
+            withBinaryFile fp WriteMode $ \h -> inner $ OTLogFile logPath h
 
     withCabal
         :: Package
         -> Path Abs Dir
-        -> Maybe (Path Abs File, Handle)
+        -> OutputType
         -> ((ExcludeTHLoading -> [String] -> RIO env ()) -> RIO env a)
         -> RIO env a
-    withCabal package pkgDir mlogFile inner = do
+    withCabal package pkgDir outputType inner = do
         config <- view configL
 
         unless (configAllowDifferentUser config) $
@@ -1108,12 +1122,12 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffi
                 runExe exeName fullArgs = do
                     compilerVer <- view actualCompilerVersionL
                     runAndOutput compilerVer `catch` \ece -> do
-                        bss <-
-                            case mlogFile of
-                                Nothing -> return []
-                                Just (logFile, h) -> do
+                        (mlogFile, bss) <-
+                            case outputType of
+                                OTConsole _ -> return (Nothing, [])
+                                OTLogFile logFile h -> do
                                     liftIO $ hClose h
-                                    withSourceFile (toFilePath logFile) $ \src ->
+                                    fmap (Just logFile,) $ withSourceFile (toFilePath logFile) $ \src ->
                                            runConduit
                                          $ src
                                         .| CT.decodeUtf8Lenient
@@ -1124,31 +1138,32 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffi
                             (Just taskProvides)
                             exeName
                             fullArgs
-                            (fmap fst mlogFile)
+                            mlogFile
                             bss
                   where
                     runAndOutput :: CompilerVersion 'CVActual -> RIO env ()
-                    runAndOutput compilerVer = withWorkingDir (toFilePath pkgDir) $ withProcessContext menv $ case mlogFile of
-                        Just (_, h) ->
+                    runAndOutput compilerVer = withWorkingDir (toFilePath pkgDir) $ withProcessContext menv $ case outputType of
+                        OTLogFile _ h ->
                             proc (toFilePath exeName) fullArgs
                           $ runProcess_
                           . setStdin (byteStringInput "")
                           . setStdout (useHandleOpen h)
                           . setStderr (useHandleOpen h)
-                        Nothing ->
+                        OTConsole prefix ->
                             void $ sinkProcessStderrStdout (toFilePath exeName) fullArgs
-                                (outputSink KeepTHLoading LevelWarn compilerVer)
-                                (outputSink stripTHLoading LevelInfo compilerVer)
+                                (outputSink KeepTHLoading LevelWarn compilerVer prefix)
+                                (outputSink stripTHLoading LevelInfo compilerVer prefix)
                     outputSink
                         :: HasCallStack
                         => ExcludeTHLoading
                         -> LogLevel
                         -> CompilerVersion 'CVActual
+                        -> Utf8Builder
                         -> ConduitM S.ByteString Void (RIO env) ()
-                    outputSink excludeTH level compilerVer =
+                    outputSink excludeTH level compilerVer prefix =
                         CT.decodeUtf8Lenient
                         .| mungeBuildOutput excludeTH makeAbsolute pkgDir compilerVer
-                        .| CL.mapM_ (logGeneric "" level . RIO.display)
+                        .| CL.mapM_ (logGeneric "" level . (prefix <>) . RIO.display)
                     -- If users want control, we should add a config option for this
                     makeAbsolute :: ConvertPathsToAbsolute
                     makeAbsolute = case stripTHLoading of
@@ -1347,7 +1362,7 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap
         bindir = toFilePath $ bcoSnapInstallRoot eeBaseConfigOpts </> bindirSuffix
 
     realConfigAndBuild cache allDepsMap = withSingleContext ac ee task (Just allDepsMap) Nothing
-        $ \package cabalfp pkgDir cabal announce _console _mlogFile -> do
+        $ \package cabalfp pkgDir cabal announce _outputType -> do
             executableBuildStatuses <- getExecutableBuildStatuses package pkgDir
             when (not (cabalIsSatisfied executableBuildStatuses) && taskIsTarget task)
                  (logInfo
@@ -1627,7 +1642,7 @@ singleTest topts testsToRun ac ee task installedMap = do
     -- FIXME: Since this doesn't use cabal, we should be able to avoid using a
     -- fullblown 'withSingleContext'.
     (allDepsMap, _cache) <- getConfigCache ee task installedMap True False
-    withSingleContext ac ee task (Just allDepsMap) (Just "test") $ \package _cabalfp pkgDir _cabal announce _console mlogFile -> do
+    withSingleContext ac ee task (Just allDepsMap) (Just "test") $ \package _cabalfp pkgDir _cabal announce outputType -> do
         config <- view configL
         let needHpc = toCoverage topts
 
@@ -1697,15 +1712,17 @@ singleTest topts testsToRun ac ee task installedMap = do
 
                         -- Clear "Progress: ..." message before
                         -- redirecting output.
-                        when (isNothing mlogFile) $ do
+                        case outputType of
+                          OTConsole _ -> do
                             logStickyDone ""
                             liftIO $ hFlush stdout
                             liftIO $ hFlush stderr
+                          OTLogFile _ _ -> pure ()
 
                         let output setter =
-                                case mlogFile of
-                                    Nothing -> id
-                                    Just (_, h) -> setter (useHandleOpen h)
+                                case outputType of
+                                    OTConsole _ -> id
+                                    OTLogFile _ h -> setter (useHandleOpen h)
 
                         ec <- withWorkingDir (toFilePath pkgDir) $
                           proc (toFilePath exePath) args $ \pc0 -> do
@@ -1721,7 +1738,9 @@ singleTest topts testsToRun ac ee task installedMap = do
                               waitExitCode p
                         -- Add a trailing newline, incase the test
                         -- output didn't finish with a newline.
-                        when (isNothing mlogFile) (logInfo "")
+                        case outputType of
+                          OTConsole _ -> logInfo ""
+                          OTLogFile _ _ -> pure ()
                         -- Move the .tix file out of the package
                         -- directory into the hpc work dir, for
                         -- tidiness.
@@ -1752,16 +1771,18 @@ singleTest topts testsToRun ac ee task installedMap = do
                 generateHpcReport pkgDir package testsToRun'
 
             bs <- liftIO $
-                case mlogFile of
-                    Nothing -> return ""
-                    Just (logFile, h) -> do
+                case outputType of
+                    OTConsole _ -> return ""
+                    OTLogFile logFile h -> do
                         hClose h
                         S.readFile $ toFilePath logFile
 
             unless (Map.null errs) $ throwM $ TestSuiteFailure
                 (taskProvides task)
                 errs
-                (fmap fst mlogFile)
+                (case outputType of
+                   OTLogFile fp _ -> Just fp
+                   OTConsole _ -> Nothing)
                 bs
 
             setTestSuccess pkgDir
@@ -1777,7 +1798,7 @@ singleBench :: HasEnvConfig env
             -> RIO env ()
 singleBench beopts benchesToRun ac ee task installedMap = do
     (allDepsMap, _cache) <- getConfigCache ee task installedMap False True
-    withSingleContext ac ee task (Just allDepsMap) (Just "bench") $ \_package _cabalfp _pkgDir cabal announce _console _mlogFile -> do
+    withSingleContext ac ee task (Just allDepsMap) (Just "bench") $ \_package _cabalfp _pkgDir cabal announce _outputType -> do
         let args = map T.unpack benchesToRun <> maybe []
                          ((:[]) . ("--benchmark-options=" <>))
                          (beoAdditionalArgs beopts)

src/Stack/Config/Build.hs

@@ -72,6 +72,9 @@ buildOptsFromMonoid BuildOptsMonoid{..} = BuildOpts
           (boptsSplitObjs defaultBuildOpts)
           buildMonoidSplitObjs
     , boptsSkipComponents = buildMonoidSkipComponents
+    , boptsInterleavedOutput = fromFirst
+          (boptsInterleavedOutput defaultBuildOpts)
+          buildMonoidInterleavedOutput
     }
   where
     -- These options are not directly used in bopts, instead they

src/Stack/Options/BuildMonoidParser.hs

@@ -21,7 +21,8 @@ buildOptsMonoidParser hide0 =
     haddockHyperlinkSource <*> copyBins <*> copyCompilerTool <*>
     preFetch <*> keepGoing <*> keepTmpFiles <*> forceDirty <*>
     tests <*> testOptsParser hideBool <*> benches <*>
-    benchOptsParser hideBool <*> reconfigure <*> cabalVerbose <*> splitObjs <*> skipComponents
+    benchOptsParser hideBool <*> reconfigure <*> cabalVerbose <*> splitObjs <*> skipComponents <*>
+    interleavedOutput
   where
     hideBool = hide0 /= BuildCmdGlobalOpts
     hide =
@@ -167,3 +168,8 @@ buildOptsMonoidParser hide0 =
                 (long "skip" <>
                  help "Skip given component, can be specified multiple times" <>
                  hide)))
+    interleavedOutput =
+        firstBoolFlags
+            "interleaved-output"
+            "Print concurrent GHC output to the console with a prefix for the package name"
+            hide

src/Stack/SDist.hs

@@ -332,7 +332,7 @@ getSDistFileList lp =
         withExecuteEnv bopts boptsCli baseConfigOpts locals
             [] [] [] -- provide empty list of globals. This is a hack around custom Setup.hs files
             $ \ee ->
-            withSingleContext ac ee task Nothing (Just "sdist") $ \_package cabalfp _pkgDir cabal _announce _console _mlogFile -> do
+            withSingleContext ac ee task Nothing (Just "sdist") $ \_package cabalfp _pkgDir cabal _announce _outputType -> do
                 let outFile = toFilePath tmpdir FP.</> "source-files-list"
                 cabal KeepTHLoading ["sdist", "--list-sources", outFile]
                 contents <- liftIO (S.readFile outFile)

src/Stack/Types/Config/Build.hs

@@ -88,6 +88,9 @@ data BuildOpts =
             -- ^ Whether to enable split-objs.
             ,boptsSkipComponents :: ![Text]
             -- ^ Which components to skip when building
+            ,boptsInterleavedOutput :: !Bool
+            -- ^ Should we use the interleaved GHC output when building
+            -- multiple packages?
             }
   deriving (Show)
 
@@ -117,6 +120,7 @@ defaultBuildOpts = BuildOpts
     , boptsCabalVerbose = False
     , boptsSplitObjs = False
     , boptsSkipComponents = []
+    , boptsInterleavedOutput = False
     }
 
 defaultBuildOptsCLI ::BuildOptsCLI
@@ -185,6 +189,7 @@ data BuildOptsMonoid = BuildOptsMonoid
     , buildMonoidCabalVerbose :: !(First Bool)
     , buildMonoidSplitObjs :: !(First Bool)
     , buildMonoidSkipComponents :: ![Text]
+    , buildMonoidInterleavedOutput :: !(First Bool)
     } deriving (Show, Generic)
 
 instance FromJSON (WithJSONWarnings BuildOptsMonoid) where
@@ -216,6 +221,7 @@ instance FromJSON (WithJSONWarnings BuildOptsMonoid) where
               buildMonoidCabalVerbose <- First <$> o ..:? buildMonoidCabalVerboseArgName
               buildMonoidSplitObjs <- First <$> o ..:? buildMonoidSplitObjsName
               buildMonoidSkipComponents <- o ..:? buildMonoidSkipComponentsName ..!= mempty
+              buildMonoidInterleavedOutput <- First <$> o ..:? buildMonoidInterleavedOutputName
               return BuildOptsMonoid{..})
 
 buildMonoidLibProfileArgName :: Text
@@ -290,6 +296,9 @@ buildMonoidSplitObjsName = "split-objs"
 buildMonoidSkipComponentsName :: Text
 buildMonoidSkipComponentsName = "skip-components"
 
+buildMonoidInterleavedOutputName :: Text
+buildMonoidInterleavedOutputName = "interleaved-output"
+
 instance Semigroup BuildOptsMonoid where
     (<>) = mappenddefault