Add the interleaved-output option/config value #3225

* Fixes #3225
* Fixes #3508

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 stdout at the same time with a `packagename> ` prefix. See
+  [#3225](https://github.com/commercialhaskell/stack/issues/3225).
 
 Bug fixes:
 

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