choose default solver based on compiler version

GHC-6.12 has base-3 depending on base-4. This is a situation the
topdown solver is hacked to deal with, but the new modular solver
currently doesn't support it. We therefore switch back to the
topdown solver if a GHC version before 7 is detected, but switch
to the modular solver by default in all other situations.

cabal-install/Distribution/Client/Configure.hs

@@ -130,6 +130,7 @@ planLocalPackage :: Verbosity -> Compiler
 planLocalPackage verbosity comp configFlags configExFlags installedPkgIndex
   (SourcePackageDb _ packagePrefs) = do
   pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity
+  solver <- chooseSolver verbosity (fromFlag $ configSolver configExFlags) (compilerId comp)
 
   let -- We create a local package and ask to resolve a dependency on it
       localPkg = SourcePackage {
@@ -138,8 +139,6 @@ planLocalPackage verbosity comp configFlags configExFlags installedPkgIndex
         packageSource             = LocalUnpackedPackage "."
       }
 
-      solver = fromFlag $ configSolver configExFlags
-
       testsEnabled = fromFlagOrDefault False $ configTests configFlags
       benchmarksEnabled =
         fromFlagOrDefault False $ configBenchmarks configFlags

cabal-install/Distribution/Client/Dependency.hs

@@ -14,6 +14,7 @@
 -----------------------------------------------------------------------------
 module Distribution.Client.Dependency (
     -- * The main package dependency resolver
+    chooseSolver,
     resolveDependencies,
     Progress(..),
     foldProgress,
@@ -64,7 +65,7 @@ import Distribution.Client.Types
          ( SourcePackageDb(SourcePackageDb)
          , SourcePackage(..) )
 import Distribution.Client.Dependency.Types
-         ( Solver(..), DependencyResolver, PackageConstraint(..)
+         ( PreSolver(..), Solver(..), DependencyResolver, PackageConstraint(..)
          , PackagePreferences(..), InstalledPreference(..)
          , PackagesPreferenceDefault(..)
          , Progress(..), foldProgress )
@@ -74,14 +75,17 @@ import Distribution.Package
          ( PackageName(..), PackageId, Package(..), packageVersion
          , InstalledPackageId, Dependency(Dependency))
 import Distribution.Version
-         ( VersionRange, anyVersion, withinRange, simplifyVersionRange )
+         ( Version(..), VersionRange, anyVersion, withinRange, simplifyVersionRange )
 import Distribution.Compiler
-         ( CompilerId(..) )
+         ( CompilerId(..), CompilerFlavor(..) )
 import Distribution.System
          ( Platform )
-import Distribution.Simple.Utils (comparing)
+import Distribution.Simple.Utils
+         ( comparing, warn, info )
 import Distribution.Text
          ( display )
+import Distribution.Verbosity
+         ( Verbosity )
 
 import Data.List (maximumBy, foldl')
 import Data.Maybe (fromMaybe)
@@ -305,6 +309,17 @@ standardInstallPolicy
 -- * Interface to the standard resolver
 -- ------------------------------------------------------------
 
+chooseSolver :: Verbosity -> PreSolver -> CompilerId -> IO Solver
+chooseSolver _         AlwaysTopDown _                = return TopDown
+chooseSolver _         AlwaysModular _                = return Modular
+chooseSolver verbosity Choose        (CompilerId f v) = do
+  let chosenSolver | f == GHC && v <= Version [7] [] = TopDown
+                   | otherwise                       = Modular
+      msg TopDown = warn verbosity "Falling back to topdown solver for GHC < 7."
+      msg Modular = info verbosity "Choosing modular solver."
+  msg chosenSolver
+  return chosenSolver
+
 runSolver :: Solver -> SolverConfig -> DependencyResolver
 runSolver TopDown = const topDownResolver -- TODO: warn about unsuported options
 runSolver Modular = modularResolver

cabal-install/Distribution/Client/Dependency/Types.hs

@@ -13,6 +13,7 @@
 module Distribution.Client.Dependency.Types (
     ExtDependency(..),
 
+    PreSolver(..),
     Solver(..),
     DependencyResolver,
 
@@ -76,17 +77,23 @@ instance Text ExtDependency where
   parse = (SourceDependency `fmap` parse) <++ (InstalledDependency `fmap` parse)
 
 -- | All the solvers that can be selected.
+data PreSolver = AlwaysTopDown | AlwaysModular | Choose
+  deriving (Eq, Ord, Show, Bounded, Enum)
+
+-- | All the solvers that can be used.
 data Solver = TopDown | Modular
   deriving (Eq, Ord, Show, Bounded, Enum)
 
-instance Text Solver where
-  disp TopDown = text "topdown"
-  disp Modular = text "modular"
+instance Text PreSolver where
+  disp AlwaysTopDown = text "topdown"
+  disp AlwaysModular = text "modular"
+  disp Choose        = text "choose"
   parse = do
     name <- Parse.munch1 isAlpha
     case map toLower name of
-      "topdown" -> return TopDown
-      "modular" -> return Modular
+      "topdown" -> return AlwaysTopDown
+      "modular" -> return AlwaysModular
+      "choose"  -> return Choose
       _         -> Parse.pfail
 
 -- | A dependency resolver is a function that works out an installation plan

cabal-install/Distribution/Client/Fetch.hs

@@ -120,6 +120,7 @@ planPackages verbosity comp fetchFlags
              installedPkgIndex sourcePkgDb pkgSpecifiers
 
   | includeDependencies = do
+      solver <- chooseSolver verbosity (fromFlag (fetchSolver fetchFlags)) (compilerId comp)
       notice verbosity "Resolving dependencies..."
       installPlan <- foldProgress logMsg die return $
                        resolveDependencies
@@ -159,7 +160,6 @@ planPackages verbosity comp fetchFlags
     includeDependencies = fromFlag (fetchDeps fetchFlags)
     logMsg message rest = debug verbosity message >> rest
 
-    solver           = fromFlag (fetchSolver           fetchFlags)
     reorderGoals     = fromFlag (fetchReorderGoals     fetchFlags)
     independentGoals = fromFlag (fetchIndependentGoals fetchFlags)
     maxBackjumps     = fromFlag (fetchMaxBackjumps     fetchFlags)

cabal-install/Distribution/Client/Install.hs

@@ -159,6 +159,8 @@ install verbosity packageDBs repos comp conf
     installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
     sourcePkgDb       <- getSourcePackages    verbosity repos
 
+    solver <- chooseSolver verbosity (fromFlag (configSolver  configExFlags)) (compilerId comp)
+
     let -- For install, if no target is given it means we use the
         -- current directory as the single target
         userTargets | null userTargets0 = [UserTargetLocalDir "."]
@@ -172,7 +174,7 @@ install verbosity packageDBs repos comp conf
     notice verbosity "Resolving dependencies..."
     installPlan   <- foldProgress logMsg die return $
                        planPackages
-                         comp configFlags configExFlags installFlags
+                         comp solver configFlags configExFlags installFlags
                          installedPkgIndex sourcePkgDb pkgSpecifiers
 
     checkPrintPlan verbosity installedPkgIndex installPlan installFlags
@@ -189,7 +191,6 @@ install verbosity packageDBs repos comp conf
                globalFlags, configFlags, configExFlags, installFlags, haddockFlags)
 
     dryRun      = fromFlag (installDryRun installFlags)
-    solver      = fromFlag (configSolver  configExFlags)
     logMsg message rest = debug verbosity message >> rest
 
 
@@ -221,14 +222,15 @@ type InstallContext = ( PackageDBStack
 -- ------------------------------------------------------------
 
 planPackages :: Compiler
+             -> Solver
              -> ConfigFlags
              -> ConfigExFlags
              -> InstallFlags
              -> PackageIndex
              -> SourcePackageDb
              -> [PackageSpecifier SourcePackage]
              -> Progress String String InstallPlan
-planPackages comp configFlags configExFlags installFlags
+planPackages comp solver configFlags configExFlags installFlags
              installedPkgIndex sourcePkgDb pkgSpecifiers =
 
         resolveDependencies
@@ -312,7 +314,6 @@ planPackages comp configFlags configExFlags installFlags
         targetnames  = map pkgSpecifierTarget pkgSpecifiers
 
 
-    solver           = fromFlag (configSolver            configExFlags)
     reinstall        = fromFlag (installReinstall        installFlags)
     reorderGoals     = fromFlag (installReorderGoals     installFlags)
     independentGoals = fromFlag (installIndependentGoals installFlags)

cabal-install/Distribution/Client/Setup.hs

@@ -39,7 +39,7 @@ import Distribution.Client.Types
 import Distribution.Client.BuildReports.Types
          ( ReportLevel(..) )
 import Distribution.Client.Dependency.Types
-         ( Solver(..) )
+         ( PreSolver(..) )
 import qualified Distribution.Client.Init.Types as IT
          ( InitFlags(..), PackageType(..) )
 import Distribution.Client.Targets
@@ -238,7 +238,7 @@ data ConfigExFlags = ConfigExFlags {
     configCabalVersion :: Flag Version,
     configExConstraints:: [UserConstraint],
     configPreferences  :: [Dependency],
-    configSolver       :: Flag Solver
+    configSolver       :: Flag PreSolver
   }
 
 defaultConfigExFlags :: ConfigExFlags
@@ -306,7 +306,7 @@ data FetchFlags = FetchFlags {
 --    fetchOutput    :: Flag FilePath,
       fetchDeps      :: Flag Bool,
       fetchDryRun    :: Flag Bool,
-      fetchSolver           :: Flag Solver,
+      fetchSolver           :: Flag PreSolver,
       fetchMaxBackjumps     :: Flag Int,
       fetchReorderGoals     :: Flag Bool,
       fetchIndependentGoals :: Flag Bool,
@@ -640,11 +640,11 @@ defaultInstallFlags = InstallFlags {
 defaultMaxBackjumps :: Int
 defaultMaxBackjumps = 200
 
-defaultSolver :: Solver
-defaultSolver = TopDown
+defaultSolver :: PreSolver
+defaultSolver = Choose
 
 allSolvers :: String
-allSolvers = intercalate ", " (map display ([minBound .. maxBound] :: [Solver]))
+allSolvers = intercalate ", " (map display ([minBound .. maxBound] :: [PreSolver]))
 
 installCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
 installCommand = CommandUI {
@@ -1110,12 +1110,12 @@ liftOptions :: (b -> a) -> (a -> b -> b)
             -> [OptionField a] -> [OptionField b]
 liftOptions get set = map (liftOption get set)
 
-optionSolver :: (flags -> Flag Solver)
-             -> (Flag Solver -> flags -> flags)
+optionSolver :: (flags -> Flag PreSolver)
+             -> (Flag PreSolver -> flags -> flags)
              -> OptionField flags
 optionSolver get set =
   option [] ["solver"]
-    ("Select dependency solver to use (default: " ++ display defaultSolver ++ "). Choices: " ++ allSolvers ++ ".")
+    ("Select dependency solver to use (default: " ++ display defaultSolver ++ "). Choices: " ++ allSolvers ++ ", where 'choose' chooses between 'topdown' and 'modular' based on compiler version.")
     get set
     (reqArg "SOLVER" (readP_to_E (const $ "solver must be one of: " ++ allSolvers)
                                  (toFlag `fmap` parse))