Revert "Remove PreSolver type and AlwaysModular instance"

This reverts commit 85ebc06.

cabal-install/src/Distribution/Client/Config.hs

@@ -547,6 +547,7 @@ instance Semigroup SavedConfig where
             configExConstraints = lastNonEmpty configExConstraints
           , -- TODO: NubListify
             configPreferences = lastNonEmpty configPreferences
+          , configSolver = combine configSolver
           , configAllowNewer =
               combineMonoid savedConfigureExFlags configAllowNewer
           , configAllowOlder =

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

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
@@ -315,6 +316,7 @@ resolveSolverSettings
           packageConfigFlagAssignment
           (getMapMappend projectConfigSpecificPackage)
       solverSettingCabalVersion = flagToMaybe projectConfigCabalVersion
+      solverSettingSolver = fromFlag projectConfigSolver
       solverSettingAllowOlder = fromMaybe mempty projectConfigAllowOlder
       solverSettingAllowNewer = fromMaybe mempty projectConfigAllowNewer
       solverSettingMaxBackjumps = case fromFlag projectConfigMaxBackjumps of
@@ -342,7 +344,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)

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 =

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

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})
@@ -2133,6 +2147,12 @@ defaultInstallFlags =
 defaultMaxBackjumps :: Int
 defaultMaxBackjumps = 4000
 
+defaultSolver :: PreSolver
+defaultSolver = AlwaysModular
+
+allSolvers :: String
+allSolvers = intercalate ", " (map prettyShow ([minBound .. maxBound] :: [PreSolver]))
+
 installCommand
   :: CommandUI
       ( ConfigFlags
@@ -3322,6 +3342,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)

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
 

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