Cabal/src/Distribution/Simple/Test/ExeV10.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE RankNTypes #-}
   3
   4 module Distribution.Simple.Test.ExeV10
   5   ( runTest
   6   ) where
   7
   8 import Distribution.Compat.Prelude
   9 import Prelude ()
  10
  11 import Distribution.Compat.Environment
  12 import qualified Distribution.PackageDescription as PD
  13 import Distribution.Pretty
  14 import Distribution.Simple.Build.PathsModule
  15 import Distribution.Simple.BuildPaths
  16 import Distribution.Simple.Compiler
  17 import Distribution.Simple.Flag
  18 import Distribution.Simple.Hpc
  19 import Distribution.Simple.InstallDirs
  20 import qualified Distribution.Simple.LocalBuildInfo as LBI
  21 import Distribution.Simple.Setup.Test
  22 import Distribution.Simple.Test.Log
  23 import Distribution.Simple.Utils
  24 import Distribution.System
  25 import Distribution.TestSuite
  26 import qualified Distribution.Types.LocalBuildInfo as LBI
  27 import Distribution.Types.UnqualComponentName
  28 import Distribution.Verbosity
  29
  30 import System.Directory
  31   ( createDirectoryIfMissing
  32   , doesDirectoryExist
  33   , doesFileExist
  34   , getCurrentDirectory
  35   , removeDirectoryRecursive
  36   )
  37 import System.FilePath ((<.>), (</>))
  38 import System.IO (stderr, stdout)
  39 import System.Process (createPipe)
  40
  41 import qualified Data.ByteString.Lazy as LBS
  42 import Distribution.Simple.Errors
  43
  44 runTest
  45   :: PD.PackageDescription
  46   -> LBI.LocalBuildInfo
  47   -> LBI.ComponentLocalBuildInfo
  48   -> TestFlags
  49   -> PD.TestSuite
  50   -> IO TestSuiteLog
  51 runTest pkg_descr lbi clbi flags suite = do
  52   let isCoverageEnabled = LBI.testCoverage lbi
  53       way = guessWay lbi
  54       tixDir_ = tixDir distPref way testName'
  55
  56   pwd <- getCurrentDirectory
  57   existingEnv <- getEnvironment
  58
  59   let cmd =
  60         LBI.buildDir lbi
  61           </> testName'
  62           </> testName' <.> exeExtension (LBI.hostPlatform lbi)
  63   -- Check that the test executable exists.
  64   exists <- doesFileExist cmd
  65   unless exists $
  66     dieWithException verbosity $
  67       Couldn'tFindTestProgram cmd
  68
  69   -- Remove old .tix files if appropriate.
  70   unless (fromFlag $ testKeepTix flags) $ do
  71     exists' <- doesDirectoryExist tixDir_
  72     when exists' $ removeDirectoryRecursive tixDir_
  73
  74   -- Create directory for HPC files.
  75   createDirectoryIfMissing True tixDir_
  76
  77   -- Write summary notices indicating start of test suite
  78   notice verbosity $ summarizeSuiteStart $ testName'
  79
  80   -- Run the test executable
  81   let opts =
  82         map
  83           (testOption pkg_descr lbi suite)
  84           (testOptions flags)
  85       dataDirPath = pwd </> PD.dataDir pkg_descr
  86       tixFile = pwd </> tixFilePath distPref way (testName')
  87       pkgPathEnv =
  88         (pkgPathEnvVar pkg_descr "datadir", dataDirPath)
  89           : existingEnv
  90       shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled] ++ pkgPathEnv
  91
  92   -- Add (DY)LD_LIBRARY_PATH if needed
  93   shellEnv' <-
  94     if LBI.withDynExe lbi
  95       then do
  96         let (Platform _ os) = LBI.hostPlatform lbi
  97         paths <- LBI.depLibraryPaths True False lbi clbi
  98         return (addLibraryPath os paths shellEnv)
  99       else return shellEnv
 100
 101   -- Output logger
 102   (wOut, wErr, getLogText) <- case details of
 103     Direct -> return (stdout, stderr, return LBS.empty)
 104     _ -> do
 105       (rOut, wOut) <- createPipe
 106
 107       return $ (,,) wOut wOut $ do
 108         -- Read test executables' output
 109         logText <- LBS.hGetContents rOut
 110
 111         -- '--show-details=streaming': print the log output in another thread
 112         when (details == Streaming) $ LBS.putStr logText
 113
 114         -- drain the output.
 115         evaluate (force logText)
 116
 117   (exit, logText) <- case testWrapper flags of
 118     Flag path ->
 119       rawSystemIOWithEnvAndAction
 120         verbosity
 121         path
 122         (cmd : opts)
 123         Nothing
 124         (Just shellEnv')
 125         getLogText
 126         -- these handles are automatically closed
 127         Nothing
 128         (Just wOut)
 129         (Just wErr)
 130     NoFlag ->
 131       rawSystemIOWithEnvAndAction
 132         verbosity
 133         cmd
 134         opts
 135         Nothing
 136         (Just shellEnv')
 137         getLogText
 138         -- these handles are automatically closed
 139         Nothing
 140         (Just wOut)
 141         (Just wErr)
 142
 143   -- Generate TestSuiteLog from executable exit code and a machine-
 144   -- readable test log.
 145   let suiteLog = buildLog exit
 146
 147   -- Write summary notice to log file indicating start of test suite
 148   appendFile (logFile suiteLog) $ summarizeSuiteStart testName'
 149
 150   -- Append contents of temporary log file to the final human-
 151   -- readable log file
 152   LBS.appendFile (logFile suiteLog) logText
 153
 154   -- Write end-of-suite summary notice to log file
 155   appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog
 156
 157   -- Show the contents of the human-readable log file on the terminal
 158   -- if there is a failure and/or detailed output is requested
 159   let whenPrinting =
 160         when $
 161           ( details == Always
 162               || details == Failures && not (suitePassed $ testLogs suiteLog)
 163           )
 164             -- verbosity overrides show-details
 165             && verbosity >= normal
 166   whenPrinting $ do
 167     LBS.putStr logText
 168     putChar '\n'
 169
 170   -- Write summary notice to terminal indicating end of test suite
 171   notice verbosity $ summarizeSuiteFinish suiteLog
 172
 173   when isCoverageEnabled $
 174     case PD.library pkg_descr of
 175       Nothing ->
 176         dieWithException verbosity TestCoverageSupport
 177       Just library ->
 178         markupTest verbosity lbi distPref (prettyShow $ PD.package pkg_descr) suite library
 179
 180   return suiteLog
 181   where
 182     testName' = unUnqualComponentName $ PD.testName suite
 183
 184     distPref = fromFlag $ testDistPref flags
 185     verbosity = fromFlag $ testVerbosity flags
 186     details = fromFlag $ testShowDetails flags
 187     testLogDir = distPref </> "test"
 188
 189     buildLog exit =
 190       let r = case exit of
 191             ExitSuccess -> Pass
 192             ExitFailure c -> Fail $ "exit code: " ++ show c
 193           -- n = unUnqualComponentName $ PD.testName suite
 194           l =
 195             TestLog
 196               { testName = testName'
 197               , testOptionsReturned = []
 198               , testResult = r
 199               }
 200        in TestSuiteLog
 201             { testSuiteName = PD.testName suite
 202             , testLogs = l
 203             , logFile =
 204                 testLogDir
 205                   </> testSuiteLogPath
 206                     (fromFlag $ testHumanLog flags)
 207                     pkg_descr
 208                     lbi
 209                     testName'
 210                     l
 211             }
 212
 213 -- TODO: This is abusing the notion of a 'PathTemplate'.  The result isn't
 214 -- necessarily a path.
 215 testOption
 216   :: PD.PackageDescription
 217   -> LBI.LocalBuildInfo
 218   -> PD.TestSuite
 219   -> PathTemplate
 220   -> String
 221 testOption pkg_descr lbi suite template =
 222   fromPathTemplate $ substPathTemplate env template
 223   where
 224     env =
 225       initialPathTemplateEnv
 226         (PD.package pkg_descr)
 227         (LBI.localUnitId lbi)
 228         (compilerInfo $ LBI.compiler lbi)
 229         (LBI.hostPlatform lbi)
 230         ++ [(TestSuiteNameVar, toPathTemplate $ unUnqualComponentName $ PD.testName suite)]