Dependency.hs

-----------------------------------------------------------------------------

-----------------------------------------------------------------------------

-- |
-- Module      :  Distribution.Client.Dependency
-- Copyright   :  (c) David Himmelstrup 2005,
--                    Bjorn Bringert 2007
--                    Duncan Coutts 2008
-- License     :  BSD-like
--
-- Maintainer  :  cabal-devel@gmail.com
-- Stability   :  provisional
-- Portability :  portable
--
-- Top level interface to dependency resolution.
module Distribution.Client.Dependency
  ( -- * The main package dependency resolver
    DepResolverParams
  , resolveDependencies
  , Progress (..)
  , foldProgress

    -- * Alternate, simple resolver that does not do dependencies recursively
  , resolveWithoutDependencies

    -- * Constructing resolver policies
  , PackageProperty (..)
  , PackageConstraint (..)
  , scopeToplevel
  , PackagesPreferenceDefault (..)
  , PackagePreference (..)

    -- ** Standard policy
  , basicInstallPolicy
  , standardInstallPolicy
  , PackageSpecifier (..)

    -- ** Extra policy options
  , upgradeDependencies
  , reinstallTargets

    -- ** Policy utils
  , addConstraints
  , addPreferences
  , setPreferenceDefault
  , setReorderGoals
  , setCountConflicts
  , setFineGrainedConflicts
  , setMinimizeConflictSet
  , setIndependentGoals
  , setAvoidReinstalls
  , setShadowPkgs
  , setStrongFlags
  , setAllowBootLibInstalls
  , setOnlyConstrained
  , setMaxBackjumps
  , setEnableBackjumping
  , setSolveExecutables
  , setGoalOrder
  , setSolverVerbosity
  , removeLowerBounds
  , removeUpperBounds
  , addDefaultSetupDependencies
  , addSetupCabalMinVersionConstraint
  , addSetupCabalMaxVersionConstraint
  , addSetupCabalProfiledDynamic
  ) where

import Distribution.Client.Compat.Prelude

import Distribution.Client.Dependency.Types
  ( PackagesPreferenceDefault (..)
  )
import Distribution.Client.SolverInstallPlan (SolverInstallPlan)
import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan
import Distribution.Client.Types
  ( AllowNewer (..)
  , AllowOlder (..)
  , PackageSpecifier (..)
  , RelaxDepMod (..)
  , RelaxDepScope (..)
  , RelaxDepSubject (..)
  , RelaxDeps (..)
  , RelaxedDep (..)
  , SourcePackageDb (SourcePackageDb)
  , UnresolvedPkgLoc
  , UnresolvedSourcePackage
  , isRelaxDeps
  , pkgSpecifierConstraints
  , pkgSpecifierTarget
  )
import Distribution.Client.Utils
  ( MergeResult (..)
  , duplicatesBy
  , mergeBy
  )
import qualified Distribution.Compat.Graph as Graph
import Distribution.Compiler
  ( CompilerInfo (..)
  )
import Distribution.Package
  ( Package (..)
  , PackageId
  , PackageIdentifier (PackageIdentifier)
  , PackageName
  , mkPackageName
  , packageName
  , packageVersion
  )
import qualified Distribution.PackageDescription as PD
import Distribution.PackageDescription.Configuration
  ( finalizePD
  )
import qualified Distribution.PackageDescription.Configuration as PD
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex
import Distribution.Simple.Setup
  ( asBool
  )
import Distribution.Solver.Modular
  ( PruneAfterFirstSuccess (..)
  , SolverConfig (..)
  , modularResolver
  )
import Distribution.System
  ( Platform
  )
import Distribution.Types.Dependency
import Distribution.Types.DependencySatisfaction
  ( DependencySatisfaction (..)
  )
import Distribution.Verbosity
  ( normal
  )
import Distribution.Version

import Distribution.Solver.Types.ComponentDeps (ComponentDeps)
import qualified Distribution.Solver.Types.ComponentDeps as CD
import Distribution.Solver.Types.ConstraintSource
import Distribution.Solver.Types.DependencyResolver
import Distribution.Solver.Types.InstalledPreference as Preference
import Distribution.Solver.Types.LabeledPackageConstraint
import Distribution.Solver.Types.OptionalStanza
import Distribution.Solver.Types.PackageConstraint
import qualified Distribution.Solver.Types.PackageIndex as PackageIndex
import Distribution.Solver.Types.PackagePath
import Distribution.Solver.Types.PackagePreferences
import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb)
import Distribution.Solver.Types.Progress
import Distribution.Solver.Types.ResolverPackage
import Distribution.Solver.Types.Settings
import Distribution.Solver.Types.SolverId
import Distribution.Solver.Types.SolverPackage
import Distribution.Solver.Types.SourcePackage
import Distribution.Solver.Types.Variable

import Control.Exception
  ( assert
  )
import Data.List
  ( maximumBy
  )
import qualified Data.Map as Map
import qualified Data.Set as Set

-- ------------------------------------------------------------

-- * High level planner policy

-- ------------------------------------------------------------

-- | The set of parameters to the dependency resolver. These parameters are
-- relatively low level but many kinds of high level policies can be
-- implemented in terms of adjustments to the parameters.
data DepResolverParams = DepResolverParams
  { depResolverTargets :: Set PackageName
  , depResolverConstraints :: [LabeledPackageConstraint]
  , depResolverPreferences :: [PackagePreference]
  , depResolverPreferenceDefault :: PackagesPreferenceDefault
  , depResolverInstalledPkgIndex :: InstalledPackageIndex
  , depResolverSourcePkgIndex :: PackageIndex.PackageIndex UnresolvedSourcePackage
  , depResolverReorderGoals :: ReorderGoals
  , depResolverCountConflicts :: CountConflicts
  , depResolverFineGrainedConflicts :: FineGrainedConflicts
  , depResolverMinimizeConflictSet :: MinimizeConflictSet
  , depResolverIndependentGoals :: IndependentGoals
  , depResolverAvoidReinstalls :: AvoidReinstalls
  , depResolverShadowPkgs :: ShadowPkgs
  , depResolverStrongFlags :: StrongFlags
  , depResolverAllowBootLibInstalls :: AllowBootLibInstalls
  -- ^ Whether to allow base and its dependencies to be installed.
  , depResolverOnlyConstrained :: OnlyConstrained
  -- ^ Whether to only allow explicitly constrained packages plus
  -- goals or to allow any package.
  , depResolverMaxBackjumps :: Maybe Int
  , depResolverEnableBackjumping :: EnableBackjumping
  , depResolverSolveExecutables :: SolveExecutables
  -- ^ Whether or not to solve for dependencies on executables.
  -- This should be true, except in the legacy code path where
  -- we can't tell if an executable has been installed or not,
  -- so we shouldn't solve for them.  See #3875.
  , depResolverGoalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering)
  -- ^ Function to override the solver's goal-ordering heuristics.
  , depResolverVerbosity :: Verbosity
  }

showDepResolverParams :: DepResolverParams -> String
showDepResolverParams p =
  "targets: "
    ++ intercalate ", " (map prettyShow $ Set.toList (depResolverTargets p))
    ++ "\nconstraints: "
    ++ concatMap
      (("\n  " ++) . showLabeledConstraint)
      (depResolverConstraints p)
    ++ "\npreferences: "
    ++ concatMap
      (("\n  " ++) . showPackagePreference)
      (depResolverPreferences p)
    ++ "\nstrategy: "
    ++ show (depResolverPreferenceDefault p)
    ++ "\nreorder goals: "
    ++ show (asBool (depResolverReorderGoals p))
    ++ "\ncount conflicts: "
    ++ show (asBool (depResolverCountConflicts p))
    ++ "\nfine grained conflicts: "
    ++ show (asBool (depResolverFineGrainedConflicts p))
    ++ "\nminimize conflict set: "
    ++ show (asBool (depResolverMinimizeConflictSet p))
    ++ "\nindependent goals: "
    ++ show (asBool (depResolverIndependentGoals p))
    ++ "\navoid reinstalls: "
    ++ show (asBool (depResolverAvoidReinstalls p))
    ++ "\nshadow packages: "
    ++ show (asBool (depResolverShadowPkgs p))
    ++ "\nstrong flags: "
    ++ show (asBool (depResolverStrongFlags p))
    ++ "\nallow boot library installs: "
    ++ show (asBool (depResolverAllowBootLibInstalls p))
    ++ "\nonly constrained packages: "
    ++ show (depResolverOnlyConstrained p)
    ++ "\nmax backjumps: "
    ++ maybe
      "infinite"
      show
      (depResolverMaxBackjumps p)
  where
    showLabeledConstraint :: LabeledPackageConstraint -> String
    showLabeledConstraint (LabeledPackageConstraint pc src) =
      showPackageConstraint pc ++ " (" ++ showConstraintSource src ++ ")"

-- | A package selection preference for a particular package.
--
-- Preferences are soft constraints that the dependency resolver should try to
-- respect where possible. It is not specified if preferences on some packages
-- are more important than others.
data PackagePreference
  = -- | A suggested constraint on the version number.
    PackageVersionPreference PackageName VersionRange
  | -- | If we prefer versions of packages that are already installed.
    PackageInstalledPreference PackageName InstalledPreference
  | -- | If we would prefer to enable these optional stanzas
    -- (i.e. test suites and/or benchmarks)
    PackageStanzasPreference PackageName [OptionalStanza]

-- | Provide a textual representation of a package preference
-- for debugging purposes.
showPackagePreference :: PackagePreference -> String
showPackagePreference (PackageVersionPreference pn vr) =
  prettyShow pn ++ " " ++ prettyShow (simplifyVersionRange vr)
showPackagePreference (PackageInstalledPreference pn ip) =
  prettyShow pn ++ " " ++ show ip
showPackagePreference (PackageStanzasPreference pn st) =
  prettyShow pn ++ " " ++ show st

basicDepResolverParams
  :: InstalledPackageIndex
  -> PackageIndex.PackageIndex UnresolvedSourcePackage
  -> DepResolverParams
basicDepResolverParams installedPkgIndex sourcePkgIndex =
  DepResolverParams
    { depResolverTargets = Set.empty
    , depResolverConstraints = []
    , depResolverPreferences = []
    , depResolverPreferenceDefault = PreferLatestForSelected
    , depResolverInstalledPkgIndex = installedPkgIndex
    , depResolverSourcePkgIndex = sourcePkgIndex
    , depResolverReorderGoals = ReorderGoals False
    , depResolverCountConflicts = CountConflicts True
    , depResolverFineGrainedConflicts = FineGrainedConflicts True
    , depResolverMinimizeConflictSet = MinimizeConflictSet False
    , depResolverIndependentGoals = IndependentGoals False
    , depResolverAvoidReinstalls = AvoidReinstalls False
    , depResolverShadowPkgs = ShadowPkgs False
    , depResolverStrongFlags = StrongFlags False
    , depResolverAllowBootLibInstalls = AllowBootLibInstalls False
    , depResolverOnlyConstrained = OnlyConstrainedNone
    , depResolverMaxBackjumps = Nothing
    , depResolverEnableBackjumping = EnableBackjumping True
    , depResolverSolveExecutables = SolveExecutables True
    , depResolverGoalOrder = Nothing
    , depResolverVerbosity = normal
    }

addTargets
  :: [PackageName]
  -> DepResolverParams
  -> DepResolverParams
addTargets extraTargets params =
  params
    { depResolverTargets = Set.fromList extraTargets `Set.union` depResolverTargets params
    }

addConstraints
  :: [LabeledPackageConstraint]
  -> DepResolverParams
  -> DepResolverParams
addConstraints extraConstraints params =
  params
    { depResolverConstraints =
        extraConstraints
          ++ depResolverConstraints params
    }

addPreferences
  :: [PackagePreference]
  -> DepResolverParams
  -> DepResolverParams
addPreferences extraPreferences params =
  params
    { depResolverPreferences =
        extraPreferences
          ++ depResolverPreferences params
    }

setPreferenceDefault
  :: PackagesPreferenceDefault
  -> DepResolverParams
  -> DepResolverParams
setPreferenceDefault preferenceDefault params =
  params
    { depResolverPreferenceDefault = preferenceDefault
    }

setReorderGoals :: ReorderGoals -> DepResolverParams -> DepResolverParams
setReorderGoals reorder params =
  params
    { depResolverReorderGoals = reorder
    }

setCountConflicts :: CountConflicts -> DepResolverParams -> DepResolverParams
setCountConflicts count params =
  params
    { depResolverCountConflicts = count
    }

setFineGrainedConflicts :: FineGrainedConflicts -> DepResolverParams -> DepResolverParams
setFineGrainedConflicts fineGrained params =
  params
    { depResolverFineGrainedConflicts = fineGrained
    }

setMinimizeConflictSet :: MinimizeConflictSet -> DepResolverParams -> DepResolverParams
setMinimizeConflictSet minimize params =
  params
    { depResolverMinimizeConflictSet = minimize
    }

setIndependentGoals :: IndependentGoals -> DepResolverParams -> DepResolverParams
setIndependentGoals indep params =
  params
    { depResolverIndependentGoals = indep
    }

setAvoidReinstalls :: AvoidReinstalls -> DepResolverParams -> DepResolverParams
setAvoidReinstalls avoid params =
  params
    { depResolverAvoidReinstalls = avoid
    }

setShadowPkgs :: ShadowPkgs -> DepResolverParams -> DepResolverParams
setShadowPkgs shadow params =
  params
    { depResolverShadowPkgs = shadow
    }

setStrongFlags :: StrongFlags -> DepResolverParams -> DepResolverParams
setStrongFlags sf params =
  params
    { depResolverStrongFlags = sf
    }

setAllowBootLibInstalls :: AllowBootLibInstalls -> DepResolverParams -> DepResolverParams
setAllowBootLibInstalls i params =
  params
    { depResolverAllowBootLibInstalls = i
    }

setOnlyConstrained :: OnlyConstrained -> DepResolverParams -> DepResolverParams
setOnlyConstrained i params =
  params
    { depResolverOnlyConstrained = i
    }

setMaxBackjumps :: Maybe Int -> DepResolverParams -> DepResolverParams
setMaxBackjumps n params =
  params
    { depResolverMaxBackjumps = n
    }

setEnableBackjumping :: EnableBackjumping -> DepResolverParams -> DepResolverParams
setEnableBackjumping b params =
  params
    { depResolverEnableBackjumping = b
    }

setSolveExecutables :: SolveExecutables -> DepResolverParams -> DepResolverParams
setSolveExecutables b params =
  params
    { depResolverSolveExecutables = b
    }

setGoalOrder
  :: Maybe (Variable QPN -> Variable QPN -> Ordering)
  -> DepResolverParams
  -> DepResolverParams
setGoalOrder order params =
  params
    { depResolverGoalOrder = order
    }

setSolverVerbosity :: Verbosity -> DepResolverParams -> DepResolverParams
setSolverVerbosity verbosity params =
  params
    { depResolverVerbosity = verbosity
    }

-- | Some packages are specific to a given compiler version and should never be
-- reinstalled.
dontInstallNonReinstallablePackages :: DepResolverParams -> DepResolverParams
dontInstallNonReinstallablePackages params =
  addConstraints extraConstraints params
  where
    extraConstraints =
      [ LabeledPackageConstraint
        (PackageConstraint (ScopeAnyQualifier pkgname) PackagePropertyInstalled)
        ConstraintSourceNonReinstallablePackage
      | pkgname <- nonReinstallablePackages
      ]

-- | The set of non-reinstallable packages includes those which cannot be
-- rebuilt using a GHC installation and Hackage-published source distribution.
-- There are a few reasons why this might be true:
--
--  * the package overrides its unit ID (e.g. with ghc's @-this-unit-id@ flag),
--    which can result in multiple indistinguishable packages (having potentially
--    different ABIs) with the same unit ID.
--
--  * the package contains definitions of wired-in declarations which tie
--    it to a particular compiler (e.g. we can't build link against
--    @base-4.18.0.0@ using GHC 9.6.1).
--
--  * the package does not have a complete (that is, buildable) source distribution.
--    For instance, some packages provided by GHC rely on files outside of the
--    source tree generated by GHC's build system.
nonReinstallablePackages :: [PackageName]
nonReinstallablePackages =
  [ mkPackageName "base"
  , mkPackageName "ghc-bignum"
  , mkPackageName "ghc-internal"
  , mkPackageName "ghc-prim"
  , mkPackageName "ghc"
  , mkPackageName "integer-gmp"
  , mkPackageName "integer-simple"
  , mkPackageName "template-haskell"
  ]

addSourcePackages
  :: [UnresolvedSourcePackage]
  -> DepResolverParams
  -> DepResolverParams
addSourcePackages pkgs params =
  params
    { depResolverSourcePkgIndex =
        foldl
          (flip PackageIndex.insert)
          (depResolverSourcePkgIndex params)
          pkgs
    }

hideInstalledPackagesSpecificBySourcePackageId
  :: [PackageId]
  -> DepResolverParams
  -> DepResolverParams
hideInstalledPackagesSpecificBySourcePackageId pkgids params =
  -- TODO: this should work using exclude constraints instead
  params
    { depResolverInstalledPkgIndex =
        foldl'
          (flip InstalledPackageIndex.deleteSourcePackageId)
          (depResolverInstalledPkgIndex params)
          pkgids
    }

hideInstalledPackagesAllVersions
  :: [PackageName]
  -> DepResolverParams
  -> DepResolverParams
hideInstalledPackagesAllVersions pkgnames params =
  -- TODO: this should work using exclude constraints instead
  params
    { depResolverInstalledPkgIndex =
        foldl'
          (flip InstalledPackageIndex.deletePackageName)
          (depResolverInstalledPkgIndex params)
          pkgnames
    }

-- | Remove upper bounds in dependencies using the policy specified by the
-- 'AllowNewer' argument (all/some/none).
--
-- Note: It's important to apply 'removeUpperBounds' after
-- 'addSourcePackages'. Otherwise, the packages inserted by
-- 'addSourcePackages' won't have upper bounds in dependencies relaxed.
removeUpperBounds :: AllowNewer -> DepResolverParams -> DepResolverParams
removeUpperBounds (AllowNewer relDeps) = removeBounds RelaxUpper relDeps

-- | Dual of 'removeUpperBounds'
removeLowerBounds :: AllowOlder -> DepResolverParams -> DepResolverParams
removeLowerBounds (AllowOlder relDeps) = removeBounds RelaxLower relDeps

data RelaxKind = RelaxLower | RelaxUpper

-- | Common internal implementation of 'removeLowerBounds'/'removeUpperBounds'
removeBounds :: RelaxKind -> RelaxDeps -> DepResolverParams -> DepResolverParams
removeBounds _ rd params | not (isRelaxDeps rd) = params -- no-op optimisation
removeBounds relKind relDeps params =
  params
    { depResolverSourcePkgIndex = sourcePkgIndex'
    }
  where
    sourcePkgIndex' :: PackageIndex.PackageIndex UnresolvedSourcePackage
    sourcePkgIndex' = relaxDeps <$> depResolverSourcePkgIndex params

    relaxDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage
    relaxDeps srcPkg =
      srcPkg
        { srcpkgDescription = relaxPackageDeps relKind relDeps (srcpkgDescription srcPkg)
        }

-- | Relax the dependencies of this package if needed.
--
-- Helper function used by 'removeBounds'
relaxPackageDeps
  :: RelaxKind
  -> RelaxDeps
  -> PD.GenericPackageDescription
  -> PD.GenericPackageDescription
relaxPackageDeps _ rd gpd | not (isRelaxDeps rd) = gpd -- subsumed by no-op case in 'removeBounds'
relaxPackageDeps relKind RelaxDepsAll gpd = PD.transformAllBuildDepends relaxAll gpd
  where
    relaxAll :: Dependency -> Dependency
    relaxAll (Dependency pkgName verRange cs) =
      Dependency pkgName (removeBound relKind RelaxDepModNone verRange) cs
relaxPackageDeps relKind (RelaxDepsSome depsToRelax0) gpd =
  PD.transformAllBuildDepends relaxSome gpd
  where
    thisPkgName = packageName gpd
    thisPkgId = packageId gpd
    depsToRelax = Map.fromList $ mapMaybe f depsToRelax0

    f :: RelaxedDep -> Maybe (RelaxDepSubject, RelaxDepMod)
    f (RelaxedDep scope rdm p) = case scope of
      RelaxDepScopeAll -> Just (p, rdm)
      RelaxDepScopePackage p0
        | p0 == thisPkgName -> Just (p, rdm)
        | otherwise -> Nothing
      RelaxDepScopePackageId p0
        | p0 == thisPkgId -> Just (p, rdm)
        | otherwise -> Nothing

    relaxSome :: Dependency -> Dependency
    relaxSome d@(Dependency depName verRange cs)
      | Just relMod <- Map.lookup RelaxDepSubjectAll depsToRelax =
          -- a '*'-subject acts absorbing, for consistency with
          -- the 'Semigroup RelaxDeps' instance
          Dependency depName (removeBound relKind relMod verRange) cs
      | Just relMod <- Map.lookup (RelaxDepSubjectPkg depName) depsToRelax =
          Dependency depName (removeBound relKind relMod verRange) cs
      | otherwise = d -- no-op

-- | Internal helper for 'relaxPackageDeps'
removeBound :: RelaxKind -> RelaxDepMod -> VersionRange -> VersionRange
removeBound RelaxLower RelaxDepModNone = removeLowerBound
removeBound RelaxUpper RelaxDepModNone = removeUpperBound
removeBound RelaxLower RelaxDepModCaret = transformCaretLower
removeBound RelaxUpper RelaxDepModCaret = transformCaretUpper

-- | Supply defaults for packages without explicit Setup dependencies
--
-- Note: It's important to apply 'addDefaultSetupDepends' after
-- 'addSourcePackages'. Otherwise, the packages inserted by
-- 'addSourcePackages' won't have upper bounds in dependencies relaxed.
addDefaultSetupDependencies
  :: (UnresolvedSourcePackage -> Maybe [Dependency])
  -> DepResolverParams
  -> DepResolverParams
addDefaultSetupDependencies defaultSetupDeps params =
  params
    { depResolverSourcePkgIndex =
        fmap applyDefaultSetupDeps (depResolverSourcePkgIndex params)
    }
  where
    applyDefaultSetupDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage
    applyDefaultSetupDeps srcpkg =
      srcpkg
        { srcpkgDescription =
            gpkgdesc
              { PD.packageDescription =
                  pkgdesc
                    { PD.setupBuildInfo =
                        case PD.setupBuildInfo pkgdesc of
                          Just sbi -> Just sbi
                          Nothing -> case defaultSetupDeps srcpkg of
                            Nothing -> Nothing
                            Just deps
                              | isCustom ->
                                  Just
                                    PD.SetupBuildInfo
                                      { PD.defaultSetupDepends = True
                                      , PD.setupDepends = deps
                                      }
                              | otherwise -> Nothing
                    }
              }
        }
      where
        isCustom = PD.buildType pkgdesc == PD.Custom || PD.buildType pkgdesc == PD.Hooks
        gpkgdesc = srcpkgDescription srcpkg
        pkgdesc = PD.packageDescription gpkgdesc

-- | If a package has a custom setup then we need to add a setup-depends
-- on Cabal.
addSetupCabalMinVersionConstraint
  :: Version
  -> DepResolverParams
  -> DepResolverParams
addSetupCabalMinVersionConstraint minVersion =
  addConstraints
    [ LabeledPackageConstraint
        ( PackageConstraint
            (ScopeAnySetupQualifier cabalPkgname)
            (PackagePropertyVersion $ orLaterVersion minVersion)
        )
        ConstraintSetupCabalMinVersion
    ]
  where
    cabalPkgname = mkPackageName "Cabal"

-- | Variant of 'addSetupCabalMinVersionConstraint' which sets an
-- upper bound on @setup.Cabal@ labeled with 'ConstraintSetupCabalMaxVersion'.
addSetupCabalMaxVersionConstraint
  :: Version
  -> DepResolverParams
  -> DepResolverParams
addSetupCabalMaxVersionConstraint maxVersion =
  addConstraints
    [ LabeledPackageConstraint
        ( PackageConstraint
            (ScopeAnySetupQualifier cabalPkgname)
            (PackagePropertyVersion $ earlierVersion maxVersion)
        )
        ConstraintSetupCabalMaxVersion
    ]
  where
    cabalPkgname = mkPackageName "Cabal"

-- | Add an a lower bound @setup.Cabal >= 3.13@ labeled with 'ConstraintSourceProfiledDynamic'
addSetupCabalProfiledDynamic
  :: DepResolverParams
  -> DepResolverParams
addSetupCabalProfiledDynamic =
  addConstraints
    [ LabeledPackageConstraint
        ( PackageConstraint
            (ScopeAnySetupQualifier cabalPkgname)
            (PackagePropertyVersion $ orLaterVersion (mkVersion [3, 13, 0]))
        )
        ConstraintSourceProfiledDynamic
    ]
  where
    cabalPkgname = mkPackageName "Cabal"

upgradeDependencies :: DepResolverParams -> DepResolverParams
upgradeDependencies = setPreferenceDefault PreferAllLatest

reinstallTargets :: DepResolverParams -> DepResolverParams
reinstallTargets params =
  hideInstalledPackagesAllVersions (Set.toList $ depResolverTargets params) params

-- | A basic solver policy on which all others are built.
basicInstallPolicy
  :: InstalledPackageIndex
  -> SourcePackageDb
  -> [PackageSpecifier UnresolvedSourcePackage]
  -> DepResolverParams
basicInstallPolicy
  installedPkgIndex
  (SourcePackageDb sourcePkgIndex sourcePkgPrefs)
  pkgSpecifiers =
    addPreferences
      [ PackageVersionPreference name ver
      | (name, ver) <- Map.toList sourcePkgPrefs
      ]
      . addConstraints
        (concatMap pkgSpecifierConstraints pkgSpecifiers)
      . addTargets
        (map pkgSpecifierTarget pkgSpecifiers)
      . hideInstalledPackagesSpecificBySourcePackageId
        [packageId pkg | SpecificSourcePackage pkg <- pkgSpecifiers]
      . addSourcePackages
        [pkg | SpecificSourcePackage pkg <- pkgSpecifiers]
      $ basicDepResolverParams
        installedPkgIndex
        sourcePkgIndex

-- | The policy used by all the standard commands, install, fetch, freeze etc
-- (but not the v2-build and related commands).
--
-- It extends the 'basicInstallPolicy' with a policy on setup deps.
standardInstallPolicy
  :: InstalledPackageIndex
  -> SourcePackageDb
  -> [PackageSpecifier UnresolvedSourcePackage]
  -> DepResolverParams
standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers =
  addDefaultSetupDependencies mkDefaultSetupDeps $
    basicInstallPolicy
      installedPkgIndex
      sourcePkgDb
      pkgSpecifiers
  where
    -- Force Cabal >= 1.24 dep when the package is affected by #3199.
    mkDefaultSetupDeps :: UnresolvedSourcePackage -> Maybe [Dependency]
    mkDefaultSetupDeps srcpkg
      | affected =
          Just [Dependency (mkPackageName "Cabal") (orLaterVersion $ mkVersion [1, 24]) mainLibSet]
      | otherwise = Nothing
      where
        gpkgdesc = srcpkgDescription srcpkg
        pkgdesc = PD.packageDescription gpkgdesc
        bt = PD.buildType pkgdesc
        affected = (bt == PD.Custom || bt == PD.Hooks) && hasBuildableFalse gpkgdesc

    -- Does this package contain any components with non-empty 'build-depends'
    -- and a 'buildable' field that could potentially be set to 'False'? False
    -- positives are possible.
    hasBuildableFalse :: PD.GenericPackageDescription -> Bool
    hasBuildableFalse gpkg =
      not (all alwaysTrue (zipWith PD.cOr buildableConditions noDepConditions))
      where
        buildableConditions = PD.extractConditions PD.buildable gpkg
        noDepConditions =
          PD.extractConditions
            (null . PD.targetBuildDepends)
            gpkg
        alwaysTrue (PD.Lit True) = True
        alwaysTrue _ = False

-- ------------------------------------------------------------

-- * Interface to the standard resolver

-- ------------------------------------------------------------

runSolver :: SolverConfig -> DependencyResolver UnresolvedPkgLoc
runSolver = modularResolver

-- | Run the dependency solver.
--
-- Since this is potentially an expensive operation, the result is wrapped in a
-- a 'Progress' structure that can be unfolded to provide progress information,
-- logging messages and the final result or an error.
resolveDependencies
  :: Platform
  -> CompilerInfo
  -> Maybe PkgConfigDb
  -> DepResolverParams
  -> Progress String String SolverInstallPlan
resolveDependencies platform comp pkgConfigDB params =
  Step (showDepResolverParams finalparams) $
    fmap (validateSolverResult platform comp indGoals) $
      runSolver
        ( SolverConfig
            reordGoals
            cntConflicts
            fineGrained
            minimize
            indGoals
            noReinstalls
            shadowing
            strFlags
            onlyConstrained_
            maxBkjumps
            enableBj
            solveExes
            order
            verbosity
            (PruneAfterFirstSuccess False)
        )
        platform
        comp
        installedPkgIndex
        sourcePkgIndex
        pkgConfigDB
        preferences
        constraints
        targets
  where
    finalparams@( DepResolverParams
                    targets
                    constraints
                    prefs
                    defpref
                    installedPkgIndex
                    sourcePkgIndex
                    reordGoals
                    cntConflicts
                    fineGrained
                    minimize
                    indGoals
                    noReinstalls
                    shadowing
                    strFlags
                    _allowBootLibs
                    onlyConstrained_
                    maxBkjumps
                    enableBj
                    solveExes
                    order
                    verbosity
                  ) =
        if asBool (depResolverAllowBootLibInstalls params)
          then params
          else dontInstallNonReinstallablePackages params

    preferences :: PackageName -> PackagePreferences
    preferences = interpretPackagesPreference targets defpref prefs

-- | Give an interpretation to the global 'PackagesPreference' as
--  specific per-package 'PackageVersionPreference'.
interpretPackagesPreference
  :: Set PackageName
  -> PackagesPreferenceDefault
  -> [PackagePreference]
  -> (PackageName -> PackagePreferences)
interpretPackagesPreference selected defaultPref prefs =
  \pkgname ->
    PackagePreferences
      (versionPref pkgname)
      (installPref pkgname)
      (stanzasPref pkgname)
  where
    versionPref :: PackageName -> [VersionRange]
    versionPref pkgname =
      fromMaybe [anyVersion] (Map.lookup pkgname versionPrefs)
    versionPrefs =
      Map.fromListWith
        (++)
        [ (pkgname, [pref])
        | PackageVersionPreference pkgname pref <- prefs
        ]

    installPref :: PackageName -> InstalledPreference
    installPref pkgname =
      fromMaybe (installPrefDefault pkgname) (Map.lookup pkgname installPrefs)
    installPrefs =
      Map.fromList
        [ (pkgname, pref)
        | PackageInstalledPreference pkgname pref <- prefs
        ]
    installPrefDefault = case defaultPref of
      PreferAllLatest -> const Preference.PreferLatest
      PreferAllOldest -> const Preference.PreferOldest
      PreferAllInstalled -> const Preference.PreferInstalled
      PreferLatestForSelected -> \pkgname ->
        -- When you say cabal install foo, what you really mean is, prefer the
        -- latest version of foo, but the installed version of everything else
        if pkgname `Set.member` selected
          then Preference.PreferLatest
          else Preference.PreferInstalled

    stanzasPref :: PackageName -> [OptionalStanza]
    stanzasPref pkgname =
      fromMaybe [] (Map.lookup pkgname stanzasPrefs)
    stanzasPrefs =
      Map.fromListWith
        (\a b -> nub (a ++ b))
        [ (pkgname, pref)
        | PackageStanzasPreference pkgname pref <- prefs
        ]

-- ------------------------------------------------------------

-- * Checking the result of the solver

-- ------------------------------------------------------------

-- | Make an install plan from the output of the dep resolver.
-- It checks that the plan is valid, or it's an error in the dep resolver.
validateSolverResult
  :: Platform
  -> CompilerInfo
  -> IndependentGoals
  -> [ResolverPackage UnresolvedPkgLoc]
  -> SolverInstallPlan
validateSolverResult platform comp indepGoals pkgs =
  case planPackagesProblems platform comp pkgs of
    [] -> case SolverInstallPlan.new indepGoals graph of
      Right plan -> plan
      Left problems -> error (formatPlanProblems problems)
    problems -> error (formatPkgProblems problems)
  where
    graph :: Graph.Graph (ResolverPackage UnresolvedPkgLoc)
    graph = Graph.fromDistinctList pkgs

    formatPkgProblems :: [PlanPackageProblem] -> String
    formatPkgProblems = formatProblemMessage . map showPlanPackageProblem
    formatPlanProblems :: [SolverInstallPlan.SolverPlanProblem] -> String
    formatPlanProblems = formatProblemMessage . map SolverInstallPlan.showPlanProblem

    formatProblemMessage problems =
      unlines $
        "internal error: could not construct a valid install plan."
          : "The proposed (invalid) plan contained the following problems:"
          : problems
          ++ "Proposed plan:"
          : [SolverInstallPlan.showPlanIndex pkgs]

data PlanPackageProblem
  = InvalidConfiguredPackage
      (SolverPackage UnresolvedPkgLoc)
      [PackageProblem]
  | DuplicatePackageSolverId SolverId [ResolverPackage UnresolvedPkgLoc]

showPlanPackageProblem :: PlanPackageProblem -> String
showPlanPackageProblem (InvalidConfiguredPackage pkg packageProblems) =
  "Package "
    ++ prettyShow (packageId pkg)
    ++ " has an invalid configuration, in particular:\n"
    ++ unlines
      [ "  " ++ showPackageProblem problem
      | problem <- packageProblems
      ]
showPlanPackageProblem (DuplicatePackageSolverId pid dups) =
  "Package "
    ++ prettyShow (packageId pid)
    ++ " has "
    ++ show (length dups)
    ++ " duplicate instances."

planPackagesProblems
  :: Platform
  -> CompilerInfo
  -> [ResolverPackage UnresolvedPkgLoc]
  -> [PlanPackageProblem]
planPackagesProblems platform cinfo pkgs =
  [ InvalidConfiguredPackage pkg packageProblems
  | Configured pkg <- pkgs
  , let packageProblems = configuredPackageProblems platform cinfo pkg
  , not (null packageProblems)
  ]
    ++ [ DuplicatePackageSolverId (Graph.nodeKey aDup) dups
       | dups <- duplicatesBy (comparing Graph.nodeKey) pkgs
       , aDup <- case dups of
          [] -> []
          (ad : _) -> [ad]
       ]

data PackageProblem
  = DuplicateFlag PD.FlagName
  | MissingFlag PD.FlagName
  | ExtraFlag PD.FlagName
  | DuplicateDeps [PackageId]
  | MissingDep Dependency
  | ExtraDep PackageId
  | InvalidDep Dependency PackageId

showPackageProblem :: PackageProblem -> String
showPackageProblem (DuplicateFlag flag) =
  "duplicate flag in the flag assignment: " ++ PD.unFlagName flag
showPackageProblem (MissingFlag flag) =
  "missing an assignment for the flag: " ++ PD.unFlagName flag
showPackageProblem (ExtraFlag flag) =
  "extra flag given that is not used by the package: " ++ PD.unFlagName flag
showPackageProblem (DuplicateDeps pkgids) =
  "duplicate packages specified as selected dependencies: "
    ++ intercalate ", " (map prettyShow pkgids)
showPackageProblem (MissingDep dep) =
  "the package has a dependency "
    ++ prettyShow dep
    ++ " but no package has been selected to satisfy it."
showPackageProblem (ExtraDep pkgid) =
  "the package configuration specifies "
    ++ prettyShow pkgid
    ++ " but (with the given flag assignment) the package does not actually"
    ++ " depend on any version of that package."
showPackageProblem (InvalidDep dep pkgid) =
  "the package depends on "
    ++ prettyShow dep
    ++ " but the configuration specifies "
    ++ prettyShow pkgid
    ++ " which does not satisfy the dependency."

-- | A 'ConfiguredPackage' is valid if the flag assignment is total and if
-- in the configuration given by the flag assignment, all the package
-- dependencies are satisfied by the specified packages.
configuredPackageProblems
  :: Platform
  -> CompilerInfo
  -> SolverPackage UnresolvedPkgLoc
  -> [PackageProblem]
configuredPackageProblems
  platform
  cinfo
  (SolverPackage pkg specifiedFlags stanzas specifiedDeps0 _specifiedExeDeps') =
    [ DuplicateFlag flag
    | flag <- PD.findDuplicateFlagAssignments specifiedFlags
    ]
      ++ [MissingFlag flag | OnlyInLeft flag <- mergedFlags]
      ++ [ExtraFlag flag | OnlyInRight flag <- mergedFlags]
      ++ [ DuplicateDeps pkgs
         | pkgs <-
            CD.nonSetupDeps
              ( fmap
                  (duplicatesBy (comparing packageName))
                  specifiedDeps1
              )
         ]
      ++ [MissingDep dep | OnlyInLeft dep <- mergedDeps]
      ++ [ExtraDep pkgid | OnlyInRight pkgid <- mergedDeps]
      ++ [ InvalidDep dep pkgid | InBoth dep pkgid <- mergedDeps, not (packageSatisfiesDependency pkgid dep)
         ]
    where
      -- TODO: sanity tests on executable deps

      thisPkgName :: PackageName
      thisPkgName = packageName (srcpkgDescription pkg)

      specifiedDeps1 :: ComponentDeps [PackageId]
      specifiedDeps1 = fmap (map solverSrcId) specifiedDeps0

      specifiedDeps :: [PackageId]
      specifiedDeps = CD.flatDeps specifiedDeps1

      mergedFlags :: [MergeResult PD.FlagName PD.FlagName]
      mergedFlags =
        mergeBy
          compare
          (sort $ map PD.flagName (PD.genPackageFlags (srcpkgDescription pkg)))
          (sort $ map fst (PD.unFlagAssignment specifiedFlags)) -- TODO
      packageSatisfiesDependency :: PackageIdentifier -> Dependency -> Bool
      packageSatisfiesDependency
        (PackageIdentifier name version)
        (Dependency name' versionRange _) =
          assert (name == name') $
            version `withinRange` versionRange

      dependencyName (Dependency name _ _) = name

      mergedDeps :: [MergeResult Dependency PackageId]
      mergedDeps = mergeDeps requiredDeps specifiedDeps

      mergeDeps
        :: [Dependency]
        -> [PackageId]
        -> [MergeResult Dependency PackageId]
      mergeDeps required specified =
        let sortNubOn f = nubBy ((==) `on` f) . sortBy (compare `on` f)
         in mergeBy
              (\dep pkgid -> dependencyName dep `compare` packageName pkgid)
              (sortNubOn dependencyName required)
              (sortNubOn packageName specified)

      compSpec = enableStanzas stanzas
      -- TODO: It would be nicer to use ComponentDeps here so we can be more
      -- precise in our checks. In fact, this no longer relies on buildDepends and
      -- thus should be easier to fix. As long as we _do_ use a flat list here, we
      -- have to allow for duplicates when we fold specifiedDeps; once we have
      -- proper ComponentDeps here we should get rid of the `nubOn` in
      -- `mergeDeps`.
      requiredDeps :: [Dependency]
      requiredDeps =
        -- TODO: use something lower level than finalizePD
        case finalizePD
          specifiedFlags
          compSpec
          (const Satisfied)
          platform
          cinfo
          []
          (srcpkgDescription pkg) of
          Right (resolvedPkg, _) ->
            -- we filter self/internal dependencies. They are still there.
            -- This is INCORRECT.
            --
            -- If we had per-component solver, it would make this unnecessary,
            -- but no finalizePDs picks components we are not building, eg. exes.
            -- See #3775
            --
            filter
              ((/= thisPkgName) . dependencyName)
              (PD.enabledBuildDepends resolvedPkg compSpec)
              ++ maybe [] PD.setupDepends (PD.setupBuildInfo resolvedPkg)
          Left _ ->
            error "configuredPackageInvalidDeps internal error"

-- ------------------------------------------------------------

-- * Simple resolver that ignores dependencies

-- ------------------------------------------------------------

-- | A simplistic method of resolving a list of target package names to
-- available packages.
--
-- Specifically, it does not consider package dependencies at all. Unlike
-- 'resolveDependencies', no attempt is made to ensure that the selected
-- packages have dependencies that are satisfiable or consistent with
-- each other.
--
-- It is suitable for tasks such as selecting packages to download for user
-- inspection. It is not suitable for selecting packages to install.
--
-- Note: if no installed package index is available, it is OK to pass 'mempty'.
-- It simply means preferences for installed packages will be ignored.
resolveWithoutDependencies
  :: DepResolverParams
  -> Either [ResolveNoDepsError] [UnresolvedSourcePackage]
resolveWithoutDependencies
  ( DepResolverParams
      targets
      constraints
      prefs
      defpref
      installedPkgIndex
      sourcePkgIndex
      _reorderGoals
      _countConflicts
      _fineGrained
      _minimizeConflictSet
      _indGoals
      _avoidReinstalls
      _shadowing
      _strFlags
      _maxBjumps
      _enableBj
      _solveExes
      _allowBootLibInstalls
      _onlyConstrained
      _order
      _verbosity
    ) =
    collectEithers $ map selectPackage (Set.toList targets)
    where
      selectPackage :: PackageName -> Either ResolveNoDepsError UnresolvedSourcePackage
      selectPackage pkgname
        | null choices = Left $! ResolveUnsatisfiable pkgname requiredVersions
        | otherwise = Right $! maximumBy bestByPrefs choices
        where
          -- Constraints
          requiredVersions :: VersionRange
          requiredVersions = packageConstraints pkgname
          choices :: [UnresolvedSourcePackage]
          choices =
            PackageIndex.lookupDependency
              sourcePkgIndex
              pkgname
              requiredVersions

          -- Preferences
          PackagePreferences preferredVersions preferInstalled _ =
            packagePreferences pkgname

          bestByPrefs :: UnresolvedSourcePackage -> UnresolvedSourcePackage -> Ordering
          bestByPrefs = comparing $ \pkg ->
            (installPref pkg, versionPref pkg, packageVersion pkg)
          installPref :: UnresolvedSourcePackage -> Bool
          installPref = case preferInstalled of
            Preference.PreferLatest -> const False
            Preference.PreferOldest -> const False
            Preference.PreferInstalled ->
              not
                . null
                . InstalledPackageIndex.lookupSourcePackageId
                  installedPkgIndex
                . packageId
          versionPref :: Package a => a -> Int
          versionPref pkg =
            length . filter (packageVersion pkg `withinRange`) $
              preferredVersions

      packageConstraints :: PackageName -> VersionRange
      packageConstraints pkgname =
        Map.findWithDefault anyVersion pkgname packageVersionConstraintMap
      packageVersionConstraintMap :: Map PackageName VersionRange
      packageVersionConstraintMap =
        let pcs = map unlabelPackageConstraint constraints
         in Map.fromList
              [ (scopeToPackageName scope, range)
              | PackageConstraint
                  scope
                  (PackagePropertyVersion range) <-
                  pcs
              ]

      packagePreferences :: PackageName -> PackagePreferences
      packagePreferences = interpretPackagesPreference targets defpref prefs

collectEithers :: [Either a b] -> Either [a] [b]
collectEithers = collect . partitionEithers
  where
    collect ([], xs) = Right xs
    collect (errs, _) = Left errs

-- | Errors for 'resolveWithoutDependencies'.
data ResolveNoDepsError
  = -- | A package name which cannot be resolved to a specific package.
    -- Also gives the constraint on the version and whether there was
    -- a constraint on the package being installed.
    ResolveUnsatisfiable PackageName VersionRange

instance Show ResolveNoDepsError where
  show (ResolveUnsatisfiable name ver) =
    "There is no available version of "
      ++ prettyShow name
      ++ " that satisfies "
      ++ prettyShow (simplifyVersionRange ver)