Fix construction of conflict sets during link validation

cabal-install/Distribution/Client/Dependency/Modular/ConflictSet.hs

@@ -0,0 +1,74 @@
+{-# LANGUAGE CPP #-}
+-- | Conflict sets
+--
+-- Intended for double import
+--
+-- > import Distribution.Client.Dependency.Modular.ConflictSet (ConflictSet)
+-- > import qualified Distribution.Client.Dependency.Modular.ConflictSet as CS
+module Distribution.Client.Dependency.Modular.ConflictSet (
+    ConflictSet -- opaque
+  , showCS
+    -- Set-like operations
+  , toList
+  , union
+  , unions
+  , insert
+  , empty
+  , singleton
+  , member
+  , filter
+  , fromList
+  ) where
+
+import Prelude hiding (filter)
+import Data.List (intercalate)
+import Data.Set (Set)
+import qualified Data.Set as S
+
+import Distribution.Client.Dependency.Modular.Package
+import Distribution.Client.Dependency.Modular.Var
+
+-- | The set of variables involved in a solver conflict
+--
+-- Since these variables should be preprocessed in some way, this type is
+-- kept abstract.
+newtype ConflictSet qpn = CS { fromConflictSet :: Set (Var qpn) }
+  deriving (Eq, Ord, Show)
+
+showCS :: ConflictSet QPN -> String
+showCS = intercalate ", " . map showVar . toList
+
+{-------------------------------------------------------------------------------
+  Set-like operations
+-------------------------------------------------------------------------------}
+
+toList :: ConflictSet qpn -> [Var qpn]
+toList = S.toList . fromConflictSet
+
+union :: Ord qpn => ConflictSet qpn -> ConflictSet qpn -> ConflictSet qpn
+union (CS a) (CS b) = CS (a `S.union` b)
+
+unions :: Ord qpn => [ConflictSet qpn] -> ConflictSet qpn
+unions = CS . S.unions . map fromConflictSet
+
+insert :: Ord qpn => Var qpn -> ConflictSet qpn -> ConflictSet qpn
+insert var (CS set) = CS (S.insert (simplifyVar var) set)
+
+empty :: ConflictSet qpn
+empty = CS S.empty
+
+singleton :: Var qpn -> ConflictSet qpn
+singleton = CS . S.singleton . simplifyVar
+
+member :: Ord qpn => Var qpn -> ConflictSet qpn -> Bool
+member var (CS set) = S.member (simplifyVar var) set
+
+#if MIN_VERSION_containers(0,5,0)
+filter :: (Var qpn -> Bool) -> ConflictSet qpn -> ConflictSet qpn
+#else
+filter :: Ord qpn => (Var qpn -> Bool) -> ConflictSet qpn -> ConflictSet qpn
+#endif
+filter p (CS set) = CS $ S.filter p set
+
+fromList :: Ord qpn => [Var qpn] -> ConflictSet qpn
+fromList = CS . S.fromList . map simplifyVar

cabal-install/Distribution/Client/Dependency/Modular/Cycles.hs

@@ -21,19 +21,20 @@ import Distribution.Client.Dependency.Modular.Dependency
 import Distribution.Client.Dependency.Modular.Flag
 import Distribution.Client.Dependency.Modular.Package
 import Distribution.Client.Dependency.Modular.Tree
+import qualified Distribution.Client.Dependency.Modular.ConflictSet as CS
 
 type DetectCycles = Reader (ConflictSet QPN)
 
 -- | Find and reject any solutions that are cyclic
 detectCyclesPhase :: Tree QGoalReasonChain -> Tree QGoalReasonChain
-detectCyclesPhase = (`runReader` Set.empty) .  cata go
+detectCyclesPhase = (`runReader` CS.empty) .  cata go
   where
     -- Most cases are simple; we just need to remember which choices we made
     go :: TreeF QGoalReasonChain (DetectCycles (Tree QGoalReasonChain)) -> DetectCycles (Tree QGoalReasonChain)
-    go (PChoiceF qpn gr     cs) = PChoice qpn gr     <$> local (extendConflictSet $ P qpn) (T.sequence cs)
-    go (FChoiceF qfn gr w m cs) = FChoice qfn gr w m <$> local (extendConflictSet $ F qfn) (T.sequence cs)
-    go (SChoiceF qsn gr w   cs) = SChoice qsn gr w   <$> local (extendConflictSet $ S qsn) (T.sequence cs)
-    go (GoalChoiceF         cs) = GoalChoice         <$>                                   (T.sequence cs)
+    go (PChoiceF qpn gr     cs) = PChoice qpn gr     <$> local (CS.insert $ P qpn) (T.sequence cs)
+    go (FChoiceF qfn gr w m cs) = FChoice qfn gr w m <$> local (CS.insert $ F qfn) (T.sequence cs)
+    go (SChoiceF qsn gr w   cs) = SChoice qsn gr w   <$> local (CS.insert $ S qsn) (T.sequence cs)
+    go (GoalChoiceF         cs) = GoalChoice         <$>                           (T.sequence cs)
     go (FailF cs reason)        = return $ Fail cs reason
 
     -- We check for cycles only if we have actually found a solution
@@ -65,7 +66,7 @@ findCycles fullSet revDeps = do
 -- | Construct the relevant conflict set given the full conflict set that
 -- lead to this decision and the set of packages involved in the cycle
 relevantConflictSet :: Set QPN -> ConflictSet QPN -> ConflictSet QPN
-relevantConflictSet cycle = Set.filter isRelevant
+relevantConflictSet cycle = CS.filter isRelevant
   where
     isRelevant :: Var QPN -> Bool
     isRelevant (P qpn)                  = qpn `Set.member` cycle

cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs

@@ -7,7 +7,7 @@ module Distribution.Client.Dependency.Modular.Dependency (
   , varPI
     -- * Conflict sets
   , ConflictSet
-  , showCS
+  , CS.showCS
     -- * Constrained instances
   , CI(..)
   , merge
@@ -30,75 +30,29 @@ module Distribution.Client.Dependency.Modular.Dependency (
   , QGoalReasonChain
   , ResetGoal(..)
   , toConflictSet
-  , extendConflictSet
     -- * Open goals
   , OpenGoal(..)
   , close
   ) where
 
 import Prelude hiding (pi)
 
-import Data.List (intercalate)
 import Data.Map (Map)
-import Data.Set (Set)
 import qualified Data.List as L
-import qualified Data.Set  as S
 
 import Language.Haskell.Extension (Extension(..), Language(..))
 
 import Distribution.Text
 
+import Distribution.Client.Dependency.Modular.ConflictSet (ConflictSet)
 import Distribution.Client.Dependency.Modular.Flag
 import Distribution.Client.Dependency.Modular.Package
+import Distribution.Client.Dependency.Modular.Var
 import Distribution.Client.Dependency.Modular.Version
+import qualified Distribution.Client.Dependency.Modular.ConflictSet as CS
 
 import Distribution.Client.ComponentDeps (Component(..))
 
-{-------------------------------------------------------------------------------
-  Variables
--------------------------------------------------------------------------------}
-
--- | The type of variables that play a role in the solver.
--- Note that the tree currently does not use this type directly,
--- and rather has separate tree nodes for the different types of
--- variables. This fits better with the fact that in most cases,
--- these have to be treated differently.
---
--- TODO: This isn't the ideal location to declare the type,
--- but we need them for constrained instances.
-data Var qpn = P qpn | F (FN qpn) | S (SN qpn)
-  deriving (Eq, Ord, Show, Functor)
-
--- | For computing conflict sets, we map flag choice vars to a
--- single flag choice. This means that all flag choices are treated
--- as interdependent. So if one flag of a package ends up in a
--- conflict set, then all flags are being treated as being part of
--- the conflict set.
-simplifyVar :: Var qpn -> Var qpn
-simplifyVar (P qpn)       = P qpn
-simplifyVar (F (FN pi _)) = F (FN pi (mkFlag "flag"))
-simplifyVar (S qsn)       = S qsn
-
-showVar :: Var QPN -> String
-showVar (P qpn) = showQPN qpn
-showVar (F qfn) = showQFN qfn
-showVar (S qsn) = showQSN qsn
-
--- | Extract the package instance from a Var
-varPI :: Var QPN -> (QPN, Maybe I)
-varPI (P qpn)               = (qpn, Nothing)
-varPI (F (FN (PI qpn i) _)) = (qpn, Just i)
-varPI (S (SN (PI qpn i) _)) = (qpn, Just i)
-
-{-------------------------------------------------------------------------------
-  Conflict sets
--------------------------------------------------------------------------------}
-
-type ConflictSet qpn = Set (Var qpn)
-
-showCS :: ConflictSet QPN -> String
-showCS = intercalate ", " . L.map showVar . S.toList
-
 {-------------------------------------------------------------------------------
   Constrained instances
 -------------------------------------------------------------------------------}
@@ -131,13 +85,13 @@ showCI (Constrained vr) = showVR (collapse vr)
 merge :: Ord qpn => CI qpn -> CI qpn -> Either (ConflictSet qpn, (CI qpn, CI qpn)) (CI qpn)
 merge c@(Fixed i g1)       d@(Fixed j g2)
   | i == j                                    = Right c
-  | otherwise                                 = Left (S.union (toConflictSet g1) (toConflictSet g2), (c, d))
+  | otherwise                                 = Left (CS.union (toConflictSet g1) (toConflictSet g2), (c, d))
 merge c@(Fixed (I v _) g1)   (Constrained rs) = go rs -- I tried "reverse rs" here, but it seems to slow things down ...
   where
     go []              = Right c
     go (d@(vr, g2) : vrs)
       | checkVR vr v   = go vrs
-      | otherwise      = Left (S.union (toConflictSet g1) (toConflictSet g2), (c, Constrained [d]))
+      | otherwise      = Left (CS.union (toConflictSet g1) (toConflictSet g2), (c, Constrained [d]))
 merge c@(Constrained _)    d@(Fixed _ _)      = merge d c
 merge   (Constrained rs)     (Constrained ss) = Right (Constrained (rs ++ ss))
 
@@ -350,20 +304,16 @@ instance ResetGoal Goal where
 -- | Compute a conflict set from a goal. The conflict set contains the closure
 -- of goal reasons as well as the variable of the goal itself.
 toConflictSet :: Ord qpn => Goal qpn -> ConflictSet qpn
-toConflictSet (Goal g grs) = S.insert (simplifyVar g) (goalReasonChainToVars grs)
-
--- | Add another variable into a conflict set
-extendConflictSet :: Ord qpn => Var qpn -> ConflictSet qpn -> ConflictSet qpn
-extendConflictSet = S.insert . simplifyVar
+toConflictSet (Goal g grs) = CS.insert g (goalReasonChainToVars grs)
 
 goalReasonToVars :: GoalReason qpn -> ConflictSet qpn
-goalReasonToVars UserGoal                 = S.empty
-goalReasonToVars (PDependency (PI qpn _)) = S.singleton (P qpn)
-goalReasonToVars (FDependency qfn _)      = S.singleton (simplifyVar (F qfn))
-goalReasonToVars (SDependency qsn)        = S.singleton (S qsn)
+goalReasonToVars UserGoal                 = CS.empty
+goalReasonToVars (PDependency (PI qpn _)) = CS.singleton (P qpn)
+goalReasonToVars (FDependency qfn _)      = CS.singleton (F qfn)
+goalReasonToVars (SDependency qsn)        = CS.singleton (S qsn)
 
 goalReasonChainToVars :: Ord qpn => GoalReasonChain qpn -> ConflictSet qpn
-goalReasonChainToVars = S.unions . L.map goalReasonToVars
+goalReasonChainToVars = CS.unions . L.map goalReasonToVars
 
 {-------------------------------------------------------------------------------
   Open goals

cabal-install/Distribution/Client/Dependency/Modular/Explore.hs

@@ -5,14 +5,14 @@ module Distribution.Client.Dependency.Modular.Explore
 
 import Data.Foldable as F
 import Data.Map as M
-import Data.Set as S
 
 import Distribution.Client.Dependency.Modular.Assignment
 import Distribution.Client.Dependency.Modular.Dependency
 import Distribution.Client.Dependency.Modular.Log
 import Distribution.Client.Dependency.Modular.Message
 import Distribution.Client.Dependency.Modular.Package
 import qualified Distribution.Client.Dependency.Modular.PSQ as P
+import qualified Distribution.Client.Dependency.Modular.ConflictSet as CS
 import Distribution.Client.Dependency.Modular.Tree
 import qualified Distribution.Client.Dependency.Types as T
 
@@ -32,16 +32,16 @@ import qualified Distribution.Client.Dependency.Types as T
 -- return it immediately. If all children contain conflict sets, we can
 -- take the union as the combined conflict set.
 backjump :: F.Foldable t => Var QPN -> t (ConflictSetLog a) -> ConflictSetLog a
-backjump var xs = F.foldr combine logBackjump xs S.empty
+backjump var xs = F.foldr combine logBackjump xs CS.empty
   where
     combine :: ConflictSetLog a
             -> (ConflictSet QPN -> ConflictSetLog a)
             ->  ConflictSet QPN -> ConflictSetLog a
     combine (T.Done x)    _ _               = T.Done x
     combine (T.Fail cs)   f csAcc
-      | not (simplifyVar var `S.member` cs) = logBackjump cs
-      | otherwise                           = f (csAcc `S.union` cs)
-    combine (T.Step m ms) f cs              = T.Step m (combine ms f cs)
+      | not (var `CS.member` cs) = logBackjump cs
+      | otherwise                = f (csAcc `CS.union` cs)
+    combine (T.Step m ms) f cs   = T.Step m (combine ms f cs)
 
     logBackjump :: ConflictSet QPN -> ConflictSetLog a
     logBackjump cs = failWith (Failure cs Backjump) cs
@@ -77,8 +77,8 @@ exploreLog = cata go
       ts
     go (GoalChoiceF        ts) a           =
       P.casePSQ ts
-        (failWith (Failure S.empty EmptyGoalChoice) S.empty) -- empty goal choice is an internal error
-        (\ k v _xs -> continueWith (Next (close k)) (v a))   -- commit to the first goal choice
+        (failWith (Failure CS.empty EmptyGoalChoice) CS.empty) -- empty goal choice is an internal error
+        (\ k v _xs -> continueWith (Next (close k)) (v a))     -- commit to the first goal choice
 
 -- | Interface.
 backjumpAndExplore :: Tree a -> Log Message (Assignment, RevDepMap)

cabal-install/Distribution/Client/Dependency/Modular/Linking.hs

@@ -28,6 +28,7 @@ import Distribution.Client.Dependency.Modular.Index
 import Distribution.Client.Dependency.Modular.Package
 import Distribution.Client.Dependency.Modular.Tree
 import qualified Distribution.Client.Dependency.Modular.PSQ as P
+import qualified Distribution.Client.Dependency.Modular.ConflictSet as CS
 
 import Distribution.Client.Types (OptionalStanza(..))
 import Distribution.Client.ComponentDeps (Component)
@@ -246,7 +247,7 @@ makeCanonical lg qpn@(Q pp _) i =
     case lgCanon lg of
       -- There is already a canonical member. Fail.
       Just _ ->
-        conflict ( S.fromList (P qpn : lgBlame lg)
+        conflict ( CS.insert (P qpn) (lgBlame lg)
                  ,    "cannot make " ++ showQPN qpn
                    ++ " canonical member of " ++ showLinkGroup lg
                  )
@@ -401,7 +402,7 @@ verifyFlag' (FN (PI pn i) fn) lg = do
         vals  = map (`M.lookup` vsFlags vs) flags
     if allEqual (catMaybes vals) -- We ignore not-yet assigned flags
       then return ()
-      else conflict ( S.fromList (map F flags) `S.union` lgConflictSet lg
+      else conflict ( CS.fromList (map F flags) `CS.union` lgConflictSet lg
                     , "flag " ++ show fn ++ " incompatible"
                     )
 
@@ -419,7 +420,7 @@ verifyStanza' (SN (PI pn i) sn) lg = do
         vals    = map (`M.lookup` vsStanzas vs) stanzas
     if allEqual (catMaybes vals) -- We ignore not-yet assigned stanzas
       then return ()
-      else conflict ( S.fromList (map S stanzas) `S.union` lgConflictSet lg
+      else conflict ( CS.fromList (map S stanzas) `CS.union` lgConflictSet lg
                     , "stanza " ++ show sn ++ " incompatible"
                     )
 
@@ -452,7 +453,7 @@ data LinkGroup = LinkGroup {
       -- | The set of variables that should be added to the conflict set if
       -- something goes wrong with this link set (in addition to the members
       -- of the link group itself)
-    , lgBlame :: [Var QPN]
+    , lgBlame :: ConflictSet QPN
     }
     deriving Show
 
@@ -483,7 +484,7 @@ lgSingleton (Q pp pn) canon = LinkGroup {
       lgPackage = pn
     , lgCanon   = canon
     , lgMembers = S.singleton pp
-    , lgBlame   = []
+    , lgBlame   = CS.empty
     }
 
 lgMerge :: [Var QPN] -> LinkGroup -> LinkGroup -> Either Conflict LinkGroup
@@ -493,7 +494,7 @@ lgMerge blame lg lg' = do
         lgPackage = lgPackage lg
       , lgCanon   = canon
       , lgMembers = lgMembers lg `S.union` lgMembers lg'
-      , lgBlame   = blame ++ lgBlame lg ++ lgBlame lg'
+      , lgBlame   = CS.unions [CS.fromList blame, lgBlame lg, lgBlame lg']
       }
   where
     pick :: Eq a => Maybe a -> Maybe a -> Either Conflict (Maybe a)
@@ -502,8 +503,8 @@ lgMerge blame lg lg' = do
     pick Nothing  (Just y) = Right $ Just y
     pick (Just x) (Just y) =
       if x == y then Right $ Just x
-                else Left ( S.unions [
-                               S.fromList blame
+                else Left ( CS.unions [
+                               CS.fromList blame
                              , lgConflictSet lg
                              , lgConflictSet lg'
                              ]
@@ -512,7 +513,9 @@ lgMerge blame lg lg' = do
                           )
 
 lgConflictSet :: LinkGroup -> ConflictSet QPN
-lgConflictSet lg = S.fromList (map aux (S.toList (lgMembers lg)) ++ lgBlame lg)
+lgConflictSet lg =
+               CS.fromList (map aux (S.toList (lgMembers lg)))
+    `CS.union` lgBlame lg
   where
     aux pp = P (Q pp (lgPackage lg))
 

cabal-install/Distribution/Client/Dependency/Modular/Log.hs

@@ -10,14 +10,14 @@ module Distribution.Client.Dependency.Modular.Log
 import Control.Applicative
 import Data.List as L
 import Data.Maybe (isNothing)
-import Data.Set as S
 
 import Distribution.Client.Dependency.Types -- from Cabal
 
 import Distribution.Client.Dependency.Modular.Dependency
 import Distribution.Client.Dependency.Modular.Message
 import Distribution.Client.Dependency.Modular.Package
 import Distribution.Client.Dependency.Modular.Tree (FailReason(..))
+import qualified Distribution.Client.Dependency.Modular.ConflictSet as CS
 
 -- | The 'Log' datatype.
 --
@@ -82,7 +82,7 @@ logToProgress mbj l = let
     go ms r           (Step x xs)           = Step x (go ms r  xs)
     go ms _           (Fail (exh, Just cs)) = Fail $
                                               "Could not resolve dependencies:\n" ++
-                                              unlines (messages $ showMessages (L.foldr (\ v _ -> v `S.member` cs) True) False ms) ++
+                                              unlines (messages $ showMessages (L.foldr (\ v _ -> v `CS.member` cs) True) False ms) ++
                                               (if exh then "Dependency tree exhaustively searched.\n"
                                                       else "Backjump limit reached (" ++ currlimit mbj ++
                                                                "change with --max-backjumps or try to run with --reorder-goals).\n")