From 1a0520194bca9ed6ef66b8f332ba4f71ad190acc Mon Sep 17 00:00:00 2001 From: Debian Haskell Group Date: Mon, 23 May 2016 14:12:09 +0000 Subject: [PATCH] cabal-show-detail-direct commit 3792d212a6f60573ef43dd72088a353725d09461 Author: Joachim Breitner Date: Thu Nov 5 11:31:12 2015 +0100 test: New mode --show-details=direct This mode implements #2911, and allows to connect the test runner directly to stdout/stdin. This is more reliable in the presence of no threading, i.e. a work-arond for #2398. I make the test suite use this, so that it passes again, despite printing lots of stuff. Once #2398 is fixed properly, the test suite should probably be extended to test all the various --show-details modes. Gbp-Pq: Name cabal-show-detail-direct.patch --- .../Cabal/Cabal/Distribution/Simple/Setup.hs | 5 ++-- .../Cabal/Distribution/Simple/Test/ExeV10.hs | 29 ++++++++++--------- 2 files changed, 19 insertions(+), 15 deletions(-) diff --git a/libraries/Cabal/Cabal/Distribution/Simple/Setup.hs b/libraries/Cabal/Cabal/Distribution/Simple/Setup.hs index b87b5678..096491a8 100644 --- a/libraries/Cabal/Cabal/Distribution/Simple/Setup.hs +++ b/libraries/Cabal/Cabal/Distribution/Simple/Setup.hs @@ -1725,7 +1725,7 @@ replCommand progConf = CommandUI -- * Test flags -- ------------------------------------------------------------ -data TestShowDetails = Never | Failures | Always | Streaming +data TestShowDetails = Never | Failures | Always | Streaming | Direct deriving (Eq, Ord, Enum, Bounded, Show) knownTestShowDetails :: [TestShowDetails] @@ -1813,7 +1813,8 @@ testCommand = CommandUI ("'always': always show results of individual test cases. " ++ "'never': never show results of individual test cases. " ++ "'failures': show results of failing test cases. " - ++ "'streaming': show results of test cases in real time.") + ++ "'streaming': show results of test cases in real time." + ++ "'direct': send results of test cases in real time; no log file.") testShowDetails (\v flags -> flags { testShowDetails = v }) (reqArg "FILTER" (readP_to_E (\_ -> "--show-details flag expects one of " diff --git a/libraries/Cabal/Cabal/Distribution/Simple/Test/ExeV10.hs b/libraries/Cabal/Cabal/Distribution/Simple/Test/ExeV10.hs index 6dc622ed..b634ba34 100644 --- a/libraries/Cabal/Cabal/Distribution/Simple/Test/ExeV10.hs +++ b/libraries/Cabal/Cabal/Distribution/Simple/Test/ExeV10.hs @@ -30,7 +30,7 @@ import System.Directory , getCurrentDirectory, removeDirectoryRecursive ) import System.Exit ( ExitCode(..) ) import System.FilePath ( (), (<.>) ) -import System.IO ( hGetContents, hPutStr, stdout ) +import System.IO ( hGetContents, hPutStr, stdout, stderr ) runTest :: PD.PackageDescription -> LBI.LocalBuildInfo @@ -63,15 +63,20 @@ runTest pkg_descr lbi flags suite = do -- Write summary notices indicating start of test suite notice verbosity $ summarizeSuiteStart $ PD.testName suite - (rOut, wOut) <- createPipe + (wOut, wErr, logText) <- case details of + Direct -> return (stdout, stderr, "") + _ -> do + (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 () + -- 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 + -- '--show-details=streaming': print the log output in another thread + when (details == Streaming) $ void $ forkIO $ hPutStr stdout logText + + return (wOut, wOut, logText) -- Run the test executable let opts = map (testOption pkg_descr lbi suite) @@ -93,7 +98,7 @@ runTest pkg_descr lbi flags suite = do exit <- rawSystemIOWithEnv verbosity cmd opts Nothing (Just shellEnv') -- these handles are automatically closed - Nothing (Just wOut) (Just wOut) + Nothing (Just wOut) (Just wErr) -- Generate TestSuiteLog from executable exit code and a machine- -- readable test log. @@ -112,12 +117,10 @@ runTest pkg_descr lbi flags suite = do -- 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) - && (not (suitePassed $ testLogs suiteLog) || details == Always) + ( details == Always || + details == Failures && not (suitePassed $ testLogs suiteLog)) -- 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 -- 2.30.2