[commit: Cabal] master: Add ConfigExFlags into the configure, install and upgrade commands (8e3d326)

[Ian Lynagh]

Repository : ssh://darcs.haskell.org//srv/darcs/packages/Cabal

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/8e3d326a86b3eabde15b54db7e71670d1c8e35ae

>---------------------------------------------------------------

commit 8e3d326a86b3eabde15b54db7e71670d1c8e35ae
Author: Duncan Coutts <duncan at haskell.org>
Date:   Mon Jan 26 01:09:18 2009 +0000

    Add ConfigExFlags into the configure, install and upgrade commands
    Not yet passed all the way through.

>---------------------------------------------------------------

 cabal-install/Distribution/Client/Setup.hs |   25 ++++++++++++-------------
 cabal-install/Main.hs                      |   24 +++++++++++++++---------
 2 files changed, 27 insertions(+), 22 deletions(-)

diff --git a/cabal-install/Distribution/Client/Setup.hs b/cabal-install/Distribution/Client/Setup.hs
index d64aa92..87be689 100644
--- a/cabal-install/Distribution/Client/Setup.hs
+++ b/cabal-install/Distribution/Client/Setup.hs
@@ -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)
diff --git a/cabal-install/Main.hs b/cabal-install/Main.hs
index 555be3d..b839e47 100644
--- a/cabal-install/Main.hs
+++ b/cabal-install/Main.hs
@@ -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)