From e94552e8ffe012e0534492e0276003b73e882b3b Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" <ezyang@cs.stanford.edu> Date: Sat, 26 Dec 2015 11:54:30 -0800 Subject: [PATCH] Rewrite the package test suite. I've rewritten the test suite to be more concise and "correct by construction". The primary method that this is achieved by is introducing the 'TestM' monad, which carries around the important state for the tests so that (1) we don't have to pass it as an argument all around, and (2) we can automatically make the correct decisions about how to do things. This new method emphasises "configuration by convention": we assume that a test-case named "Foo" has its test packages in the directory "tests/PackageTests/Foo". A secondary change is that all command functions automatically fail if they have a non-zero exit code (unless you use the 'shouldFail' combinator which inverts the sense.) This saves a lot of typing on test-cases. (In fact, I've reorganized all of the commands related here.) In the process, I've tightened up the logic for how to find the LocalBuildInfo of the Cabal we've testing, so we should now reliably be testing the inplace Cabal library, and not the system library (as was often the case.) Because things are a lot shorter, there is no good reason to make Check modules except for the biggest test cases. Most test-cases have been folded into PackageTests.Tests; if you have a small test-case you should just put it there. Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu> --- .gitignore | 7 + Cabal/Cabal.cabal | 35 +- Cabal/tests/PackageTests.hs | 326 +++---- .../PackageTests/BenchmarkExeV10/Check.hs | 16 - .../PackageTests/BenchmarkOptions/Check.hs | 26 - .../PackageTests/BenchmarkStanza/Check.hs | 49 +- .../BuildDeps/InternalLibrary0/Check.hs | 22 - .../BuildDeps/InternalLibrary1/Check.hs | 16 - .../BuildDeps/InternalLibrary2/Check.hs | 31 - .../BuildDeps/InternalLibrary3/Check.hs | 31 - .../BuildDeps/InternalLibrary4/Check.hs | 31 - .../BuildDeps/SameDepsAllRound/Check.hs | 21 - .../BuildDeps/TargetSpecificDeps1/Check.hs | 29 - .../BuildDeps/TargetSpecificDeps2/Check.hs | 21 - .../BuildDeps/TargetSpecificDeps3/Check.hs | 28 - Cabal/tests/PackageTests/CMain/Check.hs | 20 - Cabal/tests/PackageTests/CMain/Setup.hs | 3 - .../PackageTests/DeterministicAr/Check.hs | 41 +- Cabal/tests/PackageTests/EmptyLib/Check.hs | 16 - Cabal/tests/PackageTests/Haddock/Check.hs | 42 - Cabal/tests/PackageTests/OrderFlags/Check.hs | 24 - Cabal/tests/PackageTests/PackageTester.hs | 798 +++++++++++------- .../PathsModule/Executable/Check.hs | 16 - .../PackageTests/PathsModule/Library/Check.hs | 16 - Cabal/tests/PackageTests/PreProcess/Check.hs | 16 - .../PreProcessExtraSources/Check.hs | 16 - .../PackageTests/ReexportedModules/Check.hs | 41 - .../PackageTests/TemplateHaskell/Check.hs | 41 - Cabal/tests/PackageTests/TestOptions/Check.hs | 26 - Cabal/tests/PackageTests/TestStanza/Check.hs | 48 +- .../TestSuiteTests/ExeV10/Check.hs | 149 ++-- .../TestSuiteTests/LibV09/Check.hs | 41 - Cabal/tests/PackageTests/Tests.hs | 219 +++++ Cabal/tests/PackageTests/UniqueIPID/Check.hs | 47 -- 34 files changed, 1004 insertions(+), 1305 deletions(-) delete mode 100644 Cabal/tests/PackageTests/BenchmarkExeV10/Check.hs delete mode 100644 Cabal/tests/PackageTests/BenchmarkOptions/Check.hs delete mode 100644 Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs delete mode 100644 Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs delete mode 100644 Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs delete mode 100644 Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs delete mode 100644 Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs delete mode 100644 Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs delete mode 100644 Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs delete mode 100644 Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs delete mode 100644 Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs delete mode 100644 Cabal/tests/PackageTests/CMain/Check.hs delete mode 100644 Cabal/tests/PackageTests/CMain/Setup.hs delete mode 100644 Cabal/tests/PackageTests/EmptyLib/Check.hs delete mode 100644 Cabal/tests/PackageTests/Haddock/Check.hs delete mode 100644 Cabal/tests/PackageTests/OrderFlags/Check.hs delete mode 100644 Cabal/tests/PackageTests/PathsModule/Executable/Check.hs delete mode 100644 Cabal/tests/PackageTests/PathsModule/Library/Check.hs delete mode 100644 Cabal/tests/PackageTests/PreProcess/Check.hs delete mode 100644 Cabal/tests/PackageTests/PreProcessExtraSources/Check.hs delete mode 100644 Cabal/tests/PackageTests/ReexportedModules/Check.hs delete mode 100644 Cabal/tests/PackageTests/TemplateHaskell/Check.hs delete mode 100644 Cabal/tests/PackageTests/TestOptions/Check.hs delete mode 100644 Cabal/tests/PackageTests/TestSuiteTests/LibV09/Check.hs create mode 100644 Cabal/tests/PackageTests/Tests.hs delete mode 100644 Cabal/tests/PackageTests/UniqueIPID/Check.hs diff --git a/.gitignore b/.gitignore index 86353c146e..32aec1d42c 100644 --- a/.gitignore +++ b/.gitignore @@ -41,3 +41,10 @@ tags # stack artifacts /.stack-work/ + +# Shake artifacts +.shake +progress.txt + +# test files +dist-test diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal index 3a33e69987..1d91b5841a 100644 --- a/Cabal/Cabal.cabal +++ b/Cabal/Cabal.cabal @@ -76,7 +76,6 @@ extra-source-files: tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal tests/PackageTests/BuildTestSuiteDetailedV09/Dummy2.hs tests/PackageTests/CMain/Bar.hs - tests/PackageTests/CMain/Setup.hs tests/PackageTests/CMain/foo.c tests/PackageTests/CMain/my.cabal tests/PackageTests/DeterministicAr/Lib.hs @@ -299,37 +298,11 @@ test-suite package-tests type: exitcode-stdio-1.0 main-is: PackageTests.hs other-modules: - PackageTests.BenchmarkExeV10.Check - PackageTests.BenchmarkOptions.Check PackageTests.BenchmarkStanza.Check - PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check - PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check - PackageTests.BuildDeps.InternalLibrary0.Check - PackageTests.BuildDeps.InternalLibrary1.Check - PackageTests.BuildDeps.InternalLibrary2.Check - PackageTests.BuildDeps.InternalLibrary3.Check - PackageTests.BuildDeps.InternalLibrary4.Check - PackageTests.BuildDeps.SameDepsAllRound.Check - PackageTests.BuildDeps.TargetSpecificDeps1.Check - PackageTests.BuildDeps.TargetSpecificDeps2.Check - PackageTests.BuildDeps.TargetSpecificDeps3.Check - PackageTests.CMain.Check - PackageTests.DeterministicAr.Check - PackageTests.EmptyLib.Check - PackageTests.Haddock.Check - PackageTests.OrderFlags.Check - PackageTests.PackageTester - PackageTests.PathsModule.Executable.Check - PackageTests.PathsModule.Library.Check - PackageTests.PreProcess.Check - PackageTests.PreProcessExtraSources.Check - PackageTests.ReexportedModules.Check - PackageTests.TemplateHaskell.Check - PackageTests.TestOptions.Check PackageTests.TestStanza.Check + PackageTests.DeterministicAr.Check PackageTests.TestSuiteTests.ExeV10.Check - PackageTests.TestSuiteTests.LibV09.Check - PackageTests.UniqueIPID.Check + PackageTests.PackageTester Test.Distribution.Version Test.Laws Test.QuickCheck.Utils @@ -341,16 +314,16 @@ test-suite package-tests tasty-quickcheck, tasty-hunit, QuickCheck >= 2.1.0.1 && < 2.9, + transformers, Cabal, process, directory, filepath, - extensible-exceptions, bytestring, regex-posix, old-time if !os(windows) build-depends: unix - ghc-options: -Wall + ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-incomplete-patterns -rtsopts default-extensions: CPP default-language: Haskell98 diff --git a/Cabal/tests/PackageTests.hs b/Cabal/tests/PackageTests.hs index 7e725c7860..3ac9f6e2b9 100644 --- a/Cabal/tests/PackageTests.hs +++ b/Cabal/tests/PackageTests.hs @@ -6,179 +6,205 @@ module Main where -import PackageTests.BenchmarkExeV10.Check -import PackageTests.BenchmarkOptions.Check -import PackageTests.BenchmarkStanza.Check --- import PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check --- import PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check -import PackageTests.BuildDeps.InternalLibrary0.Check -import PackageTests.BuildDeps.InternalLibrary1.Check -import PackageTests.BuildDeps.InternalLibrary2.Check -import PackageTests.BuildDeps.InternalLibrary3.Check -import PackageTests.BuildDeps.InternalLibrary4.Check -import PackageTests.BuildDeps.SameDepsAllRound.Check -import PackageTests.BuildDeps.TargetSpecificDeps1.Check -import PackageTests.BuildDeps.TargetSpecificDeps2.Check -import PackageTests.BuildDeps.TargetSpecificDeps3.Check -import PackageTests.PackageTester (PackageSpec(..), SuiteConfig(..), compileSetup) -import PackageTests.PathsModule.Executable.Check -import PackageTests.PathsModule.Library.Check -import PackageTests.PreProcess.Check -import PackageTests.PreProcessExtraSources.Check -import PackageTests.TemplateHaskell.Check -import PackageTests.CMain.Check -import PackageTests.DeterministicAr.Check -import PackageTests.EmptyLib.Check -import PackageTests.Haddock.Check -import PackageTests.TestOptions.Check -import PackageTests.TestStanza.Check -import PackageTests.TestSuiteTests.ExeV10.Check -import PackageTests.TestSuiteTests.LibV09.Check -import PackageTests.OrderFlags.Check -import PackageTests.ReexportedModules.Check -import PackageTests.UniqueIPID.Check +import PackageTests.PackageTester +import PackageTests.Tests import Distribution.Simple.Configure ( ConfigStateFileError(..), findDistPrefOrDefault, getConfigStateFile ) import Distribution.Simple.Compiler (PackageDB(..)) import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..)) -import Distribution.Simple.Program.Types (programPath) +import Distribution.Simple.Program.Types (programPath, programVersion) import Distribution.Simple.Program.Builtin ( ghcProgram, ghcPkgProgram, haddockProgram ) import Distribution.Simple.Program.Db (requireProgram) import Distribution.Simple.Setup (Flag(..)) import Distribution.Simple.Utils (cabalVersion) import Distribution.Text (display) -import Distribution.Verbosity (normal) -import Distribution.Version (Version(Version)) +import Distribution.Verbosity (normal, flagToVerbosity) +import Distribution.ReadE (readEOrFail) -import Control.Exception (try, throw) -import Distribution.Compat.Environment ( setEnv ) -#if !MIN_VERSION_base(4,8,0) -import Data.Functor ((<$>)) -#endif +import Control.Exception +import Distribution.Compat.Environment ( lookupEnv ) import System.Directory - ( canonicalizePath, setCurrentDirectory ) -import System.FilePath ((</>)) import Test.Tasty -import Test.Tasty.HUnit - - -tests :: SuiteConfig -> Version -> [TestTree] -tests config version = - [ testCase "BuildDeps/SameDepsAllRound" - (PackageTests.BuildDeps.SameDepsAllRound.Check.suite config) - -- The two following tests were disabled by Johan Tibell as - -- they have been failing for a long time: - -- , testCase "BuildDeps/GlobalBuildDepsNotAdditive1/" - -- (PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check.suite ghcPath) - -- , testCase "BuildDeps/GlobalBuildDepsNotAdditive2/" - -- (PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check.suite ghcPath) - , testCase "BuildDeps/InternalLibrary0" - (PackageTests.BuildDeps.InternalLibrary0.Check.suite config version) - , testCase "PreProcess" (PackageTests.PreProcess.Check.suite config) - , testCase "PreProcessExtraSources" - (PackageTests.PreProcessExtraSources.Check.suite config) - , testCase "TestStanza" (PackageTests.TestStanza.Check.suite config) - -- ^ The Test stanza test will eventually be required - -- only for higher versions. - , testGroup "TestSuiteTests" - [ testGroup "ExeV10" - (PackageTests.TestSuiteTests.ExeV10.Check.checks config) - , testGroup "LibV09" - (PackageTests.TestSuiteTests.LibV09.Check.checks config) - ] - , testCase "TestOptions" (PackageTests.TestOptions.Check.suite config) - , testCase "BenchmarkStanza" (PackageTests.BenchmarkStanza.Check.suite config) - -- ^ The benchmark stanza test will eventually be required - -- only for higher versions. - , testCase "BenchmarkExeV10/Test" - (PackageTests.BenchmarkExeV10.Check.checkBenchmark config) - , testCase "BenchmarkOptions" (PackageTests.BenchmarkOptions.Check.suite config) - , testCase "TemplateHaskell/vanilla" - (PackageTests.TemplateHaskell.Check.vanilla config) - , testCase "TemplateHaskell/profiling" - (PackageTests.TemplateHaskell.Check.profiling config) - , testCase "PathsModule/Executable" - (PackageTests.PathsModule.Executable.Check.suite config) - , testCase "PathsModule/Library" - (PackageTests.PathsModule.Library.Check.suite config) - , testCase "DeterministicAr" - (PackageTests.DeterministicAr.Check.suite config) - , testCase "EmptyLib/emptyLib" - (PackageTests.EmptyLib.Check.emptyLib config) - , testCase "Haddock" (PackageTests.Haddock.Check.suite config) - , testCase "OrderFlags" - (PackageTests.OrderFlags.Check.suite config) - , testCase "TemplateHaskell/dynamic" - (PackageTests.TemplateHaskell.Check.dynamic config) - , testCase "ReexportedModules" - (PackageTests.ReexportedModules.Check.suite config) - , testCase "UniqueIPID" - (PackageTests.UniqueIPID.Check.suite config) - ] ++ - -- These tests are only required to pass on cabal version >= 1.7 - (if version >= Version [1, 7] [] - then [ testCase "BuildDeps/TargetSpecificDeps1" - (PackageTests.BuildDeps.TargetSpecificDeps1.Check.suite config) - , testCase "BuildDeps/TargetSpecificDeps2" - (PackageTests.BuildDeps.TargetSpecificDeps2.Check.suite config) - , testCase "BuildDeps/TargetSpecificDeps3" - (PackageTests.BuildDeps.TargetSpecificDeps3.Check.suite config) - , testCase "BuildDeps/InternalLibrary1" - (PackageTests.BuildDeps.InternalLibrary1.Check.suite config) - , testCase "BuildDeps/InternalLibrary2" - (PackageTests.BuildDeps.InternalLibrary2.Check.suite config) - , testCase "BuildDeps/InternalLibrary3" - (PackageTests.BuildDeps.InternalLibrary3.Check.suite config) - , testCase "BuildDeps/InternalLibrary4" - (PackageTests.BuildDeps.InternalLibrary4.Check.suite config) - , testCase "PackageTests/CMain" - (PackageTests.CMain.Check.checkBuild config) - ] - else []) +import Data.Maybe + +#if MIN_VERSION_base(4,6,0) +import System.Environment ( getExecutablePath ) +#endif main :: IO () main = do - -- Find the builddir used to build Cabal - distPref_ <- findDistPrefOrDefault NoFlag >>= canonicalizePath - -- Use the default builddir for all of the subsequent package tests - setEnv "CABAL_BUILDDIR" "dist" - lbi <- getPersistBuildConfig_ (distPref_ </> "setup-config") - (ghc, _) <- requireProgram normal ghcProgram (withPrograms lbi) - (ghcPkg, _) <- requireProgram normal ghcPkgProgram (withPrograms lbi) + -- In abstract, the Cabal test suite makes calls to the "Setup" + -- executable and tests the output of Cabal. However, we have to + -- responsible for building this executable in the first place, + -- since (1) Cabal doesn't support a test-suite depending on an + -- executable, so we can't put a "Setup" executable in the Cabal + -- file and then depend on it, (2) we don't want to call the Cabal + -- functions *directly* because we need to capture and save the + -- stdout and stderr, and (3) even if we could do all that, we will + -- want to test some Custom setup scripts, which will be specific to + -- the test at hand and need to be compiled against Cabal. + -- + -- To be able to build the executable, there is some information + -- we need: + -- + -- 1. We need to know what ghc to use, + -- + -- 2. We need to know what package databases (plural!) contain + -- all of the necessary dependencies to make our Cabal package + -- well-formed. + -- + -- We could have the user pass these all in as arguments (TODO: this + -- should be an option), but there's a more convenient way to get + -- this information: the *build configuration* that was used to + -- build the Cabal library (and this test suite) in the first place. + -- To do this, we need to find the 'dist' directory that was set as + -- the build directory for Cabal. + + dist_dir <- guessDistDir + lbi <- getPersistBuildConfig_ (dist_dir </> "setup-config") + + -- Put ourselves in the right directory. We do this by looking + -- at the location of Cabal.cabal. For the remainder of the + -- execution of this program, this will be our CWD; however, + -- subprocess calls may have different CWDs. + case pkgDescrFile lbi of + Nothing -> error "Can't find Cabal.cabal" + -- Double check! + Just f + -- Sufficiently new version of Cabal will have this working + | isAbsolute f -> do + test_dir <- canonicalizePath (dropFileName f) + setCurrentDirectory test_dir + -- Otherwise, just require package-tests to be run from + -- the correct directory + | otherwise -> return () + test_dir <- getCurrentDirectory + + -- Pull out the information we need from the LBI + -- TODO: The paths to GHC should be configurable by command line, + -- but it's tricky: some tests might depend on the Cabal library, in + -- which case you REALLY need to have built and installed Cabal for + -- the version that the test suite is being built against. The + -- easiest thing to do is make sure you built Cabal the same way as + -- you will run the tests. + (ghcConf, _) <- requireProgram normal ghcProgram (withPrograms lbi) + (ghcPkgConf, _) <- requireProgram normal ghcPkgProgram (withPrograms lbi) (haddock, _) <- requireProgram normal haddockProgram (withPrograms lbi) - packageDBStack' <- mapM canonicalizePackageDB $ withPackageDB lbi - let haddockPath = programPath haddock - inplaceDBFile = distPref_ </> "package.conf.inplace" - config = SuiteConfig - { cabalDistPref = distPref_ - , ghcPath = programPath ghc - , ghcPkgPath = programPath ghcPkg - , inplaceSpec = PackageSpec - { directory = [] - , configOpts = - [ "--package-db=" ++ inplaceDBFile - , "--constraint=Cabal == " ++ display cabalVersion - ] - , distPref = Nothing - } - , packageDBStack = packageDBStack' + -- Package DBs are not guaranteed to be absolute, so make them so in + -- case a subprocess using the package DB needs a different CWD. + packageDBStack0 <- mapM canonicalizePackageDB (withPackageDB lbi) + + -- The packageDBStack is worth some commentary. The database + -- stack we extract from the LBI will contain enough package + -- databases to make the Cabal package well-formed. However, + -- it does not *contain* the inplace installed Cabal package. + -- So we need to add that to the stack. + let packageDBStack1 + = packageDBStack0 ++ + [SpecificPackageDB + (dist_dir </> "package.conf.inplace")] + + -- THIS ISN'T EVEN MY FINAL FORM. The package database stack + -- controls where we install a package; specifically, the package is + -- installed to the top-most package on the stack (this makes the + -- most sense, since it could depend on any of the packages below + -- it.) If the test wants to register anything (as opposed to just + -- working in place), then we need to have another temporary + -- database we can install into (and not accidentally clobber any of + -- the other stacks.) This is done on a per-test basis. + -- + -- ONE MORE THING. On the subject of installing the package (with + -- copy/register) it is EXTREMELY important that we also overload + -- the install directories, so we don't clobber anything in the + -- default install paths. VERY IMPORTANT. + + -- TODO: make this controllable by a flag + verbosity <- maybe normal (readEOrFail flagToVerbosity) `fmap` lookupEnv "VERBOSE" + -- The inplaceDB is where the Cabal library was registered + -- in place (and is usable.) inplaceConfig is a convenient + -- set of flags to make sure we make it visible. + let suite = SuiteConfig + { cabalDistPref = dist_dir + , ghcPath = programPath ghcConf + , ghcVersion = fromJust (programVersion ghcConf) + , ghcPkgPath = programPath ghcPkgConf + , packageDBStack = packageDBStack1 + , suiteVerbosity = verbosity + , absoluteCWD = test_dir } + putStrLn $ "Cabal test suite - testing cabal version " ++ display cabalVersion - putStrLn $ "Using ghc: " ++ ghcPath config - putStrLn $ "Using ghc-pkg: " ++ ghcPkgPath config - putStrLn $ "Using haddock: " ++ haddockPath - setCurrentDirectory "tests" + putStrLn $ "Cabal build directory: " ++ dist_dir + putStrLn $ "Test directory: " ++ test_dir + putStrLn $ "Using ghc: " ++ ghcPath suite + putStrLn $ "Using ghc-pkg: " ++ ghcPkgPath suite + putStrLn $ "Using haddock: " ++ programPath haddock + -- Create a shared Setup executable to speed up Simple tests putStrLn $ "Building shared ./Setup executable" - compileSetup config "." - defaultMain $ testGroup "Package Tests" - (tests config cabalVersion) + rawCompileSetup verbosity suite [] "tests" + + defaultMain $ testGroup "Package Tests" (tests suite) --- Like Distribution.Simple.Configure.getPersistBuildConfig but +-- | Guess what the 'dist' directory Cabal was installed in is. There's +-- no 100% reliable way to find this, but there are a few good shots: +-- +-- 1. Test programs are ~always built in-place, in a directory +-- that looks like dist/build/package-tests/package-tests; +-- thus the directory can be determined by looking at $0. +-- This method is robust against sandboxes, Nix local +-- builds, and Stack, but doesn't work if you're running +-- in an interpreter. +-- +-- 2. We can use the normal input methods (as per Cabal), +-- checking for the CABAL_BUILDDIR environment variable as +-- well as the default location in the current working directory. +guessDistDir :: IO FilePath +guessDistDir = do +#if MIN_VERSION_base(4,6,0) + -- Method (1) + -- TODO: this needs to be BC'ified, probably. + exe_path <- canonicalizePath =<< getExecutablePath + -- exe_path is something like /path/to/dist/build/package-tests/package-tests + let dist0 = dropFileName exe_path </> ".." </> ".." + b <- doesFileExist (dist0 </> "setup-config") +#else + let dist0 = error "no path" + b = False +#endif + -- Method (2) + if b then canonicalizePath dist0 + else findDistPrefOrDefault NoFlag >>= canonicalizePath + +canonicalizePackageDB :: PackageDB -> IO PackageDB +canonicalizePackageDB (SpecificPackageDB path) + = SpecificPackageDB `fmap` canonicalizePath path +canonicalizePackageDB x = return x + +-- | Like Distribution.Simple.Configure.getPersistBuildConfig but -- doesn't check that the Cabal version matches, which it doesn't when -- we run Cabal's own test suite, due to bootstrapping issues. +-- Here's the situation: +-- +-- 1. There's some system Cabal-1.0 installed. We use this +-- to build Setup.hs +-- 2. We run ./Setup configure, which uses Cabal-1.0 to +-- write out the LocalBuildInfo +-- 3. We build the Cabal library, whose version is Cabal-2.0 +-- 4. We build the package-tests executable, which LINKS AGAINST +-- Cabal-2.0 +-- 5. We try to read the LocalBuildInfo that ./Setup configure +-- wrote out, but it's Cabal-1.0 format! +-- +-- It's a bit skeevy that we're trying to read Cabal-1.0 LocalBuildInfo +-- using Cabal-2.0's parser, but this seems to work OK in practice +-- because LocalBuildInfo is a slow-moving data structure. If +-- we ever make a major change, this won't work, and we'll have to +-- take a different approach (either setting "build-type: Custom" +-- so we bootstrap with the most recent Cabal, or by writing the +-- information we need in another format.) getPersistBuildConfig_ :: FilePath -> IO LocalBuildInfo getPersistBuildConfig_ filename = do eLBI <- try $ getConfigStateFile filename @@ -187,7 +213,3 @@ getPersistBuildConfig_ filename = do Left (ConfigStateFileBadVersion _ _ (Left err)) -> throw err Left err -> throw err Right lbi -> return lbi - -canonicalizePackageDB :: PackageDB -> IO PackageDB -canonicalizePackageDB (SpecificPackageDB path) = SpecificPackageDB <$> canonicalizePath path -canonicalizePackageDB x = return x diff --git a/Cabal/tests/PackageTests/BenchmarkExeV10/Check.hs b/Cabal/tests/PackageTests/BenchmarkExeV10/Check.hs deleted file mode 100644 index 83b123bed6..0000000000 --- a/Cabal/tests/PackageTests/BenchmarkExeV10/Check.hs +++ /dev/null @@ -1,16 +0,0 @@ -module PackageTests.BenchmarkExeV10.Check - ( checkBenchmark - ) where - -import PackageTests.PackageTester -import System.FilePath -import Test.Tasty.HUnit - -dir :: FilePath -dir = "PackageTests" </> "BenchmarkExeV10" - -checkBenchmark :: SuiteConfig -> Assertion -checkBenchmark config = do - let spec = PackageSpec dir Nothing ["--enable-benchmarks"] - buildResult <- cabal_build config spec - assertBuildSucceeded buildResult diff --git a/Cabal/tests/PackageTests/BenchmarkOptions/Check.hs b/Cabal/tests/PackageTests/BenchmarkOptions/Check.hs deleted file mode 100644 index 54396c1812..0000000000 --- a/Cabal/tests/PackageTests/BenchmarkOptions/Check.hs +++ /dev/null @@ -1,26 +0,0 @@ -module PackageTests.BenchmarkOptions.Check where - -import PackageTests.PackageTester -import System.FilePath -import Test.Tasty.HUnit - -suite :: SuiteConfig -> Assertion -suite config = do - let spec = PackageSpec - { directory = "PackageTests" </> "BenchmarkOptions" - , configOpts = ["--enable-benchmarks"] - , distPref = Nothing - } - _ <- cabal_build config spec - result <- cabal_bench config spec ["--benchmark-options=1 2 3"] - let message = "\"cabal bench\" did not pass the correct options to the " - ++ "benchmark executable with \"--benchmark-options\"" - assertEqual message True $ successful result - result' <- cabal_bench config spec - [ "--benchmark-option=1" - , "--benchmark-option=2" - , "--benchmark-option=3" - ] - let message' = "\"cabal bench\" did not pass the correct options to the " - ++ "benchmark executable with \"--benchmark-option\"" - assertEqual message' True $ successful result' diff --git a/Cabal/tests/PackageTests/BenchmarkStanza/Check.hs b/Cabal/tests/PackageTests/BenchmarkStanza/Check.hs index 0f03dfd0b4..1c095a0a1c 100644 --- a/Cabal/tests/PackageTests/BenchmarkStanza/Check.hs +++ b/Cabal/tests/PackageTests/BenchmarkStanza/Check.hs @@ -1,38 +1,22 @@ module PackageTests.BenchmarkStanza.Check where -import Test.Tasty.HUnit -import System.FilePath import PackageTests.PackageTester + import Distribution.Version -import Distribution.PackageDescription.Parse - ( readPackageDescription ) -import Distribution.PackageDescription.Configuration - ( finalizePackageDescription ) +import Distribution.Simple.LocalBuildInfo import Distribution.Package - ( PackageName(..), Dependency(..) ) import Distribution.PackageDescription - ( PackageDescription(..), BuildInfo(..), Benchmark(..) - , BenchmarkInterface(..) - , emptyBuildInfo - , emptyBenchmark ) -import Distribution.Verbosity (silent) -import Distribution.System (buildPlatform) -import Distribution.Compiler - ( CompilerId(..), CompilerFlavor(..), unknownCompilerInfo, AbiTag(..) ) -import Distribution.Text -suite :: SuiteConfig -> Assertion -suite config = do - let dir = "PackageTests" </> "BenchmarkStanza" - pdFile = dir </> "my" <.> "cabal" - spec = PackageSpec { directory = dir, configOpts = [], distPref = Nothing } - result <- cabal_configure config spec - assertOutputDoesNotContain "unknown section type" result - genPD <- readPackageDescription silent pdFile - let compiler = unknownCompilerInfo (CompilerId GHC $ Version [6, 12, 2] []) NoAbiTag - anticipatedBenchmark = emptyBenchmark +suite :: TestM () +suite = do + assertOutputDoesNotContain "unknown section type" + =<< cabal "configure" [] + dist_dir <- distDir + lbi <- liftIO $ getPersistBuildConfig dist_dir + let anticipatedBenchmark = emptyBenchmark { benchmarkName = "dummy" - , benchmarkInterface = BenchmarkExeV10 (Version [1,0] []) "dummy.hs" + , benchmarkInterface = BenchmarkExeV10 (Version [1,0] []) + "dummy.hs" , benchmarkBuildInfo = emptyBuildInfo { targetBuildDepends = [ Dependency (PackageName "base") anyVersion ] @@ -40,10 +24,7 @@ suite config = do } , benchmarkEnabled = False } - case finalizePackageDescription [] (const True) buildPlatform compiler [] genPD of - Left xs -> let depMessage = "should not have missing dependencies:\n" ++ - (unlines $ map (show . disp) xs) - in assertEqual depMessage True False - Right (f, _) -> let gotBenchmark = head $ benchmarks f - in assertEqual "parsed benchmark stanza does not match anticipated" - gotBenchmark anticipatedBenchmark + gotBenchmark = head $ benchmarks (localPkgDescr lbi) + assertEqual "parsed benchmark stanza does not match anticipated" + anticipatedBenchmark gotBenchmark + return () diff --git a/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs b/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs deleted file mode 100644 index e7ef5de96a..0000000000 --- a/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs +++ /dev/null @@ -1,22 +0,0 @@ -module PackageTests.BuildDeps.InternalLibrary0.Check where - -import Control.Monad -import Data.Version -import PackageTests.PackageTester -import System.FilePath -import Test.Tasty.HUnit - - -suite :: SuiteConfig -> Version -> Assertion -suite config cabalVersion = do - let spec = PackageSpec - { directory = "PackageTests" </> "BuildDeps" </> "InternalLibrary0" - , configOpts = [] - , distPref = Nothing - } - result <- cabal_build config spec - assertBuildFailed result - when (cabalVersion >= Version [1, 7] []) $ do - let sb = "library which is defined within the same package." - -- In 1.7 it should tell you how to enable the desired behaviour. - assertOutputContains sb result diff --git a/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs b/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs deleted file mode 100644 index 5e0f9f3ba0..0000000000 --- a/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs +++ /dev/null @@ -1,16 +0,0 @@ -module PackageTests.BuildDeps.InternalLibrary1.Check where - -import PackageTests.PackageTester -import System.FilePath -import Test.Tasty.HUnit - - -suite :: SuiteConfig -> Assertion -suite config = do - let spec = PackageSpec - { directory = "PackageTests" </> "BuildDeps" </> "InternalLibrary1" - , configOpts = [] - , distPref = Nothing - } - result <- cabal_build config spec - assertBuildSucceeded result diff --git a/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs b/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs deleted file mode 100644 index b35882685f..0000000000 --- a/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs +++ /dev/null @@ -1,31 +0,0 @@ -module PackageTests.BuildDeps.InternalLibrary2.Check where - -import qualified Data.ByteString.Char8 as C -import PackageTests.PackageTester -import System.FilePath -import Test.Tasty.HUnit - - -suite :: SuiteConfig -> Assertion -suite config = do - let spec = PackageSpec - { directory = "PackageTests" </> "BuildDeps" </> "InternalLibrary2" - , configOpts = [] - , distPref = Nothing - } - let specTI = PackageSpec - { directory = directory spec </> "to-install" - , configOpts = [] - , distPref = Nothing - } - - unregister config "InternalLibrary2" - iResult <- cabal_install config specTI - assertInstallSucceeded iResult - bResult <- cabal_build config spec - assertBuildSucceeded bResult - unregister config "InternalLibrary2" - - (_, _, 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 deleted file mode 100644 index 9edfa55cbc..0000000000 --- a/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs +++ /dev/null @@ -1,31 +0,0 @@ -module PackageTests.BuildDeps.InternalLibrary3.Check where - -import qualified Data.ByteString.Char8 as C -import PackageTests.PackageTester -import System.FilePath -import Test.Tasty.HUnit - - -suite :: SuiteConfig -> Assertion -suite config = do - let spec = PackageSpec - { directory = "PackageTests" </> "BuildDeps" </> "InternalLibrary3" - , configOpts = [] - , distPref = Nothing - } - let specTI = PackageSpec - { directory = directory spec </> "to-install" - , configOpts = [] - , distPref = Nothing - } - - unregister config "InternalLibrary3" - iResult <- cabal_install config specTI - assertInstallSucceeded iResult - bResult <- cabal_build config spec - assertBuildSucceeded bResult - unregister config "InternalLibrary3" - - (_, _, 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 deleted file mode 100644 index 6ccc0a9e04..0000000000 --- a/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs +++ /dev/null @@ -1,31 +0,0 @@ -module PackageTests.BuildDeps.InternalLibrary4.Check where - -import qualified Data.ByteString.Char8 as C -import PackageTests.PackageTester -import System.FilePath -import Test.Tasty.HUnit - - -suite :: SuiteConfig -> Assertion -suite config = do - let spec = PackageSpec - { directory = "PackageTests" </> "BuildDeps" </> "InternalLibrary4" - , configOpts = [] - , distPref = Nothing - } - let specTI = PackageSpec - { directory = directory spec </> "to-install" - , configOpts = [] - , distPref = Nothing - } - - unregister config "InternalLibrary4" - iResult <- cabal_install config specTI - assertInstallSucceeded iResult - bResult <- cabal_build config spec - assertBuildSucceeded bResult - unregister config "InternalLibrary4" - - (_, _, 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/BuildDeps/SameDepsAllRound/Check.hs b/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs deleted file mode 100644 index 80d4d34076..0000000000 --- a/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs +++ /dev/null @@ -1,21 +0,0 @@ -module PackageTests.BuildDeps.SameDepsAllRound.Check where - -import Test.Tasty.HUnit -import PackageTests.PackageTester -import System.FilePath -import qualified Control.Exception as E - - -suite :: SuiteConfig -> Assertion -suite config = do - let spec = PackageSpec - { directory = "PackageTests" </> "BuildDeps" </> "SameDepsAllRound" - , configOpts = [] - , distPref = Nothing - } - result <- cabal_build config spec - do - assertEqual "cabal build should succeed - see test-log.txt" True (successful result) - `E.catch` \exc -> do - putStrLn $ "Cabal result was "++show result - E.throwIO (exc :: E.SomeException) diff --git a/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs b/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs deleted file mode 100644 index e10fbd5d1b..0000000000 --- a/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs +++ /dev/null @@ -1,29 +0,0 @@ -module PackageTests.BuildDeps.TargetSpecificDeps1.Check where - -import Test.Tasty.HUnit -import PackageTests.PackageTester -import System.FilePath -import Data.List -import qualified Control.Exception as E -import Text.Regex.Posix - - -suite :: SuiteConfig -> Assertion -suite config = do - let spec = PackageSpec - { directory = "PackageTests" </> "BuildDeps" </> "TargetSpecificDeps1" - , configOpts = [] - , distPref = Nothing - } - result <- cabal_build config spec - do - assertEqual "cabal build should fail - see test-log.txt" False (successful result) - assertBool "error should be in MyLibrary.hs" $ - "MyLibrary.hs:" `isInfixOf` outputText result - assertBool "error should be \"Could not find module `System.Time\"" $ - (intercalate " " $ lines $ outputText result) - =~ "Could not find module.*System.Time" - - `E.catch` \exc -> do - putStrLn $ "Cabal result was "++show result - E.throwIO (exc :: E.SomeException) diff --git a/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs b/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs deleted file mode 100644 index 55513ba9fb..0000000000 --- a/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs +++ /dev/null @@ -1,21 +0,0 @@ -module PackageTests.BuildDeps.TargetSpecificDeps2.Check where - -import Test.Tasty.HUnit -import PackageTests.PackageTester -import System.FilePath -import qualified Control.Exception as E - - -suite :: SuiteConfig -> Assertion -suite config = do - let spec = PackageSpec - { directory = "PackageTests" </> "BuildDeps" </> "TargetSpecificDeps2" - , configOpts = [] - , distPref = Nothing - } - result <- cabal_build config spec - do - assertEqual "cabal build should succeed - see test-log.txt" True (successful result) - `E.catch` \exc -> do - putStrLn $ "Cabal result was "++show result - E.throwIO (exc :: E.SomeException) diff --git a/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs b/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs deleted file mode 100644 index 2beecbefca..0000000000 --- a/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs +++ /dev/null @@ -1,28 +0,0 @@ -module PackageTests.BuildDeps.TargetSpecificDeps3.Check where - -import Test.Tasty.HUnit -import PackageTests.PackageTester -import System.FilePath -import Data.List -import qualified Control.Exception as E -import Text.Regex.Posix - - -suite :: SuiteConfig -> Assertion -suite config = do - let spec = PackageSpec - { directory = "PackageTests" </> "BuildDeps" </> "TargetSpecificDeps3" - , configOpts = [] - , distPref = Nothing - } - result <- cabal_build config spec - do - assertEqual "cabal build should fail - see test-log.txt" False (successful result) - assertBool "error should be in lemon.hs" $ - "lemon.hs:" `isInfixOf` outputText result - assertBool "error should be \"Could not find module `System.Time\"" $ - (intercalate " " $ lines $ outputText result) - =~ "Could not find module.*System.Time" - `E.catch` \exc -> do - putStrLn $ "Cabal result was "++show result - E.throwIO (exc :: E.SomeException) diff --git a/Cabal/tests/PackageTests/CMain/Check.hs b/Cabal/tests/PackageTests/CMain/Check.hs deleted file mode 100644 index c1c46d4686..0000000000 --- a/Cabal/tests/PackageTests/CMain/Check.hs +++ /dev/null @@ -1,20 +0,0 @@ -module PackageTests.CMain.Check - ( checkBuild - ) where - -import Test.Tasty.HUnit -import System.FilePath -import PackageTests.PackageTester - -dir :: FilePath -dir = "PackageTests" </> "CMain" - -checkBuild :: SuiteConfig -> Assertion -checkBuild config = do - let spec = PackageSpec - { directory = dir - , distPref = Nothing - , configOpts = [] - } - buildResult <- cabal_build config spec - assertBuildSucceeded buildResult diff --git a/Cabal/tests/PackageTests/CMain/Setup.hs b/Cabal/tests/PackageTests/CMain/Setup.hs deleted file mode 100644 index 200a2e51d0..0000000000 --- a/Cabal/tests/PackageTests/CMain/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Distribution.Simple -main = defaultMain - diff --git a/Cabal/tests/PackageTests/DeterministicAr/Check.hs b/Cabal/tests/PackageTests/DeterministicAr/Check.hs index e10e798f3d..95691bb95e 100644 --- a/Cabal/tests/PackageTests/DeterministicAr/Check.hs +++ b/Cabal/tests/PackageTests/DeterministicAr/Check.hs @@ -8,46 +8,23 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import Data.Char (isSpace) import PackageTests.PackageTester -import System.FilePath import System.IO -import Test.Tasty.HUnit (Assertion, assertFailure) import Distribution.Compiler (CompilerFlavor(..), CompilerId(..)) import Distribution.Package (getHSLibraryName) import Distribution.Version (Version(..)) import Distribution.Simple.Compiler (compilerId) -import Distribution.Simple.Configure (getPersistBuildConfig) import Distribution.Simple.LocalBuildInfo (LocalBuildInfo, compiler, localComponentId) --- Perhaps these should live in PackageTester. - --- For a polymorphic @IO a@ rather than @Assertion = IO ()@. -assertFailure' :: String -> IO a -assertFailure' msg = assertFailure msg >> return {-unpossible!-}undefined - ------------------------------------------------------------------------- - -this :: String -this = "DeterministicAr" - -suite :: SuiteConfig -> Assertion -suite config = do - let dir = "PackageTests" </> this - let spec = PackageSpec - { directory = dir - , configOpts = [] - , distPref = Nothing - } - - result <- cabal_build config spec - assertBuildSucceeded result - - let distBuild = dir </> "dist" </> "build" - lbi <- getPersistBuildConfig (dir </> "dist") - checkMetadata lbi distBuild +suite :: TestM () +suite = do + cabal_build [] + dist_dir <- distDir + lbi <- liftIO $ getPersistBuildConfig dist_dir + liftIO $ checkMetadata lbi (dist_dir </> "build") -- Almost a copypasta of Distribution.Simple.Program.Ar.wipeMetadata -checkMetadata :: LocalBuildInfo -> FilePath -> Assertion +checkMetadata :: LocalBuildInfo -> FilePath -> IO () checkMetadata lbi dir = withBinaryFile path ReadMode $ \ h -> do hFileSize h >>= checkArchive h where @@ -57,9 +34,9 @@ checkMetadata lbi dir = withBinaryFile path ReadMode $ \ h -> do CompilerId GHC version | version >= Version [7, 10] [] -> True _ -> False - checkError msg = assertFailure' $ + checkError msg = assertFailure ( "PackageTests.DeterministicAr.checkMetadata: " ++ msg ++ - " in " ++ path + " in " ++ path) >> undefined archLF = "!<arch>\x0a" -- global magic, 8 bytes x60LF = "\x60\x0a" -- header magic, 2 bytes metadata = BS.concat diff --git a/Cabal/tests/PackageTests/EmptyLib/Check.hs b/Cabal/tests/PackageTests/EmptyLib/Check.hs deleted file mode 100644 index aa4b9307bc..0000000000 --- a/Cabal/tests/PackageTests/EmptyLib/Check.hs +++ /dev/null @@ -1,16 +0,0 @@ -module PackageTests.EmptyLib.Check where - -import PackageTests.PackageTester -import System.FilePath -import Test.Tasty.HUnit - --- See https://github.com/haskell/cabal/issues/1241 -emptyLib :: SuiteConfig -> Assertion -emptyLib config = do - let spec = PackageSpec - { directory = "PackageTests" </> "EmptyLib" </> "empty" - , configOpts = [] - , distPref = Nothing - } - result <- cabal_build config spec - assertBuildSucceeded result diff --git a/Cabal/tests/PackageTests/Haddock/Check.hs b/Cabal/tests/PackageTests/Haddock/Check.hs deleted file mode 100644 index 5064936cd7..0000000000 --- a/Cabal/tests/PackageTests/Haddock/Check.hs +++ /dev/null @@ -1,42 +0,0 @@ -module PackageTests.Haddock.Check (suite) where - -import Control.Monad (unless, when) -import Data.List (isInfixOf) - -import System.FilePath ((</>)) -import System.Directory (doesDirectoryExist, removeDirectoryRecursive) -import Test.Tasty.HUnit (Assertion, assertFailure) - -import Distribution.Simple.Utils (withFileContents) -import PackageTests.PackageTester - (PackageSpec(..), SuiteConfig, assertHaddockSucceeded, cabal_haddock) - -this :: String -this = "Haddock" - -suite :: SuiteConfig -> Assertion -suite config = do - let dir = "PackageTests" </> this - haddocksDir = dir </> "dist" </> "doc" </> "html" </> "Haddock" - spec = PackageSpec - { directory = dir - , configOpts = [] - , distPref = Nothing - } - - haddocksDirExists <- doesDirectoryExist haddocksDir - when haddocksDirExists (removeDirectoryRecursive haddocksDir) - hResult <- cabal_haddock config spec [] - assertHaddockSucceeded hResult - - let docFiles = map (haddocksDir </>) - ["CPP.html", "Literate.html", "NoCPP.html", "Simple.html"] - mapM_ (assertFindInFile "For hiding needles.") docFiles - -assertFindInFile :: String -> FilePath -> Assertion -assertFindInFile needle path = - withFileContents path - (\contents -> - unless (needle `isInfixOf` contents) - (assertFailure ("expected: " ++ needle ++ "\n" ++ - " in file: " ++ path))) diff --git a/Cabal/tests/PackageTests/OrderFlags/Check.hs b/Cabal/tests/PackageTests/OrderFlags/Check.hs deleted file mode 100644 index a90d374508..0000000000 --- a/Cabal/tests/PackageTests/OrderFlags/Check.hs +++ /dev/null @@ -1,24 +0,0 @@ -module PackageTests.OrderFlags.Check where - -import Test.Tasty.HUnit -import PackageTests.PackageTester -import System.FilePath -import Control.Exception - -#if !MIN_VERSION_base(4,6,0) -import Prelude hiding (catch) -#endif - -suite :: SuiteConfig -> Assertion -suite config = do - let spec = PackageSpec - { directory = "PackageTests" </> "OrderFlags" - , configOpts = [] - , distPref = Nothing - } - result <- cabal_build config spec - do - assertEqual "cabal build should succeed - see test-log.txt" True (successful result) - `catch` \exc -> do - putStrLn $ "Cabal result was "++show result - throwIO (exc :: SomeException) diff --git a/Cabal/tests/PackageTests/PackageTester.hs b/Cabal/tests/PackageTests/PackageTester.hs index 00d6feff6d..4a7c0985a5 100644 --- a/Cabal/tests/PackageTests/PackageTester.hs +++ b/Cabal/tests/PackageTests/PackageTester.hs @@ -1,367 +1,573 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE CPP #-} --- You can set the following VERBOSE environment variable to control --- the verbosity of the output generated by this module. module PackageTests.PackageTester - ( PackageSpec(..) + ( PackageSpec , SuiteConfig(..) - , Success(..) + , TestConfig(..) , Result(..) + , TestM + , runTestM + + -- * Paths + , packageDir + , distDir + , relativeDistDir + , sharedDBPath -- * Running cabal commands - , cabal_configure + , cabal , cabal_build - , cabal_haddock - , cabal_test - , cabal_bench , cabal_install - , cabal_register - , unregister + , ghcPkg , compileSetup , run + , runExe + , rawRun + , rawCompileSetup + , withPackage + , withEnv + , withPackageDb + + -- * Polymorphic versions of HUnit functions + , assertFailure + , assertEqual + , assertBool + , shouldExist + , shouldNotExist -- * Test helpers - , assertConfigureSucceeded - , assertBuildSucceeded - , assertBuildFailed - , assertHaddockSucceeded - , assertTestSucceeded - , assertTestFailed - , assertInstallSucceeded - , assertRegisterSucceeded - , assertRegisterFailed + , shouldFail + , whenGhcVersion , assertOutputContains , assertOutputDoesNotContain + , assertFindInFile + + , getPersistBuildConfig + + -- Common utilities + , module System.FilePath + , module Data.List + , module Control.Monad.IO.Class + , module Text.Regex.Posix ) where -import qualified Control.Exception.Extensible as E +import Distribution.Compat.CreatePipe (createPipe) +import Distribution.Simple.Compiler (PackageDBStack, PackageDB(..)) +import Distribution.Simple.Program.Run (getEffectiveEnvironment) +import Distribution.Simple.Utils + ( printRawCommandAndArgsAndEnv, withFileContents ) +import Distribution.Simple.Configure + ( getPersistBuildConfig ) +import Distribution.Verbosity (Verbosity) +import Distribution.Simple.BuildPaths (exeExtension) + +#ifndef CURRENT_PACKAGE_KEY +import Distribution.Simple.Utils (cabalVersion) +import Distribution.Text (display) +#endif + +import qualified Test.Tasty.HUnit as HUnit +import Text.Regex.Posix + +import qualified Control.Exception as E import Control.Monad +import Control.Monad.Trans.Reader +import Control.Monad.IO.Class import qualified Data.ByteString.Char8 as C import Data.List -import Data.Maybe -import System.Directory (canonicalizePath, doesFileExist) -import System.Environment (getEnv) -import System.Exit (ExitCode(ExitSuccess)) +import Data.Version +import System.Directory + ( doesFileExist, canonicalizePath, createDirectoryIfMissing + , removeDirectoryRecursive, getPermissions, setPermissions + , setOwnerExecutable ) +import System.Exit import System.FilePath -import System.IO (hIsEOF, hGetChar, hClose) +import System.IO import System.IO.Error (isDoesNotExistError) -import System.Process (runProcess, waitForProcess) -import Test.Tasty.HUnit (Assertion, assertFailure) - -import Distribution.Compat.CreatePipe (createPipe) -import Distribution.Simple.BuildPaths (exeExtension) -import Distribution.Simple.Compiler (PackageDBStack, PackageDB(..)) -import Distribution.Simple.Program.Run (getEffectiveEnvironment) -import Distribution.Simple.Utils (printRawCommandAndArgsAndEnv) -import Distribution.ReadE (readEOrFail) -import Distribution.Verbosity (Verbosity, flagToVerbosity, normal) - -data PackageSpec = PackageSpec - { directory :: FilePath - , distPref :: Maybe FilePath - , configOpts :: [String] - } - +import System.Process (runProcess, waitForProcess, showCommandForUser) + +-- | Our test monad maintains an environment recording the global test +-- suite configuration 'SuiteConfig', and the local per-test +-- configuration 'TestConfig'. +type TestM = ReaderT (SuiteConfig, TestConfig) IO + +-- | Run a test in the test monad. +runTestM :: SuiteConfig -> FilePath -> Maybe String -> TestM a -> IO () +runTestM suite name subname m = do + let test = TestConfig { + testMainName = name, + testSubName = subname, + testShouldFail = False, + testCurrentPackage = ".", + testPackageDb = False, + testEnvironment = [] + } + runReaderT (cleanup >> m) (suite, test) + return () + where + -- TODO: option not to clean up dist dirs; this should be + -- harmless! + cleanup = do + onlyIfExists . removeDirectoryRecursive =<< topDir + +-- | Run an IO action, and suppress a "does not exist" error. +onlyIfExists :: MonadIO m => IO () -> m () +onlyIfExists m = liftIO $ + E.catch m $ \(e :: IOError) -> + if isDoesNotExistError e + then return () + else E.throwIO e + +-- cleaning up: +-- cabal clean will clean up dist directory, but we also need to zap +-- Setup etc. +-- +-- Suggestion: just copy the files somewhere else! + +-- | Global configuration for the entire test suite. data SuiteConfig = SuiteConfig + -- | Where GHC lives { ghcPath :: FilePath + -- | Version of GHC + , ghcVersion :: Version + -- | Where ghc-pkg lives , ghcPkgPath :: FilePath + -- | The build directory that was used to build Cabal (used + -- to compile Setup scripts.) , cabalDistPref :: FilePath - , inplaceSpec :: PackageSpec + -- | Configuration options you can use to make the Cabal + -- being tested visible (e.g. if you're using the test runner). + -- We don't add these by default because then you have to + -- link against Cabal which makes the build go longer. , packageDBStack :: PackageDBStack + -- | How verbose should we be + , suiteVerbosity :: Verbosity + -- | The absolute current working directory + , absoluteCWD :: FilePath } -data Success = Failure - | ConfigureSuccess - | BuildSuccess - | HaddockSuccess - | InstallSuccess - | RegisterSuccess - | TestSuccess - | BenchSuccess - deriving (Eq, Show) - -data Result = Result - { successful :: Bool - , success :: Success - , outputText :: String - } deriving Show +data TestConfig = TestConfig + -- | Test name, MUST be the directory the test packages live in + -- relative to tests/PackageTests + { testMainName :: FilePath + -- | Test sub-name, used to qualify dist/database directory to avoid + -- conflicts. + , testSubName :: Maybe String + -- | This gets modified sometimes + , testShouldFail :: Bool + -- | The "current" package, ala current directory + , testCurrentPackage :: PackageSpec + -- | Says if we've initialized the per-test package DB + , testPackageDb :: Bool + -- | Environment override + , testEnvironment :: [(String, Maybe String)] + } -nullResult :: Result -nullResult = Result True Failure "" +-- | A package that can be built. +type PackageSpec = FilePath ------------------------------------------------------------------------ --- * Running cabal commands - -recordRun :: (String, ExitCode, String) -> Success -> Result -> Result -recordRun (cmd, exitCode, exeOutput) thisSucc res = - res { successful = successful res && exitCode == ExitSuccess - , success = if exitCode == ExitSuccess then thisSucc - else success res - , outputText = - (if null $ outputText res then "" else outputText res ++ "\n") ++ - cmd ++ "\n" ++ exeOutput - } +-- * Directories + +simpleSetupPath :: TestM FilePath +simpleSetupPath = do + (suite, _) <- ask + return (absoluteCWD suite </> "tests/Setup") + +-- | The absolute path to the directory containing the files for +-- this tests; usually @Check.hs@ and any test packages. +testDir :: TestM FilePath +testDir = do + (suite, test) <- ask + return $ absoluteCWD suite </> "tests/PackageTests" </> testMainName test + +-- | The absolute path to the root of the package directory; it's +-- where the Cabal file lives. This is what you want the CWD of cabal +-- calls to be. +packageDir :: TestM FilePath +packageDir = do + (_, test) <- ask + test_dir <- testDir + return $ test_dir </> testCurrentPackage test + +-- | The absolute path to the directory containing all the +-- files for ALL tests associated with a test (respecting +-- subtests.) To clean, you ONLY need to delete this directory. +topDir :: TestM FilePath +topDir = do + test_dir <- testDir + (_, test) <- ask + return $ test_dir </> + case testSubName test of + Nothing -> "dist-test" + Just n -> "dist-test." ++ n + +prefixDir :: TestM FilePath +prefixDir = do + top_dir <- topDir + return $ top_dir </> "usr" + +-- | The absolute path to the build directory that should be used +-- for the current package in a test. +distDir :: TestM FilePath +distDir = do + top_dir <- topDir + (_, test) <- ask + return $ top_dir </> testCurrentPackage test </> "dist" + +definitelyMakeRelative :: FilePath -> FilePath -> FilePath +definitelyMakeRelative base0 path0 = + let go [] path = joinPath path + go base [] = joinPath (replicate (length base) "..") + go (".":xs) ys = go xs ys + go xs (".":ys) = go xs ys + go (x:xs) (y:ys) + | x == y = go xs ys + | otherwise = go (x:xs) [] </> go [] (y:ys) + in go (splitPath base0) (splitPath path0) + +-- hpc is stupid and doesn't understand absolute paths. +relativeDistDir :: TestM FilePath +relativeDistDir = do + dist_dir0 <- distDir + pkg_dir <- packageDir + return $ definitelyMakeRelative pkg_dir dist_dir0 + +-- | The absolute path to the shared package database that should +-- be used by all packages in this test. +sharedDBPath :: TestM FilePath +sharedDBPath = do + top_dir <- topDir + return $ top_dir </> "packagedb" -cabal_configure :: SuiteConfig -> PackageSpec -> IO Result -cabal_configure config spec = do - res <- doCabalConfigure config spec - record spec res - return res - -doCabalConfigure :: SuiteConfig -> PackageSpec -> IO Result -doCabalConfigure config spec = do - cleanResult@(_, _, _) <- cabal config spec [] ["clean"] - requireSuccess cleanResult - res <- cabal config spec [] - -- Use the package dbs from when we configured cabal rather than any - -- defaults. - (["configure", "--user", "-w", ghcPath config, "--package-db=clear"] - ++ packageDBParams (packageDBStack config) - ++ configOpts spec) - return $ recordRun res ConfigureSuccess nullResult +------------------------------------------------------------------------ +-- * Running cabal + +cabal :: String -> [String] -> TestM Result +cabal cmd extraArgs0 = do + (suite, test) <- ask + prefix_dir <- prefixDir + when ((cmd == "register" || cmd == "copy") && not (testPackageDb test)) $ + error "Cannot register/copy without using 'withPackageDb'" + let extraArgs1 = case cmd of + "configure" -> + -- If the package database is empty, setting --global + -- here will make us error loudly if we try to install + -- into a bad place. + [ "--global" + , "--with-ghc", ghcPath suite + , "--with-ghc-pkg", ghcPkgPath suite + -- Would really like to do this, but we're not always + -- going to be building against sufficiently recent + -- Cabal which provides this macro. + -- , "--dependency=Cabal=" ++ THIS_PACKAGE_KEY + -- These flags make the test suite run faster + -- Can't do this unless we LD_LIBRARY_PATH correctly + -- , "--enable-executable-dynamic" + , "--disable-optimization" + -- Specify where we want our installed packages to go + , "--prefix=" ++ prefix_dir + ] ++ packageDBParams (packageDBStack suite) + ++ extraArgs0 + -- This gives us MUCH better error messages + "build" -> "-v" : extraArgs0 + _ -> extraArgs0 + -- This is a horrible hack to make hpc work correctly + dist_dir <- relativeDistDir + let extraArgs = ["--distdir", dist_dir] ++ extraArgs1 + doCabal (cmd:extraArgs) + +-- | This abstracts the common pattern of configuring and then building. +cabal_build :: [String] -> TestM () +cabal_build args = do + cabal "configure" args + cabal "build" [] + return () + +-- | This abstracts the common pattern of "installing" a package. +cabal_install :: [String] -> TestM () +cabal_install args = do + cabal "configure" args + cabal "build" [] + cabal "copy" [] + cabal "register" [] + return () + +-- | Determines what Setup executable to run and runs it +doCabal :: [String] -- ^ extra arguments + -> TestM Result +doCabal cabalArgs = do + pkg_dir <- packageDir + customSetup <- liftIO $ doesFileExist (pkg_dir </> "Setup.hs") + if customSetup + then do + compileSetup + -- TODO make this less racey + let path = pkg_dir </> "Setup" + run (Just pkg_dir) path cabalArgs + else do + -- Use shared Setup executable (only for Simple build types). + path <- simpleSetupPath + run (Just pkg_dir) path cabalArgs packageDBParams :: PackageDBStack -> [String] -packageDBParams = map (("--package-db=" ++) . convert) where +packageDBParams dbs = "--package-db=clear" + : map (("--package-db=" ++) . convert) dbs + where convert :: PackageDB -> String convert GlobalPackageDB = "global" convert UserPackageDB = "user" convert (SpecificPackageDB path) = path -doCabalBuild :: SuiteConfig -> PackageSpec -> IO Result -doCabalBuild config spec = do - configResult <- doCabalConfigure config spec - if successful configResult - then do - res <- cabal config spec [] ["build", "-v"] - return $ recordRun res BuildSuccess configResult - else - return configResult - -cabal_build :: SuiteConfig -> PackageSpec -> IO Result -cabal_build config spec = do - res <- doCabalBuild config spec - record spec res - return res - -cabal_haddock :: SuiteConfig -> PackageSpec -> [String] -> IO Result -cabal_haddock config spec extraArgs = do - res <- doCabalHaddock config spec extraArgs - record spec res - return res - -doCabalHaddock :: SuiteConfig -> PackageSpec -> [String] -> IO Result -doCabalHaddock config spec extraArgs = do - configResult <- doCabalConfigure config spec - if successful configResult - then do - res <- cabal config spec [] ("haddock" : extraArgs) - return $ recordRun res HaddockSuccess configResult - else - return configResult - -unregister :: SuiteConfig -> String -> IO () -unregister config libraryName = do - res@(_, _, output) <- run Nothing (ghcPkgPath config) [] - ["unregister", "--user", libraryName] - if "cannot find package" `isInfixOf` output - then return () - else requireSuccess res - --- | Install this library in the user area -cabal_install :: SuiteConfig -> PackageSpec -> IO Result -cabal_install config spec = do - buildResult <- doCabalBuild config spec - res <- if successful buildResult - then do - res <- cabal config spec [] ["install"] - return $ recordRun res InstallSuccess buildResult - else - return buildResult - record spec res - return res - -cabal_register :: SuiteConfig -> PackageSpec -> [String] -> IO Result -cabal_register config spec extraArgs = do - res <- doCabalRegister config spec extraArgs - record spec res - return res - -doCabalRegister :: SuiteConfig -> PackageSpec -> [String] -> IO Result -doCabalRegister config spec extraArgs = do - configResult <- doCabalConfigure config spec - if successful configResult - then do - buildResult <- doCabalBuild config spec - if successful buildResult - then do res <- cabal config spec [] ("register" : extraArgs) - return $ recordRun res RegisterSuccess configResult - else return buildResult - else - return configResult - - -cabal_test :: SuiteConfig -> PackageSpec -> [(String, Maybe String)] - -> [String] -> IO Result -cabal_test config spec envOverrides extraArgs = do - res <- cabal config spec envOverrides ("test" : extraArgs) - let r = recordRun res TestSuccess nullResult - record spec r - return r +------------------------------------------------------------------------ +-- * Compiling setup scripts + +compileSetup :: TestM () +compileSetup = do + (suite, test) <- ask + pkg_path <- packageDir + liftIO $ rawCompileSetup (suiteVerbosity suite) suite (testEnvironment test) pkg_path + +rawCompileSetup :: Verbosity -> SuiteConfig -> [(String, Maybe String)] -> FilePath -> IO () +rawCompileSetup verbosity suite e path = do + r <- rawRun verbosity (Just path) (ghcPath suite) e $ + [ "--make"] ++ + ghcPackageDBParams (ghcVersion suite) (packageDBStack suite) ++ + [ "-hide-all-packages" + , "-package base" +#ifdef CURRENT_PACKAGE_KEY + -- This is best, but we don't necessarily have it + -- if we're bootstrapping with old Cabal. + , "-package-id " ++ CURRENT_PACKAGE_KEY +#else + -- This mostly works, UNLESS you've installed a + -- version of Cabal with the SAME version number. + -- Then old GHCs will incorrectly select the installed + -- version (because it prefers the FIRST package it finds.) + -- It also semi-works to not specify "-hide-all-packages" + -- at all, except if there's a later version of Cabal + -- installed GHC will prefer that. + , "-package Cabal-" ++ display cabalVersion +#endif + , "-O0" + , "Setup.hs" ] + unless (resultExitCode r == ExitSuccess) $ + error $ + "could not build shared Setup executable\n" ++ + " ran: " ++ resultCommand r ++ "\n" ++ + " output:\n" ++ resultOutput r ++ "\n\n" + +ghcPackageDBParams :: Version -> PackageDBStack -> [String] +ghcPackageDBParams ghc_version dbs + | ghc_version >= Version [7,6] [] + = "-clear-package-db" : map convert dbs + | otherwise + = concatMap convertLegacy dbs + where + convert :: PackageDB -> String + convert GlobalPackageDB = "-global-package-db" + convert UserPackageDB = "-user-package-db" + convert (SpecificPackageDB path) = "-package-db=" ++ path -cabal_bench :: SuiteConfig -> PackageSpec -> [String] -> IO Result -cabal_bench config spec extraArgs = do - res <- cabal config spec [] ("bench" : extraArgs) - let r = recordRun res BenchSuccess nullResult - record spec r - return r + convertLegacy :: PackageDB -> [String] + convertLegacy (SpecificPackageDB path) = ["-package-conf=" ++ path] + convertLegacy _ = [] -compileSetup :: SuiteConfig -> FilePath -> IO () -compileSetup config packageDir = do - r <- run (Just $ packageDir) (ghcPath config) [] - [ "--make" --- HPC causes trouble -- see #1012 --- , "-fhpc" - , "-package-conf " ++ (cabalDistPref config) </> "package.conf.inplace" - , "Setup.hs" - ] - requireSuccess r +------------------------------------------------------------------------ +-- * Running ghc-pkg + +ghcPkg :: String -> [String] -> TestM Result +ghcPkg cmd args = do + db_path <- sharedDBPath + (config, test) <- ask + unless (testPackageDb test) $ + error "Must initialize package database using withPackageDb" + let db_stack = packageDBStack config ++ [SpecificPackageDB db_path] + extraArgs = ghcPkgPackageDBParams (ghcVersion config) db_stack + run Nothing (ghcPkgPath config) (cmd : extraArgs ++ args) + +ghcPkgPackageDBParams :: Version -> PackageDBStack -> [String] +ghcPkgPackageDBParams version dbs = concatMap convert dbs where + convert :: PackageDB -> [String] + -- Ignoring global/user is dodgy but there's no way good + -- way to give ghc-pkg the correct flags in this case. + convert GlobalPackageDB = [] + convert UserPackageDB = [] + convert (SpecificPackageDB path) + | version >= Version [7,6] [] + = ["--package-db=" ++ path] + | otherwise + = ["--package-conf=" ++ path] --- | Returns the command that was issued, the return code, and the output text. -cabal :: SuiteConfig - -> PackageSpec - -> [(String, Maybe String)] -- ^ environment variable overrides - -> [String] -- ^ extra arguments - -> IO (String, ExitCode, String) -cabal config spec envOverrides cabalArgs_ = do - let cabalArgs = case distPref spec of - Nothing -> cabalArgs_ - Just dist -> ("--builddir=" ++ dist) : cabalArgs_ - customSetup <- doesFileExist (directory spec </> "Setup.hs") - if customSetup - then do - compileSetup config (directory spec) - path <- canonicalizePath $ directory spec </> "Setup" - 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 envOverrides cabalArgs +------------------------------------------------------------------------ +-- * Running other things + +-- | Running an executable that was produced by cabal. +runExe :: String -> [String] -> TestM Result +runExe exe_name args = do + dist_dir <- distDir + let exe = dist_dir </> "build" </> exe_name </> exe_name + run Nothing exe args --- | 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 +run :: Maybe FilePath -> String -> [String] -> TestM Result +run mb_cwd path args = do verbosity <- getVerbosity + (_, test) <- ask + r <- liftIO $ rawRun verbosity mb_cwd path (testEnvironment test) args + record r + requireSuccess r + +rawRun :: Verbosity -> Maybe FilePath -> String -> [(String, Maybe String)] -> [String] -> IO Result +rawRun verbosity mb_cwd path envOverrides args = do -- 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) + canonicalizePath (if pathExists then path + else path <.> exeExtension) menv <- getEffectiveEnvironment envOverrides printRawCommandAndArgsAndEnv verbosity path' args menv (readh, writeh) <- createPipe - pid <- runProcess path' args cwd menv Nothing (Just writeh) (Just writeh) + pid <- runProcess path' args mb_cwd menv Nothing (Just writeh) (Just writeh) - -- fork off a thread to start consuming the output - out <- suckH [] readh + out <- hGetContents readh + E.evaluate (length out) -- force the output hClose readh -- wait for the program to terminate exitcode <- waitForProcess pid - let fullCmd = unwords (path' : args) - return ("\"" ++ fullCmd ++ "\" in " ++ fromMaybe "" cwd, exitcode, out) - where - suckH output h = do - eof <- hIsEOF h - if eof - then return (reverse output) - else do - c <- hGetChar h - suckH (c:output) h - - -requireSuccess :: (String, ExitCode, String) -> IO () -requireSuccess (cmd, exitCode, output) = - unless (exitCode == ExitSuccess) $ - assertFailure $ "Command " ++ cmd ++ " failed.\n" ++ - "output: " ++ output - -record :: PackageSpec -> Result -> IO () -record spec res = do - C.writeFile (directory spec </> "test-log.txt") (C.pack $ outputText res) + return Result { + resultExitCode = exitcode, + resultDirectory = mb_cwd, + resultCommand = showCommandForUser path' args, + resultOutput = out + } ------------------------------------------------------------------------ --- * Test helpers - -assertConfigureSucceeded :: Result -> Assertion -assertConfigureSucceeded result = unless (successful result) $ - assertFailure $ - "expected: \'setup configure\' should succeed\n" ++ - " output: " ++ outputText result - -assertBuildSucceeded :: Result -> Assertion -assertBuildSucceeded result = unless (successful result) $ - assertFailure $ - "expected: \'setup build\' should succeed\n" ++ - " output: " ++ outputText result +-- * Subprocess run results -assertBuildFailed :: Result -> Assertion -assertBuildFailed result = when (successful result) $ - assertFailure $ - "expected: \'setup build\' should fail\n" ++ - " output: " ++ outputText result - -assertHaddockSucceeded :: Result -> Assertion -assertHaddockSucceeded result = unless (successful result) $ - assertFailure $ - "expected: \'setup haddock\' should succeed\n" ++ - " output: " ++ outputText result - -assertTestSucceeded :: Result -> Assertion -assertTestSucceeded result = unless (successful result) $ - assertFailure $ - "expected: \'setup test\' should succeed\n" ++ - " output: " ++ outputText result - -assertTestFailed :: Result -> Assertion -assertTestFailed result = when (successful result) $ - assertFailure $ - "expected: \'setup test\' should fail\n" ++ - " output: " ++ outputText result - -assertInstallSucceeded :: Result -> Assertion -assertInstallSucceeded result = unless (successful result) $ - assertFailure $ - "expected: \'setup install\' should succeed\n" ++ - " output: " ++ outputText result +data Result = Result + { resultExitCode :: ExitCode + , resultDirectory :: Maybe FilePath + , resultCommand :: String + , resultOutput :: String + } deriving Show -assertRegisterSucceeded :: Result -> Assertion -assertRegisterSucceeded result = unless (successful result) $ - assertFailure $ - "expected: \'setup register\' should succeed\n" ++ - " output: " ++ outputText result +requireSuccess :: Result -> TestM Result +requireSuccess r@Result { resultCommand = cmd + , resultExitCode = exitCode + , resultOutput = output } = do + (_, test) <- ask + when (exitCode /= ExitSuccess && not (testShouldFail test)) $ + assertFailure $ "Command " ++ cmd ++ " failed.\n" ++ + "Output:\n" ++ output ++ "\n" + when (exitCode == ExitSuccess && testShouldFail test) $ + assertFailure $ "Command " ++ cmd ++ " succeeded.\n" ++ + "Output:\n" ++ output ++ "\n" + return r -assertRegisterFailed :: Result -> Assertion -assertRegisterFailed result = when (successful result) $ - assertFailure $ - "expected: \'setup register\' should fail\n" ++ - " output: " ++ outputText result +record :: Result -> TestM () +record res = do + build_dir <- distDir + (suite, _) <- ask + liftIO $ createDirectoryIfMissing True build_dir + liftIO $ C.appendFile (build_dir </> "test.log") + (C.pack $ "+ " ++ resultCommand res ++ "\n" + ++ resultOutput res ++ "\n\n") + let test_sh = build_dir </> "test.sh" + b <- liftIO $ doesFileExist test_sh + when (not b) . liftIO $ do + -- This is hella racey but this is not that security important + C.appendFile test_sh + (C.pack $ "#/bin/sh\nset -ev\n" ++ + "cd "++ show (absoluteCWD suite) ++"\n") + perms <- getPermissions test_sh + setPermissions test_sh (setOwnerExecutable True perms) + + liftIO $ C.appendFile test_sh + (C.pack + (case resultDirectory res of + Nothing -> resultCommand res + Just d -> "(cd " ++ show d ++ " && " ++ resultCommand res ++ ")\n")) +------------------------------------------------------------------------ +-- * Test helpers -assertOutputContains :: String -> Result -> Assertion +assertFailure :: MonadIO m => String -> m () +assertFailure = liftIO . HUnit.assertFailure + +assertEqual :: (Eq a, Show a, MonadIO m) => String -> a -> a -> m () +assertEqual s x y = liftIO $ HUnit.assertEqual s x y + +assertBool :: MonadIO m => String -> Bool -> m () +assertBool s x = liftIO $ HUnit.assertBool s x + +shouldExist :: MonadIO m => FilePath -> m () +shouldExist path = liftIO $ doesFileExist path >>= assertBool (path ++ " should exist") + +shouldNotExist :: MonadIO m => FilePath -> m () +shouldNotExist path = + liftIO $ doesFileExist path >>= assertBool (path ++ " should exist") . not + +shouldFail :: TestM a -> TestM a +shouldFail = withReaderT (\(suite, test) -> (suite, test { testShouldFail = not (testShouldFail test) })) + +whenGhcVersion :: (Version -> Bool) -> TestM () -> TestM () +whenGhcVersion p m = do + (suite, _) <- ask + when (p (ghcVersion suite)) m + +withPackage :: FilePath -> TestM a -> TestM a +withPackage f = withReaderT (\(suite, test) -> (suite, test { testCurrentPackage = f })) + +-- TODO: Really should accumulate... but I think to do this +-- properly we can't just append +withEnv :: [(String, Maybe String)] -> TestM a -> TestM a +withEnv e m = do + (_, test0) <- ask + when (not (null (testEnvironment test0))) + $ error "nested withEnv (not yet) supported" + withReaderT (\(suite, test) -> (suite, test { testEnvironment = e })) m + +withPackageDb :: TestM a -> TestM a +withPackageDb m = do + (_, test0) <- ask + db_path <- sharedDBPath + if testPackageDb test0 + then m + else withReaderT (\(suite, test) -> + (suite { packageDBStack + = packageDBStack suite + ++ [SpecificPackageDB db_path] }, + test { testPackageDb = True })) + $ do ghcPkg "init" [db_path] + m + +assertOutputContains :: MonadIO m => String -> Result -> m () assertOutputContains needle result = unless (needle `isInfixOf` (concatOutput output)) $ assertFailure $ " expected: " ++ needle ++ "\n" ++ " in output: " ++ output ++ "" - where output = outputText result + where output = resultOutput result -assertOutputDoesNotContain :: String -> Result -> Assertion +assertOutputDoesNotContain :: MonadIO m => String -> Result -> m () assertOutputDoesNotContain needle result = when (needle `isInfixOf` (concatOutput output)) $ assertFailure $ "unexpected: " ++ needle ++ " in output: " ++ output - where output = outputText result + where output = resultOutput result + +assertFindInFile :: MonadIO m => String -> FilePath -> m () +assertFindInFile needle path = + liftIO $ withFileContents path + (\contents -> + unless (needle `isInfixOf` contents) + (assertFailure ("expected: " ++ needle ++ "\n" ++ + " in file: " ++ path))) -- | Replace line breaks with spaces, correctly handling "\r\n". concatOutput :: String -> String @@ -370,15 +576,5 @@ concatOutput = unwords . lines . filter ((/=) '\r') ------------------------------------------------------------------------ -- Verbosity -lookupEnv :: String -> IO (Maybe String) -lookupEnv name = - (fmap Just $ getEnv name) - `E.catch` \ (e :: IOError) -> - if isDoesNotExistError e - then return Nothing - else E.throw e - --- TODO: Convert to a "-v" flag instead. -getVerbosity :: IO Verbosity -getVerbosity = do - maybe normal (readEOrFail flagToVerbosity) `fmap` lookupEnv "VERBOSE" +getVerbosity :: TestM Verbosity +getVerbosity = fmap (suiteVerbosity . fst) ask diff --git a/Cabal/tests/PackageTests/PathsModule/Executable/Check.hs b/Cabal/tests/PackageTests/PathsModule/Executable/Check.hs deleted file mode 100644 index 4b8d7f27c7..0000000000 --- a/Cabal/tests/PackageTests/PathsModule/Executable/Check.hs +++ /dev/null @@ -1,16 +0,0 @@ -module PackageTests.PathsModule.Executable.Check (suite) where - -import PackageTests.PackageTester - (PackageSpec(..), SuiteConfig, assertBuildSucceeded, cabal_build) -import System.FilePath -import Test.Tasty.HUnit - -suite :: SuiteConfig -> Assertion -suite config = do - let spec = PackageSpec - { directory = "PackageTests" </> "PathsModule" </> "Executable" - , distPref = Nothing - , configOpts = [] - } - result <- cabal_build config spec - assertBuildSucceeded result diff --git a/Cabal/tests/PackageTests/PathsModule/Library/Check.hs b/Cabal/tests/PackageTests/PathsModule/Library/Check.hs deleted file mode 100644 index 30b2453019..0000000000 --- a/Cabal/tests/PackageTests/PathsModule/Library/Check.hs +++ /dev/null @@ -1,16 +0,0 @@ -module PackageTests.PathsModule.Library.Check (suite) where - -import PackageTests.PackageTester - (PackageSpec(..), SuiteConfig, assertBuildSucceeded, cabal_build) -import System.FilePath -import Test.Tasty.HUnit - -suite :: SuiteConfig -> Assertion -suite config = do - let spec = PackageSpec - { directory = "PackageTests" </> "PathsModule" </> "Library" - , distPref = Nothing - , configOpts = [] - } - result <- cabal_build config spec - assertBuildSucceeded result diff --git a/Cabal/tests/PackageTests/PreProcess/Check.hs b/Cabal/tests/PackageTests/PreProcess/Check.hs deleted file mode 100644 index 0e5a6ae3eb..0000000000 --- a/Cabal/tests/PackageTests/PreProcess/Check.hs +++ /dev/null @@ -1,16 +0,0 @@ -module PackageTests.PreProcess.Check (suite) where - -import PackageTests.PackageTester - (PackageSpec(..), SuiteConfig, assertBuildSucceeded, cabal_build) -import System.FilePath -import Test.Tasty.HUnit - -suite :: SuiteConfig -> Assertion -suite config = do - let spec = PackageSpec - { directory = "PackageTests" </> "PreProcess" - , distPref = Nothing - , configOpts = ["--enable-tests", "--enable-benchmarks"] - } - result <- cabal_build config spec - assertBuildSucceeded result diff --git a/Cabal/tests/PackageTests/PreProcessExtraSources/Check.hs b/Cabal/tests/PackageTests/PreProcessExtraSources/Check.hs deleted file mode 100644 index 9bede5d877..0000000000 --- a/Cabal/tests/PackageTests/PreProcessExtraSources/Check.hs +++ /dev/null @@ -1,16 +0,0 @@ -module PackageTests.PreProcessExtraSources.Check (suite) where - -import PackageTests.PackageTester - (PackageSpec(..), SuiteConfig, assertBuildSucceeded, cabal_build) -import System.FilePath -import Test.Tasty.HUnit - -suite :: SuiteConfig -> Assertion -suite config = do - let spec = PackageSpec - { directory = "PackageTests" </> "PreProcessExtraSources" - , distPref = Nothing - , configOpts = ["--enable-tests", "--enable-benchmarks"] - } - result <- cabal_build config spec - assertBuildSucceeded result diff --git a/Cabal/tests/PackageTests/ReexportedModules/Check.hs b/Cabal/tests/PackageTests/ReexportedModules/Check.hs deleted file mode 100644 index af2d8c168b..0000000000 --- a/Cabal/tests/PackageTests/ReexportedModules/Check.hs +++ /dev/null @@ -1,41 +0,0 @@ -module PackageTests.ReexportedModules.Check where - -import Data.Version -import PackageTests.PackageTester -import System.FilePath -import Test.Tasty.HUnit -import Data.Maybe -import Data.List -import Control.Monad -import Data.Char -import Text.ParserCombinators.ReadP - -orFail :: String -> [(a, String)] -> a -orFail err r = case find (all isSpace . snd) r of - Nothing -> error err - Just (i, _) -> i - -find' :: (a -> Bool) -> [a] -> Maybe a -find' = find - -suite :: SuiteConfig -> Assertion -suite config = do - -- ToDo: Turn this into a utility function - (_, _, xs) <- run Nothing (ghcPath config) [] ["--info"] - let compat = (>= Version [7,9] []) - . orFail "could not parse version" - . readP_to_S parseVersion - . snd - . fromJust - . find' ((=="Project version").fst) - . orFail "could not parse ghc --info output" - . reads - $ xs - when compat $ do - let spec = PackageSpec - { directory = "PackageTests" </> "ReexportedModules" - , configOpts = [] - , distPref = Nothing - } - result <- cabal_build config spec - assertBuildSucceeded result diff --git a/Cabal/tests/PackageTests/TemplateHaskell/Check.hs b/Cabal/tests/PackageTests/TemplateHaskell/Check.hs deleted file mode 100644 index 1f61af038a..0000000000 --- a/Cabal/tests/PackageTests/TemplateHaskell/Check.hs +++ /dev/null @@ -1,41 +0,0 @@ -module PackageTests.TemplateHaskell.Check where - -import PackageTests.PackageTester -import System.FilePath -import Test.Tasty.HUnit - -vanilla :: SuiteConfig -> Assertion -vanilla config = do - let spec = PackageSpec - { directory = "PackageTests" </> "TemplateHaskell" </> "vanilla" - , configOpts = [] - , distPref = Nothing - } - result <- cabal_build config spec - assertBuildSucceeded result - -profiling :: SuiteConfig -> Assertion -profiling config = do - let flags = ["--enable-library-profiling" --- ,"--disable-library-vanilla" - ,"--enable-profiling"] - spec = PackageSpec - { directory = "PackageTests" </> "TemplateHaskell" </> "profiling" - , configOpts = flags - , distPref = Nothing - } - result <- cabal_build config spec - assertBuildSucceeded result - -dynamic :: SuiteConfig -> Assertion -dynamic config = do - let flags = ["--enable-shared" --- ,"--disable-library-vanilla" - ,"--enable-executable-dynamic"] - spec = PackageSpec - { directory = "PackageTests" </> "TemplateHaskell" </> "dynamic" - , configOpts = flags - , distPref = Nothing - } - result <- cabal_build config spec - assertBuildSucceeded result diff --git a/Cabal/tests/PackageTests/TestOptions/Check.hs b/Cabal/tests/PackageTests/TestOptions/Check.hs deleted file mode 100644 index c0640f8ac1..0000000000 --- a/Cabal/tests/PackageTests/TestOptions/Check.hs +++ /dev/null @@ -1,26 +0,0 @@ -module PackageTests.TestOptions.Check where - -import PackageTests.PackageTester -import System.FilePath -import Test.Tasty.HUnit - -suite :: SuiteConfig -> Assertion -suite config = do - let spec = PackageSpec - { directory = "PackageTests" </> "TestOptions" - , configOpts = ["--enable-tests"] - , distPref = Nothing - } - _ <- cabal_build config spec - result <- cabal_test config spec [] ["--test-options=1 2 3"] - 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 config spec [] - [ "--test-option=1" - , "--test-option=2" - , "--test-option=3" - ] - let message' = "\"cabal test\" did not pass the correct options to the " - ++ "test executable with \"--test-option\"" - assertEqual message' True $ successful result' diff --git a/Cabal/tests/PackageTests/TestStanza/Check.hs b/Cabal/tests/PackageTests/TestStanza/Check.hs index 4332fffe29..db7a8cad9d 100644 --- a/Cabal/tests/PackageTests/TestStanza/Check.hs +++ b/Cabal/tests/PackageTests/TestStanza/Check.hs @@ -1,36 +1,19 @@ module PackageTests.TestStanza.Check where -import Test.Tasty.HUnit -import System.FilePath import PackageTests.PackageTester + import Distribution.Version -import Distribution.PackageDescription.Parse (readPackageDescription) -import Distribution.PackageDescription.Configuration - (finalizePackageDescription) -import Distribution.Package (PackageName(..), Dependency(..)) +import Distribution.Simple.LocalBuildInfo +import Distribution.Package import Distribution.PackageDescription - ( PackageDescription(..), BuildInfo(..), TestSuite(..) - , TestSuiteInterface(..), emptyBuildInfo, emptyTestSuite ) -import Distribution.Verbosity (silent) -import Distribution.System (buildPlatform) -import Distribution.Compiler - ( CompilerId(..), CompilerFlavor(..), unknownCompilerInfo, AbiTag(..) ) -import Distribution.Text -suite :: SuiteConfig -> Assertion -suite config = do - let dir = "PackageTests" </> "TestStanza" - pdFile = dir </> "my" <.> "cabal" - spec = PackageSpec - { directory = dir - , configOpts = [] - , distPref = Nothing - } - result <- cabal_configure config spec - assertOutputDoesNotContain "unknown section type" result - genPD <- readPackageDescription silent pdFile - let compiler = unknownCompilerInfo (CompilerId GHC $ Version [6, 12, 2] []) NoAbiTag - anticipatedTestSuite = emptyTestSuite +suite :: TestM () +suite = do + assertOutputDoesNotContain "unknown section type" + =<< cabal "configure" [] + dist_dir <- distDir + lbi <- liftIO $ getPersistBuildConfig dist_dir + let anticipatedTestSuite = emptyTestSuite { testName = "dummy" , testInterface = TestSuiteExeV10 (Version [1,0] []) "dummy.hs" , testBuildInfo = emptyBuildInfo @@ -40,10 +23,7 @@ suite config = do } , testEnabled = False } - case finalizePackageDescription [] (const True) buildPlatform compiler [] genPD of - Left xs -> let depMessage = "should not have missing dependencies:\n" ++ - (unlines $ map (show . disp) xs) - in assertEqual depMessage True False - Right (f, _) -> let gotTest = head $ testSuites f - in assertEqual "parsed test-suite stanza does not match anticipated" - gotTest anticipatedTestSuite + gotTestSuite = head $ testSuites (localPkgDescr lbi) + assertEqual "parsed test-suite stanza does not match anticipated" + anticipatedTestSuite gotTestSuite + return () diff --git a/Cabal/tests/PackageTests/TestSuiteTests/ExeV10/Check.hs b/Cabal/tests/PackageTests/TestSuiteTests/ExeV10/Check.hs index 61c16160a4..6cdfce566f 100644 --- a/Cabal/tests/PackageTests/TestSuiteTests/ExeV10/Check.hs +++ b/Cabal/tests/PackageTests/TestSuiteTests/ExeV10/Check.hs @@ -1,18 +1,15 @@ -module PackageTests.TestSuiteTests.ExeV10.Check (checks) where +module PackageTests.TestSuiteTests.ExeV10.Check (tests) where import qualified Control.Exception as E (IOException, catch) import Control.Monad (when) -import Data.List (intercalate) import Data.Maybe (catMaybes) -import System.Directory ( doesFileExist ) import System.FilePath -import Test.Tasty -import Test.Tasty.HUnit +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase) import Distribution.Compiler (CompilerFlavor(..), CompilerId(..)) import Distribution.PackageDescription (package) import Distribution.Simple.Compiler (compilerId) -import Distribution.Simple.Configure (getPersistBuildConfig) import Distribution.Simple.LocalBuildInfo (compiler, localPkgDescr, localCompatPackageKey) import Distribution.Simple.Hpc import Distribution.Simple.Program.Builtin (hpcProgram) @@ -24,15 +21,46 @@ import Distribution.Version (Version(..), orLaterVersion) import PackageTests.PackageTester -checks :: SuiteConfig -> [TestTree] -checks config = - [ testCase "Test" $ checkTest config +tests :: SuiteConfig -> [TestTree] +tests config = + -- TODO: hierarchy and subnaming is a little unfortunate + [ tc "Test" "Default" $ do + cabal_build ["--enable-tests"] + cabal "test" ["--show-details=direct"] , testGroup "WithHpc" $ hpcTestMatrix config , testGroup "WithoutHpc" - [ testCase "NoTix" $ checkTestNoHpcNoTix config - , testCase "NoMarkup" $ checkTestNoHpcNoMarkup config + -- Ensures that even if -fhpc is manually provided no .tix file is output. + [ tc "NoTix" "NoHpcNoTix" $ do + dist_dir <- distDir + cabal_build + [ "--enable-tests" + , "--ghc-option=-fhpc" + , "--ghc-option=-hpcdir" + , "--ghc-option=" ++ dist_dir ++ "/hpc/vanilla" ] + cabal "test" ["--show-details=direct"] + lbi <- liftIO $ getPersistBuildConfig dist_dir + let way = guessWay lbi + shouldNotExist $ tixFilePath dist_dir way "test-Foo" + -- Ensures that even if a .tix file happens to be left around + -- markup isn't generated. + , tc "NoMarkup" "NoHpcNoMarkup" $ do + dist_dir <- distDir + let tixFile = tixFilePath dist_dir Vanilla "test-Foo" + withEnv [("HPCTIXFILE", Just tixFile)] $ do + cabal_build + [ "--enable-tests" + , "--ghc-option=-fhpc" + , "--ghc-option=-hpcdir" + , "--ghc-option=" ++ dist_dir ++ "/hpc/vanilla" ] + cabal "test" ["--show-details=direct"] + shouldNotExist $ htmlDir dist_dir Vanilla "test-Foo" </> "hpc_index.html" ] ] + where + tc :: String -> String -> TestM a -> TestTree + tc name subname m + = testCase name + (runTestM config "TestSuiteTests/ExeV10" (Just subname) m) hpcTestMatrix :: SuiteConfig -> [TestTree] hpcTestMatrix config = do @@ -59,79 +87,32 @@ hpcTestMatrix config = do enable cond flag | cond = Just $ "--enable-" ++ flag | otherwise = Nothing - return $ testCase name $ checkTestWithHpc config ("WithHpc-" ++ name) opts - -dir :: FilePath -dir = "PackageTests" </> "TestSuiteTests" </> "ExeV10" - -checkTest :: SuiteConfig -> Assertion -checkTest config = buildAndTest config "Default" [] [] - -shouldExist :: FilePath -> Assertion -shouldExist path = doesFileExist path >>= assertBool (path ++ " should exist") - -shouldNotExist :: FilePath -> Assertion -shouldNotExist path = - doesFileExist path >>= assertBool (path ++ " should exist") . not - --- | Ensure that both .tix file and markup are generated if coverage is enabled. -checkTestWithHpc :: SuiteConfig -> String -> [String] -> Assertion -checkTestWithHpc config name extraOpts = do - isCorrectVersion <- correctHpcVersion - when isCorrectVersion $ do - let distPref' = dir </> "dist-" ++ name - buildAndTest config name [] ("--enable-coverage" : extraOpts) - lbi <- getPersistBuildConfig distPref' - let way = guessWay lbi - CompilerId comp version = compilerId (compiler lbi) - subdir - | comp == GHC && version >= Version [7, 10] [] = - display (localCompatPackageKey lbi) - | otherwise = display (package $ localPkgDescr lbi) - mapM_ shouldExist - [ mixDir distPref' way "my-0.1" </> subdir </> "Foo.mix" - , mixDir distPref' way "test-Foo" </> "Main.mix" - , tixFilePath distPref' way "test-Foo" - , htmlDir distPref' way "test-Foo" </> "hpc_index.html" - ] - --- | Ensures that even if -fhpc is manually provided no .tix file is output. -checkTestNoHpcNoTix :: SuiteConfig -> Assertion -checkTestNoHpcNoTix config = do - buildAndTest config "NoHpcNoTix" [] - [ "--ghc-option=-fhpc" - , "--ghc-option=-hpcdir" - , "--ghc-option=dist-NoHpcNoTix/hpc/vanilla" ] - lbi <- getPersistBuildConfig (dir </> "dist-NoHpcNoTix") - let way = guessWay lbi - shouldNotExist $ tixFilePath (dir </> "dist-NoHpcNoTix") way "test-Foo" - --- | Ensures that even if a .tix file happens to be left around --- markup isn't generated. -checkTestNoHpcNoMarkup :: SuiteConfig -> Assertion -checkTestNoHpcNoMarkup config = do - let tixFile = tixFilePath "dist-NoHpcNoMarkup" Vanilla "test-Foo" - buildAndTest config "NoHpcNoMarkup" - [("HPCTIXFILE", Just tixFile)] - [ "--ghc-option=-fhpc" - , "--ghc-option=-hpcdir" - , "--ghc-option=dist-NoHpcNoMarkup/hpc/vanilla" ] - shouldNotExist $ htmlDir (dir </> "dist-NoHpcNoMarkup") Vanilla "test-Foo" </> "hpc_index.html" - --- | Build and test a package and ensure that both were successful. --- --- The flag "--enable-tests" is provided in addition to the given flags. -buildAndTest :: SuiteConfig -> String -> [(String, Maybe String)] -> [String] -> IO () -buildAndTest config name envOverrides flags = do - let spec = PackageSpec - { directory = dir - , distPref = Just $ "dist-" ++ name - , configOpts = "--enable-tests" : flags - } - buildResult <- cabal_build config spec - assertBuildSucceeded buildResult - testResult <- cabal_test config spec envOverrides ["--show-details=direct"] - assertTestSucceeded testResult + -- Ensure that both .tix file and markup are generated if coverage + -- is enabled. + return $ tc name ("WithHpc-" ++ name) $ do + isCorrectVersion <- liftIO $ correctHpcVersion + when isCorrectVersion $ do + dist_dir <- distDir + cabal_build ("--enable-tests" : "--enable-coverage" : opts) + cabal "test" ["--show-details=direct"] + lbi <- liftIO $ getPersistBuildConfig dist_dir + let way = guessWay lbi + CompilerId comp version = compilerId (compiler lbi) + subdir + | comp == GHC && version >= Version [7, 10] [] = + display (localCompatPackageKey lbi) + | otherwise = display (package $ localPkgDescr lbi) + mapM_ shouldExist + [ mixDir dist_dir way "my-0.1" </> subdir </> "Foo.mix" + , mixDir dist_dir way "test-Foo" </> "Main.mix" + , tixFilePath dist_dir way "test-Foo" + , htmlDir dist_dir way "test-Foo" </> "hpc_index.html" + ] + where + tc :: String -> String -> TestM a -> TestTree + tc name subname m + = testCase name + (runTestM config "TestSuiteTests/ExeV10" (Just subname) m) -- | Checks for a suitable HPC version for testing. correctHpcVersion :: IO Bool diff --git a/Cabal/tests/PackageTests/TestSuiteTests/LibV09/Check.hs b/Cabal/tests/PackageTests/TestSuiteTests/LibV09/Check.hs deleted file mode 100644 index ba9920dab0..0000000000 --- a/Cabal/tests/PackageTests/TestSuiteTests/LibV09/Check.hs +++ /dev/null @@ -1,41 +0,0 @@ -module PackageTests.TestSuiteTests.LibV09.Check (checks) where - -import Test.Tasty -import Test.Tasty.HUnit -import System.FilePath ((</>)) - -import PackageTests.PackageTester - -dir :: FilePath -dir = "PackageTests" </> "TestSuiteTests" </> "LibV09" - -checks :: SuiteConfig -> [TestTree] -checks config = - [ testCase "Build" (checkBuild config) - , localOption (mkTimeout $ 10 ^ (8 :: Int)) - $ testCase "Deadlock" (checkDeadlock config) - ] - -checkBuild :: SuiteConfig -> Assertion -checkBuild config = do - let spec = (inplaceSpec config) - { directory = dir - , distPref = Just $ "dist-Build" - , configOpts = "--enable-tests" - : configOpts (inplaceSpec config) - } - buildResult <- cabal_build config spec - assertBuildSucceeded buildResult - -checkDeadlock :: SuiteConfig -> Assertion -checkDeadlock config = do - let spec = (inplaceSpec config) - { directory = dir - , distPref = Just $ "dist-Test" - , configOpts = "--enable-tests" - : configOpts (inplaceSpec config) - } - buildResult <- cabal_build config spec - assertBuildSucceeded buildResult - testResult <- cabal_test config spec [] [] - assertTestFailed testResult diff --git a/Cabal/tests/PackageTests/Tests.hs b/Cabal/tests/PackageTests/Tests.hs new file mode 100644 index 0000000000..52540f2491 --- /dev/null +++ b/Cabal/tests/PackageTests/Tests.hs @@ -0,0 +1,219 @@ +module PackageTests.Tests(tests) where + +import PackageTests.PackageTester + +import qualified PackageTests.BenchmarkStanza.Check +import qualified PackageTests.TestStanza.Check +import qualified PackageTests.DeterministicAr.Check +import qualified PackageTests.TestSuiteTests.ExeV10.Check + +import Control.Monad + +import Data.Version +import Test.Tasty (TestTree, testGroup, 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 + + --------------------------------------------------------------------- + -- * External tests + + -- Test that Cabal parses 'benchmark' sections correctly + , tc "BenchmarkStanza" PackageTests.BenchmarkStanza.Check.suite + + -- Test that Cabal parses 'test' sections correctly + , tc "TestStanza" PackageTests.TestStanza.Check.suite + + -- Test that Cabal determinstically generates object archives + , tc "DeterministicAr" PackageTests.DeterministicAr.Check.suite + + --------------------------------------------------------------------- + -- * Test suite tests + + , testGroup "TestSuiteTests" + + -- Test exitcode-stdio-1.0 test suites (and HPC) + [ testGroup "ExeV10" + (PackageTests.TestSuiteTests.ExeV10.Check.tests config) + + -- Test detailed-0.9 test suites + , testGroup "LibV09" $ + let + tcs :: FilePath -> TestM a -> TestTree + 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" [] + ] + ] + + --------------------------------------------------------------------- + -- * Inline tests + + -- Test if exitcode-stdio-1.0 benchmark builds correctly + , tc "BenchmarkExeV10" $ cabal_build ["--enable-benchmarks"] + + -- Test --benchmark-option(s) flags on ./Setup bench + , tc "BenchmarkOptions" $ do + cabal_build ["--enable-benchmarks"] + cabal "bench" [ "--benchmark-options=1 2 3" ] + cabal "bench" [ "--benchmark-option=1" + , "--benchmark-option=2" + , "--benchmark-option=3" + ] + + -- Test --test-option(s) flags on ./Setup test + , tc "TestOptions" $ do + cabal_build ["--enable-tests"] + cabal "test" ["--test-options=1 2 3"] + cabal "test" [ "--test-option=1" + , "--test-option=2" + , "--test-option=3" + ] + + -- Test attempt to have executable depend on internal + -- library, but cabal-version is too old. + , 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 [] + + -- Test that internal library is preferred to an installed on + -- with the same name and version + , 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" + + -- 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" + + -- 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 [] + + -- 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 + cabal "configure" [] + r <- shouldFail $ cabal "build" [] + assertBool "error should be in MyLibrary.hs" $ + resultOutput r =~ "^MyLibrary.hs:" + assertBool "error should be \"Could not find module `System.Time\"" $ + resultOutput r =~ "Could not find module.*System.Time" + + -- This is a control on TargetSpecificDeps1; it should + -- succeed. + , 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 + cabal "configure" [] + r <- shouldFail $ cabal "build" [] + assertBool "error should be in lemon.hs" $ + resultOutput r =~ "^lemon.hs:" + assertBool "error should be \"Could not find module `System.Time\"" $ + resultOutput r =~ "Could not find module.*System.Time" + + -- Test that Paths module is generated and available for executables. + , tc "PathsModule/Executable" $ cabal_build [] + + -- Test that Paths module is generated and available for libraries. + , tc "PathsModule/Library" $ cabal_build [] + + -- Check that preprocessors (hsc2hs) are run + , 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"] + + -- Test building a vanilla library/executable which uses Template Haskell + , 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"] + + -- Test building a dynamic library/executable which uses Template + -- Haskell + , 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 [] + + -- Test build when the library is empty, for #1241 + , tc "EmptyLib" $ + withPackage "empty" $ cabal_build [] + + -- Test that "./Setup haddock" works correctly + , tc "Haddock" $ do + dist_dir <- distDir + let haddocksDir = dist_dir </> "doc" </> "html" </> "Haddock" + cabal "configure" [] + cabal "haddock" [] + let docFiles + = map (haddocksDir </>) + ["CPP.html", "Literate.html", "NoCPP.html", "Simple.html"] + mapM_ (assertFindInFile "For hiding needles.") docFiles + + -- Test that Cabal properly orders GHC flags passed to GHC (when + -- there are multiple ghc-options fields.) + , tc "OrderFlags" $ cabal_build [] + + -- Test that reexported modules build correctly + -- TODO: should also test that they import OK! + , tc "ReexportedModules" $ do + whenGhcVersion (>= Version [7,9] []) $ cabal_build [] + + -- Test that Cabal computes different IPIDs when the source changes. + , tc "UniqueIPID" . withPackageDb $ do + withPackage "P1" $ cabal "configure" [] + withPackage "P2" $ cabal "configure" [] + withPackage "P1" $ cabal "build" [] + withPackage "P1" $ cabal "build" [] -- rebuild should work + r1 <- withPackage "P1" $ cabal "register" ["--print-ipid", "--inplace"] + withPackage "P2" $ cabal "build" [] + r2 <- withPackage "P2" $ cabal "register" ["--print-ipid", "--inplace"] + let exIPID s = takeWhile (/= '\n') $ + head . filter (isPrefixOf $ "UniqueIPID-0.1-") $ (tails s) + when ((exIPID $ resultOutput r1) == (exIPID $ resultOutput r2)) $ + assertFailure $ "cabal has not calculated different Installed " ++ + "package ID when source is changed." + + ] + where + -- Shared test function for BuildDeps/InternalLibrary* tests. + internal_lib_test expect = withPackageDb $ do + withPackage "to-install" $ cabal_install [] + cabal_build [] + r <- runExe "lemon" [] + assertEqual + ("executable should have linked with the " ++ expect ++ " library") + ("myLibFunc " ++ expect) + (concat $ lines (resultOutput r)) + + tc :: FilePath -> TestM a -> TestTree + tc name m + = testCase name (runTestM config name Nothing m) diff --git a/Cabal/tests/PackageTests/UniqueIPID/Check.hs b/Cabal/tests/PackageTests/UniqueIPID/Check.hs deleted file mode 100644 index 6a45ce9d92..0000000000 --- a/Cabal/tests/PackageTests/UniqueIPID/Check.hs +++ /dev/null @@ -1,47 +0,0 @@ -module PackageTests.UniqueIPID.Check (suite) where - -import System.FilePath ((</>)) - -import PackageTests.PackageTester -import Test.Tasty.HUnit (Assertion, assertFailure) -import Data.List -import Distribution.Compat.Exception - -import Control.Monad ( when ) -import System.Directory - -this :: String -this = "UniqueIPID" - -suite :: SuiteConfig -> Assertion -suite config = do - let dir = "PackageTests" </> this - db = "tmp.package.conf" - spec1 = PackageSpec - { directory = dir </> "P1" - , configOpts = ["--package-db", ".." </> db] - , distPref = Nothing - } - spec2 = PackageSpec - { directory = dir </> "P2" - , configOpts = ["--package-db", ".." </> db] - , distPref = Nothing - } - removeDirectoryRecursive (dir </> db) `catchIO` const (return ()) - _ <- run Nothing (ghcPkgPath config) [] ["init", dir </> db] - _ <- cabal_configure config spec1 - _ <- cabal_configure config spec2 - _ <- cabal_build config spec1 - _ <- cabal_build config spec1 -- test rebuild cycle works - hResult1 <- cabal_register config spec1 ["--print-ipid", "--inplace"] - assertRegisterSucceeded hResult1 - _ <- cabal_build config spec2 - hResult2 <- cabal_register config spec2 ["--print-ipid", "--inplace"] - assertRegisterSucceeded hResult2 - when ((exIPID $ outputText hResult1) == (exIPID $ outputText hResult2)) $ - assertFailure $ "cabal has not calculated different Installed " ++ - "package ID when source is changed." - where - exIPID s = takeWhile (/= '\n') $ - head . filter (isPrefixOf $ this ++ "-0.1-") $ (tails s) - -- GitLab