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 ( compilerInfo )
import Distribution.Simple.Hpc ( guessWay, 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, configCoverage )
import Distribution.Simple.Test.Log
import Distribution.Simple.Utils
( die, notice, rawSystemIOWithEnv, addLibraryPath )
import Distribution.System ( Platform (..) )
import Distribution.TestSuite
import Distribution.Text
import Distribution.Verbosity ( normal )
import Control.Concurrent (forkIO)
import Control.Monad ( unless, void, when )
import System.Directory
( createDirectoryIfMissing, doesDirectoryExist, doesFileExist
, getCurrentDirectory, removeDirectoryRecursive )
import System.Exit ( ExitCode(..) )
import System.FilePath ( (</>), (<.>) )
import System.IO ( hGetContents, hPutStr, stdout )
runTest :: PD.PackageDescription
-> LBI.LocalBuildInfo
-> TestFlags
-> PD.TestSuite
-> IO TestSuiteLog
runTest pkg_descr lbi flags suite = do
let isCoverageEnabled = fromFlag $ configCoverage $ LBI.configFlags lbi
way = guessWay lbi
tixDir_ = tixDir distPref way $ PD.testName suite
pwd <- getCurrentDirectory
existingEnv <- getEnvironment
let cmd = LBI.buildDir lbi </> PD.testName suite
</> PD.testName suite <.> exeExtension
exists <- doesFileExist cmd
unless exists $ die $ "Error: Could not find test program \"" ++ cmd
++ "\". Did you build the package first?"
unless (fromFlag $ testKeepTix flags) $ do
exists' <- doesDirectoryExist tixDir_
when exists' $ removeDirectoryRecursive tixDir_
createDirectoryIfMissing True tixDir_
notice verbosity $ summarizeSuiteStart $ PD.testName suite
(rOut, wOut) <- createPipe
logText <- hGetContents rOut
void $ forkIO $ length logText `seq` return ()
when (details == Streaming) $ void $ forkIO $ hPutStr stdout logText
let opts = map (testOption pkg_descr lbi suite)
(testOptions flags)
dataDirPath = pwd </> PD.dataDir pkg_descr
tixFile = pwd </> tixFilePath distPref way (PD.testName suite)
pkgPathEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath)
: existingEnv
shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled] ++ pkgPathEnv
shellEnv' <- if LBI.withDynExe lbi
then do let (Platform _ os) = LBI.hostPlatform lbi
clbi = LBI.getComponentLocalBuildInfo lbi
(LBI.CTestName (PD.testName suite))
paths <- LBI.depLibraryPaths True False lbi clbi
return (addLibraryPath os paths shellEnv)
else return shellEnv
exit <- rawSystemIOWithEnv verbosity cmd opts Nothing (Just shellEnv')
Nothing (Just wOut) (Just wOut)
let suiteLog = buildLog exit
appendFile (logFile suiteLog) $ summarizeSuiteStart $ PD.testName suite
appendFile (logFile suiteLog) logText
appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog
let whenPrinting = when $
(details > Never)
&& (not (suitePassed $ testLogs suiteLog) || details == Always)
&& verbosity >= normal
&& details /= Streaming
whenPrinting $ putStr $ unlines $ lines logText
notice verbosity $ summarizeSuiteFinish suiteLog
when isCoverageEnabled $
markupTest verbosity lbi distPref (display $ PD.package pkg_descr) suite
return suiteLog
where
distPref = fromFlag $ testDistPref flags
verbosity = fromFlag $ testVerbosity flags
details = fromFlag $ testShowDetails 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
}
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) (LBI.pkgKey lbi)
(compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++
[(TestSuiteNameVar, toPathTemplate $ PD.testName suite)]