{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
module Distribution.Simple.Test.LibV09
( runTest
, simpleTestStub
, stubFilePath, stubMain, stubName, stubWriteLog
, writeSimpleTestStub
) where
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Types.UnqualComponentName
import Distribution.Compat.CreatePipe
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 System.Process (StdStream(..), waitForProcess)
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
[Char]
pwd <- IO [Char]
getCurrentDirectory
[([Char], [Char])]
existingEnv <- IO [([Char], [Char])]
getEnvironment
let cmd :: [Char]
cmd = LocalBuildInfo -> [Char]
LBI.buildDir LocalBuildInfo
lbi [Char] -> [Char] -> [Char]
</> TestSuite -> [Char]
stubName TestSuite
suite
[Char] -> [Char] -> [Char]
</> TestSuite -> [Char]
stubName TestSuite
suite [Char] -> [Char] -> [Char]
<.> Platform -> [Char]
exeExtension (LocalBuildInfo -> Platform
LBI.hostPlatform LocalBuildInfo
lbi)
Bool
exists <- [Char] -> IO Bool
doesFileExist [Char]
cmd
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists forall a b. (a -> b) -> a -> b
$
forall a. Verbosity -> [Char] -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ [Char]
"Error: Could not find test program \"" forall a. [a] -> [a] -> [a]
++ [Char]
cmd
forall a. [a] -> [a] -> [a]
++ [Char]
"\". Did you build the package first?"
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. WithCallStack (Flag a -> a)
fromFlag forall a b. (a -> b) -> a -> b
$ TestFlags -> Flag Bool
testKeepTix TestFlags
flags) forall a b. (a -> b) -> a -> b
$ do
let tDir :: [Char]
tDir = [Char] -> Way -> [Char] -> [Char]
tixDir [Char]
distPref Way
way [Char]
testName'
Bool
exists' <- [Char] -> IO Bool
doesDirectoryExist [Char]
tDir
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists' forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
removeDirectoryRecursive [Char]
tDir
Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True forall a b. (a -> b) -> a -> b
$ [Char] -> Way -> [Char] -> [Char]
tixDir [Char]
distPref Way
way [Char]
testName'
Verbosity -> [Char] -> IO ()
notice Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
summarizeSuiteStart [Char]
testName'
TestSuiteLog
suiteLog <- forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
CE.bracket IO [Char]
openCabalTemp [Char] -> IO ()
deleteIfExists forall a b. (a -> b) -> a -> b
$ \[Char]
tempLog -> do
(Handle
rOut, Handle
wOut) <- IO (Handle, Handle)
createPipe
(Just Handle
wIn, Maybe Handle
_, Maybe Handle
_, ProcessHandle
process) <- do
let opts :: [[Char]]
opts = forall a b. (a -> b) -> [a] -> [b]
map (PackageDescription
-> LocalBuildInfo -> TestSuite -> PathTemplate -> [Char]
testOption PackageDescription
pkg_descr LocalBuildInfo
lbi TestSuite
suite) forall a b. (a -> b) -> a -> b
$ TestFlags -> [PathTemplate]
testOptions TestFlags
flags
dataDirPath :: [Char]
dataDirPath = [Char]
pwd [Char] -> [Char] -> [Char]
</> PackageDescription -> [Char]
PD.dataDir PackageDescription
pkg_descr
tixFile :: [Char]
tixFile = [Char]
pwd [Char] -> [Char] -> [Char]
</> [Char] -> Way -> [Char] -> [Char]
tixFilePath [Char]
distPref Way
way [Char]
testName'
pkgPathEnv :: [([Char], [Char])]
pkgPathEnv = (PackageDescription -> [Char] -> [Char]
pkgPathEnvVar PackageDescription
pkg_descr [Char]
"datadir", [Char]
dataDirPath)
forall a. a -> [a] -> [a]
: [([Char], [Char])]
existingEnv
shellEnv :: [([Char], [Char])]
shellEnv = [([Char]
"HPCTIXFILE", [Char]
tixFile) | Bool
isCoverageEnabled]
forall a. [a] -> [a] -> [a]
++ [([Char], [Char])]
pkgPathEnv
[([Char], [Char])]
shellEnv' <-
if LocalBuildInfo -> Bool
LBI.withDynExe LocalBuildInfo
lbi
then do
let (Platform Arch
_ OS
os) = LocalBuildInfo -> Platform
LBI.hostPlatform LocalBuildInfo
lbi
[[Char]]
paths <- Bool
-> Bool -> LocalBuildInfo -> ComponentLocalBuildInfo -> IO [[Char]]
LBI.depLibraryPaths Bool
True Bool
False LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi
[Char]
cpath <- [Char] -> IO [Char]
canonicalizePath forall a b. (a -> b) -> a -> b
$ LocalBuildInfo -> ComponentLocalBuildInfo -> [Char]
LBI.componentBuildDir LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi
forall (m :: * -> *) a. Monad m => a -> m a
return (OS -> [[Char]] -> [([Char], [Char])] -> [([Char], [Char])]
addLibraryPath OS
os ([Char]
cpath forall a. a -> [a] -> [a]
: [[Char]]
paths) [([Char], [Char])]
shellEnv)
else forall (m :: * -> *) a. Monad m => a -> m a
return [([Char], [Char])]
shellEnv
case TestFlags -> Flag [Char]
testWrapper TestFlags
flags of
Flag [Char]
path -> Verbosity
-> [Char]
-> [[Char]]
-> Maybe [Char]
-> Maybe [([Char], [Char])]
-> StdStream
-> StdStream
-> StdStream
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcessWithEnv Verbosity
verbosity [Char]
path ([Char]
cmdforall a. a -> [a] -> [a]
:[[Char]]
opts) forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just [([Char], [Char])]
shellEnv')
StdStream
CreatePipe (Handle -> StdStream
UseHandle Handle
wOut) (Handle -> StdStream
UseHandle Handle
wOut)
Flag [Char]
NoFlag -> Verbosity
-> [Char]
-> [[Char]]
-> Maybe [Char]
-> Maybe [([Char], [Char])]
-> StdStream
-> StdStream
-> StdStream
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcessWithEnv Verbosity
verbosity [Char]
cmd [[Char]]
opts forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just [([Char], [Char])]
shellEnv')
StdStream
CreatePipe (Handle -> StdStream
UseHandle Handle
wOut) (Handle -> StdStream
UseHandle Handle
wOut)
Handle -> [Char] -> IO ()
hPutStr Handle
wIn forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show ([Char]
tempLog, TestSuite -> UnqualComponentName
PD.testName TestSuite
suite)
Handle -> IO ()
hClose Handle
wIn
ByteString
logText <- Handle -> IO ByteString
LBS.hGetContents Handle
rOut
ByteString
_ <- forall a. a -> IO a
evaluate (forall a. NFData a => a -> a
force ByteString
logText)
ExitCode
exitcode <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
process
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ExitCode
exitcode forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess) forall a b. (a -> b) -> a -> b
$ do
Verbosity -> [Char] -> IO ()
debug Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ [Char]
cmd forall a. [a] -> [a] -> [a]
++ [Char]
" returned " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show ExitCode
exitcode
let finalLogName :: TestSuiteLog -> [Char]
finalLogName TestSuiteLog
l = [Char]
testLogDir
[Char] -> [Char] -> [Char]
</> PathTemplate
-> PackageDescription
-> LocalBuildInfo
-> [Char]
-> TestLogs
-> [Char]
testSuiteLogPath
(forall a. WithCallStack (Flag a -> a)
fromFlag forall a b. (a -> b) -> a -> b
$ TestFlags -> Flag PathTemplate
testHumanLog TestFlags
flags) PackageDescription
pkg_descr LocalBuildInfo
lbi
(UnqualComponentName -> [Char]
unUnqualComponentName forall a b. (a -> b) -> a -> b
$ TestSuiteLog -> UnqualComponentName
testSuiteName TestSuiteLog
l) (TestSuiteLog -> TestLogs
testLogs TestSuiteLog
l)
TestSuiteLog
suiteLog <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[Char]
s -> (\TestSuiteLog
l -> TestSuiteLog
l { logFile :: [Char]
logFile = TestSuiteLog -> [Char]
finalLogName TestSuiteLog
l })
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"panic! read @TestSuiteLog " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
s) forall a b. (a -> b) -> a -> b
$ forall a. Read a => [Char] -> Maybe a
readMaybe [Char]
s)
forall a b. (a -> b) -> a -> b
$ [Char] -> IO [Char]
readFile [Char]
tempLog
[Char] -> [Char] -> IO ()
appendFile (TestSuiteLog -> [Char]
logFile TestSuiteLog
suiteLog) forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
summarizeSuiteStart [Char]
testName'
[Char] -> ByteString -> IO ()
LBS.appendFile (TestSuiteLog -> [Char]
logFile TestSuiteLog
suiteLog) ByteString
logText
[Char] -> [Char] -> IO ()
appendFile (TestSuiteLog -> [Char]
logFile TestSuiteLog
suiteLog) forall a b. (a -> b) -> a -> b
$ TestSuiteLog -> [Char]
summarizeSuiteFinish TestSuiteLog
suiteLog
let details :: TestShowDetails
details = forall a. WithCallStack (Flag a -> a)
fromFlag forall a b. (a -> b) -> a -> b
$ TestFlags -> Flag TestShowDetails
testShowDetails TestFlags
flags
whenPrinting :: IO () -> IO ()
whenPrinting = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when forall a b. (a -> b) -> a -> b
$ (TestShowDetails
details forall a. Ord a => a -> a -> Bool
> TestShowDetails
Never)
Bool -> Bool -> Bool
&& (Bool -> Bool
not (TestLogs -> Bool
suitePassed forall a b. (a -> b) -> a -> b
$ TestSuiteLog -> TestLogs
testLogs TestSuiteLog
suiteLog) Bool -> Bool -> Bool
|| TestShowDetails
details forall a. Eq a => a -> a -> Bool
== TestShowDetails
Always)
Bool -> Bool -> Bool
&& Verbosity
verbosity forall a. Ord a => a -> a -> Bool
>= Verbosity
normal
IO () -> IO ()
whenPrinting forall a b. (a -> b) -> a -> b
$ do
ByteString -> IO ()
LBS.putStr ByteString
logText
Char -> IO ()
putChar Char
'\n'
forall (m :: * -> *) a. Monad m => a -> m a
return TestSuiteLog
suiteLog
Verbosity -> [Char] -> IO ()
notice Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ TestSuiteLog -> [Char]
summarizeSuiteFinish TestSuiteLog
suiteLog
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isCoverageEnabled forall a b. (a -> b) -> a -> b
$
case PackageDescription -> Maybe Library
PD.library PackageDescription
pkg_descr of
Maybe Library
Nothing ->
forall a. Verbosity -> [Char] -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ [Char]
"Error: test coverage is only supported for packages with a library component"
Just Library
library ->
Verbosity
-> LocalBuildInfo
-> [Char]
-> [Char]
-> TestSuite
-> Library
-> IO ()
markupTest Verbosity
verbosity LocalBuildInfo
lbi [Char]
distPref (forall a. Pretty a => a -> [Char]
prettyShow forall a b. (a -> b) -> a -> b
$ PackageDescription -> PackageIdentifier
PD.package PackageDescription
pkg_descr) TestSuite
suite Library
library
forall (m :: * -> *) a. Monad m => a -> m a
return TestSuiteLog
suiteLog
where
testName' :: [Char]
testName' = UnqualComponentName -> [Char]
unUnqualComponentName forall a b. (a -> b) -> a -> b
$ TestSuite -> UnqualComponentName
PD.testName TestSuite
suite
deleteIfExists :: [Char] -> IO ()
deleteIfExists [Char]
file = do
Bool
exists <- [Char] -> IO Bool
doesFileExist [Char]
file
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
removeFile [Char]
file
testLogDir :: [Char]
testLogDir = [Char]
distPref [Char] -> [Char] -> [Char]
</> [Char]
"test"
openCabalTemp :: IO [Char]
openCabalTemp = do
([Char]
f, Handle
h) <- [Char] -> [Char] -> IO ([Char], Handle)
openTempFile [Char]
testLogDir forall a b. (a -> b) -> a -> b
$ [Char]
"cabal-test-" [Char] -> [Char] -> [Char]
<.> [Char]
"log"
Handle -> IO ()
hClose Handle
h forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
f
distPref :: [Char]
distPref = forall a. WithCallStack (Flag a -> a)
fromFlag forall a b. (a -> b) -> a -> b
$ TestFlags -> Flag [Char]
testDistPref TestFlags
flags
verbosity :: Verbosity
verbosity = forall a. WithCallStack (Flag a -> a)
fromFlag forall a b. (a -> b) -> a -> b
$ TestFlags -> Flag Verbosity
testVerbosity TestFlags
flags
testOption :: PD.PackageDescription
-> LBI.LocalBuildInfo
-> PD.TestSuite
-> PathTemplate
-> String
testOption :: PackageDescription
-> LocalBuildInfo -> TestSuite -> PathTemplate -> [Char]
testOption PackageDescription
pkg_descr LocalBuildInfo
lbi TestSuite
suite PathTemplate
template =
PathTemplate -> [Char]
fromPathTemplate forall a b. (a -> b) -> a -> b
$ PathTemplateEnv -> PathTemplate -> PathTemplate
substPathTemplate PathTemplateEnv
env PathTemplate
template
where
env :: PathTemplateEnv
env = PackageIdentifier
-> UnitId -> CompilerInfo -> Platform -> PathTemplateEnv
initialPathTemplateEnv
(PackageDescription -> PackageIdentifier
PD.package PackageDescription
pkg_descr) (LocalBuildInfo -> UnitId
LBI.localUnitId LocalBuildInfo
lbi)
(Compiler -> CompilerInfo
compilerInfo forall a b. (a -> b) -> a -> b
$ LocalBuildInfo -> Compiler
LBI.compiler LocalBuildInfo
lbi) (LocalBuildInfo -> Platform
LBI.hostPlatform LocalBuildInfo
lbi) forall a. [a] -> [a] -> [a]
++
[(PathTemplateVariable
TestSuiteNameVar, [Char] -> PathTemplate
toPathTemplate forall a b. (a -> b) -> a -> b
$ UnqualComponentName -> [Char]
unUnqualComponentName forall a b. (a -> b) -> a -> b
$ TestSuite -> UnqualComponentName
PD.testName TestSuite
suite)]
stubName :: PD.TestSuite -> FilePath
stubName :: TestSuite -> [Char]
stubName TestSuite
t = UnqualComponentName -> [Char]
unUnqualComponentName (TestSuite -> UnqualComponentName
PD.testName TestSuite
t) forall a. [a] -> [a] -> [a]
++ [Char]
"Stub"
stubFilePath :: PD.TestSuite -> FilePath
stubFilePath :: TestSuite -> [Char]
stubFilePath TestSuite
t = TestSuite -> [Char]
stubName TestSuite
t [Char] -> [Char] -> [Char]
<.> [Char]
"hs"
writeSimpleTestStub :: PD.TestSuite
-> FilePath
-> IO ()
writeSimpleTestStub :: TestSuite -> [Char] -> IO ()
writeSimpleTestStub TestSuite
t [Char]
dir = do
Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True [Char]
dir
let filename :: [Char]
filename = [Char]
dir [Char] -> [Char] -> [Char]
</> TestSuite -> [Char]
stubFilePath TestSuite
t
m :: ModuleName
m = case TestSuite -> TestSuiteInterface
PD.testInterface TestSuite
t of
PD.TestSuiteLibV09 Version
_ ModuleName
m' -> ModuleName
m'
TestSuiteInterface
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"writeSimpleTestStub: invalid TestSuite passed"
[Char] -> [Char] -> IO ()
writeFile [Char]
filename forall a b. (a -> b) -> a -> b
$ ModuleName -> [Char]
simpleTestStub ModuleName
m
simpleTestStub :: ModuleName -> String
simpleTestStub :: ModuleName -> [Char]
simpleTestStub ModuleName
m = [[Char]] -> [Char]
unlines
[ [Char]
"module Main ( main ) where"
, [Char]
"import Distribution.Simple.Test.LibV09 ( stubMain )"
, [Char]
"import " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall a. Pretty a => a -> Doc
pretty ModuleName
m) forall a. [a] -> [a] -> [a]
++ [Char]
" ( tests )"
, [Char]
"main :: IO ()"
, [Char]
"main = stubMain tests"
]
stubMain :: IO [Test] -> IO ()
stubMain :: IO [Test] -> IO ()
stubMain IO [Test]
tests = do
([Char]
f, UnqualComponentName
n) <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[Char]
s -> forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"panic! read " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
s) forall a b. (a -> b) -> a -> b
$ forall a. Read a => [Char] -> Maybe a
readMaybe [Char]
s) IO [Char]
getContents
[Char]
dir <- IO [Char]
getCurrentDirectory
TestLogs
results <- (IO [Test]
tests forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Test] -> IO TestLogs
stubRunTests) forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`CE.catch` SomeException -> IO TestLogs
errHandler
[Char] -> IO ()
setCurrentDirectory [Char]
dir
[Char] -> UnqualComponentName -> TestLogs -> IO ()
stubWriteLog [Char]
f UnqualComponentName
n TestLogs
results
where
errHandler :: CE.SomeException -> IO TestLogs
errHandler :: SomeException -> IO TestLogs
errHandler SomeException
e = case forall e. Exception e => SomeException -> Maybe e
CE.fromException SomeException
e of
Just AsyncException
CE.UserInterrupt -> forall e a. Exception e => e -> IO a
CE.throwIO SomeException
e
Maybe AsyncException
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TestLog { testName :: [Char]
testName = [Char]
"Cabal test suite exception",
testOptionsReturned :: [([Char], [Char])]
testOptionsReturned = [],
testResult :: Result
testResult = [Char] -> Result
Error forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show SomeException
e }
stubRunTests :: [Test] -> IO TestLogs
stubRunTests :: [Test] -> IO TestLogs
stubRunTests [Test]
tests = do
[TestLogs]
logs <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Test -> IO TestLogs
stubRunTests' [Test]
tests
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Char] -> [TestLogs] -> TestLogs
GroupLogs [Char]
"Default" [TestLogs]
logs
where
stubRunTests' :: Test -> IO TestLogs
stubRunTests' (Test TestInstance
t) = do
TestLogs
l <- TestInstance -> IO Progress
run TestInstance
t 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
forall (m :: * -> *) a. Monad m => a -> m a
return TestLogs
l
where
finish :: Progress -> IO TestLogs
finish (Finished Result
result) =
forall (m :: * -> *) a. Monad m => a -> m a
return TestLog
{ testName :: [Char]
testName = TestInstance -> [Char]
name TestInstance
t
, testOptionsReturned :: [([Char], [Char])]
testOptionsReturned = TestInstance -> [([Char], [Char])]
defaultOptions TestInstance
t
, testResult :: Result
testResult = Result
result
}
finish (Progress [Char]
_ IO Progress
next) = IO Progress
next 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 <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Test -> IO TestLogs
stubRunTests' forall a b. (a -> b) -> a -> b
$ Test -> [Test]
groupTests Test
g
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Char] -> [TestLogs] -> TestLogs
GroupLogs (Test -> [Char]
groupName Test
g) [TestLogs]
logs
stubRunTests' (ExtraOptions [OptionDescr]
_ Test
t) = Test -> IO TestLogs
stubRunTests' Test
t
maybeDefaultOption :: OptionDescr -> Maybe ([Char], [Char])
maybeDefaultOption OptionDescr
opt =
forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Maybe a
Nothing (\[Char]
d -> forall a. a -> Maybe a
Just (OptionDescr -> [Char]
optionName OptionDescr
opt, [Char]
d)) forall a b. (a -> b) -> a -> b
$ OptionDescr -> Maybe [Char]
optionDefault OptionDescr
opt
defaultOptions :: TestInstance -> [([Char], [Char])]
defaultOptions TestInstance
testInst = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe OptionDescr -> Maybe ([Char], [Char])
maybeDefaultOption forall a b. (a -> b) -> a -> b
$ TestInstance -> [OptionDescr]
options TestInstance
testInst
stubWriteLog :: FilePath -> UnqualComponentName -> TestLogs -> IO ()
stubWriteLog :: [Char] -> UnqualComponentName -> TestLogs -> IO ()
stubWriteLog [Char]
f UnqualComponentName
n TestLogs
logs = do
let testLog :: TestSuiteLog
testLog = TestSuiteLog { testSuiteName :: UnqualComponentName
testSuiteName = UnqualComponentName
n, testLogs :: TestLogs
testLogs = TestLogs
logs, logFile :: [Char]
logFile = [Char]
f }
[Char] -> [Char] -> IO ()
writeFile (TestSuiteLog -> [Char]
logFile TestSuiteLog
testLog) forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show TestSuiteLog
testLog
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TestLogs -> Bool
suiteError TestLogs
logs) forall a b. (a -> b) -> a -> b
$ forall a. ExitCode -> IO a
exitWith forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
2
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TestLogs -> Bool
suiteFailed TestLogs
logs) forall a b. (a -> b) -> a -> b
$ forall a. ExitCode -> IO a
exitWith forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
1
forall a. IO a
exitSuccess