Commit 9573059f authored by Mikhail Glushenkov's avatar Mikhail Glushenkov

Add an '--only' flag for 'build', 'test' and 'bench'.

Allows to skip the automatic reinstallation of add-source deps.
parent 729658bc
......@@ -80,7 +80,6 @@ module Distribution.Simple.Setup (
buildOptions, installDirsOptions,
defaultDistPref,
numJobsParser,
Flag(..),
toFlag,
......@@ -1252,7 +1251,6 @@ data BuildFlags = BuildFlags {
buildProgramArgs :: [(String, [String])],
buildDistPref :: Flag FilePath,
buildVerbosity :: Flag Verbosity,
buildNumJobs :: Flag (Maybe Int),
-- TODO: this one should not be here, it's just that the silly
-- UserHooks stop us from passing extra info in other ways
buildArgs :: [String]
......@@ -1269,7 +1267,6 @@ defaultBuildFlags = BuildFlags {
buildProgramArgs = [],
buildDistPref = Flag defaultDistPref,
buildVerbosity = Flag normal,
buildNumJobs = mempty,
buildArgs = []
}
......@@ -1289,13 +1286,6 @@ buildOptions progConf showOrParseArgs =
buildDistPref (\d flags -> flags { buildDistPref = d })
showOrParseArgs
: option "j" ["jobs"]
"Run NUM jobs simultaneously (or '$ncpus' if no NUM is given)."
buildNumJobs (\v flags -> flags { buildNumJobs = v })
(optArg "NUM" (fmap Flag numJobsParser)
(Flag Nothing)
(map (Just . maybe "$ncpus" show) . flagToList))
: programConfigurationPaths progConf showOrParseArgs
buildProgramPaths (\v flags -> flags { buildProgramPaths = v})
......@@ -1311,7 +1301,6 @@ instance Monoid BuildFlags where
buildProgramArgs = mempty,
buildVerbosity = mempty,
buildDistPref = mempty,
buildNumJobs = mempty,
buildArgs = mempty
}
mappend a b = BuildFlags {
......@@ -1319,7 +1308,6 @@ instance Monoid BuildFlags where
buildProgramArgs = combine buildProgramArgs,
buildVerbosity = combine buildVerbosity,
buildDistPref = combine buildDistPref,
buildNumJobs = combine buildNumJobs,
buildArgs = combine buildArgs
}
where combine field = field a `mappend` field b
......@@ -1357,7 +1345,6 @@ data TestFlags = TestFlags {
testMachineLog :: Flag PathTemplate,
testShowDetails :: Flag TestShowDetails,
testKeepTix :: Flag Bool,
testNumJobs :: Flag (Maybe Int),
--TODO: eliminate the test list and pass it directly as positional args to
--the testHook
testList :: Flag [String],
......@@ -1373,7 +1360,6 @@ defaultTestFlags = TestFlags {
testMachineLog = toFlag $ toPathTemplate $ "$pkgid.log",
testShowDetails = toFlag Failures,
testKeepTix = toFlag False,
testNumJobs = mempty,
testList = Flag [],
testOptions = []
}
......@@ -1418,12 +1404,6 @@ testCommand = makeCommand name shortDesc longDesc defaultTestFlags options
"keep .tix files for HPC between test runs"
testKeepTix (\v flags -> flags { testKeepTix = v})
trueArg
, option "j" ["jobs"]
"Run NUM jobs simultaneously (or '$ncpus' if no NUM is given)."
testNumJobs (\v flags -> flags { testNumJobs = v })
(optArg "NUM" (fmap Flag numJobsParser)
(Flag Nothing)
(map (Just . maybe "$ncpus" show) . flagToList))
, option [] ["test-options"]
("give extra options to test executables "
++ "(name templates can use $pkgid, $compiler, "
......@@ -1452,7 +1432,6 @@ instance Monoid TestFlags where
testMachineLog = mempty,
testShowDetails = mempty,
testKeepTix = mempty,
testNumJobs = mempty,
testList = mempty,
testOptions = mempty
}
......@@ -1463,7 +1442,6 @@ instance Monoid TestFlags where
testMachineLog = combine testMachineLog,
testShowDetails = combine testShowDetails,
testKeepTix = combine testKeepTix,
testNumJobs = combine testNumJobs,
testList = combine testList,
testOptions = combine testOptions
}
......@@ -1476,16 +1454,14 @@ instance Monoid TestFlags where
data BenchmarkFlags = BenchmarkFlags {
benchmarkDistPref :: Flag FilePath,
benchmarkVerbosity :: Flag Verbosity,
benchmarkOptions :: [PathTemplate],
benchmarkNumJobs :: Flag (Maybe Int)
benchmarkOptions :: [PathTemplate]
}
defaultBenchmarkFlags :: BenchmarkFlags
defaultBenchmarkFlags = BenchmarkFlags {
benchmarkDistPref = Flag defaultDistPref,
benchmarkVerbosity = Flag normal,
benchmarkOptions = [],
benchmarkNumJobs = mempty
benchmarkOptions = []
}
benchmarkCommand :: CommandUI BenchmarkFlags
......@@ -1516,12 +1492,6 @@ benchmarkCommand = makeCommand name shortDesc
benchmarkOptions (\v flags -> flags { benchmarkOptions = v })
(reqArg' "TEMPLATE" (\x -> [toPathTemplate x])
(map fromPathTemplate))
, option "j" ["jobs"]
"Run NUM jobs simultaneously (or '$ncpus' if no NUM is given)."
benchmarkNumJobs (\v flags -> flags { benchmarkNumJobs = v })
(optArg "NUM" (fmap Flag numJobsParser)
(Flag Nothing)
(map (Just . maybe "$ncpus" show) . flagToList))
]
emptyBenchmarkFlags :: BenchmarkFlags
......@@ -1531,14 +1501,12 @@ instance Monoid BenchmarkFlags where
mempty = BenchmarkFlags {
benchmarkDistPref = mempty,
benchmarkVerbosity = mempty,
benchmarkOptions = mempty,
benchmarkNumJobs = mempty
benchmarkOptions = mempty
}
mappend a b = BenchmarkFlags {
benchmarkDistPref = combine benchmarkDistPref,
benchmarkVerbosity = combine benchmarkVerbosity,
benchmarkOptions = combine benchmarkOptions,
benchmarkNumJobs = combine benchmarkNumJobs
benchmarkOptions = combine benchmarkOptions
}
where combine field = field a `mappend` field b
......@@ -1546,18 +1514,6 @@ instance Monoid BenchmarkFlags where
-- * Shared options utils
-- ------------------------------------------------------------
-- | Common parser for the @-j@ flag of @build@ and @install@.
numJobsParser :: ReadE (Maybe Int)
numJobsParser = ReadE $ \s ->
case s of
"$ncpus" -> Right Nothing
_ -> case reads s of
[(n, "")]
| n < 1 -> Left "The number of jobs should be 1 or more."
| n > 64 -> Left "You probably don't want that many jobs."
| otherwise -> Right (Just n)
_ -> Left "The jobs value should be a number or '$ncpus'"
programFlagsDescription :: ProgramConfiguration -> String
programFlagsDescription progConf =
"The flags --with-PROG and --PROG-option(s) can be used with"
......
......@@ -15,7 +15,8 @@ module Distribution.Client.Setup
, configureCommand, ConfigFlags(..), filterConfigureFlags
, configureExCommand, ConfigExFlags(..), defaultConfigExFlags
, configureExOptions
, buildCommand, BuildFlags(..)
, buildCommand, BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..)
, testCommand, benchmarkCommand
, installCommand, InstallFlags(..), installOptions, defaultInstallFlags
, listCommand, ListFlags(..)
, updateCommand
......@@ -56,8 +57,9 @@ import Distribution.Simple.Program
import Distribution.Simple.Command hiding (boolOpt)
import qualified Distribution.Simple.Setup as Cabal
import Distribution.Simple.Setup
( ConfigFlags(..), BuildFlags(..), SDistFlags(..), HaddockFlags(..)
, Flag(..), toFlag, fromFlag, flagToMaybe, flagToList, numJobsParser
( ConfigFlags(..), BuildFlags(..), TestFlags(..), BenchmarkFlags(..)
, SDistFlags(..), HaddockFlags(..)
, Flag(..), toFlag, fromFlag, flagToMaybe, flagToList
, optionVerbosity, boolOpt, trueArg, falseArg )
import Distribution.Simple.InstallDirs
( PathTemplate, toPathTemplate, fromPathTemplate )
......@@ -319,10 +321,94 @@ instance Monoid ConfigExFlags where
-- * Build flags
-- ------------------------------------------------------------
buildCommand :: CommandUI BuildFlags
buildCommand = (Cabal.buildCommand defaultProgramConfiguration) {
commandDefaultFlags = mempty
data SkipAddSourceDepsCheck =
SkipAddSourceDepsCheck | DontSkipAddSourceDepsCheck
deriving Eq
data BuildExFlags = BuildExFlags {
buildNumJobs :: Flag (Maybe Int),
buildOnly :: Flag SkipAddSourceDepsCheck
}
buildExOptions :: ShowOrParseArgs -> [OptionField BuildExFlags]
buildExOptions _showOrParseArgs =
option "j" ["jobs"]
"Run NUM jobs simultaneously (or '$ncpus' if no NUM is given)"
buildNumJobs (\v flags -> flags { buildNumJobs = v })
(optArg "NUM" (fmap Flag numJobsParser)
(Flag Nothing)
(map (Just . maybe "$ncpus" show) . flagToList))
: option [] ["only"]
"Don't reinstall add-source dependencies (sandbox-only)"
buildOnly (\v flags -> flags { buildOnly = v })
(noArg (Flag SkipAddSourceDepsCheck))
: []
buildCommand :: CommandUI (BuildFlags, BuildExFlags)
buildCommand = parent {
commandDefaultFlags = (commandDefaultFlags parent, mempty),
commandOptions =
\showOrParseArgs -> liftOptions fst setFst
(commandOptions parent showOrParseArgs)
++
liftOptions snd setSnd (buildExOptions showOrParseArgs)
}
where
setFst a (_,b) = (a,b)
setSnd b (a,_) = (a,b)
parent = Cabal.buildCommand defaultProgramConfiguration
instance Monoid BuildExFlags where
mempty = BuildExFlags {
buildNumJobs = mempty,
buildOnly = mempty
}
mappend a b = BuildExFlags {
buildNumJobs = combine buildNumJobs,
buildOnly = combine buildOnly
}
where combine field = field a `mappend` field b
-- ------------------------------------------------------------
-- * Test command
-- ------------------------------------------------------------
testCommand :: CommandUI (TestFlags, BuildExFlags)
testCommand = parent {
commandDefaultFlags = (commandDefaultFlags parent, mempty),
commandOptions =
\showOrParseArgs -> liftOptions fst setFst
(commandOptions parent showOrParseArgs)
++
liftOptions snd setSnd (buildExOptions showOrParseArgs)
}
where
setFst a (_,b) = (a,b)
setSnd b (a,_) = (a,b)
parent = Cabal.testCommand
-- ------------------------------------------------------------
-- * Bench command
-- ------------------------------------------------------------
benchmarkCommand :: CommandUI (BenchmarkFlags, BuildExFlags)
benchmarkCommand = parent {
commandDefaultFlags = (commandDefaultFlags parent, mempty),
commandOptions =
\showOrParseArgs -> liftOptions fst setFst
(commandOptions parent showOrParseArgs)
++
liftOptions snd setSnd (buildExOptions showOrParseArgs)
}
where
setFst a (_,b) = (a,b)
setSnd b (a,_) = (a,b)
parent = Cabal.benchmarkCommand
-- ------------------------------------------------------------
-- * Fetch command
......@@ -439,19 +525,27 @@ checkCommand = CommandUI {
commandOptions = \_ -> []
}
runCommand :: CommandUI BuildFlags
runCommand :: CommandUI (BuildFlags, BuildExFlags)
runCommand = CommandUI {
commandName = "run",
commandSynopsis = "Runs the compiled executable.",
commandDescription = Nothing,
commandUsage =
(\pname -> "Usage: " ++ pname
++ " run [FLAGS] [EXECUTABLE] [-- EXECUTABLE_FLAGS]\n\n"
++ "Flags for run:"),
\pname -> "Usage: " ++ pname
++ " run [FLAGS] [EXECUTABLE] [-- EXECUTABLE_FLAGS]\n\n"
++ "Flags for run:",
commandDefaultFlags = mempty,
commandOptions = Cabal.buildOptions progConf
commandOptions =
\showOrParseArgs -> liftOptions fst setFst
(Cabal.buildOptions progConf showOrParseArgs)
++
liftOptions snd setSnd
(buildExOptions showOrParseArgs)
}
where
setFst a (_,b) = (a,b)
setSnd b (a,_) = (a,b)
progConf = defaultProgramConfiguration
-- ------------------------------------------------------------
......@@ -1323,6 +1417,21 @@ instance Monoid SandboxFlags where
}
where combine field = field a `mappend` field b
-- ------------------------------------------------------------
-- * Shared options utils
-- ------------------------------------------------------------
-- | Common parser for the @-j@ flag of @build@ and @install@.
numJobsParser :: ReadE (Maybe Int)
numJobsParser = ReadE $ \s ->
case s of
"$ncpus" -> Right Nothing
_ -> case reads s of
[(n, "")]
| n < 1 -> Left "The number of jobs should be 1 or more."
| n > 64 -> Left "You probably don't want that many jobs."
| otherwise -> Right (Just n)
_ -> Left "The jobs value should be a number or '$ncpus'"
-- ------------------------------------------------------------
-- * GetOpt Utils
......
......@@ -17,7 +17,8 @@ import Distribution.Client.Setup
( GlobalFlags(..), globalCommand, globalRepos
, ConfigFlags(..)
, ConfigExFlags(..), defaultConfigExFlags, configureExCommand
, BuildFlags(..), buildCommand
, BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..)
, buildCommand, testCommand, benchmarkCommand
, InstallFlags(..), defaultInstallFlags
, installCommand, upgradeCommand
, FetchFlags(..), fetchCommand
......@@ -41,8 +42,7 @@ import Distribution.Simple.Setup
, CopyFlags(..), copyCommand
, RegisterFlags(..), registerCommand
, CleanFlags(..), cleanCommand
, TestFlags(..), testCommand
, BenchmarkFlags(..), benchmarkCommand
, TestFlags(..), BenchmarkFlags(..)
, Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe, toFlag
, configAbsolutePaths
)
......@@ -102,6 +102,8 @@ import Distribution.Simple.Configure
( checkPersistBuildConfigOutdated, configCompilerAux
, ConfigStateFileErrorType(..), tryGetPersistBuildConfig )
import qualified Distribution.Simple.LocalBuildInfo as LBI
import Distribution.Simple.Program (defaultProgramConfiguration)
import qualified Distribution.Simple.Setup as Cabal
import Distribution.Simple.Utils
( cabalVersion, die, notice, info, topHandler )
import Distribution.Text
......@@ -250,16 +252,19 @@ configureAction (configFlags, configExFlags) extraArgs globalFlags = do
(globalRepos globalFlags')
comp platform conf configFlags'' configExFlags' extraArgs
buildAction :: BuildFlags -> [String] -> GlobalFlags -> IO ()
buildAction buildFlags extraArgs globalFlags = do
let distPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)
(buildDistPref buildFlags)
verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags)
buildAction :: (BuildFlags, BuildExFlags) -> [String] -> GlobalFlags -> IO ()
buildAction (buildFlags, buildExFlags) extraArgs globalFlags = do
let distPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)
(buildDistPref buildFlags)
verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags)
noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck
(buildOnly buildExFlags)
-- Calls 'configureAction' to do the real work, so nothing special has to be
-- done to support sandboxes.
useSandbox <- reconfigure verbosity distPref
mempty [] globalFlags (buildNumJobs buildFlags) (const Nothing)
mempty [] globalFlags noAddSource (buildNumJobs buildExFlags)
(const Nothing)
maybeWithSandboxDirOnSearchPath useSandbox $
build verbosity distPref buildFlags extraArgs
......@@ -271,10 +276,11 @@ buildAction buildFlags extraArgs globalFlags = do
build :: Verbosity -> FilePath -> BuildFlags -> [String] -> IO ()
build verbosity distPref buildFlags extraArgs =
setupWrapper verbosity setupOptions Nothing
buildCommand (const buildFlags') extraArgs
(Cabal.buildCommand progConf) (const buildFlags') extraArgs
where
progConf = defaultProgramConfiguration
setupOptions = defaultSetupScriptOptions { useDistPref = distPref }
buildFlags' = buildFlags
buildFlags' = buildFlags
{ buildVerbosity = toFlag verbosity
, buildDistPref = toFlag distPref
}
......@@ -322,6 +328,9 @@ reconfigure :: Verbosity -- ^ Verbosity setting
-- set them here.
-> [String] -- ^ Extra arguments
-> GlobalFlags -- ^ Global flags
-> SkipAddSourceDepsCheck
-- ^ Should we skip the timestamp check for modified
-- add-source dependencies?
-> Flag (Maybe Int)
-- ^ -j flag for reinstalling add-source deps.
-> (ConfigFlags -> Maybe String)
......@@ -334,8 +343,8 @@ reconfigure :: Verbosity -- ^ Verbosity setting
-- automatically; this function need not check
-- for it.
-> IO UseSandbox
reconfigure verbosity distPref addConfigFlags
extraArgs globalFlags numJobsFlag checkFlags = do
reconfigure verbosity distPref addConfigFlags extraArgs globalFlags
skipAddSourceDepsCheck numJobsFlag checkFlags = do
eLbi <- tryGetPersistBuildConfig distPref
case eLbi of
......@@ -372,8 +381,14 @@ reconfigure verbosity distPref addConfigFlags
savedDistPref = fromFlagOrDefault
(useDistPref defaultSetupScriptOptions)
(configDistPref configFlags)
(useSandbox, depsReinstalled) <- maybeReinstallAddSourceDeps verbosity
numJobsFlag flags globalFlags
(useSandbox, depsReinstalled) <-
case skipAddSourceDepsCheck of
DontSkipAddSourceDepsCheck ->
maybeReinstallAddSourceDeps verbosity numJobsFlag flags globalFlags
SkipAddSourceDepsCheck -> do
(useSandbox, _) <- loadConfigOrSandboxConfig verbosity
(globalConfigFile globalFlags) mempty
return (useSandbox, NoDepsReinstalled)
-- Determine what message, if any, to display to the user if
-- reconfiguration is required.
......@@ -501,52 +516,58 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags)
installFlags' haddockFlags
targets
testAction :: TestFlags -> [String] -> GlobalFlags -> IO ()
testAction testFlags extraArgs globalFlags = do
let verbosity = fromFlagOrDefault normal (testVerbosity testFlags)
distPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)
(testDistPref testFlags)
setupOptions = defaultSetupScriptOptions { useDistPref = distPref }
testAction :: (TestFlags, BuildExFlags) -> [String] -> GlobalFlags -> IO ()
testAction (testFlags, buildExFlags) extraArgs globalFlags = do
let verbosity = fromFlagOrDefault normal (testVerbosity testFlags)
distPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)
(testDistPref testFlags)
setupOptions = defaultSetupScriptOptions { useDistPref = distPref }
addConfigFlags = mempty { configTests = toFlag True }
checkFlags flags
| fromFlagOrDefault False (configTests flags) = Nothing
| otherwise = Just "Re-configuring with test suites enabled."
| otherwise = Just "Re-configuring with test suites enabled."
noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck
(buildOnly buildExFlags)
-- reconfigure also checks if we're in a sandbox and reinstalls add-source
-- deps if needed.
useSandbox <- reconfigure verbosity distPref addConfigFlags []
globalFlags (testNumJobs testFlags) checkFlags
globalFlags noAddSource (buildNumJobs buildExFlags) checkFlags
maybeWithSandboxDirOnSearchPath useSandbox $
build verbosity distPref mempty []
maybeWithSandboxDirOnSearchPath useSandbox $
setupWrapper verbosity setupOptions Nothing
testCommand (const testFlags) extraArgs
benchmarkAction :: BenchmarkFlags -> [String] -> GlobalFlags -> IO ()
benchmarkAction benchmarkFlags extraArgs globalFlags = do
let verbosity = fromFlagOrDefault normal (benchmarkVerbosity benchmarkFlags)
distPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)
(benchmarkDistPref benchmarkFlags)
setupOptions = defaultSetupScriptOptions { useDistPref = distPref }
Cabal.testCommand (const testFlags) extraArgs
benchmarkAction :: (BenchmarkFlags, BuildExFlags) -> [String] -> GlobalFlags
-> IO ()
benchmarkAction (benchmarkFlags, buildExFlags) extraArgs globalFlags = do
let verbosity = fromFlagOrDefault normal
(benchmarkVerbosity benchmarkFlags)
distPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)
(benchmarkDistPref benchmarkFlags)
setupOptions = defaultSetupScriptOptions { useDistPref = distPref }
addConfigFlags = mempty { configBenchmarks = toFlag True }
checkFlags flags
| fromFlagOrDefault False (configBenchmarks flags) = Nothing
| otherwise = Just "Re-configuring with benchmarks enabled."
noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck
(buildOnly buildExFlags)
-- reconfigure also checks if we're in a sandbox and reinstalls add-source
-- deps if needed.
useSandbox <- reconfigure verbosity distPref addConfigFlags []
globalFlags (benchmarkNumJobs benchmarkFlags) checkFlags
globalFlags noAddSource (buildNumJobs buildExFlags)
checkFlags
maybeWithSandboxDirOnSearchPath useSandbox $
build verbosity distPref mempty []
maybeWithSandboxDirOnSearchPath useSandbox $
setupWrapper verbosity setupOptions Nothing
benchmarkCommand (const benchmarkFlags) extraArgs
Cabal.benchmarkCommand (const benchmarkFlags) extraArgs
listAction :: ListFlags -> [String] -> GlobalFlags -> IO ()
listAction listFlags extraArgs globalFlags = do
......@@ -680,16 +701,19 @@ reportAction reportFlags extraArgs globalFlags = do
(flagToMaybe $ reportUsername reportFlags')
(flagToMaybe $ reportPassword reportFlags')
runAction :: BuildFlags -> [String] -> GlobalFlags -> IO ()
runAction buildFlags extraArgs globalFlags = do
let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags)
distPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)
(buildDistPref buildFlags)
runAction :: (BuildFlags, BuildExFlags) -> [String] -> GlobalFlags -> IO ()
runAction (buildFlags, buildExFlags) extraArgs globalFlags = do
let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags)
distPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)
(buildDistPref buildFlags)
noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck
(buildOnly buildExFlags)
-- reconfigure also checks if we're in a sandbox and reinstalls add-source
-- deps if needed.
useSandbox <- reconfigure verbosity distPref mempty []
globalFlags (buildNumJobs buildFlags) (const Nothing)
globalFlags noAddSource (buildNumJobs buildExFlags)
(const Nothing)
maybeWithSandboxDirOnSearchPath useSandbox $
build verbosity distPref mempty []
......
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