Commit 8083ca4b authored by ttuegel's avatar ttuegel
Browse files

Refactor test runners

The test runners for exitcode-stdio and detailed tests will be separated
into their own modules. They cannot share a test runner because
'--show-details=streaming' does not make sense for detailed tests the
way they are implemented now. The detailed test runner needs to be
substantially rewritten anyway, so splitting up the test runners will
eventually accomodate that goal.
parent 3b4518db
......@@ -197,6 +197,9 @@ library
Distribution.Simple.Setup
Distribution.Simple.SrcDist
Distribution.Simple.Test
Distribution.Simple.Test.ExeV10
Distribution.Simple.Test.LibV09
Distribution.Simple.Test.Log
Distribution.Simple.UHC
Distribution.Simple.UserHooks
Distribution.Simple.Utils
......
......@@ -68,7 +68,7 @@ import Distribution.Simple.BuildPaths
( autogenModulesDir, autogenModuleName, cppHeaderName, exeExtension )
import Distribution.Simple.Register
( registerPackage, inplaceInstalledPackageInfo )
import Distribution.Simple.Test ( stubFilePath, stubName )
import Distribution.Simple.Test.LibV09 ( stubFilePath, stubName )
import Distribution.Simple.Utils
( createDirectoryIfMissingVerbose, rewriteFile
, die, info, debug, warn, setupMessage )
......
......@@ -58,7 +58,8 @@ import Distribution.Simple.Program
, rawSystemProgramConf, rawSystemProgram
, greencardProgram, cpphsProgram, hsc2hsProgram, c2hsProgram
, happyProgram, alexProgram, haddockProgram, ghcProgram, gccProgram )
import Distribution.Simple.Test ( writeSimpleTestStub, stubFilePath, stubName )
import Distribution.Simple.Test.LibV09
( writeSimpleTestStub, stubFilePath, stubName )
import Distribution.System
( OS(..), buildOS, Arch(..), Platform(..) )
import Distribution.Text
......
This diff is collapsed.
module Distribution.Simple.Test.ExeV10
( runTest
) where
import Distribution.Compat.CreatePipe ( createPipe )
import Distribution.Compat.Environment ( getEnvironment )
import qualified Distribution.PackageDescription as PD
import Distribution.Simple.Build.PathsModule ( pkgPathEnvVar )
import Distribution.Simple.BuildPaths ( exeExtension )
import Distribution.Simple.Compiler ( Compiler(..) )
import Distribution.Simple.Hpc ( markupTest, tixDir, tixFilePath )
import Distribution.Simple.InstallDirs
( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..)
, substPathTemplate , toPathTemplate, PathTemplate )
import qualified Distribution.Simple.LocalBuildInfo as LBI
import Distribution.Simple.Setup ( TestFlags(..), TestShowDetails(..), fromFlag )
import Distribution.Simple.Test.Log
import Distribution.Simple.Utils ( die, notice, rawSystemIOWithEnv )
import Distribution.TestSuite
import Distribution.Text
import Distribution.Verbosity ( normal )
import Control.Monad ( when, unless )
import System.Directory
( createDirectoryIfMissing, doesDirectoryExist, doesFileExist
, getCurrentDirectory, removeDirectoryRecursive )
import System.Exit ( ExitCode(..) )
import System.FilePath ( (</>), (<.>) )
import System.IO ( hGetContents )
runTest :: PD.PackageDescription
-> LBI.LocalBuildInfo
-> TestFlags
-> PD.TestSuite
-> IO TestSuiteLog
runTest pkg_descr lbi flags suite = do
pwd <- getCurrentDirectory
existingEnv <- getEnvironment
let cmd = LBI.buildDir lbi </> PD.testName suite
</> PD.testName suite <.> exeExtension
-- Check that the test executable exists.
exists <- doesFileExist cmd
unless exists $ die $ "Error: Could not find test program \"" ++ cmd
++ "\". Did you build the package first?"
-- Remove old .tix files if appropriate.
unless (fromFlag $ testKeepTix flags) $ do
let tDir = tixDir distPref $ PD.testName suite
exists' <- doesDirectoryExist tDir
when exists' $ removeDirectoryRecursive tDir
-- Create directory for HPC files.
createDirectoryIfMissing True $ tixDir distPref $ PD.testName suite
-- Write summary notices indicating start of test suite
notice verbosity $ summarizeSuiteStart $ PD.testName suite
-- Run test executable
(rLog, wLog) <- createPipe
exit <- do
let opts = map (testOption pkg_descr lbi suite)
(testOptions flags)
dataDirPath = pwd </> PD.dataDir pkg_descr
shellEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath)
: ("HPCTIXFILE", (</>) pwd
$ tixFilePath distPref $ PD.testName suite)
: existingEnv
rawSystemIOWithEnv verbosity cmd opts Nothing (Just shellEnv)
-- these handles are automatically closed
Nothing (Just wLog) (Just wLog)
-- Generate TestSuiteLog from executable exit code and a machine-
-- 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 details = fromFlag $ testShowDetails flags
whenPrinting = when $ (details > Never)
&& (not (suitePassed $ testLogs suiteLog) || details == Always)
&& verbosity >= normal
whenPrinting $ putStr $ unlines $ lines logText
-- Write summary notice to terminal indicating end of test suite
notice verbosity $ summarizeSuiteFinish suiteLog
markupTest verbosity lbi distPref
(display $ PD.package pkg_descr) suite
return suiteLog
where
distPref = fromFlag $ testDistPref flags
verbosity = fromFlag $ testVerbosity flags
testLogDir = distPref </> "test"
buildLog exit =
let r = case exit of
ExitSuccess -> Pass
ExitFailure c -> Fail $ "exit code: " ++ show c
n = PD.testName suite
l = TestLog
{ testName = n
, testOptionsReturned = []
, testResult = r
}
in TestSuiteLog
{ testSuiteName = n
, testLogs = l
, logFile =
testLogDir
</> testSuiteLogPath (fromFlag $ testHumanLog flags)
pkg_descr lbi n l
}
-- TODO: This is abusing the notion of a 'PathTemplate'. The result
-- isn't neccesarily a path.
testOption :: PD.PackageDescription
-> LBI.LocalBuildInfo
-> PD.TestSuite
-> PathTemplate
-> String
testOption pkg_descr lbi suite template =
fromPathTemplate $ substPathTemplate env template
where
env = initialPathTemplateEnv
(PD.package pkg_descr) (compilerId $ LBI.compiler lbi)
(LBI.hostPlatform lbi) ++
[(TestSuiteNameVar, toPathTemplate $ PD.testName suite)]
module Distribution.Simple.Test.LibV09
( runTest
-- Test stub
, simpleTestStub
, stubFilePath, stubMain, stubName, stubWriteLog
, writeSimpleTestStub
) where
import Distribution.Compat.CreatePipe ( createPipe )
import Distribution.Compat.Environment ( getEnvironment )
import Distribution.Compat.TempFile ( openTempFile )
import Distribution.ModuleName ( ModuleName )
import qualified Distribution.PackageDescription as PD
import Distribution.Simple.Build.PathsModule ( pkgPathEnvVar )
import Distribution.Simple.BuildPaths ( exeExtension )
import Distribution.Simple.Compiler ( Compiler(..) )
import Distribution.Simple.Hpc ( markupTest, tixDir, tixFilePath )
import Distribution.Simple.InstallDirs
( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..)
, substPathTemplate , toPathTemplate, PathTemplate )
import qualified Distribution.Simple.LocalBuildInfo as LBI
import Distribution.Simple.Setup ( TestFlags(..), TestShowDetails(..), fromFlag )
import Distribution.Simple.Test.Log
import Distribution.Simple.Utils ( die, notice, rawSystemIOWithEnv )
import Distribution.TestSuite
import Distribution.Text
import Distribution.Verbosity ( normal )
import Control.Exception ( bracket )
import Control.Monad ( when, unless )
import Data.Maybe ( mapMaybe )
import System.Directory
( createDirectoryIfMissing, doesDirectoryExist, doesFileExist
, getCurrentDirectory, removeDirectoryRecursive, removeFile
, setCurrentDirectory )
import System.Exit ( ExitCode(..), exitWith )
import System.FilePath ( (</>), (<.>) )
import System.IO ( hClose, hGetContents, hPutStr )
runTest :: PD.PackageDescription
-> LBI.LocalBuildInfo
-> TestFlags
-> PD.TestSuite
-> IO TestSuiteLog
runTest pkg_descr lbi flags suite = do
pwd <- getCurrentDirectory
existingEnv <- getEnvironment
let cmd = LBI.buildDir lbi </> stubName suite
</> stubName suite <.> exeExtension
-- Check that the test executable exists.
exists <- doesFileExist cmd
unless exists $ die $ "Error: Could not find test program \"" ++ cmd
++ "\". Did you build the package first?"
-- Remove old .tix files if appropriate.
unless (fromFlag $ testKeepTix flags) $ do
let tDir = tixDir distPref $ PD.testName suite
exists' <- doesDirectoryExist tDir
when exists' $ removeDirectoryRecursive tDir
-- Create directory for HPC files.
createDirectoryIfMissing True $ tixDir distPref $ PD.testName suite
-- Write summary notices indicating start of test suite
notice verbosity $ summarizeSuiteStart $ PD.testName suite
suiteLog <- bracket openCabalTemp deleteIfExists $ \tempLog -> do
(rIn, wIn) <- createPipe
(rOut, wOut) <- createPipe
-- Prepare standard input for test executable
--appendFile tempInput $ show (tempInput, PD.testName suite)
hPutStr wIn $ show (tempLog, PD.testName suite)
hClose wIn
-- Run test executable
_ <- do let opts = map (testOption pkg_descr lbi suite) $ testOptions flags
dataDirPath = pwd </> PD.dataDir pkg_descr
shellEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath)
: ("HPCTIXFILE", (</>) pwd
$ tixFilePath distPref $ PD.testName suite)
: existingEnv
rawSystemIOWithEnv verbosity cmd opts Nothing (Just shellEnv)
-- these handles are closed automatically
(Just rIn) (Just wOut) (Just wOut)
-- Generate final log file name
let finalLogName l = testLogDir
</> testSuiteLogPath
(fromFlag $ testHumanLog flags) pkg_descr lbi
(testSuiteName l) (testLogs l)
-- Generate TestSuiteLog from executable exit code and a machine-
-- readable test log
suiteLog <- fmap ((\l -> l { logFile = finalLogName l }) . read)
$ readFile tempLog
-- 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 rOut
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 details = fromFlag $ testShowDetails flags
whenPrinting = when $ (details > Never)
&& (not (suitePassed $ testLogs suiteLog) || details == Always)
&& verbosity >= normal
whenPrinting $ putStr $ unlines $ lines logText
return suiteLog
-- Write summary notice to terminal indicating end of test suite
notice verbosity $ summarizeSuiteFinish suiteLog
markupTest verbosity lbi distPref
(display $ PD.package pkg_descr) suite
return suiteLog
where
deleteIfExists file = do
exists <- doesFileExist file
when exists $ removeFile file
testLogDir = distPref </> "test"
openCabalTemp = do
(f, h) <- openTempFile testLogDir $ "cabal-test-" <.> "log"
hClose h >> return f
distPref = fromFlag $ testDistPref flags
verbosity = fromFlag $ testVerbosity flags
-- TODO: This is abusing the notion of a 'PathTemplate'. The result
-- isn't neccesarily a path.
testOption :: PD.PackageDescription
-> LBI.LocalBuildInfo
-> PD.TestSuite
-> PathTemplate
-> String
testOption pkg_descr lbi suite template =
fromPathTemplate $ substPathTemplate env template
where
env = initialPathTemplateEnv
(PD.package pkg_descr) (compilerId $ LBI.compiler lbi)
(LBI.hostPlatform lbi) ++
[(TestSuiteNameVar, toPathTemplate $ PD.testName suite)]
-- Test stub ----------
-- | The name of the stub executable associated with a library 'TestSuite'.
stubName :: PD.TestSuite -> FilePath
stubName t = PD.testName t ++ "Stub"
-- | The filename of the source file for the stub executable associated with a
-- library 'TestSuite'.
stubFilePath :: PD.TestSuite -> FilePath
stubFilePath t = stubName t <.> "hs"
-- | Write the source file for a library 'TestSuite' stub executable.
writeSimpleTestStub :: PD.TestSuite -- ^ library 'TestSuite' for which a stub
-- is being created
-> FilePath -- ^ path to directory where stub source
-- should be located
-> IO ()
writeSimpleTestStub t dir = do
createDirectoryIfMissing True dir
let filename = dir </> stubFilePath t
PD.TestSuiteLibV09 _ m = PD.testInterface t
writeFile filename $ simpleTestStub m
-- | Source code for library test suite stub executable
simpleTestStub :: ModuleName -> String
simpleTestStub m = unlines
[ "module Main ( main ) where"
, "import Distribution.Simple.Test.LibV09 ( stubMain )"
, "import " ++ show (disp m) ++ " ( tests )"
, "main :: IO ()"
, "main = stubMain tests"
]
-- | Main function for test stubs. Once, it was written directly into the stub,
-- but minimizing the amount of code actually in the stub maximizes the number
-- of detectable errors when Cabal is compiled.
stubMain :: IO [Test] -> IO ()
stubMain tests = do
(f, n) <- fmap read getContents
dir <- getCurrentDirectory
results <- tests >>= stubRunTests
setCurrentDirectory dir
stubWriteLog f n results
-- | The test runner used in library "TestSuite" stub executables. Runs a list
-- of 'Test's. An executable calling this function is meant to be invoked as
-- the child of a Cabal process during @.\/setup test@. A 'TestSuiteLog',
-- provided by Cabal, is read from the standard input; it supplies the name of
-- the test suite and the location of the machine-readable test suite log file.
-- Human-readable log information is written to the standard output for capture
-- by the calling Cabal process.
stubRunTests :: [Test] -> IO TestLogs
stubRunTests tests = do
logs <- mapM stubRunTests' tests
return $ GroupLogs "Default" logs
where
stubRunTests' (Test t) = do
l <- run t >>= finish
summarizeTest normal Always l
return l
where
finish (Finished result) =
return TestLog
{ testName = name t
, testOptionsReturned = defaultOptions t
, testResult = result
}
finish (Progress _ next) = next >>= finish
stubRunTests' g@(Group {}) = do
logs <- mapM stubRunTests' $ groupTests g
return $ GroupLogs (groupName g) logs
stubRunTests' (ExtraOptions _ t) = stubRunTests' t
maybeDefaultOption opt =
maybe Nothing (\d -> Just (optionName opt, d)) $ optionDefault opt
defaultOptions testInst = mapMaybe maybeDefaultOption $ options testInst
-- | From a test stub, write the 'TestSuiteLog' to temporary file for the calling
-- Cabal process to read.
stubWriteLog :: FilePath -> String -> TestLogs -> IO ()
stubWriteLog f n logs = do
let testLog = TestSuiteLog { testSuiteName = n, testLogs = logs, logFile = f }
writeFile (logFile testLog) $ show testLog
when (suiteError logs) $ exitWith $ ExitFailure 2
when (suiteFailed logs) $ exitWith $ ExitFailure 1
exitWith ExitSuccess
module Distribution.Simple.Test.Log
( PackageLog(..)
, TestLogs(..)
, TestSuiteLog(..)
, countTestResults
, localPackageLog
, summarizePackage
, summarizeSuiteFinish, summarizeSuiteStart
, summarizeTest
, suiteError, suiteFailed, suitePassed
, testSuiteLogPath
) where
import Distribution.Package ( PackageId )
import qualified Distribution.PackageDescription as PD
import Distribution.Simple.Compiler ( Compiler(..), CompilerId )
import Distribution.Simple.InstallDirs
( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..)
, substPathTemplate , toPathTemplate, PathTemplate )
import qualified Distribution.Simple.LocalBuildInfo as LBI
import Distribution.Simple.Setup ( TestShowDetails(..) )
import Distribution.Simple.Utils ( notice )
import Distribution.System ( Platform )
import Distribution.TestSuite ( Options, Result(..) )
import Distribution.Verbosity ( Verbosity )
import Control.Monad ( when )
import Data.Char ( toUpper )
-- | Logs all test results for a package, broken down first by test suite and
-- then by test case.
data PackageLog = PackageLog
{ package :: PackageId
, compiler :: CompilerId
, platform :: Platform
, testSuites :: [TestSuiteLog]
}
deriving (Read, Show, Eq)
-- | A 'PackageLog' with package and platform information specified.
localPackageLog :: PD.PackageDescription -> LBI.LocalBuildInfo -> PackageLog
localPackageLog pkg_descr lbi = PackageLog
{ package = PD.package pkg_descr
, compiler = compilerId $ LBI.compiler lbi
, platform = LBI.hostPlatform lbi
, testSuites = []
}
-- | Logs test suite results, itemized by test case.
data TestSuiteLog = TestSuiteLog
{ testSuiteName :: String
, testLogs :: TestLogs
, logFile :: FilePath -- path to human-readable log file
}
deriving (Read, Show, Eq)
data TestLogs
= TestLog
{ testName :: String
, testOptionsReturned :: Options
, testResult :: Result
}
| GroupLogs String [TestLogs]
deriving (Read, Show, Eq)
-- | Count the number of pass, fail, and error test results in a 'TestLogs'
-- tree.
countTestResults :: TestLogs
-> (Int, Int, Int) -- ^ Passes, fails, and errors,
-- respectively.
countTestResults = go (0, 0, 0)
where
go (p, f, e) (TestLog { testResult = r }) =
case r of
Pass -> (p + 1, f, e)
Fail _ -> (p, f + 1, e)
Error _ -> (p, f, e + 1)
go (p, f, e) (GroupLogs _ ts) = foldl go (p, f, e) ts
-- | From a 'TestSuiteLog', determine if the test suite passed.
suitePassed :: TestLogs -> Bool
suitePassed l =
case countTestResults l of
(_, 0, 0) -> True
_ -> False
-- | From a 'TestSuiteLog', determine if the test suite failed.
suiteFailed :: TestLogs -> Bool
suiteFailed l =
case countTestResults l of
(_, 0, _) -> False
_ -> True
-- | From a 'TestSuiteLog', determine if the test suite encountered errors.
suiteError :: TestLogs -> Bool
suiteError l =
case countTestResults l of
(_, _, 0) -> False
_ -> True
resultString :: TestLogs -> String
resultString l | suiteError l = "error"
| suiteFailed l = "fail"
| otherwise = "pass"
testSuiteLogPath :: PathTemplate
-> PD.PackageDescription
-> LBI.LocalBuildInfo
-> String -- ^ test suite name
-> TestLogs -- ^ test suite results
-> FilePath
testSuiteLogPath template pkg_descr lbi name result =
fromPathTemplate $ substPathTemplate env template
where
env = initialPathTemplateEnv
(PD.package pkg_descr) (compilerId $ LBI.compiler lbi)
(LBI.hostPlatform lbi)
++ [ (TestSuiteNameVar, toPathTemplate name)
, (TestSuiteResultVar, toPathTemplate $ resultString result)
]
-- | Print a summary to the console after all test suites have been run
-- indicating the number of successful test suites and cases. Returns 'True' if
-- all test suites passed and 'False' otherwise.
summarizePackage :: Verbosity -> PackageLog -> IO Bool
summarizePackage verbosity packageLog = do
let counts = map (countTestResults . testLogs) $ testSuites packageLog
(passed, failed, errors) = foldl1 addTriple counts
totalCases = passed + failed + errors
passedSuites = length
$ filter (suitePassed . testLogs)
$ testSuites packageLog
totalSuites = length $ testSuites packageLog
notice verbosity $ show passedSuites ++ " of " ++ show totalSuites
++ " test suites (" ++ show passed ++ " of "
++ show totalCases ++ " test cases) passed."
return $! passedSuites == totalSuites
where
addTriple (p1, f1, e1) (p2, f2, e2) = (p1 + p2, f1 + f2, e1 + e2)
-- | Print a summary of a single test case's result to the console, supressing
-- output for certain verbosity or test filter levels.
summarizeTest :: Verbosity -> TestShowDetails -> TestLogs -> IO ()
summarizeTest _ _ (GroupLogs {}) = return ()
summarizeTest verbosity details t =
when shouldPrint $ notice verbosity $ "Test case " ++ testName t
++ ": " ++ show (testResult t)
where shouldPrint = (details > Never) && (notPassed || details == Always)
notPassed = testResult t /= Pass
-- | Print a summary of the test suite's results on the console, suppressing
-- output for certain verbosity or test filter levels.
summarizeSuiteFinish :: TestSuiteLog -> String
summarizeSuiteFinish testLog = unlines
[ "Test suite " ++ testSuiteName testLog ++ ": " ++ resStr
, "Test suite logged to: " ++ logFile testLog
]
where resStr = map toUpper (resultString $ testLogs testLog)
summarizeSuiteStart :: String -> String
summarizeSuiteStart n = "Test suite " ++ n ++ ": RUNNING...\n"
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment