{-# 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.Pretty
import Distribution.Simple.Build.PathsModule
import Distribution.Simple.BuildPaths
import Distribution.Simple.Compiler
import Distribution.Simple.Flag
import Distribution.Simple.Hpc
import Distribution.Simple.InstallDirs
import qualified Distribution.Simple.LocalBuildInfo as LBI
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
import Distribution.Types.UnqualComponentName
import Distribution.Verbosity

import System.Directory
  ( createDirectoryIfMissing
  , doesDirectoryExist
  , doesFileExist
  , getCurrentDirectory
  , removeDirectoryRecursive
  )
import System.FilePath ((<.>), (</>))
import System.IO (stderr, stdout)
import System.Process (createPipe)

import qualified Data.ByteString.Lazy as LBS

runTest
  :: PD.PackageDescription
  -> LBI.LocalBuildInfo
  -> LBI.ComponentLocalBuildInfo
  -> TestFlags
  -> PD.TestSuite
  -> IO TestSuiteLog
runTest :: PackageDescription
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> TestFlags
-> TestSuite
-> IO TestSuiteLog
runTest PackageDescription
pkg_descr LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi 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_ = FilePath -> Way -> FilePath -> FilePath
tixDir FilePath
distPref Way
way FilePath
testName'

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

  let cmd :: FilePath
cmd =
        LocalBuildInfo -> FilePath
LBI.buildDir LocalBuildInfo
lbi
          FilePath -> FilePath -> FilePath
</> FilePath
testName'
          FilePath -> FilePath -> FilePath
</> FilePath
testName' FilePath -> FilePath -> FilePath
<.> Platform -> FilePath
exeExtension (LocalBuildInfo -> Platform
LBI.hostPlatform LocalBuildInfo
lbi)
  -- Check that the test executable exists.
  Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
cmd
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (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
"Could not find test program \""
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
cmd
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\". Did you build the package first?"

  -- Remove old .tix files if appropriate.
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag Bool -> Bool) -> Flag Bool -> Bool
forall a b. (a -> b) -> a -> b
$ TestFlags -> Flag Bool
testKeepTix TestFlags
flags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Bool
exists' <- FilePath -> IO Bool
doesDirectoryExist FilePath
tixDir_
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists' (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeDirectoryRecursive FilePath
tixDir_

  -- Create directory for HPC files.
  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
tixDir_

  -- Write summary notices indicating start of test suite
  Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
summarizeSuiteStart (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
testName'

  -- Run the test executable
  let opts :: [FilePath]
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)
      dataDirPath :: FilePath
dataDirPath = FilePath
pwd FilePath -> FilePath -> FilePath
</> PackageDescription -> FilePath
PD.dataDir PackageDescription
pkg_descr
      tixFile :: FilePath
tixFile = FilePath
pwd FilePath -> FilePath -> FilePath
</> FilePath -> Way -> FilePath -> FilePath
tixFilePath FilePath
distPref Way
way (FilePath
testName')
      pkgPathEnv :: [(FilePath, FilePath)]
pkgPathEnv =
        (PackageDescription -> FilePath -> FilePath
pkgPathEnvVar PackageDescription
pkg_descr FilePath
"datadir", FilePath
dataDirPath)
          (FilePath, FilePath)
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. a -> [a] -> [a]
: [(FilePath, FilePath)]
existingEnv
      shellEnv :: [(FilePath, FilePath)]
shellEnv = [(FilePath
"HPCTIXFILE", FilePath
tixFile) | Bool
isCoverageEnabled] [(FilePath, FilePath)]
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. [a] -> [a] -> [a]
++ [(FilePath, FilePath)]
pkgPathEnv

  -- Add (DY)LD_LIBRARY_PATH if needed
  [(FilePath, FilePath)]
shellEnv' <-
    if LocalBuildInfo -> Bool
LBI.withDynExe LocalBuildInfo
lbi
      then do
        let (Platform Arch
_ OS
os) = LocalBuildInfo -> Platform
LBI.hostPlatform LocalBuildInfo
lbi
        [FilePath]
paths <- Bool
-> Bool
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> IO [FilePath]
LBI.depLibraryPaths Bool
True Bool
False LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi
        [(FilePath, FilePath)] -> IO [(FilePath, FilePath)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (OS
-> [FilePath] -> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
addLibraryPath OS
os [FilePath]
paths [(FilePath, FilePath)]
shellEnv)
      else [(FilePath, FilePath)] -> IO [(FilePath, FilePath)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [(FilePath, FilePath)]
shellEnv

  -- Output logger
  (Handle
wOut, Handle
wErr, IO ByteString
getLogText) <- case TestShowDetails
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
      (Handle
rOut, Handle
wOut) <- IO (Handle, Handle)
createPipe

      (Handle, Handle, IO ByteString)
-> IO (Handle, Handle, IO ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Handle, Handle, IO ByteString)
 -> IO (Handle, Handle, IO ByteString))
-> (Handle, Handle, IO ByteString)
-> IO (Handle, Handle, IO ByteString)
forall a b. (a -> b) -> a -> b
$ (,,) Handle
wOut Handle
wOut (IO ByteString -> (Handle, Handle, IO ByteString))
-> IO ByteString -> (Handle, Handle, IO ByteString)
forall a b. (a -> b) -> a -> b
$ do
        -- Read test executables' output
        ByteString
logText <- Handle -> IO ByteString
LBS.hGetContents Handle
rOut

        -- '--show-details=streaming': print the log output in another thread
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TestShowDetails
details TestShowDetails -> TestShowDetails -> Bool
forall a. Eq a => a -> a -> Bool
== TestShowDetails
Streaming) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> IO ()
LBS.putStr ByteString
logText

        -- drain the output.
        ByteString -> IO ByteString
forall a. a -> IO a
evaluate (ByteString -> ByteString
forall a. NFData a => a -> a
force ByteString
logText)

  (ExitCode
exit, ByteString
logText) <- case TestFlags -> Flag FilePath
testWrapper TestFlags
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 :: TestSuiteLog
suiteLog = ExitCode -> TestSuiteLog
buildLog ExitCode
exit

  -- Write summary notice to log file indicating start of test suite
  FilePath -> FilePath -> IO ()
appendFile (TestSuiteLog -> FilePath
logFile TestSuiteLog
suiteLog) (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
summarizeSuiteStart FilePath
testName'

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

  -- Write end-of-suite summary notice to log file
  FilePath -> FilePath -> IO ()
appendFile (TestSuiteLog -> FilePath
logFile TestSuiteLog
suiteLog) (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ TestSuiteLog -> FilePath
summarizeSuiteFinish TestSuiteLog
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 :: IO () -> IO ()
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
  IO () -> IO ()
whenPrinting (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    ByteString -> IO ()
LBS.putStr ByteString
logText
    Char -> IO ()
putChar Char
'\n'

  -- Write summary notice to terminal indicating end of test suite
  Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ TestSuiteLog -> FilePath
summarizeSuiteFinish TestSuiteLog
suiteLog

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isCoverageEnabled (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    case PackageDescription -> Maybe Library
PD.library PackageDescription
pkg_descr of
      Maybe Library
Nothing ->
        Verbosity -> FilePath -> IO ()
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity FilePath
"Test coverage is only supported for packages with a library component."
      Just Library
library ->
        Verbosity
-> LocalBuildInfo
-> FilePath
-> FilePath
-> TestSuite
-> Library
-> IO ()
markupTest Verbosity
verbosity LocalBuildInfo
lbi FilePath
distPref (PackageIdentifier -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (PackageIdentifier -> FilePath) -> PackageIdentifier -> FilePath
forall a b. (a -> b) -> a -> b
$ PackageDescription -> PackageIdentifier
PD.package PackageDescription
pkg_descr) TestSuite
suite Library
library

  TestSuiteLog -> IO TestSuiteLog
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TestSuiteLog
suiteLog
  where
    testName' :: FilePath
testName' = UnqualComponentName -> FilePath
unUnqualComponentName (UnqualComponentName -> FilePath)
-> UnqualComponentName -> FilePath
forall a b. (a -> b) -> a -> b
$ TestSuite -> UnqualComponentName
PD.testName TestSuite
suite

    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
    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
    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 :: FilePath
testLogDir = FilePath
distPref FilePath -> FilePath -> FilePath
</> 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 =
                FilePath
testLogDir
                  FilePath -> FilePath -> FilePath
</> 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)]