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

module Distribution.Simple.Test.LibV09
  ( runTest
  -- Test stub
  , simpleTestStub
  , stubFilePath
  , stubMain
  , stubName
  , stubWriteLog
  , writeSimpleTestStub
  ) where

import Distribution.Compat.Prelude
import Distribution.Types.UnqualComponentName
import Prelude ()

import Distribution.Compat.Environment
import Distribution.Compat.Internal.TempFile
import Distribution.Compat.Process (proc)
import Distribution.ModuleName
import qualified Distribution.PackageDescription as PD
import Distribution.Pretty
import Distribution.Simple.BuildPaths
import Distribution.Simple.Compiler
import Distribution.Simple.Errors
import Distribution.Simple.Hpc
import Distribution.Simple.InstallDirs
import qualified Distribution.Simple.LocalBuildInfo as LBI
import Distribution.Simple.Program.Db
import Distribution.Simple.Program.Find
import Distribution.Simple.Program.Run
import Distribution.Simple.Setup.Common
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
import Distribution.Utils.Path
import Distribution.Verbosity

import qualified Control.Exception as CE
import qualified Data.ByteString.Lazy as LBS
import System.Directory
  ( canonicalizePath
  , createDirectoryIfMissing
  , doesDirectoryExist
  , doesFileExist
  , getCurrentDirectory
  , removeDirectoryRecursive
  , removeFile
  , setCurrentDirectory
  )
import System.IO (hClose, hPutStr)
import qualified System.Process as Process

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

  let mbWorkDir :: Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir = LocalBuildInfo -> Maybe (SymbolicPath CWD ('Dir Pkg))
LBI.mbWorkDirLBI LocalBuildInfo
lbi
  existingEnv <- IO [(FilePath, FilePath)]
getEnvironment

  let cmd =
        Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPathX 'AllowAbsolute Pkg ('Dir Build) -> FilePath
forall from (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPathX allowAbsolute from to -> FilePath
interpretSymbolicPath Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir (LocalBuildInfo -> SymbolicPathX 'AllowAbsolute Pkg ('Dir Build)
LBI.buildDir LocalBuildInfo
lbi)
          FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> TestSuite -> FilePath
stubName TestSuite
suite
          FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> TestSuite -> FilePath
stubName TestSuite
suite FilePath -> FilePath -> FilePath
forall p. FileLike p => p -> FilePath -> p
<.> Platform -> FilePath
exeExtension (LocalBuildInfo -> Platform
LBI.hostPlatform LocalBuildInfo
lbi)
      tDir = SymbolicPathX 'AllowAbsolute Pkg ('Dir Tix) -> FilePath
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> FilePath
i (SymbolicPathX 'AllowAbsolute Pkg ('Dir Tix) -> FilePath)
-> SymbolicPathX 'AllowAbsolute Pkg ('Dir Tix) -> FilePath
forall a b. (a -> b) -> a -> b
$ SymbolicPath Pkg ('Dir Dist)
-> Way -> SymbolicPathX 'AllowAbsolute Pkg ('Dir Tix)
tixDir SymbolicPath Pkg ('Dir Dist)
distPref Way
way
  -- Check that the test executable exists.
  exists <- doesFileExist cmd
  unless exists $
    dieWithException verbosity $
      Couldn'tFindTestProgLibV09 cmd

  -- Remove old .tix files if appropriate.
  unless (fromFlag $ testKeepTix flags) $ do
    exists' <- doesDirectoryExist tDir
    when exists' $ removeDirectoryRecursive tDir

  -- Create directory for HPC files.
  createDirectoryIfMissing True tDir

  -- Write summary notices indicating start of test suite
  notice verbosity $ summarizeSuiteStart testName'

  suiteLog <- CE.bracket openCabalTemp deleteIfExists $ \FilePath
tempLog -> do
    -- Compute the appropriate environment for running the test suite
    let progDb :: ProgramDb
progDb = LocalBuildInfo -> ProgramDb
LBI.withPrograms LocalBuildInfo
lbi
        pathVar :: ProgramSearchPath
pathVar = ProgramDb -> ProgramSearchPath
progSearchPath ProgramDb
progDb
        envOverrides :: [(FilePath, Maybe FilePath)]
envOverrides = ProgramDb -> [(FilePath, Maybe FilePath)]
progOverrideEnv ProgramDb
progDb
    newPath <- ProgramSearchPath -> IO FilePath
programSearchPathAsPATHVar ProgramSearchPath
pathVar
    overrideEnv <- fromMaybe [] <$> getEffectiveEnvironment ([("PATH", Just newPath)] ++ envOverrides)

    -- Run 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) ([PathTemplate] -> [FilePath]) -> [PathTemplate] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ TestFlags -> [PathTemplate]
testOptions TestFlags
flags
        tixFile = SymbolicPathX 'AllowAbsolute Pkg 'File -> FilePath
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> FilePath
i (SymbolicPathX 'AllowAbsolute Pkg 'File -> FilePath)
-> SymbolicPathX 'AllowAbsolute Pkg 'File -> FilePath
forall a b. (a -> b) -> a -> b
$ SymbolicPath Pkg ('Dir Dist)
-> Way -> FilePath -> SymbolicPathX 'AllowAbsolute Pkg 'File
tixFilePath SymbolicPath Pkg ('Dir Dist)
distPref Way
way FilePath
testName'
        shellEnv =
          [(FilePath
"HPCTIXFILE", FilePath
tixFile) | Bool
isCoverageEnabled]
            [(FilePath, FilePath)]
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. [a] -> [a] -> [a]
++ [(FilePath, FilePath)]
overrideEnv
            [(FilePath, FilePath)]
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. [a] -> [a] -> [a]
++ [(FilePath, FilePath)]
existingEnv
    -- 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
          cpath <- canonicalizePath $ i $ LBI.componentBuildDir lbi clbi
          return (addLibraryPath os (cpath : paths) shellEnv)
        else return shellEnv
    let (cmd', opts') = case testWrapper flags of
          Flag FilePath
path -> (FilePath
path, FilePath
cmd FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
opts)
          Flag FilePath
NoFlag -> (FilePath
cmd, [FilePath]
opts)

    -- TODO: this setup is broken,
    -- if the test output is too big, we will deadlock.
    (rOut, wOut) <- Process.createPipe
    (exitcode, logText) <- rawSystemProcAction
      verbosity
      (proc cmd' opts')
        { Process.env = Just shellEnv'
        , Process.std_in = Process.CreatePipe
        , Process.std_out = Process.UseHandle wOut
        , Process.std_err = Process.UseHandle wOut
        }
      $ \Maybe Handle
mIn Maybe Handle
_ Maybe Handle
_ -> do
        let wIn :: Handle
wIn = Maybe Handle -> Handle
fromCreatePipe Maybe Handle
mIn
        Handle -> FilePath -> IO ()
hPutStr Handle
wIn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ (FilePath, UnqualComponentName) -> FilePath
forall a. Show a => a -> FilePath
show (FilePath
tempLog, TestSuite -> UnqualComponentName
PD.testName TestSuite
suite)
        Handle -> IO ()
hClose Handle
wIn

        -- Append contents of temporary log file to the final human-
        -- readable log file
        logText <- Handle -> IO ByteString
LBS.hGetContents Handle
rOut
        -- Force the IO manager to drain the test output pipe
        _ <- evaluate (force logText)
        return logText
    unless (exitcode == ExitSuccess) $
      debug verbosity $
        cmd ++ " returned " ++ show exitcode

    -- Generate final log file name
    let finalLogName TestSuiteLog
l =
          Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 1) -> FilePath
forall from (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPathX allowAbsolute from to -> FilePath
interpretSymbolicPath Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 1)
forall {c3 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg c3
testLogDir
            FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> 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
              (UnqualComponentName -> FilePath
unUnqualComponentName (UnqualComponentName -> FilePath)
-> UnqualComponentName -> FilePath
forall a b. (a -> b) -> a -> b
$ TestSuiteLog -> UnqualComponentName
testSuiteName TestSuiteLog
l)
              (TestSuiteLog -> TestLogs
testLogs TestSuiteLog
l)
    -- Generate TestSuiteLog from executable exit code and a machine-
    -- readable test log
    suiteLog <-
      fmap
        ( \FilePath
s ->
            (\TestSuiteLog
l -> TestSuiteLog
l{logFile = finalLogName l})
              (TestSuiteLog -> TestSuiteLog)
-> (Maybe TestSuiteLog -> TestSuiteLog)
-> Maybe TestSuiteLog
-> TestSuiteLog
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestSuiteLog -> Maybe TestSuiteLog -> TestSuiteLog
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> TestSuiteLog
forall a. HasCallStack => FilePath -> a
error (FilePath -> TestSuiteLog) -> FilePath -> TestSuiteLog
forall a b. (a -> b) -> a -> b
$ FilePath
"panic! read @TestSuiteLog " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
s)
              (Maybe TestSuiteLog -> TestSuiteLog)
-> Maybe TestSuiteLog -> TestSuiteLog
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe TestSuiteLog
forall a. Read a => FilePath -> Maybe a
readMaybe FilePath
s -- TODO: eradicateNoParse
        )
        $ readFile tempLog

    -- Write summary notice to log file indicating start of test suite
    appendFile (logFile suiteLog) $ summarizeSuiteStart testName'

    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 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
        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. Ord a => a -> a -> Bool
> TestShowDetails
Never)
              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) Bool -> Bool -> Bool
|| TestShowDetails
details TestShowDetails -> TestShowDetails -> Bool
forall a. Eq a => a -> a -> Bool
== TestShowDetails
Always)
              Bool -> Bool -> Bool
&& Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
normal
    whenPrinting $ do
      LBS.putStr logText
      putChar '\n'

    return suiteLog

  -- 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
    i :: SymbolicPathX allowAbsolute Pkg to -> FilePath
i = LocalBuildInfo -> SymbolicPathX allowAbsolute Pkg to -> FilePath
forall (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
LocalBuildInfo -> SymbolicPathX allowAbsolute Pkg to -> FilePath
LBI.interpretSymbolicPathLBI LocalBuildInfo
lbi
    common :: CommonSetupFlags
common = TestFlags -> CommonSetupFlags
testCommonFlags TestFlags
flags
    testName' :: FilePath
testName' = UnqualComponentName -> FilePath
unUnqualComponentName (UnqualComponentName -> FilePath)
-> UnqualComponentName -> FilePath
forall a b. (a -> b) -> a -> b
$ TestSuite -> UnqualComponentName
PD.testName TestSuite
suite

    deleteIfExists :: FilePath -> IO ()
deleteIfExists FilePath
file = do
      exists <- FilePath -> IO Bool
doesFileExist FilePath
file
      when exists $ removeFile file

    testLogDir :: SymbolicPathX 'AllowAbsolute Pkg c3
testLogDir = SymbolicPath Pkg ('Dir Dist)
distPref SymbolicPath Pkg ('Dir Dist)
-> RelativePath Dist c3 -> SymbolicPathX 'AllowAbsolute Pkg c3
forall p q r. PathLike p q r => p -> q -> r
</> FilePath -> RelativePath Dist c3
forall from (to :: FileOrDir).
HasCallStack =>
FilePath -> RelativePath from to
makeRelativePathEx FilePath
"test"
    openCabalTemp :: IO FilePath
openCabalTemp = do
      (f, h) <- FilePath -> FilePath -> IO (FilePath, Handle)
openTempFile (SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 0) -> FilePath
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> FilePath
i SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 0)
forall {c3 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg c3
testLogDir) (FilePath -> IO (FilePath, Handle))
-> FilePath -> IO (FilePath, Handle)
forall a b. (a -> b) -> a -> b
$ FilePath
"cabal-test-" FilePath -> FilePath -> FilePath
forall p. FileLike p => p -> FilePath -> p
<.> FilePath
"log"
      hClose h >> return f

    distPref :: SymbolicPath Pkg ('Dir Dist)
distPref = Flag (SymbolicPath Pkg ('Dir Dist)) -> SymbolicPath Pkg ('Dir Dist)
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag (SymbolicPath Pkg ('Dir Dist))
 -> SymbolicPath Pkg ('Dir Dist))
-> Flag (SymbolicPath Pkg ('Dir Dist))
-> SymbolicPath Pkg ('Dir Dist)
forall a b. (a -> b) -> a -> b
$ CommonSetupFlags -> Flag (SymbolicPath Pkg ('Dir Dist))
setupDistPref CommonSetupFlags
common
    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
$ CommonSetupFlags -> Flag Verbosity
setupVerbosity CommonSetupFlags
common

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

-- Test stub ----------

-- | The filename of the source file for the stub executable associated with a
-- library 'TestSuite'.
stubFilePath :: PD.TestSuite -> FilePath
stubFilePath :: TestSuite -> FilePath
stubFilePath TestSuite
t = TestSuite -> FilePath
stubName TestSuite
t FilePath -> FilePath -> FilePath
forall p. FileLike p => p -> FilePath -> p
<.> FilePath
"hs"

-- | Write the source file for a library 'TestSuite' stub executable.
writeSimpleTestStub
  :: PD.TestSuite
  -- ^ library 'TestSuite' for which a stub
  -- is being created
  -> FilePath
  -- ^ path to directory where stub source
  -- should be located
  -> IO ()
writeSimpleTestStub :: TestSuite -> FilePath -> IO ()
writeSimpleTestStub TestSuite
t FilePath
dir = do
  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
dir
  let filename :: FilePath
filename = FilePath
dir FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> TestSuite -> FilePath
stubFilePath TestSuite
t
      m :: ModuleName
m = case TestSuite -> TestSuiteInterface
PD.testInterface TestSuite
t of
        PD.TestSuiteLibV09 Version
_ ModuleName
m' -> ModuleName
m'
        TestSuiteInterface
_ -> FilePath -> ModuleName
forall a. HasCallStack => FilePath -> a
error FilePath
"writeSimpleTestStub: invalid TestSuite passed"
  FilePath -> FilePath -> IO ()
writeFile FilePath
filename (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ ModuleName -> FilePath
simpleTestStub ModuleName
m

-- | Source code for library test suite stub executable
simpleTestStub :: ModuleName -> String
simpleTestStub :: ModuleName -> FilePath
simpleTestStub ModuleName
m =
  [FilePath] -> FilePath
unlines
    [ FilePath
"module Main ( main ) where"
    , FilePath
"import Distribution.Simple.Test.LibV09 ( stubMain )"
    , FilePath
"import " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Doc -> FilePath
forall a. Show a => a -> FilePath
show (ModuleName -> Doc
forall a. Pretty a => a -> Doc
pretty ModuleName
m) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" ( tests )"
    , FilePath
"main :: IO ()"
    , FilePath
"main = stubMain tests"
    ]

-- | Main function for test stubs. Once, it was written directly into the stub,
-- but minimizing the amount of code actually in the stub maximizes the number
-- of detectable errors when Cabal is compiled.
stubMain :: IO [Test] -> IO ()
stubMain :: IO [Test] -> IO ()
stubMain IO [Test]
tests = do
  (f, n) <- (FilePath -> (FilePath, UnqualComponentName))
-> IO FilePath -> IO (FilePath, UnqualComponentName)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\FilePath
s -> (FilePath, UnqualComponentName)
-> Maybe (FilePath, UnqualComponentName)
-> (FilePath, UnqualComponentName)
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> (FilePath, UnqualComponentName)
forall a. HasCallStack => FilePath -> a
error (FilePath -> (FilePath, UnqualComponentName))
-> FilePath -> (FilePath, UnqualComponentName)
forall a b. (a -> b) -> a -> b
$ FilePath
"panic! read " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
s) (Maybe (FilePath, UnqualComponentName)
 -> (FilePath, UnqualComponentName))
-> Maybe (FilePath, UnqualComponentName)
-> (FilePath, UnqualComponentName)
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe (FilePath, UnqualComponentName)
forall a. Read a => FilePath -> Maybe a
readMaybe FilePath
s) IO FilePath
getContents -- TODO: eradicateNoParse
  dir <- getCurrentDirectory
  results <- (tests >>= stubRunTests) `CE.catch` errHandler
  setCurrentDirectory dir
  stubWriteLog f n results
  where
    errHandler :: CE.SomeException -> IO TestLogs
    errHandler :: SomeException -> IO TestLogs
errHandler SomeException
e = case SomeException -> Maybe AsyncException
forall e. Exception e => SomeException -> Maybe e
CE.fromException SomeException
e of
      Just AsyncException
CE.UserInterrupt -> SomeException -> IO TestLogs
forall e a. (HasCallStack, Exception e) => e -> IO a
CE.throwIO SomeException
e
      Maybe AsyncException
_ ->
        TestLogs -> IO TestLogs
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TestLogs -> IO TestLogs) -> TestLogs -> IO TestLogs
forall a b. (a -> b) -> a -> b
$
          TestLog
            { testName :: FilePath
testName = FilePath
"Cabal test suite exception"
            , testOptionsReturned :: [(FilePath, FilePath)]
testOptionsReturned = []
            , testResult :: Result
testResult = FilePath -> Result
Error (FilePath -> Result) -> FilePath -> Result
forall a b. (a -> b) -> a -> b
$ SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
e
            }

-- | The test runner used in library "TestSuite" stub executables.  Runs a list
-- of 'Test's.  An executable calling this function is meant to be invoked as
-- the child of a Cabal process during @.\/setup test@.  A 'TestSuiteLog',
-- provided by Cabal, is read from the standard input; it supplies the name of
-- the test suite and the location of the machine-readable test suite log file.
-- Human-readable log information is written to the standard output for capture
-- by the calling Cabal process.
stubRunTests :: [Test] -> IO TestLogs
stubRunTests :: [Test] -> IO TestLogs
stubRunTests [Test]
tests = do
  logs <- (Test -> IO TestLogs) -> [Test] -> IO [TestLogs]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Test -> IO TestLogs
stubRunTests' [Test]
tests
  return $ GroupLogs "Default" logs
  where
    stubRunTests' :: Test -> IO TestLogs
stubRunTests' (Test TestInstance
t) = do
      l <- TestInstance -> IO Progress
run TestInstance
t IO Progress -> (Progress -> IO TestLogs) -> IO TestLogs
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Progress -> IO TestLogs
finish
      summarizeTest normal Always l
      return l
      where
        finish :: Progress -> IO TestLogs
finish (Finished Result
result) =
          TestLogs -> IO TestLogs
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
            TestLog
              { testName :: FilePath
testName = TestInstance -> FilePath
name TestInstance
t
              , testOptionsReturned :: [(FilePath, FilePath)]
testOptionsReturned = TestInstance -> [(FilePath, FilePath)]
defaultOptions TestInstance
t
              , testResult :: Result
testResult = Result
result
              }
        finish (Progress FilePath
_ IO Progress
next) = IO Progress
next IO Progress -> (Progress -> IO TestLogs) -> IO TestLogs
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Progress -> IO TestLogs
finish
    stubRunTests' g :: Test
g@(Group{}) = do
      logs <- (Test -> IO TestLogs) -> [Test] -> IO [TestLogs]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Test -> IO TestLogs
stubRunTests' ([Test] -> IO [TestLogs]) -> [Test] -> IO [TestLogs]
forall a b. (a -> b) -> a -> b
$ Test -> [Test]
groupTests Test
g
      return $ GroupLogs (groupName g) logs
    stubRunTests' (ExtraOptions [OptionDescr]
_ Test
t) = Test -> IO TestLogs
stubRunTests' Test
t
    maybeDefaultOption :: OptionDescr -> Maybe (FilePath, FilePath)
maybeDefaultOption OptionDescr
opt =
      Maybe (FilePath, FilePath)
-> (FilePath -> Maybe (FilePath, FilePath))
-> Maybe FilePath
-> Maybe (FilePath, FilePath)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe (FilePath, FilePath)
forall a. Maybe a
Nothing (\FilePath
d -> (FilePath, FilePath) -> Maybe (FilePath, FilePath)
forall a. a -> Maybe a
Just (OptionDescr -> FilePath
optionName OptionDescr
opt, FilePath
d)) (Maybe FilePath -> Maybe (FilePath, FilePath))
-> Maybe FilePath -> Maybe (FilePath, FilePath)
forall a b. (a -> b) -> a -> b
$ OptionDescr -> Maybe FilePath
optionDefault OptionDescr
opt
    defaultOptions :: TestInstance -> [(FilePath, FilePath)]
defaultOptions TestInstance
testInst = (OptionDescr -> Maybe (FilePath, FilePath))
-> [OptionDescr] -> [(FilePath, FilePath)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe OptionDescr -> Maybe (FilePath, FilePath)
maybeDefaultOption ([OptionDescr] -> [(FilePath, FilePath)])
-> [OptionDescr] -> [(FilePath, FilePath)]
forall a b. (a -> b) -> a -> b
$ TestInstance -> [OptionDescr]
options TestInstance
testInst

-- | From a test stub, write the 'TestSuiteLog' to temporary file for the calling
-- Cabal process to read.
stubWriteLog :: FilePath -> UnqualComponentName -> TestLogs -> IO ()
stubWriteLog :: FilePath -> UnqualComponentName -> TestLogs -> IO ()
stubWriteLog FilePath
f UnqualComponentName
n TestLogs
logs = do
  let testLog :: TestSuiteLog
testLog = TestSuiteLog{testSuiteName :: UnqualComponentName
testSuiteName = UnqualComponentName
n, testLogs :: TestLogs
testLogs = TestLogs
logs, logFile :: FilePath
logFile = FilePath
f}
  FilePath -> FilePath -> IO ()
writeFile (TestSuiteLog -> FilePath
logFile TestSuiteLog
testLog) (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ TestSuiteLog -> FilePath
forall a. Show a => a -> FilePath
show TestSuiteLog
testLog
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TestLogs -> Bool
suiteError TestLogs
logs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO ()) -> ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
2
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TestLogs -> Bool
suiteFailed TestLogs
logs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO ()) -> ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
1
  IO ()
forall a. IO a
exitSuccess