diff --git a/Cabal/tests/PackageTests/PackageTester.hs b/Cabal/tests/PackageTests/PackageTester.hs index 3fc9ce9b8976ad30a27ab50f2a0ee4e14cbc588e..0cbd8b35761a79ce787eafefa6d8c71933cbe681 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"