    {-# 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.Pretty
    import Distribution.Verbosity

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

    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
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless Bool
    exists forall a b. (a -> b) -> a -> b
    $ forall a. Verbosity -> FilePath -> IO a
    die' Verbosity
    verbosity forall a b. (a -> b) -> a -> b
    $ FilePath
    "Error: Could not find test program \"" forall a. [a] -> [a] -> [a]
    ++ FilePath
    cmd
                              forall a. [a] -> [a] -> [a]
    ++ FilePath
    "\". Did you build the package first?"

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

        -- Run the test executable
        let opts :: [FilePath]
    opts = 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)
                       forall a. a -> [a] -> [a]
    : [(FilePath, FilePath)]
    existingEnv
            shellEnv :: [(FilePath, FilePath)]
    shellEnv = [(FilePath
    "HPCTIXFILE", FilePath
    tixFile) | Bool
    isCoverageEnabled] 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
                                forall (m :: * -> *) a. Monad m => a -> m a
    return (OS
    -> [FilePath] -> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
    addLibraryPath OS
    os [FilePath]
    paths [(FilePath, FilePath)]
    shellEnv)
                        else 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 -> forall (m :: * -> *) a. Monad m => a -> m a
    return (Handle
    stdout, Handle
    stderr, forall (m :: * -> *) a. Monad m => a -> m a
    return ByteString
    LBS.empty)
            TestShowDetails
    _      -> do
                (Handle
    rOut, Handle
    wOut) <- IO (Handle, Handle)
    createPipe

                forall (m :: * -> *) a. Monad m => a -> m a
    return forall a b. (a -> b) -> a -> b
    $ (,,) Handle
    wOut Handle
    wOut 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
                    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (TestShowDetails
    details forall a. Eq a => a -> a -> Bool
    == TestShowDetails
    Streaming) forall a b. (a -> b) -> a -> b
    $ ByteString -> IO ()
    LBS.putStr ByteString
    logText

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

        (ExitCode
    exit, ByteString
    logText) <- case TestFlags -> Flag FilePath
    testWrapper TestFlags
    flags of
            Flag FilePath
    path -> 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
    cmdforall a. a -> [a] -> [a]
    :[FilePath]
    opts) forall a. Maybe a
    Nothing (forall a. a -> Maybe a
    Just [(FilePath, FilePath)]
    shellEnv')
                IO ByteString
    getLogText
                -- these handles are automatically closed
                forall a. Maybe a
    Nothing (forall a. a -> Maybe a
    Just Handle
    wOut) (forall a. a -> Maybe a
    Just Handle
    wErr)

            Flag FilePath
    NoFlag -> 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 forall a. Maybe a
    Nothing (forall a. a -> Maybe a
    Just [(FilePath, FilePath)]
    shellEnv')
                IO ByteString
    getLogText
                -- these handles are automatically closed
                forall a. Maybe a
    Nothing (forall a. a -> Maybe a
    Just Handle
    wOut) (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) forall a b. (a -> b) -> a -> b
    $ FilePath -> FilePath
    summarizeSuiteStart forall a b. (a -> b) -> a -> b
    $ 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) 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 = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when forall a b. (a -> b) -> a -> b
    $
                ( TestShowDetails
    details forall a. Eq a => a -> a -> Bool
    == TestShowDetails
    Always Bool -> Bool -> Bool
    ||
                  TestShowDetails
    details forall a. Eq a => a -> a -> Bool
    == TestShowDetails
    Failures Bool -> Bool -> Bool
    && Bool -> Bool
    not (TestLogs -> Bool
    suitePassed forall a b. (a -> b) -> a -> b
    $ TestSuiteLog -> TestLogs
    testLogs TestSuiteLog
    suiteLog))
                -- verbosity overrides show-details
                Bool -> Bool -> Bool
    && Verbosity
    verbosity forall a. Ord a => a -> a -> Bool
    >= Verbosity
    normal
        IO () -> IO ()
    whenPrinting 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 forall a b. (a -> b) -> a -> b
    $ TestSuiteLog -> FilePath
    summarizeSuiteFinish TestSuiteLog
    suiteLog

        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when Bool
    isCoverageEnabled forall a b. (a -> b) -> a -> b
    $
            case PackageDescription -> Maybe Library
    PD.library PackageDescription
    pkg_descr of
                Maybe Library
    Nothing ->
                    forall a. Verbosity -> FilePath -> IO a
    die' Verbosity
    verbosity forall a b. (a -> b) -> a -> b
    $ FilePath
    "Error: 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 (forall a. Pretty a => a -> FilePath
    prettyShow forall a b. (a -> b) -> a -> b
    $ PackageDescription -> PackageIdentifier
    PD.package PackageDescription
    pkg_descr) TestSuite
    suite Library
    library

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

        distPref :: FilePath
    distPref = forall a. WithCallStack (Flag a -> a)
    fromFlag forall a b. (a -> b) -> a -> b
    $ TestFlags -> Flag FilePath
    testDistPref TestFlags
    flags
        verbosity :: Verbosity
    verbosity = forall a. WithCallStack (Flag a -> a)
    fromFlag forall a b. (a -> b) -> a -> b
    $ TestFlags -> Flag Verbosity
    testVerbosity TestFlags
    flags
        details :: TestShowDetails
    details = forall a. WithCallStack (Flag a -> a)
    fromFlag 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 forall a b. (a -> b) -> a -> b
    $ FilePath
    "exit code: " forall a. [a] -> [a] -> [a]
    ++ 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 (forall a. WithCallStack (Flag a -> a)
    fromFlag 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 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 forall a b. (a -> b) -> a -> b
    $ LocalBuildInfo -> Compiler
    LBI.compiler LocalBuildInfo
    lbi) (LocalBuildInfo -> Platform
    LBI.hostPlatform LocalBuildInfo
    lbi) forall a. [a] -> [a] -> [a]
    ++
              [(PathTemplateVariable
    TestSuiteNameVar, FilePath -> PathTemplate
    toPathTemplate forall a b. (a -> b) -> a -> b
    $ UnqualComponentName -> FilePath
    unUnqualComponentName forall a b. (a -> b) -> a -> b
    $ TestSuite -> UnqualComponentName
    PD.testName TestSuite
    suite)]