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

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

    import Distribution.Compat.Prelude
    import Prelude ()

    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.Flag
    import Distribution.Simple.Hpc
    import Distribution.Simple.InstallDirs
    import qualified Distribution.Simple.LocalBuildInfo as LBI
      ( ComponentLocalBuildInfo (..)
      , buildDir
      , depLibraryPaths
      )
    import Distribution.Simple.Setup.Test
    import Distribution.Simple.Test.Log
    import Distribution.Simple.Utils
    import Distribution.System
    import Distribution.TestSuite
    import qualified Distribution.Types.LocalBuildInfo as LBI
      ( LocalBuildInfo (..)
      , localUnitId
      , testCoverage
      )
    import Distribution.Types.UnqualComponentName
    import Distribution.Verbosity

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

    import qualified Data.ByteString.Lazy as LBS
    import Distribution.Simple.Errors

    runTest
      :: PD.PackageDescription
      -> LBI.LocalBuildInfo
      -> LBI.ComponentLocalBuildInfo
      -> HPCMarkupInfo
      -> TestFlags
      -> PD.TestSuite
      -> IO TestSuiteLog
    runTest :: PackageDescription
    -> LocalBuildInfo
    -> ComponentLocalBuildInfo
    -> HPCMarkupInfo
    -> TestFlags
    -> TestSuite
    -> IO TestSuiteLog
    runTest PackageDescription
    pkg_descr LocalBuildInfo
    lbi ComponentLocalBuildInfo
    clbi HPCMarkupInfo
    hpcMarkupInfo 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
    tixDir FilePath
    distPref Way
    way

      pwd <- IO FilePath
    getCurrentDirectory
      existingEnv <- getEnvironment

      let 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.
      exists <- doesFileExist cmd
      unless exists $
        dieWithException verbosity $
          Couldn'tFindTestProgram cmd

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

      -- Run the test executable
      let 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
    pwd FilePath -> FilePath -> FilePath
    </> PackageDescription -> FilePath
    PD.dataDir PackageDescription
    pkg_descr
          tixFile = FilePath
    pwd FilePath -> FilePath -> FilePath
    </> FilePath -> Way -> FilePath -> FilePath
    tixFilePath FilePath
    distPref Way
    way (FilePath
    testName')
          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
    "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
      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

      -- Output logger
      (wOut, wErr, getLogText) <- case 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
          (rOut, wOut) <- IO (Handle, Handle)
    createPipe

          return $ (,,) wOut wOut $ do
            -- Read test executables' output
            logText <- LBS.hGetContents rOut

            -- '--show-details=streaming': print the log output in another thread
            when (details == Streaming) $ LBS.putStr logText

            -- drain the output.
            evaluate (force logText)

      (exit, logText) <- case testWrapper 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
    cmd FilePath -> [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 = ExitCode -> TestSuiteLog
    buildLog ExitCode
    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
      LBS.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 =
            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
      whenPrinting $ do
        LBS.putStr logText
        putChar '\n'

      -- Write summary notice to terminal indicating end of test suite
      notice verbosity $ summarizeSuiteFinish suiteLog

      when isCoverageEnabled $ do
        -- Until #9493 is fixed, we expect cabal-install to pass one dist dir per
        -- library and there being at least one library in the package with the
        -- testsuite.  When it is fixed, we can remove this predicate and allow a
        -- testsuite without a library to cover libraries in other packages of the
        -- same project
        when (null $ PD.allLibraries pkg_descr) $
          dieWithException verbosity TestCoverageSupport

        markupPackage verbosity hpcMarkupInfo lbi distPref pkg_descr [suite]

      return 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)]