Commit aa52ffd8 authored by Duncan Coutts's avatar Duncan Coutts

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.
parent adc23efe
......@@ -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 })
......
......@@ -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"
......
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