Commit 04f10838 authored by Duncan Coutts's avatar Duncan Coutts

Add ConfigExFlags into the configure, install and upgrade commands

Not yet passed all the way through.
parent aa52ffd8
......@@ -285,13 +285,13 @@ updateCommand = CommandUI {
commandOptions = \_ -> [optionVerbosity id const]
}
upgradeCommand :: CommandUI (ConfigFlags, InstallFlags)
upgradeCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags)
upgradeCommand = configureCommand {
commandName = "upgrade",
commandSynopsis = "Upgrades installed packages to the latest available version",
commandDescription = Nothing,
commandUsage = usagePackages "upgrade",
commandDefaultFlags = (mempty, defaultInstallFlags),
commandDefaultFlags = (mempty, mempty, mempty),
commandOptions = commandOptions installCommand
}
......@@ -480,8 +480,8 @@ defaultInstallFlags = InstallFlags {
installPreferences = mempty
}
installCommand :: CommandUI (ConfigFlags, InstallFlags)
installCommand = configureCommand {
installCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags)
installCommand = CommandUI {
commandName = "install",
commandSynopsis = "Installs a list of packages.",
commandUsage = usagePackages "install",
......@@ -499,11 +499,16 @@ installCommand = configureCommand {
++ " Specific version of a package\n"
++ " " ++ pname ++ " install 'foo < 2' "
++ " Constrained package version\n",
commandDefaultFlags = (mempty, mempty),
commandDefaultFlags = (mempty, mempty, mempty),
commandOptions = \showOrParseArgs ->
liftOptionsFst (commandOptions configureCommand showOrParseArgs) ++
liftOptionsSnd (installOptions showOrParseArgs)
liftOptions get1 set1 (configureOptions showOrParseArgs)
++ liftOptions get2 set2 (configureExOptions showOrParseArgs)
++ liftOptions get3 set3 (installOptions showOrParseArgs)
}
where
get1 (a,_,_) = a; set1 a (_,b,c) = (a,b,c)
get2 (_,b,_) = b; set2 b (a,_,c) = (a,b,c)
get3 (_,_,c) = c; set3 c (a,b,_) = (a,b,c)
installOptions :: ShowOrParseArgs -> [OptionField InstallFlags]
installOptions showOrParseArgs =
......@@ -670,12 +675,6 @@ reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description ->
(b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b
reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList
liftOptionsFst :: [OptionField a] -> [OptionField (a,b)]
liftOptionsFst = map (liftOption fst (\a (_,b) -> (a,b)))
liftOptionsSnd :: [OptionField b] -> [OptionField (a,b)]
liftOptionsSnd = map (liftOption snd (\b (a,_) -> (a,b)))
liftOptions :: (b -> a) -> (a -> b -> b)
-> [OptionField a] -> [OptionField b]
liftOptions get set = map (liftOption get set)
......
......@@ -15,7 +15,8 @@ module Main where
import Distribution.Client.Setup
( GlobalFlags(..), globalCommand, globalRepos
, ConfigFlags(..), configureCommand
, ConfigFlags(..)
, ConfigExFlags(..), configureExCommand
, InstallFlags(..), installCommand, upgradeCommand
, fetchCommand, checkCommand
, updateCommand
......@@ -116,7 +117,7 @@ mainWorker args =
++ " of the Cabal library "
commands =
[configureCommand `commandAddAction` configureAction
[configureExCommand `commandAddAction` configureAction
,installCommand `commandAddAction` installAction
,listCommand `commandAddAction` listAction
,infoCommand `commandAddAction` infoAction
......@@ -161,8 +162,9 @@ wrapperAction command verbosityFlag distPrefFlag =
setupWrapper verbosity setupScriptOptions Nothing
command (const flags) extraArgs
configureAction :: ConfigFlags -> [String] -> GlobalFlags -> IO ()
configureAction configFlags extraArgs globalFlags = do
configureAction :: (ConfigFlags, ConfigExFlags)
-> [String] -> GlobalFlags -> IO ()
configureAction (configFlags, configExFlags) extraArgs globalFlags = do
let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
config <- loadConfig verbosity (globalConfigFile globalFlags)
(configUserInstall configFlags)
......@@ -174,14 +176,16 @@ configureAction configFlags extraArgs globalFlags = do
(configPackageDB' configFlags') (globalRepos globalFlags')
comp conf configFlags' installFlags' extraArgs
installAction :: (ConfigFlags, InstallFlags) -> [String] -> GlobalFlags -> IO ()
installAction (configFlags, installFlags) _ _globalFlags
installAction :: (ConfigFlags, ConfigExFlags, InstallFlags)
-> [String] -> GlobalFlags -> IO ()
installAction (configFlags, _, installFlags) _ _globalFlags
| fromFlagOrDefault False (installOnly installFlags)
= let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
in setupWrapper verbosity defaultSetupScriptOptions Nothing
installCommand (const mempty) []
installAction (configFlags, installFlags) extraArgs globalFlags = do
installAction (configFlags, configExFlags, installFlags)
extraArgs globalFlags = do
pkgs <- either die return (parsePackageArgs extraArgs)
let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
config <- loadConfig verbosity (globalConfigFile globalFlags)
......@@ -236,8 +240,10 @@ updateAction verbosityFlag extraArgs globalFlags = do
let globalFlags' = savedGlobalFlags config `mappend` globalFlags
update verbosity (globalRepos globalFlags')
upgradeAction :: (ConfigFlags, InstallFlags) -> [String] -> GlobalFlags -> IO ()
upgradeAction (configFlags, installFlags) extraArgs globalFlags = do
upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags)
-> [String] -> GlobalFlags -> IO ()
upgradeAction (configFlags, configExFlags, installFlags)
extraArgs globalFlags = do
pkgs <- either die return (parsePackageArgs extraArgs)
let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
config <- loadConfig verbosity (globalConfigFile globalFlags)
......
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