Assume LocalBuildInfo is available in cabal-testsuite.

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

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