Commit f0a2d5e3 authored by ttuegel's avatar ttuegel

Tracking enabled/disabled TestSuites in PackageDescription.

This patch adds the 'testEnabled' field to TestSuite. It's 
undesirable to track build status information in the static package 
description, but there is no better solution at this time. This 
patch has the side-effect of fixing several TODOs in 
Distribution.Simple.Configure.
parent 4108560f
......@@ -83,6 +83,7 @@ module Distribution.PackageDescription (
hasTests,
withTest,
testModules,
enabledTests,
-- * Build information
BuildInfo(..),
......@@ -375,7 +376,13 @@ exeModules exe = otherModules (buildInfo exe)
data TestSuite = TestSuite {
testName :: String,
testInterface :: TestSuiteInterface,
testBuildInfo :: BuildInfo
testBuildInfo :: BuildInfo,
testEnabled :: Bool
-- TODO: By having a 'testEnabled' field in the PackageDescription, we
-- are mixing build status information (i.e., arguments to 'configure')
-- with static package description information. This is undesirable, but
-- a better solution is waiting on the next overhaul to the
-- GenericPackageDescription -> PackageDescription resolution process.
}
deriving (Show, Read, Eq)
......@@ -409,13 +416,15 @@ instance Monoid TestSuite where
mempty = TestSuite {
testName = mempty,
testInterface = mempty,
testBuildInfo = mempty
testBuildInfo = mempty,
testEnabled = False
}
mappend a b = TestSuite {
testName = combine' testName,
testInterface = combine testInterface,
testBuildInfo = combine testBuildInfo
testBuildInfo = combine testBuildInfo,
testEnabled = if testEnabled a then True else testEnabled b
}
where combine field = field a `mappend` field b
combine' f = case (f a, f b) of
......@@ -436,11 +445,14 @@ emptyTestSuite = mempty
hasTests :: PackageDescription -> Bool
hasTests = any (buildable . testBuildInfo) . testSuites
-- | Get all the enabled test suites from a package.
enabledTests :: PackageDescription -> [TestSuite]
enabledTests = filter testEnabled . testSuites
-- | Perform an action on each buildable 'TestSuite' in a package.
withTest :: PackageDescription -> (TestSuite -> IO ()) -> IO ()
withTest pkg_descr f =
mapM_ f $ filter (buildable . testBuildInfo) $
testSuites pkg_descr
mapM_ f $ filter (buildable . testBuildInfo) $ enabledTests pkg_descr
-- | Get all the module names from a test suite.
testModules :: TestSuite -> [ModuleName]
......
......@@ -235,16 +235,16 @@ data BT a = BTN a | BTB (BT a) (BT a) -- very simple binary tree
-- This would require some sort of SAT solving, though, thus it's not
-- implemented unless we really need it.
--
resolveWithFlags :: Monoid a =>
resolveWithFlags ::
[(FlagName,[Bool])]
-- ^ Domain for each flag name, will be tested in order.
-> OS -- ^ OS as returned by Distribution.System.buildOS
-> Arch -- ^ Arch as returned by Distribution.System.buildArch
-> CompilerId -- ^ Compiler flavour + version
-> [Dependency] -- ^ Additional constraints
-> [CondTree ConfVar [Dependency] a]
-> [CondTree ConfVar [Dependency] PDTagged]
-> ([Dependency] -> DepTestRslt [Dependency]) -- ^ Dependency test function.
-> Either [Dependency] (TargetSet a, FlagAssignment)
-> Either [Dependency] (TargetSet PDTagged, FlagAssignment)
-- ^ Either the missing dependencies (error case), or a pair of
-- (set of build targets with dependencies, chosen flag assignments)
resolveWithFlags dom os arch impl constrs trees checkDeps =
......@@ -392,10 +392,15 @@ newtype TargetSet a = TargetSet [(DependencyMap, a)]
-- | Combine the target-specific dependencies in a TargetSet to give the
-- dependencies for the package as a whole.
overallDependencies :: Monoid a => TargetSet a -> DependencyMap
overallDependencies :: TargetSet PDTagged -> DependencyMap
overallDependencies (TargetSet targets) = mconcat depss
where
(depss, _) = unzip targets
(depss, _) = unzip $ filter (removeDisabledTests . snd) targets
removeDisabledTests :: PDTagged -> Bool
removeDisabledTests (Lib _) = True
removeDisabledTests (Exe _ _) = True
removeDisabledTests (Test _ t) = testEnabled t
removeDisabledTests PDNull = True
-- Apply extra constraints to a dependency map.
-- Combines dependencies where the result will only contain keys from the left
......
......@@ -177,8 +177,8 @@ ppTestSuites suites =
$+$ ppFields binfoFieldDescrs (testBuildInfo testsuite)
$+$ ppCustomFields (customFieldsBI (testBuildInfo testsuite))
ppTestSuite (TestSuite _ _ buildInfo')
(Just (TestSuite _ _ buildInfo2)) =
ppTestSuite (TestSuite _ _ buildInfo' _)
(Just (TestSuite _ _ buildInfo2 _)) =
ppDiffFields binfoFieldDescrs buildInfo' buildInfo2
$+$ ppCustomFields (customFieldsBI buildInfo')
......
......@@ -82,9 +82,9 @@ import Distribution.PackageDescription as PD
( PackageDescription(..), specVersion, GenericPackageDescription(..)
, Library(..), hasLibs, Executable(..), BuildInfo(..), allExtensions
, HookedBuildInfo, updatePackageDescription, allBuildInfo
, FlagName(..), TestSuite(..) )
, FlagName(..), TestSuite(..), mapTreeData )
import Distribution.PackageDescription.Configuration
( finalizePackageDescription, flattenPackageDescription )
( finalizePackageDescription )
import Distribution.PackageDescription.Check
( PackageCheck(..), checkPackage, checkPackageFiles )
import Distribution.Simple.Program
......@@ -318,12 +318,10 @@ configure (pkg_descr0, pbi) cfg
not . null . PackageIndex.lookupDependency pkgs'
where
pkgs' = PackageIndex.insert internalPackage installedPackageSet
pkg_descr0'' =
--TODO: avoid disabling tests entirely, we otherwise cannot
-- perform semantic checks, see also checkPackageProblems
if fromFlag (configTests cfg)
then pkg_descr0
else pkg_descr0 { condTestSuites = [] }
enableTest t = t { testEnabled = fromFlag (configTests cfg) }
flaggedTests = map (\(n, t) -> (n, mapTreeData enableTest t))
(condTestSuites pkg_descr0)
pkg_descr0'' = pkg_descr0 { condTestSuites = flaggedTests }
(pkg_descr0', flags) <-
case finalizePackageDescription
......@@ -480,7 +478,7 @@ configure (pkg_descr0, pbi) cfg
(configScratchDir cfg),
libraryConfig = configLib `fmap` library pkg_descr',
executableConfigs = configExe `fmap` executables pkg_descr',
testSuiteConfigs = configTest `fmap` testSuites pkg_descr',
testSuiteConfigs = configTest `fmap` filter testEnabled (testSuites pkg_descr'),
installedPkgs = packageDependsIndex,
pkgDescrFile = Nothing,
localPkgDescr = pkg_descr',
......@@ -970,7 +968,7 @@ checkPackageProblems :: Verbosity
-> GenericPackageDescription
-> PackageDescription
-> IO ()
checkPackageProblems verbosity gpkg pkg0 = do
checkPackageProblems verbosity gpkg pkg = do
ioChecks <- checkPackageFiles pkg "."
let pureChecks = checkPackage gpkg (Just pkg)
errors = [ e | PackageBuildImpossible e <- pureChecks ++ ioChecks ]
......@@ -979,16 +977,3 @@ checkPackageProblems verbosity gpkg pkg0 = do
then mapM_ (warn verbosity) warnings
else do mapM_ (hPutStrLn stderr . ("Error: " ++)) errors
exitWith (ExitFailure 1)
where
-- TODO: Sigh, this is a fairly unpleasent hack. The issue is that
-- we want to check test-suite sections even when tests are disabled.
-- When tests are disabled we have to exclude the test-suite sections
-- when resolving the conditionals. But the checks we do are done
-- on the post-resolved form! Ug. A better solution would be either
-- 1) to do the checks on the pre-resolved form
-- 2) to resolve in two steps: find a flag assignment, then apply it
-- that'd allow us to find the flag assingment ignoring tests
-- but then to apply it anyway.
-- In the meantime we stick the tests back in before checking by
-- flattening the pre-resovled form.
pkg = pkg0 { testSuites = testSuites (flattenPackageDescription gpkg) }
......@@ -58,7 +58,7 @@ import Distribution.Package
( PackageId )
import qualified Distribution.PackageDescription as PD
( PackageDescription(..), TestSuite(..)
, TestSuiteInterface(..), testType )
, TestSuiteInterface(..), testType, hasTests )
import Distribution.Simple.Build.PathsModule ( pkgPathEnvVar )
import Distribution.Simple.BuildPaths ( exeExtension )
import Distribution.Simple.Compiler ( Compiler(..), CompilerId )
......@@ -83,7 +83,7 @@ import System.Directory
( createDirectoryIfMissing, doesFileExist, getCurrentDirectory
, removeFile )
import System.Environment ( getEnvironment )
import System.Exit ( ExitCode(..), exitFailure, exitWith )
import System.Exit ( ExitCode(..), exitFailure, exitSuccess, exitWith )
import System.FilePath ( (</>), (<.>) )
import System.IO ( hClose, IOMode(..), openFile )
import System.Process ( runProcess, waitForProcess )
......@@ -242,6 +242,7 @@ test pkg_descr lbi flags = do
testLogDir = distPref </> "test"
testNames = fromFlag $ testList flags
pkgTests = PD.testSuites pkg_descr
enabledTests = filter PD.testEnabled pkgTests
doTest :: (PD.TestSuite, Maybe TestSuiteLog) -> IO TestSuiteLog
doTest (suite, mLog) = do
......@@ -288,13 +289,26 @@ test pkg_descr lbi flags = do
, logFile = ""
}
when (not $ PD.hasTests pkg_descr) $ do
notice verbosity "Package has no test suites."
exitSuccess
when (PD.hasTests pkg_descr && null enabledTests) $
die $ "No test suites enabled. Did you remember to configure with "
++ "\'--enable-tests\'?"
testsToRun <- case testNames of
[] -> return $ zip pkgTests $ repeat Nothing
[] -> return $ zip enabledTests $ repeat Nothing
names -> flip mapM names $ \tName ->
let testMap = map (\x -> (PD.testName x, x)) pkgTests
let testMap = zip enabledNames enabledTests
enabledNames = map PD.testName enabledTests
allNames = map PD.testName pkgTests
in case lookup tName testMap of
Just t -> return (t, Nothing)
_ -> die $ "no such test: " ++ tName
_ | tName `elem` allNames ->
die $ "Package configured with test suite "
++ tName ++ " disabled."
| otherwise -> die $ "no such test: " ++ tName
createDirectoryIfMissing True testLogDir
......
......@@ -38,42 +38,20 @@ suite cabalVersion = TestCase $ do
genPD <- readPackageDescription silent pdFile
let compiler = CompilerId GHC $ Version [6, 12, 2] []
anyV = intersectVersionRanges anyVersion anyVersion
anticipatedFinalPD = emptyPackageDescription
{ package = PackageIdentifier
{ pkgName = PackageName "TestStanza"
, pkgVersion = Version [0, 1] []
}
, license = BSD3
, author = "Thomas Tuegel"
, stability = "stable"
, description = "Check that Cabal recognizes the Test stanza defined below."
, category = "PackageTests"
, specVersionRaw = Right anyVersion
, buildType = Just Simple
, buildDepends =
[ Dependency (PackageName "base") anyV ]
, library = Just emptyLibrary
{ exposedModules = [fromString "MyLibrary"]
, libBuildInfo = emptyBuildInfo
{ targetBuildDepends =
[ Dependency (PackageName "base") anyVersion ]
, hsSourceDirs = ["."]
}
}
, testSuites = [ emptyTestSuite
{ testName = "dummy"
, testInterface = TestSuiteExeV10 (Version [1,0] []) "dummy.hs"
, testBuildInfo = emptyBuildInfo
{ targetBuildDepends =
[ Dependency (PackageName "base") anyVersion ]
, hsSourceDirs = ["."]
}
}
]
}
anticipatedTestSuite = emptyTestSuite
{ testName = "dummy"
, testInterface = TestSuiteExeV10 (Version [1,0] []) "dummy.hs"
, testBuildInfo = emptyBuildInfo
{ targetBuildDepends =
[ Dependency (PackageName "base") anyVersion ]
, hsSourceDirs = ["."]
}
, testEnabled = False
}
case finalizePackageDescription [] (const True) buildPlatform compiler [] genPD of
Left xs -> let depMessage = "should not have missing dependencies:\n" ++
(unlines $ map (show . disp) xs)
in assertEqual depMessage True False
Right (f, _) -> assertEqual "parsed package description does not match anticipated"
f anticipatedFinalPD
Right (f, _) -> let gotTest = head $ testSuites f
in assertEqual "parsed test-suite stanza does not match anticipated"
gotTest anticipatedTestSuite
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