{-# LANGUAGE CPP #-}
#ifdef DEBUG_TRACETREE
{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
#endif
module Distribution.Solver.Modular.Solver
( SolverConfig(..)
, solve
, PruneAfterFirstSuccess(..)
) where
import Distribution.Solver.Compat.Prelude
import Prelude ()
import qualified Data.Map as M
import qualified Data.List as L
import qualified Data.Set as S
import Distribution.Verbosity
import Distribution.Compiler (CompilerInfo)
import Distribution.Solver.Types.PackagePath
import Distribution.Solver.Types.PackagePreferences
import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb)
import Distribution.Solver.Types.LabeledPackageConstraint
import Distribution.Solver.Types.Settings
import Distribution.Solver.Types.Variable
import Distribution.Solver.Modular.Assignment
import Distribution.Solver.Modular.Builder
import Distribution.Solver.Modular.Cycles
import Distribution.Solver.Modular.Dependency
import Distribution.Solver.Modular.Explore
import Distribution.Solver.Modular.Index
import Distribution.Solver.Modular.Log
import Distribution.Solver.Modular.Message
import Distribution.Solver.Modular.Package
import qualified Distribution.Solver.Modular.Preference as P
import Distribution.Solver.Modular.Validate
import Distribution.Solver.Modular.Linking
import Distribution.Solver.Modular.PSQ (PSQ)
import Distribution.Solver.Modular.RetryLog
import Distribution.Solver.Modular.Tree
import qualified Distribution.Solver.Modular.PSQ as PSQ
import Distribution.Simple.Setup (BooleanFlag(..))
#ifdef DEBUG_TRACETREE
import qualified Distribution.Solver.Modular.ConflictSet as CS
import qualified Distribution.Solver.Modular.WeightedPSQ as W
import qualified Distribution.Deprecated.Text as T
import Debug.Trace.Tree (gtraceJson)
import Debug.Trace.Tree.Simple
import Debug.Trace.Tree.Generic
import Debug.Trace.Tree.Assoc (Assoc(..))
#endif
data SolverConfig = SolverConfig {
SolverConfig -> ReorderGoals
reorderGoals :: ReorderGoals,
SolverConfig -> CountConflicts
countConflicts :: CountConflicts,
SolverConfig -> FineGrainedConflicts
fineGrainedConflicts :: FineGrainedConflicts,
SolverConfig -> MinimizeConflictSet
minimizeConflictSet :: MinimizeConflictSet,
SolverConfig -> IndependentGoals
independentGoals :: IndependentGoals,
SolverConfig -> AvoidReinstalls
avoidReinstalls :: AvoidReinstalls,
SolverConfig -> ShadowPkgs
shadowPkgs :: ShadowPkgs,
SolverConfig -> StrongFlags
strongFlags :: StrongFlags,
SolverConfig -> AllowBootLibInstalls
allowBootLibInstalls :: AllowBootLibInstalls,
SolverConfig -> OnlyConstrained
onlyConstrained :: OnlyConstrained,
SolverConfig -> Maybe Int
maxBackjumps :: Maybe Int,
SolverConfig -> EnableBackjumping
enableBackjumping :: EnableBackjumping,
SolverConfig -> SolveExecutables
solveExecutables :: SolveExecutables,
SolverConfig -> Maybe (Variable QPN -> Variable QPN -> Ordering)
goalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering),
SolverConfig -> Verbosity
solverVerbosity :: Verbosity,
SolverConfig -> PruneAfterFirstSuccess
pruneAfterFirstSuccess :: PruneAfterFirstSuccess
}
newtype PruneAfterFirstSuccess = PruneAfterFirstSuccess Bool
solve :: SolverConfig
-> CompilerInfo
-> Index
-> PkgConfigDb
-> (PN -> PackagePreferences)
-> M.Map PN [LabeledPackageConstraint]
-> S.Set PN
-> RetryLog Message SolverFailure (Assignment, RevDepMap)
solve :: SolverConfig
-> CompilerInfo
-> Index
-> PkgConfigDb
-> (PN -> PackagePreferences)
-> Map PN [LabeledPackageConstraint]
-> Set PN
-> RetryLog Message SolverFailure (Assignment, RevDepMap)
solve SolverConfig
sc CompilerInfo
cinfo Index
idx PkgConfigDb
pkgConfigDB PN -> PackagePreferences
userPrefs Map PN [LabeledPackageConstraint]
userConstraints Set PN
userGoals =
forall {d}.
Tree d QGoalReason
-> RetryLog Message SolverFailure (Assignment, RevDepMap)
explorePhase forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a. FilePath -> (a -> a) -> a -> a
traceTree FilePath
"cycles.json" forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall {d} {c}. Tree d c -> Tree d c
detectCycles forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a. FilePath -> (a -> a) -> a -> a
traceTree FilePath
"heuristics.json" forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall d c a. TreeTrav d c a -> Tree d c -> Tree d a
trav (
forall {d} {c}. TreeF d c (Tree d c) -> TreeF d c (Tree d c)
heuristicsPhase forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall {d} {c}. TreeF d c (Tree d c) -> TreeF d c (Tree d c)
preferencesPhase forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall {d} {c}. TreeF d c (Tree d c) -> TreeF d c (Tree d c)
validationPhase
) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a. FilePath -> (a -> a) -> a -> a
traceTree FilePath
"semivalidated.json" forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall {d} {c}. Tree d c -> Tree d c
validationCata forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a. FilePath -> (a -> a) -> a -> a
traceTree FilePath
"pruned.json" forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall d c a. TreeTrav d c a -> Tree d c -> Tree d a
trav forall {d}.
TreeF d QGoalReason (Tree d QGoalReason)
-> TreeF d QGoalReason (Tree d QGoalReason)
prunePhase forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a. FilePath -> (a -> a) -> a -> a
traceTree FilePath
"build.json" forall a. a -> a
id forall a b. (a -> b) -> a -> b
$
Tree () QGoalReason
buildPhase
where
explorePhase :: Tree d QGoalReason
-> RetryLog Message SolverFailure (Assignment, RevDepMap)
explorePhase = forall d.
Maybe Int
-> EnableBackjumping
-> FineGrainedConflicts
-> CountConflicts
-> Index
-> Tree d QGoalReason
-> RetryLog Message SolverFailure (Assignment, RevDepMap)
backjumpAndExplore (SolverConfig -> Maybe Int
maxBackjumps SolverConfig
sc)
(SolverConfig -> EnableBackjumping
enableBackjumping SolverConfig
sc)
(SolverConfig -> FineGrainedConflicts
fineGrainedConflicts SolverConfig
sc)
(SolverConfig -> CountConflicts
countConflicts SolverConfig
sc)
Index
idx
detectCycles :: Tree d c -> Tree d c
detectCycles = forall {d} {c}. Tree d c -> Tree d c
detectCyclesPhase
heuristicsPhase :: TreeF d c (Tree d c) -> TreeF d c (Tree d c)
heuristicsPhase =
let
sortGoals :: TreeF d c (Tree d c) -> TreeF d c (Tree d c)
sortGoals = case SolverConfig -> Maybe (Variable QPN -> Variable QPN -> Ordering)
goalOrder SolverConfig
sc of
Maybe (Variable QPN -> Variable QPN -> Ordering)
Nothing -> forall {d} {c}. TreeF d c (Tree d c) -> TreeF d c (Tree d c)
goalChoiceHeuristics forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall {d} {c}. TreeF d c (Tree d c) -> TreeF d c (Tree d c)
P.deferSetupExeChoices forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall {d} {c}. TreeF d c (Tree d c) -> TreeF d c (Tree d c)
P.deferWeakFlagChoices forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall {d} {c}. TreeF d c (Tree d c) -> TreeF d c (Tree d c)
P.preferBaseGoalChoice
Just Variable QPN -> Variable QPN -> Ordering
order -> forall {d} {c}. TreeF d c (Tree d c) -> TreeF d c (Tree d c)
P.firstGoal forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall d c.
(Variable QPN -> Variable QPN -> Ordering) -> EndoTreeTrav d c
P.sortGoals Variable QPN -> Variable QPN -> Ordering
order
PruneAfterFirstSuccess Bool
prune = SolverConfig -> PruneAfterFirstSuccess
pruneAfterFirstSuccess SolverConfig
sc
in forall {d} {c}. TreeF d c (Tree d c) -> TreeF d c (Tree d c)
sortGoals forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(if Bool
prune then forall {d} {c}. TreeF d c (Tree d c) -> TreeF d c (Tree d c)
P.pruneAfterFirstSuccess else forall a. a -> a
id)
preferencesPhase :: TreeF d c (Tree d c) -> TreeF d c (Tree d c)
preferencesPhase = forall {d} {c}. TreeF d c (Tree d c) -> TreeF d c (Tree d c)
P.preferLinked forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall d c. (PN -> PackagePreferences) -> EndoTreeTrav d c
P.preferPackagePreferences PN -> PackagePreferences
userPrefs
validationPhase :: TreeF d c (Tree d c) -> TreeF d c (Tree d c)
validationPhase = forall d c. Map PN [LabeledPackageConstraint] -> EndoTreeTrav d c
P.enforcePackageConstraints Map PN [LabeledPackageConstraint]
userConstraints forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall d c. Map PN [LabeledPackageConstraint] -> EndoTreeTrav d c
P.enforceManualFlags Map PN [LabeledPackageConstraint]
userConstraints
validationCata :: Tree d c -> Tree d c
validationCata = forall {d} {c}. Tree d c -> Tree d c
P.enforceSingleInstanceRestriction forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall d c. Index -> Tree d c -> Tree d c
validateLinking Index
idx forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall d c.
CompilerInfo -> Index -> PkgConfigDb -> Tree d c -> Tree d c
validateTree CompilerInfo
cinfo Index
idx PkgConfigDb
pkgConfigDB
prunePhase :: TreeF d QGoalReason (Tree d QGoalReason)
-> TreeF d QGoalReason (Tree d QGoalReason)
prunePhase = (if forall a. BooleanFlag a => a -> Bool
asBool (SolverConfig -> AvoidReinstalls
avoidReinstalls SolverConfig
sc) then forall d c. (PN -> Bool) -> EndoTreeTrav d c
P.avoidReinstalls (forall a b. a -> b -> a
const Bool
True) else forall a. a -> a
id) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(if forall a. BooleanFlag a => a -> Bool
asBool (SolverConfig -> AllowBootLibInstalls
allowBootLibInstalls SolverConfig
sc)
then forall a. a -> a
id
else forall d c. (PN -> Bool) -> EndoTreeTrav d c
P.requireInstalled (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PN]
nonInstallable)) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(case SolverConfig -> OnlyConstrained
onlyConstrained SolverConfig
sc of
OnlyConstrained
OnlyConstrainedAll ->
forall d. (PN -> Bool) -> EndoTreeTrav d QGoalReason
P.onlyConstrained PN -> Bool
pkgIsExplicit
OnlyConstrained
OnlyConstrainedNone ->
forall a. a -> a
id)
buildPhase :: Tree () QGoalReason
buildPhase = Index -> IndependentGoals -> [PN] -> Tree () QGoalReason
buildTree Index
idx (SolverConfig -> IndependentGoals
independentGoals SolverConfig
sc) (forall a. Set a -> [a]
S.toList Set PN
userGoals)
allExplicit :: Set PN
allExplicit = forall k a. Map k a -> Set k
M.keysSet Map PN [LabeledPackageConstraint]
userConstraints forall a. Ord a => Set a -> Set a -> Set a
`S.union` Set PN
userGoals
pkgIsExplicit :: PN -> Bool
pkgIsExplicit :: PN -> Bool
pkgIsExplicit PN
pn = forall a. Ord a => a -> Set a -> Bool
S.member PN
pn Set PN
allExplicit
nonInstallable :: [PackageName]
nonInstallable :: [PN]
nonInstallable =
forall a b. (a -> b) -> [a] -> [b]
L.map FilePath -> PN
mkPackageName
[ FilePath
"base"
, FilePath
"ghc-bignum"
, FilePath
"ghc-prim"
, FilePath
"ghc-boot"
, FilePath
"ghc"
, FilePath
"ghci"
, FilePath
"integer-gmp"
, FilePath
"integer-simple"
, FilePath
"template-haskell"
]
goalChoiceHeuristics :: EndoTreeTrav d c
goalChoiceHeuristics
| forall a. BooleanFlag a => a -> Bool
asBool (SolverConfig -> ReorderGoals
reorderGoals SolverConfig
sc) = forall {d} {c}. TreeF d c (Tree d c) -> TreeF d c (Tree d c)
P.preferReallyEasyGoalChoices
| Bool
otherwise = forall a. a -> a
id
traceTree ::
#ifdef DEBUG_TRACETREE
GSimpleTree a =>
#endif
FilePath
-> (a -> a)
-> a -> a
#ifdef DEBUG_TRACETREE
traceTree = gtraceJson
#else
traceTree :: forall a. FilePath -> (a -> a) -> a -> a
traceTree FilePath
_ a -> a
_ = forall a. a -> a
id
#endif
#ifdef DEBUG_TRACETREE
instance GSimpleTree (Tree d c) where
fromGeneric = go
where
go :: Tree d c -> SimpleTree
go (PChoice qpn _ _ psq) = Node "P" $ Assoc $ L.map (uncurry (goP qpn)) $ psqToList psq
go (FChoice _ _ _ _ _ _ psq) = Node "F" $ Assoc $ L.map (uncurry goFS) $ psqToList psq
go (SChoice _ _ _ _ psq) = Node "S" $ Assoc $ L.map (uncurry goFS) $ psqToList psq
go (GoalChoice _ psq) = Node "G" $ Assoc $ L.map (uncurry goG) $ PSQ.toList psq
go (Done _rdm _s) = Node "D" $ Assoc []
go (Fail cs _reason) = Node "X" $ Assoc [("CS", Leaf $ goCS cs)]
psqToList :: W.WeightedPSQ w k v -> [(k, v)]
psqToList = L.map (\(_, k, v) -> (k, v)) . W.toList
goP :: QPN -> POption -> Tree d c -> (String, SimpleTree)
goP _ (POption (I ver _loc) Nothing) subtree = (T.display ver, go subtree)
goP (Q _ pn) (POption _ (Just pp)) subtree = (showQPN (Q pp pn), go subtree)
goFS :: Bool -> Tree d c -> (String, SimpleTree)
goFS val subtree = (show val, go subtree)
goG :: Goal QPN -> Tree d c -> (String, SimpleTree)
goG (Goal var gr) subtree = (showVar var ++ " (" ++ shortGR gr ++ ")", go subtree)
shortGR :: QGoalReason -> String
shortGR UserGoal = "user"
shortGR (DependencyGoal dr) = showDependencyReason dr
goCS :: ConflictSet -> String
goCS cs = "{" ++ (intercalate "," . L.map showVar . CS.toList $ cs) ++ "}"
#endif
_removeGR :: Tree d c -> Tree d QGoalReason
_removeGR :: forall d c. Tree d c -> Tree d QGoalReason
_removeGR = forall d c a. TreeTrav d c a -> Tree d c -> Tree d a
trav forall d c.
TreeF d c (Tree d QGoalReason)
-> TreeF d QGoalReason (Tree d QGoalReason)
go
where
go :: TreeF d c (Tree d QGoalReason) -> TreeF d QGoalReason (Tree d QGoalReason)
go :: forall d c.
TreeF d c (Tree d QGoalReason)
-> TreeF d QGoalReason (Tree d QGoalReason)
go (PChoiceF QPN
qpn RevDepMap
rdm c
_ WeightedPSQ [Weight] POption (Tree d QGoalReason)
psq) = forall d c a.
QPN
-> RevDepMap -> c -> WeightedPSQ [Weight] POption a -> TreeF d c a
PChoiceF QPN
qpn RevDepMap
rdm QGoalReason
dummy WeightedPSQ [Weight] POption (Tree d QGoalReason)
psq
go (FChoiceF QFN
qfn RevDepMap
rdm c
_ WeakOrTrivial
a FlagType
b Bool
d WeightedPSQ [Weight] Bool (Tree d QGoalReason)
psq) = forall d c a.
QFN
-> RevDepMap
-> c
-> WeakOrTrivial
-> FlagType
-> Bool
-> WeightedPSQ [Weight] Bool a
-> TreeF d c a
FChoiceF QFN
qfn RevDepMap
rdm QGoalReason
dummy WeakOrTrivial
a FlagType
b Bool
d WeightedPSQ [Weight] Bool (Tree d QGoalReason)
psq
go (SChoiceF QSN
qsn RevDepMap
rdm c
_ WeakOrTrivial
a WeightedPSQ [Weight] Bool (Tree d QGoalReason)
psq) = forall d c a.
QSN
-> RevDepMap
-> c
-> WeakOrTrivial
-> WeightedPSQ [Weight] Bool a
-> TreeF d c a
SChoiceF QSN
qsn RevDepMap
rdm QGoalReason
dummy WeakOrTrivial
a WeightedPSQ [Weight] Bool (Tree d QGoalReason)
psq
go (GoalChoiceF RevDepMap
rdm PSQ (Goal QPN) (Tree d QGoalReason)
psq) = forall d c a. RevDepMap -> PSQ (Goal QPN) a -> TreeF d c a
GoalChoiceF RevDepMap
rdm (forall d.
PSQ (Goal QPN) (Tree d QGoalReason)
-> PSQ (Goal QPN) (Tree d QGoalReason)
goG PSQ (Goal QPN) (Tree d QGoalReason)
psq)
go (DoneF RevDepMap
rdm d
s) = forall d c a. RevDepMap -> d -> TreeF d c a
DoneF RevDepMap
rdm d
s
go (FailF ConflictSet
cs FailReason
reason) = forall d c a. ConflictSet -> FailReason -> TreeF d c a
FailF ConflictSet
cs FailReason
reason
goG :: PSQ (Goal QPN) (Tree d QGoalReason) -> PSQ (Goal QPN) (Tree d QGoalReason)
goG :: forall d.
PSQ (Goal QPN) (Tree d QGoalReason)
-> PSQ (Goal QPN) (Tree d QGoalReason)
goG = forall k a. [(k, a)] -> PSQ k a
PSQ.fromList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
L.map (\(Goal Var QPN
var QGoalReason
_, Tree d QGoalReason
subtree) -> (forall qpn. Var qpn -> GoalReason qpn -> Goal qpn
Goal Var QPN
var QGoalReason
dummy, Tree d QGoalReason
subtree))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. PSQ k a -> [(k, a)]
PSQ.toList
dummy :: QGoalReason
dummy :: QGoalReason
dummy =
forall qpn. DependencyReason qpn -> GoalReason qpn
DependencyGoal forall a b. (a -> b) -> a -> b
$
forall qpn.
qpn -> Map Flag FlagValue -> Set Stanza -> DependencyReason qpn
DependencyReason
(forall a. PackagePath -> a -> Qualified a
Q (Namespace -> Qualifier -> PackagePath
PackagePath Namespace
DefaultNamespace Qualifier
QualToplevel) (FilePath -> PN
mkPackageName FilePath
"$"))
forall k a. Map k a
M.empty forall a. Set a
S.empty