content: module Distribution.Simple.Test.ExeV10
         ( runTest
         ) where
  
  import Distribution.Compat.CreatePipe ( createPipe )
  import Distribution.Compat.Environment ( getEnvironment )
  import qualified Distribution.PackageDescription as PD
  import Distribution.Simple.Build.PathsModule ( pkgPathEnvVar )
  import Distribution.Simple.BuildPaths ( exeExtension )
  import Distribution.Simple.Compiler ( compilerInfo )
  import Distribution.Simple.Hpc ( guessWay, markupTest, tixDir, tixFilePath )
  import Distribution.Simple.InstallDirs
      ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..)
      , substPathTemplate , toPathTemplate, PathTemplate )
  import qualified Distribution.Simple.LocalBuildInfo as LBI
  import Distribution.Simple.Setup
      ( TestFlags(..), TestShowDetails(..), fromFlag, configCoverage )
  import Distribution.Simple.Test.Log
  import Distribution.Simple.Utils
      ( die, notice, rawSystemIOWithEnv, addLibraryPath )
  import Distribution.System ( Platform (..) )
  import Distribution.TestSuite
  import Distribution.Text
  import Distribution.Verbosity ( normal )
  
  import Control.Concurrent (forkIO)
  import Control.Monad ( unless, void, when )
  import System.Directory
      ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist
      , getCurrentDirectory, removeDirectoryRecursive )
  import System.Exit ( ExitCode(..) )
  import System.FilePath ( (</>), (<.>) )
  import System.IO ( hGetContents, hPutStr, stdout )
  
  runTest :: PD.PackageDescription
          -> LBI.LocalBuildInfo
          -> TestFlags
          -> PD.TestSuite
          -> IO TestSuiteLog
  runTest pkg_descr lbi flags suite = do
      let isCoverageEnabled = fromFlag $ configCoverage $ LBI.configFlags lbi
          way = guessWay lbi
          tixDir_ = tixDir distPref way $ PD.testName suite
  
      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
          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 $ PD.testName suite
  
      (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
      let opts = map (testOption pkg_descr lbi suite)
                     (testOptions flags)
          dataDirPath = pwd </> PD.dataDir pkg_descr
          tixFile = pwd </> tixFilePath distPref way (PD.testName suite)
          pkgPathEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath)
                     : existingEnv
          shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled] ++ pkgPathEnv
  
      -- Add (DY)LD_LIBRARY_PATH if needed
      shellEnv' <- if LBI.withDynExe lbi
                      then do let (Platform _ os) = LBI.hostPlatform lbi
                                  clbi = LBI.getComponentLocalBuildInfo lbi
                                           (LBI.CTestName (PD.testName suite))
                              paths <- LBI.depLibraryPaths True False lbi clbi
                              return (addLibraryPath os paths shellEnv)
                      else return shellEnv
  
      exit <- rawSystemIOWithEnv verbosity cmd opts Nothing (Just shellEnv')
                                 -- these handles are automatically closed
                                 Nothing (Just wOut) (Just wOut)
  
      -- Generate TestSuiteLog from executable exit code and a machine-
      -- readable test log.
      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
      let whenPrinting = when $
              (details > Never)
              && (not (suitePassed $ testLogs suiteLog) || details == Always)
              -- verbosity overrides show-details
              && verbosity >= normal
              -- if streaming, we already printed the log
              && details /= Streaming
      whenPrinting $ putStr $ unlines $ lines logText
  
      -- Write summary notice to terminal indicating end of test suite
      notice verbosity $ summarizeSuiteFinish suiteLog
  
      when isCoverageEnabled $
          markupTest verbosity lbi distPref (display $ PD.package pkg_descr) suite
  
      return suiteLog
    where
      distPref = fromFlag $ testDistPref flags
      verbosity = fromFlag $ testVerbosity flags
      details = fromFlag $ testShowDetails flags
      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
                  }
  
  -- 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 pkg_descr lbi suite template =
      fromPathTemplate $ substPathTemplate env template
    where
      env = initialPathTemplateEnv
            (PD.package pkg_descr) (LBI.pkgKey lbi)
            (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++
            [(TestSuiteNameVar, toPathTemplate $ PD.testName suite)]
  