Commit 257c0429 authored by kristenk's avatar kristenk
Browse files

Use a writer monad to define Cabal package tests

parent 7f3e817d
......@@ -180,7 +180,8 @@ main = do
putStrLn $ "Building shared ./Setup executable"
rawCompileSetup verbosity suite [] "tests"
defaultMain $ testGroup "Package Tests" (tests suite)
defaultMain $
runTestTree "Package Tests" (tests suite)
-- Reverse of 'interpretPackageDbFlags'.
-- prop_idem stk b
......
......@@ -49,6 +49,14 @@ module PackageTests.PackageTester
, assertFindInFile
, concatOutput
-- * Test trees
, TestTreeM
, runTestTree
, testTree
, testTree'
, groupTests
, mapTestTrees
, getPersistBuildConfig
-- Common utilities
......@@ -79,6 +87,7 @@ import Text.Regex.Posix
import qualified Control.Exception as E
import Control.Monad
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Writer
import Control.Monad.IO.Class
import qualified Data.ByteString.Char8 as C
import Data.List
......@@ -92,6 +101,7 @@ import System.FilePath
import System.IO
import System.IO.Error (isDoesNotExistError)
import System.Process (runProcess, waitForProcess, showCommandForUser)
import Test.Tasty (TestTree, testGroup)
-- | Our test monad maintains an environment recording the global test
-- suite configuration 'SuiteConfig', and the local per-test
......@@ -604,6 +614,27 @@ assertFindInFile needle path =
concatOutput :: String -> String
concatOutput = unwords . lines . filter ((/=) '\r')
------------------------------------------------------------------------
-- * Test trees
type TestTreeM = Writer [TestTree]
runTestTree :: String -> TestTreeM () -> TestTree
runTestTree name ts = testGroup name (execWriter ts)
testTree :: SuiteConfig -> String -> Maybe String -> TestM a -> TestTreeM ()
testTree config name subname m =
testTree' $ HUnit.testCase name $ runTestM config name subname m
testTree' :: TestTree -> TestTreeM ()
testTree' tc = tell [tc]
groupTests :: String -> TestTreeM () -> TestTreeM ()
groupTests name = censor (\ts -> [testGroup name ts])
mapTestTrees :: (TestTree -> TestTree) -> TestTreeM a -> TestTreeM a
mapTestTrees = censor . map
------------------------------------------------------------------------
-- Verbosity
......
module PackageTests.TestSuiteTests.ExeV10.Check (tests) where
import qualified Control.Exception as E (IOException, catch)
import Control.Monad (when)
import Control.Monad (forM_, liftM4, when)
import Data.Maybe (catMaybes)
import System.FilePath
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (testCase)
import Distribution.Compiler (CompilerFlavor(..), CompilerId(..))
......@@ -21,18 +20,18 @@ import Distribution.Version (Version(..), orLaterVersion)
import PackageTests.PackageTester
tests :: SuiteConfig -> [TestTree]
tests config =
tests :: SuiteConfig -> TestTreeM ()
tests config = do
-- TODO: hierarchy and subnaming is a little unfortunate
[ tc "Test" "Default" $ do
tc "Test" "Default" $ do
cabal_build ["--enable-tests"]
-- This one runs both tests, including the very LONG Foo
-- test which prints a lot of output
cabal "test" ["--show-details=direct"]
, testGroup "WithHpc" $ hpcTestMatrix config
, testGroup "WithoutHpc"
groupTests "WithHpc" $ hpcTestMatrix config
groupTests "WithoutHpc" $ do
-- Ensures that even if -fhpc is manually provided no .tix file is output.
[ tc "NoTix" "NoHpcNoTix" $ do
tc "NoTix" "NoHpcNoTix" $ do
dist_dir <- distDir
cabal_build
[ "--enable-tests"
......@@ -45,7 +44,7 @@ tests config =
shouldNotExist $ tixFilePath dist_dir way "test-Short"
-- Ensures that even if a .tix file happens to be left around
-- markup isn't generated.
, tc "NoMarkup" "NoHpcNoMarkup" $ do
tc "NoMarkup" "NoHpcNoMarkup" $ do
dist_dir <- distDir
let tixFile = tixFilePath dist_dir Vanilla "test-Short"
withEnv [("HPCTIXFILE", Just tixFile)] $ do
......@@ -56,20 +55,15 @@ tests config =
, "--ghc-option=" ++ dist_dir ++ "/hpc/vanilla" ]
cabal "test" ["test-Short", "--show-details=direct"]
shouldNotExist $ htmlDir dist_dir Vanilla "test-Short" </> "hpc_index.html"
]
]
where
tc :: String -> String -> TestM a -> TestTree
tc :: String -> String -> TestM a -> TestTreeM ()
tc name subname m
= testCase name
= testTree' $ testCase name
(runTestM config "TestSuiteTests/ExeV10" (Just subname) m)
hpcTestMatrix :: SuiteConfig -> [TestTree]
hpcTestMatrix config = do
libProf <- [True, False]
exeProf <- [True, False]
exeDyn <- [True, False]
shared <- [True, False]
hpcTestMatrix :: SuiteConfig -> TestTreeM ()
hpcTestMatrix config = forM_ (choose4 [True, False]) $
\(libProf, exeProf, exeDyn, shared) -> do
let name | null suffixes = "Vanilla"
| otherwise = intercalate "-" suffixes
where
......@@ -91,7 +85,7 @@ hpcTestMatrix config = do
| otherwise = Nothing
-- Ensure that both .tix file and markup are generated if coverage
-- is enabled.
return $ tc name ("WithHpc-" ++ name) $ do
tc name ("WithHpc-" ++ name) $ do
isCorrectVersion <- liftIO $ correctHpcVersion
when isCorrectVersion $ do
dist_dir <- distDir
......@@ -111,11 +105,14 @@ hpcTestMatrix config = do
, htmlDir dist_dir way "test-Short" </> "hpc_index.html"
]
where
tc :: String -> String -> TestM a -> TestTree
tc :: String -> String -> TestM a -> TestTreeM ()
tc name subname m
= testCase name
= testTree' $ testCase name
(runTestM config "TestSuiteTests/ExeV10" (Just subname) m)
choose4 :: [a] -> [(a, a, a, a)]
choose4 xs = liftM4 (,,,) xs xs xs xs
-- | Checks for a suitable HPC version for testing.
correctHpcVersion :: IO Bool
correctHpcVersion = do
......
......@@ -10,62 +10,58 @@ import qualified PackageTests.TestSuiteTests.ExeV10.Check
import Control.Monad
import Data.Version
import Test.Tasty (TestTree, testGroup, mkTimeout, localOption)
import Test.Tasty (mkTimeout, localOption)
import Test.Tasty.HUnit (testCase)
-- TODO: turn this into a "test-defining writer monad".
-- This will let us handle scoping gracefully.
tests :: SuiteConfig -> [TestTree]
tests config =
tail [ undefined
tests :: SuiteConfig -> TestTreeM ()
tests config = do
---------------------------------------------------------------------
-- * External tests
-- Test that Cabal parses 'benchmark' sections correctly
, tc "BenchmarkStanza" PackageTests.BenchmarkStanza.Check.suite
tc "BenchmarkStanza" PackageTests.BenchmarkStanza.Check.suite
-- Test that Cabal parses 'test' sections correctly
, tc "TestStanza" PackageTests.TestStanza.Check.suite
tc "TestStanza" PackageTests.TestStanza.Check.suite
-- Test that Cabal determinstically generates object archives
, tc "DeterministicAr" PackageTests.DeterministicAr.Check.suite
tc "DeterministicAr" PackageTests.DeterministicAr.Check.suite
---------------------------------------------------------------------
-- * Test suite tests
, testGroup "TestSuiteTests"
groupTests "TestSuiteTests" $ do
-- Test exitcode-stdio-1.0 test suites (and HPC)
[ testGroup "ExeV10"
groupTests "ExeV10"
(PackageTests.TestSuiteTests.ExeV10.Check.tests config)
-- Test detailed-0.9 test suites
, testGroup "LibV09" $
groupTests "LibV09" $
let
tcs :: FilePath -> TestM a -> TestTree
tcs :: FilePath -> TestM a -> TestTreeM ()
tcs name m
= testCase name (runTestM config ("TestSuiteTests/LibV09")
(Just name) m)
in -- Test if detailed-0.9 builds correctly
[ tcs "Build" $ cabal_build ["--enable-tests"]
-- Tests for #2489, stdio deadlock
, localOption (mkTimeout $ 10 ^ (8 :: Int))
. tcs "Deadlock" $ do
cabal_build ["--enable-tests"]
shouldFail $ cabal "test" []
]
]
= testTree' $ testCase name (runTestM config ("TestSuiteTests/LibV09")
(Just name) m)
in do
-- Test if detailed-0.9 builds correctly
tcs "Build" $ cabal_build ["--enable-tests"]
-- Tests for #2489, stdio deadlock
mapTestTrees (localOption (mkTimeout $ 10 ^ (8 :: Int)))
. tcs "Deadlock" $ do
cabal_build ["--enable-tests"]
shouldFail $ cabal "test" []
---------------------------------------------------------------------
-- * Inline tests
-- Test if exitcode-stdio-1.0 benchmark builds correctly
, tc "BenchmarkExeV10" $ cabal_build ["--enable-benchmarks"]
tc "BenchmarkExeV10" $ cabal_build ["--enable-benchmarks"]
-- Test --benchmark-option(s) flags on ./Setup bench
, tc "BenchmarkOptions" $ do
tc "BenchmarkOptions" $ do
cabal_build ["--enable-benchmarks"]
cabal "bench" [ "--benchmark-options=1 2 3" ]
cabal "bench" [ "--benchmark-option=1"
......@@ -74,7 +70,7 @@ tests config =
]
-- Test --test-option(s) flags on ./Setup test
, tc "TestOptions" $ do
tc "TestOptions" $ do
cabal_build ["--enable-tests"]
cabal "test" ["--test-options=1 2 3"]
cabal "test" [ "--test-option=1"
......@@ -84,36 +80,36 @@ tests config =
-- Test attempt to have executable depend on internal
-- library, but cabal-version is too old.
, tc "BuildDeps/InternalLibrary0" $ do
tc "BuildDeps/InternalLibrary0" $ do
r <- shouldFail $ cabal' "configure" []
-- Should tell you how to enable the desired behavior
let sb = "library which is defined within the same package."
assertOutputContains sb r
-- Test executable depends on internal library.
, tc "BuildDeps/InternalLibrary1" $ cabal_build []
tc "BuildDeps/InternalLibrary1" $ cabal_build []
-- Test that internal library is preferred to an installed on
-- with the same name and version
, tc "BuildDeps/InternalLibrary2" $ internal_lib_test "internal"
tc "BuildDeps/InternalLibrary2" $ internal_lib_test "internal"
-- Test that internal library is preferred to an installed on
-- with the same name and LATER version
, tc "BuildDeps/InternalLibrary3" $ internal_lib_test "internal"
tc "BuildDeps/InternalLibrary3" $ internal_lib_test "internal"
-- Test that an explicit dependency constraint which doesn't
-- match the internal library causes us to use external library
, tc "BuildDeps/InternalLibrary4" $ internal_lib_test "installed"
tc "BuildDeps/InternalLibrary4" $ internal_lib_test "installed"
-- Test "old build-dep behavior", where we should get the
-- same package dependencies on all targets if cabal-version
-- is sufficiently old.
, tc "BuildDeps/SameDepsAllRound" $ cabal_build []
tc "BuildDeps/SameDepsAllRound" $ cabal_build []
-- Test "new build-dep behavior", where each target gets
-- separate dependencies. This tests that an executable
-- dep does not leak into the library.
, tc "BuildDeps/TargetSpecificDeps1" $ do
tc "BuildDeps/TargetSpecificDeps1" $ do
cabal "configure" []
r <- shouldFail $ cabal' "build" []
assertBool "error should be in MyLibrary.hs" $
......@@ -123,12 +119,12 @@ tests config =
-- This is a control on TargetSpecificDeps1; it should
-- succeed.
, tc "BuildDeps/TargetSpecificDeps2" $ cabal_build []
tc "BuildDeps/TargetSpecificDeps2" $ cabal_build []
-- Test "new build-dep behavior", where each target gets
-- separate dependencies. This tests that an library
-- dep does not leak into the executable.
, tc "BuildDeps/TargetSpecificDeps3" $ do
tc "BuildDeps/TargetSpecificDeps3" $ do
cabal "configure" []
r <- shouldFail $ cabal' "build" []
assertBool "error should be in lemon.hs" $
......@@ -137,38 +133,38 @@ tests config =
resultOutput r =~ "Could not find module.*Text\\.PrettyPrint"
-- Test that Paths module is generated and available for executables.
, tc "PathsModule/Executable" $ cabal_build []
tc "PathsModule/Executable" $ cabal_build []
-- Test that Paths module is generated and available for libraries.
, tc "PathsModule/Library" $ cabal_build []
tc "PathsModule/Library" $ cabal_build []
-- Check that preprocessors (hsc2hs) are run
, tc "PreProcess" $ cabal_build ["--enable-tests", "--enable-benchmarks"]
tc "PreProcess" $ cabal_build ["--enable-tests", "--enable-benchmarks"]
-- Check that preprocessors that generate extra C sources are handled
, tc "PreProcessExtraSources" $ cabal_build ["--enable-tests", "--enable-benchmarks"]
tc "PreProcessExtraSources" $ cabal_build ["--enable-tests", "--enable-benchmarks"]
-- Test building a vanilla library/executable which uses Template Haskell
, tc "TemplateHaskell/vanilla" $ cabal_build []
tc "TemplateHaskell/vanilla" $ cabal_build []
-- Test building a profiled library/executable which uses Template Haskell
-- (Cabal has to build the non-profiled version first)
, tc "TemplateHaskell/profiling" $ cabal_build ["--enable-library-profiling", "--enable-profiling"]
tc "TemplateHaskell/profiling" $ cabal_build ["--enable-library-profiling", "--enable-profiling"]
-- Test building a dynamic library/executable which uses Template
-- Haskell
, tc "TemplateHaskell/dynamic" $ cabal_build ["--enable-shared", "--enable-executable-dynamic"]
tc "TemplateHaskell/dynamic" $ cabal_build ["--enable-shared", "--enable-executable-dynamic"]
-- Test building an executable whose main() function is defined in a C
-- file
, tc "CMain" $ cabal_build []
tc "CMain" $ cabal_build []
-- Test build when the library is empty, for #1241
, tc "EmptyLib" $
tc "EmptyLib" $
withPackage "empty" $ cabal_build []
-- Test that "./Setup haddock" works correctly
, tc "Haddock" $ do
tc "Haddock" $ do
dist_dir <- distDir
let haddocksDir = dist_dir </> "doc" </> "html" </> "Haddock"
cabal "configure" []
......@@ -179,21 +175,21 @@ tests config =
mapM_ (assertFindInFile "For hiding needles.") docFiles
-- Test that Haddock with a newline in synopsis works correctly, #3004
, tc "HaddockNewline" $ do
tc "HaddockNewline" $ do
cabal "configure" []
cabal "haddock" []
-- Test that Cabal properly orders GHC flags passed to GHC (when
-- there are multiple ghc-options fields.)
, tc "OrderFlags" $ cabal_build []
tc "OrderFlags" $ cabal_build []
-- Test that reexported modules build correctly
-- TODO: should also test that they import OK!
, tc "ReexportedModules" $ do
tc "ReexportedModules" $ do
whenGhcVersion (>= Version [7,9] []) $ cabal_build []
-- Test that Cabal computes different IPIDs when the source changes.
, tc "UniqueIPID" . withPackageDb $ do
tc "UniqueIPID" . withPackageDb $ do
withPackage "P1" $ cabal "configure" []
withPackage "P2" $ cabal "configure" []
withPackage "P1" $ cabal "build" []
......@@ -207,7 +203,7 @@ tests config =
assertFailure $ "cabal has not calculated different Installed " ++
"package ID when source is changed."
, tc "DuplicateModuleName" $ do
tc "DuplicateModuleName" $ do
cabal_build ["--enable-tests"]
r1 <- shouldFail $ cabal' "test" ["foo"]
assertOutputContains "test B" r1
......@@ -216,7 +212,7 @@ tests config =
assertOutputContains "test C" r2
assertOutputContains "test A" r2
, tc "TestNameCollision" $ do
tc "TestNameCollision" $ do
withPackageDb $ do
withPackage "parent" $ cabal_install []
withPackage "child" $ do
......@@ -224,7 +220,7 @@ tests config =
cabal "test" []
-- Test that '--allow-newer' works via the 'Setup.hs configure' interface.
, tc "AllowNewer" $ do
tc "AllowNewer" $ do
shouldFail $ cabal "configure" []
cabal "configure" ["--allow-newer"]
shouldFail $ cabal "configure" ["--allow-newer=baz,quux"]
......@@ -251,21 +247,20 @@ tests config =
-- Test that Cabal can choose flags to disable building a component when that
-- component's dependencies are unavailable. The build should succeed without
-- requiring the component's dependencies or imports.
, tc "BuildableField" $ do
r <- cabal' "configure" ["-v"]
assertOutputContains "Flags chosen: build-exe=False" r
cabal "build" []
tc "BuildableField" $ do
r <- cabal' "configure" ["-v"]
assertOutputContains "Flags chosen: build-exe=False" r
cabal "build" []
, tc "GhcPkgGuess/SameDirectory" $ ghc_pkg_guess "ghc"
, tc "GhcPkgGuess/SameDirectoryVersion" $ ghc_pkg_guess "ghc-7.10"
, tc "GhcPkgGuess/SameDirectoryGhcVersion" $ ghc_pkg_guess "ghc-7.10"
tc "GhcPkgGuess/SameDirectory" $ ghc_pkg_guess "ghc"
tc "GhcPkgGuess/SameDirectoryVersion" $ ghc_pkg_guess "ghc-7.10"
tc "GhcPkgGuess/SameDirectoryGhcVersion" $ ghc_pkg_guess "ghc-7.10"
-- TODO: Disable these tests on Windows
, tc "GhcPkgGuess/Symlink" $ ghc_pkg_guess "ghc"
, tc "GhcPkgGuess/SymlinkVersion" $ ghc_pkg_guess "ghc"
, tc "GhcPkgGuess/SymlinkGhcVersion" $ ghc_pkg_guess "ghc"
tc "GhcPkgGuess/Symlink" $ ghc_pkg_guess "ghc"
tc "GhcPkgGuess/SymlinkVersion" $ ghc_pkg_guess "ghc"
tc "GhcPkgGuess/SymlinkGhcVersion" $ ghc_pkg_guess "ghc"
]
where
ghc_pkg_guess bin_name = do
cwd <- packageDir
......@@ -285,6 +280,5 @@ tests config =
("foo foo myLibFunc " ++ expect)
(concatOutput (resultOutput r))
tc :: FilePath -> TestM a -> TestTree
tc name m
= testCase name (runTestM config name Nothing m)
tc :: FilePath -> TestM a -> TestTreeM ()
tc name = testTree config name Nothing
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