Distribution/Simple/Test/ExeV10.hs

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

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

    import Prelude ()
    import Distribution.Compat.Prelude

    import Distribution.Types.UnqualComponentName
    import Distribution.Compat.CreatePipe
    import Distribution.Compat.Environment
    import qualified Distribution.PackageDescription as PD
    import Distribution.Simple.Build.PathsModule
    import Distribution.Simple.BuildPaths
    import Distribution.Simple.Compiler
    import Distribution.Simple.Hpc
    import Distribution.Simple.InstallDirs
    import qualified Distribution.Simple.LocalBuildInfo as LBI
    import qualified Distribution.Types.LocalBuildInfo as LBI
    import Distribution.Simple.Setup
    import Distribution.Simple.Test.Log
    import Distribution.Simple.Utils
    import Distribution.System
    import Distribution.TestSuite
    import Distribution.Text
    import Distribution.Verbosity

    import Control.Concurrent (forkIO)
    import System.Directory
        ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist
        , getCurrentDirectory, removeDirectoryRecursive )
    import System.Exit ( ExitCode(..) )
    import System.FilePath ( (</>), (<.>) )
    import System.IO ( hGetContents, hPutStr, stdout, stderr )

    runTest :: PD.PackageDescription
            -> LBI.LocalBuildInfo
            -> LBI.ComponentLocalBuildInfo
            -> TestFlags
            -> PD.TestSuite
            -> IO TestSuiteLog
    runTest pkg_descr lbi clbi flags suite = do
        let isCoverageEnabled = LBI.testCoverage lbi
            way = guessWay lbi
            tixDir_ = tixDir distPref way testName'

        pwd <- getCurrentDirectory
        existingEnv <- getEnvironment

        let cmd = LBI.buildDir lbi </> testName'
                      </> testName' <.> exeExtension
        -- Check that the test executable exists.
        exists <- doesFileExist cmd
        unless exists $ die' verbosity $ "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 $ testName'

        (wOut, wErr, logText) <- case details of
            Direct -> return (stdout, stderr, "")
            _ -> do
                (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

                return (wOut, wOut, 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 (testName')
            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
                                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 wErr)

        -- 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 $ testName'

        -- 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 == Always ||
                  details == Failures && not (suitePassed $ testLogs suiteLog))
                -- verbosity overrides show-details
                && verbosity >= normal
        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
        testName' = unUnqualComponentName $ PD.testName suite

        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 = unUnqualComponentName $ PD.testName suite
                l = TestLog
                    { testName = testName'
                    , testOptionsReturned = []
                    , testResult = r
                    }
            in TestSuiteLog
                    { testSuiteName = PD.testName suite
                    , testLogs = l
                    , logFile =
                        testLogDir
                        </> testSuiteLogPath (fromFlag $ testHumanLog flags)
                                             pkg_descr lbi testName' 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.localUnitId lbi)
              (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++
              [(TestSuiteNameVar, toPathTemplate $ unUnqualComponentName $ PD.testName suite)]