{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns #-}
module Distribution.Simple.Test
( test
) where
import Distribution.Compat.Prelude
import Prelude ()
import qualified Distribution.PackageDescription as PD
import Distribution.Pretty
import Distribution.Simple.Compiler
import Distribution.Simple.Flag (fromFlag)
import Distribution.Simple.Hpc
import Distribution.Simple.InstallDirs
import qualified Distribution.Simple.LocalBuildInfo as LBI
import Distribution.Simple.Setup.Test
import qualified Distribution.Simple.Test.ExeV10 as ExeV10
import qualified Distribution.Simple.Test.LibV09 as LibV09
import Distribution.Simple.Test.Log
import Distribution.Simple.UserHooks
import Distribution.Simple.Utils
import Distribution.TestSuite
import qualified Distribution.Types.LocalBuildInfo as LBI
import Distribution.Types.UnqualComponentName
import Distribution.Simple.Configure (getInstalledPackagesById)
import Distribution.Simple.Errors
import Distribution.Simple.Register
import Distribution.Simple.Setup (fromFlagOrDefault)
import Distribution.Simple.Setup.Common (extraCompilationArtifacts)
import Distribution.Simple.Setup.Config
import Distribution.Types.ExposedModule
import Distribution.Types.InstalledPackageInfo (InstalledPackageInfo (libraryDirs), exposedModules)
import Distribution.Types.LocalBuildInfo (LocalBuildInfo (..))
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
lbi0 TestFlags
flags = do
let verbosity :: Verbosity
verbosity = Flag Verbosity -> Verbosity
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag Verbosity -> Verbosity) -> Flag Verbosity -> Verbosity
forall a b. (a -> b) -> a -> b
$ TestFlags -> Flag Verbosity
testVerbosity TestFlags
flags
machineTemplate :: PathTemplate
machineTemplate = Flag PathTemplate -> PathTemplate
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag PathTemplate -> PathTemplate)
-> Flag PathTemplate -> PathTemplate
forall a b. (a -> b) -> a -> b
$ TestFlags -> Flag PathTemplate
testMachineLog TestFlags
flags
distPref :: FilePath
distPref = Flag FilePath -> FilePath
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag FilePath -> FilePath) -> Flag FilePath -> FilePath
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
internalPkgDB :: FilePath
internalPkgDB = LocalBuildInfo -> FilePath -> FilePath
internalPackageDBPath LocalBuildInfo
lbi FilePath
distPref
lbi :: LocalBuildInfo
lbi = LocalBuildInfo
lbi0{withPackageDB = withPackageDB lbi0 ++ [SpecificPackageDB internalPkgDB]}
doTest
:: HPCMarkupInfo
-> ( (PD.TestSuite, LBI.ComponentLocalBuildInfo)
, Maybe TestSuiteLog
)
-> IO TestSuiteLog
doTest :: HPCMarkupInfo
-> ((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)
-> IO TestSuiteLog
doTest HPCMarkupInfo
hpcMarkupInfo ((TestSuite
suite, ComponentLocalBuildInfo
clbi), Maybe TestSuiteLog
_) =
case TestSuite -> TestSuiteInterface
PD.testInterface TestSuite
suite of
PD.TestSuiteExeV10 Version
_ FilePath
_ ->
PackageDescription
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> HPCMarkupInfo
-> TestFlags
-> TestSuite
-> IO TestSuiteLog
ExeV10.runTest PackageDescription
pkg_descr LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi HPCMarkupInfo
hpcMarkupInfo TestFlags
flags TestSuite
suite
PD.TestSuiteLibV09 Version
_ ModuleName
_ ->
PackageDescription
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> HPCMarkupInfo
-> TestFlags
-> TestSuite
-> IO TestSuiteLog
LibV09.runTest PackageDescription
pkg_descr LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi HPCMarkupInfo
hpcMarkupInfo TestFlags
flags TestSuite
suite
TestSuiteInterface
_ ->
TestSuiteLog -> IO TestSuiteLog
forall a. a -> IO a
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 (UnqualComponentName -> FilePath)
-> UnqualComponentName -> FilePath
forall a b. (a -> b) -> a -> b
$ TestSuite -> UnqualComponentName
PD.testName TestSuite
suite
, testOptionsReturned :: Options
testOptionsReturned = []
, testResult :: Result
testResult =
FilePath -> Result
Error (FilePath -> Result) -> FilePath -> Result
forall a b. (a -> b) -> a -> b
$
FilePath
"No support for running test suite type: "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Doc -> FilePath
forall a. Show a => a -> FilePath
show (TestType -> Doc
forall a. Pretty a => a -> Doc
pretty (TestType -> Doc) -> TestType -> Doc
forall a b. (a -> b) -> a -> b
$ TestSuite -> TestType
PD.testType TestSuite
suite)
}
, logFile :: FilePath
logFile = FilePath
""
}
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PackageDescription -> Bool
PD.hasTests PackageDescription
pkg_descr) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity FilePath
"Package has no test suites."
IO ()
forall a. IO a
exitSuccess
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PackageDescription -> Bool
PD.hasTests PackageDescription
pkg_descr Bool -> Bool -> Bool
&& [(TestSuite, ComponentLocalBuildInfo)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(TestSuite, ComponentLocalBuildInfo)]
enabledTests) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Verbosity -> CabalException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalException
NoTestSuitesEnabled
testsToRun <- case Args
testNames of
[] -> [((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)]
-> IO [((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)]
-> IO [((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)])
-> [((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)]
-> IO [((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)]
forall a b. (a -> b) -> a -> b
$ [(TestSuite, ComponentLocalBuildInfo)]
-> [Maybe TestSuiteLog]
-> [((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(TestSuite, ComponentLocalBuildInfo)]
enabledTests ([Maybe TestSuiteLog]
-> [((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)])
-> [Maybe TestSuiteLog]
-> [((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)]
forall a b. (a -> b) -> a -> b
$ Maybe TestSuiteLog -> [Maybe TestSuiteLog]
forall a. a -> [a]
repeat Maybe TestSuiteLog
forall a. Maybe a
Nothing
Args
names -> Args
-> (FilePath
-> IO ((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog))
-> IO [((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Args
names ((FilePath
-> IO ((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog))
-> IO [((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)])
-> (FilePath
-> IO ((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog))
-> IO [((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)]
forall a b. (a -> b) -> a -> b
$ \FilePath
tName ->
let testMap :: [(UnqualComponentName, (TestSuite, ComponentLocalBuildInfo))]
testMap = [UnqualComponentName]
-> [(TestSuite, ComponentLocalBuildInfo)]
-> [(UnqualComponentName, (TestSuite, ComponentLocalBuildInfo))]
forall a b. [a] -> [b] -> [(a, b)]
zip [UnqualComponentName]
enabledNames [(TestSuite, ComponentLocalBuildInfo)]
enabledTests
enabledNames :: [UnqualComponentName]
enabledNames = ((TestSuite, ComponentLocalBuildInfo) -> UnqualComponentName)
-> [(TestSuite, ComponentLocalBuildInfo)] -> [UnqualComponentName]
forall a b. (a -> b) -> [a] -> [b]
map (TestSuite -> UnqualComponentName
PD.testName (TestSuite -> UnqualComponentName)
-> ((TestSuite, ComponentLocalBuildInfo) -> TestSuite)
-> (TestSuite, ComponentLocalBuildInfo)
-> UnqualComponentName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TestSuite, ComponentLocalBuildInfo) -> TestSuite
forall a b. (a, b) -> a
fst) [(TestSuite, ComponentLocalBuildInfo)]
enabledTests
allNames :: [UnqualComponentName]
allNames = (TestSuite -> UnqualComponentName)
-> [TestSuite] -> [UnqualComponentName]
forall a b. (a -> b) -> [a] -> [b]
map TestSuite -> UnqualComponentName
PD.testName [TestSuite]
pkgTests
tCompName :: UnqualComponentName
tCompName = FilePath -> UnqualComponentName
mkUnqualComponentName FilePath
tName
in case UnqualComponentName
-> [(UnqualComponentName, (TestSuite, ComponentLocalBuildInfo))]
-> Maybe (TestSuite, ComponentLocalBuildInfo)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup UnqualComponentName
tCompName [(UnqualComponentName, (TestSuite, ComponentLocalBuildInfo))]
testMap of
Just (TestSuite, ComponentLocalBuildInfo)
t -> ((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)
-> IO ((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((TestSuite, ComponentLocalBuildInfo)
t, Maybe TestSuiteLog
forall a. Maybe a
Nothing)
Maybe (TestSuite, ComponentLocalBuildInfo)
_
| UnqualComponentName
tCompName UnqualComponentName -> [UnqualComponentName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [UnqualComponentName]
allNames ->
Verbosity
-> CabalException
-> IO ((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalException
-> IO ((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog))
-> CabalException
-> IO ((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)
forall a b. (a -> b) -> a -> b
$ FilePath -> CabalException
TestNameDisabled FilePath
tName
| Bool
otherwise -> Verbosity
-> CabalException
-> IO ((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalException
-> IO ((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog))
-> CabalException
-> IO ((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)
forall a b. (a -> b) -> a -> b
$ FilePath -> CabalException
NoSuchTest FilePath
tName
createDirectoryIfMissing True testLogDir
getDirectoryContents testLogDir
>>= filterM doesFileExist . map (testLogDir </>)
>>= traverse_ removeFile
let coverageFor =
[UnitId] -> [UnitId]
forall a. Eq a => [a] -> [a]
nub ([UnitId] -> [UnitId]) -> [UnitId] -> [UnitId]
forall a b. (a -> b) -> a -> b
$
[UnitId] -> Flag [UnitId] -> [UnitId]
forall a. a -> Flag a -> a
fromFlagOrDefault [] (ConfigFlags -> Flag [UnitId]
configCoverageFor (LocalBuildInfo -> ConfigFlags
configFlags LocalBuildInfo
lbi))
[UnitId] -> [UnitId] -> [UnitId]
forall a. Semigroup a => a -> a -> a
<> LocalBuildInfo -> [UnitId]
extraCoverageFor LocalBuildInfo
lbi
ipkginfos <- getInstalledPackagesById verbosity lbi MissingCoveredInstalledLibrary coverageFor
let ( concat -> pathsToLibsArtifacts
, concat -> libsModulesToInclude
) =
unzip $
map
( \InstalledPackageInfo
ip ->
( (FilePath -> FilePath) -> Args -> Args
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> FilePath -> FilePath
</> FilePath
extraCompilationArtifacts) (Args -> Args) -> Args -> Args
forall a b. (a -> b) -> a -> b
$ InstalledPackageInfo -> Args
libraryDirs InstalledPackageInfo
ip
, (ExposedModule -> ModuleName) -> [ExposedModule] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map ExposedModule -> ModuleName
exposedName ([ExposedModule] -> [ModuleName])
-> [ExposedModule] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ InstalledPackageInfo -> [ExposedModule]
exposedModules InstalledPackageInfo
ip
)
)
ipkginfos
hpcMarkupInfo = HPCMarkupInfo{Args
pathsToLibsArtifacts :: Args
pathsToLibsArtifacts :: Args
pathsToLibsArtifacts, [ModuleName]
libsModulesToInclude :: [ModuleName]
libsModulesToInclude :: [ModuleName]
libsModulesToInclude}
let totalSuites = [((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)]
testsToRun
notice verbosity $ "Running " ++ show totalSuites ++ " test suites..."
suites <- traverse (doTest hpcMarkupInfo) testsToRun
let packageLog = (PackageDescription -> LocalBuildInfo -> PackageLog
localPackageLog PackageDescription
pkg_descr LocalBuildInfo
lbi){testSuites = suites}
packageLogFile =
FilePath -> FilePath -> FilePath
(</>) FilePath
testLogDir (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$
PathTemplate -> PackageDescription -> LocalBuildInfo -> FilePath
packageLogPath PathTemplate
machineTemplate PackageDescription
pkg_descr LocalBuildInfo
lbi
allOk <- summarizePackage verbosity packageLog
writeFile packageLogFile $ show packageLog
when (LBI.testCoverage lbi) $
markupPackage verbosity hpcMarkupInfo lbi distPref pkg_descr $
map (fst . fst) testsToRun
unless allOk exitFailure
packageLogPath
:: PathTemplate
-> PD.PackageDescription
-> LBI.LocalBuildInfo
-> FilePath
packageLogPath :: PathTemplate -> PackageDescription -> LocalBuildInfo -> FilePath
packageLogPath PathTemplate
template PackageDescription
pkg_descr LocalBuildInfo
lbi =
PathTemplate -> FilePath
fromPathTemplate (PathTemplate -> FilePath) -> PathTemplate -> FilePath
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 (Compiler -> CompilerInfo) -> Compiler -> CompilerInfo
forall a b. (a -> b) -> a -> b
$ LocalBuildInfo -> Compiler
LBI.compiler LocalBuildInfo
lbi)
(LocalBuildInfo -> Platform
LBI.hostPlatform LocalBuildInfo
lbi)