{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
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 :: PackageDescription
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> TestFlags
-> TestSuite
-> IO TestSuiteLog
runTest PackageDescription
pkg_descr LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi TestFlags
flags TestSuite
suite = do
let isCoverageEnabled :: Bool
isCoverageEnabled = LocalBuildInfo -> Bool
LBI.testCoverage LocalBuildInfo
lbi
way :: Way
way = LocalBuildInfo -> Way
guessWay LocalBuildInfo
lbi
tixDir_ :: FilePath
tixDir_ = FilePath -> Way -> FilePath -> FilePath
tixDir FilePath
distPref Way
way FilePath
testName'
FilePath
pwd <- IO FilePath
getCurrentDirectory
[(FilePath, FilePath)]
existingEnv <- IO [(FilePath, FilePath)]
getEnvironment
let cmd :: FilePath
cmd = LocalBuildInfo -> FilePath
LBI.buildDir LocalBuildInfo
lbi FilePath -> FilePath -> FilePath
</> FilePath
testName'
FilePath -> FilePath -> FilePath
</> FilePath
testName' FilePath -> FilePath -> FilePath
<.> Platform -> FilePath
exeExtension (LocalBuildInfo -> Platform
LBI.hostPlatform LocalBuildInfo
lbi)
Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
cmd
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists forall a b. (a -> b) -> a -> b
$ forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ FilePath
"Error: Could not find test program \"" forall a. [a] -> [a] -> [a]
++ FilePath
cmd
forall a. [a] -> [a] -> [a]
++ FilePath
"\". Did you build the package first?"
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. WithCallStack (Flag a -> a)
fromFlag forall a b. (a -> b) -> a -> b
$ TestFlags -> Flag Bool
testKeepTix TestFlags
flags) forall a b. (a -> b) -> a -> b
$ do
Bool
exists' <- FilePath -> IO Bool
doesDirectoryExist FilePath
tixDir_
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists' forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeDirectoryRecursive FilePath
tixDir_
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
tixDir_
Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
summarizeSuiteStart forall a b. (a -> b) -> a -> b
$ FilePath
testName'
let opts :: [FilePath]
opts = forall a b. (a -> b) -> [a] -> [b]
map (PackageDescription
-> LocalBuildInfo -> TestSuite -> PathTemplate -> FilePath
testOption PackageDescription
pkg_descr LocalBuildInfo
lbi TestSuite
suite)
(TestFlags -> [PathTemplate]
testOptions TestFlags
flags)
dataDirPath :: FilePath
dataDirPath = FilePath
pwd FilePath -> FilePath -> FilePath
</> PackageDescription -> FilePath
PD.dataDir PackageDescription
pkg_descr
tixFile :: FilePath
tixFile = FilePath
pwd FilePath -> FilePath -> FilePath
</> FilePath -> Way -> FilePath -> FilePath
tixFilePath FilePath
distPref Way
way (FilePath
testName')
pkgPathEnv :: [(FilePath, FilePath)]
pkgPathEnv = (PackageDescription -> FilePath -> FilePath
pkgPathEnvVar PackageDescription
pkg_descr FilePath
"datadir", FilePath
dataDirPath)
forall a. a -> [a] -> [a]
: [(FilePath, FilePath)]
existingEnv
shellEnv :: [(FilePath, FilePath)]
shellEnv = [(FilePath
"HPCTIXFILE", FilePath
tixFile) | Bool
isCoverageEnabled] forall a. [a] -> [a] -> [a]
++ [(FilePath, FilePath)]
pkgPathEnv
[(FilePath, FilePath)]
shellEnv' <- if LocalBuildInfo -> Bool
LBI.withDynExe LocalBuildInfo
lbi
then do let (Platform Arch
_ OS
os) = LocalBuildInfo -> Platform
LBI.hostPlatform LocalBuildInfo
lbi
[FilePath]
paths <- Bool
-> Bool
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> IO [FilePath]
LBI.depLibraryPaths Bool
True Bool
False LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi
forall (m :: * -> *) a. Monad m => a -> m a
return (OS
-> [FilePath] -> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
addLibraryPath OS
os [FilePath]
paths [(FilePath, FilePath)]
shellEnv)
else forall (m :: * -> *) a. Monad m => a -> m a
return [(FilePath, FilePath)]
shellEnv
(Handle
wOut, Handle
wErr, IO ByteString
getLogText) <- case TestShowDetails
details of
TestShowDetails
Direct -> forall (m :: * -> *) a. Monad m => a -> m a
return (Handle
stdout, Handle
stderr, forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
LBS.empty)
TestShowDetails
_ -> do
(Handle
rOut, Handle
wOut) <- IO (Handle, Handle)
createPipe
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (,,) Handle
wOut Handle
wOut forall a b. (a -> b) -> a -> b
$ do
ByteString
logText <- Handle -> IO ByteString
LBS.hGetContents Handle
rOut
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TestShowDetails
details forall a. Eq a => a -> a -> Bool
== TestShowDetails
Streaming) forall a b. (a -> b) -> a -> b
$ ByteString -> IO ()
LBS.putStr ByteString
logText
forall a. a -> IO a
evaluate (forall a. NFData a => a -> a
force ByteString
logText)
(ExitCode
exit, ByteString
logText) <- case TestFlags -> Flag FilePath
testWrapper TestFlags
flags of
Flag FilePath
path -> forall a.
Verbosity
-> FilePath
-> [FilePath]
-> Maybe FilePath
-> Maybe [(FilePath, FilePath)]
-> IO a
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO (ExitCode, a)
rawSystemIOWithEnvAndAction
Verbosity
verbosity FilePath
path (FilePath
cmdforall a. a -> [a] -> [a]
:[FilePath]
opts) forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just [(FilePath, FilePath)]
shellEnv')
IO ByteString
getLogText
forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just Handle
wOut) (forall a. a -> Maybe a
Just Handle
wErr)
Flag FilePath
NoFlag -> forall a.
Verbosity
-> FilePath
-> [FilePath]
-> Maybe FilePath
-> Maybe [(FilePath, FilePath)]
-> IO a
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO (ExitCode, a)
rawSystemIOWithEnvAndAction
Verbosity
verbosity FilePath
cmd [FilePath]
opts forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just [(FilePath, FilePath)]
shellEnv')
IO ByteString
getLogText
forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just Handle
wOut) (forall a. a -> Maybe a
Just Handle
wErr)
let suiteLog :: TestSuiteLog
suiteLog = ExitCode -> TestSuiteLog
buildLog ExitCode
exit
FilePath -> FilePath -> IO ()
appendFile (TestSuiteLog -> FilePath
logFile TestSuiteLog
suiteLog) forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
summarizeSuiteStart forall a b. (a -> b) -> a -> b
$ FilePath
testName'
FilePath -> ByteString -> IO ()
LBS.appendFile (TestSuiteLog -> FilePath
logFile TestSuiteLog
suiteLog) ByteString
logText
FilePath -> FilePath -> IO ()
appendFile (TestSuiteLog -> FilePath
logFile TestSuiteLog
suiteLog) forall a b. (a -> b) -> a -> b
$ TestSuiteLog -> FilePath
summarizeSuiteFinish TestSuiteLog
suiteLog
let whenPrinting :: IO () -> IO ()
whenPrinting = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when forall a b. (a -> b) -> a -> b
$
( TestShowDetails
details forall a. Eq a => a -> a -> Bool
== TestShowDetails
Always Bool -> Bool -> Bool
||
TestShowDetails
details forall a. Eq a => a -> a -> Bool
== TestShowDetails
Failures Bool -> Bool -> Bool
&& Bool -> Bool
not (TestLogs -> Bool
suitePassed forall a b. (a -> b) -> a -> b
$ TestSuiteLog -> TestLogs
testLogs TestSuiteLog
suiteLog))
Bool -> Bool -> Bool
&& Verbosity
verbosity forall a. Ord a => a -> a -> Bool
>= Verbosity
normal
IO () -> IO ()
whenPrinting forall a b. (a -> b) -> a -> b
$ do
ByteString -> IO ()
LBS.putStr ByteString
logText
Char -> IO ()
putChar Char
'\n'
Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ TestSuiteLog -> FilePath
summarizeSuiteFinish TestSuiteLog
suiteLog
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isCoverageEnabled forall a b. (a -> b) -> a -> b
$
case PackageDescription -> Maybe Library
PD.library PackageDescription
pkg_descr of
Maybe Library
Nothing ->
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ FilePath
"Error: test coverage is only supported for packages with a library component"
Just Library
library ->
Verbosity
-> LocalBuildInfo
-> FilePath
-> FilePath
-> TestSuite
-> Library
-> IO ()
markupTest Verbosity
verbosity LocalBuildInfo
lbi FilePath
distPref (forall a. Pretty a => a -> FilePath
prettyShow forall a b. (a -> b) -> a -> b
$ PackageDescription -> PackageIdentifier
PD.package PackageDescription
pkg_descr) TestSuite
suite Library
library
forall (m :: * -> *) a. Monad m => a -> m a
return TestSuiteLog
suiteLog
where
testName' :: FilePath
testName' = UnqualComponentName -> FilePath
unUnqualComponentName forall a b. (a -> b) -> a -> b
$ TestSuite -> UnqualComponentName
PD.testName TestSuite
suite
distPref :: FilePath
distPref = forall a. WithCallStack (Flag a -> a)
fromFlag forall a b. (a -> b) -> a -> b
$ TestFlags -> Flag FilePath
testDistPref TestFlags
flags
verbosity :: Verbosity
verbosity = forall a. WithCallStack (Flag a -> a)
fromFlag forall a b. (a -> b) -> a -> b
$ TestFlags -> Flag Verbosity
testVerbosity TestFlags
flags
details :: TestShowDetails
details = forall a. WithCallStack (Flag a -> a)
fromFlag forall a b. (a -> b) -> a -> b
$ TestFlags -> Flag TestShowDetails
testShowDetails TestFlags
flags
testLogDir :: FilePath
testLogDir = FilePath
distPref FilePath -> FilePath -> FilePath
</> FilePath
"test"
buildLog :: ExitCode -> TestSuiteLog
buildLog ExitCode
exit =
let r :: Result
r = case ExitCode
exit of
ExitCode
ExitSuccess -> Result
Pass
ExitFailure Int
c -> FilePath -> Result
Fail forall a b. (a -> b) -> a -> b
$ FilePath
"exit code: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show Int
c
l :: TestLogs
l = TestLog
{ testName :: FilePath
testName = FilePath
testName'
, testOptionsReturned :: [(FilePath, FilePath)]
testOptionsReturned = []
, testResult :: Result
testResult = Result
r
}
in TestSuiteLog
{ testSuiteName :: UnqualComponentName
testSuiteName = TestSuite -> UnqualComponentName
PD.testName TestSuite
suite
, testLogs :: TestLogs
testLogs = TestLogs
l
, logFile :: FilePath
logFile =
FilePath
testLogDir
FilePath -> FilePath -> FilePath
</> PathTemplate
-> PackageDescription
-> LocalBuildInfo
-> FilePath
-> TestLogs
-> FilePath
testSuiteLogPath (forall a. WithCallStack (Flag a -> a)
fromFlag forall a b. (a -> b) -> a -> b
$ TestFlags -> Flag PathTemplate
testHumanLog TestFlags
flags)
PackageDescription
pkg_descr LocalBuildInfo
lbi FilePath
testName' TestLogs
l
}
testOption :: PD.PackageDescription
-> LBI.LocalBuildInfo
-> PD.TestSuite
-> PathTemplate
-> String
testOption :: PackageDescription
-> LocalBuildInfo -> TestSuite -> PathTemplate -> FilePath
testOption PackageDescription
pkg_descr LocalBuildInfo
lbi TestSuite
suite PathTemplate
template =
PathTemplate -> FilePath
fromPathTemplate forall a b. (a -> b) -> a -> b
$ PathTemplateEnv -> PathTemplate -> PathTemplate
substPathTemplate PathTemplateEnv
env PathTemplate
template
where
env :: PathTemplateEnv
env = PackageIdentifier
-> UnitId -> CompilerInfo -> Platform -> PathTemplateEnv
initialPathTemplateEnv
(PackageDescription -> PackageIdentifier
PD.package PackageDescription
pkg_descr) (LocalBuildInfo -> UnitId
LBI.localUnitId LocalBuildInfo
lbi)
(Compiler -> CompilerInfo
compilerInfo forall a b. (a -> b) -> a -> b
$ LocalBuildInfo -> Compiler
LBI.compiler LocalBuildInfo
lbi) (LocalBuildInfo -> Platform
LBI.hostPlatform LocalBuildInfo
lbi) forall a. [a] -> [a] -> [a]
++
[(PathTemplateVariable
TestSuiteNameVar, FilePath -> PathTemplate
toPathTemplate forall a b. (a -> b) -> a -> b
$ UnqualComponentName -> FilePath
unUnqualComponentName forall a b. (a -> b) -> a -> b
$ TestSuite -> UnqualComponentName
PD.testName TestSuite
suite)]