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

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

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

import Distribution.Compat.Environment
import Distribution.Compat.Internal.TempFile
import Distribution.ModuleName
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 qualified Control.Exception as CE
import qualified Data.ByteString.Lazy as LBS
import System.Directory
    ( createDirectoryIfMissing, canonicalizePath
    , doesDirectoryExist, doesFileExist
    , getCurrentDirectory, removeDirectoryRecursive, removeFile
    , setCurrentDirectory )
import System.FilePath ( (</>), (<.>) )
import System.IO ( hClose, hPutStr )
import Distribution.Compat.Process (proc)
import qualified System.Process as Process

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

    String
pwd <- IO String
getCurrentDirectory
    [(String, String)]
existingEnv <- IO [(String, String)]
getEnvironment

    let cmd :: String
cmd = LocalBuildInfo -> String
LBI.buildDir LocalBuildInfo
lbi String -> String -> String
</> TestSuite -> String
stubName TestSuite
suite
                  String -> String -> String
</> TestSuite -> String
stubName TestSuite
suite String -> String -> String
<.> Platform -> String
exeExtension (LocalBuildInfo -> Platform
LBI.hostPlatform LocalBuildInfo
lbi)
    -- Check that the test executable exists.
    Bool
exists <- String -> IO Bool
doesFileExist String
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 -> String -> IO ()
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Could not find test program \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmd
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\". 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
        let tDir :: String
tDir = String -> Way -> String -> String
tixDir String
distPref Way
way String
testName'
        Bool
exists' <- String -> IO Bool
doesDirectoryExist String
tDir
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists' (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeDirectoryRecursive String
tDir

    -- Create directory for HPC files.
    Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Way -> String -> String
tixDir String
distPref Way
way String
testName'

    -- Write summary notices indicating start of test suite
    Verbosity -> String -> IO ()
notice Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String
summarizeSuiteStart String
testName'

    TestSuiteLog
suiteLog <- IO String
-> (String -> IO ())
-> (String -> IO TestSuiteLog)
-> IO TestSuiteLog
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
CE.bracket IO String
openCabalTemp String -> IO ()
deleteIfExists ((String -> IO TestSuiteLog) -> IO TestSuiteLog)
-> (String -> IO TestSuiteLog) -> IO TestSuiteLog
forall a b. (a -> b) -> a -> b
$ \String
tempLog -> do

        -- Run test executable
        let opts :: [String]
opts = (PathTemplate -> String) -> [PathTemplate] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (PackageDescription
-> LocalBuildInfo -> TestSuite -> PathTemplate -> String
testOption PackageDescription
pkg_descr LocalBuildInfo
lbi TestSuite
suite) ([PathTemplate] -> [String]) -> [PathTemplate] -> [String]
forall a b. (a -> b) -> a -> b
$ TestFlags -> [PathTemplate]
testOptions TestFlags
flags
            dataDirPath :: String
dataDirPath = String
pwd String -> String -> String
</> PackageDescription -> String
PD.dataDir PackageDescription
pkg_descr
            tixFile :: String
tixFile = String
pwd String -> String -> String
</> String -> Way -> String -> String
tixFilePath String
distPref Way
way String
testName'
            pkgPathEnv :: [(String, String)]
pkgPathEnv = (PackageDescription -> String -> String
pkgPathEnvVar PackageDescription
pkg_descr String
"datadir", String
dataDirPath)
                       (String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
: [(String, String)]
existingEnv
            shellEnv :: [(String, String)]
shellEnv = [(String
"HPCTIXFILE", String
tixFile) | Bool
isCoverageEnabled]
                     [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++ [(String, String)]
pkgPathEnv
        -- Add (DY)LD_LIBRARY_PATH if needed
        [(String, String)]
shellEnv' <-
          if LocalBuildInfo -> Bool
LBI.withDynExe LocalBuildInfo
lbi
          then do
            let (Platform Arch
_ OS
os) = LocalBuildInfo -> Platform
LBI.hostPlatform LocalBuildInfo
lbi
            [String]
paths <- Bool
-> Bool -> LocalBuildInfo -> ComponentLocalBuildInfo -> IO [String]
LBI.depLibraryPaths Bool
True Bool
False LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi
            String
cpath <- String -> IO String
canonicalizePath (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ LocalBuildInfo -> ComponentLocalBuildInfo -> String
LBI.componentBuildDir LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi
            [(String, String)] -> IO [(String, String)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (OS -> [String] -> [(String, String)] -> [(String, String)]
addLibraryPath OS
os (String
cpath String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
paths) [(String, String)]
shellEnv)
          else [(String, String)] -> IO [(String, String)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [(String, String)]
shellEnv
        let (String
cmd', [String]
opts') = case TestFlags -> Flag String
testWrapper TestFlags
flags of
                              Flag String
path -> (String
path, String
cmdString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
opts)
                              Flag String
NoFlag -> (String
cmd, [String]
opts)

        -- TODO: this setup is broken,
        -- if the test output is too big, we will deadlock.
        (Handle
rOut, Handle
wOut) <- IO (Handle, Handle)
Process.createPipe
        (ExitCode
exitcode, ByteString
logText) <- Verbosity
-> CreateProcess
-> (Maybe Handle -> Maybe Handle -> Maybe Handle -> IO ByteString)
-> IO (ExitCode, ByteString)
forall a.
Verbosity
-> CreateProcess
-> (Maybe Handle -> Maybe Handle -> Maybe Handle -> IO a)
-> IO (ExitCode, a)
rawSystemProcAction Verbosity
verbosity
            (String -> [String] -> CreateProcess
proc String
cmd' [String]
opts') { env :: Maybe [(String, String)]
Process.env           = [(String, String)] -> Maybe [(String, String)]
forall a. a -> Maybe a
Just [(String, String)]
shellEnv'
                              , std_in :: StdStream
Process.std_in        = StdStream
Process.CreatePipe
                              , std_out :: StdStream
Process.std_out       = Handle -> StdStream
Process.UseHandle Handle
wOut
                              , std_err :: StdStream
Process.std_err       = Handle -> StdStream
Process.UseHandle Handle
wOut
                              } ((Maybe Handle -> Maybe Handle -> Maybe Handle -> IO ByteString)
 -> IO (ExitCode, ByteString))
-> (Maybe Handle -> Maybe Handle -> Maybe Handle -> IO ByteString)
-> IO (ExitCode, ByteString)
forall a b. (a -> b) -> a -> b
$ \Maybe Handle
mIn Maybe Handle
_ Maybe Handle
_ -> do
          let wIn :: Handle
wIn = Maybe Handle -> Handle
fromCreatePipe Maybe Handle
mIn
          Handle -> String -> IO ()
hPutStr Handle
wIn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ (String, UnqualComponentName) -> String
forall a. Show a => a -> String
show (String
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
          ByteString
logText <- Handle -> IO ByteString
LBS.hGetContents Handle
rOut
          -- Force the IO manager to drain the test output pipe
          ByteString
_ <- ByteString -> IO ByteString
forall a. a -> IO a
evaluate (ByteString -> ByteString
forall a. NFData a => a -> a
force ByteString
logText)
          ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
logText
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ExitCode
exitcode ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          Verbosity -> String -> IO ()
debug Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
cmd String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" returned " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExitCode -> String
forall a. Show a => a -> String
show ExitCode
exitcode

        -- Generate final log file name
        let finalLogName :: TestSuiteLog -> String
finalLogName TestSuiteLog
l = String
testLogDir
                             String -> String -> String
</> PathTemplate
-> PackageDescription
-> LocalBuildInfo
-> String
-> TestLogs
-> String
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 -> String
unUnqualComponentName (UnqualComponentName -> String) -> UnqualComponentName -> String
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
        TestSuiteLog
suiteLog <- (String -> TestSuiteLog) -> IO String -> IO TestSuiteLog
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\String
s -> (\TestSuiteLog
l -> TestSuiteLog
l { logFile :: String
logFile = TestSuiteLog -> String
finalLogName TestSuiteLog
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 (String -> TestSuiteLog
forall a. HasCallStack => String -> a
error (String -> TestSuiteLog) -> String -> TestSuiteLog
forall a b. (a -> b) -> a -> b
$ String
"panic! read @TestSuiteLog " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
s) (Maybe TestSuiteLog -> TestSuiteLog)
-> Maybe TestSuiteLog -> TestSuiteLog
forall a b. (a -> b) -> a -> b
$ String -> Maybe TestSuiteLog
forall a. Read a => String -> Maybe a
readMaybe String
s) -- TODO: eradicateNoParse
                    (IO String -> IO TestSuiteLog) -> IO String -> IO TestSuiteLog
forall a b. (a -> b) -> a -> b
$ String -> IO String
readFile String
tempLog

        -- Write summary notice to log file indicating start of test suite
        String -> String -> IO ()
appendFile (TestSuiteLog -> String
logFile TestSuiteLog
suiteLog) (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String
summarizeSuiteStart String
testName'

        String -> ByteString -> IO ()
LBS.appendFile (TestSuiteLog -> String
logFile TestSuiteLog
suiteLog) ByteString
logText

        -- Write end-of-suite summary notice to log file
        String -> String -> IO ()
appendFile (TestSuiteLog -> String
logFile TestSuiteLog
suiteLog) (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ TestSuiteLog -> String
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 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
            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. 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
        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'

        TestSuiteLog -> IO TestSuiteLog
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TestSuiteLog
suiteLog

    -- Write summary notice to terminal indicating end of test suite
    Verbosity -> String -> IO ()
notice Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ TestSuiteLog -> String
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 -> String -> IO ()
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity String
"Test coverage is only supported for packages with a library component."
        Just Library
library ->
          Verbosity
-> LocalBuildInfo
-> String
-> String
-> TestSuite
-> Library
-> IO ()
markupTest Verbosity
verbosity LocalBuildInfo
lbi String
distPref (PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow (PackageIdentifier -> String) -> PackageIdentifier -> String
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' :: String
testName' = UnqualComponentName -> String
unUnqualComponentName (UnqualComponentName -> String) -> UnqualComponentName -> String
forall a b. (a -> b) -> a -> b
$ TestSuite -> UnqualComponentName
PD.testName TestSuite
suite

    deleteIfExists :: String -> IO ()
deleteIfExists String
file = do
        Bool
exists <- String -> IO Bool
doesFileExist String
file
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeFile String
file

    testLogDir :: String
testLogDir = String
distPref String -> String -> String
</> String
"test"
    openCabalTemp :: IO String
openCabalTemp = do
        (String
f, Handle
h) <- String -> String -> IO (String, Handle)
openTempFile String
testLogDir (String -> IO (String, Handle)) -> String -> IO (String, Handle)
forall a b. (a -> b) -> a -> b
$ String
"cabal-test-" String -> String -> String
<.> String
"log"
        Handle -> IO ()
hClose Handle
h IO () -> IO String -> IO String
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
f

    distPref :: String
distPref = Flag String -> String
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag String -> String) -> Flag String -> String
forall a b. (a -> b) -> a -> b
$ TestFlags -> Flag String
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

-- 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 -> String
testOption PackageDescription
pkg_descr LocalBuildInfo
lbi TestSuite
suite PathTemplate
template =
    PathTemplate -> String
fromPathTemplate (PathTemplate -> String) -> PathTemplate -> String
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, String -> PathTemplate
toPathTemplate (String -> PathTemplate) -> String -> PathTemplate
forall a b. (a -> b) -> a -> b
$ UnqualComponentName -> String
unUnqualComponentName (UnqualComponentName -> String) -> UnqualComponentName -> String
forall a b. (a -> b) -> a -> b
$ TestSuite -> UnqualComponentName
PD.testName TestSuite
suite)]

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

-- | The name of the stub executable associated with a library 'TestSuite'.
stubName :: PD.TestSuite -> FilePath
stubName :: TestSuite -> String
stubName TestSuite
t = UnqualComponentName -> String
unUnqualComponentName (TestSuite -> UnqualComponentName
PD.testName TestSuite
t) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Stub"

-- | The filename of the source file for the stub executable associated with a
-- library 'TestSuite'.
stubFilePath :: PD.TestSuite -> FilePath
stubFilePath :: TestSuite -> String
stubFilePath TestSuite
t = TestSuite -> String
stubName TestSuite
t String -> String -> String
<.> String
"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 -> String -> IO ()
writeSimpleTestStub TestSuite
t String
dir = do
    Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
dir
    let filename :: String
filename = String
dir String -> String -> String
</> TestSuite -> String
stubFilePath TestSuite
t
        m :: ModuleName
m = case TestSuite -> TestSuiteInterface
PD.testInterface TestSuite
t of
            PD.TestSuiteLibV09 Version
_  ModuleName
m' -> ModuleName
m'
            TestSuiteInterface
_                        -> String -> ModuleName
forall a. HasCallStack => String -> a
error String
"writeSimpleTestStub: invalid TestSuite passed"
    String -> String -> IO ()
writeFile String
filename (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ ModuleName -> String
simpleTestStub ModuleName
m

-- | Source code for library test suite stub executable
simpleTestStub :: ModuleName -> String
simpleTestStub :: ModuleName -> String
simpleTestStub ModuleName
m = [String] -> String
unlines
    [ String
"module Main ( main ) where"
    , String
"import Distribution.Simple.Test.LibV09 ( stubMain )"
    , String
"import " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc -> String
forall a. Show a => a -> String
show (ModuleName -> Doc
forall a. Pretty a => a -> Doc
pretty ModuleName
m) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ( tests )"
    , String
"main :: IO ()"
    , String
"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
    (String
f, UnqualComponentName
n) <- (String -> (String, UnqualComponentName))
-> IO String -> IO (String, UnqualComponentName)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\String
s -> (String, UnqualComponentName)
-> Maybe (String, UnqualComponentName)
-> (String, UnqualComponentName)
forall a. a -> Maybe a -> a
fromMaybe (String -> (String, UnqualComponentName)
forall a. HasCallStack => String -> a
error (String -> (String, UnqualComponentName))
-> String -> (String, UnqualComponentName)
forall a b. (a -> b) -> a -> b
$ String
"panic! read " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
s) (Maybe (String, UnqualComponentName)
 -> (String, UnqualComponentName))
-> Maybe (String, UnqualComponentName)
-> (String, UnqualComponentName)
forall a b. (a -> b) -> a -> b
$ String -> Maybe (String, UnqualComponentName)
forall a. Read a => String -> Maybe a
readMaybe String
s) IO String
getContents -- TODO: eradicateNoParse
    String
dir <- IO String
getCurrentDirectory
    TestLogs
results <- (IO [Test]
tests IO [Test] -> ([Test] -> 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
>>= [Test] -> IO TestLogs
stubRunTests) IO TestLogs -> (SomeException -> IO TestLogs) -> IO TestLogs
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`CE.catch` SomeException -> IO TestLogs
errHandler
    String -> IO ()
setCurrentDirectory String
dir
    String -> UnqualComponentName -> TestLogs -> IO ()
stubWriteLog String
f UnqualComponentName
n TestLogs
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. 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 :: String
testName = String
"Cabal test suite exception",
                                testOptionsReturned :: [(String, String)]
testOptionsReturned = [],
                                testResult :: Result
testResult = String -> Result
Error (String -> Result) -> String -> Result
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
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
    [TestLogs]
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
    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
$ String -> [TestLogs] -> TestLogs
GroupLogs String
"Default" [TestLogs]
logs
  where
    stubRunTests' :: Test -> IO TestLogs
stubRunTests' (Test TestInstance
t) = do
        TestLogs
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
        Verbosity -> TestShowDetails -> TestLogs -> IO ()
summarizeTest Verbosity
normal TestShowDetails
Always TestLogs
l
        TestLogs -> IO TestLogs
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TestLogs
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 :: String
testName = TestInstance -> String
name TestInstance
t
                , testOptionsReturned :: [(String, String)]
testOptionsReturned = TestInstance -> [(String, String)]
defaultOptions TestInstance
t
                , testResult :: Result
testResult = Result
result
                }
        finish (Progress String
_ 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
        [TestLogs]
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
        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
$ String -> [TestLogs] -> TestLogs
GroupLogs (Test -> String
groupName Test
g) [TestLogs]
logs
    stubRunTests' (ExtraOptions [OptionDescr]
_ Test
t) = Test -> IO TestLogs
stubRunTests' Test
t
    maybeDefaultOption :: OptionDescr -> Maybe (String, String)
maybeDefaultOption OptionDescr
opt =
        Maybe (String, String)
-> (String -> Maybe (String, String))
-> Maybe String
-> Maybe (String, String)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe (String, String)
forall a. Maybe a
Nothing (\String
d -> (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just (OptionDescr -> String
optionName OptionDescr
opt, String
d)) (Maybe String -> Maybe (String, String))
-> Maybe String -> Maybe (String, String)
forall a b. (a -> b) -> a -> b
$ OptionDescr -> Maybe String
optionDefault OptionDescr
opt
    defaultOptions :: TestInstance -> [(String, String)]
defaultOptions TestInstance
testInst = (OptionDescr -> Maybe (String, String))
-> [OptionDescr] -> [(String, String)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe OptionDescr -> Maybe (String, String)
maybeDefaultOption ([OptionDescr] -> [(String, String)])
-> [OptionDescr] -> [(String, String)]
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 :: String -> UnqualComponentName -> TestLogs -> IO ()
stubWriteLog String
f UnqualComponentName
n TestLogs
logs = do
    let testLog :: TestSuiteLog
testLog = TestSuiteLog { testSuiteName :: UnqualComponentName
testSuiteName = UnqualComponentName
n, testLogs :: TestLogs
testLogs = TestLogs
logs, logFile :: String
logFile = String
f }
    String -> String -> IO ()
writeFile (TestSuiteLog -> String
logFile TestSuiteLog
testLog) (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ TestSuiteLog -> String
forall a. Show a => a -> String
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