module Distribution.Simple.Test.LibV09
( runTest
, simpleTestStub
, stubFilePath, stubMain, stubName, stubWriteLog
, writeSimpleTestStub
) where
import Distribution.Compat.CreatePipe
import Distribution.Compat.Environment
import Distribution.Compat.Internal.TempFile
import Distribution.ModuleName
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 Distribution.Simple.Setup
import Distribution.Simple.Test.Log
import Distribution.Simple.Utils
import Distribution.System
import Distribution.TestSuite
import Distribution.Text
import Distribution.Verbosity
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 )
import System.Process (StdStream(..), waitForProcess)
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
pwd <- getCurrentDirectory
existingEnv <- getEnvironment
let cmd = LBI.buildDir lbi </> stubName suite
</> stubName 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
let tDir = tixDir distPref way $ PD.testName suite
exists' <- doesDirectoryExist tDir
when exists' $ removeDirectoryRecursive tDir
createDirectoryIfMissing True $ tixDir distPref way $ PD.testName suite
notice verbosity $ summarizeSuiteStart $ PD.testName suite
suiteLog <- bracket openCabalTemp deleteIfExists $ \tempLog -> do
(rOut, wOut) <- createPipe
(Just wIn, _, _, process) <- do
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
createProcessWithEnv verbosity cmd opts Nothing (Just shellEnv')
CreatePipe (UseHandle wOut) (UseHandle wOut)
hPutStr wIn $ show (tempLog, PD.testName suite)
hClose wIn
logText <- hGetContents rOut
length logText `seq` return ()
exitcode <- waitForProcess process
unless (exitcode == ExitSuccess) $ do
debug verbosity $ cmd ++ " returned " ++ show exitcode
let finalLogName l = testLogDir
</> testSuiteLogPath
(fromFlag $ testHumanLog flags) pkg_descr lbi
(testSuiteName l) (testLogs l)
suiteLog <- fmap ((\l -> l { logFile = finalLogName l }) . read)
$ readFile tempLog
appendFile (logFile suiteLog) $ summarizeSuiteStart $ PD.testName suite
appendFile (logFile suiteLog) logText
appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog
let details = fromFlag $ testShowDetails flags
whenPrinting = when $ (details > Never)
&& (not (suitePassed $ testLogs suiteLog) || details == Always)
&& verbosity >= normal
whenPrinting $ putStr $ unlines $ lines logText
return suiteLog
notice verbosity $ summarizeSuiteFinish suiteLog
when isCoverageEnabled $
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
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 $ PD.testName suite)]
stubName :: PD.TestSuite -> FilePath
stubName t = PD.testName t ++ "Stub"
stubFilePath :: PD.TestSuite -> FilePath
stubFilePath t = stubName t <.> "hs"
writeSimpleTestStub :: PD.TestSuite
-> FilePath
-> IO ()
writeSimpleTestStub t dir = do
createDirectoryIfMissing True dir
let filename = dir </> stubFilePath t
PD.TestSuiteLibV09 _ m = PD.testInterface t
writeFile filename $ simpleTestStub m
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"
]
stubMain :: IO [Test] -> IO ()
stubMain tests = do
(f, n) <- fmap read getContents
dir <- getCurrentDirectory
results <- tests >>= stubRunTests
setCurrentDirectory dir
stubWriteLog f n results
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
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