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

On branch  : master

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

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

commit 8f5f2c5248ea12aed97bab67767ae2608d62deca
Author: Duncan Coutts <[email protected]>
Date:   Mon Jan 26 01:01:32 2009 +0000

    Add ConfigExFlags and related command
    This is for configure flags that we use in the configure command in the
    cabal command line tool that are not present in runghc Setup configure
    command line interface. These are flags that we are moving from the
    install command, so that we can also use them for the configure command.
    Initially it's just the flags for specifying package version preferences
    and  the cabal library version. We'll add constraints later.

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

 cabal-install/Distribution/Client/Config.hs |   13 +++++
 cabal-install/Distribution/Client/Setup.hs  |   64 +++++++++++++++++++++++++++
 2 files changed, 77 insertions(+), 0 deletions(-)

diff --git a/cabal-install/Distribution/Client/Config.hs 
b/cabal-install/Distribution/Client/Config.hs
index 101474d..d51aca3 100644
--- a/cabal-install/Distribution/Client/Config.hs
+++ b/cabal-install/Distribution/Client/Config.hs
@@ -29,6 +29,7 @@ import Distribution.Client.Types
          ( RemoteRepo(..), Username(..), Password(..) )
 import Distribution.Client.Setup
          ( GlobalFlags(..), globalCommand
+         , ConfigExFlags(..), configureExOptions, defaultConfigExFlags
          , InstallFlags(..), installOptions, defaultInstallFlags
          , UploadFlags(..), uploadCommand
          , showRepo, parseRepo )
@@ -96,6 +97,7 @@ data SavedConfig = SavedConfig {
     savedGlobalFlags       :: GlobalFlags,
     savedInstallFlags      :: InstallFlags,
     savedConfigureFlags    :: ConfigFlags,
+    savedConfigureExFlags  :: ConfigExFlags,
     savedUserInstallDirs   :: InstallDirs (Flag PathTemplate),
     savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate),
     savedUploadFlags       :: UploadFlags
@@ -106,6 +108,7 @@ instance Monoid SavedConfig where
     savedGlobalFlags       = mempty,
     savedInstallFlags      = mempty,
     savedConfigureFlags    = mempty,
+    savedConfigureExFlags  = mempty,
     savedUserInstallDirs   = mempty,
     savedGlobalInstallDirs = mempty,
     savedUploadFlags       = mempty
@@ -114,6 +117,7 @@ instance Monoid SavedConfig where
     savedGlobalFlags       = combine savedGlobalFlags,
     savedInstallFlags      = combine savedInstallFlags,
     savedConfigureFlags    = combine savedConfigureFlags,
+    savedConfigureExFlags  = combine savedConfigureExFlags,
     savedUserInstallDirs   = combine savedUserInstallDirs,
     savedGlobalInstallDirs = combine savedGlobalInstallDirs,
     savedUploadFlags       = combine savedUploadFlags
@@ -273,6 +277,7 @@ commentSavedConfig = do
   return SavedConfig {
     savedGlobalFlags       = commandDefaultFlags globalCommand,
     savedInstallFlags      = defaultInstallFlags,
+    savedConfigureExFlags  = defaultConfigExFlags,
     savedConfigureFlags    = (defaultConfigFlags defaultProgramConfiguration) {
       configUserInstall    = toFlag defaultUserInstall
     },
@@ -298,6 +303,10 @@ configFieldDescriptions =
        (configureOptions ParseArgs)
        (["scratchdir", "configure-option"] ++ map fieldName installDirsFields)
 
+  ++ toSavedConfig liftConfigExFlag
+       (configureExOptions ParseArgs)
+       []
+
       --FIXME: this is only here because viewAsFieldDescr gives us a parser
       -- that only recognises 'ghc' etc, the case-sensitive flag names, not
       -- what the normal case-insensitive parser gives us.
@@ -365,6 +374,10 @@ liftConfigFlag :: FieldDescr ConfigFlags -> FieldDescr 
SavedConfig
 liftConfigFlag = liftField
   savedConfigureFlags (\flags conf -> conf { savedConfigureFlags = flags })
 
+liftConfigExFlag :: FieldDescr ConfigExFlags -> FieldDescr SavedConfig
+liftConfigExFlag = liftField
+  savedConfigureExFlags (\flags conf -> conf { savedConfigureExFlags = flags })
+
 liftInstallFlag :: FieldDescr InstallFlags -> FieldDescr SavedConfig
 liftInstallFlag = liftField
   savedInstallFlags (\flags conf -> conf { savedInstallFlags = flags })
diff --git a/cabal-install/Distribution/Client/Setup.hs 
b/cabal-install/Distribution/Client/Setup.hs
index 63c9085..d64aa92 100644
--- a/cabal-install/Distribution/Client/Setup.hs
+++ b/cabal-install/Distribution/Client/Setup.hs
@@ -13,6 +13,8 @@
 module Distribution.Client.Setup
     ( globalCommand, GlobalFlags(..), globalRepos
     , configureCommand, ConfigFlags(..), filterConfigureFlags, configPackageDB'
+    , configureExCommand, ConfigExFlags(..), defaultConfigExFlags
+                        , configureExOptions
     , installCommand, InstallFlags(..), installOptions, defaultInstallFlags
     , listCommand, ListFlags(..)
     , updateCommand
@@ -186,6 +188,9 @@ configureCommand = (Cabal.configureCommand 
defaultProgramConfiguration) {
     commandDefaultFlags = mempty
   }
 
+configureOptions ::  ShowOrParseArgs -> [OptionField ConfigFlags]
+configureOptions = commandOptions configureCommand
+
 configPackageDB' :: ConfigFlags -> PackageDB
 configPackageDB' config =
   fromFlagOrDefault defaultDB (configPackageDB config)
@@ -201,6 +206,61 @@ filterConfigureFlags flags cabalLibVersion
     -- older Cabal does not grok the constraints flag:
   | otherwise = flags { configConstraints = [] }
 
+
+-- ------------------------------------------------------------
+-- * Config extra flags
+-- ------------------------------------------------------------
+
+-- | cabal configure takes some extra flags beyond runghc Setup configure
+--
+data ConfigExFlags = ConfigExFlags {
+    configCabalVersion :: Flag Version,
+    configPreferences  :: [Dependency]
+  }
+
+defaultConfigExFlags :: ConfigExFlags
+defaultConfigExFlags = mempty
+
+configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags)
+configureExCommand = configureCommand {
+    commandDefaultFlags = (mempty, defaultConfigExFlags),
+    commandOptions      = \showOrParseArgs ->
+         liftOptions fst setFst (configureOptions   showOrParseArgs)
+      ++ liftOptions snd setSnd (configureExOptions showOrParseArgs)
+  }
+  where
+    setFst a (_,b) = (a,b)
+    setSnd b (a,_) = (a,b)
+
+configureExOptions ::  ShowOrParseArgs -> [OptionField ConfigExFlags]
+configureExOptions _showOrParseArgs =
+  [ option [] ["cabal-lib-version"]
+      ("Select which version of the Cabal lib to use to build packages "
+      ++ "(useful for testing).")
+      configCabalVersion (\v flags -> flags { configCabalVersion = v })
+      (reqArg "VERSION" (readP_to_E ("Cannot parse cabal lib version: "++)
+                                    (fmap toFlag parse))
+                        (map display . flagToList))
+
+  , option [] ["preference"]
+      "Specify preferences (soft constraints) on the version of a package"
+      configPreferences (\v flags -> flags { configPreferences = v })
+      (reqArg "DEPENDENCY"
+        (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parse))
+                                        (map (\x -> display x)))
+  ]
+
+instance Monoid ConfigExFlags where
+  mempty = ConfigExFlags {
+    configCabalVersion = mempty,
+    configPreferences  = mempty
+  }
+  mappend a b = ConfigExFlags {
+    configCabalVersion = combine configCabalVersion,
+    configPreferences  = combine configPreferences
+  }
+    where combine field = field a `mappend` field b
+
 -- ------------------------------------------------------------
 -- * Other commands
 -- ------------------------------------------------------------
@@ -616,6 +676,10 @@ 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)
+
 usagePackages :: String -> String -> String
 usagePackages name pname =
      "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n"



_______________________________________________
Cvs-libraries mailing list
[email protected]
http://www.haskell.org/mailman/listinfo/cvs-libraries

Reply via email to