136 lines
5.4 KiB
Haskell
136 lines
5.4 KiB
Haskell
-----------------------------------------------------------------------------
|
|
-- |
|
|
-- Module : Distribution.Simple.Test
|
|
-- Copyright : Thomas Tuegel 2010
|
|
-- License : BSD3
|
|
--
|
|
-- Maintainer : cabal-devel@haskell.org
|
|
-- Portability : portable
|
|
--
|
|
-- This is the entry point into testing a built package. It performs the
|
|
-- \"@.\/setup test@\" action. It runs test suites designated in the package
|
|
-- description and reports on the results.
|
|
|
|
module Distribution.Simple.Test
|
|
( test
|
|
) where
|
|
|
|
import qualified Distribution.PackageDescription as PD
|
|
( PackageDescription(..), BuildInfo(buildable)
|
|
, TestSuite(..)
|
|
, TestSuiteInterface(..), testType, hasTests )
|
|
import Distribution.Simple.Compiler ( compilerInfo )
|
|
import Distribution.Simple.Hpc ( markupPackage )
|
|
import Distribution.Simple.InstallDirs
|
|
( fromPathTemplate, initialPathTemplateEnv, substPathTemplate
|
|
, PathTemplate )
|
|
import qualified Distribution.Simple.LocalBuildInfo as LBI
|
|
( LocalBuildInfo(..) )
|
|
import Distribution.Simple.Setup ( TestFlags(..), fromFlag, configCoverage )
|
|
import Distribution.Simple.UserHooks ( Args )
|
|
import qualified Distribution.Simple.Test.ExeV10 as ExeV10
|
|
import qualified Distribution.Simple.Test.LibV09 as LibV09
|
|
import Distribution.Simple.Test.Log
|
|
import Distribution.Simple.Utils ( die, notice )
|
|
import Distribution.TestSuite ( Result(..) )
|
|
import Distribution.Text
|
|
|
|
import Control.Monad ( when, unless, filterM )
|
|
import System.Directory
|
|
( createDirectoryIfMissing, doesFileExist, getDirectoryContents
|
|
, removeFile )
|
|
import System.Exit ( ExitCode(..), exitFailure, exitWith )
|
|
import System.FilePath ( (</>) )
|
|
|
|
-- |Perform the \"@.\/setup test@\" action.
|
|
test :: Args -- ^positional command-line arguments
|
|
-> PD.PackageDescription -- ^information from the .cabal file
|
|
-> LBI.LocalBuildInfo -- ^information from the configure step
|
|
-> TestFlags -- ^flags sent to test
|
|
-> IO ()
|
|
test args pkg_descr lbi flags = do
|
|
let verbosity = fromFlag $ testVerbosity flags
|
|
machineTemplate = fromFlag $ testMachineLog flags
|
|
distPref = fromFlag $ testDistPref flags
|
|
testLogDir = distPref </> "test"
|
|
testNames = args
|
|
pkgTests = PD.testSuites pkg_descr
|
|
enabledTests = [ t | t <- pkgTests
|
|
, PD.testEnabled t
|
|
, PD.buildable (PD.testBuildInfo t) ]
|
|
|
|
doTest :: (PD.TestSuite, Maybe TestSuiteLog) -> IO TestSuiteLog
|
|
doTest (suite, _) =
|
|
case PD.testInterface suite of
|
|
PD.TestSuiteExeV10 _ _ ->
|
|
ExeV10.runTest pkg_descr lbi flags suite
|
|
|
|
PD.TestSuiteLibV09 _ _ ->
|
|
LibV09.runTest pkg_descr lbi flags suite
|
|
|
|
_ -> return TestSuiteLog
|
|
{ testSuiteName = PD.testName suite
|
|
, testLogs = TestLog
|
|
{ testName = PD.testName suite
|
|
, testOptionsReturned = []
|
|
, testResult =
|
|
Error $ "No support for running test suite type: "
|
|
++ show (disp $ PD.testType suite)
|
|
}
|
|
, logFile = ""
|
|
}
|
|
|
|
when (not $ PD.hasTests pkg_descr) $ do
|
|
notice verbosity "Package has no test suites."
|
|
exitWith ExitSuccess
|
|
|
|
when (PD.hasTests pkg_descr && null enabledTests) $
|
|
die $ "No test suites enabled. Did you remember to configure with "
|
|
++ "\'--enable-tests\'?"
|
|
|
|
testsToRun <- case testNames of
|
|
[] -> return $ zip enabledTests $ repeat Nothing
|
|
names -> flip mapM names $ \tName ->
|
|
let testMap = zip enabledNames enabledTests
|
|
enabledNames = map PD.testName enabledTests
|
|
allNames = map PD.testName pkgTests
|
|
in case lookup tName testMap of
|
|
Just t -> return (t, Nothing)
|
|
_ | tName `elem` allNames ->
|
|
die $ "Package configured with test suite "
|
|
++ tName ++ " disabled."
|
|
| otherwise -> die $ "no such test: " ++ tName
|
|
|
|
createDirectoryIfMissing True testLogDir
|
|
|
|
-- Delete ordinary files from test log directory.
|
|
getDirectoryContents testLogDir
|
|
>>= filterM doesFileExist . map (testLogDir </>)
|
|
>>= mapM_ removeFile
|
|
|
|
let totalSuites = length testsToRun
|
|
notice verbosity $ "Running " ++ show totalSuites ++ " test suites..."
|
|
suites <- mapM doTest testsToRun
|
|
let packageLog = (localPackageLog pkg_descr lbi) { testSuites = suites }
|
|
packageLogFile = (</>) testLogDir
|
|
$ packageLogPath machineTemplate pkg_descr lbi
|
|
allOk <- summarizePackage verbosity packageLog
|
|
writeFile packageLogFile $ show packageLog
|
|
|
|
let isCoverageEnabled = fromFlag $ configCoverage $ LBI.configFlags lbi
|
|
when isCoverageEnabled $
|
|
markupPackage verbosity lbi distPref (display $ PD.package pkg_descr) $
|
|
map fst testsToRun
|
|
|
|
unless allOk exitFailure
|
|
|
|
packageLogPath :: PathTemplate
|
|
-> PD.PackageDescription
|
|
-> LBI.LocalBuildInfo
|
|
-> FilePath
|
|
packageLogPath template pkg_descr lbi =
|
|
fromPathTemplate $ substPathTemplate env template
|
|
where
|
|
env = initialPathTemplateEnv
|
|
(PD.package pkg_descr) (LBI.pkgKey lbi)
|
|
(compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi)
|