Commit d132ffe0 authored by Neil Vice's avatar Neil Vice Committed by ttuegel
Browse files

Test executable tests without hpc

parent 5cf626df
......@@ -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
......
......@@ -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)
......@@ -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)
......@@ -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)
......@@ -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
......
......@@ -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) $
......
......@@ -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
......
......@@ -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\""
......
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
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment