{-# LANGUAGE ScopedTypeVariables #-}
-- | Reordering or pruning the tree in order to prefer or make certain choices.
module Distribution.Solver.Modular.Preference
    ( avoidReinstalls
    , deferSetupExeChoices
    , deferWeakFlagChoices
    , enforceManualFlags
    , enforcePackageConstraints
    , enforceSingleInstanceRestriction
    , firstGoal
    , preferBaseGoalChoice
    , preferLinked
    , preferPackagePreferences
    , preferReallyEasyGoalChoices
    , requireInstalled
    , onlyConstrained
    , sortGoals
    , pruneAfterFirstSuccess
    ) where

import Prelude ()
import Distribution.Solver.Compat.Prelude

import qualified Data.List as L
import qualified Data.Map as M
import Control.Monad.Trans.Reader (Reader, runReader, ask, local)

import Distribution.PackageDescription (lookupFlagAssignment, unFlagAssignment) -- from Cabal

import Distribution.Solver.Types.Flag
import Distribution.Solver.Types.InstalledPreference
import Distribution.Solver.Types.LabeledPackageConstraint
import Distribution.Solver.Types.OptionalStanza
import Distribution.Solver.Types.PackageConstraint
import Distribution.Solver.Types.PackagePath
import Distribution.Solver.Types.PackagePreferences
import Distribution.Solver.Types.Variable

import Distribution.Solver.Modular.Dependency
import Distribution.Solver.Modular.Flag
import Distribution.Solver.Modular.Package
import qualified Distribution.Solver.Modular.PSQ as P
import Distribution.Solver.Modular.Tree
import Distribution.Solver.Modular.Version
import qualified Distribution.Solver.Modular.ConflictSet as CS
import qualified Distribution.Solver.Modular.WeightedPSQ as W

-- | Update the weights of children under 'PChoice' nodes. 'addWeights' takes a
-- list of weight-calculating functions in order to avoid sorting the package
-- choices multiple times. Each function takes the package name, sorted list of
-- children's versions, and package option. 'addWeights' prepends the new
-- weights to the existing weights, which gives precedence to preferences that
-- are applied later.
addWeights :: [PN -> [Ver] -> POption -> Weight] -> EndoTreeTrav d c
addWeights :: [PN -> [Ver] -> POption -> Weight] -> EndoTreeTrav d c
addWeights [PN -> [Ver] -> POption -> Weight]
fs = EndoTreeTrav d c
forall d c. TreeF d c (Tree d c) -> TreeF d c (Tree d c)
go
  where
    go :: TreeF d c (Tree d c) -> TreeF d c (Tree d c)
    go :: TreeF d c (Tree d c) -> TreeF d c (Tree d c)
go (PChoiceF qpn :: QPN
qpn@(Q PackagePath
_ PN
pn) RevDepMap
rdm c
x WeightedPSQ [Weight] POption (Tree d c)
cs) =
      let sortedVersions :: [Ver]
sortedVersions = (Ver -> Ver -> Ordering) -> [Ver] -> [Ver]
forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy ((Ver -> Ver -> Ordering) -> Ver -> Ver -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip Ver -> Ver -> Ordering
forall a. Ord a => a -> a -> Ordering
compare) ([Ver] -> [Ver]) -> [Ver] -> [Ver]
forall a b. (a -> b) -> a -> b
$ (POption -> Ver) -> [POption] -> [Ver]
forall a b. (a -> b) -> [a] -> [b]
L.map POption -> Ver
version (WeightedPSQ [Weight] POption (Tree d c) -> [POption]
forall w k v. WeightedPSQ w k v -> [k]
W.keys WeightedPSQ [Weight] POption (Tree d c)
cs)
          weights :: POption -> [Weight]
weights POption
k = [PN -> [Ver] -> POption -> Weight
f PN
pn [Ver]
sortedVersions POption
k | PN -> [Ver] -> POption -> Weight
f <- [PN -> [Ver] -> POption -> Weight]
fs]

          elemsToWhnf :: [a] -> ()
          elemsToWhnf :: [a] -> ()
elemsToWhnf = (a -> () -> ()) -> () -> [a] -> ()
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> () -> ()
seq ()
      in  QPN
-> RevDepMap
-> c
-> WeightedPSQ [Weight] POption (Tree d c)
-> TreeF d c (Tree d c)
forall d c a.
QPN
-> RevDepMap -> c -> WeightedPSQ [Weight] POption a -> TreeF d c a
PChoiceF QPN
qpn RevDepMap
rdm c
x
          -- Evaluate the children's versions before evaluating any of the
          -- subtrees, so that 'sortedVersions' doesn't hold onto all of the
          -- subtrees (referenced by cs) and cause a space leak.
          ([Ver] -> ()
forall a. [a] -> ()
elemsToWhnf [Ver]
sortedVersions ()
-> WeightedPSQ [Weight] POption (Tree d c)
-> WeightedPSQ [Weight] POption (Tree d c)
`seq`
             (POption -> [Weight] -> [Weight])
-> WeightedPSQ [Weight] POption (Tree d c)
-> WeightedPSQ [Weight] POption (Tree d c)
forall w2 k w1 v.
Ord w2 =>
(k -> w1 -> w2) -> WeightedPSQ w1 k v -> WeightedPSQ w2 k v
W.mapWeightsWithKey (\POption
k [Weight]
w -> POption -> [Weight]
weights POption
k [Weight] -> [Weight] -> [Weight]
forall a. [a] -> [a] -> [a]
++ [Weight]
w) WeightedPSQ [Weight] POption (Tree d c)
cs)
    go TreeF d c (Tree d c)
x                            = TreeF d c (Tree d c)
x

addWeight :: (PN -> [Ver] -> POption -> Weight) -> EndoTreeTrav d c
addWeight :: (PN -> [Ver] -> POption -> Weight) -> EndoTreeTrav d c
addWeight PN -> [Ver] -> POption -> Weight
f = [PN -> [Ver] -> POption -> Weight] -> EndoTreeTrav d c
forall d c. [PN -> [Ver] -> POption -> Weight] -> EndoTreeTrav d c
addWeights [PN -> [Ver] -> POption -> Weight
f]

version :: POption -> Ver
version :: POption -> Ver
version (POption (I Ver
v Loc
_) Maybe PackagePath
_) = Ver
v

-- | Prefer to link packages whenever possible.
preferLinked :: EndoTreeTrav d c
preferLinked :: EndoTreeTrav d c
preferLinked = (PN -> [Ver] -> POption -> Weight) -> EndoTreeTrav d c
forall d c. (PN -> [Ver] -> POption -> Weight) -> EndoTreeTrav d c
addWeight (([Ver] -> POption -> Weight) -> PN -> [Ver] -> POption -> Weight
forall a b. a -> b -> a
const ((POption -> Weight) -> [Ver] -> POption -> Weight
forall a b. a -> b -> a
const POption -> Weight
forall p. Num p => POption -> p
linked))
  where
    linked :: POption -> p
linked (POption I
_ Maybe PackagePath
Nothing)  = p
1
    linked (POption I
_ (Just PackagePath
_)) = p
0

-- Works by setting weights on choice nodes. Also applies stanza preferences.
preferPackagePreferences :: (PN -> PackagePreferences) -> EndoTreeTrav d c
preferPackagePreferences :: (PN -> PackagePreferences) -> EndoTreeTrav d c
preferPackagePreferences PN -> PackagePreferences
pcs =
    (PN -> PackagePreferences) -> EndoTreeTrav d c
forall d c. (PN -> PackagePreferences) -> EndoTreeTrav d c
preferPackageStanzaPreferences PN -> PackagePreferences
pcs EndoTreeTrav d c -> EndoTreeTrav d c -> EndoTreeTrav d c
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    [PN -> [Ver] -> POption -> Weight] -> EndoTreeTrav d c
forall d c. [PN -> [Ver] -> POption -> Weight] -> EndoTreeTrav d c
addWeights [
          \PN
pn [Ver]
_  POption
opt -> PN -> POption -> Weight
preferred PN
pn POption
opt

        -- Note that we always rank installed before uninstalled, and later
        -- versions before earlier, but we can change the priority of the
        -- two orderings.
        , \PN
pn [Ver]
vs POption
opt -> case PN -> InstalledPreference
preference PN
pn of
                          InstalledPreference
PreferInstalled -> POption -> Weight
installed POption
opt
                          InstalledPreference
PreferLatest    -> [Ver] -> POption -> Weight
latest [Ver]
vs POption
opt
        , \PN
pn [Ver]
vs POption
opt -> case PN -> InstalledPreference
preference PN
pn of
                          InstalledPreference
PreferInstalled -> [Ver] -> POption -> Weight
latest [Ver]
vs POption
opt
                          InstalledPreference
PreferLatest    -> POption -> Weight
installed POption
opt
        ]
  where
    -- Prefer packages with higher version numbers over packages with
    -- lower version numbers.
    latest :: [Ver] -> POption -> Weight
    latest :: [Ver] -> POption -> Weight
latest [Ver]
sortedVersions POption
opt =
      let l :: Int
l = [Ver] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Ver]
sortedVersions
          index :: Int
index = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
l (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ (Ver -> Bool) -> [Ver] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
L.findIndex (Ver -> Ver -> Bool
forall a. Ord a => a -> a -> Bool
<= POption -> Ver
version POption
opt) [Ver]
sortedVersions
      in  Int -> Weight
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
index Weight -> Weight -> Weight
forall a. Fractional a => a -> a -> a
/ Int -> Weight
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
l

    preference :: PN -> InstalledPreference
    preference :: PN -> InstalledPreference
preference PN
pn =
      let PackagePreferences [VersionRange]
_ InstalledPreference
ipref [OptionalStanza]
_ = PN -> PackagePreferences
pcs PN
pn
      in  InstalledPreference
ipref

    -- | Prefer versions satisfying more preferred version ranges.
    preferred :: PN -> POption -> Weight
    preferred :: PN -> POption -> Weight
preferred PN
pn POption
opt =
      let PackagePreferences [VersionRange]
vrs InstalledPreference
_ [OptionalStanza]
_ = PN -> PackagePreferences
pcs PN
pn
      in Int -> Weight
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Weight)
-> ([VersionRange] -> Int) -> [VersionRange] -> Weight
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int
forall a. Num a => a -> a
negate (Int -> Int) -> ([VersionRange] -> Int) -> [VersionRange] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [VersionRange] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
L.length ([VersionRange] -> Weight) -> [VersionRange] -> Weight
forall a b. (a -> b) -> a -> b
$
         (VersionRange -> Bool) -> [VersionRange] -> [VersionRange]
forall a. (a -> Bool) -> [a] -> [a]
L.filter ((VersionRange -> Ver -> Bool) -> Ver -> VersionRange -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip VersionRange -> Ver -> Bool
checkVR (POption -> Ver
version POption
opt)) [VersionRange]
vrs

    -- Prefer installed packages over non-installed packages.
    installed :: POption -> Weight
    installed :: POption -> Weight
installed (POption (I Ver
_ (Inst PId
_)) Maybe PackagePath
_) = Weight
0
    installed POption
_                          = Weight
1

-- | Traversal that tries to establish package stanza enable\/disable
-- preferences. Works by reordering the branches of stanza choices.
-- Note that this works on packages lower in the path as well as at the top level.
-- This is because stanza preferences apply to local packages only
-- and for local packages, a single version is fixed, which means
-- (for now) that all stanza preferences must be uniform at all levels.
-- Further, even when we can have multiple versions of the same package,
-- the build plan will be more efficient if we can attempt to keep
-- stanza preferences aligned at all levels.
preferPackageStanzaPreferences :: (PN -> PackagePreferences) -> EndoTreeTrav d c
preferPackageStanzaPreferences :: (PN -> PackagePreferences) -> EndoTreeTrav d c
preferPackageStanzaPreferences PN -> PackagePreferences
pcs = EndoTreeTrav d c
forall d c a. TreeF d c a -> TreeF d c a
go
  where
    go :: TreeF d c a -> TreeF d c a
go (SChoiceF qsn :: QSN
qsn@(SN (Q PackagePath
_pp PN
pn) OptionalStanza
s) RevDepMap
rdm c
gr WeakOrTrivial
_tr WeightedPSQ [Weight] Bool a
ts)
      | PN -> OptionalStanza -> Bool
enableStanzaPref PN
pn OptionalStanza
s =
          -- move True case first to try enabling the stanza
          let ts' :: WeightedPSQ [Weight] Bool a
ts' = (Bool -> [Weight] -> [Weight])
-> WeightedPSQ [Weight] Bool a -> WeightedPSQ [Weight] Bool a
forall w2 k w1 v.
Ord w2 =>
(k -> w1 -> w2) -> WeightedPSQ w1 k v -> WeightedPSQ w2 k v
W.mapWeightsWithKey (\Bool
k [Weight]
w -> Bool -> Weight
forall p. Num p => Bool -> p
weight Bool
k Weight -> [Weight] -> [Weight]
forall a. a -> [a] -> [a]
: [Weight]
w) WeightedPSQ [Weight] Bool a
ts
              weight :: Bool -> p
weight Bool
k = if Bool
k then p
0 else p
1
          -- defer the choice by setting it to weak
          in  QSN
-> RevDepMap
-> c
-> WeakOrTrivial
-> WeightedPSQ [Weight] Bool a
-> TreeF d c a
forall d c a.
QSN
-> RevDepMap
-> c
-> WeakOrTrivial
-> WeightedPSQ [Weight] Bool a
-> TreeF d c a
SChoiceF QSN
qsn RevDepMap
rdm c
gr (Bool -> WeakOrTrivial
WeakOrTrivial Bool
True) WeightedPSQ [Weight] Bool a
ts'
    go TreeF d c a
x = TreeF d c a
x

    enableStanzaPref :: PN -> OptionalStanza -> Bool
    enableStanzaPref :: PN -> OptionalStanza -> Bool
enableStanzaPref PN
pn OptionalStanza
s =
      let PackagePreferences [VersionRange]
_ InstalledPreference
_ [OptionalStanza]
spref = PN -> PackagePreferences
pcs PN
pn
      in  OptionalStanza
s OptionalStanza -> [OptionalStanza] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [OptionalStanza]
spref

-- | Helper function that tries to enforce a single package constraint on a
-- given instance for a P-node. Translates the constraint into a
-- tree-transformer that either leaves the subtree untouched, or replaces it
-- with an appropriate failure node.
processPackageConstraintP :: forall d c. QPN
                          -> ConflictSet
                          -> I
                          -> LabeledPackageConstraint
                          -> Tree d c
                          -> Tree d c
processPackageConstraintP :: QPN
-> ConflictSet
-> I
-> LabeledPackageConstraint
-> Tree d c
-> Tree d c
processPackageConstraintP QPN
qpn ConflictSet
c I
i (LabeledPackageConstraint (PackageConstraint ConstraintScope
scope PackageProperty
prop) ConstraintSource
src) Tree d c
r =
    if ConstraintScope -> QPN -> Bool
constraintScopeMatches ConstraintScope
scope QPN
qpn
    then I -> PackageProperty -> Tree d c
go I
i PackageProperty
prop
    else Tree d c
r
  where
    go :: I -> PackageProperty -> Tree d c
    go :: I -> PackageProperty -> Tree d c
go (I Ver
v Loc
_) (PackagePropertyVersion VersionRange
vr)
        | VersionRange -> Ver -> Bool
checkVR VersionRange
vr Ver
v  = Tree d c
r
        | Bool
otherwise     = ConflictSet -> FailReason -> Tree d c
forall d c. ConflictSet -> FailReason -> Tree d c
Fail ConflictSet
c (VersionRange -> ConstraintSource -> FailReason
GlobalConstraintVersion VersionRange
vr ConstraintSource
src)
    go I
_       PackageProperty
PackagePropertyInstalled
        | I -> Bool
instI I
i       = Tree d c
r
        | Bool
otherwise     = ConflictSet -> FailReason -> Tree d c
forall d c. ConflictSet -> FailReason -> Tree d c
Fail ConflictSet
c (ConstraintSource -> FailReason
GlobalConstraintInstalled ConstraintSource
src)
    go I
_       PackageProperty
PackagePropertySource
        | Bool -> Bool
not (I -> Bool
instI I
i) = Tree d c
r
        | Bool
otherwise     = ConflictSet -> FailReason -> Tree d c
forall d c. ConflictSet -> FailReason -> Tree d c
Fail ConflictSet
c (ConstraintSource -> FailReason
GlobalConstraintSource ConstraintSource
src)
    go I
_       PackageProperty
_        = Tree d c
r

-- | Helper function that tries to enforce a single package constraint on a
-- given flag setting for an F-node. Translates the constraint into a
-- tree-transformer that either leaves the subtree untouched, or replaces it
-- with an appropriate failure node.
processPackageConstraintF :: forall d c. QPN
                          -> Flag
                          -> ConflictSet
                          -> Bool
                          -> LabeledPackageConstraint
                          -> Tree d c
                          -> Tree d c
processPackageConstraintF :: QPN
-> Flag
-> ConflictSet
-> Bool
-> LabeledPackageConstraint
-> Tree d c
-> Tree d c
processPackageConstraintF QPN
qpn Flag
f ConflictSet
c Bool
b' (LabeledPackageConstraint (PackageConstraint ConstraintScope
scope PackageProperty
prop) ConstraintSource
src) Tree d c
r =
    if ConstraintScope -> QPN -> Bool
constraintScopeMatches ConstraintScope
scope QPN
qpn
    then PackageProperty -> Tree d c
go PackageProperty
prop
    else Tree d c
r
  where
    go :: PackageProperty -> Tree d c
    go :: PackageProperty -> Tree d c
go (PackagePropertyFlags FlagAssignment
fa) =
        case Flag -> FlagAssignment -> Maybe Bool
lookupFlagAssignment Flag
f FlagAssignment
fa of
          Maybe Bool
Nothing            -> Tree d c
r
          Just Bool
b | Bool
b Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
b'   -> Tree d c
r
                 | Bool
otherwise -> ConflictSet -> FailReason -> Tree d c
forall d c. ConflictSet -> FailReason -> Tree d c
Fail ConflictSet
c (ConstraintSource -> FailReason
GlobalConstraintFlag ConstraintSource
src)
    go PackageProperty
_                             = Tree d c
r

-- | Helper function that tries to enforce a single package constraint on a
-- given flag setting for an F-node. Translates the constraint into a
-- tree-transformer that either leaves the subtree untouched, or replaces it
-- with an appropriate failure node.
processPackageConstraintS :: forall d c. QPN
                          -> OptionalStanza
                          -> ConflictSet
                          -> Bool
                          -> LabeledPackageConstraint
                          -> Tree d c
                          -> Tree d c
processPackageConstraintS :: QPN
-> OptionalStanza
-> ConflictSet
-> Bool
-> LabeledPackageConstraint
-> Tree d c
-> Tree d c
processPackageConstraintS QPN
qpn OptionalStanza
s ConflictSet
c Bool
b' (LabeledPackageConstraint (PackageConstraint ConstraintScope
scope PackageProperty
prop) ConstraintSource
src) Tree d c
r =
    if ConstraintScope -> QPN -> Bool
constraintScopeMatches ConstraintScope
scope QPN
qpn
    then PackageProperty -> Tree d c
go PackageProperty
prop
    else Tree d c
r
  where
    go :: PackageProperty -> Tree d c
    go :: PackageProperty -> Tree d c
go (PackagePropertyStanzas [OptionalStanza]
ss) =
        if Bool -> Bool
not Bool
b' Bool -> Bool -> Bool
&& OptionalStanza
s OptionalStanza -> [OptionalStanza] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [OptionalStanza]
ss then ConflictSet -> FailReason -> Tree d c
forall d c. ConflictSet -> FailReason -> Tree d c
Fail ConflictSet
c (ConstraintSource -> FailReason
GlobalConstraintFlag ConstraintSource
src)
                                 else Tree d c
r
    go PackageProperty
_                               = Tree d c
r

-- | Traversal that tries to establish various kinds of user constraints. Works
-- by selectively disabling choices that have been ruled out by global user
-- constraints.
enforcePackageConstraints :: M.Map PN [LabeledPackageConstraint]
                          -> EndoTreeTrav d c
enforcePackageConstraints :: Map PN [LabeledPackageConstraint] -> EndoTreeTrav d c
enforcePackageConstraints Map PN [LabeledPackageConstraint]
pcs = EndoTreeTrav d c
forall d c d c. TreeF d c (Tree d c) -> TreeF d c (Tree d c)
go
  where
    go :: TreeF d c (Tree d c) -> TreeF d c (Tree d c)
go (PChoiceF qpn :: QPN
qpn@(Q PackagePath
_ PN
pn) RevDepMap
rdm c
gr                    WeightedPSQ [Weight] POption (Tree d c)
ts) =
      let c :: ConflictSet
c = Var QPN -> ConflictSet
varToConflictSet (QPN -> Var QPN
forall qpn. qpn -> Var qpn
P QPN
qpn)
          -- compose the transformation functions for each of the relevant constraint
          g :: POption -> Tree d c -> Tree d c
g = \ (POption I
i Maybe PackagePath
_) -> ((Tree d c -> Tree d c)
 -> LabeledPackageConstraint -> Tree d c -> Tree d c)
-> (Tree d c -> Tree d c)
-> [LabeledPackageConstraint]
-> Tree d c
-> Tree d c
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ Tree d c -> Tree d c
h LabeledPackageConstraint
pc -> Tree d c -> Tree d c
h (Tree d c -> Tree d c)
-> (Tree d c -> Tree d c) -> Tree d c -> Tree d c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QPN
-> ConflictSet
-> I
-> LabeledPackageConstraint
-> Tree d c
-> Tree d c
forall d c.
QPN
-> ConflictSet
-> I
-> LabeledPackageConstraint
-> Tree d c
-> Tree d c
processPackageConstraintP QPN
qpn ConflictSet
c I
i LabeledPackageConstraint
pc)
                                       Tree d c -> Tree d c
forall a. a -> a
id
                                       ([LabeledPackageConstraint]
-> PN
-> Map PN [LabeledPackageConstraint]
-> [LabeledPackageConstraint]
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault [] PN
pn Map PN [LabeledPackageConstraint]
pcs)
      in QPN
-> RevDepMap
-> c
-> WeightedPSQ [Weight] POption (Tree d c)
-> TreeF d c (Tree d c)
forall d c a.
QPN
-> RevDepMap -> c -> WeightedPSQ [Weight] POption a -> TreeF d c a
PChoiceF QPN
qpn RevDepMap
rdm c
gr        ((POption -> Tree d c -> Tree d c)
-> WeightedPSQ [Weight] POption (Tree d c)
-> WeightedPSQ [Weight] POption (Tree d c)
forall k v1 v2 w.
(k -> v1 -> v2) -> WeightedPSQ w k v1 -> WeightedPSQ w k v2
W.mapWithKey POption -> Tree d c -> Tree d c
forall d c. POption -> Tree d c -> Tree d c
g WeightedPSQ [Weight] POption (Tree d c)
ts)
    go (FChoiceF qfn :: QFN
qfn@(FN qpn :: QPN
qpn@(Q PackagePath
_ PN
pn) Flag
f) RevDepMap
rdm c
gr WeakOrTrivial
tr FlagType
m Bool
d WeightedPSQ [Weight] Bool (Tree d c)
ts) =
      let c :: ConflictSet
c = Var QPN -> ConflictSet
varToConflictSet (QFN -> Var QPN
forall qpn. FN qpn -> Var qpn
F QFN
qfn)
          -- compose the transformation functions for each of the relevant constraint
          g :: Bool -> Tree d c -> Tree d c
g = \ Bool
b -> ((Tree d c -> Tree d c)
 -> LabeledPackageConstraint -> Tree d c -> Tree d c)
-> (Tree d c -> Tree d c)
-> [LabeledPackageConstraint]
-> Tree d c
-> Tree d c
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ Tree d c -> Tree d c
h LabeledPackageConstraint
pc -> Tree d c -> Tree d c
h (Tree d c -> Tree d c)
-> (Tree d c -> Tree d c) -> Tree d c -> Tree d c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QPN
-> Flag
-> ConflictSet
-> Bool
-> LabeledPackageConstraint
-> Tree d c
-> Tree d c
forall d c.
QPN
-> Flag
-> ConflictSet
-> Bool
-> LabeledPackageConstraint
-> Tree d c
-> Tree d c
processPackageConstraintF QPN
qpn Flag
f ConflictSet
c Bool
b LabeledPackageConstraint
pc)
                           Tree d c -> Tree d c
forall a. a -> a
id
                           ([LabeledPackageConstraint]
-> PN
-> Map PN [LabeledPackageConstraint]
-> [LabeledPackageConstraint]
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault [] PN
pn Map PN [LabeledPackageConstraint]
pcs)
      in QFN
-> RevDepMap
-> c
-> WeakOrTrivial
-> FlagType
-> Bool
-> WeightedPSQ [Weight] Bool (Tree d c)
-> TreeF d c (Tree d c)
forall d c a.
QFN
-> RevDepMap
-> c
-> WeakOrTrivial
-> FlagType
-> Bool
-> WeightedPSQ [Weight] Bool a
-> TreeF d c a
FChoiceF QFN
qfn RevDepMap
rdm c
gr WeakOrTrivial
tr FlagType
m Bool
d ((Bool -> Tree d c -> Tree d c)
-> WeightedPSQ [Weight] Bool (Tree d c)
-> WeightedPSQ [Weight] Bool (Tree d c)
forall k v1 v2 w.
(k -> v1 -> v2) -> WeightedPSQ w k v1 -> WeightedPSQ w k v2
W.mapWithKey Bool -> Tree d c -> Tree d c
forall d c. Bool -> Tree d c -> Tree d c
g WeightedPSQ [Weight] Bool (Tree d c)
ts)
    go (SChoiceF qsn :: QSN
qsn@(SN qpn :: QPN
qpn@(Q PackagePath
_ PN
pn) OptionalStanza
f) RevDepMap
rdm c
gr WeakOrTrivial
tr   WeightedPSQ [Weight] Bool (Tree d c)
ts) =
      let c :: ConflictSet
c = Var QPN -> ConflictSet
varToConflictSet (QSN -> Var QPN
forall qpn. SN qpn -> Var qpn
S QSN
qsn)
          -- compose the transformation functions for each of the relevant constraint
          g :: Bool -> Tree d c -> Tree d c
g = \ Bool
b -> ((Tree d c -> Tree d c)
 -> LabeledPackageConstraint -> Tree d c -> Tree d c)
-> (Tree d c -> Tree d c)
-> [LabeledPackageConstraint]
-> Tree d c
-> Tree d c
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ Tree d c -> Tree d c
h LabeledPackageConstraint
pc -> Tree d c -> Tree d c
h (Tree d c -> Tree d c)
-> (Tree d c -> Tree d c) -> Tree d c -> Tree d c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QPN
-> OptionalStanza
-> ConflictSet
-> Bool
-> LabeledPackageConstraint
-> Tree d c
-> Tree d c
forall d c.
QPN
-> OptionalStanza
-> ConflictSet
-> Bool
-> LabeledPackageConstraint
-> Tree d c
-> Tree d c
processPackageConstraintS QPN
qpn OptionalStanza
f ConflictSet
c Bool
b LabeledPackageConstraint
pc)
                           Tree d c -> Tree d c
forall a. a -> a
id
                           ([LabeledPackageConstraint]
-> PN
-> Map PN [LabeledPackageConstraint]
-> [LabeledPackageConstraint]
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault [] PN
pn Map PN [LabeledPackageConstraint]
pcs)
      in QSN
-> RevDepMap
-> c
-> WeakOrTrivial
-> WeightedPSQ [Weight] Bool (Tree d c)
-> TreeF d c (Tree d c)
forall d c a.
QSN
-> RevDepMap
-> c
-> WeakOrTrivial
-> WeightedPSQ [Weight] Bool a
-> TreeF d c a
SChoiceF QSN
qsn RevDepMap
rdm c
gr WeakOrTrivial
tr     ((Bool -> Tree d c -> Tree d c)
-> WeightedPSQ [Weight] Bool (Tree d c)
-> WeightedPSQ [Weight] Bool (Tree d c)
forall k v1 v2 w.
(k -> v1 -> v2) -> WeightedPSQ w k v1 -> WeightedPSQ w k v2
W.mapWithKey Bool -> Tree d c -> Tree d c
forall d c. Bool -> Tree d c -> Tree d c
g WeightedPSQ [Weight] Bool (Tree d c)
ts)
    go TreeF d c (Tree d c)
x = TreeF d c (Tree d c)
x

-- | Transformation that tries to enforce the rule that manual flags can only be
-- set by the user.
--
-- If there are no constraints on a manual flag, this function prunes all but
-- the default value. If there are constraints, then the flag is allowed to have
-- the values specified by the constraints. Note that the type used for flag
-- values doesn't need to be Bool.
--
-- This function makes an exception for the case where there are multiple goals
-- for a single package (with different qualifiers), and flag constraints for
-- manual flag x only apply to some of those goals. In that case, we allow the
-- unconstrained goals to use the default value for x OR any of the values in
-- the constraints on x (even though the constraints don't apply), in order to
-- allow the unconstrained goals to be linked to the constrained goals. See
-- https://github.com/haskell/cabal/issues/4299. Removing the single instance
-- restriction (SIR) would also fix #4299, so we may want to remove this
-- exception and only let the user toggle manual flags if we remove the SIR.
--
-- This function does not enforce any of the constraints, since that is done by
-- 'enforcePackageConstraints'.
enforceManualFlags :: M.Map PN [LabeledPackageConstraint] -> EndoTreeTrav d c
enforceManualFlags :: Map PN [LabeledPackageConstraint] -> EndoTreeTrav d c
enforceManualFlags Map PN [LabeledPackageConstraint]
pcs = EndoTreeTrav d c
forall d c d c. TreeF d c (Tree d c) -> TreeF d c (Tree d c)
go
  where
    go :: TreeF d c (Tree d c) -> TreeF d c (Tree d c)
go (FChoiceF qfn :: QFN
qfn@(FN (Q PackagePath
_ PN
pn) Flag
fn) RevDepMap
rdm c
gr WeakOrTrivial
tr FlagType
Manual Bool
d WeightedPSQ [Weight] Bool (Tree d c)
ts) =
        QFN
-> RevDepMap
-> c
-> WeakOrTrivial
-> FlagType
-> Bool
-> WeightedPSQ [Weight] Bool (Tree d c)
-> TreeF d c (Tree d c)
forall d c a.
QFN
-> RevDepMap
-> c
-> WeakOrTrivial
-> FlagType
-> Bool
-> WeightedPSQ [Weight] Bool a
-> TreeF d c a
FChoiceF QFN
qfn RevDepMap
rdm c
gr WeakOrTrivial
tr FlagType
Manual Bool
d (WeightedPSQ [Weight] Bool (Tree d c) -> TreeF d c (Tree d c))
-> WeightedPSQ [Weight] Bool (Tree d c) -> TreeF d c (Tree d c)
forall a b. (a -> b) -> a -> b
$
          let -- A list of all values specified by constraints on 'fn'.
              -- We ignore the constraint scope in order to handle issue #4299.
              flagConstraintValues :: [Bool]
              flagConstraintValues :: [Bool]
flagConstraintValues =
                  [ Bool
flagVal
                  | let lpcs :: [LabeledPackageConstraint]
lpcs = [LabeledPackageConstraint]
-> PN
-> Map PN [LabeledPackageConstraint]
-> [LabeledPackageConstraint]
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault [] PN
pn Map PN [LabeledPackageConstraint]
pcs
                  , (LabeledPackageConstraint (PackageConstraint ConstraintScope
_ (PackagePropertyFlags FlagAssignment
fa)) ConstraintSource
_) <- [LabeledPackageConstraint]
lpcs
                  , (Flag
fn', Bool
flagVal) <- FlagAssignment -> [(Flag, Bool)]
unFlagAssignment FlagAssignment
fa
                  , Flag
fn' Flag -> Flag -> Bool
forall a. Eq a => a -> a -> Bool
== Flag
fn ]

              -- Prune flag values that are not the default and do not match any
              -- of the constraints.
              restrictToggling :: Eq a => a -> [a] -> a -> Tree d c -> Tree d c
              restrictToggling :: a -> [a] -> a -> Tree d c -> Tree d c
restrictToggling a
flagDefault [a]
constraintVals a
flagVal Tree d c
r =
                  if a
flagVal a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
constraintVals Bool -> Bool -> Bool
|| a
flagVal a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
flagDefault
                  then Tree d c
r
                  else ConflictSet -> FailReason -> Tree d c
forall d c. ConflictSet -> FailReason -> Tree d c
Fail (Var QPN -> ConflictSet
varToConflictSet (QFN -> Var QPN
forall qpn. FN qpn -> Var qpn
F QFN
qfn)) FailReason
ManualFlag

      in (Bool -> Tree d c -> Tree d c)
-> WeightedPSQ [Weight] Bool (Tree d c)
-> WeightedPSQ [Weight] Bool (Tree d c)
forall k v1 v2 w.
(k -> v1 -> v2) -> WeightedPSQ w k v1 -> WeightedPSQ w k v2
W.mapWithKey (Bool -> [Bool] -> Bool -> Tree d c -> Tree d c
forall a d c. Eq a => a -> [a] -> a -> Tree d c -> Tree d c
restrictToggling Bool
d [Bool]
flagConstraintValues) WeightedPSQ [Weight] Bool (Tree d c)
ts
    go TreeF d c (Tree d c)
x                                                            = TreeF d c (Tree d c)
x

-- | Require installed packages.
requireInstalled :: (PN -> Bool) -> EndoTreeTrav d c
requireInstalled :: (PN -> Bool) -> EndoTreeTrav d c
requireInstalled PN -> Bool
p = EndoTreeTrav d c
forall d c d c. TreeF d c (Tree d c) -> TreeF d c (Tree d c)
go
  where
    go :: TreeF d c (Tree d c) -> TreeF d c (Tree d c)
go (PChoiceF v :: QPN
v@(Q PackagePath
_ PN
pn) RevDepMap
rdm c
gr WeightedPSQ [Weight] POption (Tree d c)
cs)
      | PN -> Bool
p PN
pn      = QPN
-> RevDepMap
-> c
-> WeightedPSQ [Weight] POption (Tree d c)
-> TreeF d c (Tree d c)
forall d c a.
QPN
-> RevDepMap -> c -> WeightedPSQ [Weight] POption a -> TreeF d c a
PChoiceF QPN
v RevDepMap
rdm c
gr ((POption -> Tree d c -> Tree d c)
-> WeightedPSQ [Weight] POption (Tree d c)
-> WeightedPSQ [Weight] POption (Tree d c)
forall k v1 v2 w.
(k -> v1 -> v2) -> WeightedPSQ w k v1 -> WeightedPSQ w k v2
W.mapWithKey POption -> Tree d c -> Tree d c
forall d c. POption -> Tree d c -> Tree d c
installed WeightedPSQ [Weight] POption (Tree d c)
cs)
      | Bool
otherwise = QPN
-> RevDepMap
-> c
-> WeightedPSQ [Weight] POption (Tree d c)
-> TreeF d c (Tree d c)
forall d c a.
QPN
-> RevDepMap -> c -> WeightedPSQ [Weight] POption a -> TreeF d c a
PChoiceF QPN
v RevDepMap
rdm c
gr                         WeightedPSQ [Weight] POption (Tree d c)
cs
      where
        installed :: POption -> Tree d c -> Tree d c
installed (POption (I Ver
_ (Inst PId
_)) Maybe PackagePath
_) Tree d c
x = Tree d c
x
        installed POption
_ Tree d c
_ = ConflictSet -> FailReason -> Tree d c
forall d c. ConflictSet -> FailReason -> Tree d c
Fail (Var QPN -> ConflictSet
varToConflictSet (QPN -> Var QPN
forall qpn. qpn -> Var qpn
P QPN
v)) FailReason
CannotInstall
    go TreeF d c (Tree d c)
x          = TreeF d c (Tree d c)
x

-- | Avoid reinstalls.
--
-- This is a tricky strategy. If a package version is installed already and the
-- same version is available from a repo, the repo version will never be chosen.
-- This would result in a reinstall (either destructively, or potentially,
-- shadowing). The old instance won't be visible or even present anymore, but
-- other packages might have depended on it.
--
-- TODO: It would be better to actually check the reverse dependencies of installed
-- packages. If they're not depended on, then reinstalling should be fine. Even if
-- they are, perhaps this should just result in trying to reinstall those other
-- packages as well. However, doing this all neatly in one pass would require to
-- change the builder, or at least to change the goal set after building.
avoidReinstalls :: (PN -> Bool) -> EndoTreeTrav d c
avoidReinstalls :: (PN -> Bool) -> EndoTreeTrav d c
avoidReinstalls PN -> Bool
p = EndoTreeTrav d c
forall d c d c. TreeF d c (Tree d c) -> TreeF d c (Tree d c)
go
  where
    go :: TreeF d c (Tree d c) -> TreeF d c (Tree d c)
go (PChoiceF qpn :: QPN
qpn@(Q PackagePath
_ PN
pn) RevDepMap
rdm c
gr WeightedPSQ [Weight] POption (Tree d c)
cs)
      | PN -> Bool
p PN
pn      = QPN
-> RevDepMap
-> c
-> WeightedPSQ [Weight] POption (Tree d c)
-> TreeF d c (Tree d c)
forall d c a.
QPN
-> RevDepMap -> c -> WeightedPSQ [Weight] POption a -> TreeF d c a
PChoiceF QPN
qpn RevDepMap
rdm c
gr WeightedPSQ [Weight] POption (Tree d c)
disableReinstalls
      | Bool
otherwise = QPN
-> RevDepMap
-> c
-> WeightedPSQ [Weight] POption (Tree d c)
-> TreeF d c (Tree d c)
forall d c a.
QPN
-> RevDepMap -> c -> WeightedPSQ [Weight] POption a -> TreeF d c a
PChoiceF QPN
qpn RevDepMap
rdm c
gr WeightedPSQ [Weight] POption (Tree d c)
cs
      where
        disableReinstalls :: WeightedPSQ [Weight] POption (Tree d c)
disableReinstalls =
          let installed :: [Ver]
installed = [ Ver
v | ([Weight]
_, POption (I Ver
v (Inst PId
_)) Maybe PackagePath
_, Tree d c
_) <- WeightedPSQ [Weight] POption (Tree d c)
-> [([Weight], POption, Tree d c)]
forall w k v. WeightedPSQ w k v -> [(w, k, v)]
W.toList WeightedPSQ [Weight] POption (Tree d c)
cs ]
          in  (POption -> Tree d c -> Tree d c)
-> WeightedPSQ [Weight] POption (Tree d c)
-> WeightedPSQ [Weight] POption (Tree d c)
forall k v1 v2 w.
(k -> v1 -> v2) -> WeightedPSQ w k v1 -> WeightedPSQ w k v2
W.mapWithKey ([Ver] -> POption -> Tree d c -> Tree d c
forall (t :: * -> *) d c.
Foldable t =>
t Ver -> POption -> Tree d c -> Tree d c
notReinstall [Ver]
installed) WeightedPSQ [Weight] POption (Tree d c)
cs

        notReinstall :: t Ver -> POption -> Tree d c -> Tree d c
notReinstall t Ver
vs (POption (I Ver
v Loc
InRepo) Maybe PackagePath
_) Tree d c
_ | Ver
v Ver -> t Ver -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t Ver
vs =
          ConflictSet -> FailReason -> Tree d c
forall d c. ConflictSet -> FailReason -> Tree d c
Fail (Var QPN -> ConflictSet
varToConflictSet (QPN -> Var QPN
forall qpn. qpn -> Var qpn
P QPN
qpn)) FailReason
CannotReinstall
        notReinstall t Ver
_ POption
_ Tree d c
x =
          Tree d c
x
    go TreeF d c (Tree d c)
x          = TreeF d c (Tree d c)
x

-- | Require all packages to be mentioned in a constraint or as a goal.
onlyConstrained :: (PN -> Bool) -> EndoTreeTrav d QGoalReason
onlyConstrained :: (PN -> Bool) -> EndoTreeTrav d QGoalReason
onlyConstrained PN -> Bool
p = EndoTreeTrav d QGoalReason
forall d a. TreeF d QGoalReason a -> TreeF d QGoalReason a
go
  where
    go :: TreeF d QGoalReason a -> TreeF d QGoalReason a
go (PChoiceF v :: QPN
v@(Q PackagePath
_ PN
pn) RevDepMap
_ QGoalReason
gr WeightedPSQ [Weight] POption a
_) | Bool -> Bool
not (PN -> Bool
p PN
pn)
      = ConflictSet -> FailReason -> TreeF d QGoalReason a
forall d c a. ConflictSet -> FailReason -> TreeF d c a
FailF
        (Var QPN -> ConflictSet
varToConflictSet (QPN -> Var QPN
forall qpn. qpn -> Var qpn
P QPN
v) ConflictSet -> ConflictSet -> ConflictSet
`CS.union` QPN -> QGoalReason -> ConflictSet
goalReasonToConflictSetWithConflict QPN
v QGoalReason
gr)
        FailReason
NotExplicit
    go TreeF d QGoalReason a
x
      = TreeF d QGoalReason a
x

-- | Sort all goals using the provided function.
sortGoals :: (Variable QPN -> Variable QPN -> Ordering) -> EndoTreeTrav d c
sortGoals :: (Variable QPN -> Variable QPN -> Ordering) -> EndoTreeTrav d c
sortGoals Variable QPN -> Variable QPN -> Ordering
variableOrder = EndoTreeTrav d c
forall d c a. TreeF d c a -> TreeF d c a
go
  where
    go :: TreeF d c a -> TreeF d c a
go (GoalChoiceF RevDepMap
rdm PSQ (Goal QPN) a
xs) = RevDepMap -> PSQ (Goal QPN) a -> TreeF d c a
forall d c a. RevDepMap -> PSQ (Goal QPN) a -> TreeF d c a
GoalChoiceF RevDepMap
rdm ((Goal QPN -> Goal QPN -> Ordering)
-> PSQ (Goal QPN) a -> PSQ (Goal QPN) a
forall k a. (k -> k -> Ordering) -> PSQ k a -> PSQ k a
P.sortByKeys Goal QPN -> Goal QPN -> Ordering
goalOrder PSQ (Goal QPN) a
xs)
    go TreeF d c a
x                    = TreeF d c a
x

    goalOrder :: Goal QPN -> Goal QPN -> Ordering
    goalOrder :: Goal QPN -> Goal QPN -> Ordering
goalOrder = Variable QPN -> Variable QPN -> Ordering
variableOrder (Variable QPN -> Variable QPN -> Ordering)
-> (Goal QPN -> Variable QPN) -> Goal QPN -> Goal QPN -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Var QPN -> Variable QPN
varToVariable (Var QPN -> Variable QPN)
-> (Goal QPN -> Var QPN) -> Goal QPN -> Variable QPN
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Goal QPN -> Var QPN
forall a. Goal a -> Var a
goalToVar)

    varToVariable :: Var QPN -> Variable QPN
    varToVariable :: Var QPN -> Variable QPN
varToVariable (P QPN
qpn)                    = QPN -> Variable QPN
forall qpn. qpn -> Variable qpn
PackageVar QPN
qpn
    varToVariable (F (FN QPN
qpn Flag
fn))     = QPN -> Flag -> Variable QPN
forall qpn. qpn -> Flag -> Variable qpn
FlagVar QPN
qpn Flag
fn
    varToVariable (S (SN QPN
qpn OptionalStanza
stanza)) = QPN -> OptionalStanza -> Variable QPN
forall qpn. qpn -> OptionalStanza -> Variable qpn
StanzaVar QPN
qpn OptionalStanza
stanza

-- | Reduce the branching degree of the search tree by removing all choices
-- after the first successful choice at each level. The returned tree is the
-- minimal subtree containing the path to the first backjump.
pruneAfterFirstSuccess :: EndoTreeTrav d c
pruneAfterFirstSuccess :: EndoTreeTrav d c
pruneAfterFirstSuccess = EndoTreeTrav d c
forall d c d c. TreeF d c (Tree d c) -> TreeF d c (Tree d c)
go
  where
    go :: TreeF d c (Tree d c) -> TreeF d c (Tree d c)
go (PChoiceF QPN
qpn RevDepMap
rdm c
gr       WeightedPSQ [Weight] POption (Tree d c)
ts) = QPN
-> RevDepMap
-> c
-> WeightedPSQ [Weight] POption (Tree d c)
-> TreeF d c (Tree d c)
forall d c a.
QPN
-> RevDepMap -> c -> WeightedPSQ [Weight] POption a -> TreeF d c a
PChoiceF QPN
qpn RevDepMap
rdm c
gr       ((Tree d c -> Bool)
-> WeightedPSQ [Weight] POption (Tree d c)
-> WeightedPSQ [Weight] POption (Tree d c)
forall w k v. (v -> Bool) -> WeightedPSQ w k v -> WeightedPSQ w k v
W.takeUntil Tree d c -> Bool
forall d c. Tree d c -> Bool
active WeightedPSQ [Weight] POption (Tree d c)
ts)
    go (FChoiceF QFN
qfn RevDepMap
rdm c
gr WeakOrTrivial
w FlagType
m Bool
d WeightedPSQ [Weight] Bool (Tree d c)
ts) = QFN
-> RevDepMap
-> c
-> WeakOrTrivial
-> FlagType
-> Bool
-> WeightedPSQ [Weight] Bool (Tree d c)
-> TreeF d c (Tree d c)
forall d c a.
QFN
-> RevDepMap
-> c
-> WeakOrTrivial
-> FlagType
-> Bool
-> WeightedPSQ [Weight] Bool a
-> TreeF d c a
FChoiceF QFN
qfn RevDepMap
rdm c
gr WeakOrTrivial
w FlagType
m Bool
d ((Tree d c -> Bool)
-> WeightedPSQ [Weight] Bool (Tree d c)
-> WeightedPSQ [Weight] Bool (Tree d c)
forall w k v. (v -> Bool) -> WeightedPSQ w k v -> WeightedPSQ w k v
W.takeUntil Tree d c -> Bool
forall d c. Tree d c -> Bool
active WeightedPSQ [Weight] Bool (Tree d c)
ts)
    go (SChoiceF QSN
qsn RevDepMap
rdm c
gr WeakOrTrivial
w     WeightedPSQ [Weight] Bool (Tree d c)
ts) = QSN
-> RevDepMap
-> c
-> WeakOrTrivial
-> WeightedPSQ [Weight] Bool (Tree d c)
-> TreeF d c (Tree d c)
forall d c a.
QSN
-> RevDepMap
-> c
-> WeakOrTrivial
-> WeightedPSQ [Weight] Bool a
-> TreeF d c a
SChoiceF QSN
qsn RevDepMap
rdm c
gr WeakOrTrivial
w     ((Tree d c -> Bool)
-> WeightedPSQ [Weight] Bool (Tree d c)
-> WeightedPSQ [Weight] Bool (Tree d c)
forall w k v. (v -> Bool) -> WeightedPSQ w k v -> WeightedPSQ w k v
W.takeUntil Tree d c -> Bool
forall d c. Tree d c -> Bool
active WeightedPSQ [Weight] Bool (Tree d c)
ts)
    go TreeF d c (Tree d c)
x                              = TreeF d c (Tree d c)
x

-- | Always choose the first goal in the list next, abandoning all
-- other choices.
--
-- This is unnecessary for the default search strategy, because
-- it descends only into the first goal choice anyway,
-- but may still make sense to just reduce the tree size a bit.
firstGoal :: EndoTreeTrav d c
firstGoal :: EndoTreeTrav d c
firstGoal = EndoTreeTrav d c
forall d c a. TreeF d c a -> TreeF d c a
go
  where
    go :: TreeF d c a -> TreeF d c a
go (GoalChoiceF RevDepMap
rdm PSQ (Goal QPN) a
xs) = RevDepMap -> PSQ (Goal QPN) a -> TreeF d c a
forall d c a. RevDepMap -> PSQ (Goal QPN) a -> TreeF d c a
GoalChoiceF RevDepMap
rdm (PSQ (Goal QPN) a -> PSQ (Goal QPN) a
forall k a. PSQ k a -> PSQ k a
P.firstOnly PSQ (Goal QPN) a
xs)
    go TreeF d c a
x                    = TreeF d c a
x
    -- Note that we keep empty choice nodes, because they mean success.

-- | Transformation that tries to make a decision on base as early as
-- possible by pruning all other goals when base is available. In nearly
-- all cases, there's a single choice for the base package. Also, fixing
-- base early should lead to better error messages.
preferBaseGoalChoice :: EndoTreeTrav d c
preferBaseGoalChoice :: EndoTreeTrav d c
preferBaseGoalChoice = EndoTreeTrav d c
forall d c a. TreeF d c a -> TreeF d c a
go
  where
    go :: TreeF d c a -> TreeF d c a
go (GoalChoiceF RevDepMap
rdm PSQ (Goal QPN) a
xs) = RevDepMap -> PSQ (Goal QPN) a -> TreeF d c a
forall d c a. RevDepMap -> PSQ (Goal QPN) a -> TreeF d c a
GoalChoiceF RevDepMap
rdm ((Goal QPN -> Bool) -> PSQ (Goal QPN) a -> PSQ (Goal QPN) a
forall k a. (k -> Bool) -> PSQ k a -> PSQ k a
P.filterIfAnyByKeys Goal QPN -> Bool
isBase PSQ (Goal QPN) a
xs)
    go TreeF d c a
x                    = TreeF d c a
x

    isBase :: Goal QPN -> Bool
    isBase :: Goal QPN -> Bool
isBase (Goal (P (Q PackagePath
_pp PN
pn)) QGoalReason
_) = PN -> String
unPN PN
pn String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"base"
    isBase Goal QPN
_                       = Bool
False

-- | Deal with setup and build-tool-depends dependencies after regular dependencies,
-- so we will link setup/exe dependencies against package dependencies when possible
deferSetupExeChoices :: EndoTreeTrav d c
deferSetupExeChoices :: EndoTreeTrav d c
deferSetupExeChoices = EndoTreeTrav d c
forall d c a. TreeF d c a -> TreeF d c a
go
  where
    go :: TreeF d c a -> TreeF d c a
go (GoalChoiceF RevDepMap
rdm PSQ (Goal QPN) a
xs) = RevDepMap -> PSQ (Goal QPN) a -> TreeF d c a
forall d c a. RevDepMap -> PSQ (Goal QPN) a -> TreeF d c a
GoalChoiceF RevDepMap
rdm ((Goal QPN -> Bool) -> PSQ (Goal QPN) a -> PSQ (Goal QPN) a
forall k a. (k -> Bool) -> PSQ k a -> PSQ k a
P.preferByKeys Goal QPN -> Bool
noSetupOrExe PSQ (Goal QPN) a
xs)
    go TreeF d c a
x                    = TreeF d c a
x

    noSetupOrExe :: Goal QPN -> Bool
    noSetupOrExe :: Goal QPN -> Bool
noSetupOrExe (Goal (P (Q (PackagePath Namespace
_ns (QualSetup PN
_)) PN
_)) QGoalReason
_) = Bool
False
    noSetupOrExe (Goal (P (Q (PackagePath Namespace
_ns (QualExe PN
_ PN
_)) PN
_)) QGoalReason
_) = Bool
False
    noSetupOrExe Goal QPN
_                                                  = Bool
True

-- | Transformation that tries to avoid making weak flag choices early.
-- Weak flags are trivial flags (not influencing dependencies) or such
-- flags that are explicitly declared to be weak in the index.
deferWeakFlagChoices :: EndoTreeTrav d c
deferWeakFlagChoices :: EndoTreeTrav d c
deferWeakFlagChoices = EndoTreeTrav d c
forall d c d c. TreeF d c (Tree d c) -> TreeF d c (Tree d c)
go
  where
    go :: TreeF d c (Tree d c) -> TreeF d c (Tree d c)
go (GoalChoiceF RevDepMap
rdm PSQ (Goal QPN) (Tree d c)
xs) = RevDepMap -> PSQ (Goal QPN) (Tree d c) -> TreeF d c (Tree d c)
forall d c a. RevDepMap -> PSQ (Goal QPN) a -> TreeF d c a
GoalChoiceF RevDepMap
rdm ((Tree d c -> Bool)
-> PSQ (Goal QPN) (Tree d c) -> PSQ (Goal QPN) (Tree d c)
forall a k. (a -> Bool) -> PSQ k a -> PSQ k a
P.prefer Tree d c -> Bool
forall d c. Tree d c -> Bool
noWeakFlag ((Tree d c -> Bool)
-> PSQ (Goal QPN) (Tree d c) -> PSQ (Goal QPN) (Tree d c)
forall a k. (a -> Bool) -> PSQ k a -> PSQ k a
P.prefer Tree d c -> Bool
forall d c. Tree d c -> Bool
noWeakStanza PSQ (Goal QPN) (Tree d c)
xs))
    go TreeF d c (Tree d c)
x                    = TreeF d c (Tree d c)
x

    noWeakStanza :: Tree d c -> Bool
    noWeakStanza :: Tree d c -> Bool
noWeakStanza (SChoice QSN
_ RevDepMap
_ c
_ (WeakOrTrivial Bool
True)   WeightedPSQ [Weight] Bool (Tree d c)
_) = Bool
False
    noWeakStanza Tree d c
_                                        = Bool
True

    noWeakFlag :: Tree d c -> Bool
    noWeakFlag :: Tree d c -> Bool
noWeakFlag (FChoice QFN
_ RevDepMap
_ c
_ (WeakOrTrivial Bool
True) FlagType
_ Bool
_ WeightedPSQ [Weight] Bool (Tree d c)
_) = Bool
False
    noWeakFlag Tree d c
_                                          = Bool
True

-- | Transformation that prefers goals with lower branching degrees.
--
-- When a goal choice node has at least one goal with zero or one children, this
-- function prunes all other goals. This transformation can help the solver find
-- a solution in fewer steps by allowing it to backtrack sooner when it is
-- exploring a subtree with no solutions. However, each step is more expensive.
preferReallyEasyGoalChoices :: EndoTreeTrav d c
preferReallyEasyGoalChoices :: EndoTreeTrav d c
preferReallyEasyGoalChoices = EndoTreeTrav d c
forall d c d c. TreeF d c (Tree d c) -> TreeF d c (Tree d c)
go
  where
    go :: TreeF d c (Tree d c) -> TreeF d c (Tree d c)
go (GoalChoiceF RevDepMap
rdm PSQ (Goal QPN) (Tree d c)
xs) = RevDepMap -> PSQ (Goal QPN) (Tree d c) -> TreeF d c (Tree d c)
forall d c a. RevDepMap -> PSQ (Goal QPN) a -> TreeF d c a
GoalChoiceF RevDepMap
rdm ((Tree d c -> Bool)
-> PSQ (Goal QPN) (Tree d c) -> PSQ (Goal QPN) (Tree d c)
forall a k. (a -> Bool) -> PSQ k a -> PSQ k a
P.filterIfAny Tree d c -> Bool
forall d c. Tree d c -> Bool
zeroOrOneChoices PSQ (Goal QPN) (Tree d c)
xs)
    go TreeF d c (Tree d c)
x                    = TreeF d c (Tree d c)
x

-- | Monad used internally in enforceSingleInstanceRestriction
--
-- For each package instance we record the goal for which we picked a concrete
-- instance. The SIR means that for any package instance there can only be one.
type EnforceSIR = Reader (Map (PI PN) QPN)

-- | Enforce ghc's single instance restriction
--
-- From the solver's perspective, this means that for any package instance
-- (that is, package name + package version) there can be at most one qualified
-- goal resolving to that instance (there may be other goals _linking_ to that
-- instance however).
enforceSingleInstanceRestriction :: Tree d c -> Tree d c
enforceSingleInstanceRestriction :: Tree d c -> Tree d c
enforceSingleInstanceRestriction = (Reader (Map (PI PN) QPN) (Tree d c) -> Map (PI PN) QPN -> Tree d c
forall r a. Reader r a -> r -> a
`runReader` Map (PI PN) QPN
forall k a. Map k a
M.empty) (Reader (Map (PI PN) QPN) (Tree d c) -> Tree d c)
-> (Tree d c -> Reader (Map (PI PN) QPN) (Tree d c))
-> Tree d c
-> Tree d c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree d c -> Reader (Map (PI PN) QPN) (Tree d c)
forall d c. Tree d c -> EnforceSIR (Tree d c)
go
  where
    go :: Tree d c -> EnforceSIR (Tree d c)

    -- We just verify package choices.
    go :: Tree d c -> EnforceSIR (Tree d c)
go (PChoice QPN
qpn RevDepMap
rdm c
gr WeightedPSQ [Weight] POption (Tree d c)
cs) =
      QPN
-> RevDepMap
-> c
-> WeightedPSQ [Weight] POption (Tree d c)
-> Tree d c
forall d c.
QPN
-> RevDepMap
-> c
-> WeightedPSQ [Weight] POption (Tree d c)
-> Tree d c
PChoice QPN
qpn RevDepMap
rdm c
gr (WeightedPSQ [Weight] POption (Tree d c) -> Tree d c)
-> ReaderT
     (Map (PI PN) QPN)
     Identity
     (WeightedPSQ [Weight] POption (Tree d c))
-> EnforceSIR (Tree d c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WeightedPSQ [Weight] POption (EnforceSIR (Tree d c))
-> ReaderT
     (Map (PI PN) QPN)
     Identity
     (WeightedPSQ [Weight] POption (Tree d c))
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA ((POption -> EnforceSIR (Tree d c) -> EnforceSIR (Tree d c))
-> WeightedPSQ [Weight] POption (EnforceSIR (Tree d c))
-> WeightedPSQ [Weight] POption (EnforceSIR (Tree d c))
forall k v1 v2 w.
(k -> v1 -> v2) -> WeightedPSQ w k v1 -> WeightedPSQ w k v2
W.mapWithKey (QPN -> POption -> EnforceSIR (Tree d c) -> EnforceSIR (Tree d c)
forall d c.
QPN -> POption -> EnforceSIR (Tree d c) -> EnforceSIR (Tree d c)
goP QPN
qpn) ((Tree d c -> EnforceSIR (Tree d c))
-> WeightedPSQ [Weight] POption (Tree d c)
-> WeightedPSQ [Weight] POption (EnforceSIR (Tree d c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Tree d c -> EnforceSIR (Tree d c)
forall d c. Tree d c -> EnforceSIR (Tree d c)
go WeightedPSQ [Weight] POption (Tree d c)
cs))
    go (FChoice QFN
qfn RevDepMap
rdm c
y WeakOrTrivial
t FlagType
m Bool
d WeightedPSQ [Weight] Bool (Tree d c)
ts) =
      QFN
-> RevDepMap
-> c
-> WeakOrTrivial
-> FlagType
-> Bool
-> WeightedPSQ [Weight] Bool (Tree d c)
-> Tree d c
forall d c.
QFN
-> RevDepMap
-> c
-> WeakOrTrivial
-> FlagType
-> Bool
-> WeightedPSQ [Weight] Bool (Tree d c)
-> Tree d c
FChoice QFN
qfn RevDepMap
rdm c
y WeakOrTrivial
t FlagType
m Bool
d (WeightedPSQ [Weight] Bool (Tree d c) -> Tree d c)
-> ReaderT
     (Map (PI PN) QPN) Identity (WeightedPSQ [Weight] Bool (Tree d c))
-> EnforceSIR (Tree d c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Tree d c -> EnforceSIR (Tree d c))
-> WeightedPSQ [Weight] Bool (Tree d c)
-> ReaderT
     (Map (PI PN) QPN) Identity (WeightedPSQ [Weight] Bool (Tree d c))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Tree d c -> EnforceSIR (Tree d c)
forall d c. Tree d c -> EnforceSIR (Tree d c)
go WeightedPSQ [Weight] Bool (Tree d c)
ts
    go (SChoice QSN
qsn RevDepMap
rdm c
y WeakOrTrivial
t WeightedPSQ [Weight] Bool (Tree d c)
ts) =
      QSN
-> RevDepMap
-> c
-> WeakOrTrivial
-> WeightedPSQ [Weight] Bool (Tree d c)
-> Tree d c
forall d c.
QSN
-> RevDepMap
-> c
-> WeakOrTrivial
-> WeightedPSQ [Weight] Bool (Tree d c)
-> Tree d c
SChoice QSN
qsn RevDepMap
rdm c
y WeakOrTrivial
t (WeightedPSQ [Weight] Bool (Tree d c) -> Tree d c)
-> ReaderT
     (Map (PI PN) QPN) Identity (WeightedPSQ [Weight] Bool (Tree d c))
-> EnforceSIR (Tree d c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Tree d c -> EnforceSIR (Tree d c))
-> WeightedPSQ [Weight] Bool (Tree d c)
-> ReaderT
     (Map (PI PN) QPN) Identity (WeightedPSQ [Weight] Bool (Tree d c))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Tree d c -> EnforceSIR (Tree d c)
forall d c. Tree d c -> EnforceSIR (Tree d c)
go WeightedPSQ [Weight] Bool (Tree d c)
ts
    go (GoalChoice RevDepMap
rdm PSQ (Goal QPN) (Tree d c)
ts) =
      RevDepMap -> PSQ (Goal QPN) (Tree d c) -> Tree d c
forall d c. RevDepMap -> PSQ (Goal QPN) (Tree d c) -> Tree d c
GoalChoice RevDepMap
rdm (PSQ (Goal QPN) (Tree d c) -> Tree d c)
-> ReaderT (Map (PI PN) QPN) Identity (PSQ (Goal QPN) (Tree d c))
-> EnforceSIR (Tree d c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Tree d c -> EnforceSIR (Tree d c))
-> PSQ (Goal QPN) (Tree d c)
-> ReaderT (Map (PI PN) QPN) Identity (PSQ (Goal QPN) (Tree d c))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Tree d c -> EnforceSIR (Tree d c)
forall d c. Tree d c -> EnforceSIR (Tree d c)
go PSQ (Goal QPN) (Tree d c)
ts
    go x :: Tree d c
x@(Fail ConflictSet
_ FailReason
_) = Tree d c -> EnforceSIR (Tree d c)
forall (m :: * -> *) a. Monad m => a -> m a
return Tree d c
x
    go x :: Tree d c
x@(Done RevDepMap
_ d
_) = Tree d c -> EnforceSIR (Tree d c)
forall (m :: * -> *) a. Monad m => a -> m a
return Tree d c
x

    -- The check proper
    goP :: QPN -> POption -> EnforceSIR (Tree d c) -> EnforceSIR (Tree d c)
    goP :: QPN -> POption -> EnforceSIR (Tree d c) -> EnforceSIR (Tree d c)
goP qpn :: QPN
qpn@(Q PackagePath
_ PN
pn) (POption I
i Maybe PackagePath
linkedTo) EnforceSIR (Tree d c)
r = do
      let inst :: PI PN
inst = PN -> I -> PI PN
forall qpn. qpn -> I -> PI qpn
PI PN
pn I
i
      Map (PI PN) QPN
env <- ReaderT (Map (PI PN) QPN) Identity (Map (PI PN) QPN)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
      case (Maybe PackagePath
linkedTo, PI PN -> Map (PI PN) QPN -> Maybe QPN
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PI PN
inst Map (PI PN) QPN
env) of
        (Just PackagePath
_, Maybe QPN
_) ->
          -- For linked nodes we don't check anything
          EnforceSIR (Tree d c)
r
        (Maybe PackagePath
Nothing, Maybe QPN
Nothing) ->
          -- Not linked, not already used
          (Map (PI PN) QPN -> Map (PI PN) QPN)
-> EnforceSIR (Tree d c) -> EnforceSIR (Tree d c)
forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r m a
local (PI PN -> QPN -> Map (PI PN) QPN -> Map (PI PN) QPN
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert PI PN
inst QPN
qpn) EnforceSIR (Tree d c)
r
        (Maybe PackagePath
Nothing, Just QPN
qpn') -> do
          -- Not linked, already used. This is an error
          Tree d c -> EnforceSIR (Tree d c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree d c -> EnforceSIR (Tree d c))
-> Tree d c -> EnforceSIR (Tree d c)
forall a b. (a -> b) -> a -> b
$ ConflictSet -> FailReason -> Tree d c
forall d c. ConflictSet -> FailReason -> Tree d c
Fail (ConflictSet -> ConflictSet -> ConflictSet
CS.union (Var QPN -> ConflictSet
varToConflictSet (QPN -> Var QPN
forall qpn. qpn -> Var qpn
P QPN
qpn)) (Var QPN -> ConflictSet
varToConflictSet (QPN -> Var QPN
forall qpn. qpn -> Var qpn
P QPN
qpn'))) FailReason
MultipleInstances