{-# 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

-- | Various options for the modular solver.
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
}

-- | Whether to remove all choices after the first successful choice at each
-- level in the search tree.
newtype PruneAfterFirstSuccess = PruneAfterFirstSuccess Bool

-- | Run all solver phases.
--
-- In principle, we have a valid tree after 'validationPhase', which
-- means that every 'Done' node should correspond to valid solution.
--
-- There is one exception, though, and that is cycle detection, which
-- has been added relatively recently. Cycles are only removed directly
-- before exploration.
--
solve :: SolverConfig                         -- ^ solver parameters
      -> CompilerInfo
      -> Index                                -- ^ all available packages as an index
      -> PkgConfigDb                          -- ^ available pkg-config pkgs
      -> (PN -> PackagePreferences)           -- ^ preferences
      -> M.Map PN [LabeledPackageConstraint]  -- ^ global constraints
      -> S.Set PN                             -- ^ global goals
      -> 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

    -- packages that can never be installed or upgraded
    -- If you change this enumeration, make sure to update the list in
    -- "Distribution.Client.Dependency" as well
    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"
             ]

    -- When --reorder-goals is set, we use preferReallyEasyGoalChoices, which
    -- prefers (keeps) goals only if the have 0 or 1 enabled choice.
    --
    -- In the past, we furthermore used P.firstGoal to trim down the goal choice nodes
    -- to just a single option. This was a way to work around a space leak that was
    -- unnecessary and is now fixed, so we no longer do it.
    --
    -- If --count-conflicts is active, it will then choose among the remaining goals
    -- the one that has been responsible for the most conflicts so far.
    --
    -- Otherwise, we simply choose the first remaining goal.
    --
    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 {- P.firstGoal -}

-- | Dump solver tree to a file (in debugging mode)
--
-- This only does something if the @debug-tracetree@ configure argument was
-- given; otherwise this is just the identity function.
traceTree ::
#ifdef DEBUG_TRACETREE
  GSimpleTree a =>
#endif
     FilePath  -- ^ Output file
  -> (a -> a)  -- ^ Function to summarize the tree before dumping
  -> 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

      -- Show package choice
      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)

      -- Show flag or stanza choice
      goFS :: Bool -> Tree d c -> (String, SimpleTree)
      goFS val subtree = (show val, go subtree)

      -- Show goal choice
      goG :: Goal QPN -> Tree d c -> (String, SimpleTree)
      goG (Goal var gr) subtree = (showVar var ++ " (" ++ shortGR gr ++ ")", go subtree)

      -- Variation on 'showGR' that produces shorter strings
      -- (Actually, QGoalReason records more info than necessary: we only need
      -- to know the variable that introduced the goal, not the value assigned
      -- to that variable)
      shortGR :: QGoalReason -> String
      shortGR UserGoal            = "user"
      shortGR (DependencyGoal dr) = showDependencyReason dr

      -- Show conflict set
      goCS :: ConflictSet -> String
      goCS cs = "{" ++ (intercalate "," . L.map showVar . CS.toList $ cs) ++ "}"
#endif

-- | Replace all goal reasons with a dummy goal reason in the tree
--
-- This is useful for debugging (when experimenting with the impact of GRs)
_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