From d6774eb1653c65ae4a74420ddd758a09e9644849 Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel Date: Wed, 6 Mar 2019 21:40:21 +0100 Subject: [PATCH] Proof-of-concept for #5916 This needs more refinement and is a first draft trying to address #5916 --- cabal-testsuite/Setup.hs | 79 ++++++++++++++++++++++++--- cabal-testsuite/Test/Cabal/Monad.hs | 16 +++--- cabal-testsuite/Test/Cabal/Script.hs | 37 +++++-------- cabal-testsuite/cabal-testsuite.cabal | 21 +++---- cabal-testsuite/main/cabal-tests.hs | 5 +- 5 files changed, 105 insertions(+), 53 deletions(-) diff --git a/cabal-testsuite/Setup.hs b/cabal-testsuite/Setup.hs index 590d1336d2c..df92ba4b598 100644 --- a/cabal-testsuite/Setup.hs +++ b/cabal-testsuite/Setup.hs @@ -1,10 +1,73 @@ +import Distribution.Backpack import Distribution.Simple +import Distribution.Simple.BuildPaths +import Distribution.Simple.LocalBuildInfo +import Distribution.Types.LocalBuildInfo +import Distribution.Types.ModuleRenaming +import Distribution.Types.UnqualComponentName + +import System.Directory +import System.FilePath + main :: IO () -main = defaultMain - --- Although this looks like the Simple build type, it is in fact vital that --- we use this Setup.hs because we need to compile against the very same --- version of the Cabal library that the test suite will be compiled --- against. When this happens, it will mean that we'll be able to --- read the LocalBuildInfo of our build environment, which we will --- subsequently use to make decisions about PATHs etc. Important! +main = defaultMainWithHooks simpleUserHooks + { buildHook = \pkg lbi hooks flags -> do + generateScriptEnvModule lbi + buildHook simpleUserHooks pkg lbi hooks flags + } + +generateScriptEnvModule :: LocalBuildInfo -> IO () +generateScriptEnvModule lbi = do + lbiPackageDbStack <- mapM canonicalizePackageDB (withPackageDB lbi) + + createDirectoryIfMissing True moduledir + writeFile (moduledir "ScriptEnv0.hs") $ unlines + [ "module Test.Cabal.ScriptEnv0 where" + , "" + , "import Distribution.Simple" + , "import Distribution.System (Platform(..), Arch(..), OS(..))" + , "import Distribution.Types.ModuleRenaming" + , "import Distribution.Simple.Program.Db" + , "import Distribution.Backpack (OpenUnitId)" + , "import Data.Map (fromList)" + , "" + , "lbiPackageDbStack :: PackageDBStack" + , "lbiPackageDbStack = " ++ show lbiPackageDbStack + , "" + , "lbiPlatform :: Platform" + , "lbiPlatform = " ++ show (hostPlatform lbi) + , "" + , "lbiCompiler :: Compiler" + , "lbiCompiler = " ++ show (compiler lbi) + , "" + , "lbiPackages :: [(OpenUnitId, ModuleRenaming)]" + , "lbiPackages = read " ++ show (show (cabalTestsPackages lbi)) + , "" + , "lbiProgramDb :: ProgramDb" + , "lbiProgramDb = read " ++ show (show (withPrograms lbi)) + , "" + , "lbiWithSharedLib :: Bool" + , "lbiWithSharedLib = " ++ show (withSharedLib lbi) + ] + where + moduledir = libAutogenDir "Test" "Cabal" + -- fixme: use component-specific folder + libAutogenDir = autogenPackageModulesDir lbi + +-- | Convert package database into absolute path, so that +-- if we change working directories in a subprocess we get the correct database. +canonicalizePackageDB :: PackageDB -> IO PackageDB +canonicalizePackageDB (SpecificPackageDB path) + = SpecificPackageDB `fmap` canonicalizePath path +canonicalizePackageDB x = return x + + +-- | Compute the set of @-package-id@ flags which would be passed when +-- building the public library. Assumes that the public library is +-- non-Backpack. +cabalTestsPackages :: LocalBuildInfo -> [(OpenUnitId, ModuleRenaming)] +cabalTestsPackages lbi = + case componentNameCLBIs lbi (CExeName (mkUnqualComponentName "cabal-tests")) of + [clbi] -> -- [ (unUnitId $ unDefUnitId duid,rn) | (DefiniteUnitId duid, rn) <- componentIncludes clbi ] + componentIncludes clbi + _ -> error "cabalTestsPackages" diff --git a/cabal-testsuite/Test/Cabal/Monad.hs b/cabal-testsuite/Test/Cabal/Monad.hs index 07e070a1c45..ca07013c050 100644 --- a/cabal-testsuite/Test/Cabal/Monad.hs +++ b/cabal-testsuite/Test/Cabal/Monad.hs @@ -66,8 +66,7 @@ import Distribution.System import Distribution.Simple.Program.Db import Distribution.Simple.Program import Distribution.Simple.Configure - ( getPersistBuildConfig, configCompilerEx ) -import Distribution.Types.LocalBuildInfo + ( configCompilerEx ) import Distribution.Version import Distribution.Text import Distribution.Package @@ -240,20 +239,19 @@ runTestM mode m = withSystemTempDirectory "cabal-testsuite" $ \tmp_dir -> do script_base = dropExtensions script_filename -- Canonicalize this so that it is stable across working directory changes script_dir <- canonicalizePath script_dir0 - lbi <- getPersistBuildConfig dist_dir let verbosity = normal -- TODO: configurable - senv <- mkScriptEnv verbosity lbi + senv <- mkScriptEnv verbosity -- Add test suite specific programs let program_db0 = addKnownPrograms ([gitProgram, hackageRepoToolProgram, cabalProgram, diffProgram] ++ builtinPrograms) - (withPrograms lbi) + (runnerProgramDb senv) -- Reconfigure according to user flags let cargs = testCommonArgs args -- Reconfigure GHC (comp, platform, program_db2) <- case argGhcPath cargs of - Nothing -> return (compiler lbi, hostPlatform lbi, program_db0) + Nothing -> return (runnerCompiler senv, runnerPlatform senv, program_db0) Just ghc_path -> do -- All the things that get updated paths from -- configCompilerEx. The point is to make sure @@ -274,7 +272,7 @@ runTestM mode m = withSystemTempDirectory "cabal-testsuite" $ \tmp_dir -> do -- we don't pay for things we don't need. A bit difficult -- to do in the current design. configCompilerEx - (Just (compilerFlavor (compiler lbi))) + (Just (compilerFlavor (runnerCompiler senv))) (Just ghc_path) Nothing program_db1 @@ -294,7 +292,7 @@ runTestM mode m = withSystemTempDirectory "cabal-testsuite" $ \tmp_dir -> do let db_stack = case argGhcPath (testCommonArgs args) of - Nothing -> withPackageDB lbi + Nothing -> runnerPackageDbStack senv -- NB: canonicalized -- Can't use the build package db stack since they -- are all for the wrong versions! TODO: Make -- this configurable @@ -313,7 +311,7 @@ runTestM mode m = withSystemTempDirectory "cabal-testsuite" $ \tmp_dir -> do testScriptEnv = senv, testSetupPath = dist_dir "setup" "setup", testSkipSetupTests = argSkipSetupTests (testCommonArgs args), - testHaveCabalShared = withSharedLib lbi, + testHaveCabalShared = runnerWithSharedLib senv, testEnvironment = -- Try to avoid Unicode output [ ("LC_ALL", Just "C") diff --git a/cabal-testsuite/Test/Cabal/Script.hs b/cabal-testsuite/Test/Cabal/Script.hs index 7305527e0eb..7cbf68afc53 100644 --- a/cabal-testsuite/Test/Cabal/Script.hs +++ b/cabal-testsuite/Test/Cabal/Script.hs @@ -9,13 +9,10 @@ module Test.Cabal.Script ( ) where import Test.Cabal.Run +import Test.Cabal.ScriptEnv0 import Distribution.Backpack import Distribution.Types.ModuleRenaming -import Distribution.Types.LocalBuildInfo -import Distribution.Types.ComponentLocalBuildInfo -import Distribution.Types.ComponentName -import Distribution.Types.UnqualComponentName import Distribution.Utils.NubList import Distribution.Simple.Program.Db import Distribution.Simple.Program.Builtin @@ -26,9 +23,9 @@ import Distribution.Verbosity import Distribution.System import Distribution.Simple.Setup (Flag(..)) -import System.Directory import qualified Data.Monoid as M + -- | The runner environment, which contains all of the important -- parameters for invoking GHC. Mostly subset of 'LocalBuildInfo'. data ScriptEnv = ScriptEnv @@ -38,8 +35,11 @@ data ScriptEnv = ScriptEnv , runnerPlatform :: Platform , runnerCompiler :: Compiler , runnerPackages :: [(OpenUnitId, ModuleRenaming)] + , runnerWithSharedLib :: Bool } +{- + -- | Convert package database into absolute path, so that -- if we change working directories in a subprocess we get the correct database. canonicalizePackageDB :: PackageDB -> IO PackageDB @@ -47,31 +47,24 @@ canonicalizePackageDB (SpecificPackageDB path) = SpecificPackageDB `fmap` canonicalizePath path canonicalizePackageDB x = return x +-} + -- | Create a 'ScriptEnv' from a 'LocalBuildInfo' configured with -- the GHC that we want to use. -mkScriptEnv :: Verbosity -> LocalBuildInfo -> IO ScriptEnv -mkScriptEnv verbosity lbi = do - package_db <- mapM canonicalizePackageDB (withPackageDB lbi) +mkScriptEnv :: Verbosity -> IO ScriptEnv +mkScriptEnv verbosity = return $ ScriptEnv { runnerVerbosity = verbosity - , runnerProgramDb = withPrograms lbi - , runnerPackageDbStack = package_db - , runnerPlatform = hostPlatform lbi - , runnerCompiler = compiler lbi + , runnerProgramDb = lbiProgramDb + , runnerPackageDbStack = lbiPackageDbStack + , runnerPlatform = lbiPlatform + , runnerCompiler = lbiCompiler -- NB: the set of packages available to test.hs scripts will COINCIDE -- with the dependencies on the cabal-testsuite library - , runnerPackages = cabalTestsPackages lbi + , runnerPackages = lbiPackages + , runnerWithSharedLib = lbiWithSharedLib } --- | Compute the set of @-package-id@ flags which would be passed when --- building the public library. Assumes that the public library is --- non-Backpack. -cabalTestsPackages :: LocalBuildInfo -> [(OpenUnitId, ModuleRenaming)] -cabalTestsPackages lbi = - case componentNameCLBIs lbi (CExeName (mkUnqualComponentName "cabal-tests")) of - [clbi] -> componentIncludes clbi - _ -> error "cabalTestsPackages" - -- | Run a script with 'runghc', under the 'ScriptEnv'. runghc :: ScriptEnv -> Maybe FilePath -> [(String, Maybe String)] -> FilePath -> [String] -> IO Result diff --git a/cabal-testsuite/cabal-testsuite.cabal b/cabal-testsuite/cabal-testsuite.cabal index db6a411cfa0..f535c2ea2ae 100644 --- a/cabal-testsuite/cabal-testsuite.cabal +++ b/cabal-testsuite/cabal-testsuite.cabal @@ -1,7 +1,8 @@ +cabal-version: 2.4 name: cabal-testsuite version: 3.0.0.0 copyright: 2003-2018, Cabal Development Team (see AUTHORS file) -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Cabal Development Team maintainer: cabal-devel@haskell.org @@ -11,7 +12,6 @@ synopsis: Test suite for Cabal and cabal-install description: This package defines a shared test suite for Cabal and cabal-install. category: Distribution -cabal-version: >=1.10 build-type: Custom extra-source-files: @@ -32,8 +32,15 @@ library Test.Cabal.Server Test.Cabal.Monad Test.Cabal.CheckArMetadata + + other-modules: + Test.Cabal.ScriptEnv0 + autogen-modules: + Test.Cabal.ScriptEnv0 + build-depends: aeson ==1.4.*, + containers, attoparsec, async, base, @@ -75,11 +82,5 @@ executable cabal-tests default-language: Haskell2010 custom-setup - -- It's important that we pick the exact same version of lib:Cabal - -- both here and for cabal-tests itself. Without this constraint, - -- the solver would pick the in-tree Cabal for cabal-tests's - -- lib:Cabal dependency, and some stable lib:Cabal version for its - -- custom-setup's one (due to 'setupMaxCabalVersionConstraint' in - -- 'D.C.ProjectPlanning'). - setup-depends: Cabal == 3.0.0.0, - base + setup-depends: Cabal == 2.4.*, + base, filepath, directory diff --git a/cabal-testsuite/main/cabal-tests.hs b/cabal-testsuite/main/cabal-tests.hs index e3424f542a1..3a779d13530 100644 --- a/cabal-testsuite/main/cabal-tests.hs +++ b/cabal-testsuite/main/cabal-tests.hs @@ -9,7 +9,6 @@ import Test.Cabal.Server import Test.Cabal.Monad import Distribution.Verbosity (normal, verbose, Verbosity) -import Distribution.Simple.Configure (getPersistBuildConfig) import Distribution.Simple.Utils (getDirectoryContentsRecursive) import Options.Applicative @@ -110,10 +109,8 @@ main = do Nothing -> guessDistDir when (verbosity >= verbose) $ hPutStrLn stderr $ "Using dist dir: " ++ dist_dir - lbi <- getPersistBuildConfig dist_dir - -- Get ready to go! - senv <- mkScriptEnv verbosity lbi + senv <- mkScriptEnv verbosity let runTest runner path = runner Nothing [] path $ ["--builddir", dist_dir, path] ++ renderCommonArgs (mainCommonArgs args)