Always stream test output concurrently

Issue haskell#1810. Some test suites would freeze if invoked with
`--show-details=always` instead of `--show-details=streaming` because
output would build up in the pipe without being cleared. This corrects
the issue by forcing the length of the output string in another thread.

Cabal/Distribution/Compat/CreatePipe.hs

@@ -1,9 +1,7 @@
 {-# LANGUAGE CPP, ForeignFunctionInterface #-}
-module Distribution.Compat.CreatePipe (createPipe, tee) where
+module Distribution.Compat.CreatePipe (createPipe) where
 
-import Control.Concurrent (forkIO)
-import Control.Monad (forM_, when)
-import System.IO (Handle, hClose, hGetContents, hPutStr)
+import System.IO (Handle)
 
 -- The mingw32_HOST_OS CPP macro is GHC-specific
 #if mingw32_HOST_OS
@@ -55,21 +53,3 @@ createPipe = do
     writeh <- fdToHandle writefd
     return (readh, writeh)
 #endif
-
--- | Copy the contents of the input handle to the output handles, like
--- the Unix command. The input handle is processed in another thread until
--- EOF is reached; 'tee' returns immediately. The 'Bool' with each output
--- handle indicates if it should be closed when EOF is reached.
--- Synchronization can be achieved by blocking on an output handle.
-tee :: Handle -- ^ input
-    -> [(Handle, Bool)] -- ^ output, close?
-    -> IO ()
-tee inH outHs = do
-    -- 'hGetContents' might cause text decoding errors on binary streams that
-    -- are not text. It might be better to read into a buffer with 'hGetBuf'
-    -- that does no text decoding, but that seems to block all threads on
-    -- Windows. This is much simpler.
-    str <- hGetContents inH
-    forM_ outHs $ \(h, close) -> forkIO $ do
-        hPutStr h str
-        when close $ hClose h

Cabal/Distribution/Simple/Test/ExeV10.hs

@@ -2,8 +2,9 @@ module Distribution.Simple.Test.ExeV10
        ( runTest
        ) where
 
-import Distribution.Compat.CreatePipe ( createPipe, tee )
+import Distribution.Compat.CreatePipe ( createPipe )
 import Distribution.Compat.Environment ( getEnvironment )
+import Distribution.Compat.TempFile ( openTempFile )
 import qualified Distribution.PackageDescription as PD
 import Distribution.Simple.Build.PathsModule ( pkgPathEnvVar )
 import Distribution.Simple.BuildPaths ( exeExtension )
@@ -20,13 +21,15 @@ import Distribution.TestSuite
 import Distribution.Text
 import Distribution.Verbosity ( normal )
 
-import Control.Monad ( when, unless )
+import Control.Concurrent (forkIO)
+import Control.Exception ( bracket )
+import Control.Monad ( unless, void, when )
 import System.Directory
     ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist
-    , getCurrentDirectory, removeDirectoryRecursive )
+    , getCurrentDirectory, removeDirectoryRecursive, removeFile )
 import System.Exit ( ExitCode(..) )
 import System.FilePath ( (</>), (<.>) )
-import System.IO ( hGetContents, stdout )
+import System.IO ( hClose, hGetContents, hPutStr, stdout )
 
 runTest :: PD.PackageDescription
         -> LBI.LocalBuildInfo
@@ -56,46 +59,51 @@ runTest pkg_descr lbi flags suite = do
     -- Write summary notices indicating start of test suite
     notice verbosity $ summarizeSuiteStart $ PD.testName suite
 
-    -- Run test executable
-    (rLog, wLog) <- createPipe
+    (rOut, wOut) <- createPipe
+
+    -- Read test executable's output lazily (returns immediately)
+    logText <- hGetContents rOut
+    -- Force the IO manager to drain the test output pipe
+    void $ forkIO $ length logText `seq` return ()
+
+    -- '--show-details=streaming': print the log output in another thread
+    when (details == Streaming) $ void $ forkIO $ hPutStr stdout logText
+
+    -- Run the test executable
     let opts = map (testOption pkg_descr lbi suite)
                    (testOptions flags)
         dataDirPath = pwd </> PD.dataDir pkg_descr
+        tixFile = pwd </> (tixFilePath distPref $ PD.testName suite)
         shellEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath)
-                   : ("HPCTIXFILE", (</>) pwd
-                       $ tixFilePath distPref $ PD.testName suite)
+                   : ("HPCTIXFILE", tixFile)
                    : existingEnv
-
-    (rOut, wOut) <- createPipe
-    let outHandles | details == Streaming = [(stdout, False)]
-                   | otherwise = []
-    tee rOut $ (wLog, True) : outHandles
     exit <- rawSystemIOWithEnv verbosity cmd opts Nothing (Just shellEnv)
                                -- these handles are automatically closed
                                Nothing (Just wOut) (Just wOut)
 
     -- Generate TestSuiteLog from executable exit code and a machine-
-    -- readable test log
+    -- readable test log.
     let suiteLog = buildLog exit
 
     -- Write summary notice to log file indicating start of test suite
     appendFile (logFile suiteLog) $ summarizeSuiteStart $ PD.testName suite
 
     -- Append contents of temporary log file to the final human-
     -- readable log file
-    logText <- hGetContents rLog
     appendFile (logFile suiteLog) logText
 
     -- Write end-of-suite summary notice to log file
     appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog
 
     -- Show the contents of the human-readable log file on the terminal
     -- if there is a failure and/or detailed output is requested
-    let
-        whenPrinting = when $ (details > Never)
+    let whenPrinting = when $
+            (details > Never)
             && (not (suitePassed $ testLogs suiteLog) || details == Always)
-            && verbosity >= normal -- verbosity overrides show-details
-            && details /= Streaming -- If streaming, we already printed the log
+            -- verbosity overrides show-details
+            && verbosity >= normal
+            -- if streaming, we already printed the log
+            && details /= Streaming
     whenPrinting $ putStr $ unlines $ lines logText
 
     -- Write summary notice to terminal indicating end of test suite