Commit 4d08a8ab authored by Oleg Grenrus's avatar Oleg Grenrus Committed by GitHub
Browse files

Merge pull request #4244 from haskell/new-test

WIP: new-test
parents eda30d31 d383ba85
{-# LANGUAGE NamedFieldPuns #-}
-- | cabal-install CLI command: new-test
--
module Distribution.Client.CmdTest (
testCommand,
testAction,
) where
import Distribution.Client.ProjectOrchestration
import Distribution.Client.ProjectPlanning
( PackageTarget(..) )
import Distribution.Client.BuildTarget
( readUserBuildTargets )
import Distribution.Client.Setup
( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags )
import Distribution.Simple.Setup
( HaddockFlags, fromFlagOrDefault )
import Distribution.Verbosity
( normal )
import Distribution.Simple.Command
( CommandUI(..), usageAlternatives )
import Distribution.Simple.Utils
( wrapText )
import qualified Distribution.Client.Setup as Client
testCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
testCommand = Client.installCommand {
commandName = "new-test",
commandSynopsis = "Perform new-build and run tests",
commandUsage = usageAlternatives "new-test" [ "[FLAGS] TARGET" ],
commandDescription = Just $ \_ -> wrapText $
"Build and run test targets",
commandNotes = Just $ \_pname ->
"Examples:\n"
}
-- | The @test@ command is very much like @build@. It brings the install plan
-- up to date, selects that part of the plan needed by the given or implicit
-- test arget(s) and then executes the plan.
--
-- Compared to @build@ the difference is that there's also test targets
-- which are ephemeral.
--
-- For more details on how this works, see the module
-- "Distribution.Client.ProjectOrchestration"
--
testAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
-> [String] -> GlobalFlags -> IO ()
testAction (configFlags, configExFlags, installFlags, haddockFlags)
targetStrings globalFlags = do
userTargets <- readUserBuildTargets targetStrings
buildCtx <-
runProjectPreBuildPhase
verbosity
( globalFlags, configFlags, configExFlags
, installFlags, haddockFlags )
PreBuildHooks {
hookPrePlanning = \_ _ _ -> return (),
hookSelectPlanSubset = \_buildSettings elaboratedPlan ->
-- Interpret the targets on the command line as test targets
-- (as opposed to say build or haddock targets).
selectTargets
verbosity
TestDefaultComponents
TestSpecificComponent
userTargets
False -- onlyDependencies, always False for test
elaboratedPlan
}
printPlan verbosity buildCtx
buildOutcomes <- runProjectBuildPhase verbosity buildCtx
runProjectPostBuildPhase verbosity buildCtx buildOutcomes
where
verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
......@@ -352,7 +352,8 @@ packageFileMonitorKeyValues elab =
--
elab_config =
elab {
elabBuildTargets = [],
elabBuildTargets = [],
elabTestTargets = [],
elabReplTarget = Nothing,
elabBuildHaddocks = False
}
......@@ -1099,6 +1100,10 @@ buildInplaceUnpackedPackage verbosity
updatePackageRegFileMonitor packageFileMonitor srcdir mipkg
whenTest $ do
annotateFailureNoLog TestsFailed $
setup testCommand testFlags testArgs
-- Repl phase
--
whenRepl $
......@@ -1130,6 +1135,10 @@ buildInplaceUnpackedPackage verbosity
whenRebuild action
| null (elabBuildTargets pkg) = return ()
| otherwise = action
whenTest action
| null (elabTestTargets pkg) = return ()
| otherwise = action
whenRepl action
......@@ -1159,6 +1168,11 @@ buildInplaceUnpackedPackage verbosity
verbosity builddir
buildArgs = setupHsBuildArgs pkg
testCommand = Cabal.testCommand -- defaultProgramDb
testFlags _ = setupHsTestFlags pkg pkgshared
verbosity builddir
testArgs = setupHsTestArgs pkg
replCommand = Cabal.replCommand defaultProgramDb
replFlags _ = setupHsReplFlags pkg pkgshared
verbosity builddir
......
......@@ -41,6 +41,8 @@ module Distribution.Client.ProjectPlanning (
setupHsBuildArgs,
setupHsReplFlags,
setupHsReplArgs,
setupHsTestFlags,
setupHsTestArgs,
setupHsCopyFlags,
setupHsRegisterFlags,
setupHsHaddockFlags,
......@@ -1590,6 +1592,7 @@ elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB
-- we haven't improved the plan yet), so we do it in another pass.
-- Check the comments of those functions for more details.
elabBuildTargets = []
elabTestTargets = []
elabReplTarget = Nothing
elabBuildHaddocks = False
......@@ -1919,12 +1922,19 @@ instantiateInstallPlan plan =
--TODO: this needs to report some user target/config errors
elaboratePackageTargets :: ElaboratedConfiguredPackage -> [PackageTarget]
-> ([ComponentTarget], Maybe ComponentTarget, Bool)
-> ([ComponentTarget], [ComponentTarget], Maybe ComponentTarget, Bool)
elaboratePackageTargets ElaboratedConfiguredPackage{..} targets =
let buildTargets = nubComponentTargets
. map compatSubComponentTargets
. concatMap elaborateBuildTarget
$ targets
testTargets = nubComponentTargets
. filter isTestComponentTarget
. map compatSubComponentTargets
. concatMap elaborateTestTarget
$ targets
--TODO: instead of listToMaybe we should be reporting an error here
replTargets = listToMaybe
. nubComponentTargets
......@@ -1933,13 +1943,21 @@ elaboratePackageTargets ElaboratedConfiguredPackage{..} targets =
$ targets
buildHaddocks = HaddockDefaultComponents `elem` targets
in (buildTargets, replTargets, buildHaddocks)
in (buildTargets, testTargets, replTargets, buildHaddocks)
where
--TODO: need to report an error here if defaultComponents is empty
elaborateBuildTarget BuildDefaultComponents = pkgDefaultComponents
elaborateBuildTarget (BuildSpecificComponent t) = [t]
-- TODO: We need to build test components as well
-- should this be configurable, i.e. to /just/ run, not try to build
elaborateBuildTarget TestDefaultComponents = pkgDefaultComponents
elaborateBuildTarget (TestSpecificComponent t) = [t]
elaborateBuildTarget _ = []
elaborateTestTarget TestDefaultComponents = pkgDefaultComponents
elaborateTestTarget (TestSpecificComponent t) = [t]
elaborateTestTarget _ = []
--TODO: need to report an error here if defaultComponents is empty
elaborateReplTarget ReplDefaultComponent = take 1 pkgDefaultComponents
elaborateReplTarget (ReplSpecificComponent t) = [t]
......@@ -1991,6 +2009,7 @@ elaboratePackageTargets ElaboratedConfiguredPackage{..} targets =
pkgHasEphemeralBuildTargets :: ElaboratedConfiguredPackage -> Bool
pkgHasEphemeralBuildTargets elab =
isJust (elabReplTarget elab)
|| (not . null) (elabTestTargets elab)
|| (not . null) [ () | ComponentTarget _ subtarget <- elabBuildTargets elab
, subtarget /= WholeComponent ]
......@@ -2075,6 +2094,7 @@ pruneInstallPlanPass1 perPkgTargetsMap pkgs =
roots = mapMaybe find_root pkgs'
find_root (InstallPlan.Configured (PrunedPackage elab _)) =
if not (null (elabBuildTargets elab)
&& null (elabTestTargets elab)
&& isNothing (elabReplTarget elab)
&& not (elabBuildHaddocks elab))
then Just (installedUnitId elab)
......@@ -2088,11 +2108,12 @@ pruneInstallPlanPass1 perPkgTargetsMap pkgs =
setElabBuildTargets elab =
elab {
elabBuildTargets = mapMaybe targetForElab buildTargets,
elabTestTargets = mapMaybe targetForElab testTargets,
elabReplTarget = replTarget >>= targetForElab,
elabBuildHaddocks = buildHaddocks
}
where
(buildTargets, replTarget, buildHaddocks)
(buildTargets, testTargets, replTarget, buildHaddocks)
= elaboratePackageTargets elab targets
targets = fromMaybe []
$ Map.lookup (installedUnitId elab) perPkgTargetsMap
......@@ -2155,6 +2176,7 @@ pruneInstallPlanPass1 perPkgTargetsMap pkgs =
Set.fromList
[ stanza
| ComponentTarget cname _ <- elabBuildTargets pkg
++ elabTestTargets pkg
++ maybeToList (elabReplTarget pkg)
, stanza <- maybeToList (componentOptionalStanza cname)
]
......@@ -2782,6 +2804,26 @@ setupHsBuildArgs (ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent _
= []
setupHsTestFlags :: ElaboratedConfiguredPackage
-> ElaboratedSharedConfig
-> Verbosity
-> FilePath
-> Cabal.TestFlags
setupHsTestFlags _ _ verbosity builddir = Cabal.TestFlags
{ testDistPref = toFlag builddir
, testVerbosity = toFlag verbosity
, testMachineLog = mempty
, testHumanLog = mempty
, testShowDetails = toFlag Cabal.Always
, testKeepTix = mempty
, testOptions = mempty
}
setupHsTestArgs :: ElaboratedConfiguredPackage -> [String]
-- TODO: Does the issue #3335 affects test as well
setupHsTestArgs elab =
mapMaybe (showTestComponentTarget (packageId elab)) (elabTestTargets elab)
setupHsReplFlags :: ElaboratedConfiguredPackage
-> ElaboratedSharedConfig
-> Verbosity
......
......@@ -40,8 +40,11 @@ module Distribution.Client.ProjectPlanning.Types (
PackageTarget(..),
ComponentTarget(..),
showComponentTarget,
showTestComponentTarget,
SubComponentTarget(..),
isTestComponentTarget,
-- * Setup script
SetupScriptStyle(..),
) where
......@@ -272,6 +275,7 @@ data ElaboratedConfiguredPackage
-- Build time related:
elabBuildTargets :: [ComponentTarget],
elabTestTargets :: [ComponentTarget],
elabReplTarget :: Maybe ComponentTarget,
elabBuildHaddocks :: Bool,
......@@ -581,6 +585,8 @@ data PackageTarget =
| BuildSpecificComponent ComponentTarget
| ReplDefaultComponent
| ReplSpecificComponent ComponentTarget
| TestDefaultComponents
| TestSpecificComponent ComponentTarget
| HaddockDefaultComponents
deriving (Eq, Show, Generic)
......@@ -609,7 +615,13 @@ showComponentTarget pkgid =
ModuleTarget mname -> Cabal.BuildTargetModule cname mname
FileTarget fname -> Cabal.BuildTargetFile cname fname
showTestComponentTarget :: PackageId -> ComponentTarget -> Maybe String
showTestComponentTarget _ (ComponentTarget (CTestName n) _) = Just $ display n
showTestComponentTarget _ _ = Nothing
isTestComponentTarget :: ComponentTarget -> Bool
isTestComponentTarget (ComponentTarget (CTestName _) _) = True
isTestComponentTarget _ = False
---------------------------
-- Setup.hs script policy
......
......@@ -74,11 +74,12 @@ import Distribution.Client.Targets
import qualified Distribution.Client.List as List
( list, info )
import qualified Distribution.Client.CmdConfigure as CmdConfigure
import qualified Distribution.Client.CmdBuild as CmdBuild
import qualified Distribution.Client.CmdRepl as CmdRepl
import qualified Distribution.Client.CmdConfigure as CmdConfigure
import qualified Distribution.Client.CmdFreeze as CmdFreeze
import qualified Distribution.Client.CmdHaddock as CmdHaddock
import qualified Distribution.Client.CmdRepl as CmdRepl
import qualified Distribution.Client.CmdTest as CmdTest
import Distribution.Client.Install (install)
import Distribution.Client.Configure (configure, writeConfigFlags)
......@@ -284,6 +285,7 @@ mainWorker args = topHandler $
, regularCmd CmdConfigure.configureCommand CmdConfigure.configureAction
, regularCmd CmdBuild.buildCommand CmdBuild.buildAction
, regularCmd CmdRepl.replCommand CmdRepl.replAction
, hiddenCmd CmdTest.testCommand CmdTest.testAction
, regularCmd CmdFreeze.freezeCommand CmdFreeze.freezeAction
, regularCmd CmdHaddock.haddockCommand CmdHaddock.haddockAction
]
......
......@@ -213,6 +213,7 @@ executable cabal
Distribution.Client.CmdConfigure
Distribution.Client.CmdFreeze
Distribution.Client.CmdHaddock
Distribution.Client.CmdTest
Distribution.Client.CmdRepl
Distribution.Client.Config
Distribution.Client.Configure
......
import Test.Cabal.Prelude
main = cabalTest $ do
cabal "new-test" []
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