From 927ec76354b1b964a906296dd6bf11eb23113ddb Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Fri, 19 Feb 2016 10:17:01 +0100 Subject: [PATCH 1/2] Remove functor instance from Dep and fix bug in qualityDeps --- .../Client/Dependency/Modular/Dependency.hs | 33 +++++++++++++------ 1 file changed, 23 insertions(+), 10 deletions(-) diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs b/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs index a9d5cddb6cf..df0536954ea 100644 --- a/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs +++ b/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs @@ -171,7 +171,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 +189,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 +241,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 From a0a80420c10590dc97c393ce1ebeef9e426c5de4 Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Fri, 19 Feb 2016 10:30:16 +0100 Subject: [PATCH 2/2] Detect and reject cyclic solutions in the solver --- .../Client/Dependency/Modular/Cycles.hs | 73 +++++++++++++++++++ .../Client/Dependency/Modular/Dependency.hs | 5 ++ .../Client/Dependency/Modular/Message.hs | 1 + .../Client/Dependency/Modular/Solver.hs | 2 + .../Client/Dependency/Modular/Tree.hs | 1 + cabal-install/cabal-install.cabal | 1 + .../Client/Dependency/Modular/Solver.hs | 19 +++++ 7 files changed, 102 insertions(+) create mode 100644 cabal-install/Distribution/Client/Dependency/Modular/Cycles.hs diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Cycles.hs b/cabal-install/Distribution/Client/Dependency/Modular/Cycles.hs new file mode 100644 index 00000000000..b123b087b46 --- /dev/null +++ b/cabal-install/Distribution/Client/Dependency/Modular/Cycles.hs @@ -0,0 +1,73 @@ +{-# 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 diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs b/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs index df0536954ea..dbc449231d1 100644 --- a/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs +++ b/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 @@ -345,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) diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Message.hs b/cabal-install/Distribution/Client/Dependency/Modular/Message.hs index e0cd415ca16..4310dffb033 100644 --- a/cabal-install/Distribution/Client/Dependency/Modular/Message.hs +++ b/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. diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs b/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs index 205bf2fafeb..595c80699ae 100644 --- a/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs +++ b/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 $ diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs b/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs index d1f19c93d00..42d403ef94f 100644 --- a/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs +++ b/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. diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index 11ea8d72453..558546d17fe 100644 --- a/cabal-install/cabal-install.cabal +++ b/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 diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs b/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs index 7150a2d700e..870faeaecfa 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs +++ b/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)]