Merge pull request #3480 from grayjay/stanza-preferences

Fix bug in dependency solver stanza preferences

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

@@ -145,13 +145,14 @@ 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 (w || trivial) m (P.fromList (reorder b
+      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 })]))
       where
         reorder True  = id
         reorder False = reverse
         trivial = L.null t && L.null f
+        weak = WeakOrTrivial $ unWeakOrTrivial w || trivial
 
     -- For a stanza, we also create only two subtrees. The order is initially
     -- False, True. This can be changed later by constraints (force enabling
@@ -163,7 +164,7 @@ build = ana go
         [(False,                                                             bs  { next = Goals }),
          (True,  (extendOpen qpn (L.map (flip OpenGoal (SDependency qsn)) t) bs) { next = Goals })])
       where
-        trivial = L.null t
+        trivial = WeakOrTrivial (L.null t)
 
     -- For a particular instance, we change the state: we update the scope,
     -- and furthermore we update the set of goals.

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

@@ -7,6 +7,7 @@ module Distribution.Solver.Modular.Flag
     , QFN
     , QSN
     , SN(..)
+    , WeakOrTrivial(..)
     , mkFlag
     , showFBool
     , showQFN
@@ -40,7 +41,7 @@ mkFlag fn = FlagName fn
 -- | Flag info. Default value, whether the flag is manual, and
 -- whether the flag is weak. Manual flags can only be set explicitly.
 -- Weak flags are typically deferred by the solver.
-data FInfo = FInfo { fdefault :: Bool, fmanual :: Bool, fweak :: Bool }
+data FInfo = FInfo { fdefault :: Bool, fmanual :: Bool, fweak :: WeakOrTrivial }
   deriving (Eq, Ord, Show)
 
 -- | Flag defaults.
@@ -56,6 +57,20 @@ data SN qpn = SN (PI qpn) OptionalStanza
 -- | Qualified stanza name.
 type QSN = SN QPN
 
+-- | A property of flag and stanza choices that determines whether the
+-- choice should be deferred in the solving process.
+--
+-- A choice is called weak if we do want to defer it. This is the
+-- case for flags that should be implied by what's currently installed on
+-- the system, as opposed to flags that are used to explicitly enable or
+-- disable some functionality.
+--
+-- A choice is called trivial if it clearly does not matter. The
+-- special case of triviality we actually consider is if there are no new
+-- dependencies introduced by the choice.
+newtype WeakOrTrivial = WeakOrTrivial { unWeakOrTrivial :: Bool }
+  deriving (Eq, Ord, Show)
+
 unStanza :: OptionalStanza -> String
 unStanza TestStanzas  = "test"
 unStanza BenchStanzas = "bench"

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

@@ -193,7 +193,9 @@ prefix f fds = [f (concat fds)]
 -- unless strong flags have been selected explicitly.
 flagInfo :: StrongFlags -> [PD.Flag] -> FlagInfo
 flagInfo (StrongFlags strfl) =
-    M.fromList . L.map (\ (MkFlag fn _ b m) -> (fn, FInfo b m (not (strfl || m))))
+    M.fromList . L.map (\ (MkFlag fn _ b m) -> (fn, FInfo b m (weak m)))
+  where
+    weak m = WeakOrTrivial $ not (strfl || m)
 
 -- | Internal package names, which should not be interpreted as true
 -- dependencies.

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

@@ -117,15 +117,19 @@ preferLatestOrdering (I v1 _) (I v2 _) = compare v1 v2
 preferPackageStanzaPreferences :: (PN -> PackagePreferences) -> Tree a -> Tree a
 preferPackageStanzaPreferences pcs = trav go
   where
-    go (SChoiceF qsn@(SN (PI (Q pp pn) _) s) gr _tr ts) | primaryPP pp =
-        let PackagePreferences _ _ spref = pcs pn
-            enableStanzaPref = s `elem` spref
-                  -- move True case first to try enabling the stanza
-            ts' | enableStanzaPref = P.sortByKeys (flip compare) ts
-                | otherwise        = ts
-         in SChoiceF qsn gr True ts'   -- True: now weak choice
+    go (SChoiceF qsn@(SN (PI (Q pp pn) _) s) gr _tr ts)
+      | primaryPP pp && enableStanzaPref pn s =
+          -- move True case first to try enabling the stanza
+          let ts' = P.sortByKeys (flip compare) ts
+          -- defer the choice by setting it to weak
+          in  SChoiceF qsn gr (WeakOrTrivial True) ts'
     go x = x
 
+    enableStanzaPref :: PN -> OptionalStanza -> Bool
+    enableStanzaPref pn s =
+      let PackagePreferences _ _ spref = pcs pn
+      in  s `elem` 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
@@ -341,12 +345,12 @@ deferWeakFlagChoices = trav go
     go x                = x
 
     noWeakStanza :: Tree a -> Bool
-    noWeakStanza (SChoice _ _ True _) = False
-    noWeakStanza _                    = True
+    noWeakStanza (SChoice _ _ (WeakOrTrivial True) _) = False
+    noWeakStanza _                                    = True
 
     noWeakFlag :: Tree a -> Bool
-    noWeakFlag (FChoice _ _ True _ _) = False
-    noWeakFlag _                      = True
+    noWeakFlag (FChoice _ _ (WeakOrTrivial True) _ _) = False
+    noWeakFlag _                                      = True
 
 -- | Transformation that sorts choice nodes so that
 -- child nodes with a small branching degree are preferred.

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

@@ -36,24 +36,11 @@ data Tree a =
 
     -- | Choose a value for a flag
     --
-    -- The first Bool indicates whether it's weak/trivial,
-    -- the second Bool whether it's manual.
-    --
-    -- A choice is called trivial if it clearly does not matter. The
-    -- special case of triviality we actually consider is if there are no new
-    -- dependencies introduced by this node.
-    --
-    -- A (flag) choice is called weak if we do want to defer it. This is the
-    -- case for flags that should be implied by what's currently installed on
-    -- the system, as opposed to flags that are used to explicitly enable or
-    -- disable some functionality.
-  | FChoice QFN a Bool Bool (PSQ Bool (Tree a))
+    -- The Bool indicates whether it's manual.
+  | FChoice QFN a WeakOrTrivial Bool (PSQ Bool (Tree a))
 
     -- | Choose whether or not to enable a stanza
-    --
-    -- The Bool indicates whether it's trivial (see 'FChoice' for a discussion
-    -- of triviality).
-  | SChoice QSN a Bool (PSQ Bool (Tree a))
+  | SChoice QSN a WeakOrTrivial (PSQ Bool (Tree a))
 
     -- | Choose which choice to make next
     --
@@ -116,10 +103,10 @@ data FailReason = InconsistentInitialConstraints
 
 -- | Functor for the tree type.
 data TreeF a b =
-    PChoiceF    QPN a           (PSQ POption    b)
-  | FChoiceF    QFN a Bool Bool (PSQ Bool       b)
-  | SChoiceF    QSN a Bool      (PSQ Bool       b)
-  | GoalChoiceF                 (PSQ (Goal QPN) b)
+    PChoiceF    QPN a                    (PSQ POption    b)
+  | FChoiceF    QFN a WeakOrTrivial Bool (PSQ Bool       b)
+  | SChoiceF    QSN a WeakOrTrivial      (PSQ Bool       b)
+  | GoalChoiceF                          (PSQ (Goal QPN) b)
   | DoneF       RevDepMap
   | FailF       (ConflictSet QPN) FailReason
   deriving (Functor, Foldable, Traversable)