diff --git a/cabal-install/Distribution/Solver/Modular/Builder.hs b/cabal-install/Distribution/Solver/Modular/Builder.hs index 1e94260ac9a..9a564fe5c5d 100644 --- a/cabal-install/Distribution/Solver/Modular/Builder.hs +++ b/cabal-install/Distribution/Solver/Modular/Builder.hs @@ -144,13 +144,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 @@ -162,7 +163,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. diff --git a/cabal-install/Distribution/Solver/Modular/Flag.hs b/cabal-install/Distribution/Solver/Modular/Flag.hs index afd283cbf65..f5e451c2be7 100644 --- a/cabal-install/Distribution/Solver/Modular/Flag.hs +++ b/cabal-install/Distribution/Solver/Modular/Flag.hs @@ -7,6 +7,7 @@ module Distribution.Solver.Modular.Flag , QFN , QSN , SN(..) + , WeakOrTrivial(..) , mkFlag , showFBool , showQFN @@ -39,7 +40,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. @@ -55,6 +56,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" diff --git a/cabal-install/Distribution/Solver/Modular/IndexConversion.hs b/cabal-install/Distribution/Solver/Modular/IndexConversion.hs index 3edfa17dec8..69aeb75fa5b 100644 --- a/cabal-install/Distribution/Solver/Modular/IndexConversion.hs +++ b/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. diff --git a/cabal-install/Distribution/Solver/Modular/Preference.hs b/cabal-install/Distribution/Solver/Modular/Preference.hs index aa722861047..3965d9f530b 100644 --- a/cabal-install/Distribution/Solver/Modular/Preference.hs +++ b/cabal-install/Distribution/Solver/Modular/Preference.hs @@ -113,15 +113,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 @@ -322,12 +326,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. diff --git a/cabal-install/Distribution/Solver/Modular/Tree.hs b/cabal-install/Distribution/Solver/Modular/Tree.hs index d484d63dad9..c6145b26b63 100644 --- a/cabal-install/Distribution/Solver/Modular/Tree.hs +++ b/cabal-install/Distribution/Solver/Modular/Tree.hs @@ -35,24 +35,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 -- @@ -115,10 +102,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)