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

module Distribution.Simple.Test.ExeV10
  ( runTest
  ) where

import Distribution.Compat.Prelude
import Prelude ()

import Distribution.Compat.Environment
import qualified Distribution.PackageDescription as PD
import Distribution.Simple.BuildPaths
import Distribution.Simple.Compiler
import Distribution.Simple.Errors
import Distribution.Simple.Flag
import Distribution.Simple.Hpc
import Distribution.Simple.InstallDirs
import qualified Distribution.Simple.LocalBuildInfo as LBI
  ( ComponentLocalBuildInfo (..)
  , buildDir
  , depLibraryPaths
  )
import Distribution.Simple.Program.Db
import Distribution.Simple.Program.Find
import Distribution.Simple.Program.Run
import Distribution.Simple.Setup.Common
import Distribution.Simple.Setup.Test
import Distribution.Simple.Test.Log
import Distribution.Simple.Utils
import Distribution.System
import Distribution.TestSuite
import qualified Distribution.Types.LocalBuildInfo as LBI
  ( LocalBuildInfo (..)
  , localUnitId
  , testCoverage
  )
import Distribution.Types.UnqualComponentName
import Distribution.Verbosity

import Distribution.Utils.Path

import qualified Data.ByteString.Lazy as LBS
import Distribution.Simple.LocalBuildInfo (interpretSymbolicPathLBI, packageRoot)
import System.Directory
  ( createDirectoryIfMissing
  , doesDirectoryExist
  , doesFileExist
  , removeDirectoryRecursive
  )
import System.IO (stderr, stdout)
import System.Process (createPipe)

runTest
  :: PD.PackageDescription
  -> LBI.LocalBuildInfo
  -> LBI.ComponentLocalBuildInfo
  -> HPCMarkupInfo
  -> TestFlags
  -> PD.TestSuite
  -> IO TestSuiteLog
runTest :: PackageDescription
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> HPCMarkupInfo
-> TestFlags
-> TestSuite
-> IO TestSuiteLog
runTest PackageDescription
pkg_descr LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi HPCMarkupInfo
hpcMarkupInfo 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_ = SymbolicPathX 'AllowAbsolute Pkg ('Dir Tix) -> FilePath
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> FilePath
i (SymbolicPathX 'AllowAbsolute Pkg ('Dir Tix) -> FilePath)
-> SymbolicPathX 'AllowAbsolute Pkg ('Dir Tix) -> FilePath
forall a b. (a -> b) -> a -> b
$ SymbolicPath Pkg ('Dir Dist)
-> Way -> SymbolicPathX 'AllowAbsolute Pkg ('Dir Tix)
tixDir SymbolicPath Pkg ('Dir Dist)
distPref Way
way

  existingEnv <- IO [(FilePath, FilePath)]
getEnvironment

  let cmd =
        SymbolicPathX 'AllowAbsolute Pkg ('Dir Build) -> FilePath
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> FilePath
i (LocalBuildInfo -> SymbolicPathX 'AllowAbsolute Pkg ('Dir Build)
LBI.buildDir LocalBuildInfo
lbi)
          FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> FilePath
testName'
          FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> FilePath
testName' FilePath -> FilePath -> FilePath
forall p. FileLike p => p -> FilePath -> p
<.> Platform -> FilePath
exeExtension (LocalBuildInfo -> Platform
LBI.hostPlatform LocalBuildInfo
lbi)
  -- Check that the test executable exists.
  exists <- doesFileExist cmd
  unless exists $
    dieWithException verbosity $
      Couldn'tFindTestProgram cmd

  -- Remove old .tix files if appropriate.
  unless (fromFlag $ testKeepTix flags) $ do
    exists' <- doesDirectoryExist tixDir_
    when exists' $ removeDirectoryRecursive tixDir_

  -- Create directory for HPC files.
  createDirectoryIfMissing True tixDir_

  -- Write summary notices indicating start of test suite
  notice verbosity $ summarizeSuiteStart $ testName'

  -- Run the test executable (with the appropriate environment set)
  let progDb = LocalBuildInfo -> ProgramDb
LBI.withPrograms LocalBuildInfo
lbi
      pathVar = ProgramDb -> ProgramSearchPath
progSearchPath ProgramDb
progDb
      envOverrides = ProgramDb -> [(FilePath, Maybe FilePath)]
progOverrideEnv ProgramDb
progDb
  newPath <- programSearchPathAsPATHVar pathVar
  overrideEnv <- fromMaybe [] <$> getEffectiveEnvironment ([("PATH", Just newPath)] ++ envOverrides)
  let opts =
        (PathTemplate -> FilePath) -> [PathTemplate] -> [FilePath]
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)
      tixFile = CommonSetupFlags -> FilePath
packageRoot (TestFlags -> CommonSetupFlags
testCommonFlags TestFlags
flags) FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> SymbolicPathX 'AllowAbsolute Pkg 'File -> FilePath
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> FilePath
getSymbolicPath (SymbolicPath Pkg ('Dir Dist)
-> Way -> FilePath -> SymbolicPathX 'AllowAbsolute Pkg 'File
tixFilePath SymbolicPath Pkg ('Dir Dist)
distPref Way
way (FilePath
testName'))
      shellEnv = [(FilePath
"HPCTIXFILE", FilePath
tixFile) | Bool
isCoverageEnabled] [(FilePath, FilePath)]
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. [a] -> [a] -> [a]
++ [(FilePath, FilePath)]
overrideEnv [(FilePath, FilePath)]
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. [a] -> [a] -> [a]
++ [(FilePath, FilePath)]
existingEnv

  -- Add (DY)LD_LIBRARY_PATH if needed
  shellEnv' <-
    if LBI.withDynExe lbi
      then do
        let (Platform _ os) = LBI.hostPlatform lbi
        paths <- LBI.depLibraryPaths True False lbi clbi
        return (addLibraryPath os paths shellEnv)
      else return shellEnv

  -- Output logger
  (wOut, wErr, getLogText) <- case details of
    TestShowDetails
Direct -> (Handle, Handle, IO ByteString)
-> IO (Handle, Handle, IO ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Handle
stdout, Handle
stderr, ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
LBS.empty)
    TestShowDetails
_ -> do
      (rOut, wOut) <- IO (Handle, Handle)
createPipe

      return $ (,,) wOut wOut $ do
        -- Read test executables' output
        logText <- LBS.hGetContents rOut

        -- '--show-details=streaming': print the log output in another thread
        when (details == Streaming) $ LBS.putStr logText

        -- drain the output.
        evaluate (force logText)

  (exit, logText) <- case testWrapper flags of
    Flag FilePath
path ->
      Verbosity
-> FilePath
-> [FilePath]
-> Maybe FilePath
-> Maybe [(FilePath, FilePath)]
-> IO ByteString
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO (ExitCode, ByteString)
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
cmd FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
opts)
        Maybe FilePath
forall a. Maybe a
Nothing
        ([(FilePath, FilePath)] -> Maybe [(FilePath, FilePath)]
forall a. a -> Maybe a
Just [(FilePath, FilePath)]
shellEnv')
        IO ByteString
getLogText
        -- these handles are automatically closed
        Maybe Handle
forall a. Maybe a
Nothing
        (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
wOut)
        (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
wErr)
    Flag FilePath
NoFlag ->
      Verbosity
-> FilePath
-> [FilePath]
-> Maybe FilePath
-> Maybe [(FilePath, FilePath)]
-> IO ByteString
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO (ExitCode, ByteString)
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
        Maybe FilePath
forall a. Maybe a
Nothing
        ([(FilePath, FilePath)] -> Maybe [(FilePath, FilePath)]
forall a. a -> Maybe a
Just [(FilePath, FilePath)]
shellEnv')
        IO ByteString
getLogText
        -- these handles are automatically closed
        Maybe Handle
forall a. Maybe a
Nothing
        (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
wOut)
        (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
wErr)

  -- Generate TestSuiteLog from executable exit code and a machine-
  -- readable test log.
  let suiteLog = ExitCode -> TestSuiteLog
buildLog ExitCode
exit

  -- Write summary notice to log file indicating start of test suite
  appendFile (logFile suiteLog) $ summarizeSuiteStart testName'

  -- Append contents of temporary log file to the final human-
  -- readable log file
  LBS.appendFile (logFile suiteLog) logText

  -- Write end-of-suite summary notice to log file
  appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog

  -- Show the contents of the human-readable log file on the terminal
  -- if there is a failure and/or detailed output is requested
  let whenPrinting =
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> IO () -> IO ()) -> Bool -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          ( TestShowDetails
details TestShowDetails -> TestShowDetails -> Bool
forall a. Eq a => a -> a -> Bool
== TestShowDetails
Always
              Bool -> Bool -> Bool
|| TestShowDetails
details TestShowDetails -> TestShowDetails -> Bool
forall a. Eq a => a -> a -> Bool
== TestShowDetails
Failures Bool -> Bool -> Bool
&& Bool -> Bool
not (TestLogs -> Bool
suitePassed (TestLogs -> Bool) -> TestLogs -> Bool
forall a b. (a -> b) -> a -> b
$ TestSuiteLog -> TestLogs
testLogs TestSuiteLog
suiteLog)
          )
            -- verbosity overrides show-details
            Bool -> Bool -> Bool
&& Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
normal
  whenPrinting $ do
    LBS.putStr logText
    putChar '\n'

  -- Write summary notice to terminal indicating end of test suite
  notice verbosity $ summarizeSuiteFinish suiteLog

  when isCoverageEnabled $ do
    -- Until #9493 is fixed, we expect cabal-install to pass one dist dir per
    -- library and there being at least one library in the package with the
    -- testsuite.  When it is fixed, we can remove this predicate and allow a
    -- testsuite without a library to cover libraries in other packages of the
    -- same project
    when (null $ PD.allLibraries pkg_descr) $
      dieWithException verbosity TestCoverageSupport

    markupPackage verbosity hpcMarkupInfo lbi distPref pkg_descr [suite]

  return suiteLog
  where
    i :: SymbolicPathX allowAbsolute Pkg to -> FilePath
i = LocalBuildInfo -> SymbolicPathX allowAbsolute Pkg to -> FilePath
forall (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
LocalBuildInfo -> SymbolicPathX allowAbsolute Pkg to -> FilePath
interpretSymbolicPathLBI LocalBuildInfo
lbi -- See Note [Symbolic paths] in Distribution.Utils.Path
    commonFlags :: CommonSetupFlags
commonFlags = TestFlags -> CommonSetupFlags
testCommonFlags TestFlags
flags

    testName' :: FilePath
testName' = UnqualComponentName -> FilePath
unUnqualComponentName (UnqualComponentName -> FilePath)
-> UnqualComponentName -> FilePath
forall a b. (a -> b) -> a -> b
$ TestSuite -> UnqualComponentName
PD.testName TestSuite
suite

    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
commonFlags
    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
commonFlags
    details :: TestShowDetails
details = Flag TestShowDetails -> TestShowDetails
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag TestShowDetails -> TestShowDetails)
-> Flag TestShowDetails -> TestShowDetails
forall a b. (a -> b) -> a -> b
$ TestFlags -> Flag TestShowDetails
testShowDetails 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"

    buildLog :: ExitCode -> TestSuiteLog
buildLog ExitCode
exit =
      let r :: Result
r = case ExitCode
exit of
            ExitCode
ExitSuccess -> Result
Pass
            ExitFailure Int
c -> FilePath -> Result
Fail (FilePath -> Result) -> FilePath -> Result
forall a b. (a -> b) -> a -> b
$ FilePath
"exit code: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
c
          -- n = unUnqualComponentName $ PD.testName suite
          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 =
                SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 0) -> FilePath
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> FilePath
i SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 0)
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
-> TestLogs
-> FilePath
testSuiteLogPath
                    (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
testHumanLog TestFlags
flags)
                    PackageDescription
pkg_descr
                    LocalBuildInfo
lbi
                    FilePath
testName'
                    TestLogs
l
            }

-- TODO: This is abusing the notion of a 'PathTemplate'.  The result isn't
-- necessarily a path.
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 (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)
        PathTemplateEnv -> PathTemplateEnv -> PathTemplateEnv
forall a. [a] -> [a] -> [a]
++ [(PathTemplateVariable
TestSuiteNameVar, FilePath -> PathTemplate
toPathTemplate (FilePath -> PathTemplate) -> FilePath -> PathTemplate
forall a b. (a -> b) -> a -> b
$ UnqualComponentName -> FilePath
unUnqualComponentName (UnqualComponentName -> FilePath)
-> UnqualComponentName -> FilePath
forall a b. (a -> b) -> a -> b
$ TestSuite -> UnqualComponentName
PD.testName TestSuite
suite)]