Commit ad17ad99 authored by Edward Z. Yang's avatar Edward Z. Yang Committed by Edward Z. Yang
Browse files

Assume LocalBuildInfo is available in cabal-testsuite.



Now that cabal-testsuite uses a Custom setup, we can assume
that we are able to read the LBI from our build.  This is good
news, because the old algorithm didn't really work at all
(and stopped working with cabal-install-1.24.0.1)

Fixes #4108.
Signed-off-by: default avatarEdward Z. Yang <ezyang@cs.stanford.edu>
parent 3d9be43b
......@@ -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
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment