Add 'WeightedPSQ' and use it to sort package, flag, and stanza choices.

cabal-install/Distribution/Solver/Modular/Builder.hs

@@ -27,6 +27,7 @@ import Distribution.Solver.Modular.Package
 import Distribution.Solver.Modular.PSQ (PSQ)
 import qualified Distribution.Solver.Modular.PSQ as P
 import Distribution.Solver.Modular.Tree
+import qualified Distribution.Solver.Modular.WeightedPSQ as W
 
 import Distribution.Solver.Types.ComponentDeps (Component)
 import Distribution.Solver.Types.PackagePath
@@ -134,9 +135,9 @@ build = ana go
       -- We will probably want to give this case special treatment when generating error
       -- messages though.
       case M.lookup pn idx of
-        Nothing  -> PChoiceF qpn gr (P.fromList [])
-        Just pis -> PChoiceF qpn gr (P.fromList (L.map (\ (i, info) ->
-                                                           (POption i Nothing, bs { next = Instance qpn i info gr }))
+        Nothing  -> PChoiceF qpn gr (W.fromList [])
+        Just pis -> PChoiceF qpn gr (W.fromList (L.map (\ (i, info) ->
+                                                           ([], POption i Nothing, bs { next = Instance qpn i info gr }))
                                                          (M.toList pis)))
           -- TODO: data structure conversion is rather ugly here
 
@@ -145,12 +146,10 @@ build = ana go
     --
     -- TODO: Should we include the flag default in the tree?
     go bs@(BS { next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) (FInfo b m w) t f) gr) }) =
-      FChoiceF qfn gr weak m (P.fromList (reorder b
-        [(True,  (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn True )) t) bs) { next = Goals }),
-         (False, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn False)) f) bs) { next = Goals })]))
+      FChoiceF qfn gr weak m (W.fromList
+        [([if b then 0 else 1], True,  (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn True )) t) bs) { next = Goals }),
+         ([if b then 1 else 0], False, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn False)) f) bs) { next = Goals })])
       where
-        reorder True  = id
-        reorder False = reverse
         trivial = L.null t && L.null f
         weak = WeakOrTrivial $ unWeakOrTrivial w || trivial
 
@@ -160,9 +159,9 @@ build = ana go
     -- (try enabling the stanza if possible by moving the True branch first).
 
     go bs@(BS { next = OneGoal (OpenGoal (Stanza qsn@(SN (PI qpn _) _) t) gr) }) =
-      SChoiceF qsn gr trivial (P.fromList
-        [(False,                                                             bs  { next = Goals }),
-         (True,  (extendOpen qpn (L.map (flip OpenGoal (SDependency qsn)) t) bs) { next = Goals })])
+      SChoiceF qsn gr trivial (W.fromList
+        [([0], False,                                                             bs  { next = Goals }),
+         ([1], True,  (extendOpen qpn (L.map (flip OpenGoal (SDependency qsn)) t) bs) { next = Goals })])
       where
         trivial = WeakOrTrivial (L.null t)
 

cabal-install/Distribution/Solver/Modular/Degree.hs

@@ -0,0 +1,21 @@
+module Distribution.Solver.Modular.Degree where
+
+-- | Approximation of the branching degree.
+--
+-- This is designed for computing the branching degree of a goal choice
+-- node. If the degree is 0 or 1, it is always good to take that goal,
+-- because we can either abort immediately, or have no other choice anyway.
+--
+-- So we do not actually want to compute the full degree (which is
+-- somewhat costly) in cases where we have such an easy choice.
+--
+data Degree = ZeroOrOne | Two | Other
+  deriving (Show, Eq)
+
+instance Ord Degree where
+  compare ZeroOrOne _         = LT -- lazy approximation
+  compare _         ZeroOrOne = GT -- approximation
+  compare Two       Two       = EQ
+  compare Two       Other     = LT
+  compare Other     Two       = GT
+  compare Other     Other     = EQ

cabal-install/Distribution/Solver/Modular/Explore.hs

@@ -16,6 +16,7 @@ import qualified Distribution.Solver.Modular.PSQ as P
 import qualified Distribution.Solver.Modular.ConflictSet as CS
 import Distribution.Solver.Modular.RetryLog
 import Distribution.Solver.Modular.Tree
+import qualified Distribution.Solver.Modular.WeightedPSQ as W
 import Distribution.Solver.Types.PackagePath
 import Distribution.Solver.Types.Settings (EnableBackjumping(..), CountConflicts(..))
 
@@ -43,7 +44,7 @@ import Distribution.Solver.Types.Settings (EnableBackjumping(..), CountConflicts
 -- variable. See also the comments for 'avoidSet'.
 --
 backjump :: EnableBackjumping -> Var QPN
-         -> ConflictSet QPN -> P.PSQ k (ConflictMap -> ConflictSetLog a)
+         -> ConflictSet QPN -> W.WeightedPSQ w k (ConflictMap -> ConflictSetLog a)
          -> ConflictMap -> ConflictSetLog a
 backjump (EnableBackjumping enableBj) var initial xs =
     F.foldr combine logBackjump xs initial
@@ -105,23 +106,23 @@ exploreLog enableBj (CountConflicts countConflicts) = cata go
     go (DoneF rdm)              a            = \ _  -> succeedWith Success (a, rdm)
     go (PChoiceF qpn gr     ts) (A pa fa sa) =
       backjump enableBj (P qpn) (avoidSet (P qpn) gr) $ -- try children in order,
-        P.mapWithKey                                -- when descending ...
+        W.mapWithKey                                -- when descending ...
           (\ i@(POption k _) r cm ->
             let l = r (A (M.insert qpn k pa) fa sa) cm
             in tryWith (TryP qpn i) l
           )
         ts
     go (FChoiceF qfn gr _ _ ts) (A pa fa sa) =
       backjump enableBj (F qfn) (avoidSet (F qfn) gr) $ -- try children in order,
-        P.mapWithKey                                -- when descending ...
+        W.mapWithKey                                -- when descending ...
           (\ k r cm ->
             let l = r (A pa (M.insert qfn k fa) sa) cm
             in  tryWith (TryF qfn k) l
           )
         ts
     go (SChoiceF qsn gr _   ts) (A pa fa sa) =
       backjump enableBj (S qsn) (avoidSet (S qsn) gr) $ -- try children in order,
-        P.mapWithKey                                -- when descending ...
+        W.mapWithKey                                -- when descending ...
           (\ k r cm ->
             let l = r (A pa fa (M.insert qsn k sa)) cm
             in  tryWith (TryS qsn k) l

cabal-install/Distribution/Solver/Modular/Linking.hs

@@ -29,8 +29,8 @@ import Distribution.Solver.Modular.Flag
 import Distribution.Solver.Modular.Index
 import Distribution.Solver.Modular.Package
 import Distribution.Solver.Modular.Tree
-import qualified Distribution.Solver.Modular.PSQ as P
 import qualified Distribution.Solver.Modular.ConflictSet as CS
+import qualified Distribution.Solver.Modular.WeightedPSQ as W
 
 import Distribution.Solver.Types.OptionalStanza
 import Distribution.Solver.Types.PackagePath
@@ -69,9 +69,9 @@ addLinking = (`runReader` M.empty) .  cata go
     -- The only nodes of interest are package nodes
     go (PChoiceF qpn gr cs) = do
       env <- ask
-      let linkedCs = P.fromList $ concatMap (linkChoices env qpn) (P.toList cs)
-          unlinkedCs = P.mapWithKey (goP qpn) cs
-      allCs <- T.sequence $ unlinkedCs `P.union` linkedCs
+      let linkedCs = W.fromList $ concatMap (linkChoices env qpn) (W.toList cs)
+          unlinkedCs = W.mapWithKey (goP qpn) cs
+      allCs <- T.sequence $ unlinkedCs `W.union` linkedCs
       return $ PChoice qpn gr allCs
     go _otherwise =
       innM _otherwise
@@ -82,13 +82,16 @@ addLinking = (`runReader` M.empty) .  cata go
     goP (Q pp pn) (POption i Nothing) = local (M.insertWith (++) (pn, i) [pp])
     goP _ _ = alreadyLinked
 
-linkChoices :: forall a . RelatedGoals -> QPN -> (POption, a) -> [(POption, a)]
-linkChoices related (Q _pp pn) (POption i Nothing, subtree) =
+linkChoices :: forall a w . RelatedGoals
+            -> QPN
+            -> (w, POption, a)
+            -> [(w, POption, a)]
+linkChoices related (Q _pp pn) (weight, POption i Nothing, subtree) =
     map aux (M.findWithDefault [] (pn, i) related)
   where
-    aux :: PackagePath -> (POption, a)
-    aux pp = (POption i (Just pp), subtree)
-linkChoices _ _ (POption _ (Just _), _) =
+    aux :: PackagePath -> (w, POption, a)
+    aux pp = (weight, POption i (Just pp), subtree)
+linkChoices _ _ (_, POption _ (Just _), _) =
     alreadyLinked
 
 alreadyLinked :: a
@@ -140,11 +143,11 @@ validateLinking index = (`runReader` initVS) . cata go
     go :: TreeF a (Validate (Tree a)) -> Validate (Tree a)
 
     go (PChoiceF qpn gr cs) =
-      PChoice qpn gr     <$> T.sequence (P.mapWithKey (goP qpn) cs)
+      PChoice qpn gr     <$> T.sequence (W.mapWithKey (goP qpn) cs)
     go (FChoiceF qfn gr t m cs) =
-      FChoice qfn gr t m <$> T.sequence (P.mapWithKey (goF qfn) cs)
+      FChoice qfn gr t m <$> T.sequence (W.mapWithKey (goF qfn) cs)
     go (SChoiceF qsn gr t cs) =
-      SChoice qsn gr t   <$> T.sequence (P.mapWithKey (goS qsn) cs)
+      SChoice qsn gr t   <$> T.sequence (W.mapWithKey (goS qsn) cs)
 
     -- For the other nodes we just recurse
     go (GoalChoiceF         cs)       = GoalChoice          <$> T.sequence cs

cabal-install/Distribution/Solver/Modular/PSQ.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
 module Distribution.Solver.Modular.PSQ
     ( PSQ(..)  -- Unit test needs constructor access
-    , Degree(..)
     , casePSQ
     , cons
     , degree
@@ -40,6 +39,8 @@ module Distribution.Solver.Modular.PSQ
 -- (inefficiently implemented) lookup, because I think that queue-based
 -- operations and sorting turn out to be more efficiency-critical in practice.
 
+import Distribution.Solver.Modular.Degree
+
 import Control.Arrow (first, second)
 
 import qualified Data.Foldable as F
@@ -173,26 +174,6 @@ filter p (PSQ xs) = PSQ (S.filter (p . snd) xs)
 length :: PSQ k a -> Int
 length (PSQ xs) = S.length xs
 
--- | Approximation of the branching degree.
---
--- This is designed for computing the branching degree of a goal choice
--- node. If the degree is 0 or 1, it is always good to take that goal,
--- because we can either abort immediately, or have no other choice anyway.
---
--- So we do not actually want to compute the full degree (which is
--- somewhat costly) in cases where we have such an easy choice.
---
-data Degree = ZeroOrOne | Two | Other
-  deriving (Show, Eq)
-
-instance Ord Degree where
-  compare ZeroOrOne _         = LT -- lazy approximation
-  compare _         ZeroOrOne = GT -- approximation
-  compare Two       Two       = EQ
-  compare Two       Other     = LT
-  compare Other     Two       = GT
-  compare Other     Other     = EQ
-
 degree :: PSQ k a -> Degree
 degree (PSQ [])     = ZeroOrOne
 degree (PSQ [_])    = ZeroOrOne