diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs b/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs index 2bea5b80afe..9f356a6d097 100644 --- a/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs +++ b/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs @@ -180,4 +180,4 @@ buildTree idx ind igs = topLevelGoal qpn = OpenGoal (Simple (Dep qpn (Constrained [])) ()) [UserGoal] qpns | ind = makeIndependent igs - | otherwise = L.map (Q None) igs + | otherwise = L.map (Q (PP DefaultNamespace Unqualified)) igs diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs b/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs index b352d1e1a34..11b5235588a 100644 --- a/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs +++ b/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs @@ -232,12 +232,8 @@ data QualifyOptions = QO { -- NOTE: It's the _dependencies_ of a package that may or may not be independent -- from the package itself. Package flag choices must of course be consistent. qualifyDeps :: QualifyOptions -> QPN -> FlaggedDeps Component PN -> FlaggedDeps Component QPN -qualifyDeps QO{..} (Q pp' pn) = go +qualifyDeps QO{..} (Q pp@(PP ns q) pn) = go where - -- The Base qualifier does not get inherited - pp :: PP - pp = (if qoBaseShim then stripBase else id) pp' - go :: FlaggedDeps Component PN -> FlaggedDeps Component QPN go = map go1 @@ -259,9 +255,22 @@ qualifyDeps QO{..} (Q pp' pn) = go goD (Lang lang) _ = Lang lang goD (Pkg pkn vr) _ = Pkg pkn vr 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) + | qBase dep = Dep (Q (PP ns (Base pn)) dep) (fmap (Q pp) ci) + | qSetup comp = Dep (Q (PP ns (Setup pn)) dep) (fmap (Q pp) ci) + | otherwise = Dep (Q (PP ns inheritedQ) dep) (fmap (Q pp) ci) + + -- If P has a setup dependency on Q, and Q has a regular dependency on R, then + -- we say that the 'Setup' qualifier is inherited: P has an (indirect) setup + -- dependency on R. We do not do this for the base qualifier however. + -- + -- The inherited qualifier is only used for regular dependencies; for setup + -- and base deppendencies we override the existing qualifier. See #3160 for + -- a detailed discussion. + inheritedQ :: Qualifier + inheritedQ = case q of + Setup _ -> q + Unqualified -> q + Base _ -> Unqualified -- Should we qualify this goal with the 'Base' package path? qBase :: PN -> Bool diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Package.hs b/cabal-install/Distribution/Client/Dependency/Modular/Package.hs index 4fc8f7abeb9..ef903f19d15 100644 --- a/cabal-install/Distribution/Client/Dependency/Modular/Package.hs +++ b/cabal-install/Distribution/Client/Dependency/Modular/Package.hs @@ -8,6 +8,8 @@ module Distribution.Client.Dependency.Modular.Package , PI(..) , PN , PP(..) + , Namespace(..) + , Qualifier(..) , QPN , QPV , Q(..) @@ -17,7 +19,6 @@ module Distribution.Client.Dependency.Modular.Package , showI , showPI , showQPN - , stripBase , unPN ) where @@ -81,46 +82,75 @@ instI :: I -> Bool instI (I _ (Inst _)) = True instI _ = False --- | Package path. --- --- Stored in reverse order -data PP = - -- User-specified independent goal - Independent Int PP - -- Setup dependencies are always considered independent from their package - | Setup PN PP - -- Any dependency on base is considered independent (allows for base shims) - | Base PN PP - -- Unqualified - | None +-- | A package path consists of a namespace and a package path inside that +-- namespace. +data PP = PP Namespace Qualifier deriving (Eq, Ord, Show) --- | Strip any 'Base' qualifiers from a PP +-- | Top-level namespace -- --- (the Base qualifier does not get inherited) -stripBase :: PP -> PP -stripBase (Independent i pp) = Independent i (stripBase pp) -stripBase (Setup pn pp) = Setup pn (stripBase pp) -stripBase (Base _pn pp) = stripBase pp -stripBase None = None +-- Package choices in different namespaces are considered completely independent +-- by the solver. +data Namespace = + -- | The default namespace + DefaultNamespace + + -- | Independent namespace + -- + -- For now we just number these (rather than giving them more structure). + | Independent Int + deriving (Eq, Ord, Show) + +-- | Qualifier of a package within a namespace (see 'PP') +data Qualifier = + -- | Top-level dependency in this namespace + Unqualified + + -- | Any dependency on base is considered independent + -- + -- This makes it possible to have base shims. + | Base PN + + -- | Setup dependency + -- + -- By rights setup dependencies ought to be nestable; after all, the setup + -- dependencies of a package might themselves have setup dependencies, which + -- are independent from everything else. However, this very quickly leads to + -- infinite search trees in the solver. Therefore we limit ourselves to + -- a single qualifier (within a given namespace). + | Setup PN + deriving (Eq, Ord, Show) -- | Is the package in the primary group of packages. In particular this -- does not include packages pulled in as setup deps. -- primaryPP :: PP -> Bool -primaryPP (Independent _ pp) = primaryPP pp -primaryPP (Setup _ _ ) = False -primaryPP (Base _ pp) = primaryPP pp -primaryPP None = True +primaryPP (PP _ns q) = go q + where + go Unqualified = True + go (Base _) = True + go (Setup _) = False -- | String representation of a package path. -- --- NOTE: This always ends in a period +-- NOTE: The result of 'showPP' is either empty or results in a period, so that +-- it can be prepended to a package name. showPP :: PP -> String -showPP (Independent i pp) = show i ++ "." ++ showPP pp -showPP (Setup pn pp) = display pn ++ "-setup" ++ "." ++ showPP pp -showPP (Base pn pp) = display pn ++ "." ++ showPP pp -showPP None = "" +showPP (PP ns q) = + case ns of + DefaultNamespace -> go q + Independent i -> show i ++ "." ++ go q + where + -- Print the qualifier + -- + -- NOTE: the base qualifier is for a dependency _on_ base; the qualifier is + -- there to make sure different dependencies on base are all independent. + -- So we want to print something like @"A.base"@, where the @"A."@ part + -- is the qualifier and @"base"@ is the actual dependency (which, for the + -- 'Base' qualifier, will always be @base@). + go Unqualified = "" + go (Setup pn) = display pn ++ "-setup." + go (Base pn) = display pn ++ "." -- | A qualified entity. Pairs a package path with the entity. data Q a = Q PP a @@ -128,8 +158,7 @@ data Q a = Q PP a -- | Standard string representation of a qualified entity. showQ :: (a -> String) -> (Q a -> String) -showQ showa (Q None x) = showa x -showQ showa (Q pp x) = showPP pp ++ showa x +showQ showa (Q pp x) = showPP pp ++ showa x -- | Qualified package name. type QPN = Q PN @@ -142,5 +171,5 @@ showQPN = showQ display -- them all independent. makeIndependent :: [PN] -> [QPN] makeIndependent ps = [ Q pp pn | (pn, i) <- zip ps [0::Int ..] - , let pp = Independent i None + , let pp = PP (Independent i) Unqualified ] diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs b/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs index 63dfbec1f46..c441724200d 100644 --- a/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs +++ b/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs @@ -308,8 +308,8 @@ deferSetupChoices = trav go go x = x noSetup :: OpenGoal comp -> Bool - noSetup (OpenGoal (Simple (Dep (Q (Setup _ _) _) _) _) _) = False - noSetup _ = True + noSetup (OpenGoal (Simple (Dep (Q (PP _ns (Setup _)) _) _) _) _) = False + noSetup _ = True -- | Transformation that tries to avoid making weak flag choices early. -- Weak flags are trivial flags (not influencing dependencies) or such 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 c3c3f999137..92ad0679b13 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs @@ -74,9 +74,14 @@ tests = [ , 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)]) + runTest $ mkTest db14 "simpleCycle1" ["A"] Nothing + , runTest $ mkTest db14 "simpleCycle2" ["A", "B"] Nothing + , runTest $ mkTest db14 "cycleWithFlagChoice1" ["C"] (Just [("C", 1), ("E", 1)]) + , runTest $ mkTest db15 "cycleThroughSetupDep1" ["A"] Nothing + , runTest $ mkTest db15 "cycleThroughSetupDep2" ["B"] Nothing + , runTest $ mkTest db15 "cycleThroughSetupDep3" ["C"] (Just [("C", 2), ("D", 1)]) + , runTest $ mkTest db15 "cycleThroughSetupDep4" ["D"] (Just [("D", 1)]) + , runTest $ mkTest db15 "cycleThroughSetupDep5" ["E"] (Just [("C", 2), ("D", 1), ("E", 1)]) ] , testGroup "Extensions" [ runTest $ mkTestExts [EnableExtension CPP] dbExts1 "unsupported" ["A"] Nothing @@ -460,6 +465,29 @@ db14 = [ , Right $ exAv "E" 1 [] ] +-- | Cycles through setup dependencies +-- +-- The first cycle is unsolvable: package A has a setup dependency on B, +-- B has a regular dependency on A, and we only have a single version available +-- for both. +-- +-- The second cycle can be broken by picking different versions: package C-2.0 +-- has a setup dependency on D, and D has a regular dependency on C-*. However, +-- version C-1.0 is already available (perhaps it didn't have this setup dep). +-- Thus, we should be able to break this cycle even if we are installing package +-- E, which explictly depends on C-2.0. +db15 :: ExampleDb +db15 = [ + -- First example (real cycle, no solution) + Right $ exAv "A" 1 [] `withSetupDeps` [ExAny "B"] + , Right $ exAv "B" 1 [ExAny "A"] + -- Second example (cycle can be broken by picking versions carefully) + , Left $ exInst "C" 1 "C-1-inst" [] + , Right $ exAv "C" 2 [] `withSetupDeps` [ExAny "D"] + , Right $ exAv "D" 1 [ExAny "C" ] + , Right $ exAv "E" 1 [ExFix "C" 2] + ] + dbExts1 :: ExampleDb dbExts1 = [ Right $ exAv "A" 1 [ExExt (EnableExtension RankNTypes)]