From 4d1470f3af3c872b0a4558cbad06dbd7bd37b433 Mon Sep 17 00:00:00 2001
From: Kristen Kozak <grayjay@wordroute.com>
Date: Fri, 12 Jan 2018 23:49:17 -0800
Subject: [PATCH] Solver: Detect cycles between packages and their setup
 scripts (fixes #4161).

The solver already detected cycles involving more than one package, but it
allowed dependencies between components within a package.  This commit treats a
dependency between a package's setup script and library as a cycle in order to
allow the solver to backtrack and try to break the cycle.
---
 .../Distribution/Solver/Modular/Builder.hs    | 12 +++++++--
 .../Distribution/Solver/Modular/Solver.hs     | 25 +++++++++++++++++++
 2 files changed, 35 insertions(+), 2 deletions(-)

diff --git a/cabal-install/Distribution/Solver/Modular/Builder.hs b/cabal-install/Distribution/Solver/Modular/Builder.hs
index 4c530a40a0e..d60fa49e47d 100644
--- a/cabal-install/Distribution/Solver/Modular/Builder.hs
+++ b/cabal-install/Distribution/Solver/Modular/Builder.hs
@@ -32,6 +32,7 @@ import qualified Distribution.Solver.Modular.PSQ as P
 import Distribution.Solver.Modular.Tree
 import qualified Distribution.Solver.Modular.WeightedPSQ as W
 
+import Distribution.Solver.Types.ComponentDeps
 import Distribution.Solver.Types.PackagePath
 import Distribution.Solver.Types.Settings
 
@@ -72,8 +73,15 @@ extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs
     go g o ((Stanza sn@(SN qpn _) t)           : ngs) =
         go g (StanzaGoal sn t (flagGR qpn) : o) ngs
     go g o ((Simple (LDep dr (Dep _ qpn _)) c) : ngs)
-      | qpn == qpn'       = go                            g               o  ngs
-          -- we ignore self-dependencies at this point; TODO: more care may be needed
+      | qpn == qpn'       =
+            -- We currently only add a self-dependency to the graph if it is
+            -- between a package and its setup script. The edge creates a cycle
+            -- and causes the solver to backtrack and choose a different
+            -- instance for the setup script. We may need to track other
+            -- self-dependencies once we implement component-based solving.
+          case c of
+            ComponentSetup -> go (M.adjust (addIfAbsent (ComponentSetup, qpn')) qpn g) o ngs
+            _              -> go                                                    g  o ngs
       | qpn `M.member` g  = go (M.adjust (addIfAbsent (c, qpn')) qpn g)   o  ngs
       | otherwise         = go (M.insert qpn [(c, qpn')]  g) (PkgGoal qpn (DependencyGoal dr) : o) ngs
           -- code above is correct; insert/adjust have different arg order
diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs
index 23e0b11f455..def3525b5d7 100644
--- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs
@@ -159,6 +159,7 @@ tests = [
         , runTest $ mkTest db15 "cycleThroughSetupDep3" ["C"]      (solverSuccess [("C", 2), ("D", 1)])
         , runTest $ mkTest db15 "cycleThroughSetupDep4" ["D"]      (solverSuccess [("D", 1)])
         , runTest $ mkTest db15 "cycleThroughSetupDep5" ["E"]      (solverSuccess [("C", 2), ("D", 1), ("E", 1)])
+        , runTest $ issue4161 "detect cycle between package and its setup script"
         , runTest $ testCyclicDependencyErrorMessages "cyclic dependency error messages"
         ]
     , testGroup "Extensions" [
@@ -783,6 +784,30 @@ db15 = [
   , Right $ exAv   "E" 1            [ExFix "C" 2]
   ]
 
+-- | Detect a cycle between a package and its setup script.
+--
+-- This type of cycle can easily occur when new-build adds default setup
+-- dependencies to packages without custom-setup stanzas. For example, cabal
+-- adds 'time' as a setup dependency for 'time'. The solver should detect the
+-- cycle when it attempts to link the setup and non-setup instances of the
+-- package and then choose a different version for the setup dependency.
+issue4161 :: String -> SolverTest
+issue4161 name =
+    mkTest db name ["target"] $
+    SolverResult checkFullLog $ Right [("target", 1), ("time", 2)]
+  where
+    db :: ExampleDb
+    db = [
+        Right $ exAv   "target" 1               [ExFix "time" 2]
+      , Right $ exAv   "time"   2               [] `withSetupDeps` [ExAny "time"]
+      , Left  $ exInst "time"   1 "time-2-inst" []
+      ]
+
+    checkFullLog :: [String] -> Bool
+    checkFullLog = any $ isInfixOf $
+        "rejecting: time:setup.time~>time-2.0.0 (cyclic dependencies; "
+                ++ "conflict set: time:setup.time)"
+
 -- | Packages pkg-A, pkg-B, and pkg-C form a cycle. The solver should backtrack
 -- as soon as it chooses the last package in the cycle, to avoid searching parts
 -- of the tree that have no solution. Since there is no way to break the cycle,