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

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

    import Prelude ()
    import Distribution.Compat.Prelude

    import Distribution.Types.UnqualComponentName
    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 System.Process ( createPipe )

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

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

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

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

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

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

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

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

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

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