From d89fedd61a82f85461498189e09b58ccf30ee578 Mon Sep 17 00:00:00 2001 From: Andres Loeh <andres@well-typed.com> Date: Mon, 16 Apr 2012 12:30:24 +0000 Subject: [PATCH] handling the solver options properly in config file --- cabal-install/Distribution/Client/Config.hs | 4 +- cabal-install/Distribution/Client/Setup.hs | 43 +++++++++++++-------- 2 files changed, 28 insertions(+), 19 deletions(-) diff --git a/cabal-install/Distribution/Client/Config.hs b/cabal-install/Distribution/Client/Config.hs index 39b360a16b..70c4ce7e71 100644 --- a/cabal-install/Distribution/Client/Config.hs +++ b/cabal-install/Distribution/Client/Config.hs @@ -346,7 +346,7 @@ configFieldDescriptions = ++ toSavedConfig liftConfigFlag (configureOptions ParseArgs) - (["builddir", "configure-option"] ++ map fieldName installDirsFields) + (["builddir", "configure-option", "constraint"] ++ map fieldName installDirsFields) --FIXME: this is only here because viewAsFieldDescr gives us a parser -- that only recognises 'ghc' etc, the case-sensitive flag names, not @@ -387,7 +387,7 @@ configFieldDescriptions = ++ toSavedConfig liftInstallFlag (installOptions ParseArgs) - ["dry-run", "reinstall", "only"] [] + ["dry-run", "only"] [] ++ toSavedConfig liftUploadFlag (commandOptions uploadCommand ParseArgs) diff --git a/cabal-install/Distribution/Client/Setup.hs b/cabal-install/Distribution/Client/Setup.hs index 56362347a4..441470bb12 100644 --- a/cabal-install/Distribution/Client/Setup.hs +++ b/cabal-install/Distribution/Client/Setup.hs @@ -53,7 +53,7 @@ import qualified Distribution.Simple.Setup as Cabal import Distribution.Simple.Setup ( ConfigFlags(..), SDistFlags(..), HaddockFlags(..) ) import Distribution.Simple.Setup - ( Flag(..), toFlag, fromFlag, flagToList + ( Flag(..), toFlag, fromFlag, flagToMaybe, flagToList , optionVerbosity, boolOpt, trueArg, falseArg ) import Distribution.Simple.InstallDirs ( PathTemplate, toPathTemplate, fromPathTemplate ) @@ -334,7 +334,7 @@ fetchCommand = CommandUI { commandDescription = Nothing, commandUsage = usagePackages "fetch", commandDefaultFlags = defaultFetchFlags, - commandOptions = \_ -> [ + commandOptions = \ showOrParseArgs -> [ optionVerbosity fetchVerbosity (\v flags -> flags { fetchVerbosity = v }) -- , option "o" ["output"] @@ -360,7 +360,8 @@ fetchCommand = CommandUI { ] ++ optionSolver fetchSolver (\v flags -> flags { fetchSolver = v }) : - optionSolverFlags fetchMaxBackjumps (\v flags -> flags { fetchMaxBackjumps = v }) + optionSolverFlags showOrParseArgs + fetchMaxBackjumps (\v flags -> flags { fetchMaxBackjumps = v }) fetchReorderGoals (\v flags -> flags { fetchReorderGoals = v }) fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v }) fetchShadowPkgs (\v flags -> flags { fetchShadowPkgs = v }) @@ -721,7 +722,8 @@ installOptions showOrParseArgs = trueArg ] ++ - optionSolverFlags installMaxBackjumps (\v flags -> flags { installMaxBackjumps = v }) + optionSolverFlags showOrParseArgs + installMaxBackjumps (\v flags -> flags { installMaxBackjumps = v }) installReorderGoals (\v flags -> flags { installReorderGoals = v }) installIndependentGoals (\v flags -> flags { installIndependentGoals = v }) installShadowPkgs (\v flags -> flags { installShadowPkgs = v }) ++ @@ -729,28 +731,27 @@ installOptions showOrParseArgs = [ option [] ["reinstall"] "Install even if it means installing the same version again." installReinstall (\v flags -> flags { installReinstall = v }) - trueArg + (yesNoOpt showOrParseArgs) , option [] ["avoid-reinstalls"] "Do not select versions that would destructively overwrite installed packages." installAvoidReinstalls (\v flags -> flags { installAvoidReinstalls = v }) - trueArg + (yesNoOpt showOrParseArgs) , option [] ["force-reinstalls"] "Reinstall packages even if they will most likely break other installed packages." installOverrideReinstall (\v flags -> flags { installOverrideReinstall = v }) - trueArg + (yesNoOpt showOrParseArgs) , option [] ["upgrade-dependencies"] "Pick the latest version for all dependencies, rather than trying to pick an installed version." installUpgradeDeps (\v flags -> flags { installUpgradeDeps = v }) - trueArg + (yesNoOpt showOrParseArgs) , option [] ["only-dependencies"] "Install only the dependencies necessary to build the given packages" installOnlyDeps (\v flags -> flags { installOnlyDeps = v }) - trueArg - + (yesNoOpt showOrParseArgs) , option [] ["root-cmd"] "Command used to gain root privileges, when installing with --global." @@ -784,7 +785,7 @@ installOptions showOrParseArgs = , option [] ["one-shot"] "Do not record the packages in the world file." installOneShot (\v flags -> flags { installOneShot = v }) - trueArg + (yesNoOpt showOrParseArgs) ] ++ case showOrParseArgs of -- TODO: remove when "cabal install" avoids ParseArgs -> option [] ["only"] @@ -1110,14 +1111,18 @@ instance Monoid SDistExFlags where -- * GetOpt Utils -- ------------------------------------------------------------ -reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description -> - (b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b +reqArgFlag :: ArgPlaceHolder -> + MkOptDescr (b -> Flag String) (Flag String -> b -> b) b reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList liftOptions :: (b -> a) -> (a -> b -> b) -> [OptionField a] -> [OptionField b] liftOptions get set = map (liftOption get set) +yesNoOpt :: ShowOrParseArgs -> MkOptDescr (b -> Flag Bool) (Flag Bool -> (b -> b)) b +yesNoOpt ShowArgs sf lf = trueArg sf lf +yesNoOpt _ sf lf = boolOpt' flagToMaybe Flag (sf, lf) ([], map ("no-" ++) lf) sf lf + optionSolver :: (flags -> Flag PreSolver) -> (Flag PreSolver -> flags -> flags) -> OptionField flags @@ -1129,12 +1134,13 @@ optionSolver get set = (toFlag `fmap` parse)) (flagToList . fmap display)) -optionSolverFlags :: (flags -> Flag Int ) -> (Flag Int -> flags -> flags) +optionSolverFlags :: ShowOrParseArgs + -> (flags -> Flag Int ) -> (Flag Int -> flags -> flags) -> (flags -> Flag Bool ) -> (Flag Bool -> flags -> flags) -> (flags -> Flag Bool ) -> (Flag Bool -> flags -> flags) -> (flags -> Flag Bool ) -> (Flag Bool -> flags -> flags) -> [OptionField flags] -optionSolverFlags getmbj setmbj getrg setrg getig setig getsip setsip = +optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg _getig _setig getsip setsip = [ option [] ["max-backjumps"] ("Maximum number of backjumps allowed while solving (default: " ++ show defaultMaxBackjumps ++ "). Use a negative number to enable unlimited backtracking. Use 0 to disable backtracking completely.") getmbj setmbj @@ -1144,11 +1150,14 @@ optionSolverFlags getmbj setmbj getrg setrg getig setig getsip setsip = , option [] ["reorder-goals"] "Try to reorder goals according to certain heuristics. Slows things down on average, but may make backtracking faster for some packages." getrg setrg - trueArg + (yesNoOpt showOrParseArgs) + -- TODO: Disabled for now because it does not work as advertised (yet). +{- , option [] ["independent-goals"] "Treat several goals on the command line as independent. If several goals depend on the same package, different versions can be chosen." getig setig - trueArg + (yesNoOpt showOrParseArgs) +-} , option [] ["shadow-installed-packages"] "If multiple package instances of the same version are installed, treat all but one as shadowed." getsip setsip -- GitLab