module Distribution.Simple.Test.ExeV10
( runTest
) where
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Types.UnqualComponentName
import Distribution.Compat.CreatePipe
import Distribution.Compat.Environment
import qualified Distribution.PackageDescription as PD
import Distribution.Simple.Build.PathsModule
import Distribution.Simple.BuildPaths
import Distribution.Simple.Compiler
import Distribution.Simple.Hpc
import Distribution.Simple.InstallDirs
import qualified Distribution.Simple.LocalBuildInfo as LBI
import qualified Distribution.Types.LocalBuildInfo as LBI
import Distribution.Simple.Setup
import Distribution.Simple.Test.Log
import Distribution.Simple.Utils
import Distribution.System
import Distribution.TestSuite
import Distribution.Pretty
import Distribution.Verbosity
import System.Directory
( createDirectoryIfMissing, doesDirectoryExist, doesFileExist
, getCurrentDirectory, removeDirectoryRecursive )
import System.FilePath ( (</>), (<.>) )
import System.IO ( stdout, stderr )
import qualified Data.ByteString.Lazy as LBS
runTest :: PD.PackageDescription
-> LBI.LocalBuildInfo
-> LBI.ComponentLocalBuildInfo
-> TestFlags
-> PD.TestSuite
-> IO TestSuiteLog
runTest pkg_descr lbi clbi flags suite = do
let isCoverageEnabled = LBI.testCoverage lbi
way = guessWay lbi
tixDir_ = tixDir distPref way testName'
pwd <- getCurrentDirectory
existingEnv <- getEnvironment
let cmd = LBI.buildDir lbi </> testName'
</> testName' <.> exeExtension (LBI.hostPlatform lbi)
exists <- doesFileExist cmd
unless exists $ die' verbosity $ "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 $ testName'
let opts = map (testOption pkg_descr lbi suite)
(testOptions flags)
dataDirPath = pwd </> PD.dataDir pkg_descr
tixFile = pwd </> tixFilePath distPref way (testName')
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
paths <- LBI.depLibraryPaths True False lbi clbi
return (addLibraryPath os paths shellEnv)
else return shellEnv
(wOut, wErr, getLogText) <- case details of
Direct -> return (stdout, stderr, return LBS.empty)
_ -> do
(rOut, wOut) <- createPipe
return $ (,,) wOut wOut $ do
logText <- LBS.hGetContents rOut
when (details == Streaming) $ LBS.putStr logText
evaluate (force logText)
(exit, logText) <- case testWrapper flags of
Flag path -> rawSystemIOWithEnvAndAction
verbosity path (cmd:opts) Nothing (Just shellEnv')
getLogText
Nothing (Just wOut) (Just wErr)
NoFlag -> rawSystemIOWithEnvAndAction
verbosity cmd opts Nothing (Just shellEnv')
getLogText
Nothing (Just wOut) (Just wErr)
let suiteLog = buildLog exit
appendFile (logFile suiteLog) $ summarizeSuiteStart $ testName'
LBS.appendFile (logFile suiteLog) logText
appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog
let whenPrinting = when $
( details == Always ||
details == Failures && not (suitePassed $ testLogs suiteLog))
&& verbosity >= normal
whenPrinting $ do
LBS.putStr logText
putChar '\n'
notice verbosity $ summarizeSuiteFinish suiteLog
when isCoverageEnabled $
markupTest verbosity lbi distPref (prettyShow $ PD.package pkg_descr) suite
return suiteLog
where
testName' = unUnqualComponentName $ PD.testName suite
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
l = TestLog
{ testName = testName'
, testOptionsReturned = []
, testResult = r
}
in TestSuiteLog
{ testSuiteName = PD.testName suite
, testLogs = l
, logFile =
testLogDir
</> testSuiteLogPath (fromFlag $ testHumanLog flags)
pkg_descr lbi testName' 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.localUnitId lbi)
(compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++
[(TestSuiteNameVar, toPathTemplate $ unUnqualComponentName $ PD.testName suite)]