{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Simple.Test
-- Copyright   :  Thomas Tuegel 2010
-- License     :  BSD3
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- This is the entry point into testing a built package. It performs the
-- \"@.\/setup test@\" action. It runs test suites designated in the package
-- description and reports on the results.

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 ( (</>) )

-- |Perform the \"@.\/setup test@\" action.
test :: Args                    -- ^positional command-line arguments
     -> PD.PackageDescription   -- ^information from the .cabal file
     -> LBI.LocalBuildInfo      -- ^information from the configure step
     -> TestFlags               -- ^flags sent to test
     -> IO ()
test :: Args -> PackageDescription -> LocalBuildInfo -> TestFlags -> IO ()
test Args
args PackageDescription
pkg_descr LocalBuildInfo
lbi 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

        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
_ -> 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 -> FilePath -> IO ()
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
              FilePath
"No test suites enabled. Did you remember to configure with "
           FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\'--enable-tests\'?"

    [((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)]
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
-> FilePath
-> IO ((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath
 -> IO ((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog))
-> FilePath
-> IO ((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)
forall a b. (a -> b) -> a -> b
$ FilePath
"Package configured with test suite "
                                FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
tName FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" disabled."
                      | Bool
otherwise -> Verbosity
-> FilePath
-> IO ((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath
 -> IO ((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog))
-> FilePath
-> IO ((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)
forall a b. (a -> b) -> a -> b
$ FilePath
"no such test: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
tName

    Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
testLogDir

    -- Delete ordinary files from test log directory.
    FilePath -> IO Args
getDirectoryContents FilePath
testLogDir
        IO Args -> (Args -> IO Args) -> IO Args
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (FilePath -> IO Bool) -> Args -> IO Args
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM FilePath -> IO Bool
doesFileExist (Args -> IO Args) -> (Args -> Args) -> Args -> IO Args
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> FilePath) -> Args -> Args
forall a b. (a -> b) -> [a] -> [b]
map (FilePath
testLogDir FilePath -> FilePath -> FilePath
</>)
        IO Args -> (Args -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (FilePath -> IO ()) -> Args -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ FilePath -> IO ()
removeFile

    let totalSuites :: Int
totalSuites = [((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)]
testsToRun
    Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Running " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
totalSuites FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" test suites..."
    [TestSuiteLog]
suites <- (((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)
 -> IO TestSuiteLog)
-> [((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)]
-> IO [TestSuiteLog]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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
            (FilePath -> FilePath) -> FilePath -> FilePath
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 (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ PackageLog -> FilePath
forall a. Show a => a -> FilePath
show PackageLog
packageLog

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LocalBuildInfo -> Bool
LBI.testCoverage LocalBuildInfo
lbi) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Verbosity
-> LocalBuildInfo
-> FilePath
-> PackageDescription
-> [TestSuite]
-> IO ()
markupPackage Verbosity
verbosity LocalBuildInfo
lbi FilePath
distPref PackageDescription
pkg_descr ([TestSuite] -> IO ()) -> [TestSuite] -> IO ()
forall a b. (a -> b) -> a -> b
$
            (((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)
 -> TestSuite)
-> [((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)]
-> [TestSuite]
forall a b. (a -> b) -> [a] -> [b]
map ((TestSuite, ComponentLocalBuildInfo) -> TestSuite
forall a b. (a, b) -> a
fst ((TestSuite, ComponentLocalBuildInfo) -> TestSuite)
-> (((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)
    -> (TestSuite, ComponentLocalBuildInfo))
-> ((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)
-> TestSuite
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)
-> (TestSuite, ComponentLocalBuildInfo)
forall a b. (a, b) -> a
fst) [((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)]
testsToRun

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
allOk IO ()
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 (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)