diff --git a/cabal-testsuite/PackageTests.hs b/cabal-testsuite/PackageTests.hs index 3643f3ddb2f..a0998fb128a 100644 --- a/cabal-testsuite/PackageTests.hs +++ b/cabal-testsuite/PackageTests.hs @@ -10,11 +10,17 @@ import PackageTests.Options import PackageTests.PackageTester import PackageTests.Tests +import Distribution.Backpack +import Distribution.Types.ModuleRenaming import Distribution.Simple.Configure ( ConfigStateFileError(..), findDistPrefOrDefault, getConfigStateFile , interpretPackageDbFlags, configCompilerEx ) import Distribution.Simple.Compiler (PackageDB(..), PackageDBStack ,CompilerFlavor(GHC)) +import Distribution.Types.LocalBuildInfo (componentNameCLBIs) +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.ComponentName +import Distribution.Package import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..)) import Distribution.Simple.Program (defaultProgramDb) import Distribution.Simple.Setup (Flag(..), readPackageDbList, showPackageDbList) @@ -67,10 +73,10 @@ main = do -- First, figure out the dist directory associated with this Cabal. dist_dir :: FilePath <- guessDistDir - -- Next, attempt to read out the LBI. This may not work, in which - -- case we'll try to guess the correct parameters. This is ignored - -- if values are explicitly passed into the test suite. - mb_lbi <- getPersistBuildConfig_ (dist_dir "setup-config") + -- Next, read out the LBI. Now that package-tests is in a separate + -- package with a Custom setup, this MUST succeed; we will freak + -- out if it does not + lbi <- getPersistBuildConfig dist_dir -- You need to run the test suite in the right directory, sorry. -- This variable is modestly misnamed: this refers to the base @@ -102,24 +108,7 @@ main = do -- By default we use the same configuration as the one from the -- LBI, but a user can override it to test against a different -- version of GHC. - mb_ghc_path <- lookupEnv "CABAL_PACKAGETESTS_GHC" - mb_ghc_pkg_path <- lookupEnv "CABAL_PACKAGETESTS_GHC_PKG" - boot_programs <- - case (mb_ghc_path, mb_ghc_pkg_path) of - (Nothing, Nothing) | Just lbi <- mb_lbi -> do - putStrLn "Using configuration from LBI" - return (withPrograms lbi) - _ -> do - putStrLn "(Re)configuring test suite (ignoring LBI)" - (_comp, _compPlatform, programDb) - <- configCompilerEx - (Just GHC) mb_ghc_path mb_ghc_pkg_path - -- NB: if we accept full ConfigFlags parser then - -- should use (mkProgramDb cfg (configPrograms cfg)) - -- instead. - defaultProgramDb - (lessVerbose verbosity) - return programDb + let boot_programs = withPrograms lbi mb_with_ghc_path <- lookupEnv "CABAL_PACKAGETESTS_WITH_GHC" mb_with_ghc_pkg_path <- lookupEnv "CABAL_PACKAGETESTS_WITH_GHC_PKG" @@ -144,16 +133,7 @@ main = do -- Figure out what database stack to use. (This is the tricky bit, -- because we need to have enough databases to make the just-built -- Cabal package well-formed). - db_stack_env <- lookupEnv "CABAL_PACKAGETESTS_DB_STACK" - let packageDBStack0 = case db_stack_env of - Just str -> interpretPackageDbFlags True -- user install? why not. - (concatMap readPackageDbList - (splitSearchPath str)) - Nothing -> - case mb_lbi of - Just lbi -> withPackageDB lbi - -- A wild guess! - Nothing -> interpretPackageDbFlags True [] + let packageDBStack0 = withPackageDB lbi -- Package DBs are not guaranteed to be absolute, so make them so in -- case a subprocess using the package DB needs a different CWD. @@ -212,6 +192,9 @@ main = do , withGhcDBStack = with_ghc_db_stack , suiteVerbosity = verbosity , absoluteCWD = cabal_dir + , bootCompiler = compiler lbi + , bootPlatform = hostPlatform lbi + , bootPackages = cabalTestsuitePackages lbi , mtimeChangeDelay = mtimeChange' } @@ -247,6 +230,15 @@ main = do defaultMainWithIngredients options $ runTestTree "Package Tests" (tests suite) +-- | Compute the set of @-package-id@ flags which would be passed when +-- building the public library. Assumes that the public library is +-- non-Backpack. +cabalTestsuitePackages :: LocalBuildInfo -> [(OpenUnitId, ModuleRenaming)] +cabalTestsuitePackages lbi = + case componentNameCLBIs lbi (CTestName (mkUnqualComponentName "package-tests")) of + [clbi] -> componentIncludes clbi + _ -> error "cabalTestsuitePackages" + -- Reverse of 'interpretPackageDbFlags'. -- prop_idem stk b -- = interpretPackageDbFlags b (uninterpretPackageDBFlags stk) == stk diff --git a/cabal-testsuite/PackageTests/PackageTester.hs b/cabal-testsuite/PackageTests/PackageTester.hs index 631b93b7926..9bad0b4b332 100644 --- a/cabal-testsuite/PackageTests/PackageTester.hs +++ b/cabal-testsuite/PackageTests/PackageTester.hs @@ -88,13 +88,18 @@ module PackageTests.PackageTester import PackageTests.Options +import Distribution.Simple.Setup (Flag(..)) +import Distribution.Utils.NubList +import Distribution.Backpack +import Distribution.Simple.Compiler +import Distribution.System +import Distribution.Types.ModuleRenaming import Distribution.Compat.CreatePipe (createPipe) -import Distribution.Simple.Compiler (PackageDBStack, PackageDB(..)) import Distribution.Simple.Program.Run (getEffectiveEnvironment) import Distribution.Simple.Program.Types import Distribution.Simple.Program.Db +import Distribution.Simple.Program.GHC import Distribution.Simple.Program -import Distribution.System (OS(Windows), buildOS) import Distribution.Simple.Utils ( printRawCommandAndArgsAndEnv, withFileContents ) import Distribution.Simple.Configure @@ -104,14 +109,12 @@ import Distribution.Version import Distribution.Simple.BuildPaths (exeExtension) -import Distribution.Simple.Utils (cabalVersion) -import Distribution.Text (display) - import qualified Test.Tasty.HUnit as HUnit import Text.Regex.Posix import qualified Control.Exception as E import Control.Monad +import qualified Data.Monoid as M import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Reader import Control.Monad.Trans.Writer @@ -186,6 +189,9 @@ data SuiteConfig = SuiteConfig -- | The build directory that was used to build Cabal (used -- to compile Setup scripts.) , cabalDistPref :: FilePath + , bootPackages :: [(OpenUnitId, ModuleRenaming)] + , bootCompiler :: Compiler + , bootPlatform :: Platform -- | The package database stack which makes the *built* -- Cabal well-formed. In general, this is going to be -- the package DB stack from the LBI you used to build @@ -243,9 +249,6 @@ ghcPkgProg suite = getBootProgram suite ghcPkgProgram ghcPkgPath :: SuiteConfig -> FilePath ghcPkgPath = programPath . ghcPkgProg -ghcVersion :: SuiteConfig -> Version -ghcVersion = programVersion' . ghcProg - withGhcPath :: SuiteConfig -> FilePath withGhcPath = programPath . withGhcProg @@ -473,42 +476,20 @@ rawCompileSetup verbosity suite e path = do -- NB: Use 'ghcPath', not 'withGhcPath', since we need to be able to -- link against the Cabal library which was built with 'ghcPath'. -- Ditto with packageDBStack. - r <- rawRun verbosity (Just path) (ghcPath suite) e $ - [ "--make"] ++ - ghcPackageDBParams (ghcVersion suite) (packageDBStack suite) ++ - [ "-hide-package Cabal" - -- 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 - , "-O0" - , "Setup.hs" ] + let ghc_args = renderGhcOptions (bootCompiler suite) (bootPlatform suite) $ M.mempty { + ghcOptMode = Flag GhcModeMake, + ghcOptPackageDBs = packageDBStack suite, + ghcOptPackages = toNubListR (bootPackages suite), + ghcOptOptimisation = Flag GhcNoOptimisation, + ghcOptInputFiles = toNubListR ["Setup.hs"] + } + r <- rawRun verbosity (Just path) (ghcPath suite) e $ ghc_args 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 >= mkVersion [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 - - convertLegacy :: PackageDB -> [String] - convertLegacy (SpecificPackageDB path) = ["-package-conf=" ++ path] - convertLegacy _ = [] - ------------------------------------------------------------------------ -- * Running ghc-pkg