{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
module Distribution.Simple.Test
( test
) where
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Types.UnqualComponentName
import qualified Distribution.PackageDescription as PD
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.UserHooks
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
import Distribution.TestSuite
import Distribution.Pretty
import System.Directory
( createDirectoryIfMissing, doesFileExist, getDirectoryContents
, removeFile )
import System.FilePath ( (</>) )
test :: Args
-> PD.PackageDescription
-> LBI.LocalBuildInfo
-> TestFlags
-> IO ()
test :: Args -> PackageDescription -> LocalBuildInfo -> TestFlags -> IO ()
test Args
args PackageDescription
pkg_descr LocalBuildInfo
lbi TestFlags
flags = do
let verbosity :: Verbosity
verbosity = forall a. WithCallStack (Flag a -> a)
fromFlag forall a b. (a -> b) -> a -> b
$ TestFlags -> Flag Verbosity
testVerbosity TestFlags
flags
machineTemplate :: PathTemplate
machineTemplate = forall a. WithCallStack (Flag a -> a)
fromFlag forall a b. (a -> b) -> a -> b
$ TestFlags -> Flag PathTemplate
testMachineLog TestFlags
flags
distPref :: FilePath
distPref = forall a. WithCallStack (Flag a -> a)
fromFlag forall a b. (a -> b) -> a -> b
$ TestFlags -> Flag FilePath
testDistPref TestFlags
flags
testLogDir :: FilePath
testLogDir = FilePath
distPref FilePath -> FilePath -> FilePath
</> FilePath
"test"
testNames :: Args
testNames = Args
args
pkgTests :: [TestSuite]
pkgTests = PackageDescription -> [TestSuite]
PD.testSuites PackageDescription
pkg_descr
enabledTests :: [(TestSuite, ComponentLocalBuildInfo)]
enabledTests = PackageDescription
-> LocalBuildInfo -> [(TestSuite, ComponentLocalBuildInfo)]
LBI.enabledTestLBIs PackageDescription
pkg_descr LocalBuildInfo
lbi
doTest :: ((PD.TestSuite, LBI.ComponentLocalBuildInfo),
Maybe TestSuiteLog) -> IO TestSuiteLog
doTest :: ((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)
-> IO TestSuiteLog
doTest ((TestSuite
suite, ComponentLocalBuildInfo
clbi), Maybe TestSuiteLog
_) =
case TestSuite -> TestSuiteInterface
PD.testInterface TestSuite
suite of
PD.TestSuiteExeV10 Version
_ FilePath
_ ->
PackageDescription
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> TestFlags
-> TestSuite
-> IO TestSuiteLog
ExeV10.runTest PackageDescription
pkg_descr LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi TestFlags
flags TestSuite
suite
PD.TestSuiteLibV09 Version
_ ModuleName
_ ->
PackageDescription
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> TestFlags
-> TestSuite
-> IO TestSuiteLog
LibV09.runTest PackageDescription
pkg_descr LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi TestFlags
flags TestSuite
suite
TestSuiteInterface
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return TestSuiteLog
{ testSuiteName :: UnqualComponentName
testSuiteName = TestSuite -> UnqualComponentName
PD.testName TestSuite
suite
, testLogs :: TestLogs
testLogs = TestLog
{ testName :: FilePath
testName = UnqualComponentName -> FilePath
unUnqualComponentName forall a b. (a -> b) -> a -> b
$ TestSuite -> UnqualComponentName
PD.testName TestSuite
suite
, testOptionsReturned :: Options
testOptionsReturned = []
, testResult :: Result
testResult =
FilePath -> Result
Error forall a b. (a -> b) -> a -> b
$ FilePath
"No support for running test suite type: "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show (forall a. Pretty a => a -> Doc
pretty forall a b. (a -> b) -> a -> b
$ TestSuite -> TestType
PD.testType TestSuite
suite)
}
, logFile :: FilePath
logFile = FilePath
""
}
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PackageDescription -> Bool
PD.hasTests PackageDescription
pkg_descr) forall a b. (a -> b) -> a -> b
$ do
Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity FilePath
"Package has no test suites."
forall a. IO a
exitSuccess
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PackageDescription -> Bool
PD.hasTests PackageDescription
pkg_descr Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(TestSuite, ComponentLocalBuildInfo)]
enabledTests) forall a b. (a -> b) -> a -> b
$
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
FilePath
"No test suites enabled. Did you remember to configure with "
forall a. [a] -> [a] -> [a]
++ FilePath
"\'--enable-tests\'?"
[((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)]
testsToRun <- case Args
testNames of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [(TestSuite, ComponentLocalBuildInfo)]
enabledTests forall a b. (a -> b) -> a -> b
$ forall a. a -> [a]
repeat forall a. Maybe a
Nothing
Args
names -> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Args
names forall a b. (a -> b) -> a -> b
$ \FilePath
tName ->
let testMap :: [(UnqualComponentName, (TestSuite, ComponentLocalBuildInfo))]
testMap = forall a b. [a] -> [b] -> [(a, b)]
zip [UnqualComponentName]
enabledNames [(TestSuite, ComponentLocalBuildInfo)]
enabledTests
enabledNames :: [UnqualComponentName]
enabledNames = forall a b. (a -> b) -> [a] -> [b]
map (TestSuite -> UnqualComponentName
PD.testName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(TestSuite, ComponentLocalBuildInfo)]
enabledTests
allNames :: [UnqualComponentName]
allNames = forall a b. (a -> b) -> [a] -> [b]
map TestSuite -> UnqualComponentName
PD.testName [TestSuite]
pkgTests
tCompName :: UnqualComponentName
tCompName = FilePath -> UnqualComponentName
mkUnqualComponentName FilePath
tName
in case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup UnqualComponentName
tCompName [(UnqualComponentName, (TestSuite, ComponentLocalBuildInfo))]
testMap of
Just (TestSuite, ComponentLocalBuildInfo)
t -> forall (m :: * -> *) a. Monad m => a -> m a
return ((TestSuite, ComponentLocalBuildInfo)
t, forall a. Maybe a
Nothing)
Maybe (TestSuite, ComponentLocalBuildInfo)
_ | UnqualComponentName
tCompName forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [UnqualComponentName]
allNames ->
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ FilePath
"Package configured with test suite "
forall a. [a] -> [a] -> [a]
++ FilePath
tName forall a. [a] -> [a] -> [a]
++ FilePath
" disabled."
| Bool
otherwise -> forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ FilePath
"no such test: " forall a. [a] -> [a] -> [a]
++ FilePath
tName
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
testLogDir
FilePath -> IO Args
getDirectoryContents FilePath
testLogDir
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM FilePath -> IO Bool
doesFileExist forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (FilePath
testLogDir FilePath -> FilePath -> FilePath
</>)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ FilePath -> IO ()
removeFile
let totalSuites :: Int
totalSuites = forall (t :: * -> *) a. Foldable t => t a -> Int
length [((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)]
testsToRun
Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ FilePath
"Running " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show Int
totalSuites forall a. [a] -> [a] -> [a]
++ FilePath
" test suites..."
[TestSuiteLog]
suites <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)
-> IO TestSuiteLog
doTest [((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)]
testsToRun
let packageLog :: PackageLog
packageLog = (PackageDescription -> LocalBuildInfo -> PackageLog
localPackageLog PackageDescription
pkg_descr LocalBuildInfo
lbi) { testSuites :: [TestSuiteLog]
testSuites = [TestSuiteLog]
suites }
packageLogFile :: FilePath
packageLogFile = FilePath -> FilePath -> FilePath
(</>) FilePath
testLogDir
forall a b. (a -> b) -> a -> b
$ PathTemplate -> PackageDescription -> LocalBuildInfo -> FilePath
packageLogPath PathTemplate
machineTemplate PackageDescription
pkg_descr LocalBuildInfo
lbi
Bool
allOk <- Verbosity -> PackageLog -> IO Bool
summarizePackage Verbosity
verbosity PackageLog
packageLog
FilePath -> FilePath -> IO ()
writeFile FilePath
packageLogFile forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> FilePath
show PackageLog
packageLog
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LocalBuildInfo -> Bool
LBI.testCoverage LocalBuildInfo
lbi) forall a b. (a -> b) -> a -> b
$
Verbosity
-> LocalBuildInfo
-> FilePath
-> PackageDescription
-> [TestSuite]
-> IO ()
markupPackage Verbosity
verbosity LocalBuildInfo
lbi FilePath
distPref PackageDescription
pkg_descr forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)]
testsToRun
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
allOk forall a. IO a
exitFailure
packageLogPath :: PathTemplate
-> PD.PackageDescription
-> LBI.LocalBuildInfo
-> FilePath
packageLogPath :: PathTemplate -> PackageDescription -> LocalBuildInfo -> FilePath
packageLogPath PathTemplate
template PackageDescription
pkg_descr LocalBuildInfo
lbi =
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)