Rebase fixLinkDeps onto solver branch

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

@@ -19,6 +19,7 @@ module Distribution.Client.Dependency.Modular.Dependency (
   , flattenFlaggedDeps
   , QualifyOptions(..)
   , qualifyDeps
+  , unqualifyDeps
     -- ** Setting/forgetting components
   , forgetCompOpenGoal
   , setCompFlaggedDeps
@@ -239,6 +240,26 @@ qualifyDeps QO{..} (Q pp@(PP ns q) pn) = go
     qSetup :: Component -> Bool
     qSetup comp = qoSetupIndependent && comp == ComponentSetup
 
+unqualifyDeps :: FlaggedDeps comp QPN -> FlaggedDeps comp PN
+unqualifyDeps = go
+  where
+    go :: FlaggedDeps comp QPN -> FlaggedDeps comp PN
+    go = map go1
+
+    go1 :: FlaggedDep comp QPN -> FlaggedDep comp PN
+    go1 (Flagged fn nfo t f) = Flagged (fmap unq fn) nfo (go t) (go f)
+    go1 (Stanza  sn     t)   = Stanza  (fmap unq sn)     (go t)
+    go1 (Simple dep comp)    = Simple (goD dep) comp
+
+    goD :: Dep QPN -> Dep PN
+    goD (Dep qpn ci) = Dep (unq qpn) (fmap unq ci)
+    goD (Ext  ext)   = Ext ext
+    goD (Lang lang)  = Lang lang
+    goD (Pkg pn vr)  = Pkg pn vr
+
+    unq :: QPN -> PN
+    unq (Q _ pn) = pn
+
 {-------------------------------------------------------------------------------
   Setting/forgetting the Component
 -------------------------------------------------------------------------------}

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

@@ -199,7 +199,7 @@ conflict = lift' . Left
 execUpdateState :: UpdateState () -> ValidateState -> Either Conflict ValidateState
 execUpdateState = execStateT . unUpdateState
 
-pickPOption :: QPN -> POption -> FlaggedDeps comp QPN -> UpdateState ()
+pickPOption :: QPN -> POption -> FlaggedDeps Component QPN -> UpdateState ()
 pickPOption qpn (POption i Nothing)    _deps = pickConcrete qpn i
 pickPOption qpn (POption i (Just pp'))  deps = pickLink     qpn i pp' deps
 
@@ -217,7 +217,7 @@ pickConcrete qpn@(Q pp _) i = do
       Just lg ->
         makeCanonical lg qpn i
 
-pickLink :: QPN -> I -> PP -> FlaggedDeps comp QPN -> UpdateState ()
+pickLink :: QPN -> I -> PP -> FlaggedDeps Component QPN -> UpdateState ()
 pickLink qpn@(Q pp pn) i pp' deps = do
     vs <- get
     -- Find the link group for the package we are linking to, and add this package
@@ -226,7 +226,8 @@ pickLink qpn@(Q pp pn) i pp' deps = do
     -- concrete instance for that package, and since we create singleton link
     -- groups for concrete instances, this link group must exist (and must
     -- in fact already have a canonical member).
-    let lg = vsLinks vs ! Q pp' pn
+    let target = Q pp' pn
+        lg     = vsLinks vs ! target
 
     -- Verify here that the member we add is in fact for the same package and
     -- matches the version of the canonical instance. However, violations of
@@ -240,7 +241,7 @@ pickLink qpn@(Q pp pn) i pp' deps = do
     -- member into the group
     let lg' = lg { lgMembers = S.insert pp (lgMembers lg) }
     updateLinkGroup lg'
-    linkDeps [P qpn] pp' deps
+    linkDeps target [P qpn] deps
 
 makeCanonical :: LinkGroup -> QPN -> I -> UpdateState ()
 makeCanonical lg qpn@(Q pp _) i =
@@ -264,35 +265,45 @@ makeCanonical lg qpn@(Q pp _) i =
 -- because having the direct dependencies in a link group means that we must
 -- have already made or will make sooner or later a link choice for one of these
 -- as well, and cover their dependencies at that point.
-linkDeps :: [Var QPN] -> PP -> FlaggedDeps comp QPN -> UpdateState ()
-linkDeps parents pp' = mapM_ go
+linkDeps :: QPN -> [Var QPN] -> FlaggedDeps Component QPN -> UpdateState ()
+linkDeps parent = \parents deps -> do
+    rdeps <- requalify deps
+    go parents deps rdeps
   where
-    go :: FlaggedDep comp QPN -> UpdateState ()
-    go (Simple (Dep qpn@(Q _ pn) _) _) = do
-      vs <- get
-      let qpn' = Q pp' pn
-          lg   = M.findWithDefault (lgSingleton qpn  Nothing) qpn  $ vsLinks vs
-          lg'  = M.findWithDefault (lgSingleton qpn' Nothing) qpn' $ vsLinks vs
-      lg'' <- lift' $ lgMerge parents lg lg'
-      updateLinkGroup lg''
+    go :: [Var QPN] -> FlaggedDeps Component QPN -> FlaggedDeps Component QPN -> UpdateState ()
+    go parents deps rdeps = mapM_ (uncurry (go1 parents)) $ zip deps rdeps
+
+    go1 :: [Var QPN] -> FlaggedDep Component QPN -> FlaggedDep Component QPN -> UpdateState ()
+    go1 parents dep rdep = case (dep, rdep) of
+      (Simple (Dep qpn _) _, ~(Simple (Dep qpn' _) _)) -> do
+        vs <- get
+        let lg   = M.findWithDefault (lgSingleton qpn  Nothing) qpn  $ vsLinks vs
+            lg'  = M.findWithDefault (lgSingleton qpn' Nothing) qpn' $ vsLinks vs
+        lg'' <- lift' $ lgMerge parents lg lg'
+        updateLinkGroup lg''
+      (Flagged fn _ t f, ~(Flagged _ _ t' f')) -> do
+        vs <- get
+        case M.lookup fn (vsFlags vs) of
+          Nothing    -> return () -- flag assignment not yet known
+          Just True  -> go (F fn:parents) t t'
+          Just False -> go (F fn:parents) f f'
+      (Stanza sn t, ~(Stanza _ t')) -> do
+        vs <- get
+        case M.lookup sn (vsStanzas vs) of
+          Nothing    -> return () -- stanza assignment not yet known
+          Just True  -> go (S sn:parents) t t'
+          Just False -> return () -- stanza not enabled; no new deps
     -- For extensions and language dependencies, there is nothing to do.
     -- No choice is involved, just checking, so there is nothing to link.
-    go (Simple (Ext  _)             _) = return ()
-    go (Simple (Lang _)             _) = return ()
-    -- Similarly for pkg-config constraints
-    go (Simple (Pkg  _ _)           _) = return ()
-    go (Flagged fn _ t f) = do
-      vs <- get
-      case M.lookup fn (vsFlags vs) of
-        Nothing    -> return () -- flag assignment not yet known
-        Just True  -> linkDeps (F fn:parents) pp' t
-        Just False -> linkDeps (F fn:parents) pp' f
-    go (Stanza sn t) = do
+    -- The same goes for for pkg-config constraints.
+      (Simple (Ext  _)   _, _) -> return ()
+      (Simple (Lang _)   _, _) -> return ()
+      (Simple (Pkg  _ _) _, _) -> return ()
+
+    requalify :: FlaggedDeps Component QPN -> UpdateState (FlaggedDeps Component QPN)
+    requalify deps = do
       vs <- get
-      case M.lookup sn (vsStanzas vs) of
-        Nothing    -> return () -- stanza assignment not yet known
-        Just True  -> linkDeps (S sn:parents) pp' t
-        Just False -> return () -- stanza not enabled; no new deps
+      return $ qualifyDeps (vsQualifyOptions vs) parent (unqualifyDeps deps)
 
 pickFlag :: QFN -> Bool -> UpdateState ()
 pickFlag qfn b = do
@@ -322,7 +333,7 @@ linkNewDeps var b = do
         lg                      = vsLinks vs ! qpn
         (parents, newDeps)      = findNewDeps vs qdeps
         linkedTo                = S.delete pp (lgMembers lg)
-    forM_ (S.toList linkedTo) $ \pp' -> linkDeps (P qpn : parents) pp' newDeps
+    forM_ (S.toList linkedTo) $ \pp' -> linkDeps (Q pp' pn) (P qpn : parents) newDeps
   where
     findNewDeps :: ValidateState -> FlaggedDeps comp QPN -> ([Var QPN], FlaggedDeps Component QPN)
     findNewDeps vs = concatMapUnzip (findNewDeps' vs)

cabal-install/cabal-install.cabal

@@ -335,6 +335,7 @@ Test-Suite unit-tests
         random,
         hackage-security,
         tasty,
+        tasty-expected-failure,
         tasty-hunit,
         tasty-quickcheck,
         tagged,

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

@@ -11,6 +11,7 @@ import qualified Distribution.Version as V
 
 -- test-framework
 import Test.Tasty as TF
+import Test.Tasty.ExpectedFailure (expectFail)
 import Test.Tasty.HUnit (testCase, assertEqual, assertBool)
 
 -- Cabal
@@ -44,6 +45,7 @@ tests = [
         , runTest $         mkTest db3 "forceFlagOff" ["D"]      (Just [("A", 2), ("B", 1), ("D", 1)])
         , runTest $ indep $ mkTest db3 "linkFlags1"   ["C", "D"] Nothing
         , runTest $ indep $ mkTest db4 "linkFlags2"   ["C", "D"] Nothing
+        , runTest $ indep $ mkTest db18 "linkFlags3"  ["A", "B"] (Just [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2), ("F", 1)])
         ]
     , testGroup "Stanzas" [
           runTest $         mkTest db5 "simpleTest1" ["C"]      (Just [("A", 2), ("C", 1)])
@@ -57,14 +59,15 @@ tests = [
         , runTest $ indep $ mkTest db6 "depsWithTests2" ["C", "D"] (Just [("A", 1), ("B", 1), ("C", 1), ("D", 1)])
         ]
     , testGroup "Setup dependencies" [
-          runTest $ mkTest db7  "setupDeps1" ["B"] (Just [("A", 2), ("B", 1)])
-        , runTest $ mkTest db7  "setupDeps2" ["C"] (Just [("A", 2), ("C", 1)])
-        , runTest $ mkTest db7  "setupDeps3" ["D"] (Just [("A", 1), ("D", 1)])
-        , runTest $ mkTest db7  "setupDeps4" ["E"] (Just [("A", 1), ("A", 2), ("E", 1)])
-        , runTest $ mkTest db7  "setupDeps5" ["F"] (Just [("A", 1), ("A", 2), ("F", 1)])
-        , runTest $ mkTest db8  "setupDeps6" ["C", "D"] (Just [("A", 1), ("B", 1), ("B", 2), ("C", 1), ("D", 1)])
-        , runTest $ mkTest db9  "setupDeps7" ["F", "G"] (Just [("A", 1), ("B", 1), ("B",2 ), ("C", 1), ("D", 1), ("E", 1), ("E", 2), ("F", 1), ("G", 1)])
-        , runTest $ mkTest db10 "setupDeps8" ["C"] (Just [("C", 1)])
+          runTest $         mkTest db7  "setupDeps1" ["B"] (Just [("A", 2), ("B", 1)])
+        , runTest $         mkTest db7  "setupDeps2" ["C"] (Just [("A", 2), ("C", 1)])
+        , runTest $         mkTest db7  "setupDeps3" ["D"] (Just [("A", 1), ("D", 1)])
+        , runTest $         mkTest db7  "setupDeps4" ["E"] (Just [("A", 1), ("A", 2), ("E", 1)])
+        , runTest $         mkTest db7  "setupDeps5" ["F"] (Just [("A", 1), ("A", 2), ("F", 1)])
+        , runTest $         mkTest db8  "setupDeps6" ["C", "D"] (Just [("A", 1), ("B", 1), ("B", 2), ("C", 1), ("D", 1)])
+        , runTest $         mkTest db9  "setupDeps7" ["F", "G"] (Just [("A", 1), ("B", 1), ("B",2 ), ("C", 1), ("D", 1), ("E", 1), ("E", 2), ("F", 1), ("G", 1)])
+        , runTest $         mkTest db10 "setupDeps8" ["C"] (Just [("C", 1)])
+        , runTest $ indep $ mkTest dbSetupDeps "setupDeps9" ["A", "B"] (Just [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2)])
         ]
     , testGroup "Base shim" [
           runTest $ mkTest db11 "baseShim1" ["A"] (Just [("A", 1)])
@@ -126,7 +129,10 @@ tests = [
         , runTest $ mkTestPCDepends [("pkgA", "1.0.0"), ("pkgB", "2.0.0")] dbPC1 "chooseNewest" ["C"] (Just [("A", 1), ("B", 2), ("C", 1)])
         ]
     , testGroup "Independent goals" [
-          runTest $ indep $ mkTest db16 "indepGoals" ["A", "B"] (Just [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2), ("E", 1)])
+          runTest $ indep $ mkTest db16 "indepGoals1" ["A", "B"] (Just [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2), ("E", 1)])
+        , runTest $ indep $ mkTest db17 "indepGoals2" ["A", "B"] (Just [("A", 1), ("B", 1), ("C", 1), ("D", 1)])
+        , expectFail $
+          runTest $ indep $ mkTest db19 "indepGoals3" ["D", "E", "F"] Nothing -- The target order is important.
         ]
     ]
   where
@@ -428,6 +434,24 @@ db10 =
     , Right $ exAv "C" 1 [ExFix "A" 2] `withSetupDeps` [ExFix "A" 1]
     ]
 
+-- | This database tests that a package's setup dependencies are correctly
+-- linked when the package is linked. See pull request #3268.
+--
+-- When A and B are installed as independent goals, their dependencies on C must
+-- be linked, due to the single instance restriction. Since C depends on D, 0.D
+-- and 1.D must be linked. C also has a setup dependency on D, so 0.C-setup.D
+-- and 1.C-setup.D must be linked. However, D's two link groups must remain
+-- independent. The solver should be able to choose D-1 for C's library and D-2
+-- for C's setup script.
+dbSetupDeps :: ExampleDb
+dbSetupDeps = [
+    Right $ exAv "A" 1 [ExAny "C"]
+  , Right $ exAv "B" 1 [ExAny "C"]
+  , Right $ exAv "C" 1 [ExFix "D" 1] `withSetupDeps` [ExFix "D" 2]
+  , Right $ exAv "D" 1 []
+  , Right $ exAv "D" 2 []
+  ]
+
 -- | Tests for dealing with base shims
 db11 :: ExampleDb
 db11 =
@@ -510,10 +534,23 @@ db15 = [
   , Right $ exAv   "E" 1            [ExFix "C" 2]
   ]
 
--- | When A and B are installed as independent goals, the single instance
+-- | Check that the solver can backtrack after encountering the SIR (issue #2843)
+--
+-- When A and B are installed as independent goals, the single instance
 -- restriction prevents B from depending on C.  This database tests that the
 -- solver can backtrack after encountering the single instance restriction and
--- choose the only valid flag assignment (-flagA +flagB).
+-- choose the only valid flag assignment (-flagA +flagB):
+--
+-- > flagA flagB  B depends on
+-- >  On    _     C-*
+-- >  Off   On    E-*               <-- only valid flag assignment
+-- >  Off   Off   D-2.0, C-*
+--
+-- Since A depends on C-* and D-1.0, and C-1.0 depends on any version of D,
+-- we must build C-1.0 against D-1.0. Since B depends on D-2.0, we cannot have
+-- C in the transitive closure of B's dependencies, because that would mean we
+-- would need two instances of C: one built against D-1.0 and one built against
+-- D-2.0.
 db16 :: ExampleDb
 db16 = [
     Right $ exAv "A" 1 [ExAny "C", ExFix "D" 1]
@@ -529,6 +566,91 @@ db16 = [
   , Right $ exAv "E" 1 []
   ]
 
+-- | This database checks that when the solver discovers a constraint on a
+-- package's version after choosing to link that package, it can backtrack to
+-- try alternative versions for the linked-to package. See pull request #3327.
+--
+-- When A and B are installed as independent goals, their dependencies on C
+-- must be linked. Since C depends on D, A and B's dependencies on D must also
+-- be linked. This test relies on the fact that the solver chooses D-2 for both
+-- 0.D and 1.D before it encounters the test suites' constraints. The solver
+-- must backtrack to try D-1 for both 0.D and 1.D.
+db17 :: ExampleDb
+db17 = [
+    Right $ exAv "A" 1 [ExAny "C"] `withTest` ExTest "test" [ExFix "D" 1]
+  , Right $ exAv "B" 1 [ExAny "C"] `withTest` ExTest "test" [ExFix "D" 1]
+  , Right $ exAv "C" 1 [ExAny "D"]
+  , Right $ exAv "D" 1 []
+  , Right $ exAv "D" 2 []
+  ]
+
+-- | Issue #2834
+-- When both A and B are installed as independent goals, their dependencies on
+-- C must be linked. The only combination of C's flags that is consistent with
+-- A and B's dependencies on D is -flagA +flagB. This database tests that the
+-- solver can backtrack to find the right combination of flags (requiring F, but
+-- not E or G) and apply it to both 0.C and 1.C.
+--
+-- > flagA flagB  C depends on
+-- >  On    _     D-1, E-*
+-- >  Off   On    F-*        <-- Only valid choice
+-- >  Off   Off   D-2, G-*
+--
+-- The single instance restriction means we cannot have one instance of C
+-- built against D-1 and one instance built against D-2; since A depends on
+-- D-1, and B depends on C-2, it is therefore important that C cannot depend
+-- on any version of D.
+db18 :: ExampleDb
+db18 = [
+    Right $ exAv "A" 1 [ExAny "C", ExFix "D" 1]
+  , Right $ exAv "B" 1 [ExAny "C", ExFix "D" 2]
+  , Right $ exAv "C" 1 [exFlag "flagA"
+                           [ExFix "D" 1, ExAny "E"]
+                           [exFlag "flagB"
+                               [ExAny "F"]
+                               [ExFix "D" 2, ExAny "G"]]]
+  , Right $ exAv "D" 1 []
+  , Right $ exAv "D" 2 []
+  , Right $ exAv "E" 1 []
+  , Right $ exAv "F" 1 []
+  , Right $ exAv "G" 1 []
+  ]
+
+-- | Tricky test case with independent goals (issue #2842)
+--
+-- Suppose we are installing D, E, and F as independent goals:
+--
+-- * D depends on A-* and C-1, requiring A-1 to be built against C-1
+-- * E depends on B-* and C-2, requiring B-1 to be built against C-2
+-- * F depends on A-* and B-*; this means we need A-1 and B-1 both to be built
+--     against the same version of C, violating the single instance restriction.
+--
+-- We can visualize this DB as:
+--
+-- >    C-1   C-2
+-- >    /|\   /|\
+-- >   / | \ / | \
+-- >  /  |  X  |  \
+-- > |   | / \ |   |
+-- > |   |/   \|   |
+-- > |   +     +   |
+-- > |   |     |   |
+-- > |   A     B   |
+-- >  \  |\   /|  /
+-- >   \ | \ / | /
+-- >    \|  V  |/
+-- >     D  F  E
+db19 :: ExampleDb
+db19 = [
+    Right $ exAv "A" 1 [ExAny "C"]
+  , Right $ exAv "B" 1 [ExAny "C"]
+  , Right $ exAv "C" 1 []
+  , Right $ exAv "C" 2 []
+  , Right $ exAv "D" 1 [ExAny "A", ExFix "C" 1]
+  , Right $ exAv "E" 1 [ExAny "B", ExFix "C" 2]
+  , Right $ exAv "F" 1 [ExAny "A", ExAny "B"]
+  ]
+
 dbExts1 :: ExampleDb
 dbExts1 = [
     Right $ exAv "A" 1 [ExExt (EnableExtension RankNTypes)]

travis-script.sh

@@ -75,7 +75,7 @@ install_from_tarball
 cd ../cabal-install
 
 cabal install happy
-cabal install --only-dependencies --enable-tests --enable-benchmarks
+cabal install --only-dependencies --enable-tests --enable-benchmarks --allow-newer=tasty-expected-failure:base
 cabal configure \
     --user --ghc-option=-Werror --enable-tests --enable-benchmarks \
     -v2 # -v2 provides useful information for debugging