Merge pull request #3220 from edsko/pr/LimitQualifierDepth

Limit qualifier depth

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

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

@@ -237,12 +237,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
 
@@ -264,9 +260,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

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
                      ]

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

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

@@ -75,9 +75,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
@@ -479,6 +484,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)]