From f8ba8584ec245cd97787793dbb82a18e565ab315 Mon Sep 17 00:00:00 2001
From: "Edward Z. Yang" <ezyang@cs.stanford.edu>
Date: Sun, 27 Nov 2016 00:26:00 -0800
Subject: [PATCH] Program-ify everything in test suite.
Previously, in some cases we would carry around an explicit
FilePath for an executable that we wanted to invoke subsequently.
In this new scheme, any executable we want to execute gets registered
to the ProgramDb we are carrying around. Now we can uniformly
use runProgramM in all cases. Great!
Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>
---
Cabal/Distribution/Simple/Program/Db.hs | 8 ++
.../PackageTests/Exec/sandbox-hc-pkg.test.hs | 9 +-
cabal-testsuite/Test/Cabal/Monad.hs | 126 +++++++++++++-----
cabal-testsuite/Test/Cabal/Prelude.hs | 18 +--
4 files changed, 110 insertions(+), 51 deletions(-)
diff --git a/Cabal/Distribution/Simple/Program/Db.hs b/Cabal/Distribution/Simple/Program/Db.hs
index d15368d6e1..18c35ce9b0 100644
--- a/Cabal/Distribution/Simple/Program/Db.hs
+++ b/Cabal/Distribution/Simple/Program/Db.hs
@@ -52,6 +52,7 @@ module Distribution.Simple.Program.Db (
-- ** Query and manipulate the program db
configureProgram,
configureAllKnownPrograms,
+ unconfigureProgram,
lookupProgramVersion,
reconfigurePrograms,
requireProgram,
@@ -365,6 +366,13 @@ configurePrograms verbosity progs progdb =
foldM (flip (configureProgram verbosity)) progdb progs
+-- | Unconfigure a program. This is basically a hack and you shouldn't
+-- use it, but it can be handy for making sure a 'requireProgram'
+-- actually reconfigures.
+unconfigureProgram :: String -> ProgramDb -> ProgramDb
+unconfigureProgram progname =
+ updateConfiguredProgs $ Map.delete progname
+
-- | Try to configure all the known programs that have not yet been configured.
--
configureAllKnownPrograms :: Verbosity
diff --git a/cabal-testsuite/PackageTests/Exec/sandbox-hc-pkg.test.hs b/cabal-testsuite/PackageTests/Exec/sandbox-hc-pkg.test.hs
index 5bf979e682..dee03490f8 100644
--- a/cabal-testsuite/PackageTests/Exec/sandbox-hc-pkg.test.hs
+++ b/cabal-testsuite/PackageTests/Exec/sandbox-hc-pkg.test.hs
@@ -1,5 +1,7 @@
import Test.Cabal.Prelude
import Data.Maybe
+import System.Directory
+import Control.Monad.IO.Class
main = cabalTest $ do
withPackageDb $ do
withSandbox $ do
@@ -10,9 +12,10 @@ main = cabalTest $ do
-- When run inside 'cabal-exec' the 'sandbox hc-pkg list' sub-command
-- should find the library.
env <- getTestEnv
- -- TODO: libify me
- let cabal_path = fromMaybe (error "No cabal-install path configured")
- (testCabalInstallPath env)
+ -- NB: cabal_path might be relative, so we have to
+ -- turn it absolute
+ rel_cabal_path <- programPathM cabalProgram
+ cabal_path <- liftIO $ makeAbsolute rel_cabal_path
cabal' "exec" ["sh", "--", "-c"
, "cd subdir && " ++ show cabal_path ++
-- TODO: Ugh. Test abstractions leaking
diff --git a/cabal-testsuite/Test/Cabal/Monad.hs b/cabal-testsuite/Test/Cabal/Monad.hs
index dd872f56ed..46e85d60c1 100644
--- a/cabal-testsuite/Test/Cabal/Monad.hs
+++ b/cabal-testsuite/Test/Cabal/Monad.hs
@@ -12,6 +12,9 @@ module Test.Cabal.Monad (
-- * Helper functions
programPathM,
requireProgramM,
+ isAvailableProgram,
+ hackageRepoToolProgram,
+ cabalProgram,
-- * The test environment
TestEnv(..),
getTestEnv,
@@ -54,7 +57,6 @@ import Distribution.Simple.Configure
( getPersistBuildConfig, configCompilerEx )
import Distribution.Types.LocalBuildInfo
-
import Distribution.Verbosity
import qualified Control.Exception as E
@@ -71,10 +73,10 @@ import System.IO.Error (isDoesNotExistError)
import Options.Applicative
data CommonArgs = CommonArgs {
- argCabalInstallPath :: Maybe FilePath,
- argGhcPath :: Maybe FilePath,
- argHackageRepoToolPath :: FilePath,
- argSkipSetupTests :: Bool
+ argCabalInstallPath :: Maybe FilePath,
+ argGhcPath :: Maybe FilePath,
+ argHackageRepoToolPath :: Maybe FilePath,
+ argSkipSetupTests :: Bool
}
commonArgParser :: Parser CommonArgs
@@ -90,25 +92,24 @@ commonArgParser = CommonArgs
<> long "with-ghc"
<> metavar "PATH"
))
- <*> option str
+ <*> optional (option str
( help "Path to hackage-repo-tool to use for repository manipulation"
<> long "with-hackage-repo-tool"
<> metavar "PATH"
- <> value "hackage-repo-tool"
- )
+ ))
<*> switch (long "skip-setup-tests" <> help "Skip setup tests")
renderCommonArgs :: CommonArgs -> [String]
renderCommonArgs args =
- maybe [] (\x -> ["--with-cabal", x]) (argCabalInstallPath args) ++
- maybe [] (\x -> ["--with-ghc", x]) (argGhcPath args) ++
- ["--with-hackage-repo-tool", argHackageRepoToolPath args] ++
+ maybe [] (\x -> ["--with-cabal", x]) (argCabalInstallPath args) ++
+ maybe [] (\x -> ["--with-ghc", x]) (argGhcPath args) ++
+ maybe [] (\x -> ["--with-hackage-repo-tool", x]) (argHackageRepoToolPath args) ++
(if argSkipSetupTests args then ["--skip-setup-tests"] else [])
data TestArgs = TestArgs {
- testArgDistDir :: FilePath,
+ testArgDistDir :: FilePath,
testArgScriptPath :: FilePath,
- testCommonArgs :: CommonArgs
+ testCommonArgs :: CommonArgs
}
testArgParser :: Parser TestArgs
@@ -153,15 +154,14 @@ unexpectedSuccessExitCode = 66
setupAndCabalTest :: TestM () -> IO ()
setupAndCabalTest m = runTestM $ do
env <- getTestEnv
- skipIf (testSkipSetupTests env && isNothing (testCabalInstallPath env))
+ have_cabal <- isAvailableProgram cabalProgram
+ skipIf (testSkipSetupTests env && not have_cabal)
when (not (testSkipSetupTests env)) $ do
liftIO $ putStrLn "Test with Setup:"
m
- case testCabalInstallPath env of
- Nothing -> return ()
- Just _ -> do
- liftIO $ putStrLn "Test with cabal-install:"
- withReaderT (\nenv -> nenv { testCabalInstallAsSetup = True }) m
+ when have_cabal $ do
+ liftIO $ putStrLn "Test with cabal-install:"
+ withReaderT (\nenv -> nenv { testCabalInstallAsSetup = True }) m
setupTest :: TestM () -> IO ()
setupTest m = runTestM $ do
@@ -171,12 +171,20 @@ setupTest m = runTestM $ do
cabalTest :: TestM () -> IO ()
cabalTest m = runTestM $ do
- env <- getTestEnv
- skipIf (isNothing (testCabalInstallPath env))
+ skipUnless =<< isAvailableProgram cabalProgram
withReaderT (\nenv -> nenv { testCabalInstallAsSetup = True }) m
type TestM = ReaderT TestEnv IO
+hackageRepoToolProgram :: Program
+hackageRepoToolProgram = simpleProgram "hackage-repo-tool"
+
+cabalProgram :: Program
+cabalProgram = (simpleProgram "cabal") {
+ -- Do NOT search for executable named cabal
+ programFindLocation = \_ _ -> return Nothing
+ }
+
-- | Run a test in the test monad according to program's arguments.
runTestM :: TestM () -> IO ()
runTestM m = do
@@ -189,20 +197,61 @@ runTestM m = do
lbi <- getPersistBuildConfig dist_dir
let verbosity = normal -- TODO: configurable
senv <- mkScriptEnv verbosity lbi
- (program_db, db_stack) <- case argGhcPath (testCommonArgs args) of
- Nothing -> return (withPrograms lbi, withPackageDB lbi)
+ -- Add test suite specific programs
+ let program_db0 =
+ addKnownPrograms
+ ([hackageRepoToolProgram, cabalProgram] ++ builtinPrograms)
+ (withPrograms lbi)
+ -- Reconfigure according to user flags
+ let cargs = testCommonArgs args
+ program_db1 <-
+ reconfigurePrograms verbosity
+ ([("cabal", p) | p <- maybeToList (argCabalInstallPath cargs)] ++
+ [("ghc", p) | p <- maybeToList (argGhcPath cargs)] ++
+ [("hackage-repo-tool", p)
+ | p <- maybeToList (argHackageRepoToolPath cargs)])
+ [] -- --prog-options not supported ATM
+ program_db0
+
+ -- Reconfigure the rest of GHC
+ program_db <- case argGhcPath cargs of
+ Nothing -> return program_db1
Just ghc_path -> do
+ -- All the things that get updated paths from
+ -- configCompilerEx. The point is to make sure
+ -- we reconfigure these when we need them.
+ let program_db2 = unconfigureProgram "ghc"
+ . unconfigureProgram "ghc-pkg"
+ . unconfigureProgram "hsc2hs"
+ . unconfigureProgram "haddock"
+ . unconfigureProgram "hpc"
+ . unconfigureProgram "runghc"
+ . unconfigureProgram "gcc"
+ . unconfigureProgram "ld"
+ . unconfigureProgram "ar"
+ . unconfigureProgram "strip"
+ $ program_db1
(_, _, program_db) <-
configCompilerEx
(Just (compilerFlavor (compiler lbi)))
(Just ghc_path)
Nothing
- defaultProgramDb -- don't use lbi; it won't reconfigure
+ program_db2
verbosity
- -- TODO: configurable
- let db_stack = [GlobalPackageDB]
- return (program_db, db_stack)
- let env = TestEnv {
+ -- TODO: this actually leaves a pile of things unconfigured.
+ -- Optimal strategy for us is to lazily configure them, so
+ -- we don't pay for things we don't need. A bit difficult
+ -- to do in the current design.
+ return program_db
+
+ let db_stack =
+ case argGhcPath (testCommonArgs args) of
+ Nothing -> withPackageDB lbi
+ -- Can't use the build package db stack since they
+ -- are all for the wrong versions! TODO: Make
+ -- this configurable
+ Just _ -> [GlobalPackageDB]
+ env = TestEnv {
testSourceDir = script_dir,
testSubName = script_base,
testProgramDb = program_db,
@@ -211,8 +260,6 @@ runTestM m = do
testMtimeChangeDelay = Nothing,
testScriptEnv = senv,
testSetupPath = dist_dir </> "setup" </> "setup",
- testCabalInstallPath = argCabalInstallPath (testCommonArgs args),
- testHackageRepoToolPath = argHackageRepoToolPath (testCommonArgs args),
testSkipSetupTests = argSkipSetupTests (testCommonArgs args),
testEnvironment =
-- Try to avoid Unicode output
@@ -253,6 +300,18 @@ programPathM :: Program -> TestM FilePath
programPathM program = do
fmap programPath (requireProgramM program)
+isAvailableProgram :: Program -> TestM Bool
+isAvailableProgram program = do
+ env <- getTestEnv
+ case lookupProgram program (testProgramDb env) of
+ Just _ -> return True
+ Nothing -> do
+ -- It might not have been configured. Try to configure.
+ progdb <- liftIO $ configureProgram (testVerbosity env) program (testProgramDb env)
+ case lookupProgram program progdb of
+ Just _ -> return True
+ Nothing -> return False
+
-- | Run an IO action, and suppress a "does not exist" error.
onlyIfExists :: MonadIO m => IO () -> m ()
onlyIfExists m =
@@ -285,13 +344,6 @@ data TestEnv = TestEnv
, testScriptEnv :: ScriptEnv
-- | Setup script path
, testSetupPath :: FilePath
- -- | cabal-install path (or Nothing if we are not testing
- -- cabal-install). NB: This does NOT default to @cabal@ in PATH as
- -- this is unlikely to be the cabal you want to test.
- , testCabalInstallPath :: Maybe FilePath
- -- | hackage-repo-tool path (defaults to hackage-repo-tool found in
- -- PATH)
- , testHackageRepoToolPath :: FilePath
-- | Skip Setup tests?
, testSkipSetupTests :: Bool
diff --git a/cabal-testsuite/Test/Cabal/Prelude.hs b/cabal-testsuite/Test/Cabal/Prelude.hs
index dc0889ae41..6e068c6974 100644
--- a/cabal-testsuite/Test/Cabal/Prelude.hs
+++ b/cabal-testsuite/Test/Cabal/Prelude.hs
@@ -135,8 +135,7 @@ setup' cmd args = do
full_args = cmd : ["-v", "--distdir", rel_dist_dir] ++ args'
r <-
if testCabalInstallAsSetup env
- then runM (fromMaybe (error "No cabal-install path configured")
- (testCabalInstallPath env)) full_args
+ then runProgramM cabalProgram full_args
else do
pdfile <- liftIO $ tryFindPackageDesc (testCurrentDir env)
pdesc <- liftIO $ readPackageDescription (testVerbosity env) pdfile
@@ -262,13 +261,7 @@ cabal_sandbox' cmd args = do
cabal_raw' :: [String] -> TestM Result
cabal_raw' cabal_args = do
- env <- getTestEnv
- r <- liftIO $ run (testVerbosity env)
- (Just (testCurrentDir env))
- (testEnvironment env)
- (fromMaybe (error "No cabal-install path configured")
- (testCabalInstallPath env))
- cabal_args
+ r <- runProgramM cabalProgram cabal_args
record r
requireSuccess r
@@ -426,8 +419,7 @@ hackageRepoTool cmd args = void $ hackageRepoTool' cmd args
hackageRepoTool' :: String -> [String] -> TestM Result
hackageRepoTool' cmd args = do
- env <- getTestEnv
- r <- runM (testHackageRepoToolPath env) (cmd : args)
+ r <- runProgramM hackageRepoToolProgram (cmd : args)
record r
_ <- requireSuccess r
return r
@@ -456,6 +448,10 @@ infixr 4 `archiveTo`
withRepo :: FilePath -> TestM a -> TestM a
withRepo repo_dir m = do
env <- getTestEnv
+
+ -- Check if hackage-repo-tool is available, and skip if not
+ skipUnless =<< isAvailableProgram hackageRepoToolProgram
+
-- 1. Generate keys
hackageRepoTool "create-keys" ["--keys", testKeysDir env]
-- 2. Initialize repo directory
--
GitLab