Remove PreSolver type and AlwaysModular instance

This also eliminates the front-facing false choice presented to users, where they could choose among the list of 1 solver available ...
haskell · Aug 25, 2023 · 85ebc06 · 85ebc06
1 parent 6ff9acd
commit 85ebc06
Show file tree

Hide file tree

Showing 8 changed files with 5 additions and 81 deletions.
diff --git a/cabal-install/src/Distribution/Client/Config.hs b/cabal-install/src/Distribution/Client/Config.hs
@@ -543,7 +543,6 @@ 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
@@ -1,42 +1,21 @@
 {-# LANGUAGE DeriveGeneric #-}
 
 module Distribution.Client.Dependency.Types
-  ( PreSolver (..)
-  , Solver (..)
+  ( 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
@@ -108,7 +108,6 @@ import Distribution.Solver.Types.SourcePackage
 
 import Distribution.Client.Setup
   ( defaultMaxBackjumps
-  , defaultSolver
   )
 import Distribution.Client.SrcDist
   ( packageDirToSdist
@@ -315,7 +314,6 @@ resolveSolverSettings
           packageConfigFlagAssignment
           (getMapMappend projectConfigSpecificPackage)
       solverSettingCabalVersion = flagToMaybe projectConfigCabalVersion
-      solverSettingSolver = fromFlag projectConfigSolver
       solverSettingAllowOlder = fromMaybe mempty projectConfigAllowOlder
       solverSettingAllowNewer = fromMaybe mempty projectConfigAllowNewer
       solverSettingMaxBackjumps = case fromFlag projectConfigMaxBackjumps of
@@ -343,8 +341,7 @@ resolveSolverSettings
 
       defaults =
         mempty
-          { projectConfigSolver = Flag defaultSolver
-          , projectConfigAllowOlder = Just (AllowOlder mempty)
+          { 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
@@ -641,7 +641,6 @@ convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags
       { configCabalVersion = projectConfigCabalVersion
       , configExConstraints = projectConfigConstraints
       , configPreferences = projectConfigPreferences
-      , configSolver = projectConfigSolver
       , configAllowOlder = projectConfigAllowOlder
       , configAllowNewer = projectConfigAllowNewer
       , configWriteGhcEnvironmentFilesPolicy =
@@ -911,7 +910,6 @@ 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
@@ -29,9 +29,6 @@ import Prelude ()
 import Distribution.Client.BuildReports.Types
   ( ReportLevel (..)
   )
-import Distribution.Client.Dependency.Types
-  ( PreSolver
-  )
 import Distribution.Client.Targets
   ( UserConstraint
   )
@@ -202,7 +199,6 @@ 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
@@ -406,7 +402,6 @@ 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
@@ -48,7 +48,6 @@ module Distribution.Client.Setup
   , filterHaddockArgs
   , filterHaddockFlags
   , haddockOptions
-  , defaultSolver
   , defaultMaxBackjumps
   , listCommand
   , ListFlags (..)
@@ -100,9 +99,6 @@ import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy
 import Distribution.Client.BuildReports.Types
   ( ReportLevel (..)
   )
-import Distribution.Client.Dependency.Types
-  ( PreSolver (..)
-  )
 import Distribution.Client.IndexUtils.ActiveRepos
   ( ActiveRepos
   )
@@ -829,7 +825,6 @@ data ConfigExFlags = ConfigExFlags
   , configBackup :: Flag Bool
   , configExConstraints :: [(UserConstraint, ConstraintSource)]
   , configPreferences :: [PackageVersionConstraint]
-  , configSolver :: Flag PreSolver
   , configAllowNewer :: Maybe AllowNewer
   , configAllowOlder :: Maybe AllowOlder
   , configWriteGhcEnvironmentFilesPolicy
@@ -838,7 +833,7 @@ data ConfigExFlags = ConfigExFlags
   deriving (Eq, Show, Generic)
 
 defaultConfigExFlags :: ConfigExFlags
-defaultConfigExFlags = mempty{configSolver = Flag defaultSolver}
+defaultConfigExFlags = mempty
 
 configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags)
 configureExCommand =
@@ -923,7 +918,6 @@ configureExOptions _showOrParseArgs src =
           )
           (map prettyShow)
       )
-  , optionSolver configSolver (\v flags -> flags{configSolver = v})
   , option
       []
       ["allow-older"]
@@ -1258,7 +1252,6 @@ data FetchFlags = FetchFlags
   { --    fetchOutput    :: Flag FilePath,
     fetchDeps :: Flag Bool
   , fetchDryRun :: Flag Bool
-  , fetchSolver :: Flag PreSolver
   , fetchMaxBackjumps :: Flag Int
   , fetchReorderGoals :: Flag ReorderGoals
   , fetchCountConflicts :: Flag CountConflicts
@@ -1281,7 +1274,6 @@ defaultFetchFlags =
     { --  fetchOutput    = mempty,
       fetchDeps = toFlag True
     , fetchDryRun = toFlag False
-    , fetchSolver = Flag defaultSolver
     , fetchMaxBackjumps = Flag defaultMaxBackjumps
     , fetchReorderGoals = Flag (ReorderGoals False)
     , fetchCountConflicts = Flag (CountConflicts True)
@@ -1356,8 +1348,7 @@ fetchCommand =
             (\v flags -> flags{fetchBenchmarks = v})
             (boolOpt [] [])
         ]
-          ++ optionSolver fetchSolver (\v flags -> flags{fetchSolver = v})
-          : optionSolverFlags
+          ++ optionSolverFlags
             showOrParseArgs
             fetchMaxBackjumps
             (\v flags -> flags{fetchMaxBackjumps = v})
@@ -1393,7 +1384,6 @@ data FreezeFlags = FreezeFlags
   { freezeDryRun :: Flag Bool
   , freezeTests :: Flag Bool
   , freezeBenchmarks :: Flag Bool
-  , freezeSolver :: Flag PreSolver
   , freezeMaxBackjumps :: Flag Int
   , freezeReorderGoals :: Flag ReorderGoals
   , freezeCountConflicts :: Flag CountConflicts
@@ -1414,7 +1404,6 @@ defaultFreezeFlags =
     { freezeDryRun = toFlag False
     , freezeTests = toFlag False
     , freezeBenchmarks = toFlag False
-    , freezeSolver = Flag defaultSolver
     , freezeMaxBackjumps = Flag defaultMaxBackjumps
     , freezeReorderGoals = Flag (ReorderGoals False)
     , freezeCountConflicts = Flag (CountConflicts True)
@@ -1476,10 +1465,7 @@ freezeCommand =
             (\v flags -> flags{freezeBenchmarks = v})
             (boolOpt [] [])
         ]
-          ++ optionSolver
-            freezeSolver
-            (\v flags -> flags{freezeSolver = v})
-          : optionSolverFlags
+          ++ optionSolverFlags
             showOrParseArgs
             freezeMaxBackjumps
             (\v flags -> flags{freezeMaxBackjumps = v})
@@ -2134,12 +2120,6 @@ defaultInstallFlags =
 defaultMaxBackjumps :: Int
 defaultMaxBackjumps = 4000
 
-defaultSolver :: PreSolver
-defaultSolver = AlwaysModular
-
-allSolvers :: String
-allSolvers = intercalate ", " (map prettyShow ([minBound .. maxBound] :: [PreSolver]))
-
 installCommand
   :: CommandUI
       ( ConfigFlags
@@ -3316,26 +3296,6 @@ 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
@@ -969,9 +969,6 @@ 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
@@ -55,7 +55,6 @@ instance ToExpr PackageConfig
 instance ToExpr PackageDB
 instance ToExpr PackageProperty
 instance ToExpr PreferOldest
-instance ToExpr PreSolver
 instance ToExpr ProjectConfig
 instance ToExpr ProjectConfigBuildOnly
 instance ToExpr ProjectConfigProvenance