ExeV10.hs 6.61 KB
Newer Older
ttuegel's avatar
ttuegel committed
1 2 3 4
module Distribution.Simple.Test.ExeV10
       ( runTest
       ) where

5
import Distribution.Compat.CreatePipe ( createPipe )
ttuegel's avatar
ttuegel committed
6 7 8 9
import Distribution.Compat.Environment ( getEnvironment )
import qualified Distribution.PackageDescription as PD
import Distribution.Simple.Build.PathsModule ( pkgPathEnvVar )
import Distribution.Simple.BuildPaths ( exeExtension )
10
import Distribution.Simple.Compiler ( compilerInfo )
11
import Distribution.Simple.Hpc ( guessWay, markupTest, tixDir, tixFilePath )
ttuegel's avatar
ttuegel committed
12 13 14 15
import Distribution.Simple.InstallDirs
    ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..)
    , substPathTemplate , toPathTemplate, PathTemplate )
import qualified Distribution.Simple.LocalBuildInfo as LBI
16 17
import Distribution.Simple.Setup
    ( TestFlags(..), TestShowDetails(..), fromFlag, configCoverage )
ttuegel's avatar
ttuegel committed
18
import Distribution.Simple.Test.Log
19 20 21
import Distribution.Simple.Utils
    ( die, notice, rawSystemIOWithEnv, addLibraryPath )
import Distribution.System ( Platform (..) )
ttuegel's avatar
ttuegel committed
22 23 24 25
import Distribution.TestSuite
import Distribution.Text
import Distribution.Verbosity ( normal )

26 27
import Control.Concurrent (forkIO)
import Control.Monad ( unless, void, when )
ttuegel's avatar
ttuegel committed
28 29 30 31 32
import System.Directory
    ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist
    , getCurrentDirectory, removeDirectoryRecursive )
import System.Exit ( ExitCode(..) )
import System.FilePath ( (</>), (<.>) )
33
import System.IO ( hGetContents, hPutStr, stdout )
ttuegel's avatar
ttuegel committed
34 35 36 37 38 39 40

runTest :: PD.PackageDescription
        -> LBI.LocalBuildInfo
        -> TestFlags
        -> PD.TestSuite
        -> IO TestSuiteLog
runTest pkg_descr lbi flags suite = do
41
    let isCoverageEnabled = fromFlag $ configCoverage $ LBI.configFlags lbi
42 43
        way = guessWay lbi
        tixDir_ = tixDir distPref way $ PD.testName suite
44

ttuegel's avatar
ttuegel committed
45 46 47 48 49 50 51 52 53 54 55 56
    pwd <- getCurrentDirectory
    existingEnv <- getEnvironment

    let cmd = LBI.buildDir lbi </> PD.testName suite
                  </> PD.testName suite <.> exeExtension
    -- Check that the test executable exists.
    exists <- doesFileExist cmd
    unless exists $ die $ "Error: Could not find test program \"" ++ cmd
                          ++ "\". Did you build the package first?"

    -- Remove old .tix files if appropriate.
    unless (fromFlag $ testKeepTix flags) $ do
57 58
        exists' <- doesDirectoryExist tixDir_
        when exists' $ removeDirectoryRecursive tixDir_
ttuegel's avatar
ttuegel committed
59 60

    -- Create directory for HPC files.
61
    createDirectoryIfMissing True tixDir_
ttuegel's avatar
ttuegel committed
62 63 64 65

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

66 67 68 69 70 71 72 73 74 75 76
    (rOut, wOut) <- createPipe

    -- Read test executable's output lazily (returns immediately)
    logText <- hGetContents rOut
    -- Force the IO manager to drain the test output pipe
    void $ forkIO $ length logText `seq` return ()

    -- '--show-details=streaming': print the log output in another thread
    when (details == Streaming) $ void $ forkIO $ hPutStr stdout logText

    -- Run the test executable
77 78 79
    let opts = map (testOption pkg_descr lbi suite)
                   (testOptions flags)
        dataDirPath = pwd </> PD.dataDir pkg_descr
80
        tixFile = pwd </> tixFilePath distPref way (PD.testName suite)
81 82 83
        pkgPathEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath)
                   : existingEnv
        shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled] ++ pkgPathEnv
84 85

    -- Add (DY)LD_LIBRARY_PATH if needed
86
    shellEnv' <- if LBI.withDynExe lbi
87 88 89
                    then do let (Platform _ os) = LBI.hostPlatform lbi
                                clbi = LBI.getComponentLocalBuildInfo lbi
                                         (LBI.CTestName (PD.testName suite))
90
                            paths <- LBI.depLibraryPaths True False lbi clbi
91
                            return (addLibraryPath os paths shellEnv)
92 93 94
                    else return shellEnv

    exit <- rawSystemIOWithEnv verbosity cmd opts Nothing (Just shellEnv')
95 96
                               -- these handles are automatically closed
                               Nothing (Just wOut) (Just wOut)
ttuegel's avatar
ttuegel committed
97 98

    -- Generate TestSuiteLog from executable exit code and a machine-
99
    -- readable test log.
ttuegel's avatar
ttuegel committed
100 101 102 103 104 105 106 107 108 109 110 111 112 113
    let suiteLog = buildLog exit

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

    -- Append contents of temporary log file to the final human-
    -- readable log file
    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
114 115
    let whenPrinting = when $
            (details > Never)
ttuegel's avatar
ttuegel committed
116
            && (not (suitePassed $ testLogs suiteLog) || details == Always)
117 118 119 120
            -- verbosity overrides show-details
            && verbosity >= normal
            -- if streaming, we already printed the log
            && details /= Streaming
ttuegel's avatar
ttuegel committed
121 122 123 124 125
    whenPrinting $ putStr $ unlines $ lines logText

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

126 127
    when isCoverageEnabled $
        markupTest verbosity lbi distPref (display $ PD.package pkg_descr) suite
ttuegel's avatar
ttuegel committed
128 129 130 131 132

    return suiteLog
  where
    distPref = fromFlag $ testDistPref flags
    verbosity = fromFlag $ testVerbosity flags
133
    details = fromFlag $ testShowDetails flags
ttuegel's avatar
ttuegel committed
134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154
    testLogDir = distPref </> "test"

    buildLog exit =
        let r = case exit of
                    ExitSuccess -> Pass
                    ExitFailure c -> Fail $ "exit code: " ++ show c
            n = PD.testName suite
            l = TestLog
                { testName = n
                , testOptionsReturned = []
                , testResult = r
                }
        in TestSuiteLog
                { testSuiteName = n
                , testLogs = l
                , logFile =
                    testLogDir
                    </> testSuiteLogPath (fromFlag $ testHumanLog flags)
                                         pkg_descr lbi n l
                }

Mikhail Glushenkov's avatar
Typos.  
Mikhail Glushenkov committed
155 156
-- TODO: This is abusing the notion of a 'PathTemplate'.  The result isn't
-- necessarily a path.
ttuegel's avatar
ttuegel committed
157 158 159 160 161 162 163 164 165
testOption :: PD.PackageDescription
           -> LBI.LocalBuildInfo
           -> PD.TestSuite
           -> PathTemplate
           -> String
testOption pkg_descr lbi suite template =
    fromPathTemplate $ substPathTemplate env template
  where
    env = initialPathTemplateEnv
166
          (PD.package pkg_descr) (LBI.pkgKey lbi)
167
          (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++
ttuegel's avatar
ttuegel committed
168
          [(TestSuiteNameVar, toPathTemplate $ PD.testName suite)]