From 09dff97690679a188eb06f5910f72c8be11bcc20 Mon Sep 17 00:00:00 2001
From: Johan Tibell <johan.tibell@gmail.com>
Date: Tue, 30 Oct 2012 09:37:19 -0700
Subject: [PATCH] Test suite: optionally output commands run
---
Cabal/tests/PackageTests/PackageTester.hs | 42 +++++++++++++++++------
1 file changed, 31 insertions(+), 11 deletions(-)
diff --git a/Cabal/tests/PackageTests/PackageTester.hs b/Cabal/tests/PackageTests/PackageTester.hs
index 3fc9ce9b89..0cbd8b3576 100644
--- a/Cabal/tests/PackageTests/PackageTester.hs
+++ b/Cabal/tests/PackageTests/PackageTester.hs
@@ -1,4 +1,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
+
+-- You can set the following VERBOSE environment variable to control
+-- the verbosity of the output generated by this module.
module PackageTests.PackageTester (
PackageSpec(..),
Success(..),
@@ -31,9 +34,13 @@ import Control.Monad
import Data.List
import Data.Maybe
import qualified Data.ByteString.Char8 as C
-import Test.HUnit
+import Test.HUnit hiding (path)
import Distribution.Compat.CreatePipe (createPipe)
+import Distribution.ReadE (readEOrFail)
+import Distribution.Simple.Utils (debug)
+import Distribution.Verbosity (Verbosity, deafening, flagToVerbosity, normal,
+ verbose)
data PackageSpec =
PackageSpec {
@@ -156,26 +163,27 @@ cabal spec cabalArgs = do
if customSetup
then do
compileSetup (directory spec)
- run (Just $ directory spec) (wd </> directory spec </> "Setup") cabalArgs
+ run (Just $ directory spec) (wd </> directory spec </> "Setup")
+ cabalArgs
else do
run (Just $ directory spec) (wd </> "Setup") cabalArgs
-- | Returns the command that was issued, the return code, and hte output text
run :: Maybe FilePath -> String -> [String] -> IO (String, ExitCode, String)
-run cwd cmd args = do
- -- Posix-specific
+run cwd path args = do
+ verbosity <- getVerbosity
+ printRawCommandAndArgs verbosity path args
(readh, writeh) <- createPipe
- pid <- runProcess cmd args cwd Nothing Nothing (Just writeh) (Just writeh)
+ pid <- runProcess path args cwd Nothing Nothing (Just writeh) (Just writeh)
-- fork off a thread to start consuming the output
- output <- suckH [] readh
+ out <- suckH [] readh
hClose readh
- -- wait on the process
- ex <- waitForProcess pid
- let fullCmd = intercalate " " $ cmd:args
- return ("\"" ++ fullCmd ++ "\" in " ++ fromMaybe "" cwd,
- ex, output)
+ -- wait for the program to terminate
+ exitcode <- waitForProcess pid
+ let fullCmd = unwords (path : args)
+ return ("\"" ++ fullCmd ++ "\" in " ++ fromMaybe "" cwd, exitcode, out)
where
suckH output h = do
eof <- hIsEOF h
@@ -185,6 +193,13 @@ run cwd cmd args = do
c <- hGetChar h
suckH (c:output) h
+-- Copied from Distribution/Simple/Utils.hs
+printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO ()
+printRawCommandAndArgs verbosity path args
+ | verbosity >= deafening = print (path, args)
+ | verbosity >= verbose = putStrLn $ unwords (path : args)
+ | otherwise = return ()
+
requireSuccess :: (String, ExitCode, String) -> IO ()
requireSuccess (cmd, exitCode, output) =
unless (exitCode == ExitSuccess) $
@@ -261,3 +276,8 @@ getGHCPkg = do
ghc <- getGHC
-- Somewhat brittle, but better than nothing.
return $ "ghc-pkg" ++ drop 3 ghc
+
+-- TODO: Convert to a "-v" flag instead.
+getVerbosity :: IO Verbosity
+getVerbosity = do
+ maybe normal (readEOrFail flagToVerbosity) `fmap` lookupEnv "VERBOSE"
--
GitLab