diff --git a/cabal-install/src/Distribution/Client/Config.hs b/cabal-install/src/Distribution/Client/Config.hs index 685d944fa6a..13f94146c08 100644 --- a/cabal-install/src/Distribution/Client/Config.hs +++ b/cabal-install/src/Distribution/Client/Config.hs @@ -543,6 +543,7 @@ instance Semigroup SavedConfig where configExConstraints = lastNonEmpty configExConstraints , -- TODO: NubListify configPreferences = lastNonEmpty configPreferences + , configSolver = combine configSolver , configAllowNewer = combineMonoid savedConfigureExFlags configAllowNewer , configAllowOlder = diff --git a/cabal-install/src/Distribution/Client/Dependency/Types.hs b/cabal-install/src/Distribution/Client/Dependency/Types.hs index 75da4a5a992..78f97662008 100644 --- a/cabal-install/src/Distribution/Client/Dependency/Types.hs +++ b/cabal-install/src/Distribution/Client/Dependency/Types.hs @@ -1,21 +1,42 @@ {-# LANGUAGE DeriveGeneric #-} module Distribution.Client.Dependency.Types - ( Solver (..) + ( PreSolver (..) + , Solver (..) , PackagesPreferenceDefault (..) ) where import Distribution.Client.Compat.Prelude import Prelude () +import Text.PrettyPrint (text) + +import qualified Distribution.Compat.CharParsing as P + +-- | All the solvers that can be selected. +data PreSolver = AlwaysModular + deriving (Eq, Ord, Show, Bounded, Enum, Generic) + -- | All the solvers that can be used. data Solver = Modular deriving (Eq, Ord, Show, Bounded, Enum, Generic) +instance Binary PreSolver instance Binary Solver +instance Structured PreSolver instance Structured Solver +instance Pretty PreSolver where + pretty AlwaysModular = text "modular" + +instance Parsec PreSolver where + parsec = do + name <- P.munch1 isAlpha + case map toLower name of + "modular" -> return AlwaysModular + _ -> P.unexpected $ "PreSolver: " ++ name + -- | Global policy for all packages to say if we prefer package versions that -- are already installed locally or if we just prefer the latest available. data PackagesPreferenceDefault diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs index d18779fb8ae..4470d4fbfcf 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig.hs @@ -108,6 +108,7 @@ import Distribution.Solver.Types.SourcePackage import Distribution.Client.Setup ( defaultMaxBackjumps + , defaultSolver ) import Distribution.Client.SrcDist ( packageDirToSdist @@ -314,6 +315,7 @@ resolveSolverSettings packageConfigFlagAssignment (getMapMappend projectConfigSpecificPackage) solverSettingCabalVersion = flagToMaybe projectConfigCabalVersion + solverSettingSolver = fromFlag projectConfigSolver solverSettingAllowOlder = fromMaybe mempty projectConfigAllowOlder solverSettingAllowNewer = fromMaybe mempty projectConfigAllowNewer solverSettingMaxBackjumps = case fromFlag projectConfigMaxBackjumps of @@ -341,7 +343,8 @@ resolveSolverSettings defaults = mempty - { projectConfigAllowOlder = Just (AllowOlder mempty) + { projectConfigSolver = Flag defaultSolver + , projectConfigAllowOlder = Just (AllowOlder mempty) , projectConfigAllowNewer = Just (AllowNewer mempty) , projectConfigMaxBackjumps = Flag defaultMaxBackjumps , projectConfigReorderGoals = Flag (ReorderGoals False) diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs index 13bb0d2c111..7814d6ef0ca 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs @@ -641,6 +641,7 @@ convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags { configCabalVersion = projectConfigCabalVersion , configExConstraints = projectConfigConstraints , configPreferences = projectConfigPreferences + , configSolver = projectConfigSolver , configAllowOlder = projectConfigAllowOlder , configAllowNewer = projectConfigAllowNewer , configWriteGhcEnvironmentFilesPolicy = @@ -910,6 +911,7 @@ convertToLegacySharedConfig , configBackup = mempty , configExConstraints = projectConfigConstraints , configPreferences = projectConfigPreferences + , configSolver = projectConfigSolver , configAllowOlder = projectConfigAllowOlder , configAllowNewer = projectConfigAllowNewer , configWriteGhcEnvironmentFilesPolicy = diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs index 1f6661d3af2..744a50ddc37 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs @@ -29,6 +29,9 @@ import Prelude () import Distribution.Client.BuildReports.Types ( ReportLevel (..) ) +import Distribution.Client.Dependency.Types + ( PreSolver + ) import Distribution.Client.Targets ( UserConstraint ) @@ -199,6 +202,7 @@ data ProjectConfigShared = ProjectConfigShared projectConfigConstraints :: [(UserConstraint, ConstraintSource)] , projectConfigPreferences :: [PackageVersionConstraint] , projectConfigCabalVersion :: Flag Version -- TODO: [required eventually] unused + , projectConfigSolver :: Flag PreSolver , projectConfigAllowOlder :: Maybe AllowOlder , projectConfigAllowNewer :: Maybe AllowNewer , projectConfigWriteGhcEnvironmentFilesPolicy @@ -402,6 +406,7 @@ data SolverSettings = SolverSettings -- ^ For all local packages , solverSettingFlagAssignments :: Map PackageName FlagAssignment , solverSettingCabalVersion :: Maybe Version -- TODO: [required eventually] unused + , solverSettingSolver :: PreSolver , solverSettingAllowOlder :: AllowOlder , solverSettingAllowNewer :: AllowNewer , solverSettingMaxBackjumps :: Maybe Int diff --git a/cabal-install/src/Distribution/Client/Setup.hs b/cabal-install/src/Distribution/Client/Setup.hs index f1a29fe1c03..44224d9559b 100644 --- a/cabal-install/src/Distribution/Client/Setup.hs +++ b/cabal-install/src/Distribution/Client/Setup.hs @@ -48,6 +48,7 @@ module Distribution.Client.Setup , filterHaddockArgs , filterHaddockFlags , haddockOptions + , defaultSolver , defaultMaxBackjumps , listCommand , ListFlags (..) @@ -99,6 +100,9 @@ import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy import Distribution.Client.BuildReports.Types ( ReportLevel (..) ) +import Distribution.Client.Dependency.Types + ( PreSolver (..) + ) import Distribution.Client.IndexUtils.ActiveRepos ( ActiveRepos ) @@ -825,6 +829,7 @@ data ConfigExFlags = ConfigExFlags , configBackup :: Flag Bool , configExConstraints :: [(UserConstraint, ConstraintSource)] , configPreferences :: [PackageVersionConstraint] + , configSolver :: Flag PreSolver , configAllowNewer :: Maybe AllowNewer , configAllowOlder :: Maybe AllowOlder , configWriteGhcEnvironmentFilesPolicy @@ -833,7 +838,7 @@ data ConfigExFlags = ConfigExFlags deriving (Eq, Show, Generic) defaultConfigExFlags :: ConfigExFlags -defaultConfigExFlags = mempty +defaultConfigExFlags = mempty{configSolver = Flag defaultSolver} configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags) configureExCommand = @@ -918,6 +923,7 @@ configureExOptions _showOrParseArgs src = ) (map prettyShow) ) + , optionSolver configSolver (\v flags -> flags{configSolver = v}) , option [] ["allow-older"] @@ -1252,6 +1258,7 @@ data FetchFlags = FetchFlags { -- fetchOutput :: Flag FilePath, fetchDeps :: Flag Bool , fetchDryRun :: Flag Bool + , fetchSolver :: Flag PreSolver , fetchMaxBackjumps :: Flag Int , fetchReorderGoals :: Flag ReorderGoals , fetchCountConflicts :: Flag CountConflicts @@ -1274,6 +1281,7 @@ defaultFetchFlags = { -- fetchOutput = mempty, fetchDeps = toFlag True , fetchDryRun = toFlag False + , fetchSolver = Flag defaultSolver , fetchMaxBackjumps = Flag defaultMaxBackjumps , fetchReorderGoals = Flag (ReorderGoals False) , fetchCountConflicts = Flag (CountConflicts True) @@ -1348,7 +1356,8 @@ fetchCommand = (\v flags -> flags{fetchBenchmarks = v}) (boolOpt [] []) ] - ++ optionSolverFlags + ++ optionSolver fetchSolver (\v flags -> flags{fetchSolver = v}) + : optionSolverFlags showOrParseArgs fetchMaxBackjumps (\v flags -> flags{fetchMaxBackjumps = v}) @@ -1384,6 +1393,7 @@ data FreezeFlags = FreezeFlags { freezeDryRun :: Flag Bool , freezeTests :: Flag Bool , freezeBenchmarks :: Flag Bool + , freezeSolver :: Flag PreSolver , freezeMaxBackjumps :: Flag Int , freezeReorderGoals :: Flag ReorderGoals , freezeCountConflicts :: Flag CountConflicts @@ -1404,6 +1414,7 @@ defaultFreezeFlags = { freezeDryRun = toFlag False , freezeTests = toFlag False , freezeBenchmarks = toFlag False + , freezeSolver = Flag defaultSolver , freezeMaxBackjumps = Flag defaultMaxBackjumps , freezeReorderGoals = Flag (ReorderGoals False) , freezeCountConflicts = Flag (CountConflicts True) @@ -1465,7 +1476,10 @@ freezeCommand = (\v flags -> flags{freezeBenchmarks = v}) (boolOpt [] []) ] - ++ optionSolverFlags + ++ optionSolver + freezeSolver + (\v flags -> flags{freezeSolver = v}) + : optionSolverFlags showOrParseArgs freezeMaxBackjumps (\v flags -> flags{freezeMaxBackjumps = v}) @@ -2120,6 +2134,12 @@ defaultInstallFlags = defaultMaxBackjumps :: Int defaultMaxBackjumps = 4000 +defaultSolver :: PreSolver +defaultSolver = AlwaysModular + +allSolvers :: String +allSolvers = intercalate ", " (map prettyShow ([minBound .. maxBound] :: [PreSolver])) + installCommand :: CommandUI ( ConfigFlags @@ -3296,6 +3316,26 @@ yesNoOpt :: ShowOrParseArgs -> MkOptDescr (b -> Flag Bool) (Flag Bool -> b -> b) yesNoOpt ShowArgs sf lf = trueArg sf lf yesNoOpt _ sf lf = Command.boolOpt' flagToMaybe Flag (sf, lf) ([], map ("no-" ++) lf) sf lf +optionSolver + :: (flags -> Flag PreSolver) + -> (Flag PreSolver -> flags -> flags) + -> OptionField flags +optionSolver get set = + option + [] + ["solver"] + ("Select dependency solver to use (default: " ++ prettyShow defaultSolver ++ "). Choices: " ++ allSolvers ++ ".") + get + set + ( reqArg + "SOLVER" + ( parsecToReadE + (const $ "solver must be one of: " ++ allSolvers) + (toFlag `fmap` parsec) + ) + (flagToList . fmap prettyShow) + ) + optionSolverFlags :: ShowOrParseArgs -> (flags -> Flag Int) diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs index 9fc7bfe872b..cdb34a3534c 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -969,6 +969,9 @@ instance Arbitrary LocalRepo where <*> elements ["/tmp/foo", "/tmp/bar"] -- TODO: generate valid absolute paths <*> arbitrary +instance Arbitrary PreSolver where + arbitrary = elements [minBound .. maxBound] + instance Arbitrary ReorderGoals where arbitrary = ReorderGoals <$> arbitrary diff --git a/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs index acb8211944e..495c4cbf402 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs @@ -55,6 +55,7 @@ instance ToExpr PackageConfig instance ToExpr PackageDB instance ToExpr PackageProperty instance ToExpr PreferOldest +instance ToExpr PreSolver instance ToExpr ProjectConfig instance ToExpr ProjectConfigBuildOnly instance ToExpr ProjectConfigProvenance