{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns #-}

-----------------------------------------------------------------------------

-- |
-- 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 Distribution.Compat.Prelude
import Prelude ()

import qualified Distribution.PackageDescription as PD
import Distribution.Pretty
import Distribution.Simple.Build (addInternalBuildTools)
import Distribution.Simple.Compiler
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.Utils.Path

import Distribution.Simple.Configure (getInstalledPackagesById)
import Distribution.Simple.Errors
import Distribution.Simple.Register (internalPackageDBPath)
import Distribution.Simple.Setup.Common
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
  )

-- | 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
lbi0 TestFlags
flags = do
  let common :: CommonSetupFlags
common = TestFlags -> CommonSetupFlags
testCommonFlags TestFlags
flags
      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
$ CommonSetupFlags -> Flag Verbosity
setupVerbosity CommonSetupFlags
common
      distPref :: SymbolicPath Pkg ('Dir Dist)
distPref = Flag (SymbolicPath Pkg ('Dir Dist)) -> SymbolicPath Pkg ('Dir Dist)
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag (SymbolicPath Pkg ('Dir Dist))
 -> SymbolicPath Pkg ('Dir Dist))
-> Flag (SymbolicPath Pkg ('Dir Dist))
-> SymbolicPath Pkg ('Dir Dist)
forall a b. (a -> b) -> a -> b
$ CommonSetupFlags -> Flag (SymbolicPath Pkg ('Dir Dist))
setupDistPref CommonSetupFlags
common
      i :: SymbolicPathX allowAbsolute Pkg to -> FilePath
i = LocalBuildInfo -> SymbolicPathX allowAbsolute Pkg to -> FilePath
forall (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
LocalBuildInfo -> SymbolicPathX allowAbsolute Pkg to -> FilePath
LBI.interpretSymbolicPathLBI LocalBuildInfo
lbi -- See Note [Symbolic paths] in Distribution.Utils.Path
      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
      testLogDir :: SymbolicPathX 'AllowAbsolute Pkg c3
testLogDir = SymbolicPath Pkg ('Dir Dist)
distPref SymbolicPath Pkg ('Dir Dist)
-> RelativePath Dist c3 -> SymbolicPathX 'AllowAbsolute Pkg c3
forall p q r. PathLike p q r => p -> q -> r
</> FilePath -> RelativePath Dist c3
forall from (to :: FileOrDir).
HasCallStack =>
FilePath -> RelativePath from to
makeRelativePathEx 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
      -- We must add the internalPkgDB to the package database stack to lookup
      -- the path to HPC dirs of libraries local to this package
      internalPkgDb :: SymbolicPath Pkg ('Dir PkgDB)
internalPkgDb = LocalBuildInfo
-> SymbolicPath Pkg ('Dir Dist) -> SymbolicPath Pkg ('Dir PkgDB)
internalPackageDBPath LocalBuildInfo
lbi0 SymbolicPath Pkg ('Dir Dist)
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
_) = do
        let lbiForTest :: LocalBuildInfo
lbiForTest =
              LocalBuildInfo
lbi
                { withPrograms =
                    -- Include any build-tool-depends on build tools internal to the current package.
                    addInternalBuildTools
                      pkg_descr
                      lbi
                      (PD.testBuildInfo suite)
                      (withPrograms lbi)
                }
        case TestSuite -> TestSuiteInterface
PD.testInterface TestSuite
suite of
          PD.TestSuiteExeV10 Version
_ RelativePath Source 'File
_ ->
            PackageDescription
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> HPCMarkupInfo
-> TestFlags
-> TestSuite
-> IO TestSuiteLog
ExeV10.runTest PackageDescription
pkg_descr LocalBuildInfo
lbiForTest 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
lbiForTest 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

  [((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
-> 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

  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ SymbolicPathX 'AllowAbsolute Pkg Any -> FilePath
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> FilePath
i SymbolicPathX 'AllowAbsolute Pkg Any
forall {c3 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg c3
testLogDir

  -- Delete ordinary files from test log directory.
  FilePath -> IO Args
getDirectoryContents (SymbolicPathX 'AllowAbsolute Pkg Any -> FilePath
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> FilePath
i SymbolicPathX 'AllowAbsolute Pkg Any
forall {c3 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg c3
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 (SymbolicPathX 'AllowAbsolute Pkg Any -> FilePath
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> FilePath
i SymbolicPathX 'AllowAbsolute Pkg Any
forall {c3 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg c3
testLogDir FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</>)
    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

  -- We configured the unit-ids of libraries we should cover in our coverage
  -- report at configure time into the local build info. At build time, we built
  -- the hpc artifacts into the extraCompilationArtifacts directory, which, at
  -- install time, is copied into the ghc-pkg database files.
  -- Now, we get the path to the HPC artifacts and exposed modules of each
  -- library by querying the package database keyed by unit-id:
  let coverageFor :: [UnitId]
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
  [InstalledPackageInfo]
ipkginfos <- Verbosity
-> LocalBuildInfo
-> (UnitId -> CabalException)
-> [UnitId]
-> IO [InstalledPackageInfo]
forall exception.
(Exception (VerboseException exception), Show exception,
 Typeable exception) =>
Verbosity
-> LocalBuildInfo
-> (UnitId -> exception)
-> [UnitId]
-> IO [InstalledPackageInfo]
getInstalledPackagesById Verbosity
verbosity LocalBuildInfo
lbi UnitId -> CabalException
MissingCoveredInstalledLibrary [UnitId]
coverageFor
  let ( [[SymbolicPathX 'AllowAbsolute a3 c3]]
-> [SymbolicPathX 'AllowAbsolute a3 c3]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat -> [SymbolicPathX 'AllowAbsolute a3 c3]
pathsToLibsArtifacts
        , [[ModuleName]] -> [ModuleName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat -> [ModuleName]
libsModulesToInclude
        ) =
          [([SymbolicPathX 'AllowAbsolute a3 c3], [ModuleName])]
-> ([[SymbolicPathX 'AllowAbsolute a3 c3]], [[ModuleName]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([SymbolicPathX 'AllowAbsolute a3 c3], [ModuleName])]
 -> ([[SymbolicPathX 'AllowAbsolute a3 c3]], [[ModuleName]]))
-> [([SymbolicPathX 'AllowAbsolute a3 c3], [ModuleName])]
-> ([[SymbolicPathX 'AllowAbsolute a3 c3]], [[ModuleName]])
forall a b. (a -> b) -> a -> b
$
            (InstalledPackageInfo
 -> ([SymbolicPathX 'AllowAbsolute a3 c3], [ModuleName]))
-> [InstalledPackageInfo]
-> [([SymbolicPathX 'AllowAbsolute a3 c3], [ModuleName])]
forall a b. (a -> b) -> [a] -> [b]
map
              ( \InstalledPackageInfo
ip ->
                  ( (FilePath -> SymbolicPathX 'AllowAbsolute a3 c3)
-> Args -> [SymbolicPathX 'AllowAbsolute a3 c3]
forall a b. (a -> b) -> [a] -> [b]
map ((SymbolicPath a3 ('Dir Build)
-> SymbolicPathX 'OnlyRelative Build c3
-> SymbolicPathX 'AllowAbsolute a3 c3
forall p q r. PathLike p q r => p -> q -> r
</> SymbolicPathX 'OnlyRelative Build ('Dir Artifacts)
-> SymbolicPathX 'OnlyRelative Build c3
forall (allowAbsolute :: AllowAbsolute) from (to1 :: FileOrDir)
       (to2 :: FileOrDir).
SymbolicPathX allowAbsolute from to1
-> SymbolicPathX allowAbsolute from to2
coerceSymbolicPath SymbolicPathX 'OnlyRelative Build ('Dir Artifacts)
extraCompilationArtifacts) (SymbolicPath a3 ('Dir Build)
 -> SymbolicPathX 'AllowAbsolute a3 c3)
-> (FilePath -> SymbolicPath a3 ('Dir Build))
-> FilePath
-> SymbolicPathX 'AllowAbsolute a3 c3
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> SymbolicPath a3 ('Dir Build)
forall from (to :: FileOrDir). FilePath -> SymbolicPath from to
makeSymbolicPath) (Args -> [SymbolicPathX 'AllowAbsolute a3 c3])
-> Args -> [SymbolicPathX 'AllowAbsolute a3 c3]
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
                  )
              )
              [InstalledPackageInfo]
ipkginfos
      hpcMarkupInfo :: HPCMarkupInfo
hpcMarkupInfo = HPCMarkupInfo{[SymbolicPath Pkg ('Dir Artifacts)]
forall {a3} {c3 :: FileOrDir}. [SymbolicPathX 'AllowAbsolute a3 c3]
pathsToLibsArtifacts :: forall {a3} {c3 :: FileOrDir}. [SymbolicPathX 'AllowAbsolute a3 c3]
pathsToLibsArtifacts :: [SymbolicPath Pkg ('Dir Artifacts)]
pathsToLibsArtifacts, [ModuleName]
libsModulesToInclude :: [ModuleName]
libsModulesToInclude :: [ModuleName]
libsModulesToInclude}

  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 (HPCMarkupInfo
-> ((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)
-> IO TestSuiteLog
doTest HPCMarkupInfo
hpcMarkupInfo) [((TestSuite, ComponentLocalBuildInfo), Maybe TestSuiteLog)]
testsToRun
  let packageLog :: PackageLog
packageLog = (PackageDescription -> LocalBuildInfo -> PackageLog
localPackageLog PackageDescription
pkg_descr LocalBuildInfo
lbi){testSuites = suites}
      packageLogFile :: FilePath
packageLogFile =
        SymbolicPathX 'AllowAbsolute Pkg Any -> FilePath
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> FilePath
i SymbolicPathX 'AllowAbsolute Pkg Any
forall {c3 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg c3
testLogDir
          FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> 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
-> HPCMarkupInfo
-> LocalBuildInfo
-> SymbolicPath Pkg ('Dir Dist)
-> PackageDescription
-> [TestSuite]
-> IO ()
markupPackage Verbosity
verbosity HPCMarkupInfo
hpcMarkupInfo LocalBuildInfo
lbi SymbolicPath Pkg ('Dir Dist)
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)