diff --git a/Distribution/Simple/Setup.hs b/Distribution/Simple/Setup.hs index 7ef9a21ae93..8a99882232e 100644 --- a/Distribution/Simple/Setup.hs +++ b/Distribution/Simple/Setup.hs @@ -114,7 +114,6 @@ import Distribution.Verbosity import Data.List ( sort ) import Data.Char ( isSpace, isAlpha ) import Data.Monoid ( Monoid(..) ) -import Data.Maybe ( fromJust ) -- FIXME Not sure where this should live defaultDistPref :: FilePath @@ -1222,14 +1221,10 @@ data TestFlags = TestFlags { testDistPref :: Flag FilePath, testVerbosity :: Flag Verbosity, testHumanLog :: Flag PathTemplate, - --TODO: do we really need append? - testHumanAppend :: Flag Bool, testMachineLog :: Flag PathTemplate, testShowDetails :: Flag TestShowDetails, --TODO: eliminate the test list and pass it directly as positional args to the testHook testList :: Flag [String], - -- TODO: do we need this feature? - testReplay :: Flag (Maybe FilePath), -- TODO: think about if/how options are passed to test exes testOptions :: Flag [String] } @@ -1239,11 +1234,9 @@ defaultTestFlags = TestFlags { testDistPref = Flag defaultDistPref, testVerbosity = Flag normal, testHumanLog = toFlag $ toPathTemplate $ "$pkgid-$test-suite.log", - testHumanAppend = toFlag False, testMachineLog = toFlag $ toPathTemplate $ "$pkgid.log", testShowDetails = toFlag Failures, testList = Flag [], - testReplay = toFlag Nothing, testOptions = Flag [] } @@ -1258,10 +1251,6 @@ testCommand = makeCommand name shortDesc longDesc defaultTestFlags options , optionDistPref testDistPref (\d flags -> flags { testDistPref = d }) showOrParseArgs - , option [] ["append-human-logs"] - ("Append test output to human-readable logs, instead of overwriting.") - testHumanAppend (\v flags -> flags { testHumanAppend = v }) - trueArg , option [] ["human-log"] ("Log all test suite results to file (name template can use " ++ "$pkgid, $compiler, $os, $arch, $test-suite, $result)") @@ -1287,11 +1276,6 @@ testCommand = makeCommand name shortDesc longDesc defaultTestFlags options (map display knownTestShowDetails)) (fmap toFlag parse)) (flagToList . fmap display)) - , option [] ["replay"] - ("replay the test suites in the given machine-readable log file " - ++ "using the options therein") - testReplay (\v flags -> flags { testReplay = v }) - (reqArg' "FILE" (toFlag . Just) (flagToList . fmap fromJust)) , option [] ["test-options"] "give extra options to test executables" testOptions (\v flags -> flags { testOptions = v }) @@ -1311,22 +1295,18 @@ instance Monoid TestFlags where testDistPref = mempty, testVerbosity = mempty, testHumanLog = mempty, - testHumanAppend = mempty, testMachineLog = mempty, testShowDetails = mempty, testList = mempty, - testReplay = mempty, testOptions = mempty } mappend a b = TestFlags { testDistPref = combine testDistPref, testVerbosity = combine testVerbosity, testHumanLog = combine testHumanLog, - testHumanAppend = combine testHumanAppend, testMachineLog = combine testMachineLog, testShowDetails = combine testShowDetails, testList = combine testList, - testReplay = combine testReplay, testOptions = combine testOptions } where combine field = field a `mappend` field b diff --git a/Distribution/Simple/Test.hs b/Distribution/Simple/Test.hs index 571443dcdc1..01bf1298e44 100644 --- a/Distribution/Simple/Test.hs +++ b/Distribution/Simple/Test.hs @@ -81,10 +81,10 @@ import Data.Char ( toUpper ) import Data.Monoid ( mempty ) import System.Directory ( createDirectoryIfMissing, doesFileExist, getCurrentDirectory - , getDirectoryContents, removeFile ) + , removeFile ) import System.Environment ( getEnvironment ) import System.Exit ( ExitCode(..), exitFailure, exitSuccess, exitWith ) -import System.FilePath ( (), (<.>), takeExtension ) +import System.FilePath ( (), (<.>) ) import System.IO ( hClose, IOMode(..), withFile ) import System.Process ( runProcess, waitForProcess ) @@ -122,8 +122,8 @@ data Case = Case } deriving (Read, Show, Eq) -getReplayOptions :: TestSuite.Test -> TestSuiteLog -> IO TestSuite.Options -getReplayOptions t l = +getTestOptions :: TestSuite.Test -> TestSuiteLog -> IO TestSuite.Options +getTestOptions t l = case filter ((== TestSuite.name t) . caseName) (cases l) of (x:_) -> return $ caseOptions x _ -> TestSuite.defaultOptions t @@ -234,14 +234,12 @@ test :: PD.PackageDescription -- ^information from the .cabal file -> IO () test pkg_descr lbi flags = do let verbosity = fromFlag $ testVerbosity flags - append = fromFlag $ testHumanAppend flags humanTemplate = fromFlag $ testHumanLog flags machineTemplate = fromFlag $ testMachineLog flags distPref = fromFlag $ testDistPref flags testLogDir = distPref "test" testNames = fromFlag $ testList flags pkgTests = PD.testSuites pkg_descr - replay = fromFlag $ testReplay flags doTest :: (PD.TestSuite, Maybe TestSuiteLog) -> IO TestSuiteLog doTest (suite, mLog) = do @@ -288,32 +286,16 @@ test pkg_descr lbi flags = do , logFile = "" } - testsToRun <- case replay of - Nothing -> case testNames of + testsToRun <- case testNames of [] -> return $ zip pkgTests $ repeat Nothing names -> flip mapM names $ \tName -> let testMap = map (\x -> (PD.testName x, x)) pkgTests in case lookup tName testMap of Just t -> return (t, Nothing) _ -> die $ "no such test: " ++ tName - Just f -> do - notice verbosity $ "Replaying " ++ f ++ " ..." - pkgLog <- readFile f >>= (return . read) - let testSuiteNames = map name $ testSuites pkgLog - replayTests = - filter (\t -> PD.testName t `elem` testSuiteNames) pkgTests - getLog t = Just $ head $ filter (\l -> PD.testName t == name l) - $ testSuites pkgLog - return $ zip replayTests $ map getLog replayTests createDirectoryIfMissing True testLogDir - -- Remove existing human log files, unless they are to be appended. - -- The machine log file is always overwritten. - existingLogFiles <- liftM (filter $ (== ".log") . takeExtension) - $ getDirectoryContents testLogDir - unless append $ mapM_ (removeFile . (testLogDir )) existingLogFiles - let totalSuites = length testsToRun notice verbosity $ "Running " ++ show totalSuites ++ " test suites..." suites <- mapM doTest testsToRun @@ -434,7 +416,7 @@ runTests tests = do testLogIn <- liftM read getContents let go :: TestSuite.Test -> IO Case go t = do - o <- getReplayOptions t testLogIn + o <- getTestOptions t testLogIn r <- TestSuite.runM t o let ret = Case { caseName = TestSuite.name t