Merge branch 'pr/DetectCyclesInSolver' of https://github.com/edsko/cabal into...

Merge branch 'pr/DetectCyclesInSolver' of https://github.com/edsko/cabal into edsko-pr/DetectCyclesInSolver

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

+{-# LANGUAGE CPP #-}
+module Distribution.Client.Dependency.Modular.Cycles (
+    detectCycles
+  ) 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 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)
+
+-- | Find any reject any solutions that are cyclic
+detectCycles :: Tree QGoalReasonChain -> Tree QGoalReasonChain
+detectCycles = (`runReader` Set.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 (FailF cs reason)        = return $ 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
+        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 of the solution is cyclic. If it is, return the conflic 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
+  where
+    cycles :: [[QPN]]
+    cycles = [vs | Gr.CyclicSCC vs <- scc]
+
+    scc :: [SCC QPN]
+    scc = Gr.stronglyConnComp . map aux . Map.toList $ revDeps
+
+    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

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

@@ -30,6 +30,7 @@ module Distribution.Client.Dependency.Modular.Dependency (
   , QGoalReasonChain
   , ResetGoal(..)
   , toConflictSet
+  , extendConflictSet
     -- * Open goals
   , OpenGoal(..)
   , close
@@ -171,7 +172,7 @@ data FlaggedDep comp qpn =
     Flagged (FN qpn) FInfo (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn)
   | Stanza  (SN qpn)       (TrueFlaggedDeps qpn)
   | Simple (Dep qpn) comp
-  deriving (Eq, Show, Functor)
+  deriving (Eq, Show)
 
 -- | Conversatively flatten out flagged dependencies
 --
@@ -189,10 +190,15 @@ type FalseFlaggedDeps qpn = FlaggedDeps Component qpn
 
 -- | A dependency (constraint) associates a package name with a
 -- constrained instance.
+--
+-- 'Dep' intentionally has no 'Functor' instance because the type variable
+-- is used both to record the dependencies as well as who's doing the
+-- depending; having a 'Functor' instance makes bugs where we don't distinguish
+-- these two far too likely. (By rights 'Dep' ought to have two type variables.)
 data Dep qpn = Dep  qpn (CI qpn)  -- dependency on a package
              | Ext  Extension     -- dependency on a language extension
              | Lang Language      -- dependency on a language version
-  deriving (Eq, Show, Functor)
+  deriving (Eq, Show)
 
 showDep :: Dep QPN -> String
 showDep (Dep qpn (Fixed i (Goal v _))          ) =
@@ -236,17 +242,25 @@ qualifyDeps QO{..} (Q pp' pn) = go
     go1 (Stanza  sn     t)   = Stanza  (fmap (Q pp) sn)     (go t)
     go1 (Simple dep comp)    = Simple (goD dep comp) comp
 
+    -- Suppose package B has a setup dependency on package A.
+    -- This will be recorded as something like
+    --
+    -- > Dep "A" (Constrained [(AnyVersion, Goal (P "B") reason])
+    --
+    -- Observe that when we qualify this dependency, we need to turn that
+    -- @"A"@ into @"B-setup.A"@, but we should not apply that same qualifier
+    -- to the goal or the goal reason chain.
     goD :: Dep PN -> Component -> Dep QPN
-    goD dep comp
-      | qBase  dep  = fmap (Q (Base  pn pp)) dep
-      | qSetup comp = fmap (Q (Setup pn pp)) dep
-      | otherwise   = fmap (Q           pp ) dep
+    goD (Ext  ext)    _    = Ext  ext
+    goD (Lang lang)   _    = Lang lang
+    goD (Dep  dep ci) comp
+      | qBase  dep  = Dep (Q (Base  pn pp) dep) (fmap (Q pp) ci)
+      | qSetup comp = Dep (Q (Setup pn pp) dep) (fmap (Q pp) ci)
+      | otherwise   = Dep (Q           pp  dep) (fmap (Q pp) ci)
 
     -- Should we qualify this goal with the 'Base' package path?
-    qBase :: Dep PN -> Bool
-    qBase (Dep dep _ci) = qoBaseShim && unPackageName dep == "base"
-    qBase (Ext _)       = False
-    qBase (Lang _)      = False
+    qBase :: PN -> Bool
+    qBase dep = qoBaseShim && unPackageName dep == "base"
 
     -- Should we qualify this goal with the 'Setup' packaeg path?
     qSetup :: Component -> Bool
@@ -332,6 +346,10 @@ instance ResetGoal Goal where
 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
+
 goalReasonToVars :: GoalReason qpn -> ConflictSet qpn
 goalReasonToVars UserGoal                 = S.empty
 goalReasonToVars (PDependency (PI qpn _)) = S.singleton (P qpn)

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

@@ -123,6 +123,7 @@ showFR _ (BuildFailureNotInIndex pn)      = " (unknown package: " ++ display pn
 showFR c Backjump                         = " (backjumping, conflict set: " ++ showCS c ++ ")"
 showFR _ MultipleInstances                = " (multiple instances)"
 showFR c (DependenciesNotLinked msg)      = " (dependencies not linked: " ++ msg ++ "; conflict set: " ++ showCS c ++ ")"
+showFR c CyclicDependencies               = " (cyclic dependencies; conflict set: " ++ showCS c ++ ")"
 -- The following are internal failures. They should not occur. In the
 -- interest of not crashing unnecessarily, we still just print an error
 -- message though.

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

@@ -11,6 +11,7 @@ import Distribution.Client.Dependency.Types
 
 import Distribution.Client.Dependency.Modular.Assignment
 import Distribution.Client.Dependency.Modular.Builder
+import Distribution.Client.Dependency.Modular.Cycles
 import Distribution.Client.Dependency.Modular.Dependency
 import Distribution.Client.Dependency.Modular.Explore
 import Distribution.Client.Dependency.Modular.Index
@@ -40,6 +41,7 @@ solve :: SolverConfig ->                      -- solver parameters
          Log Message (Assignment, RevDepMap)
 solve sc cinfo idx userPrefs userConstraints userGoals =
   explorePhase     $
+  detectCycles     $
   heuristicsPhase  $
   preferencesPhase $
   validationPhase  $

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

@@ -82,6 +82,7 @@ data FailReason = InconsistentInitialConstraints
                 | Backjump
                 | MultipleInstances
                 | DependenciesNotLinked String
+                | CyclicDependencies
   deriving (Eq, Show)
 
 -- | Functor for the tree type.

cabal-install/cabal-install.cabal

@@ -138,6 +138,7 @@ executable cabal
         Distribution.Client.Dependency.Modular.Builder
         Distribution.Client.Dependency.Modular.Configured
         Distribution.Client.Dependency.Modular.ConfiguredConversion
+        Distribution.Client.Dependency.Modular.Cycles
         Distribution.Client.Dependency.Modular.Dependency
         Distribution.Client.Dependency.Modular.Explore
         Distribution.Client.Dependency.Modular.Flag

cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs

@@ -72,6 +72,11 @@ tests = [
         , runTest $ mkTest db12 "baseShim5" ["D"] Nothing
         , runTest $ mkTest db12 "baseShim6" ["E"] (Just [("E", 1), ("syb", 2)])
         ]
+    , testGroup "Cycles" [
+          runTest $ mkTest db14 "simpleCycle1"         ["A"]      Nothing
+        , runTest $ mkTest db14 "simpleCycle2"         ["A", "B"] Nothing
+        , runTest $ mkTest db14 "cycleWithFlagChoice1" ["C"]      (Just [("C", 1), ("E", 1)])
+        ]
     , testGroup "Extensions" [
           runTest $ mkTestExts [EnableExtension CPP] dbExts1 "unsupported" ["A"] Nothing
         , runTest $ mkTestExts [EnableExtension CPP] dbExts1 "unsupportedIndirect" ["B"] Nothing
@@ -423,6 +428,20 @@ db13 = [
   , Right $ exAv "A" 3 []
   ]
 
+-- | Database with some cycles
+--
+-- * Simplest non-trivial cycle: A -> B and B -> A
+-- * There is a cycle C -> D -> C, but it can be broken by picking the
+--   right flag assignment.
+db14 :: ExampleDb
+db14 = [
+    Right $ exAv "A" 1 [ExAny "B"]
+  , Right $ exAv "B" 1 [ExAny "A"]
+  , Right $ exAv "C" 1 [exFlag "flagC" [ExAny "D"] [ExAny "E"]]
+  , Right $ exAv "D" 1 [ExAny "C"]
+  , Right $ exAv "E" 1 []
+  ]
+
 dbExts1 :: ExampleDb
 dbExts1 = [
     Right $ exAv "A" 1 [ExExt (EnableExtension RankNTypes)]