cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs

   1 {-# LANGUAGE CPP #-}
   2 #ifdef DEBUG_TRACETREE
   3 {-# LANGUAGE FlexibleInstances #-}
   4 {-# OPTIONS_GHC -fno-warn-orphans #-}
   5 #endif
   6 module Distribution.Solver.Modular.Solver
   7     ( SolverConfig(..)
   8     , solve
   9     , PruneAfterFirstSuccess(..)
  10     ) where
  11
  12 import Distribution.Solver.Compat.Prelude
  13 import Prelude ()
  14
  15 import qualified Data.Map as M
  16 import qualified Data.List as L
  17 import qualified Data.Set as S
  18 import Distribution.Verbosity
  19
  20 import Distribution.Compiler (CompilerInfo)
  21
  22 import Distribution.Solver.Types.PackagePath
  23 import Distribution.Solver.Types.PackagePreferences
  24 import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb)
  25 import Distribution.Solver.Types.LabeledPackageConstraint
  26 import Distribution.Solver.Types.Settings
  27 import Distribution.Solver.Types.Variable
  28
  29 import Distribution.Solver.Modular.Assignment
  30 import Distribution.Solver.Modular.Builder
  31 import Distribution.Solver.Modular.Cycles
  32 import Distribution.Solver.Modular.Dependency
  33 import Distribution.Solver.Modular.Explore
  34 import Distribution.Solver.Modular.Index
  35 import Distribution.Solver.Modular.Log
  36 import Distribution.Solver.Modular.Message
  37 import Distribution.Solver.Modular.Package
  38 import qualified Distribution.Solver.Modular.Preference as P
  39 import Distribution.Solver.Modular.Validate
  40 import Distribution.Solver.Modular.Linking
  41 import Distribution.Solver.Modular.PSQ (PSQ)
  42 import Distribution.Solver.Modular.RetryLog
  43 import Distribution.Solver.Modular.Tree
  44 import qualified Distribution.Solver.Modular.PSQ as PSQ
  45
  46 import Distribution.Simple.Setup (BooleanFlag(..))
  47
  48 #ifdef DEBUG_TRACETREE
  49 import qualified Distribution.Solver.Modular.ConflictSet as CS
  50 import qualified Distribution.Solver.Modular.WeightedPSQ as W
  51 import qualified Distribution.Deprecated.Text as T
  52
  53 import Debug.Trace.Tree (gtraceJson)
  54 import Debug.Trace.Tree.Simple
  55 import Debug.Trace.Tree.Generic
  56 import Debug.Trace.Tree.Assoc (Assoc(..))
  57 #endif
  58
  59 -- | Various options for the modular solver.
  60 data SolverConfig = SolverConfig {
  61   reorderGoals           :: ReorderGoals,
  62   countConflicts         :: CountConflicts,
  63   fineGrainedConflicts   :: FineGrainedConflicts,
  64   minimizeConflictSet    :: MinimizeConflictSet,
  65   independentGoals       :: IndependentGoals,
  66   avoidReinstalls        :: AvoidReinstalls,
  67   shadowPkgs             :: ShadowPkgs,
  68   strongFlags            :: StrongFlags,
  69   onlyConstrained        :: OnlyConstrained,
  70   maxBackjumps           :: Maybe Int,
  71   enableBackjumping      :: EnableBackjumping,
  72   solveExecutables       :: SolveExecutables,
  73   goalOrder              :: Maybe (Variable QPN -> Variable QPN -> Ordering),
  74   solverVerbosity        :: Verbosity,
  75   pruneAfterFirstSuccess :: PruneAfterFirstSuccess
  76 }
  77
  78 -- | Whether to remove all choices after the first successful choice at each
  79 -- level in the search tree.
  80 newtype PruneAfterFirstSuccess = PruneAfterFirstSuccess Bool
  81
  82 -- | Run all solver phases.
  83 --
  84 -- In principle, we have a valid tree after 'validationPhase', which
  85 -- means that every 'Done' node should correspond to valid solution.
  86 --
  87 -- There is one exception, though, and that is cycle detection, which
  88 -- has been added relatively recently. Cycles are only removed directly
  89 -- before exploration.
  90 --
  91 solve :: SolverConfig                         -- ^ solver parameters
  92       -> CompilerInfo
  93       -> Index                                -- ^ all available packages as an index
  94       -> Maybe PkgConfigDb                    -- ^ available pkg-config pkgs
  95       -> (PN -> PackagePreferences)           -- ^ preferences
  96       -> M.Map PN [LabeledPackageConstraint]  -- ^ global constraints
  97       -> S.Set PN                             -- ^ global goals
  98       -> RetryLog Message SolverFailure (Assignment, RevDepMap)
  99 solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =
 100   explorePhase      .
 101   traceTree "cycles.json" id .
 102   detectCycles      .
 103   traceTree "heuristics.json" id .
 104   trav (
 105    heuristicsPhase  .
 106    preferencesPhase .
 107    validationPhase
 108   ) .
 109   traceTree "semivalidated.json" id .
 110   validationCata    .
 111   traceTree "pruned.json" id .
 112   trav prunePhase   .
 113   traceTree "build.json" id $
 114   buildPhase
 115   where
 116     explorePhase     = backjumpAndExplore (maxBackjumps sc)
 117                                           (enableBackjumping sc)
 118                                           (fineGrainedConflicts sc)
 119                                           (countConflicts sc)
 120                                           idx
 121     detectCycles     = detectCyclesPhase
 122     heuristicsPhase  =
 123       let
 124           sortGoals = case goalOrder sc of
 125                         Nothing -> goalChoiceHeuristics .
 126                                    P.deferSetupExeChoices .
 127                                    P.deferWeakFlagChoices .
 128                                    P.preferBaseGoalChoice
 129                         Just order -> P.firstGoal .
 130                                       P.sortGoals order
 131           PruneAfterFirstSuccess prune = pruneAfterFirstSuccess sc
 132       in sortGoals .
 133          (if prune then P.pruneAfterFirstSuccess else id)
 134     preferencesPhase = P.preferLinked .
 135                        P.preferPackagePreferences userPrefs
 136     validationPhase  = P.enforcePackageConstraints userConstraints .
 137                        P.enforceManualFlags userConstraints
 138     validationCata   = P.enforceSingleInstanceRestriction .
 139                        validateLinking idx .
 140                        validateTree cinfo idx pkgConfigDB
 141     prunePhase       = (if asBool (avoidReinstalls sc) then P.avoidReinstalls (const True) else id) .
 142                        (case onlyConstrained sc of
 143                           OnlyConstrainedAll ->
 144                             P.onlyConstrained pkgIsExplicit
 145                           OnlyConstrainedNone ->
 146                             id)
 147     buildPhase       = buildTree idx (independentGoals sc) (S.toList userGoals)
 148
 149     allExplicit = M.keysSet userConstraints `S.union` userGoals
 150
 151     pkgIsExplicit :: PN -> Bool
 152     pkgIsExplicit pn = S.member pn allExplicit
 153
 154     -- When --reorder-goals is set, we use preferReallyEasyGoalChoices, which
 155     -- prefers (keeps) goals only if the have 0 or 1 enabled choice.
 156     --
 157     -- In the past, we furthermore used P.firstGoal to trim down the goal choice nodes
 158     -- to just a single option. This was a way to work around a space leak that was
 159     -- unnecessary and is now fixed, so we no longer do it.
 160     --
 161     -- If --count-conflicts is active, it will then choose among the remaining goals
 162     -- the one that has been responsible for the most conflicts so far.
 163     --
 164     -- Otherwise, we simply choose the first remaining goal.
 165     --
 166     goalChoiceHeuristics
 167       | asBool (reorderGoals sc) = P.preferReallyEasyGoalChoices
 168       | otherwise                = id {- P.firstGoal -}
 169
 170 -- | Dump solver tree to a file (in debugging mode)
 171 --
 172 -- This only does something if the @debug-tracetree@ configure argument was
 173 -- given; otherwise this is just the identity function.
 174 traceTree ::
 175 #ifdef DEBUG_TRACETREE
 176   GSimpleTree a =>
 177 #endif
 178      FilePath  -- ^ Output file
 179   -> (a -> a)  -- ^ Function to summarize the tree before dumping
 180   -> a -> a
 181 #ifdef DEBUG_TRACETREE
 182 traceTree = gtraceJson
 183 #else
 184 traceTree _ _ = id
 185 #endif
 186
 187 #ifdef DEBUG_TRACETREE
 188 instance GSimpleTree (Tree d c) where
 189   fromGeneric = go
 190     where
 191       go :: Tree d c -> SimpleTree
 192       go (PChoice qpn _ _       psq) = Node "P" $ Assoc $ L.map (uncurry (goP qpn)) $ psqToList  psq
 193       go (FChoice _   _ _ _ _ _ psq) = Node "F" $ Assoc $ L.map (uncurry goFS)      $ psqToList  psq
 194       go (SChoice _   _ _ _     psq) = Node "S" $ Assoc $ L.map (uncurry goFS)      $ psqToList  psq
 195       go (GoalChoice  _         psq) = Node "G" $ Assoc $ L.map (uncurry goG)       $ PSQ.toList psq
 196       go (Done _rdm _s)              = Node "D" $ Assoc []
 197       go (Fail cs _reason)           = Node "X" $ Assoc [("CS", Leaf $ goCS cs)]
 198
 199       psqToList :: W.WeightedPSQ w k v -> [(k, v)]
 200       psqToList = L.map (\(_, k, v) -> (k, v)) . W.toList
 201
 202       -- Show package choice
 203       goP :: QPN -> POption -> Tree d c -> (String, SimpleTree)
 204       goP _        (POption (I ver _loc) Nothing)  subtree = (T.display ver, go subtree)
 205       goP (Q _ pn) (POption _           (Just pp)) subtree = (showQPN (Q pp pn), go subtree)
 206
 207       -- Show flag or stanza choice
 208       goFS :: Bool -> Tree d c -> (String, SimpleTree)
 209       goFS val subtree = (show val, go subtree)
 210
 211       -- Show goal choice
 212       goG :: Goal QPN -> Tree d c -> (String, SimpleTree)
 213       goG (Goal var gr) subtree = (showVar var ++ " (" ++ shortGR gr ++ ")", go subtree)
 214
 215       -- Variation on 'showGR' that produces shorter strings
 216       -- (Actually, QGoalReason records more info than necessary: we only need
 217       -- to know the variable that introduced the goal, not the value assigned
 218       -- to that variable)
 219       shortGR :: QGoalReason -> String
 220       shortGR UserGoal            = "user"
 221       shortGR (DependencyGoal dr) = showDependencyReason dr
 222
 223       -- Show conflict set
 224       goCS :: ConflictSet -> String
 225       goCS cs = "{" ++ (intercalate "," . L.map showVar . CS.toList $ cs) ++ "}"
 226 #endif
 227
 228 -- | Replace all goal reasons with a dummy goal reason in the tree
 229 --
 230 -- This is useful for debugging (when experimenting with the impact of GRs)
 231 _removeGR :: Tree d c -> Tree d QGoalReason
 232 _removeGR = trav go
 233   where
 234    go :: TreeF d c (Tree d QGoalReason) -> TreeF d QGoalReason (Tree d QGoalReason)
 235    go (PChoiceF qpn rdm _       psq) = PChoiceF qpn rdm dummy       psq
 236    go (FChoiceF qfn rdm _ a b d psq) = FChoiceF qfn rdm dummy a b d psq
 237    go (SChoiceF qsn rdm _ a     psq) = SChoiceF qsn rdm dummy a     psq
 238    go (GoalChoiceF  rdm         psq) = GoalChoiceF  rdm             (goG psq)
 239    go (DoneF rdm s)                  = DoneF rdm s
 240    go (FailF cs reason)              = FailF cs reason
 241
 242    goG :: PSQ (Goal QPN) (Tree d QGoalReason) -> PSQ (Goal QPN) (Tree d QGoalReason)
 243    goG = PSQ.fromList
 244        . L.map (\(Goal var _, subtree) -> (Goal var dummy, subtree))
 245        . PSQ.toList
 246
 247    dummy :: QGoalReason
 248    dummy =
 249        DependencyGoal $
 250        DependencyReason
 251            (Q (PackagePath DefaultNamespace QualToplevel) (mkPackageName "$"))
 252            M.empty S.empty