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

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

-- |
-- 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
  ) 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.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
  { DepResolverParams -> Set PackageName
depResolverTargets :: Set PackageName
  , DepResolverParams -> [LabeledPackageConstraint]
depResolverConstraints :: [LabeledPackageConstraint]
  , DepResolverParams -> [PackagePreference]
depResolverPreferences :: [PackagePreference]
  , DepResolverParams -> PackagesPreferenceDefault
depResolverPreferenceDefault :: PackagesPreferenceDefault
  , DepResolverParams -> InstalledPackageIndex
depResolverInstalledPkgIndex :: InstalledPackageIndex
  , DepResolverParams -> PackageIndex UnresolvedSourcePackage
depResolverSourcePkgIndex :: PackageIndex.PackageIndex UnresolvedSourcePackage
  , DepResolverParams -> ReorderGoals
depResolverReorderGoals :: ReorderGoals
  , DepResolverParams -> CountConflicts
depResolverCountConflicts :: CountConflicts
  , DepResolverParams -> FineGrainedConflicts
depResolverFineGrainedConflicts :: FineGrainedConflicts
  , DepResolverParams -> MinimizeConflictSet
depResolverMinimizeConflictSet :: MinimizeConflictSet
  , DepResolverParams -> IndependentGoals
depResolverIndependentGoals :: IndependentGoals
  , DepResolverParams -> AvoidReinstalls
depResolverAvoidReinstalls :: AvoidReinstalls
  , DepResolverParams -> ShadowPkgs
depResolverShadowPkgs :: ShadowPkgs
  , DepResolverParams -> StrongFlags
depResolverStrongFlags :: StrongFlags
  , DepResolverParams -> AllowBootLibInstalls
depResolverAllowBootLibInstalls :: AllowBootLibInstalls
  -- ^ Whether to allow base and its dependencies to be installed.
  , DepResolverParams -> OnlyConstrained
depResolverOnlyConstrained :: OnlyConstrained
  -- ^ Whether to only allow explicitly constrained packages plus
  -- goals or to allow any package.
  , DepResolverParams -> Maybe Int
depResolverMaxBackjumps :: Maybe Int
  , DepResolverParams -> EnableBackjumping
depResolverEnableBackjumping :: EnableBackjumping
  , DepResolverParams -> SolveExecutables
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.
  , DepResolverParams
-> Maybe (Variable QPN -> Variable QPN -> Ordering)
depResolverGoalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering)
  -- ^ Function to override the solver's goal-ordering heuristics.
  , DepResolverParams -> Verbosity
depResolverVerbosity :: Verbosity
  }

showDepResolverParams :: DepResolverParams -> String
showDepResolverParams :: DepResolverParams -> String
showDepResolverParams DepResolverParams
p =
  String
"targets: "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((PackageName -> String) -> [PackageName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PackageName -> String
forall a. Pretty a => a -> String
prettyShow ([PackageName] -> [String]) -> [PackageName] -> [String]
forall a b. (a -> b) -> a -> b
$ Set PackageName -> [PackageName]
forall a. Set a -> [a]
Set.toList (DepResolverParams -> Set PackageName
depResolverTargets DepResolverParams
p))
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nconstraints: "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ (LabeledPackageConstraint -> String)
-> [LabeledPackageConstraint] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
      ((String
"\n  " String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String)
-> (LabeledPackageConstraint -> String)
-> LabeledPackageConstraint
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LabeledPackageConstraint -> String
showLabeledConstraint)
      (DepResolverParams -> [LabeledPackageConstraint]
depResolverConstraints DepResolverParams
p)
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\npreferences: "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ (PackagePreference -> String) -> [PackagePreference] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
      ((String
"\n  " String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String)
-> (PackagePreference -> String) -> PackagePreference -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackagePreference -> String
showPackagePreference)
      (DepResolverParams -> [PackagePreference]
depResolverPreferences DepResolverParams
p)
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nstrategy: "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackagesPreferenceDefault -> String
forall a. Show a => a -> String
show (DepResolverParams -> PackagesPreferenceDefault
depResolverPreferenceDefault DepResolverParams
p)
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nreorder goals: "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show (ReorderGoals -> Bool
forall a. BooleanFlag a => a -> Bool
asBool (DepResolverParams -> ReorderGoals
depResolverReorderGoals DepResolverParams
p))
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\ncount conflicts: "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show (CountConflicts -> Bool
forall a. BooleanFlag a => a -> Bool
asBool (DepResolverParams -> CountConflicts
depResolverCountConflicts DepResolverParams
p))
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nfine grained conflicts: "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show (FineGrainedConflicts -> Bool
forall a. BooleanFlag a => a -> Bool
asBool (DepResolverParams -> FineGrainedConflicts
depResolverFineGrainedConflicts DepResolverParams
p))
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nminimize conflict set: "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show (MinimizeConflictSet -> Bool
forall a. BooleanFlag a => a -> Bool
asBool (DepResolverParams -> MinimizeConflictSet
depResolverMinimizeConflictSet DepResolverParams
p))
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nindependent goals: "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show (IndependentGoals -> Bool
forall a. BooleanFlag a => a -> Bool
asBool (DepResolverParams -> IndependentGoals
depResolverIndependentGoals DepResolverParams
p))
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\navoid reinstalls: "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show (AvoidReinstalls -> Bool
forall a. BooleanFlag a => a -> Bool
asBool (DepResolverParams -> AvoidReinstalls
depResolverAvoidReinstalls DepResolverParams
p))
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nshadow packages: "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show (ShadowPkgs -> Bool
forall a. BooleanFlag a => a -> Bool
asBool (DepResolverParams -> ShadowPkgs
depResolverShadowPkgs DepResolverParams
p))
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nstrong flags: "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show (StrongFlags -> Bool
forall a. BooleanFlag a => a -> Bool
asBool (DepResolverParams -> StrongFlags
depResolverStrongFlags DepResolverParams
p))
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nallow boot library installs: "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show (AllowBootLibInstalls -> Bool
forall a. BooleanFlag a => a -> Bool
asBool (DepResolverParams -> AllowBootLibInstalls
depResolverAllowBootLibInstalls DepResolverParams
p))
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nonly constrained packages: "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ OnlyConstrained -> String
forall a. Show a => a -> String
show (DepResolverParams -> OnlyConstrained
depResolverOnlyConstrained DepResolverParams
p)
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nmax backjumps: "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> (Int -> String) -> Maybe Int -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      String
"infinite"
      Int -> String
forall a. Show a => a -> String
show
      (DepResolverParams -> Maybe Int
depResolverMaxBackjumps DepResolverParams
p)
  where
    showLabeledConstraint :: LabeledPackageConstraint -> String
    showLabeledConstraint :: LabeledPackageConstraint -> String
showLabeledConstraint (LabeledPackageConstraint PackageConstraint
pc ConstraintSource
src) =
      PackageConstraint -> String
showPackageConstraint PackageConstraint
pc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ConstraintSource -> String
showConstraintSource ConstraintSource
src String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

-- | 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 :: PackagePreference -> String
showPackagePreference (PackageVersionPreference PackageName
pn VersionRange
vr) =
  PackageName -> String
forall a. Pretty a => a -> String
prettyShow PackageName
pn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ VersionRange -> String
forall a. Pretty a => a -> String
prettyShow (VersionRange -> VersionRange
simplifyVersionRange VersionRange
vr)
showPackagePreference (PackageInstalledPreference PackageName
pn InstalledPreference
ip) =
  PackageName -> String
forall a. Pretty a => a -> String
prettyShow PackageName
pn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ InstalledPreference -> String
forall a. Show a => a -> String
show InstalledPreference
ip
showPackagePreference (PackageStanzasPreference PackageName
pn [OptionalStanza]
st) =
  PackageName -> String
forall a. Pretty a => a -> String
prettyShow PackageName
pn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [OptionalStanza] -> String
forall a. Show a => a -> String
show [OptionalStanza]
st

basicDepResolverParams
  :: InstalledPackageIndex
  -> PackageIndex.PackageIndex UnresolvedSourcePackage
  -> DepResolverParams
basicDepResolverParams :: InstalledPackageIndex
-> PackageIndex UnresolvedSourcePackage -> DepResolverParams
basicDepResolverParams InstalledPackageIndex
installedPkgIndex PackageIndex UnresolvedSourcePackage
sourcePkgIndex =
  DepResolverParams
    { depResolverTargets :: Set PackageName
depResolverTargets = Set PackageName
forall a. Set a
Set.empty
    , depResolverConstraints :: [LabeledPackageConstraint]
depResolverConstraints = []
    , depResolverPreferences :: [PackagePreference]
depResolverPreferences = []
    , depResolverPreferenceDefault :: PackagesPreferenceDefault
depResolverPreferenceDefault = PackagesPreferenceDefault
PreferLatestForSelected
    , depResolverInstalledPkgIndex :: InstalledPackageIndex
depResolverInstalledPkgIndex = InstalledPackageIndex
installedPkgIndex
    , depResolverSourcePkgIndex :: PackageIndex UnresolvedSourcePackage
depResolverSourcePkgIndex = PackageIndex UnresolvedSourcePackage
sourcePkgIndex
    , depResolverReorderGoals :: ReorderGoals
depResolverReorderGoals = Bool -> ReorderGoals
ReorderGoals Bool
False
    , depResolverCountConflicts :: CountConflicts
depResolverCountConflicts = Bool -> CountConflicts
CountConflicts Bool
True
    , depResolverFineGrainedConflicts :: FineGrainedConflicts
depResolverFineGrainedConflicts = Bool -> FineGrainedConflicts
FineGrainedConflicts Bool
True
    , depResolverMinimizeConflictSet :: MinimizeConflictSet
depResolverMinimizeConflictSet = Bool -> MinimizeConflictSet
MinimizeConflictSet Bool
False
    , depResolverIndependentGoals :: IndependentGoals
depResolverIndependentGoals = Bool -> IndependentGoals
IndependentGoals Bool
False
    , depResolverAvoidReinstalls :: AvoidReinstalls
depResolverAvoidReinstalls = Bool -> AvoidReinstalls
AvoidReinstalls Bool
False
    , depResolverShadowPkgs :: ShadowPkgs
depResolverShadowPkgs = Bool -> ShadowPkgs
ShadowPkgs Bool
False
    , depResolverStrongFlags :: StrongFlags
depResolverStrongFlags = Bool -> StrongFlags
StrongFlags Bool
False
    , depResolverAllowBootLibInstalls :: AllowBootLibInstalls
depResolverAllowBootLibInstalls = Bool -> AllowBootLibInstalls
AllowBootLibInstalls Bool
False
    , depResolverOnlyConstrained :: OnlyConstrained
depResolverOnlyConstrained = OnlyConstrained
OnlyConstrainedNone
    , depResolverMaxBackjumps :: Maybe Int
depResolverMaxBackjumps = Maybe Int
forall a. Maybe a
Nothing
    , depResolverEnableBackjumping :: EnableBackjumping
depResolverEnableBackjumping = Bool -> EnableBackjumping
EnableBackjumping Bool
True
    , depResolverSolveExecutables :: SolveExecutables
depResolverSolveExecutables = Bool -> SolveExecutables
SolveExecutables Bool
True
    , depResolverGoalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering)
depResolverGoalOrder = Maybe (Variable QPN -> Variable QPN -> Ordering)
forall a. Maybe a
Nothing
    , depResolverVerbosity :: Verbosity
depResolverVerbosity = Verbosity
normal
    }

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

-- | Some packages are specific to a given compiler version and should never be
-- reinstalled.
dontInstallNonReinstallablePackages :: DepResolverParams -> DepResolverParams
dontInstallNonReinstallablePackages :: DepResolverParams -> DepResolverParams
dontInstallNonReinstallablePackages DepResolverParams
params =
  [LabeledPackageConstraint]
-> DepResolverParams -> DepResolverParams
addConstraints [LabeledPackageConstraint]
extraConstraints DepResolverParams
params
  where
    extraConstraints :: [LabeledPackageConstraint]
extraConstraints =
      [ PackageConstraint -> ConstraintSource -> LabeledPackageConstraint
LabeledPackageConstraint
        (ConstraintScope -> PackageProperty -> PackageConstraint
PackageConstraint (PackageName -> ConstraintScope
ScopeAnyQualifier PackageName
pkgname) PackageProperty
PackagePropertyInstalled)
        ConstraintSource
ConstraintSourceNonReinstallablePackage
      | PackageName
pkgname <- [PackageName]
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 :: [PackageName]
nonReinstallablePackages =
  [ String -> PackageName
mkPackageName String
"base"
  , String -> PackageName
mkPackageName String
"ghc-bignum"
  , String -> PackageName
mkPackageName String
"ghc-internal"
  , String -> PackageName
mkPackageName String
"ghc-prim"
  , String -> PackageName
mkPackageName String
"ghc"
  , String -> PackageName
mkPackageName String
"integer-gmp"
  , String -> PackageName
mkPackageName String
"integer-simple"
  , String -> PackageName
mkPackageName String
"template-haskell"
  ]

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

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

hideInstalledPackagesAllVersions
  :: [PackageName]
  -> DepResolverParams
  -> DepResolverParams
hideInstalledPackagesAllVersions :: [PackageName] -> DepResolverParams -> DepResolverParams
hideInstalledPackagesAllVersions [PackageName]
pkgnames DepResolverParams
params =
  -- TODO: this should work using exclude constraints instead
  DepResolverParams
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 -> DepResolverParams -> DepResolverParams
removeUpperBounds (AllowNewer RelaxDeps
relDeps) = RelaxKind -> RelaxDeps -> DepResolverParams -> DepResolverParams
removeBounds RelaxKind
RelaxUpper RelaxDeps
relDeps

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

data RelaxKind = RelaxLower | RelaxUpper

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

    relaxDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage
    relaxDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage
relaxDeps UnresolvedSourcePackage
srcPkg =
      UnresolvedSourcePackage
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 :: RelaxKind
-> RelaxDeps
-> GenericPackageDescription
-> GenericPackageDescription
relaxPackageDeps RelaxKind
_ RelaxDeps
rd GenericPackageDescription
gpd | Bool -> Bool
not (RelaxDeps -> Bool
isRelaxDeps RelaxDeps
rd) = GenericPackageDescription
gpd -- subsumed by no-op case in 'removeBounds'
relaxPackageDeps RelaxKind
relKind RelaxDeps
RelaxDepsAll GenericPackageDescription
gpd = (Dependency -> Dependency)
-> GenericPackageDescription -> GenericPackageDescription
PD.transformAllBuildDepends Dependency -> Dependency
relaxAll GenericPackageDescription
gpd
  where
    relaxAll :: Dependency -> Dependency
    relaxAll :: Dependency -> Dependency
relaxAll (Dependency PackageName
pkgName VersionRange
verRange NonEmptySet LibraryName
cs) =
      PackageName
-> VersionRange -> NonEmptySet LibraryName -> Dependency
Dependency PackageName
pkgName (RelaxKind -> RelaxDepMod -> VersionRange -> VersionRange
removeBound RelaxKind
relKind RelaxDepMod
RelaxDepModNone VersionRange
verRange) NonEmptySet LibraryName
cs
relaxPackageDeps RelaxKind
relKind (RelaxDepsSome [RelaxedDep]
depsToRelax0) GenericPackageDescription
gpd =
  (Dependency -> Dependency)
-> GenericPackageDescription -> GenericPackageDescription
PD.transformAllBuildDepends Dependency -> Dependency
relaxSome GenericPackageDescription
gpd
  where
    thisPkgName :: PackageName
thisPkgName = GenericPackageDescription -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName GenericPackageDescription
gpd
    thisPkgId :: PackageId
thisPkgId = GenericPackageDescription -> PackageId
forall pkg. Package pkg => pkg -> PackageId
packageId GenericPackageDescription
gpd
    depsToRelax :: Map RelaxDepSubject RelaxDepMod
depsToRelax = [(RelaxDepSubject, RelaxDepMod)] -> Map RelaxDepSubject RelaxDepMod
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(RelaxDepSubject, RelaxDepMod)]
 -> Map RelaxDepSubject RelaxDepMod)
-> [(RelaxDepSubject, RelaxDepMod)]
-> Map RelaxDepSubject RelaxDepMod
forall a b. (a -> b) -> a -> b
$ (RelaxedDep -> Maybe (RelaxDepSubject, RelaxDepMod))
-> [RelaxedDep] -> [(RelaxDepSubject, RelaxDepMod)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe RelaxedDep -> Maybe (RelaxDepSubject, RelaxDepMod)
f [RelaxedDep]
depsToRelax0

    f :: RelaxedDep -> Maybe (RelaxDepSubject, RelaxDepMod)
    f :: RelaxedDep -> Maybe (RelaxDepSubject, RelaxDepMod)
f (RelaxedDep RelaxDepScope
scope RelaxDepMod
rdm RelaxDepSubject
p) = case RelaxDepScope
scope of
      RelaxDepScope
RelaxDepScopeAll -> (RelaxDepSubject, RelaxDepMod)
-> Maybe (RelaxDepSubject, RelaxDepMod)
forall a. a -> Maybe a
Just (RelaxDepSubject
p, RelaxDepMod
rdm)
      RelaxDepScopePackage PackageName
p0
        | PackageName
p0 PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== PackageName
thisPkgName -> (RelaxDepSubject, RelaxDepMod)
-> Maybe (RelaxDepSubject, RelaxDepMod)
forall a. a -> Maybe a
Just (RelaxDepSubject
p, RelaxDepMod
rdm)
        | Bool
otherwise -> Maybe (RelaxDepSubject, RelaxDepMod)
forall a. Maybe a
Nothing
      RelaxDepScopePackageId PackageId
p0
        | PackageId
p0 PackageId -> PackageId -> Bool
forall a. Eq a => a -> a -> Bool
== PackageId
thisPkgId -> (RelaxDepSubject, RelaxDepMod)
-> Maybe (RelaxDepSubject, RelaxDepMod)
forall a. a -> Maybe a
Just (RelaxDepSubject
p, RelaxDepMod
rdm)
        | Bool
otherwise -> Maybe (RelaxDepSubject, RelaxDepMod)
forall a. Maybe a
Nothing

    relaxSome :: Dependency -> Dependency
    relaxSome :: Dependency -> Dependency
relaxSome d :: Dependency
d@(Dependency PackageName
depName VersionRange
verRange NonEmptySet LibraryName
cs)
      | Just RelaxDepMod
relMod <- RelaxDepSubject
-> Map RelaxDepSubject RelaxDepMod -> Maybe RelaxDepMod
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup RelaxDepSubject
RelaxDepSubjectAll Map RelaxDepSubject RelaxDepMod
depsToRelax =
          -- a '*'-subject acts absorbing, for consistency with
          -- the 'Semigroup RelaxDeps' instance
          PackageName
-> VersionRange -> NonEmptySet LibraryName -> Dependency
Dependency PackageName
depName (RelaxKind -> RelaxDepMod -> VersionRange -> VersionRange
removeBound RelaxKind
relKind RelaxDepMod
relMod VersionRange
verRange) NonEmptySet LibraryName
cs
      | Just RelaxDepMod
relMod <- RelaxDepSubject
-> Map RelaxDepSubject RelaxDepMod -> Maybe RelaxDepMod
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (PackageName -> RelaxDepSubject
RelaxDepSubjectPkg PackageName
depName) Map RelaxDepSubject RelaxDepMod
depsToRelax =
          PackageName
-> VersionRange -> NonEmptySet LibraryName -> Dependency
Dependency PackageName
depName (RelaxKind -> RelaxDepMod -> VersionRange -> VersionRange
removeBound RelaxKind
relKind RelaxDepMod
relMod VersionRange
verRange) NonEmptySet LibraryName
cs
      | Bool
otherwise = Dependency
d -- no-op

-- | Internal helper for 'relaxPackageDeps'
removeBound :: RelaxKind -> RelaxDepMod -> VersionRange -> VersionRange
removeBound :: RelaxKind -> RelaxDepMod -> VersionRange -> VersionRange
removeBound RelaxKind
RelaxLower RelaxDepMod
RelaxDepModNone = VersionRange -> VersionRange
removeLowerBound
removeBound RelaxKind
RelaxUpper RelaxDepMod
RelaxDepModNone = VersionRange -> VersionRange
removeUpperBound
removeBound RelaxKind
RelaxLower RelaxDepMod
RelaxDepModCaret = VersionRange -> VersionRange
transformCaretLower
removeBound RelaxKind
RelaxUpper RelaxDepMod
RelaxDepModCaret = VersionRange -> VersionRange
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 :: (UnresolvedSourcePackage -> Maybe [Dependency])
-> DepResolverParams -> DepResolverParams
addDefaultSetupDependencies UnresolvedSourcePackage -> Maybe [Dependency]
defaultSetupDeps DepResolverParams
params =
  DepResolverParams
params
    { depResolverSourcePkgIndex =
        fmap applyDefaultSetupDeps (depResolverSourcePkgIndex params)
    }
  where
    applyDefaultSetupDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage
    applyDefaultSetupDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage
applyDefaultSetupDeps UnresolvedSourcePackage
srcpkg =
      UnresolvedSourcePackage
srcpkg
        { srcpkgDescription =
            gpkgdesc
              { PD.packageDescription =
                  pkgdesc
                    { PD.setupBuildInfo =
                        case PD.setupBuildInfo pkgdesc of
                          Just SetupBuildInfo
sbi -> SetupBuildInfo -> Maybe SetupBuildInfo
forall a. a -> Maybe a
Just SetupBuildInfo
sbi
                          Maybe SetupBuildInfo
Nothing -> case UnresolvedSourcePackage -> Maybe [Dependency]
defaultSetupDeps UnresolvedSourcePackage
srcpkg of
                            Maybe [Dependency]
Nothing -> Maybe SetupBuildInfo
forall a. Maybe a
Nothing
                            Just [Dependency]
deps
                              | Bool
isCustom ->
                                  SetupBuildInfo -> Maybe SetupBuildInfo
forall a. a -> Maybe a
Just
                                    PD.SetupBuildInfo
                                      { defaultSetupDepends :: Bool
PD.defaultSetupDepends = Bool
True
                                      , setupDepends :: [Dependency]
PD.setupDepends = [Dependency]
deps
                                      }
                              | Bool
otherwise -> Maybe SetupBuildInfo
forall a. Maybe a
Nothing
                    }
              }
        }
      where
        isCustom :: Bool
isCustom = PackageDescription -> BuildType
PD.buildType PackageDescription
pkgdesc BuildType -> BuildType -> Bool
forall a. Eq a => a -> a -> Bool
== BuildType
PD.Custom
        gpkgdesc :: GenericPackageDescription
gpkgdesc = UnresolvedSourcePackage -> GenericPackageDescription
forall loc. SourcePackage loc -> GenericPackageDescription
srcpkgDescription UnresolvedSourcePackage
srcpkg
        pkgdesc :: PackageDescription
pkgdesc = GenericPackageDescription -> PackageDescription
PD.packageDescription GenericPackageDescription
gpkgdesc

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

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

upgradeDependencies :: DepResolverParams -> DepResolverParams
upgradeDependencies :: DepResolverParams -> DepResolverParams
upgradeDependencies = PackagesPreferenceDefault -> DepResolverParams -> DepResolverParams
setPreferenceDefault PackagesPreferenceDefault
PreferAllLatest

reinstallTargets :: DepResolverParams -> DepResolverParams
reinstallTargets :: DepResolverParams -> DepResolverParams
reinstallTargets DepResolverParams
params =
  [PackageName] -> DepResolverParams -> DepResolverParams
hideInstalledPackagesAllVersions (Set PackageName -> [PackageName]
forall a. Set a -> [a]
Set.toList (Set PackageName -> [PackageName])
-> Set PackageName -> [PackageName]
forall a b. (a -> b) -> a -> b
$ DepResolverParams -> Set PackageName
depResolverTargets DepResolverParams
params) DepResolverParams
params

-- | A basic solver policy on which all others are built.
basicInstallPolicy
  :: InstalledPackageIndex
  -> SourcePackageDb
  -> [PackageSpecifier UnresolvedSourcePackage]
  -> DepResolverParams
basicInstallPolicy :: InstalledPackageIndex
-> SourcePackageDb
-> [PackageSpecifier UnresolvedSourcePackage]
-> DepResolverParams
basicInstallPolicy
  InstalledPackageIndex
installedPkgIndex
  (SourcePackageDb PackageIndex UnresolvedSourcePackage
sourcePkgIndex Map PackageName VersionRange
sourcePkgPrefs)
  [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers =
    [PackagePreference] -> DepResolverParams -> DepResolverParams
addPreferences
      [ PackageName -> VersionRange -> PackagePreference
PackageVersionPreference PackageName
name VersionRange
ver
      | (PackageName
name, VersionRange
ver) <- Map PackageName VersionRange -> [(PackageName, VersionRange)]
forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName VersionRange
sourcePkgPrefs
      ]
      (DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LabeledPackageConstraint]
-> DepResolverParams -> DepResolverParams
addConstraints
        ((PackageSpecifier UnresolvedSourcePackage
 -> [LabeledPackageConstraint])
-> [PackageSpecifier UnresolvedSourcePackage]
-> [LabeledPackageConstraint]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PackageSpecifier UnresolvedSourcePackage
-> [LabeledPackageConstraint]
forall pkg.
Package pkg =>
PackageSpecifier pkg -> [LabeledPackageConstraint]
pkgSpecifierConstraints [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers)
      (DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PackageName] -> DepResolverParams -> DepResolverParams
addTargets
        ((PackageSpecifier UnresolvedSourcePackage -> PackageName)
-> [PackageSpecifier UnresolvedSourcePackage] -> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map PackageSpecifier UnresolvedSourcePackage -> PackageName
forall pkg. Package pkg => PackageSpecifier pkg -> PackageName
pkgSpecifierTarget [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers)
      (DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PackageId] -> DepResolverParams -> DepResolverParams
hideInstalledPackagesSpecificBySourcePackageId
        [UnresolvedSourcePackage -> PackageId
forall pkg. Package pkg => pkg -> PackageId
packageId UnresolvedSourcePackage
pkg | SpecificSourcePackage UnresolvedSourcePackage
pkg <- [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers]
      (DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [UnresolvedSourcePackage] -> DepResolverParams -> DepResolverParams
addSourcePackages
        [UnresolvedSourcePackage
pkg | SpecificSourcePackage UnresolvedSourcePackage
pkg <- [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers]
      (DepResolverParams -> DepResolverParams)
-> DepResolverParams -> DepResolverParams
forall a b. (a -> b) -> a -> b
$ InstalledPackageIndex
-> PackageIndex UnresolvedSourcePackage -> DepResolverParams
basicDepResolverParams
        InstalledPackageIndex
installedPkgIndex
        PackageIndex UnresolvedSourcePackage
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 :: InstalledPackageIndex
-> SourcePackageDb
-> [PackageSpecifier UnresolvedSourcePackage]
-> DepResolverParams
standardInstallPolicy InstalledPackageIndex
installedPkgIndex SourcePackageDb
sourcePkgDb [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers =
  (UnresolvedSourcePackage -> Maybe [Dependency])
-> DepResolverParams -> DepResolverParams
addDefaultSetupDependencies UnresolvedSourcePackage -> Maybe [Dependency]
mkDefaultSetupDeps (DepResolverParams -> DepResolverParams)
-> DepResolverParams -> DepResolverParams
forall a b. (a -> b) -> a -> b
$
    InstalledPackageIndex
-> SourcePackageDb
-> [PackageSpecifier UnresolvedSourcePackage]
-> DepResolverParams
basicInstallPolicy
      InstalledPackageIndex
installedPkgIndex
      SourcePackageDb
sourcePkgDb
      [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers
  where
    -- Force Cabal >= 1.24 dep when the package is affected by #3199.
    mkDefaultSetupDeps :: UnresolvedSourcePackage -> Maybe [Dependency]
    mkDefaultSetupDeps :: UnresolvedSourcePackage -> Maybe [Dependency]
mkDefaultSetupDeps UnresolvedSourcePackage
srcpkg
      | Bool
affected =
          [Dependency] -> Maybe [Dependency]
forall a. a -> Maybe a
Just [PackageName
-> VersionRange -> NonEmptySet LibraryName -> Dependency
Dependency (String -> PackageName
mkPackageName String
"Cabal") (Version -> VersionRange
orLaterVersion (Version -> VersionRange) -> Version -> VersionRange
forall a b. (a -> b) -> a -> b
$ [Int] -> Version
mkVersion [Int
1, Int
24]) NonEmptySet LibraryName
mainLibSet]
      | Bool
otherwise = Maybe [Dependency]
forall a. Maybe a
Nothing
      where
        gpkgdesc :: GenericPackageDescription
gpkgdesc = UnresolvedSourcePackage -> GenericPackageDescription
forall loc. SourcePackage loc -> GenericPackageDescription
srcpkgDescription UnresolvedSourcePackage
srcpkg
        pkgdesc :: PackageDescription
pkgdesc = GenericPackageDescription -> PackageDescription
PD.packageDescription GenericPackageDescription
gpkgdesc
        bt :: BuildType
bt = PackageDescription -> BuildType
PD.buildType PackageDescription
pkgdesc
        affected :: Bool
affected = BuildType
bt BuildType -> BuildType -> Bool
forall a. Eq a => a -> a -> Bool
== BuildType
PD.Custom Bool -> Bool -> Bool
&& GenericPackageDescription -> Bool
hasBuildableFalse GenericPackageDescription
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 :: GenericPackageDescription -> Bool
hasBuildableFalse GenericPackageDescription
gpkg =
      Bool -> Bool
not ((Condition ConfVar -> Bool) -> [Condition ConfVar] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Condition ConfVar -> Bool
forall {c}. Condition c -> Bool
alwaysTrue ((Condition ConfVar -> Condition ConfVar -> Condition ConfVar)
-> [Condition ConfVar]
-> [Condition ConfVar]
-> [Condition ConfVar]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Condition ConfVar -> Condition ConfVar -> Condition ConfVar
forall v. Eq v => Condition v -> Condition v -> Condition v
PD.cOr [Condition ConfVar]
buildableConditions [Condition ConfVar]
noDepConditions))
      where
        buildableConditions :: [Condition ConfVar]
buildableConditions = (BuildInfo -> Bool)
-> GenericPackageDescription -> [Condition ConfVar]
PD.extractConditions BuildInfo -> Bool
PD.buildable GenericPackageDescription
gpkg
        noDepConditions :: [Condition ConfVar]
noDepConditions =
          (BuildInfo -> Bool)
-> GenericPackageDescription -> [Condition ConfVar]
PD.extractConditions
            ([Dependency] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Dependency] -> Bool)
-> (BuildInfo -> [Dependency]) -> BuildInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildInfo -> [Dependency]
PD.targetBuildDepends)
            GenericPackageDescription
gpkg
        alwaysTrue :: Condition c -> Bool
alwaysTrue (PD.Lit Bool
True) = Bool
True
        alwaysTrue Condition c
_ = Bool
False

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

-- * Interface to the standard resolver

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

runSolver :: SolverConfig -> DependencyResolver UnresolvedPkgLoc
runSolver :: SolverConfig -> DependencyResolver UnresolvedPkgLoc
runSolver = SolverConfig -> DependencyResolver UnresolvedPkgLoc
forall loc. SolverConfig -> DependencyResolver loc
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
  -> PkgConfigDb
  -> DepResolverParams
  -> Progress String String SolverInstallPlan
resolveDependencies :: Platform
-> CompilerInfo
-> PkgConfigDb
-> DepResolverParams
-> Progress String String SolverInstallPlan
resolveDependencies Platform
platform CompilerInfo
comp PkgConfigDb
pkgConfigDB DepResolverParams
params =
  String
-> Progress String String SolverInstallPlan
-> Progress String String SolverInstallPlan
forall step fail done.
step -> Progress step fail done -> Progress step fail done
Step (DepResolverParams -> String
showDepResolverParams DepResolverParams
finalparams) (Progress String String SolverInstallPlan
 -> Progress String String SolverInstallPlan)
-> Progress String String SolverInstallPlan
-> Progress String String SolverInstallPlan
forall a b. (a -> b) -> a -> b
$
    ([ResolverPackage UnresolvedPkgLoc] -> SolverInstallPlan)
-> Progress String String [ResolverPackage UnresolvedPkgLoc]
-> Progress String String SolverInstallPlan
forall a b.
(a -> b) -> Progress String String a -> Progress String String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Platform
-> CompilerInfo
-> IndependentGoals
-> [ResolverPackage UnresolvedPkgLoc]
-> SolverInstallPlan
validateSolverResult Platform
platform CompilerInfo
comp IndependentGoals
indGoals) (Progress String String [ResolverPackage UnresolvedPkgLoc]
 -> Progress String String SolverInstallPlan)
-> Progress String String [ResolverPackage UnresolvedPkgLoc]
-> Progress String String SolverInstallPlan
forall a b. (a -> b) -> a -> b
$
      SolverConfig -> DependencyResolver UnresolvedPkgLoc
runSolver
        ( ReorderGoals
-> CountConflicts
-> FineGrainedConflicts
-> MinimizeConflictSet
-> IndependentGoals
-> AvoidReinstalls
-> ShadowPkgs
-> StrongFlags
-> OnlyConstrained
-> Maybe Int
-> EnableBackjumping
-> SolveExecutables
-> Maybe (Variable QPN -> Variable QPN -> Ordering)
-> Verbosity
-> PruneAfterFirstSuccess
-> SolverConfig
SolverConfig
            ReorderGoals
reordGoals
            CountConflicts
cntConflicts
            FineGrainedConflicts
fineGrained
            MinimizeConflictSet
minimize
            IndependentGoals
indGoals
            AvoidReinstalls
noReinstalls
            ShadowPkgs
shadowing
            StrongFlags
strFlags
            OnlyConstrained
onlyConstrained_
            Maybe Int
maxBkjumps
            EnableBackjumping
enableBj
            SolveExecutables
solveExes
            Maybe (Variable QPN -> Variable QPN -> Ordering)
order
            Verbosity
verbosity
            (Bool -> PruneAfterFirstSuccess
PruneAfterFirstSuccess Bool
False)
        )
        Platform
platform
        CompilerInfo
comp
        InstalledPackageIndex
installedPkgIndex
        PackageIndex UnresolvedSourcePackage
sourcePkgIndex
        PkgConfigDb
pkgConfigDB
        PackageName -> PackagePreferences
preferences
        [LabeledPackageConstraint]
constraints
        Set PackageName
targets
  where
    finalparams :: DepResolverParams
finalparams@( DepResolverParams
                    Set PackageName
targets
                    [LabeledPackageConstraint]
constraints
                    [PackagePreference]
prefs
                    PackagesPreferenceDefault
defpref
                    InstalledPackageIndex
installedPkgIndex
                    PackageIndex UnresolvedSourcePackage
sourcePkgIndex
                    ReorderGoals
reordGoals
                    CountConflicts
cntConflicts
                    FineGrainedConflicts
fineGrained
                    MinimizeConflictSet
minimize
                    IndependentGoals
indGoals
                    AvoidReinstalls
noReinstalls
                    ShadowPkgs
shadowing
                    StrongFlags
strFlags
                    AllowBootLibInstalls
_allowBootLibs
                    OnlyConstrained
onlyConstrained_
                    Maybe Int
maxBkjumps
                    EnableBackjumping
enableBj
                    SolveExecutables
solveExes
                    Maybe (Variable QPN -> Variable QPN -> Ordering)
order
                    Verbosity
verbosity
                  ) =
        if AllowBootLibInstalls -> Bool
forall a. BooleanFlag a => a -> Bool
asBool (DepResolverParams -> AllowBootLibInstalls
depResolverAllowBootLibInstalls DepResolverParams
params)
          then DepResolverParams
params
          else DepResolverParams -> DepResolverParams
dontInstallNonReinstallablePackages DepResolverParams
params

    preferences :: PackageName -> PackagePreferences
    preferences :: PackageName -> PackagePreferences
preferences = Set PackageName
-> PackagesPreferenceDefault
-> [PackagePreference]
-> PackageName
-> PackagePreferences
interpretPackagesPreference Set PackageName
targets PackagesPreferenceDefault
defpref [PackagePreference]
prefs

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

    installPref :: PackageName -> InstalledPreference
    installPref :: PackageName -> InstalledPreference
installPref PackageName
pkgname =
      InstalledPreference
-> Maybe InstalledPreference -> InstalledPreference
forall a. a -> Maybe a -> a
fromMaybe (PackageName -> InstalledPreference
installPrefDefault PackageName
pkgname) (PackageName
-> Map PackageName InstalledPreference -> Maybe InstalledPreference
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
pkgname Map PackageName InstalledPreference
installPrefs)
    installPrefs :: Map PackageName InstalledPreference
installPrefs =
      [(PackageName, InstalledPreference)]
-> Map PackageName InstalledPreference
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (PackageName
pkgname, InstalledPreference
pref)
        | PackageInstalledPreference PackageName
pkgname InstalledPreference
pref <- [PackagePreference]
prefs
        ]
    installPrefDefault :: PackageName -> InstalledPreference
installPrefDefault = case PackagesPreferenceDefault
defaultPref of
      PackagesPreferenceDefault
PreferAllLatest -> InstalledPreference -> PackageName -> InstalledPreference
forall a b. a -> b -> a
const InstalledPreference
Preference.PreferLatest
      PackagesPreferenceDefault
PreferAllOldest -> InstalledPreference -> PackageName -> InstalledPreference
forall a b. a -> b -> a
const InstalledPreference
Preference.PreferOldest
      PackagesPreferenceDefault
PreferAllInstalled -> InstalledPreference -> PackageName -> InstalledPreference
forall a b. a -> b -> a
const InstalledPreference
Preference.PreferInstalled
      PackagesPreferenceDefault
PreferLatestForSelected -> \PackageName
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 PackageName
pkgname PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PackageName
selected
          then InstalledPreference
Preference.PreferLatest
          else InstalledPreference
Preference.PreferInstalled

    stanzasPref :: PackageName -> [OptionalStanza]
    stanzasPref :: PackageName -> [OptionalStanza]
stanzasPref PackageName
pkgname =
      [OptionalStanza] -> Maybe [OptionalStanza] -> [OptionalStanza]
forall a. a -> Maybe a -> a
fromMaybe [] (PackageName
-> Map PackageName [OptionalStanza] -> Maybe [OptionalStanza]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
pkgname Map PackageName [OptionalStanza]
stanzasPrefs)
    stanzasPrefs :: Map PackageName [OptionalStanza]
stanzasPrefs =
      ([OptionalStanza] -> [OptionalStanza] -> [OptionalStanza])
-> [(PackageName, [OptionalStanza])]
-> Map PackageName [OptionalStanza]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith
        (\[OptionalStanza]
a [OptionalStanza]
b -> [OptionalStanza] -> [OptionalStanza]
forall a. Eq a => [a] -> [a]
nub ([OptionalStanza]
a [OptionalStanza] -> [OptionalStanza] -> [OptionalStanza]
forall a. [a] -> [a] -> [a]
++ [OptionalStanza]
b))
        [ (PackageName
pkgname, [OptionalStanza]
pref)
        | PackageStanzasPreference PackageName
pkgname [OptionalStanza]
pref <- [PackagePreference]
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
-> CompilerInfo
-> IndependentGoals
-> [ResolverPackage UnresolvedPkgLoc]
-> SolverInstallPlan
validateSolverResult Platform
platform CompilerInfo
comp IndependentGoals
indepGoals [ResolverPackage UnresolvedPkgLoc]
pkgs =
  case Platform
-> CompilerInfo
-> [ResolverPackage UnresolvedPkgLoc]
-> [PlanPackageProblem]
planPackagesProblems Platform
platform CompilerInfo
comp [ResolverPackage UnresolvedPkgLoc]
pkgs of
    [] -> case IndependentGoals
-> SolverPlanIndex -> Either [SolverPlanProblem] SolverInstallPlan
SolverInstallPlan.new IndependentGoals
indepGoals SolverPlanIndex
graph of
      Right SolverInstallPlan
plan -> SolverInstallPlan
plan
      Left [SolverPlanProblem]
problems -> String -> SolverInstallPlan
forall a. (?callStack::CallStack) => String -> a
error ([SolverPlanProblem] -> String
formatPlanProblems [SolverPlanProblem]
problems)
    [PlanPackageProblem]
problems -> String -> SolverInstallPlan
forall a. (?callStack::CallStack) => String -> a
error ([PlanPackageProblem] -> String
formatPkgProblems [PlanPackageProblem]
problems)
  where
    graph :: Graph.Graph (ResolverPackage UnresolvedPkgLoc)
    graph :: SolverPlanIndex
graph = [ResolverPackage UnresolvedPkgLoc] -> SolverPlanIndex
forall a. (IsNode a, Show (Key a)) => [a] -> Graph a
Graph.fromDistinctList [ResolverPackage UnresolvedPkgLoc]
pkgs

    formatPkgProblems :: [PlanPackageProblem] -> String
    formatPkgProblems :: [PlanPackageProblem] -> String
formatPkgProblems = [String] -> String
formatProblemMessage ([String] -> String)
-> ([PlanPackageProblem] -> [String])
-> [PlanPackageProblem]
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PlanPackageProblem -> String) -> [PlanPackageProblem] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PlanPackageProblem -> String
showPlanPackageProblem
    formatPlanProblems :: [SolverInstallPlan.SolverPlanProblem] -> String
    formatPlanProblems :: [SolverPlanProblem] -> String
formatPlanProblems = [String] -> String
formatProblemMessage ([String] -> String)
-> ([SolverPlanProblem] -> [String])
-> [SolverPlanProblem]
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SolverPlanProblem -> String) -> [SolverPlanProblem] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map SolverPlanProblem -> String
SolverInstallPlan.showPlanProblem

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

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

showPlanPackageProblem :: PlanPackageProblem -> String
showPlanPackageProblem :: PlanPackageProblem -> String
showPlanPackageProblem (InvalidConfiguredPackage SolverPackage UnresolvedPkgLoc
pkg [PackageProblem]
packageProblems) =
  String
"Package "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackageId -> String
forall a. Pretty a => a -> String
prettyShow (SolverPackage UnresolvedPkgLoc -> PackageId
forall pkg. Package pkg => pkg -> PackageId
packageId SolverPackage UnresolvedPkgLoc
pkg)
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" has an invalid configuration, in particular:\n"
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines
      [ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackageProblem -> String
showPackageProblem PackageProblem
problem
      | PackageProblem
problem <- [PackageProblem]
packageProblems
      ]
showPlanPackageProblem (DuplicatePackageSolverId SolverId
pid [ResolverPackage UnresolvedPkgLoc]
dups) =
  String
"Package "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackageId -> String
forall a. Pretty a => a -> String
prettyShow (SolverId -> PackageId
forall pkg. Package pkg => pkg -> PackageId
packageId SolverId
pid)
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" has "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([ResolverPackage UnresolvedPkgLoc] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ResolverPackage UnresolvedPkgLoc]
dups)
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" duplicate instances."

planPackagesProblems
  :: Platform
  -> CompilerInfo
  -> [ResolverPackage UnresolvedPkgLoc]
  -> [PlanPackageProblem]
planPackagesProblems :: Platform
-> CompilerInfo
-> [ResolverPackage UnresolvedPkgLoc]
-> [PlanPackageProblem]
planPackagesProblems Platform
platform CompilerInfo
cinfo [ResolverPackage UnresolvedPkgLoc]
pkgs =
  [ SolverPackage UnresolvedPkgLoc
-> [PackageProblem] -> PlanPackageProblem
InvalidConfiguredPackage SolverPackage UnresolvedPkgLoc
pkg [PackageProblem]
packageProblems
  | Configured SolverPackage UnresolvedPkgLoc
pkg <- [ResolverPackage UnresolvedPkgLoc]
pkgs
  , let packageProblems :: [PackageProblem]
packageProblems = Platform
-> CompilerInfo
-> SolverPackage UnresolvedPkgLoc
-> [PackageProblem]
configuredPackageProblems Platform
platform CompilerInfo
cinfo SolverPackage UnresolvedPkgLoc
pkg
  , Bool -> Bool
not ([PackageProblem] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageProblem]
packageProblems)
  ]
    [PlanPackageProblem]
-> [PlanPackageProblem] -> [PlanPackageProblem]
forall a. [a] -> [a] -> [a]
++ [ SolverId
-> [ResolverPackage UnresolvedPkgLoc] -> PlanPackageProblem
DuplicatePackageSolverId (ResolverPackage UnresolvedPkgLoc
-> Key (ResolverPackage UnresolvedPkgLoc)
forall a. IsNode a => a -> Key a
Graph.nodeKey ResolverPackage UnresolvedPkgLoc
aDup) [ResolverPackage UnresolvedPkgLoc]
dups
       | [ResolverPackage UnresolvedPkgLoc]
dups <- (ResolverPackage UnresolvedPkgLoc
 -> ResolverPackage UnresolvedPkgLoc -> Ordering)
-> [ResolverPackage UnresolvedPkgLoc]
-> [[ResolverPackage UnresolvedPkgLoc]]
forall a. (a -> a -> Ordering) -> [a] -> [[a]]
duplicatesBy ((ResolverPackage UnresolvedPkgLoc -> SolverId)
-> ResolverPackage UnresolvedPkgLoc
-> ResolverPackage UnresolvedPkgLoc
-> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ResolverPackage UnresolvedPkgLoc
-> Key (ResolverPackage UnresolvedPkgLoc)
ResolverPackage UnresolvedPkgLoc -> SolverId
forall a. IsNode a => a -> Key a
Graph.nodeKey) [ResolverPackage UnresolvedPkgLoc]
pkgs
       , ResolverPackage UnresolvedPkgLoc
aDup <- case [ResolverPackage UnresolvedPkgLoc]
dups of
          [] -> []
          (ResolverPackage UnresolvedPkgLoc
ad : [ResolverPackage UnresolvedPkgLoc]
_) -> [ResolverPackage UnresolvedPkgLoc
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 :: PackageProblem -> String
showPackageProblem (DuplicateFlag FlagName
flag) =
  String
"duplicate flag in the flag assignment: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FlagName -> String
PD.unFlagName FlagName
flag
showPackageProblem (MissingFlag FlagName
flag) =
  String
"missing an assignment for the flag: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FlagName -> String
PD.unFlagName FlagName
flag
showPackageProblem (ExtraFlag FlagName
flag) =
  String
"extra flag given that is not used by the package: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FlagName -> String
PD.unFlagName FlagName
flag
showPackageProblem (DuplicateDeps [PackageId]
pkgids) =
  String
"duplicate packages specified as selected dependencies: "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((PackageId -> String) -> [PackageId] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PackageId -> String
forall a. Pretty a => a -> String
prettyShow [PackageId]
pkgids)
showPackageProblem (MissingDep Dependency
dep) =
  String
"the package has a dependency "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ Dependency -> String
forall a. Pretty a => a -> String
prettyShow Dependency
dep
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" but no package has been selected to satisfy it."
showPackageProblem (ExtraDep PackageId
pkgid) =
  String
"the package configuration specifies "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackageId -> String
forall a. Pretty a => a -> String
prettyShow PackageId
pkgid
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" but (with the given flag assignment) the package does not actually"
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" depend on any version of that package."
showPackageProblem (InvalidDep Dependency
dep PackageId
pkgid) =
  String
"the package depends on "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ Dependency -> String
forall a. Pretty a => a -> String
prettyShow Dependency
dep
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" but the configuration specifies "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackageId -> String
forall a. Pretty a => a -> String
prettyShow PackageId
pkgid
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" 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
-> CompilerInfo
-> SolverPackage UnresolvedPkgLoc
-> [PackageProblem]
configuredPackageProblems
  Platform
platform
  CompilerInfo
cinfo
  (SolverPackage UnresolvedSourcePackage
pkg FlagAssignment
specifiedFlags OptionalStanzaSet
stanzas ComponentDeps [SolverId]
specifiedDeps0 ComponentDeps [SolverId]
_specifiedExeDeps') =
    [ FlagName -> PackageProblem
DuplicateFlag FlagName
flag
    | FlagName
flag <- FlagAssignment -> [FlagName]
PD.findDuplicateFlagAssignments FlagAssignment
specifiedFlags
    ]
      [PackageProblem] -> [PackageProblem] -> [PackageProblem]
forall a. [a] -> [a] -> [a]
++ [FlagName -> PackageProblem
MissingFlag FlagName
flag | OnlyInLeft FlagName
flag <- [MergeResult FlagName FlagName]
mergedFlags]
      [PackageProblem] -> [PackageProblem] -> [PackageProblem]
forall a. [a] -> [a] -> [a]
++ [FlagName -> PackageProblem
ExtraFlag FlagName
flag | OnlyInRight FlagName
flag <- [MergeResult FlagName FlagName]
mergedFlags]
      [PackageProblem] -> [PackageProblem] -> [PackageProblem]
forall a. [a] -> [a] -> [a]
++ [ [PackageId] -> PackageProblem
DuplicateDeps [PackageId]
pkgs
         | [PackageId]
pkgs <-
            ComponentDeps [[PackageId]] -> [[PackageId]]
forall a. Monoid a => ComponentDeps a -> a
CD.nonSetupDeps
              ( ([PackageId] -> [[PackageId]])
-> ComponentDeps [PackageId] -> ComponentDeps [[PackageId]]
forall a b. (a -> b) -> ComponentDeps a -> ComponentDeps b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                  ((PackageId -> PackageId -> Ordering)
-> [PackageId] -> [[PackageId]]
forall a. (a -> a -> Ordering) -> [a] -> [[a]]
duplicatesBy ((PackageId -> PackageName) -> PackageId -> PackageId -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing PackageId -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName))
                  ComponentDeps [PackageId]
specifiedDeps1
              )
         ]
      [PackageProblem] -> [PackageProblem] -> [PackageProblem]
forall a. [a] -> [a] -> [a]
++ [Dependency -> PackageProblem
MissingDep Dependency
dep | OnlyInLeft Dependency
dep <- [MergeResult Dependency PackageId]
mergedDeps]
      [PackageProblem] -> [PackageProblem] -> [PackageProblem]
forall a. [a] -> [a] -> [a]
++ [PackageId -> PackageProblem
ExtraDep PackageId
pkgid | OnlyInRight PackageId
pkgid <- [MergeResult Dependency PackageId]
mergedDeps]
      [PackageProblem] -> [PackageProblem] -> [PackageProblem]
forall a. [a] -> [a] -> [a]
++ [ Dependency -> PackageId -> PackageProblem
InvalidDep Dependency
dep PackageId
pkgid | InBoth Dependency
dep PackageId
pkgid <- [MergeResult Dependency PackageId]
mergedDeps, Bool -> Bool
not (PackageId -> Dependency -> Bool
packageSatisfiesDependency PackageId
pkgid Dependency
dep)
         ]
    where
      -- TODO: sanity tests on executable deps

      thisPkgName :: PackageName
      thisPkgName :: PackageName
thisPkgName = GenericPackageDescription -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName (UnresolvedSourcePackage -> GenericPackageDescription
forall loc. SourcePackage loc -> GenericPackageDescription
srcpkgDescription UnresolvedSourcePackage
pkg)

      specifiedDeps1 :: ComponentDeps [PackageId]
      specifiedDeps1 :: ComponentDeps [PackageId]
specifiedDeps1 = ([SolverId] -> [PackageId])
-> ComponentDeps [SolverId] -> ComponentDeps [PackageId]
forall a b. (a -> b) -> ComponentDeps a -> ComponentDeps b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SolverId -> PackageId) -> [SolverId] -> [PackageId]
forall a b. (a -> b) -> [a] -> [b]
map SolverId -> PackageId
solverSrcId) ComponentDeps [SolverId]
specifiedDeps0

      specifiedDeps :: [PackageId]
      specifiedDeps :: [PackageId]
specifiedDeps = ComponentDeps [PackageId] -> [PackageId]
forall a. Monoid a => ComponentDeps a -> a
CD.flatDeps ComponentDeps [PackageId]
specifiedDeps1

      mergedFlags :: [MergeResult PD.FlagName PD.FlagName]
      mergedFlags :: [MergeResult FlagName FlagName]
mergedFlags =
        (FlagName -> FlagName -> Ordering)
-> [FlagName] -> [FlagName] -> [MergeResult FlagName FlagName]
forall a b. (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b]
mergeBy
          FlagName -> FlagName -> Ordering
forall a. Ord a => a -> a -> Ordering
compare
          ([FlagName] -> [FlagName]
forall a. Ord a => [a] -> [a]
sort ([FlagName] -> [FlagName]) -> [FlagName] -> [FlagName]
forall a b. (a -> b) -> a -> b
$ (PackageFlag -> FlagName) -> [PackageFlag] -> [FlagName]
forall a b. (a -> b) -> [a] -> [b]
map PackageFlag -> FlagName
PD.flagName (GenericPackageDescription -> [PackageFlag]
PD.genPackageFlags (UnresolvedSourcePackage -> GenericPackageDescription
forall loc. SourcePackage loc -> GenericPackageDescription
srcpkgDescription UnresolvedSourcePackage
pkg)))
          ([FlagName] -> [FlagName]
forall a. Ord a => [a] -> [a]
sort ([FlagName] -> [FlagName]) -> [FlagName] -> [FlagName]
forall a b. (a -> b) -> a -> b
$ ((FlagName, Bool) -> FlagName) -> [(FlagName, Bool)] -> [FlagName]
forall a b. (a -> b) -> [a] -> [b]
map (FlagName, Bool) -> FlagName
forall a b. (a, b) -> a
fst (FlagAssignment -> [(FlagName, Bool)]
PD.unFlagAssignment FlagAssignment
specifiedFlags)) -- TODO
      packageSatisfiesDependency :: PackageIdentifier -> Dependency -> Bool
      packageSatisfiesDependency :: PackageId -> Dependency -> Bool
packageSatisfiesDependency
        (PackageIdentifier PackageName
name Version
version)
        (Dependency PackageName
name' VersionRange
versionRange NonEmptySet LibraryName
_) =
          Bool -> Bool -> Bool
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (PackageName
name PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== PackageName
name') (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
            Version
version Version -> VersionRange -> Bool
`withinRange` VersionRange
versionRange

      dependencyName :: Dependency -> PackageName
dependencyName (Dependency PackageName
name VersionRange
_ NonEmptySet LibraryName
_) = PackageName
name

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

      mergeDeps
        :: [Dependency]
        -> [PackageId]
        -> [MergeResult Dependency PackageId]
      mergeDeps :: [Dependency] -> [PackageId] -> [MergeResult Dependency PackageId]
mergeDeps [Dependency]
required [PackageId]
specified =
        let sortNubOn :: (a -> b) -> [a] -> [a]
sortNubOn a -> b
f = (a -> a -> Bool) -> [a] -> [a]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (b -> b -> Bool
forall a. Eq a => a -> a -> Bool
(==) (b -> b -> Bool) -> (a -> b) -> a -> a -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` a -> b
f) ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a -> Ordering) -> [a] -> [a]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (b -> b -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (b -> b -> Ordering) -> (a -> b) -> a -> a -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` a -> b
f)
         in (Dependency -> PackageId -> Ordering)
-> [Dependency]
-> [PackageId]
-> [MergeResult Dependency PackageId]
forall a b. (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b]
mergeBy
              (\Dependency
dep PackageId
pkgid -> Dependency -> PackageName
dependencyName Dependency
dep PackageName -> PackageName -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` PackageId -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageId
pkgid)
              ((Dependency -> PackageName) -> [Dependency] -> [Dependency]
forall {b} {a}. Ord b => (a -> b) -> [a] -> [a]
sortNubOn Dependency -> PackageName
dependencyName [Dependency]
required)
              ((PackageId -> PackageName) -> [PackageId] -> [PackageId]
forall {b} {a}. Ord b => (a -> b) -> [a] -> [a]
sortNubOn PackageId -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName [PackageId]
specified)

      compSpec :: ComponentRequestedSpec
compSpec = OptionalStanzaSet -> ComponentRequestedSpec
enableStanzas OptionalStanzaSet
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 :: [Dependency]
requiredDeps =
        -- TODO: use something lower level than finalizePD
        case FlagAssignment
-> ComponentRequestedSpec
-> (Dependency -> Bool)
-> Platform
-> CompilerInfo
-> [PackageVersionConstraint]
-> GenericPackageDescription
-> Either [Dependency] (PackageDescription, FlagAssignment)
finalizePD
          FlagAssignment
specifiedFlags
          ComponentRequestedSpec
compSpec
          (Bool -> Dependency -> Bool
forall a b. a -> b -> a
const Bool
True)
          Platform
platform
          CompilerInfo
cinfo
          []
          (UnresolvedSourcePackage -> GenericPackageDescription
forall loc. SourcePackage loc -> GenericPackageDescription
srcpkgDescription UnresolvedSourcePackage
pkg) of
          Right (PackageDescription
resolvedPkg, FlagAssignment
_) ->
            -- 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
            --
            (Dependency -> Bool) -> [Dependency] -> [Dependency]
forall a. (a -> Bool) -> [a] -> [a]
filter
              ((PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
/= PackageName
thisPkgName) (PackageName -> Bool)
-> (Dependency -> PackageName) -> Dependency -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dependency -> PackageName
dependencyName)
              (PackageDescription -> ComponentRequestedSpec -> [Dependency]
PD.enabledBuildDepends PackageDescription
resolvedPkg ComponentRequestedSpec
compSpec)
              [Dependency] -> [Dependency] -> [Dependency]
forall a. [a] -> [a] -> [a]
++ [Dependency]
-> (SetupBuildInfo -> [Dependency])
-> Maybe SetupBuildInfo
-> [Dependency]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] SetupBuildInfo -> [Dependency]
PD.setupDepends (PackageDescription -> Maybe SetupBuildInfo
PD.setupBuildInfo PackageDescription
resolvedPkg)
          Left [Dependency]
_ ->
            String -> [Dependency]
forall a. (?callStack::CallStack) => String -> a
error String
"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
-> Either [ResolveNoDepsError] [UnresolvedSourcePackage]
resolveWithoutDependencies
  ( DepResolverParams
      Set PackageName
targets
      [LabeledPackageConstraint]
constraints
      [PackagePreference]
prefs
      PackagesPreferenceDefault
defpref
      InstalledPackageIndex
installedPkgIndex
      PackageIndex UnresolvedSourcePackage
sourcePkgIndex
      ReorderGoals
_reorderGoals
      CountConflicts
_countConflicts
      FineGrainedConflicts
_fineGrained
      MinimizeConflictSet
_minimizeConflictSet
      IndependentGoals
_indGoals
      AvoidReinstalls
_avoidReinstalls
      ShadowPkgs
_shadowing
      StrongFlags
_strFlags
      AllowBootLibInstalls
_maxBjumps
      OnlyConstrained
_enableBj
      Maybe Int
_solveExes
      EnableBackjumping
_allowBootLibInstalls
      SolveExecutables
_onlyConstrained
      Maybe (Variable QPN -> Variable QPN -> Ordering)
_order
      Verbosity
_verbosity
    ) =
    [Either ResolveNoDepsError UnresolvedSourcePackage]
-> Either [ResolveNoDepsError] [UnresolvedSourcePackage]
forall a b. [Either a b] -> Either [a] [b]
collectEithers ([Either ResolveNoDepsError UnresolvedSourcePackage]
 -> Either [ResolveNoDepsError] [UnresolvedSourcePackage])
-> [Either ResolveNoDepsError UnresolvedSourcePackage]
-> Either [ResolveNoDepsError] [UnresolvedSourcePackage]
forall a b. (a -> b) -> a -> b
$ (PackageName -> Either ResolveNoDepsError UnresolvedSourcePackage)
-> [PackageName]
-> [Either ResolveNoDepsError UnresolvedSourcePackage]
forall a b. (a -> b) -> [a] -> [b]
map PackageName -> Either ResolveNoDepsError UnresolvedSourcePackage
selectPackage (Set PackageName -> [PackageName]
forall a. Set a -> [a]
Set.toList Set PackageName
targets)
    where
      selectPackage :: PackageName -> Either ResolveNoDepsError UnresolvedSourcePackage
      selectPackage :: PackageName -> Either ResolveNoDepsError UnresolvedSourcePackage
selectPackage PackageName
pkgname
        | [UnresolvedSourcePackage] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UnresolvedSourcePackage]
choices = ResolveNoDepsError
-> Either ResolveNoDepsError UnresolvedSourcePackage
forall a b. a -> Either a b
Left (ResolveNoDepsError
 -> Either ResolveNoDepsError UnresolvedSourcePackage)
-> ResolveNoDepsError
-> Either ResolveNoDepsError UnresolvedSourcePackage
forall a b. (a -> b) -> a -> b
$! PackageName -> VersionRange -> ResolveNoDepsError
ResolveUnsatisfiable PackageName
pkgname VersionRange
requiredVersions
        | Bool
otherwise = UnresolvedSourcePackage
-> Either ResolveNoDepsError UnresolvedSourcePackage
forall a b. b -> Either a b
Right (UnresolvedSourcePackage
 -> Either ResolveNoDepsError UnresolvedSourcePackage)
-> UnresolvedSourcePackage
-> Either ResolveNoDepsError UnresolvedSourcePackage
forall a b. (a -> b) -> a -> b
$! (UnresolvedSourcePackage -> UnresolvedSourcePackage -> Ordering)
-> [UnresolvedSourcePackage] -> UnresolvedSourcePackage
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy UnresolvedSourcePackage -> UnresolvedSourcePackage -> Ordering
bestByPrefs [UnresolvedSourcePackage]
choices
        where
          -- Constraints
          requiredVersions :: VersionRange
          requiredVersions :: VersionRange
requiredVersions = PackageName -> VersionRange
packageConstraints PackageName
pkgname
          choices :: [UnresolvedSourcePackage]
          choices :: [UnresolvedSourcePackage]
choices =
            PackageIndex UnresolvedSourcePackage
-> PackageName -> VersionRange -> [UnresolvedSourcePackage]
forall pkg.
Package pkg =>
PackageIndex pkg -> PackageName -> VersionRange -> [pkg]
PackageIndex.lookupDependency
              PackageIndex UnresolvedSourcePackage
sourcePkgIndex
              PackageName
pkgname
              VersionRange
requiredVersions

          -- Preferences
          PackagePreferences [VersionRange]
preferredVersions InstalledPreference
preferInstalled [OptionalStanza]
_ =
            PackageName -> PackagePreferences
packagePreferences PackageName
pkgname

          bestByPrefs :: UnresolvedSourcePackage -> UnresolvedSourcePackage -> Ordering
          bestByPrefs :: UnresolvedSourcePackage -> UnresolvedSourcePackage -> Ordering
bestByPrefs = (UnresolvedSourcePackage -> (Bool, Int, Version))
-> UnresolvedSourcePackage -> UnresolvedSourcePackage -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ((UnresolvedSourcePackage -> (Bool, Int, Version))
 -> UnresolvedSourcePackage -> UnresolvedSourcePackage -> Ordering)
-> (UnresolvedSourcePackage -> (Bool, Int, Version))
-> UnresolvedSourcePackage
-> UnresolvedSourcePackage
-> Ordering
forall a b. (a -> b) -> a -> b
$ \UnresolvedSourcePackage
pkg ->
            (UnresolvedSourcePackage -> Bool
installPref UnresolvedSourcePackage
pkg, UnresolvedSourcePackage -> Int
forall a. Package a => a -> Int
versionPref UnresolvedSourcePackage
pkg, UnresolvedSourcePackage -> Version
forall pkg. Package pkg => pkg -> Version
packageVersion UnresolvedSourcePackage
pkg)
          installPref :: UnresolvedSourcePackage -> Bool
          installPref :: UnresolvedSourcePackage -> Bool
installPref = case InstalledPreference
preferInstalled of
            InstalledPreference
Preference.PreferLatest -> Bool -> UnresolvedSourcePackage -> Bool
forall a b. a -> b -> a
const Bool
False
            InstalledPreference
Preference.PreferOldest -> Bool -> UnresolvedSourcePackage -> Bool
forall a b. a -> b -> a
const Bool
False
            InstalledPreference
Preference.PreferInstalled ->
              Bool -> Bool
not
                (Bool -> Bool)
-> (UnresolvedSourcePackage -> Bool)
-> UnresolvedSourcePackage
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [InstalledPackageInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null
                ([InstalledPackageInfo] -> Bool)
-> (UnresolvedSourcePackage -> [InstalledPackageInfo])
-> UnresolvedSourcePackage
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledPackageIndex -> PackageId -> [InstalledPackageInfo]
forall a. PackageIndex a -> PackageId -> [a]
InstalledPackageIndex.lookupSourcePackageId
                  InstalledPackageIndex
installedPkgIndex
                (PackageId -> [InstalledPackageInfo])
-> (UnresolvedSourcePackage -> PackageId)
-> UnresolvedSourcePackage
-> [InstalledPackageInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnresolvedSourcePackage -> PackageId
forall pkg. Package pkg => pkg -> PackageId
packageId
          versionPref :: Package a => a -> Int
          versionPref :: forall a. Package a => a -> Int
versionPref a
pkg =
            [VersionRange] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([VersionRange] -> Int)
-> ([VersionRange] -> [VersionRange]) -> [VersionRange] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VersionRange -> Bool) -> [VersionRange] -> [VersionRange]
forall a. (a -> Bool) -> [a] -> [a]
filter (a -> Version
forall pkg. Package pkg => pkg -> Version
packageVersion a
pkg Version -> VersionRange -> Bool
`withinRange`) ([VersionRange] -> Int) -> [VersionRange] -> Int
forall a b. (a -> b) -> a -> b
$
              [VersionRange]
preferredVersions

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

      packagePreferences :: PackageName -> PackagePreferences
      packagePreferences :: PackageName -> PackagePreferences
packagePreferences = Set PackageName
-> PackagesPreferenceDefault
-> [PackagePreference]
-> PackageName
-> PackagePreferences
interpretPackagesPreference Set PackageName
targets PackagesPreferenceDefault
defpref [PackagePreference]
prefs

collectEithers :: [Either a b] -> Either [a] [b]
collectEithers :: forall a b. [Either a b] -> Either [a] [b]
collectEithers = ([a], [b]) -> Either [a] [b]
forall {a} {b}. ([a], b) -> Either [a] b
collect (([a], [b]) -> Either [a] [b])
-> ([Either a b] -> ([a], [b])) -> [Either a b] -> Either [a] [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either a b] -> ([a], [b])
forall a b. [Either a b] -> ([a], [b])
partitionEithers
  where
    collect :: ([a], b) -> Either [a] b
collect ([], b
xs) = b -> Either [a] b
forall a b. b -> Either a b
Right b
xs
    collect ([a]
errs, b
_) = [a] -> Either [a] b
forall a b. a -> Either a b
Left [a]
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 :: ResolveNoDepsError -> String
show (ResolveUnsatisfiable PackageName
name VersionRange
ver) =
    String
"There is no available version of "
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackageName -> String
forall a. Pretty a => a -> String
prettyShow PackageName
name
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" that satisfies "
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ VersionRange -> String
forall a. Pretty a => a -> String
prettyShow (VersionRange -> VersionRange
simplifyVersionRange VersionRange
ver)