{-# 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
FilePath
pwd <- IO FilePath
getCurrentDirectory
[(FilePath, FilePath)]
existingEnv <- IO [(FilePath, FilePath)]
getEnvironment
let cmd :: FilePath
cmd = LocalBuildInfo -> FilePath
LBI.buildDir LocalBuildInfo
lbi FilePath -> FilePath -> FilePath
</> TestSuite -> FilePath
stubName TestSuite
suite
FilePath -> FilePath -> FilePath
</> TestSuite -> FilePath
stubName TestSuite
suite FilePath -> FilePath -> FilePath
<.> Platform -> FilePath
exeExtension (LocalBuildInfo -> Platform
LBI.hostPlatform LocalBuildInfo
lbi)
Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
cmd
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Verbosity -> FilePath -> IO ()
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Error: Could not find test program \"" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
cmd
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\". Did you build the package first?"
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 :: FilePath
tDir = FilePath -> Way -> FilePath -> FilePath
tixDir FilePath
distPref Way
way FilePath
testName'
Bool
exists' <- FilePath -> IO Bool
doesDirectoryExist FilePath
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
$ FilePath -> IO ()
removeDirectoryRecursive FilePath
tDir
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Way -> FilePath -> FilePath
tixDir FilePath
distPref Way
way FilePath
testName'
Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
summarizeSuiteStart FilePath
testName'
TestSuiteLog
suiteLog <- IO FilePath
-> (FilePath -> IO ())
-> (FilePath -> IO TestSuiteLog)
-> IO TestSuiteLog
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
CE.bracket IO FilePath
openCabalTemp FilePath -> IO ()
deleteIfExists ((FilePath -> IO TestSuiteLog) -> IO TestSuiteLog)
-> (FilePath -> IO TestSuiteLog) -> IO TestSuiteLog
forall a b. (a -> b) -> a -> b
$ \FilePath
tempLog -> do
(Handle
rOut, Handle
wOut) <- IO (Handle, Handle)
createPipe
(Just Handle
wIn, Maybe Handle
_, Maybe Handle
_, ProcessHandle
process) <- do
let opts :: [FilePath]
opts = (PathTemplate -> FilePath) -> [PathTemplate] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (PackageDescription
-> LocalBuildInfo -> TestSuite -> PathTemplate -> FilePath
testOption PackageDescription
pkg_descr LocalBuildInfo
lbi TestSuite
suite) ([PathTemplate] -> [FilePath]) -> [PathTemplate] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ TestFlags -> [PathTemplate]
testOptions TestFlags
flags
dataDirPath :: FilePath
dataDirPath = FilePath
pwd FilePath -> FilePath -> FilePath
</> PackageDescription -> FilePath
PD.dataDir PackageDescription
pkg_descr
tixFile :: FilePath
tixFile = FilePath
pwd FilePath -> FilePath -> FilePath
</> FilePath -> Way -> FilePath -> FilePath
tixFilePath FilePath
distPref Way
way FilePath
testName'
pkgPathEnv :: [(FilePath, FilePath)]
pkgPathEnv = (PackageDescription -> FilePath -> FilePath
pkgPathEnvVar PackageDescription
pkg_descr FilePath
"datadir", FilePath
dataDirPath)
(FilePath, FilePath)
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. a -> [a] -> [a]
: [(FilePath, FilePath)]
existingEnv
shellEnv :: [(FilePath, FilePath)]
shellEnv = [(FilePath
"HPCTIXFILE", FilePath
tixFile) | Bool
isCoverageEnabled]
[(FilePath, FilePath)]
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. [a] -> [a] -> [a]
++ [(FilePath, FilePath)]
pkgPathEnv
[(FilePath, FilePath)]
shellEnv' <-
if LocalBuildInfo -> Bool
LBI.withDynExe LocalBuildInfo
lbi
then do
let (Platform Arch
_ OS
os) = LocalBuildInfo -> Platform
LBI.hostPlatform LocalBuildInfo
lbi
[FilePath]
paths <- Bool
-> Bool
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> IO [FilePath]
LBI.depLibraryPaths Bool
True Bool
False LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi
FilePath
cpath <- FilePath -> IO FilePath
canonicalizePath (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ LocalBuildInfo -> ComponentLocalBuildInfo -> FilePath
LBI.componentBuildDir LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi
[(FilePath, FilePath)] -> IO [(FilePath, FilePath)]
forall (m :: * -> *) a. Monad m => a -> m a
return (OS
-> [FilePath] -> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
addLibraryPath OS
os (FilePath
cpath FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
paths) [(FilePath, FilePath)]
shellEnv)
else [(FilePath, FilePath)] -> IO [(FilePath, FilePath)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(FilePath, FilePath)]
shellEnv
case TestFlags -> Flag FilePath
testWrapper TestFlags
flags of
Flag FilePath
path -> Verbosity
-> FilePath
-> [FilePath]
-> Maybe FilePath
-> Maybe [(FilePath, FilePath)]
-> StdStream
-> StdStream
-> StdStream
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcessWithEnv Verbosity
verbosity FilePath
path (FilePath
cmdFilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[FilePath]
opts) Maybe FilePath
forall a. Maybe a
Nothing ([(FilePath, FilePath)] -> Maybe [(FilePath, FilePath)]
forall a. a -> Maybe a
Just [(FilePath, FilePath)]
shellEnv')
StdStream
CreatePipe (Handle -> StdStream
UseHandle Handle
wOut) (Handle -> StdStream
UseHandle Handle
wOut)
Flag FilePath
NoFlag -> Verbosity
-> FilePath
-> [FilePath]
-> Maybe FilePath
-> Maybe [(FilePath, FilePath)]
-> StdStream
-> StdStream
-> StdStream
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcessWithEnv 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')
StdStream
CreatePipe (Handle -> StdStream
UseHandle Handle
wOut) (Handle -> StdStream
UseHandle Handle
wOut)
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
ByteString
logText <- Handle -> IO ByteString
LBS.hGetContents Handle
rOut
ByteString
_ <- ByteString -> IO ByteString
forall a. a -> IO a
evaluate (ByteString -> ByteString
forall a. NFData a => a -> a
force ByteString
logText)
ExitCode
exitcode <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
process
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
$ do
Verbosity -> FilePath -> IO ()
debug Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
cmd FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" returned " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ExitCode -> FilePath
forall a. Show a => a -> FilePath
show ExitCode
exitcode
let finalLogName :: TestSuiteLog -> FilePath
finalLogName TestSuiteLog
l = 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
(UnqualComponentName -> FilePath
unUnqualComponentName (UnqualComponentName -> FilePath)
-> UnqualComponentName -> FilePath
forall a b. (a -> b) -> a -> b
$ TestSuiteLog -> UnqualComponentName
testSuiteName TestSuiteLog
l) (TestSuiteLog -> TestLogs
testLogs TestSuiteLog
l)
TestSuiteLog
suiteLog <- (FilePath -> TestSuiteLog) -> IO FilePath -> IO TestSuiteLog
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\FilePath
s -> (\TestSuiteLog
l -> TestSuiteLog
l { logFile :: FilePath
logFile = TestSuiteLog -> FilePath
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 (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)
(IO FilePath -> IO TestSuiteLog) -> IO FilePath -> IO TestSuiteLog
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
readFile FilePath
tempLog
FilePath -> FilePath -> IO ()
appendFile (TestSuiteLog -> FilePath
logFile TestSuiteLog
suiteLog) (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
summarizeSuiteStart FilePath
testName'
FilePath -> ByteString -> IO ()
LBS.appendFile (TestSuiteLog -> FilePath
logFile TestSuiteLog
suiteLog) ByteString
logText
FilePath -> FilePath -> IO ()
appendFile (TestSuiteLog -> FilePath
logFile TestSuiteLog
suiteLog) (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ TestSuiteLog -> FilePath
summarizeSuiteFinish TestSuiteLog
suiteLog
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 (m :: * -> *) a. Monad m => a -> m a
return TestSuiteLog
suiteLog
Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ TestSuiteLog -> FilePath
summarizeSuiteFinish TestSuiteLog
suiteLog
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isCoverageEnabled (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Verbosity
-> LocalBuildInfo -> FilePath -> FilePath -> TestSuite -> IO ()
markupTest Verbosity
verbosity LocalBuildInfo
lbi FilePath
distPref (PackageIdentifier -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (PackageIdentifier -> FilePath) -> PackageIdentifier -> FilePath
forall a b. (a -> b) -> a -> b
$ PackageDescription -> PackageIdentifier
PD.package PackageDescription
pkg_descr) TestSuite
suite
TestSuiteLog -> IO TestSuiteLog
forall (m :: * -> *) a. Monad m => a -> m a
return TestSuiteLog
suiteLog
where
testName' :: FilePath
testName' = UnqualComponentName -> FilePath
unUnqualComponentName (UnqualComponentName -> FilePath)
-> UnqualComponentName -> FilePath
forall a b. (a -> b) -> a -> b
$ TestSuite -> UnqualComponentName
PD.testName TestSuite
suite
deleteIfExists :: FilePath -> IO ()
deleteIfExists FilePath
file = do
Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
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
$ FilePath -> IO ()
removeFile FilePath
file
testLogDir :: FilePath
testLogDir = FilePath
distPref FilePath -> FilePath -> FilePath
</> FilePath
"test"
openCabalTemp :: IO FilePath
openCabalTemp = do
(FilePath
f, Handle
h) <- FilePath -> FilePath -> IO (FilePath, Handle)
openTempFile FilePath
testLogDir (FilePath -> IO (FilePath, Handle))
-> FilePath -> IO (FilePath, Handle)
forall a b. (a -> b) -> a -> b
$ FilePath
"cabal-test-" FilePath -> FilePath -> FilePath
<.> FilePath
"log"
Handle -> IO ()
hClose Handle
h IO () -> IO FilePath -> IO FilePath
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
f
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
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)]
stubName :: PD.TestSuite -> FilePath
stubName :: TestSuite -> FilePath
stubName TestSuite
t = UnqualComponentName -> FilePath
unUnqualComponentName (TestSuite -> UnqualComponentName
PD.testName TestSuite
t) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"Stub"
stubFilePath :: PD.TestSuite -> FilePath
stubFilePath :: TestSuite -> FilePath
stubFilePath TestSuite
t = TestSuite -> FilePath
stubName TestSuite
t FilePath -> FilePath -> FilePath
<.> FilePath
"hs"
writeSimpleTestStub :: PD.TestSuite
-> FilePath
-> 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
</> 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
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"
]
stubMain :: IO [Test] -> IO ()
stubMain :: IO [Test] -> IO ()
stubMain IO [Test]
tests = do
(FilePath
f, UnqualComponentName
n) <- (FilePath -> (FilePath, UnqualComponentName))
-> IO FilePath -> IO (FilePath, UnqualComponentName)
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
FilePath
dir <- IO FilePath
getCurrentDirectory
TestLogs
results <- (IO [Test]
tests IO [Test] -> ([Test] -> IO TestLogs) -> IO TestLogs
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
FilePath -> IO ()
setCurrentDirectory FilePath
dir
FilePath -> UnqualComponentName -> TestLogs -> IO ()
stubWriteLog FilePath
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 (m :: * -> *) a. Monad m => a -> m a
return (TestLogs -> IO TestLogs) -> TestLogs -> IO TestLogs
forall a b. (a -> b) -> a -> b
$ TestLog :: FilePath -> [(FilePath, FilePath)] -> Result -> TestLogs
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 }
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)
traverse Test -> IO TestLogs
stubRunTests' [Test]
tests
TestLogs -> IO TestLogs
forall (m :: * -> *) a. Monad m => a -> m a
return (TestLogs -> IO TestLogs) -> TestLogs -> IO TestLogs
forall a b. (a -> b) -> a -> b
$ FilePath -> [TestLogs] -> TestLogs
GroupLogs FilePath
"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 (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 (m :: * -> *) a. Monad m => a -> m a
return TestLogs
l
where
finish :: Progress -> IO TestLogs
finish (Finished Result
result) =
TestLogs -> IO TestLogs
forall (m :: * -> *) a. Monad m => a -> m a
return TestLog :: FilePath -> [(FilePath, FilePath)] -> Result -> TestLogs
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 (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)
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 (m :: * -> *) a. Monad m => a -> m a
return (TestLogs -> IO TestLogs) -> TestLogs -> IO TestLogs
forall a b. (a -> b) -> a -> b
$ FilePath -> [TestLogs] -> TestLogs
GroupLogs (Test -> FilePath
groupName Test
g) [TestLogs]
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
stubWriteLog :: FilePath -> UnqualComponentName -> TestLogs -> IO ()
stubWriteLog :: FilePath -> UnqualComponentName -> TestLogs -> IO ()
stubWriteLog FilePath
f UnqualComponentName
n TestLogs
logs = do
let testLog :: TestSuiteLog
testLog = TestSuiteLog :: UnqualComponentName -> TestLogs -> FilePath -> TestSuiteLog
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