diff --git a/Cabal/tests/PackageTests.hs b/Cabal/tests/PackageTests.hs
index 6c0f5402263aea6339a4c29c36adfd0e630bb357..b3f50705d2543ecb56eb68b5246a7534f6fcc143 100644
--- a/Cabal/tests/PackageTests.hs
+++ b/Cabal/tests/PackageTests.hs
@@ -80,6 +80,10 @@ tests version inplaceSpec ghcPath ghcPkgPath =
, hunit "TestSuiteExeV10/Test" (PackageTests.TestSuiteExeV10.Check.checkTest ghcPath)
, hunit "TestSuiteExeV10/TestWithHpc"
(PackageTests.TestSuiteExeV10.Check.checkTestWithHpc ghcPath)
+ , hunit "TestSuiteExeV10/TestWithoutHpcNoTix"
+ (PackageTests.TestSuiteExeV10.Check.checkTestWithoutHpcNoTix ghcPath)
+ , hunit "TestSuiteExeV10/TestWithoutHpcNoMarkup"
+ (PackageTests.TestSuiteExeV10.Check.checkTestWithoutHpcNoMarkup ghcPath)
, hunit "TestOptions" (PackageTests.TestOptions.Check.suite ghcPath)
, hunit "BenchmarkStanza" (PackageTests.BenchmarkStanza.Check.suite ghcPath)
-- ^ The benchmark stanza test will eventually be required
diff --git a/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs b/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs
index cf7ca3cd1bdacd3a44229f9adc9b47c95e2d18f8..065c71c83ab4caca8c5e344dd9f4059bc37c1a06 100644
--- a/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs
+++ b/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs
@@ -18,7 +18,7 @@ suite ghcPath ghcPkgPath = TestCase $ do
assertBuildSucceeded bResult
unregister "InternalLibrary2" ghcPkgPath
- (_, _, output) <- run (Just $ directory spec) (directory spec </> "dist" </> "build" </> "lemon" </> "lemon") []
+ (_, _, output) <- run (Just $ directory spec) (directory spec </> "dist" </> "build" </> "lemon" </> "lemon") [] []
C.appendFile (directory spec </> "test-log.txt") (C.pack $ "\ndist/build/lemon/lemon\n"++output)
assertEqual "executable should have linked with the internal library" "myLibFunc internal" (concat $ lines output)
diff --git a/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs b/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs
index 8d12af00856452183298aafce198767ae6298c1f..8dcf90f1cca2a2f53ea8f83cb21e4abd05d58ee0 100644
--- a/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs
+++ b/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs
@@ -18,7 +18,7 @@ suite ghcPath ghcPkgPath = TestCase $ do
assertBuildSucceeded bResult
unregister "InternalLibrary3"ghcPkgPath
- (_, _, output) <- run (Just $ directory spec) (directory spec </> "dist" </> "build" </> "lemon" </> "lemon") []
+ (_, _, output) <- run (Just $ directory spec) (directory spec </> "dist" </> "build" </> "lemon" </> "lemon") [] []
C.appendFile (directory spec </> "test-log.txt") (C.pack $ "\ndist/build/lemon/lemon\n"++output)
assertEqual "executable should have linked with the internal library" "myLibFunc internal" (concat $ lines output)
diff --git a/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs b/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs
index af40320ef1003473ab7fec98aa7ab712842d0606..70b3eb65d0566cdbedf35b95d35b3de958f42fc7 100644
--- a/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs
+++ b/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs
@@ -18,7 +18,7 @@ suite ghcPath ghcPkgPath = TestCase $ do
assertBuildSucceeded bResult
unregister "InternalLibrary4" ghcPkgPath
- (_, _, output) <- run (Just $ directory spec) (directory spec </> "dist" </> "build" </> "lemon" </> "lemon") []
+ (_, _, output) <- run (Just $ directory spec) (directory spec </> "dist" </> "build" </> "lemon" </> "lemon") [] []
C.appendFile (directory spec </> "test-log.txt") (C.pack $ "\ndist/build/lemon/lemon\n"++output)
assertEqual "executable should have linked with the installed library" "myLibFunc installed" (concat $ lines output)
diff --git a/Cabal/tests/PackageTests/DeterministicAr/Check.hs b/Cabal/tests/PackageTests/DeterministicAr/Check.hs
index b0bcd2918f32c6d4bc0a366d25b075089e64273a..9930b3607566195c5c82489265bed56ae8514f74 100644
--- a/Cabal/tests/PackageTests/DeterministicAr/Check.hs
+++ b/Cabal/tests/PackageTests/DeterministicAr/Check.hs
@@ -22,7 +22,7 @@ assertFailure' msg = assertFailure msg >> return {-unpossible!-}undefined
ghcPkg_field :: String -> String -> FilePath -> IO [FilePath]
ghcPkg_field libraryName fieldName ghcPkgPath = do
- (cmd, exitCode, raw) <- run Nothing ghcPkgPath
+ (cmd, exitCode, raw) <- run Nothing ghcPkgPath []
["--user", "field", libraryName, fieldName]
let output = filter ('\r' /=) raw -- Windows
-- copypasta of PackageTester.requireSuccess
diff --git a/Cabal/tests/PackageTests/PackageTester.hs b/Cabal/tests/PackageTests/PackageTester.hs
index 0296d184556bb2fc77d1e86f429972a5043cad6d..c2dddfdb0e7ed3eecd87199d5739491eb99b9e78 100644
--- a/Cabal/tests/PackageTests/PackageTester.hs
+++ b/Cabal/tests/PackageTests/PackageTester.hs
@@ -37,14 +37,15 @@ import System.Directory (canonicalizePath, doesFileExist, getCurrentDirectory)
import System.Environment (getEnv)
import System.Exit (ExitCode(ExitSuccess))
import System.FilePath
-import System.IO
+import System.IO (hIsEOF, hGetChar, hClose)
import System.IO.Error (isDoesNotExistError)
import System.Process (runProcess, waitForProcess)
import Test.HUnit (Assertion, assertFailure)
-import Distribution.Simple.BuildPaths (exeExtension)
-import Distribution.Simple.Utils (printRawCommandAndArgs)
import Distribution.Compat.CreatePipe (createPipe)
+import Distribution.Simple.BuildPaths (exeExtension)
+import Distribution.Simple.Program.Run (getEffectiveEnvironment)
+import Distribution.Simple.Utils (printRawCommandAndArgsAndEnv)
import Distribution.ReadE (readEOrFail)
import Distribution.Verbosity (Verbosity, flagToVerbosity, normal)
@@ -92,9 +93,9 @@ cabal_configure spec ghcPath = do
doCabalConfigure :: PackageSpec -> FilePath -> IO Result
doCabalConfigure spec ghcPath = do
- cleanResult@(_, _, _) <- cabal spec ["clean"] ghcPath
+ cleanResult@(_, _, _) <- cabal spec [] ["clean"] ghcPath
requireSuccess cleanResult
- res <- cabal spec
+ res <- cabal spec []
(["configure", "--user", "-w", ghcPath] ++ configOpts spec)
ghcPath
return $ recordRun res ConfigureSuccess nullResult
@@ -104,7 +105,7 @@ doCabalBuild spec ghcPath = do
configResult <- doCabalConfigure spec ghcPath
if successful configResult
then do
- res <- cabal spec ["build", "-v"] ghcPath
+ res <- cabal spec [] ["build", "-v"] ghcPath
return $ recordRun res BuildSuccess configResult
else
return configResult
@@ -126,14 +127,14 @@ doCabalHaddock spec extraArgs ghcPath = do
configResult <- doCabalConfigure spec ghcPath
if successful configResult
then do
- res <- cabal spec ("haddock" : extraArgs) ghcPath
+ res <- cabal spec [] ("haddock" : extraArgs) ghcPath
return $ recordRun res HaddockSuccess configResult
else
return configResult
unregister :: String -> FilePath -> IO ()
unregister libraryName ghcPkgPath = do
- res@(_, _, output) <- run Nothing ghcPkgPath ["unregister", "--user", libraryName]
+ res@(_, _, output) <- run Nothing ghcPkgPath [] ["unregister", "--user", libraryName]
if "cannot find package" `isInfixOf` output
then return ()
else requireSuccess res
@@ -144,23 +145,23 @@ cabal_install spec ghcPath = do
buildResult <- doCabalBuild spec ghcPath
res <- if successful buildResult
then do
- res <- cabal spec ["install"] ghcPath
+ res <- cabal spec [] ["install"] ghcPath
return $ recordRun res InstallSuccess buildResult
else
return buildResult
record spec res
return res
-cabal_test :: PackageSpec -> [String] -> FilePath -> IO Result
-cabal_test spec extraArgs ghcPath = do
- res <- cabal spec ("test" : extraArgs) ghcPath
+cabal_test :: PackageSpec -> [(String, Maybe String)] -> [String] -> FilePath -> IO Result
+cabal_test spec envOverrides extraArgs ghcPath = do
+ res <- cabal spec envOverrides ("test" : extraArgs) ghcPath
let r = recordRun res TestSuccess nullResult
record spec r
return r
cabal_bench :: PackageSpec -> [String] -> FilePath -> IO Result
cabal_bench spec extraArgs ghcPath = do
- res <- cabal spec ("bench" : extraArgs) ghcPath
+ res <- cabal spec [] ("bench" : extraArgs) ghcPath
let r = recordRun res BenchSuccess nullResult
record spec r
return r
@@ -168,7 +169,7 @@ cabal_bench spec extraArgs ghcPath = do
compileSetup :: FilePath -> FilePath -> IO ()
compileSetup packageDir ghcPath = do
wd <- getCurrentDirectory
- r <- run (Just $ packageDir) ghcPath
+ r <- run (Just $ packageDir) ghcPath []
[ "--make"
-- HPC causes trouble -- see #1012
-- , "-fhpc"
@@ -178,30 +179,32 @@ compileSetup packageDir ghcPath = do
requireSuccess r
-- | Returns the command that was issued, the return code, and the output text.
-cabal :: PackageSpec -> [String] -> FilePath -> IO (String, ExitCode, String)
-cabal spec cabalArgs ghcPath = do
+cabal :: PackageSpec -> [(String, Maybe String)] -> [String] -> FilePath -> IO (String, ExitCode, String)
+cabal spec envOverrides cabalArgs ghcPath = do
customSetup <- doesFileExist (directory spec </> "Setup.hs")
if customSetup
then do
compileSetup (directory spec) ghcPath
path <- canonicalizePath $ directory spec </> "Setup"
- run (Just $ directory spec) path cabalArgs
+ run (Just $ directory spec) path envOverrides cabalArgs
else do
-- Use shared Setup executable (only for Simple build types).
path <- canonicalizePath "Setup"
- run (Just $ directory spec) path cabalArgs
+ run (Just $ directory spec) path envOverrides cabalArgs
--- | Returns the command that was issued, the return code, and hte output text
-run :: Maybe FilePath -> String -> [String] -> IO (String, ExitCode, String)
-run cwd path args = do
+-- | Returns the command that was issued, the return code, and the output text
+run :: Maybe FilePath -> String -> [(String, Maybe String)] -> [String] -> IO (String, ExitCode, String)
+run cwd path envOverrides args = do
verbosity <- getVerbosity
-- path is relative to the current directory; canonicalizePath makes it
-- absolute, so that runProcess will find it even when changing directory.
path' <- do pathExists <- doesFileExist path
canonicalizePath (if pathExists then path else path <.> exeExtension)
- printRawCommandAndArgs verbosity path' args
+ menv <- getEffectiveEnvironment envOverrides
+
+ printRawCommandAndArgsAndEnv verbosity path' args menv
(readh, writeh) <- createPipe
- pid <- runProcess path' args cwd Nothing Nothing (Just writeh) (Just writeh)
+ pid <- runProcess path' args cwd menv Nothing (Just writeh) (Just writeh)
-- fork off a thread to start consuming the output
out <- suckH [] readh
@@ -220,6 +223,7 @@ run cwd path args = do
c <- hGetChar h
suckH (c:output) h
+
requireSuccess :: (String, ExitCode, String) -> IO ()
requireSuccess (cmd, exitCode, output) =
unless (exitCode == ExitSuccess) $
diff --git a/Cabal/tests/PackageTests/ReexportedModules/Check.hs b/Cabal/tests/PackageTests/ReexportedModules/Check.hs
index 211bc60762f248c3c2edc1234724c60639571962..c4778cb3564dc6e7682a030afbf3fe91af5ca87c 100644
--- a/Cabal/tests/PackageTests/ReexportedModules/Check.hs
+++ b/Cabal/tests/PackageTests/ReexportedModules/Check.hs
@@ -18,7 +18,7 @@ orFail err r = case find (all isSpace . snd) r of
suite :: FilePath -> Test
suite ghcPath = TestCase $ do
-- ToDo: Turn this into a utility function
- (_, _, xs) <- run Nothing ghcPath ["--info"]
+ (_, _, xs) <- run Nothing ghcPath [] ["--info"]
let compat = (>= Version [7,9] [])
. orFail "could not parse version"
. readP_to_S parseVersion
diff --git a/Cabal/tests/PackageTests/TestOptions/Check.hs b/Cabal/tests/PackageTests/TestOptions/Check.hs
index cb13395826d5bb48fac0efa2b6827cfe606600f9..252393f167cdc60f04755a49fe02f69554f49e31 100644
--- a/Cabal/tests/PackageTests/TestOptions/Check.hs
+++ b/Cabal/tests/PackageTests/TestOptions/Check.hs
@@ -9,14 +9,14 @@ suite ghcPath = TestCase $ do
let spec = PackageSpec ("PackageTests" </> "TestOptions")
["--enable-tests"]
_ <- cabal_build spec ghcPath
- result <- cabal_test spec ["--test-options=1 2 3"] ghcPath
+ result <- cabal_test spec [] ["--test-options=1 2 3"] ghcPath
let message = "\"cabal test\" did not pass the correct options to the "
++ "test executable with \"--test-options\""
assertEqual message True $ successful result
- result' <- cabal_test spec [ "--test-option=1"
- , "--test-option=2"
- , "--test-option=3"
- ]
+ result' <- cabal_test spec [] [ "--test-option=1"
+ , "--test-option=2"
+ , "--test-option=3"
+ ]
ghcPath
let message' = "\"cabal test\" did not pass the correct options to the "
++ "test executable with \"--test-option\""
diff --git a/Cabal/tests/PackageTests/TestSuiteExeV10/Check.hs b/Cabal/tests/PackageTests/TestSuiteExeV10/Check.hs
index 45e75adf548a07ccc8bb669536631f2e9075ba17..af85e53dbf98480f6b713e394489bf44f328c868 100644
--- a/Cabal/tests/PackageTests/TestSuiteExeV10/Check.hs
+++ b/Cabal/tests/PackageTests/TestSuiteExeV10/Check.hs
@@ -1,6 +1,8 @@
module PackageTests.TestSuiteExeV10.Check
( checkTest
, checkTestWithHpc
+ , checkTestWithoutHpcNoTix
+ , checkTestWithoutHpcNoMarkup
) where
import Distribution.PackageDescription ( TestSuite(..), emptyTestSuite )
@@ -12,7 +14,7 @@ import Distribution.Simple.Program.Db ( emptyProgramDb, configureProgram,
import PackageTests.PackageTester
import qualified Control.Exception as E ( IOException, catch )
import Control.Monad ( when )
-import System.Directory
+import System.Directory ( doesFileExist )
import System.FilePath
import Test.HUnit
@@ -22,24 +24,14 @@ dir :: FilePath
dir = "PackageTests" </> "TestSuiteExeV10"
checkTest :: FilePath -> Test
-checkTest ghcPath = TestCase $ do
- let spec = PackageSpec dir ["--enable-tests"]
- buildResult <- cabal_build spec ghcPath
- assertBuildSucceeded buildResult
- testResult <- cabal_test spec [] ghcPath
- assertTestSucceeded testResult
+checkTest ghcPath = TestCase $ buildAndTest ghcPath [] []
+-- | Ensure that both .tix file and markup are generated if coverage is enabled.
checkTestWithHpc :: FilePath -> Test
checkTestWithHpc ghcPath = TestCase $ do
- isCorrectVersion <- checkHpcVersion
+ isCorrectVersion <- correctHpcVersion
when isCorrectVersion $ do
- let spec = PackageSpec dir [ "--enable-tests"
- , "--enable-library-coverage"
- ]
- buildResult <- cabal_build spec ghcPath
- assertBuildSucceeded buildResult
- testResult <- cabal_test spec [] ghcPath
- assertTestSucceeded testResult
+ buildAndTest ghcPath [] ["--enable-library-coverage"]
let dummy = emptyTestSuite { testName = "test-Foo" }
tixFile = tixFilePath (dir </> "dist") $ testName dummy
tixFileMessage = ".tix file should exist"
@@ -51,15 +43,56 @@ checkTestWithHpc ghcPath = TestCase $ do
markupFileExists <- doesFileExist markupFile
assertEqual markupFileMessage True markupFileExists
where
- checkHpcVersion :: IO Bool
- checkHpcVersion = do
- let programDb' = emptyProgramDb
- let verbosity = Verbosity.normal
- let verRange = orLaterVersion (Version [0,7] [])
- programDb <- configureProgram verbosity hpcProgram programDb'
- (requireProgramVersion verbosity hpcProgram verRange programDb
- >> return True) `catchIO` (\_ -> return False)
- -- Distirubution.Compat.Exception is hidden.
+-- | Ensures that even if -fhpc is manually provided no .tix file is output.
+checkTestWithoutHpcNoTix :: FilePath -> Test
+checkTestWithoutHpcNoTix ghcPath = TestCase $ do
+ isCorrectVersion <- correctHpcVersion
+ when isCorrectVersion $ do
+ buildAndTest ghcPath [] ["--ghc-option=-fhpc"]
+ let dummy = emptyTestSuite { testName = "test-Foo" }
+ tixFile = tixFilePath (dir </> "dist") $ testName dummy
+ tixFileMessage = ".tix file should NOT exist"
+ tixFileExists <- doesFileExist tixFile
+ assertEqual tixFileMessage False tixFileExists
+
+-- | Ensures that even if a .tix file happens to be left around
+-- markup isn't generated.
+checkTestWithoutHpcNoMarkup :: FilePath -> Test
+checkTestWithoutHpcNoMarkup ghcPath = TestCase $ do
+ isCorrectVersion <- correctHpcVersion
+ when isCorrectVersion $ do
+ let dummy = emptyTestSuite { testName = "test-Foo" }
+ tixFile = tixFilePath "dist" $ testName dummy
+ markupDir = htmlDir (dir </> "dist") $ testName dummy
+ markupFile = markupDir </> "hpc_index" <.> "html"
+ markupFileMessage = "HPC markup file should NOT exist"
+ buildAndTest ghcPath [("HPCTIXFILE", Just tixFile)] ["--ghc-option=-fhpc"]
+ markupFileExists <- doesFileExist markupFile
+ assertEqual markupFileMessage False markupFileExists
+
+-- | Build and test a package and ensure that both were successful.
+--
+-- The flag "--enable-tests" is provided in addition to the given flags.
+buildAndTest :: FilePath -> [(String, Maybe String)] -> [String] -> IO ()
+buildAndTest ghcPath envOverrides flags = do
+ let spec = PackageSpec dir $ "--enable-tests" : flags
+ buildResult <- cabal_build spec ghcPath
+ assertBuildSucceeded buildResult
+ testResult <- cabal_test spec envOverrides [] ghcPath
+ assertTestSucceeded testResult
+
+-- | Checks for a suitable HPC version for testing.
+correctHpcVersion :: IO Bool
+correctHpcVersion = do
+ let programDb' = emptyProgramDb
+ let verbosity = Verbosity.normal
+ let verRange = orLaterVersion (Version [0,7] [])
+ programDb <- configureProgram verbosity hpcProgram programDb'
+ (requireProgramVersion verbosity hpcProgram verRange programDb
+ >> return True) `catchIO` (\_ -> return False)
+ where
+ -- Distribution.Compat.Exception is hidden.
catchIO :: IO a -> (E.IOException -> IO a) -> IO a
catchIO = E.catch
+