Fix construction of conflict sets once and for all (WIP)

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

@@ -64,22 +64,22 @@ data PreAssignment = PA PPreAssignment FAssignment SAssignment
 extend :: (Extension -> Bool) -- ^ is a given extension supported
        -> (Language  -> Bool) -- ^ is a given language supported
        -> (PN -> VR  -> Bool) -- ^ is a given pkg-config requirement satisfiable
-       -> Goal QPN
+       -> Var QPN
        -> PPreAssignment -> [Dep QPN] -> Either (ConflictSet QPN, [Dep QPN]) PPreAssignment
-extend extSupported langSupported pkgPresent goal@(Goal var _) = foldM extendSingle
+extend extSupported langSupported pkgPresent var = foldM extendSingle
   where
 
     extendSingle :: PPreAssignment -> Dep QPN
                  -> Either (ConflictSet QPN, [Dep QPN]) PPreAssignment
     extendSingle a (Ext  ext )  =
       if extSupported  ext  then Right a
-                            else Left (toConflictSet goal, [Ext ext])
+                            else Left (varToConflictSet var, [Ext ext])
     extendSingle a (Lang lang)  =
       if langSupported lang then Right a
-                            else Left (toConflictSet goal, [Lang lang])
+                            else Left (varToConflictSet var, [Lang lang])
     extendSingle a (Pkg pn vr)  =
       if pkgPresent pn vr then Right a
-                          else Left (toConflictSet goal, [Pkg pn vr])
+                          else Left (varToConflictSet var, [Pkg pn vr])
     extendSingle a (Dep qpn ci) =
       let ci' = M.findWithDefault (Constrained []) qpn a
       in  case (\ x -> M.insert qpn x a) <$> merge ci' ci of
@@ -90,9 +90,9 @@ extend extSupported langSupported pkgPresent goal@(Goal var _) = foldM extendSin
     -- making a choice pkg == instance, and pkg => pkg == instance is a part
     -- of the conflict, then this info is clear from the context and does not
     -- have to be repeated.
-    simplify v (Fixed _ (Goal var' _)) c | v == var && var' == var = [c]
-    simplify v c (Fixed _ (Goal var' _)) | v == var && var' == var = [c]
-    simplify _ c                       d                           = [c, d]
+    simplify v (Fixed _ var') c | v == var && var' == var = [c]
+    simplify v c (Fixed _ var') | v == var && var' == var = [c]
+    simplify _ c              d                           = [c, d]
 
 -- | Delivers an ordered list of fully configured packages.
 --

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

@@ -67,7 +67,7 @@ extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs
 
 -- | Given the current scope, qualify all the package names in the given set of
 -- dependencies and then extend the set of open goals accordingly.
-scopedExtendOpen :: QPN -> I -> QGoalReasonChain -> FlaggedDeps Component PN -> FlagInfo ->
+scopedExtendOpen :: QPN -> I -> QGoalReason -> FlaggedDeps Component PN -> FlagInfo ->
                     BuildState -> BuildState
 scopedExtendOpen qpn i gr fdeps fdefs s = extendOpen qpn gs s
   where
@@ -97,13 +97,13 @@ scopedExtendOpen qpn i gr fdeps fdefs s = extendOpen qpn gs s
 data BuildType =
     Goals                                  -- ^ build a goal choice node
   | OneGoal (OpenGoal ())                  -- ^ build a node for this goal
-  | Instance QPN I PInfo QGoalReasonChain  -- ^ build a tree for a concrete instance
+  | Instance QPN I PInfo QGoalReason  -- ^ build a tree for a concrete instance
   deriving Show
 
-build :: BuildState -> Tree QGoalReasonChain
+build :: BuildState -> Tree QGoalReason
 build = ana go
   where
-    go :: BuildState -> TreeF QGoalReasonChain BuildState
+    go :: BuildState -> TreeF QGoalReason BuildState
 
     -- If we have a choice between many goals, we just record the choice in
     -- the tree. We select each open goal in turn, and before we descend, remove
@@ -125,8 +125,13 @@ build = ana go
     go    (BS { index = _  , next = OneGoal (OpenGoal (Simple (Pkg _ _          ) _) _ ) }) =
       error "Distribution.Client.Dependency.Modular.Builder: build.go called with Pkg goal"
     go bs@(BS { index = idx, next = OneGoal (OpenGoal (Simple (Dep qpn@(Q _ pn) _) _) gr) }) =
+      -- If the package does not exist in the index, we construct an emty PChoiceF node for it
+      -- After all, we have no choices here. Alternatively, we could immediately construct
+      -- a Fail node here, but that would complicate the construction of conflict sets.
+      -- We will probably want to give this case special treatment when generating error
+      -- messages though.
       case M.lookup pn idx of
-        Nothing  -> FailF (toConflictSet (Goal (P qpn) gr)) (BuildFailureNotInIndex pn)
+        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 }))
                                                          (M.toList pis)))
@@ -138,8 +143,8 @@ 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
-        [(True,  (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn True  : gr)) t) bs) { next = Goals }),
-         (False, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn False : gr)) f) bs) { next = Goals })]))
+        [(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
@@ -152,22 +157,22 @@ build = ana go
 
     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 : gr)) t) bs) { next = Goals })])
+        [(False,                                                             bs  { next = Goals }),
+         (True,  (extendOpen qpn (L.map (flip OpenGoal (SDependency qsn)) t) bs) { next = Goals })])
       where
         trivial = L.null t
 
     -- For a particular instance, we change the state: we update the scope,
     -- and furthermore we update the set of goals.
     --
     -- TODO: We could inline this above.
-    go bs@(BS { next = Instance qpn i (PInfo fdeps fdefs _) gr }) =
-      go ((scopedExtendOpen qpn i (PDependency (PI qpn i) : gr) fdeps fdefs bs)
+    go bs@(BS { next = Instance qpn i (PInfo fdeps fdefs _) _gr }) =
+      go ((scopedExtendOpen qpn i (PDependency (PI qpn i)) fdeps fdefs bs)
              { next = Goals })
 
 -- | Interface to the tree builder. Just takes an index and a list of package names,
 -- and computes the initial state and then the tree from there.
-buildTree :: Index -> Bool -> [PN] -> Tree QGoalReasonChain
+buildTree :: Index -> Bool -> [PN] -> Tree QGoalReason
 buildTree idx ind igs =
     build BS {
         index = idx
@@ -177,7 +182,7 @@ buildTree idx ind igs =
       , qualifyOptions = defaultQualifyOptions idx
       }
   where
-    topLevelGoal qpn = OpenGoal (Simple (Dep qpn (Constrained [])) ()) [UserGoal]
+    topLevelGoal qpn = OpenGoal (Simple (Dep qpn (Constrained [])) ()) UserGoal
 
     qpns | ind       = makeIndependent igs
          | otherwise = L.map (Q (PP DefaultNamespace Unqualified)) igs

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

@@ -4,54 +4,43 @@ module Distribution.Client.Dependency.Modular.Cycles (
   ) where
 
 import Prelude hiding (cycle)
-import Control.Monad
-import Control.Monad.Reader
 import Data.Graph (SCC)
-import Data.Set   (Set)
-import qualified Data.Graph       as Gr
-import qualified Data.Map         as Map
-import qualified Data.Set         as Set
-import qualified Data.Traversable as T
-
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative ((<$>))
-#endif
+import qualified Data.Graph as Gr
+import qualified Data.Map   as Map
 
 import Distribution.Client.Dependency.Modular.Dependency
-import Distribution.Client.Dependency.Modular.Flag
 import Distribution.Client.Dependency.Modular.Package
 import Distribution.Client.Dependency.Modular.Tree
-
-type DetectCycles = Reader (ConflictSet QPN)
+import qualified Distribution.Client.Dependency.Modular.ConflictSet as CS
 
 -- | Find and reject any solutions that are cyclic
-detectCyclesPhase :: Tree QGoalReasonChain -> Tree QGoalReasonChain
-detectCyclesPhase = (`runReader` Set.empty) .  cata go
+detectCyclesPhase :: Tree QGoalReason -> Tree QGoalReason
+detectCyclesPhase = 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 (FailF cs reason)        = return $ Fail cs reason
+    -- The only node of interest is DoneF
+    go :: TreeF QGoalReason (Tree QGoalReason) -> Tree QGoalReason
+    go (PChoiceF qpn gr     cs) = PChoice qpn gr     cs
+    go (FChoiceF qfn gr w m cs) = FChoice qfn gr w m cs
+    go (SChoiceF qsn gr w   cs) = SChoice qsn gr w   cs
+    go (GoalChoiceF         cs) = GoalChoice         cs
+    go (FailF cs reason)        = Fail cs reason
 
     -- We check for cycles only if we have actually found a solution
     -- This minimizes the number of cycle checks we do as cycles are rare
     go (DoneF revDeps) = do
-      fullSet <- ask
-      return $ case findCycles fullSet revDeps of
+      case findCycles revDeps of
         Nothing     -> Done revDeps
         Just relSet -> Fail relSet CyclicDependencies
 
 -- | Given the reverse dependency map from a 'Done' node in the tree, as well
 -- as the full conflict set containing all decisions that led to that 'Done'
 -- node, check if the solution is cyclic. If it is, return the conflict set
 -- containing all decisions that could potentially break the cycle.
-findCycles :: ConflictSet QPN -> RevDepMap -> Maybe (ConflictSet QPN)
-findCycles fullSet revDeps = do
-    guard $ not (null cycles)
-    return $ relevantConflictSet (Set.fromList (concat cycles)) fullSet
+findCycles :: RevDepMap -> Maybe (ConflictSet QPN)
+findCycles revDeps =
+    case cycles of
+      []  -> Nothing
+      c:_ -> Just $ CS.unions $ map (varToConflictSet . P) c
   where
     cycles :: [[QPN]]
     cycles = [vs | Gr.CyclicSCC vs <- scc]
@@ -61,13 +50,3 @@ findCycles fullSet revDeps = do
 
     aux :: (QPN, [(comp, QPN)]) -> (QPN, QPN, [QPN])
     aux (fr, to) = (fr, fr, map snd to)
-
--- | 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
-  where
-    isRelevant :: Var QPN -> Bool
-    isRelevant (P qpn)                  = qpn `Set.member` cycle
-    isRelevant (F (FN (PI qpn _i) _fn)) = qpn `Set.member` cycle
-    isRelevant (S (SN (PI qpn _i) _sn)) = qpn `Set.member` cycle