From 4053927d4ddb9b6cf26bd68db9067b308258eb51 Mon Sep 17 00:00:00 2001
From: Duncan Coutts <duncan@community.haskell.org>
Date: Fri, 29 Aug 2014 14:50:51 +0100
Subject: [PATCH 01/28] Remove the solver's scope and encapsulation mechanism

It turns out not to be the right solution for general private
dependencies and is just complicated. However we keep qualified
goals, just much simpler. Now dependencies simply inherit the
qualification of their parent goal. This gets us closer to the
intended behaviour for the --independent-goals feature, and for
the simpler case of private dependencies for setup scripts.

When not using --independent-goals, the solver behaves exactly as
before (tested by comparing solver logs for a hard hackage goal).
When using --independent-goals, now every dep of each independent
goal is qualified, so the dependencies are solved completely
independently (which is actually too much still).
---
 .../Client/Dependency/Modular/Builder.hs      | 47 +++++++------------
 .../Client/Dependency/Modular/Index.hs        |  7 +--
 .../Dependency/Modular/IndexConversion.hs     |  9 ++--
 .../Client/Dependency/Modular/Package.hs      | 16 ++-----
 .../Client/Dependency/Modular/Preference.hs   | 16 +++----
 .../Client/Dependency/Modular/Validate.hs     | 22 ++++-----
 6 files changed, 45 insertions(+), 72 deletions(-)

diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs b/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs
index 38fbf71858f..50cb570548c 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs
@@ -1,4 +1,4 @@
-module Distribution.Client.Dependency.Modular.Builder where
+module Distribution.Client.Dependency.Modular.Builder (buildTree) where
 
 -- Building the search tree.
 --
@@ -30,7 +30,6 @@ import Distribution.Client.Dependency.Modular.Tree
 -- | The state needed during the build phase of the search tree.
 data BuildState = BS {
   index :: Index,           -- ^ information about packages and their dependencies
-  scope :: Scope,           -- ^ information about encapsulations
   rdeps :: RevDepMap,       -- ^ set of all package goals, completed and open, with reverse dependencies
   open  :: PSQ OpenGoal (), -- ^ set of still open goals (flag and package goals)
   next  :: BuildType        -- ^ kind of node to generate next
@@ -57,23 +56,14 @@ extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs
       | otherwise                                         = go (M.insert qpn [qpn']  g) (cons ng () o) ngs
                                        -- code above is correct; insert/adjust have different arg order
 
--- | Update the current scope by taking into account the encapsulations that
--- are defined for the current package.
-establishScope :: QPN -> Encaps -> BuildState -> BuildState
-establishScope (Q pp pn) ecs s =
-    s { scope = L.foldl (\ m e -> M.insert e pp' m) (scope s) ecs }
-  where
-    pp' = pn : pp -- new path
-
 -- | Given the current scope, qualify all the package names in the given set of
 -- dependencies and then extend the set of open goals accordingly.
 scopedExtendOpen :: QPN -> I -> QGoalReasonChain -> FlaggedDeps PN -> FlagInfo ->
                     BuildState -> BuildState
-scopedExtendOpen qpn i gr fdeps fdefs s = extendOpen qpn gs s
+scopedExtendOpen qpn@(Q pp _pn) i gr fdeps fdefs s = extendOpen qpn gs s
   where
-    sc     = scope s
     -- Qualify all package names
-    qfdeps = L.map (fmap (qualify sc)) fdeps -- qualify all the package names
+    qfdeps = L.map (fmap (Q pp)) fdeps -- qualify all the package names
     -- Introduce all package flags
     qfdefs = L.map (\ (fn, b) -> Flagged (FN (PI qpn i) fn) b [] []) $ M.toList fdefs
     -- Combine new package and flag goals
@@ -101,10 +91,10 @@ data BuildType =
   | Instance QPN I PInfo QGoalReasonChain  -- ^ build a tree for a concrete instance
   deriving Show
 
-build :: BuildState -> Tree (QGoalReasonChain, Scope)
+build :: BuildState -> Tree QGoalReasonChain
 build = ana go
   where
-    go :: BuildState -> TreeF (QGoalReasonChain, Scope) BuildState
+    go :: BuildState -> TreeF QGoalReasonChain BuildState
 
     -- If we have a choice between many goals, we just record the choice in
     -- the tree. We select each open goal in turn, and before we descend, remove
@@ -119,10 +109,10 @@ build = ana go
     --
     -- For a package, we look up the instances available in the global info,
     -- and then handle each instance in turn.
-    go bs@(BS { index = idx, scope = sc, next = OneGoal (OpenGoal (Simple (Dep qpn@(Q _ pn) _)) gr) }) =
+    go bs@(BS { index = idx, next = OneGoal (OpenGoal (Simple (Dep qpn@(Q _ pn) _)) gr) }) =
       case M.lookup pn idx of
         Nothing  -> FailF (toConflictSet (Goal (P qpn) gr)) (BuildFailureNotInIndex pn)
-        Just pis -> PChoiceF qpn (gr, sc) (P.fromList (L.map (\ (i, info) ->
+        Just pis -> PChoiceF qpn gr (P.fromList (L.map (\ (i, info) ->
                                                            (i, bs { next = Instance qpn i info gr }))
                                                          (M.toList pis)))
           -- TODO: data structure conversion is rather ugly here
@@ -131,8 +121,8 @@ build = ana go
     -- that is indicated by the flag default.
     --
     -- TODO: Should we include the flag default in the tree?
-    go bs@(BS { scope = sc, next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) (FInfo b m w) t f) gr) }) =
-      FChoiceF qfn (gr, sc) (w || trivial) m (P.fromList (reorder b
+    go bs@(BS { next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) (FInfo b m w) t f) gr) }) =
+      FChoiceF qfn gr (w || trivial) m (P.fromList (reorder b
         [(True,  (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn True  : gr)) t) bs) { next = Goals }),
          (False, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn False : gr)) f) bs) { next = Goals })]))
       where
@@ -140,8 +130,8 @@ build = ana go
         reorder False = reverse
         trivial = L.null t && L.null f
 
-    go bs@(BS { scope = sc, next = OneGoal (OpenGoal (Stanza qsn@(SN (PI qpn _) _) t) gr) }) =
-      SChoiceF qsn (gr, sc) trivial (P.fromList
+    go bs@(BS { next = OneGoal (OpenGoal (Stanza qsn@(SN (PI qpn _) _) t) gr) }) =
+      SChoiceF qsn gr trivial (P.fromList
         [(False,                                                                        bs  { next = Goals }),
          (True,  (extendOpen qpn (L.map (flip OpenGoal (SDependency qsn : gr)) t) bs) { next = Goals })])
       where
@@ -151,20 +141,17 @@ build = ana go
     -- and furthermore we update the set of goals.
     --
     -- TODO: We could inline this above.
-    go bs@(BS { next = Instance qpn i (PInfo fdeps fdefs ecs _) gr }) =
-      go ((establishScope qpn ecs
-             (scopedExtendOpen qpn i (PDependency (PI qpn i) : gr) fdeps fdefs bs))
+    go bs@(BS { next = Instance qpn i (PInfo fdeps fdefs _) gr }) =
+      go ((scopedExtendOpen qpn i (PDependency (PI qpn i) : gr) fdeps fdefs bs)
              { next = Goals })
 
 -- | Interface to the tree builder. Just takes an index and a list of package names,
 -- and computes the initial state and then the tree from there.
-buildTree :: Index -> Bool -> [PN] -> Tree (QGoalReasonChain, Scope)
+buildTree :: Index -> Bool -> [PN] -> Tree QGoalReasonChain
 buildTree idx ind igs =
-    build (BS idx sc
-                  (M.fromList (L.map (\ qpn -> (qpn, []))                                                     qpns))
+    build (BS idx (M.fromList (L.map (\ qpn -> (qpn, []))                                                     qpns))
                   (P.fromList (L.map (\ qpn -> (OpenGoal (Simple (Dep qpn (Constrained []))) [UserGoal], ())) qpns))
                   Goals)
   where
-    sc | ind       = makeIndependent igs
-       | otherwise = emptyScope
-    qpns           = L.map (qualify sc) igs
+    qpns | ind       = makeIndependent igs
+         | otherwise = L.map (Q []) igs
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Index.hs b/cabal-install/Distribution/Client/Dependency/Modular/Index.hs
index d01cdb61fa1..ac3450379a7 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Index.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Index.hs
@@ -15,17 +15,14 @@ import Distribution.Client.Dependency.Modular.Tree
 type Index = Map PN (Map I PInfo)
 
 -- | Info associated with a package instance.
--- Currently, dependencies, flags, encapsulations and failure reasons.
+-- Currently, dependencies, flags and failure reasons.
 -- Packages that have a failure reason recorded for them are disabled
 -- globally, for reasons external to the solver. We currently use this
 -- for shadowing which essentially is a GHC limitation, and for
 -- installed packages that are broken.
-data PInfo = PInfo (FlaggedDeps PN) FlagInfo Encaps (Maybe FailReason)
+data PInfo = PInfo (FlaggedDeps PN) FlagInfo (Maybe FailReason)
   deriving (Show)
 
--- | Encapsulations. A list of package names.
-type Encaps = [PN]
-
 mkIndex :: [(PN, I, PInfo)] -> Index
 mkIndex xs = M.map M.fromList (groupMap (L.map (\ (pn, i, pi) -> (pn, (i, pi))) xs))
 
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs b/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs
index cd31868fdfe..53b5a46a4db 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs
@@ -49,8 +49,8 @@ convIPI' sip idx =
   where
 
     -- shadowing is recorded in the package info
-    shadow (pn, i, PInfo fdeps fds encs _) | sip = (pn, i, PInfo fdeps fds encs (Just Shadowed))
-    shadow x                                     = x
+    shadow (pn, i, PInfo fdeps fds _) | sip = (pn, i, PInfo fdeps fds (Just Shadowed))
+    shadow x                                = x
 
 convIPI :: Bool -> SI.InstalledPackageIndex -> Index
 convIPI sip = mkIndex . convIPI' sip
@@ -62,8 +62,8 @@ convIP idx ipi =
       i = I (pkgVersion (sourcePackageId ipi)) (Inst ipid)
       pn = pkgName (sourcePackageId ipi)
   in  case mapM (convIPId pn idx) (IPI.depends ipi) of
-        Nothing  -> (pn, i, PInfo [] M.empty [] (Just Broken))
-        Just fds -> (pn, i, PInfo fds M.empty [] Nothing)
+        Nothing  -> (pn, i, PInfo []  M.empty (Just Broken))
+        Just fds -> (pn, i, PInfo fds M.empty Nothing)
 -- TODO: Installed packages should also store their encapsulations!
 
 -- | Convert dependencies specified by an installed package id into
@@ -119,7 +119,6 @@ convGPD os arch comp strfl pi
       prefix (Stanza (SN pi BenchStanzas))
         (L.map     (convCondTree os arch comp pi fds (const True)     . snd) benchs))
       fds
-      [] -- TODO: add encaps
       Nothing
 
 prefix :: (FlaggedDeps qpn -> FlaggedDep qpn) -> [FlaggedDeps qpn] -> FlaggedDeps qpn
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Package.hs b/cabal-install/Distribution/Client/Dependency/Modular/Package.hs
index 5f81c6868cb..a654f012318 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Package.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Package.hs
@@ -4,7 +4,6 @@ module Distribution.Client.Dependency.Modular.Package
    module Distribution.Package) where
 
 import Data.List as L
-import Data.Map as M
 
 import Distribution.Package -- from Cabal
 import Distribution.Text    -- from Cabal
@@ -91,21 +90,12 @@ type QPN = Q PN
 showQPN :: QPN -> String
 showQPN = showQ display
 
--- | The scope associates every package with a path. The convention is that packages
--- not in the data structure have an empty path associated with them.
-type Scope = Map PN PP
-
--- | An empty scope structure, for initialization.
-emptyScope :: Scope
-emptyScope = M.empty
-
 -- | Create artificial parents for each of the package names, making
 -- them all independent.
-makeIndependent :: [PN] -> Scope
-makeIndependent ps = L.foldl (\ sc (n, p) -> M.insert p [PackageName (show n)] sc) emptyScope (zip ([0..] :: [Int]) ps)
+makeIndependent :: [PN] -> [QPN]
+makeIndependent ps = [ Q pp pn | (pn, i) <- zip ps [0::Int ..]
+                               , let pp = [PackageName (show i)] ]
 
-qualify :: Scope -> PN -> QPN
-qualify sc pn = Q (findWithDefault [] pn sc) pn
 
 unQualify :: Q a -> a
 unQualify (Q _ x) = x
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs b/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
index 005eeb1eccb..64b10ae9b7b 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
@@ -166,12 +166,12 @@ preferLatest :: Tree a -> Tree a
 preferLatest = preferLatestFor (const True)
 
 -- | Require installed packages.
-requireInstalled :: (PN -> Bool) -> Tree (QGoalReasonChain, a) -> Tree (QGoalReasonChain, a)
+requireInstalled :: (PN -> Bool) -> Tree QGoalReasonChain -> Tree QGoalReasonChain
 requireInstalled p = trav go
   where
-    go (PChoiceF v@(Q _ pn) i@(gr, _) cs)
-      | p pn      = PChoiceF v i (P.mapWithKey installed cs)
-      | otherwise = PChoiceF v i                         cs
+    go (PChoiceF v@(Q _ pn) gr cs)
+      | p pn      = PChoiceF v gr (P.mapWithKey installed cs)
+      | otherwise = PChoiceF v gr                         cs
       where
         installed (I _ (Inst _)) x = x
         installed _              _ = Fail (toConflictSet (Goal (P v) gr)) CannotInstall
@@ -190,12 +190,12 @@ requireInstalled p = trav go
 -- they are, perhaps this should just result in trying to reinstall those other
 -- packages as well. However, doing this all neatly in one pass would require to
 -- change the builder, or at least to change the goal set after building.
-avoidReinstalls :: (PN -> Bool) -> Tree (QGoalReasonChain, a) -> Tree (QGoalReasonChain, a)
+avoidReinstalls :: (PN -> Bool) -> Tree QGoalReasonChain -> Tree QGoalReasonChain
 avoidReinstalls p = trav go
   where
-    go (PChoiceF qpn@(Q _ pn) i@(gr, _) cs)
-      | p pn      = PChoiceF qpn i disableReinstalls
-      | otherwise = PChoiceF qpn i cs
+    go (PChoiceF qpn@(Q _ pn) gr cs)
+      | p pn      = PChoiceF qpn gr disableReinstalls
+      | otherwise = PChoiceF qpn gr cs
       where
         disableReinstalls =
           let installed = [ v | (I v (Inst _), _) <- toList cs ]
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs b/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs
index 16c8cf55370..8b8d380e386 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs
@@ -1,4 +1,4 @@
-module Distribution.Client.Dependency.Modular.Validate where
+module Distribution.Client.Dependency.Modular.Validate (validateTree) where
 
 -- Validation of the tree.
 --
@@ -80,13 +80,13 @@ data ValidateState = VS {
 
 type Validate = Reader ValidateState
 
-validate :: Tree (QGoalReasonChain, Scope) -> Validate (Tree QGoalReasonChain)
+validate :: Tree QGoalReasonChain -> Validate (Tree QGoalReasonChain)
 validate = cata go
   where
-    go :: TreeF (QGoalReasonChain, Scope) (Validate (Tree QGoalReasonChain)) -> Validate (Tree QGoalReasonChain)
+    go :: TreeF QGoalReasonChain (Validate (Tree QGoalReasonChain)) -> Validate (Tree QGoalReasonChain)
 
-    go (PChoiceF qpn (gr,  sc)     ts) = PChoice qpn gr <$> sequence (P.mapWithKey (goP qpn gr sc) ts)
-    go (FChoiceF qfn (gr, _sc) b m ts) =
+    go (PChoiceF qpn gr     ts) = PChoice qpn gr <$> sequence (P.mapWithKey (goP qpn gr) ts)
+    go (FChoiceF qfn gr b m ts) =
       do
         -- Flag choices may occur repeatedly (because they can introduce new constraints
         -- in various places). However, subsequent choices must be consistent. We thereby
@@ -99,7 +99,7 @@ validate = cata go
                        Nothing -> return $ Fail (toConflictSet (Goal (F qfn) gr)) (MalformedFlagChoice qfn)
           Nothing -> -- flag choice is new, follow both branches
                      FChoice qfn gr b m <$> sequence (P.mapWithKey (goF qfn gr) ts)
-    go (SChoiceF qsn (gr, _sc) b   ts) =
+    go (SChoiceF qsn gr b   ts) =
       do
         -- Optional stanza choices are very similar to flag choices.
         PA _ _ psa <- asks pa -- obtain current stanza-preassignment
@@ -117,13 +117,13 @@ validate = cata go
     go (FailF    c fr              ) = pure (Fail c fr)
 
     -- What to do for package nodes ...
-    goP :: QPN -> QGoalReasonChain -> Scope -> I -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain)
-    goP qpn@(Q _pp pn) gr sc i r = do
+    goP :: QPN -> QGoalReasonChain -> I -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain)
+    goP qpn@(Q pp pn) gr i r = do
       PA ppa pfa psa <- asks pa    -- obtain current preassignment
       idx            <- asks index -- obtain the index
       svd            <- asks saved -- obtain saved dependencies
-      let (PInfo deps _ _ mfr) = idx ! pn ! i -- obtain dependencies and index-dictated exclusions introduced by the choice
-      let qdeps = L.map (fmap (qualify sc)) deps -- qualify the deps in the current scope
+      let (PInfo deps _ mfr) = idx ! pn ! i -- obtain dependencies and index-dictated exclusions introduced by the choice
+      let qdeps = L.map (fmap (Q pp)) deps -- qualify the deps in the current scope
       -- the new active constraints are given by the instance we have chosen,
       -- plus the dependency information we have for that instance
       let goal = Goal (P qpn) gr
@@ -228,5 +228,5 @@ extractNewDeps v gr b fa sa = go
                                   Just False -> []
 
 -- | Interface.
-validateTree :: Index -> Tree (QGoalReasonChain, Scope) -> Tree QGoalReasonChain
+validateTree :: Index -> Tree QGoalReasonChain -> Tree QGoalReasonChain
 validateTree idx t = runReader (validate t) (VS idx M.empty (PA M.empty M.empty M.empty))

From 208551111adaf25d1aaa8c73e6cddb9ca5c78ea4 Mon Sep 17 00:00:00 2001
From: Edsko de Vries <edsko@well-typed.com>
Date: Thu, 12 Feb 2015 12:07:21 +0000
Subject: [PATCH 02/28] Add union operation to PSQ

---
 cabal-install/Distribution/Client/Dependency/Modular/PSQ.hs | 5 ++++-
 1 file changed, 4 insertions(+), 1 deletion(-)

diff --git a/cabal-install/Distribution/Client/Dependency/Modular/PSQ.hs b/cabal-install/Distribution/Client/Dependency/Modular/PSQ.hs
index 7197cd3f84d..db2e320cd37 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/PSQ.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/PSQ.hs
@@ -57,7 +57,7 @@ casePSQ (PSQ xs) n c =
     (k, v) : ys -> c k v (PSQ ys)
 
 splits :: PSQ k a -> PSQ k (a, PSQ k a)
-splits = go id 
+splits = go id
   where
     go f xs = casePSQ xs
         (PSQ [])
@@ -92,3 +92,6 @@ null (PSQ xs) = S.null xs
 
 toList :: PSQ k a -> [(k, a)]
 toList (PSQ xs) = xs
+
+union :: PSQ k a -> PSQ k a -> PSQ k a
+union (PSQ xs) (PSQ ys) = PSQ (xs ++ ys)

From 6b7fe108bd72f373f1c66d6e8bc34792159ef4d5 Mon Sep 17 00:00:00 2001
From: Edsko de Vries <edsko@well-typed.com>
Date: Thu, 19 Feb 2015 10:28:56 +0100
Subject: [PATCH 03/28] Prefer base no matter the qualifier

---
 .../Distribution/Client/Dependency/Modular/Preference.hs    | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs b/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
index 64b10ae9b7b..c3d3bc980ba 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
@@ -230,9 +230,9 @@ preferBaseGoalChoice = trav go
     go x                = x
 
     preferBase :: OpenGoal -> OpenGoal -> Ordering
-    preferBase (OpenGoal (Simple (Dep (Q [] pn) _)) _) _ | unPN pn == "base" = LT
-    preferBase _ (OpenGoal (Simple (Dep (Q [] pn) _)) _) | unPN pn == "base" = GT
-    preferBase _ _                                                           = EQ
+    preferBase (OpenGoal (Simple (Dep (Q _pp pn) _)) _) _ | unPN pn == "base" = LT
+    preferBase _ (OpenGoal (Simple (Dep (Q _pp pn) _)) _) | unPN pn == "base" = GT
+    preferBase _ _                                                            = EQ
 
 -- | Transformation that sorts choice nodes so that
 -- child nodes with a small branching degree are preferred. As a

From 3a1f1f24c090cbbfce4c8e7c8d35a910b63801e9 Mon Sep 17 00:00:00 2001
From: Edsko de Vries <edsko@well-typed.com>
Date: Mon, 23 Mar 2015 12:01:29 +0000
Subject: [PATCH 04/28] Make PP (PackagePath) structured type

---
 .../Client/Dependency/Modular/Builder.hs      |  2 +-
 .../Client/Dependency/Modular/Package.hs      | 19 ++++++++++++-------
 2 files changed, 13 insertions(+), 8 deletions(-)

diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs b/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs
index 50cb570548c..acdfbf147ab 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs
@@ -154,4 +154,4 @@ buildTree idx ind igs =
                   Goals)
   where
     qpns | ind       = makeIndependent igs
-         | otherwise = L.map (Q []) igs
+         | otherwise = L.map (Q None) igs
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Package.hs b/cabal-install/Distribution/Client/Dependency/Modular/Package.hs
index a654f012318..4cd9fe8bf0d 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Package.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Package.hs
@@ -66,13 +66,17 @@ instI :: I -> Bool
 instI (I _ (Inst _)) = True
 instI _              = False
 
--- | Package path. (Stored in "reverse" order.)
-type PP = [PN]
+-- | Package path.
+data PP = Independent Int PP | Setup PN PP | None
+  deriving (Eq, Ord, Show)
 
 -- | String representation of a package path.
+--
+-- NOTE: This always ends in a period
 showPP :: PP -> String
-showPP = intercalate "." . L.map display . reverse
-
+showPP (Independent i pp) = show i ++ "." ++ showPP pp
+showPP (Setup pn      pp) = display pn ++ ".setup." ++ showPP pp
+showPP None               = ""
 
 -- | A qualified entity. Pairs a package path with the entity.
 data Q a = Q PP a
@@ -80,8 +84,8 @@ data Q a = Q PP a
 
 -- | Standard string representation of a qualified entity.
 showQ :: (a -> String) -> (Q a -> String)
-showQ showa (Q [] x) = showa x
-showQ showa (Q pp x) = showPP pp ++ "." ++ showa x
+showQ showa (Q None x) = showa x
+showQ showa (Q pp   x) = showPP pp ++ showa x
 
 -- | Qualified package name.
 type QPN = Q PN
@@ -94,7 +98,8 @@ showQPN = showQ display
 -- them all independent.
 makeIndependent :: [PN] -> [QPN]
 makeIndependent ps = [ Q pp pn | (pn, i) <- zip ps [0::Int ..]
-                               , let pp = [PackageName (show i)] ]
+                               , let pp = Independent i None
+                     ]
 
 
 unQualify :: Q a -> a

From 66f2b23473b3d7e4a86eddf7b7017aa65e6c6606 Mon Sep 17 00:00:00 2001
From: Edsko de Vries <edsko@well-typed.com>
Date: Thu, 12 Feb 2015 10:44:57 +0000
Subject: [PATCH 05/28] Introduce POption

POption annotates a package choice with a "linked to" field. This commit
just introduces the datatype and deals with the immediate fallout, it doesn't
actually use the field for anything.
---
 .../Client/Dependency/Modular/Builder.hs      |  2 +-
 .../Client/Dependency/Modular/Explore.hs      |  4 ++--
 .../Client/Dependency/Modular/Message.hs      | 20 +++++++++++-------
 .../Client/Dependency/Modular/Preference.hs   | 21 +++++++++++--------
 .../Client/Dependency/Modular/Tree.hs         |  9 ++++++--
 .../Client/Dependency/Modular/Validate.hs     |  4 ++--
 6 files changed, 37 insertions(+), 23 deletions(-)

diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs b/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs
index acdfbf147ab..1a9bb2cd342 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs
@@ -113,7 +113,7 @@ build = ana go
       case M.lookup pn idx of
         Nothing  -> FailF (toConflictSet (Goal (P qpn) gr)) (BuildFailureNotInIndex pn)
         Just pis -> PChoiceF qpn gr (P.fromList (L.map (\ (i, info) ->
-                                                           (i, bs { next = Instance qpn i info gr }))
+                                                           (POption i Nothing, bs { next = Instance qpn i info gr }))
                                                          (M.toList pis)))
           -- TODO: data structure conversion is rather ugly here
 
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Explore.hs b/cabal-install/Distribution/Client/Dependency/Modular/Explore.hs
index 2cf0d575f8f..82dbec8eebe 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Explore.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Explore.hs
@@ -80,7 +80,7 @@ explore = cata go
     go (PChoiceF qpn _     ts) (A pa fa sa)   =
       asum $                                      -- try children in order,
       P.mapWithKey                                -- when descending ...
-        (\ k r -> r (A (M.insert qpn k pa) fa sa)) -- record the pkg choice
+        (\ (POption k _) r -> r (A (M.insert qpn k pa) fa sa)) -- record the pkg choice
       ts
     go (FChoiceF qfn _ _ _ ts) (A pa fa sa)   =
       asum $                                      -- try children in order,
@@ -107,7 +107,7 @@ exploreLog = cata go
       backjumpInfo c $
       asum $                                      -- try children in order,
       P.mapWithKey                                -- when descending ...
-        (\ k r -> tryWith (TryP (PI qpn k)) $     -- log and ...
+        (\ i@(POption k _) r -> tryWith (TryP qpn i) $     -- log and ...
                     r (A (M.insert qpn k pa) fa sa)) -- record the pkg choice
       ts
     go (FChoiceF qfn c _ _ ts) (A pa fa sa)   =
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Message.hs b/cabal-install/Distribution/Client/Dependency/Modular/Message.hs
index 9042d4ea4de..f63b87e5603 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Message.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Message.hs
@@ -13,7 +13,7 @@ import Distribution.Client.Dependency.Modular.Tree
 data Message =
     Enter           -- ^ increase indentation level
   | Leave           -- ^ decrease indentation level
-  | TryP (PI QPN)
+  | TryP QPN POption
   | TryF QFN Bool
   | TryS QSN Bool
   | Next (Goal QPN)
@@ -38,15 +38,15 @@ showMessages p sl = go [] 0
     go :: [Var QPN] -> Int -> [Message] -> [String]
     go _ _ []                            = []
     -- complex patterns
-    go v l (TryP (PI qpn i) : Enter : Failure c fr : Leave : ms) = goPReject v l qpn [i] c fr ms
+    go v l (TryP qpn i : Enter : Failure c fr : Leave : ms) = goPReject v l qpn [i] c fr ms
     go v l (TryF qfn b : Enter : Failure c fr : Leave : ms) = (atLevel (add (F qfn) v) l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go v l ms)
     go v l (TryS qsn b : Enter : Failure c fr : Leave : ms) = (atLevel (add (S qsn) v) l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go v l ms)
-    go v l (Next (Goal (P qpn) gr) : TryP pi : ms@(Enter : Next _ : _)) = (atLevel (add (P qpn) v) l $ "trying: " ++ showPI pi ++ showGRs gr) (go (add (P qpn) v) l ms)
+    go v l (Next (Goal (P qpn) gr) : TryP qpn' i : ms@(Enter : Next _ : _)) = (atLevel (add (P qpn) v) l $ "trying: " ++ showQPNPOpt qpn' i ++ showGRs gr) (go (add (P qpn) v) l ms)
     go v l (Failure c Backjump : ms@(Leave : Failure c' Backjump : _)) | c == c' = go v l ms
     -- standard display
     go v l (Enter                  : ms) = go v          (l+1) ms
     go v l (Leave                  : ms) = go (drop 1 v) (l-1) ms
-    go v l (TryP pi@(PI qpn _)     : ms) = (atLevel (add (P qpn) v) l $ "trying: " ++ showPI pi) (go (add (P qpn) v) l ms)
+    go v l (TryP qpn i             : ms) = (atLevel (add (P qpn) v) l $ "trying: " ++ showQPNPOpt qpn i) (go (add (P qpn) v) l ms)
     go v l (TryF qfn b             : ms) = (atLevel (add (F qfn) v) l $ "trying: " ++ showQFNBool qfn b) (go (add (F qfn) v) l ms)
     go v l (TryS qsn b             : ms) = (atLevel (add (S qsn) v) l $ "trying: " ++ showQSNBool qsn b) (go (add (S qsn) v) l ms)
     go v l (Next (Goal (P qpn) gr) : ms) = (atLevel (add (P qpn) v) l $ "next goal: " ++ showQPN qpn ++ showGRs gr) (go v l ms)
@@ -58,9 +58,9 @@ showMessages p sl = go [] 0
     add v vs = simplifyVar v : vs
 
     -- special handler for many subsequent package rejections
-    goPReject :: [Var QPN] -> Int -> QPN -> [I] -> ConflictSet QPN -> FailReason -> [Message] -> [String]
-    goPReject v l qpn is c fr (TryP (PI qpn' i) : Enter : Failure _ fr' : Leave : ms) | qpn == qpn' && fr == fr' = goPReject v l qpn (i : is) c fr ms
-    goPReject v l qpn is c fr ms = (atLevel (P qpn : v) l $ "rejecting: " ++ showQPN qpn ++ "-" ++ L.intercalate ", " (map showI (reverse is)) ++ showFR c fr) (go v l ms)
+    goPReject :: [Var QPN] -> Int -> QPN -> [POption] -> ConflictSet QPN -> FailReason -> [Message] -> [String]
+    goPReject v l qpn is c fr (TryP qpn' i : Enter : Failure _ fr' : Leave : ms) | qpn == qpn' && fr == fr' = goPReject v l qpn (i : is) c fr ms
+    goPReject v l qpn is c fr ms = (atLevel (P qpn : v) l $ "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr) (go v l ms)
 
     -- write a message, but only if it's relevant; we can also enable or disable the display of the current level
     atLevel v l x xs
@@ -69,6 +69,12 @@ showMessages p sl = go [] 0
       | p v       = x : xs
       | otherwise = xs
 
+showQPNPOpt :: QPN -> POption -> String
+showQPNPOpt qpn@(Q _pp pn) (POption i linkedTo) =
+  case linkedTo of
+    Nothing  -> showPI (PI qpn i) -- Consistent with prior to POption
+    Just pp' -> showQPN qpn ++ "~>" ++ showPI (PI (Q pp' pn) i)
+
 showGRs :: QGoalReasonChain -> String
 showGRs (gr : _) = showGR gr
 showGRs []       = ""
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs b/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
index c3d3bc980ba..18876c8ae21 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
@@ -25,13 +25,16 @@ import Distribution.Client.Dependency.Modular.Version
 -- | Generic abstraction for strategies that just rearrange the package order.
 -- Only packages that match the given predicate are reordered.
 packageOrderFor :: (PN -> Bool) -> (PN -> I -> I -> Ordering) -> Tree a -> Tree a
-packageOrderFor p cmp = trav go
+packageOrderFor p cmp' = trav go
   where
     go (PChoiceF v@(Q _ pn) r cs)
       | p pn                        = PChoiceF v r (P.sortByKeys (flip (cmp pn)) cs)
       | otherwise                   = PChoiceF v r                               cs
     go x                            = x
 
+    cmp :: PN -> POption -> POption -> Ordering
+    cmp pn (POption i _) (POption i' _) = cmp' pn i i'
+
 -- | Ordering that treats preferred versions as greater than non-preferred
 -- versions.
 preferredVersionsOrdering :: VR -> Ver -> Ver -> Ordering
@@ -114,7 +117,7 @@ enforcePackageConstraints pcs = trav go
     go (PChoiceF qpn@(Q _ pn)               gr      ts) =
       let c = toConflictSet (Goal (P qpn) gr)
           -- compose the transformation functions for each of the relevant constraint
-          g = \ i -> foldl (\ h pc -> h . processPackageConstraintP   c i pc) id
+          g = \ (POption i _) -> foldl (\ h pc -> h . processPackageConstraintP   c i pc) id
                            (M.findWithDefault [] pn pcs)
       in PChoiceF qpn gr      (P.mapWithKey g ts)
     go (FChoiceF qfn@(FN (PI (Q _ pn) _) f) gr tr m ts) =
@@ -173,8 +176,8 @@ requireInstalled p = trav go
       | p pn      = PChoiceF v gr (P.mapWithKey installed cs)
       | otherwise = PChoiceF v gr                         cs
       where
-        installed (I _ (Inst _)) x = x
-        installed _              _ = Fail (toConflictSet (Goal (P v) gr)) CannotInstall
+        installed (POption (I _ (Inst _)) _) x = x
+        installed _ _ = Fail (toConflictSet (Goal (P v) gr)) CannotInstall
     go x          = x
 
 -- | Avoid reinstalls.
@@ -198,12 +201,13 @@ avoidReinstalls p = trav go
       | otherwise = PChoiceF qpn gr cs
       where
         disableReinstalls =
-          let installed = [ v | (I v (Inst _), _) <- toList cs ]
+          let installed = [ v | (POption (I v (Inst _)) _, _) <- toList cs ]
           in  P.mapWithKey (notReinstall installed) cs
 
-        notReinstall vs (I v InRepo) _
-          | v `elem` vs                = Fail (toConflictSet (Goal (P qpn) gr)) CannotReinstall
-        notReinstall _  _            x = x
+        notReinstall vs (POption (I v InRepo) _) _ | v `elem` vs =
+          Fail (toConflictSet (Goal (P qpn) gr)) CannotReinstall
+        notReinstall _ _ x =
+          x
     go x          = x
 
 -- | Always choose the first goal in the list next, abandoning all
@@ -278,4 +282,3 @@ preferEasyGoalChoices' = para (inn . go)
   where
     go (GoalChoiceF xs) = GoalChoiceF (P.map fst (P.sortBy (comparing (choices . snd)) xs))
     go x                = fmap fst x
-
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs b/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs
index d7ccc17aaec..2724402ceed 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs
@@ -14,7 +14,7 @@ import Distribution.Client.Dependency.Modular.Version
 
 -- | Type of the search tree. Inlining the choice nodes for now.
 data Tree a =
-    PChoice     QPN a           (PSQ I        (Tree a))
+    PChoice     QPN a           (PSQ POption  (Tree a))
   | FChoice     QFN a Bool Bool (PSQ Bool     (Tree a)) -- Bool indicates whether it's weak/trivial, second Bool whether it's manual
   | SChoice     QSN a Bool      (PSQ Bool     (Tree a)) -- Bool indicates whether it's trivial
   | GoalChoice                  (PSQ OpenGoal (Tree a)) -- PSQ should never be empty
@@ -30,6 +30,11 @@ data Tree a =
   -- the system, as opposed to flags that are used to explicitly enable or
   -- disable some functionality.
 
+-- | A package option is an instance, together with an optional annotation that
+-- this package is linked to the same package with another prefix
+data POption = POption I (Maybe PP)
+  deriving (Eq, Show)
+
 data FailReason = InconsistentInitialConstraints
                 | Conflicting [Dep QPN]
                 | CannotInstall
@@ -50,7 +55,7 @@ data FailReason = InconsistentInitialConstraints
 
 -- | Functor for the tree type.
 data TreeF a b =
-    PChoiceF    QPN a           (PSQ I        b)
+    PChoiceF    QPN a           (PSQ POption  b)
   | FChoiceF    QFN a Bool Bool (PSQ Bool     b)
   | SChoiceF    QSN a Bool      (PSQ Bool     b)
   | GoalChoiceF                 (PSQ OpenGoal b)
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs b/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs
index 8b8d380e386..c28700e142b 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs
@@ -117,8 +117,8 @@ validate = cata go
     go (FailF    c fr              ) = pure (Fail c fr)
 
     -- What to do for package nodes ...
-    goP :: QPN -> QGoalReasonChain -> I -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain)
-    goP qpn@(Q pp pn) gr i r = do
+    goP :: QPN -> QGoalReasonChain -> POption -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain)
+    goP qpn@(Q pp pn) gr (POption i _) r = do
       PA ppa pfa psa <- asks pa    -- obtain current preassignment
       idx            <- asks index -- obtain the index
       svd            <- asks saved -- obtain saved dependencies

From 6b85cdca9bac223523cce305d6d2b2414bd152de Mon Sep 17 00:00:00 2001
From: Edsko de Vries <edsko@well-typed.com>
Date: Thu, 12 Feb 2015 11:05:43 +0000
Subject: [PATCH 06/28] Add single instance restriction

---
 .../Client/Dependency/Modular/Message.hs      |  1 +
 .../Client/Dependency/Modular/Preference.hs   | 47 +++++++++++++++++++
 .../Client/Dependency/Modular/Solver.hs       |  1 +
 .../Client/Dependency/Modular/Tree.hs         |  1 +
 4 files changed, 50 insertions(+)

diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Message.hs b/cabal-install/Distribution/Client/Dependency/Modular/Message.hs
index f63b87e5603..b933ddc7c92 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Message.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Message.hs
@@ -99,6 +99,7 @@ showFR _ GlobalConstraintFlag           = " (global constraint requires opposite
 showFR _ ManualFlag                     = " (manual flag can only be changed explicitly)"
 showFR _ (BuildFailureNotInIndex pn)    = " (unknown package: " ++ display pn ++ ")"
 showFR c Backjump                       = " (backjumping, conflict set: " ++ showCS c ++ ")"
+showFR _ MultipleInstances              = " (multiple instances)"
 -- 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/Preference.hs b/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
index 18876c8ae21..16802134016 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
@@ -7,8 +7,14 @@ import qualified Data.List as L
 import qualified Data.Map as M
 #if !MIN_VERSION_base(4,8,0)
 import Data.Monoid
+import Control.Applicative
 #endif
+import qualified Data.Set as S
+import Prelude hiding (sequence)
+import Control.Monad.Reader hiding (sequence)
 import Data.Ord
+import Data.Map (Map)
+import Data.Traversable (sequence)
 
 import Distribution.Client.Dependency.Types
   ( PackageConstraint(..), PackagePreferences(..), InstalledPreference(..) )
@@ -282,3 +288,44 @@ preferEasyGoalChoices' = para (inn . go)
   where
     go (GoalChoiceF xs) = GoalChoiceF (P.map fst (P.sortBy (comparing (choices . snd)) xs))
     go x                = fmap fst x
+
+-- | Monad used internally in enforceSingleInstanceRestriction
+type EnforceSIR = Reader (Map (PI PN) QPN)
+
+-- | Enforce ghc's single instance restriction
+--
+-- From the solver's perspective, this means that for any package instance
+-- (that is, package name + package version) there can be at most one qualified
+-- goal resolving to that instance (there may be other goals _linking_ to that
+-- instance however).
+enforceSingleInstanceRestriction :: Tree QGoalReasonChain -> Tree QGoalReasonChain
+enforceSingleInstanceRestriction = (`runReader` M.empty) . cata go
+  where
+    go :: TreeF QGoalReasonChain (EnforceSIR (Tree QGoalReasonChain)) -> EnforceSIR (Tree QGoalReasonChain)
+
+    -- We just verify package choices
+    go (PChoiceF qpn gr cs) =
+      PChoice qpn gr <$> sequence (P.mapWithKey (goP qpn) cs)
+
+    -- For all other nodes we don't check anything
+    go (FChoiceF qfn gr t m cs)       = FChoice qfn gr t m <$> sequence cs
+    go (SChoiceF qsn gr t   cs)       = SChoice qsn gr t   <$> sequence cs
+    go (GoalChoiceF         cs)       = GoalChoice         <$> sequence cs
+    go (DoneF revDepMap)              = return $ Done revDepMap
+    go (FailF conflictSet failReason) = return $ Fail conflictSet failReason
+
+    -- The check proper
+    goP :: QPN -> POption -> EnforceSIR (Tree QGoalReasonChain) -> EnforceSIR (Tree QGoalReasonChain)
+    goP qpn@(Q _ pn) (POption i linkedTo) r = do
+      let inst = PI pn i
+      env <- ask
+      case (linkedTo, M.lookup inst env) of
+        (Just _, _) ->
+          -- For linked nodes we don't check anything
+          r
+        (Nothing, Nothing) ->
+          -- Not linked, not already used
+          local (M.insert inst qpn) r
+        (Nothing, Just qpn') -> do
+          -- Not linked, already used. This is an error
+          return $ Fail (S.fromList [P qpn, P qpn']) MultipleInstances
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs b/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs
index 13ec67bc03b..48a4faefa4f 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs
@@ -49,6 +49,7 @@ solve sc idx userPrefs userConstraints userGoals =
     preferencesPhase = P.preferPackagePreferences userPrefs
     validationPhase  = P.enforceManualFlags . -- can only be done after user constraints
                        P.enforcePackageConstraints userConstraints .
+                       P.enforceSingleInstanceRestriction .
                        validateTree idx
     prunePhase       = (if avoidReinstalls sc then P.avoidReinstalls (const True) else id) .
                        -- packages that can never be "upgraded":
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs b/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs
index 2724402ceed..7bf47f2f0f3 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs
@@ -51,6 +51,7 @@ data FailReason = InconsistentInitialConstraints
                 | MalformedStanzaChoice QSN
                 | EmptyGoalChoice
                 | Backjump
+                | MultipleInstances
   deriving (Eq, Show)
 
 -- | Functor for the tree type.

From ce955ecf57d4d54a28d57282ad2b7576829ede0c Mon Sep 17 00:00:00 2001
From: Edsko de Vries <edsko@well-typed.com>
Date: Thu, 12 Feb 2015 12:59:31 +0000
Subject: [PATCH 07/28] Prefer to link when possible

---
 .../Client/Dependency/Modular/Preference.hs       | 15 +++++++++++++++
 .../Client/Dependency/Modular/Solver.hs           |  1 +
 2 files changed, 16 insertions(+)

diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs b/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
index 16802134016..8e8b98dba65 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
@@ -41,6 +41,21 @@ packageOrderFor p cmp' = trav go
     cmp :: PN -> POption -> POption -> Ordering
     cmp pn (POption i _) (POption i' _) = cmp' pn i i'
 
+-- | Prefer to link packages whenever possible
+preferLinked :: Tree a -> Tree a
+preferLinked = trav go
+  where
+    go (PChoiceF qn a  cs) = PChoiceF qn a (P.sortByKeys cmp cs)
+    go x                   = x
+
+    cmp (POption _ linkedTo) (POption _ linkedTo') = cmpL linkedTo linkedTo'
+
+    cmpL Nothing  Nothing  = EQ
+    cmpL Nothing  (Just _) = GT
+    cmpL (Just _) Nothing  = LT
+    cmpL (Just _) (Just _) = EQ
+
+
 -- | Ordering that treats preferred versions as greater than non-preferred
 -- versions.
 preferredVersionsOrdering :: VR -> Ver -> Ver -> Ordering
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs b/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs
index 48a4faefa4f..b413aefceab 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs
@@ -43,6 +43,7 @@ solve sc idx userPrefs userConstraints userGoals =
     heuristicsPhase  = P.firstGoal . -- after doing goal-choice heuristics, commit to the first choice (saves space)
                        P.deferWeakFlagChoices .
                        P.preferBaseGoalChoice .
+                       P.preferLinked .
                        if preferEasyGoalChoices sc
                          then P.lpreferEasyGoalChoices
                          else id

From 7e192b26dbd827249f0f71f21bae4ab99a7cdf1b Mon Sep 17 00:00:00 2001
From: Edsko de Vries <edsko@well-typed.com>
Date: Thu, 12 Feb 2015 11:12:01 +0000
Subject: [PATCH 08/28] Actually add link nodes

This is implemented as a separate pass so that it can be understood
independently of the rest of the solver.
---
 .../Client/Dependency/Modular/Linking.hs      | 62 +++++++++++++++++++
 .../Client/Dependency/Modular/Solver.hs       |  3 +-
 2 files changed, 64 insertions(+), 1 deletion(-)
 create mode 100644 cabal-install/Distribution/Client/Dependency/Modular/Linking.hs

diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Linking.hs b/cabal-install/Distribution/Client/Dependency/Modular/Linking.hs
new file mode 100644
index 00000000000..c2e92781615
--- /dev/null
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Linking.hs
@@ -0,0 +1,62 @@
+{-# LANGUAGE CPP #-}
+module Distribution.Client.Dependency.Modular.Linking (
+    addLinking
+  ) where
+
+import Control.Monad.Reader
+import Data.Map (Map)
+import qualified Data.Map         as M
+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.Package
+import Distribution.Client.Dependency.Modular.Tree
+import qualified Distribution.Client.Dependency.Modular.PSQ as P
+
+{-------------------------------------------------------------------------------
+  Add linking
+-------------------------------------------------------------------------------}
+
+type RelatedGoals = Map (PN, I) [PP]
+type Linker       = Reader RelatedGoals
+
+addLinking :: Tree QGoalReasonChain -> Tree QGoalReasonChain
+addLinking = (`runReader` M.empty) .  cata go
+  where
+    go :: TreeF QGoalReasonChain (Linker (Tree QGoalReasonChain)) -> Linker (Tree QGoalReasonChain)
+
+    -- The only nodes of interest are package nodes
+    go (PChoiceF qpn gr cs) = do
+      env <- ask
+      cs' <- T.sequence $ P.mapWithKey (goP qpn) cs
+      let newCs = concatMap (linkChoices env qpn) (P.toList cs')
+      return $ PChoice qpn gr (cs' `P.union` P.fromList newCs)
+
+    -- For all other nodes we just recurse
+    go (FChoiceF qfn gr t m cs)       = FChoice qfn gr t m  <$> T.sequence cs
+    go (SChoiceF qsn gr t   cs)       = SChoice qsn gr t    <$> T.sequence cs
+    go (GoalChoiceF         cs)       = GoalChoice          <$> T.sequence cs
+    go (DoneF revDepMap)              = return $ Done revDepMap
+    go (FailF conflictSet failReason) = return $ Fail conflictSet failReason
+
+    -- Recurse underneath package choices. Here we just need to make sure
+    -- that we record the package choice so that it is available below
+    goP :: QPN -> POption -> Linker (Tree QGoalReasonChain) -> Linker (Tree QGoalReasonChain)
+    goP (Q pp pn) (POption i Nothing) = local (M.insertWith (++) (pn, i) [pp])
+    goP _ _ = alreadyLinked
+
+linkChoices :: RelatedGoals -> QPN -> (POption, Tree QGoalReasonChain) -> [(POption, Tree QGoalReasonChain)]
+linkChoices related (Q _pp pn) (POption i Nothing, subtree) =
+    map aux (M.findWithDefault [] (pn, i) related)
+  where
+    aux :: PP -> (POption, Tree QGoalReasonChain)
+    aux pp = (POption i (Just pp), subtree)
+linkChoices _ _ (POption _ (Just _), _) =
+    alreadyLinked
+
+alreadyLinked :: a
+alreadyLinked = error "addLinking called on tree that already contains linked nodes"
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs b/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs
index b413aefceab..069064ba11b 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs
@@ -14,6 +14,7 @@ import Distribution.Client.Dependency.Modular.Message
 import Distribution.Client.Dependency.Modular.Package
 import qualified Distribution.Client.Dependency.Modular.Preference as P
 import Distribution.Client.Dependency.Modular.Validate
+import Distribution.Client.Dependency.Modular.Linking
 
 -- | Various options for the modular solver.
 data SolverConfig = SolverConfig {
@@ -59,4 +60,4 @@ solve sc idx userPrefs userConstraints userGoals =
                                                   , PackageName "integer-gmp"
                                                   , PackageName "integer-simple"
                                                   ])
-    buildPhase       = buildTree idx (independentGoals sc) userGoals
+    buildPhase       = addLinking $ buildTree idx (independentGoals sc) userGoals

From ae377ae43318d0de9519bc4bec7bb139658e04b6 Mon Sep 17 00:00:00 2001
From: Edsko de Vries <edsko@well-typed.com>
Date: Thu, 12 Feb 2015 13:17:42 +0000
Subject: [PATCH 09/28] Link validation

---
 .../Client/Dependency/Modular/Linking.hs      | 401 +++++++++++++++++-
 .../Client/Dependency/Modular/Message.hs      |   1 +
 .../Client/Dependency/Modular/Solver.hs       |   1 +
 .../Client/Dependency/Modular/Tree.hs         |   1 +
 4 files changed, 403 insertions(+), 1 deletion(-)

diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Linking.hs b/cabal-install/Distribution/Client/Dependency/Modular/Linking.hs
index c2e92781615..b9b5aea078c 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Linking.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Linking.hs
@@ -1,22 +1,36 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 module Distribution.Client.Dependency.Modular.Linking (
     addLinking
+  , validateLinking
   ) where
 
+import Prelude hiding (pi)
+import Control.Exception (assert)
 import Control.Monad.Reader
-import Data.Map (Map)
+import Control.Monad.State
+import Data.Maybe (catMaybes)
+import Data.Map (Map, (!))
+import Data.List (intercalate)
+import Data.Set (Set)
 import qualified Data.Map         as M
+import qualified Data.Set         as S
 import qualified Data.Traversable as T
 
 #if !MIN_VERSION_base(4,8,0)
 import Control.Applicative
 #endif
 
+import Distribution.Client.Dependency.Modular.Assignment
 import Distribution.Client.Dependency.Modular.Dependency
+import Distribution.Client.Dependency.Modular.Flag
+import Distribution.Client.Dependency.Modular.Index
 import Distribution.Client.Dependency.Modular.Package
 import Distribution.Client.Dependency.Modular.Tree
 import qualified Distribution.Client.Dependency.Modular.PSQ as P
 
+import Distribution.Client.Types (OptionalStanza(..))
+
 {-------------------------------------------------------------------------------
   Add linking
 -------------------------------------------------------------------------------}
@@ -60,3 +74,388 @@ linkChoices _ _ (POption _ (Just _), _) =
 
 alreadyLinked :: a
 alreadyLinked = error "addLinking called on tree that already contains linked nodes"
+
+{-------------------------------------------------------------------------------
+  Validation
+-------------------------------------------------------------------------------}
+
+data ValidateState = VS {
+      vsIndex    :: Index
+    , vsLinks    :: Map QPN LinkGroup
+    , vsFlags    :: FAssignment
+    , vsStanzas  :: SAssignment
+    }
+    deriving Show
+
+type Validate = Reader ValidateState
+
+-- | Validate linked packages
+--
+-- Verify that linked packages have
+--
+-- * Linked dependencies,
+-- * Equal flag assignments
+-- * And something to do with stanzas (TODO)
+validateLinking :: Index -> Tree QGoalReasonChain -> Tree QGoalReasonChain
+validateLinking index = (`runReader` initVS) . cata go
+  where
+    go :: TreeF QGoalReasonChain (Validate (Tree QGoalReasonChain)) -> Validate (Tree QGoalReasonChain)
+
+    go (PChoiceF qpn gr cs) =
+      PChoice qpn gr     <$> T.sequence (P.mapWithKey (goP qpn) cs)
+    go (FChoiceF qfn gr t m cs) =
+      FChoice qfn gr t m <$> T.sequence (P.mapWithKey (goF qfn) cs)
+    go (SChoiceF qsn gr t cs) =
+      SChoice qsn gr t   <$> T.sequence (P.mapWithKey (goS qsn) cs)
+
+    -- For the other nodes we just recurse
+    go (GoalChoiceF         cs)       = GoalChoice          <$> T.sequence cs
+    go (DoneF revDepMap)              = return $ Done revDepMap
+    go (FailF conflictSet failReason) = return $ Fail conflictSet failReason
+
+    -- Package choices
+    goP :: QPN -> POption -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain)
+    goP qpn@(Q pp pn) opt@(POption i _) r = do
+      vs <- ask
+      let PInfo deps _ _ = vsIndex vs ! pn ! i
+          qdeps          = map (fmap (Q pp)) deps
+      case execUpdateState (pickPOption qpn opt qdeps) vs of
+        Left  (cs, err) -> return $ Fail cs (DependenciesNotLinked err)
+        Right vs'       -> local (const vs') r
+
+    -- Flag choices
+    goF :: QFN -> Bool -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain)
+    goF qfn b r = do
+      vs <- ask
+      case execUpdateState (pickFlag qfn b) vs of
+        Left  (cs, err) -> return $ Fail cs (DependenciesNotLinked err)
+        Right vs'       -> local (const vs') r
+
+    -- Stanza choices (much the same as flag choices)
+    goS :: QSN -> Bool -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain)
+    goS qsn b r = do
+      vs <- ask
+      case execUpdateState (pickStanza qsn b) vs of
+        Left  (cs, err) -> return $ Fail cs (DependenciesNotLinked err)
+        Right vs'       -> local (const vs') r
+
+    initVS :: ValidateState
+    initVS = VS {
+        vsIndex   = index
+      , vsLinks   = M.empty
+      , vsFlags   = M.empty
+      , vsStanzas = M.empty
+      }
+
+{-------------------------------------------------------------------------------
+  Updating the validation state
+-------------------------------------------------------------------------------}
+
+type Conflict = (ConflictSet QPN, String)
+
+newtype UpdateState a = UpdateState {
+    unUpdateState :: StateT ValidateState (Either Conflict) a
+  }
+  deriving (Functor, Applicative, Monad, MonadState ValidateState)
+
+lift' :: Either Conflict a -> UpdateState a
+lift' = UpdateState . lift
+
+conflict :: Conflict -> UpdateState a
+conflict = lift' . Left
+
+execUpdateState :: UpdateState () -> ValidateState -> Either Conflict ValidateState
+execUpdateState = execStateT . unUpdateState
+
+pickPOption :: QPN -> POption -> FlaggedDeps QPN -> UpdateState ()
+pickPOption qpn (POption i Nothing)    _deps = pickConcrete qpn i
+pickPOption qpn (POption i (Just pp'))  deps = pickLink     qpn i pp' deps
+
+pickConcrete :: QPN -> I -> UpdateState ()
+pickConcrete qpn@(Q pp _) i = do
+    vs <- get
+    case M.lookup qpn (vsLinks vs) of
+      -- Package is not yet in a LinkGroup. Create a new singleton link group.
+      Nothing -> do
+        let lg = (lgSingleton qpn (Just i)) { lgCanon = Just pp }
+        updateLinkGroup lg
+
+      -- Package is already in a link group. Since we are picking a concrete
+      -- instance here, it must by definition by the canonical package.
+      Just lg ->
+        makeCanonical lg qpn
+
+pickLink :: QPN -> I -> PP -> FlaggedDeps QPN -> UpdateState ()
+pickLink qpn@(Q _ pn) i pp' deps = do
+    vs <- get
+    -- Find the link group for the package we are linking to, and add this package
+    --
+    -- Since the builder never links to a package without having first picked a
+    -- concrete instance for that package, and since we create singleton link
+    -- groups for concrete instances, this  link group must exist.
+    let lg = vsLinks vs ! Q pp' pn
+    lg' <- lift' $ lgAddMember qpn i lg
+    updateLinkGroup lg'
+    linkDeps [P qpn] pp' deps
+
+makeCanonical :: LinkGroup -> QPN -> UpdateState ()
+makeCanonical lg qpn@(Q pp _) =
+    case lgCanon lg of
+      -- There is already a canonical member. Fail.
+      Just _ ->
+        conflict ( S.fromList (P qpn : lgBlame lg)
+                 ,    "cannot make " ++ showQPN qpn
+                   ++ " canonical member of " ++ showLinkGroup lg
+                 )
+      Nothing -> do
+        let lg' = lg { lgCanon = Just pp }
+        updateLinkGroup lg'
+
+linkDeps :: [Var QPN] -> PP -> FlaggedDeps QPN -> UpdateState ()
+linkDeps parents pp' = mapM_ go
+  where
+    go :: FlaggedDep 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 (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
+      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
+
+pickFlag :: QFN -> Bool -> UpdateState ()
+pickFlag qfn b = do
+    modify $ \vs -> vs { vsFlags = M.insert qfn b (vsFlags vs) }
+    verifyFlag qfn
+    linkNewDeps (F qfn) b
+
+pickStanza :: QSN -> Bool -> UpdateState ()
+pickStanza qsn b = do
+    modify $ \vs -> vs { vsStanzas = M.insert qsn b (vsStanzas vs) }
+    verifyStanza qsn
+    linkNewDeps (S qsn) b
+
+linkNewDeps :: Var QPN -> Bool -> UpdateState ()
+linkNewDeps var b = do
+    vs <- get
+    let (qpn@(Q pp pn), Just i) = varPI var
+        PInfo deps _ _          = vsIndex vs ! pn ! i
+        qdeps                   = map (fmap (Q pp)) deps
+        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
+  where
+    findNewDeps :: ValidateState -> FlaggedDeps QPN -> ([Var QPN], FlaggedDeps QPN)
+    findNewDeps vs = concatMapUnzip (findNewDeps' vs)
+
+    findNewDeps' :: ValidateState -> FlaggedDep QPN -> ([Var QPN], FlaggedDeps QPN)
+    findNewDeps' _  (Simple _)          = ([], [])
+    findNewDeps' vs (Flagged qfn _ t f) =
+      case (F qfn == var, M.lookup qfn (vsFlags vs)) of
+        (True, _)    -> ([F qfn], if b then t else f)
+        (_, Nothing) -> ([], []) -- not yet known
+        (_, Just b') -> let (parents, deps) = findNewDeps vs (if b' then t else f)
+                        in (F qfn:parents, deps)
+    findNewDeps' vs (Stanza qsn t) =
+      case (S qsn == var, M.lookup qsn (vsStanzas vs)) of
+        (True, _)    -> ([S qsn], if b then t else [])
+        (_, Nothing) -> ([], []) -- not yet known
+        (_, Just b') -> let (parents, deps) = findNewDeps vs (if b' then t else [])
+                        in (S qsn:parents, deps)
+
+updateLinkGroup :: LinkGroup -> UpdateState ()
+updateLinkGroup lg = do
+    verifyLinkGroup lg
+    modify $ \vs -> vs {
+        vsLinks =           M.fromList (map aux (S.toList (lgMembers lg)))
+                  `M.union` vsLinks vs
+      }
+  where
+    aux pp = (Q pp (lgPackage lg), lg)
+
+{-------------------------------------------------------------------------------
+  Verification
+-------------------------------------------------------------------------------}
+
+verifyLinkGroup :: LinkGroup -> UpdateState ()
+verifyLinkGroup lg =
+    case lgInstance lg of
+      -- No instance picked yet. Nothing to verify
+      Nothing ->
+        return ()
+
+      -- We picked an instance. Verify flags and stanzas
+      -- TODO: The enumeration of OptionalStanza names is very brittle;
+      -- if a constructor is added to the datatype we won't notice it here
+      Just i -> do
+        vs <- get
+        let PInfo _deps finfo _ = vsIndex vs ! lgPackage lg ! i
+            flags   = M.keys finfo
+            stanzas = [TestStanzas, BenchStanzas]
+        forM_ flags $ \fn -> do
+          let flag = FN (PI (lgPackage lg) i) fn
+          verifyFlag' flag lg
+        forM_ stanzas $ \sn -> do
+          let stanza = SN (PI (lgPackage lg) i) sn
+          verifyStanza' stanza lg
+
+verifyFlag :: QFN -> UpdateState ()
+verifyFlag (FN (PI qpn@(Q _pp pn) i) fn) = do
+    vs <- get
+    -- We can only pick a flag after picking an instance; link group must exist
+    verifyFlag' (FN (PI pn i) fn) (vsLinks vs ! qpn)
+
+verifyStanza :: QSN -> UpdateState ()
+verifyStanza (SN (PI qpn@(Q _pp pn) i) sn) = do
+    vs <- get
+    -- We can only pick a stanza after picking an instance; link group must exist
+    verifyStanza' (SN (PI pn i) sn) (vsLinks vs ! qpn)
+
+verifyFlag' :: FN PN -> LinkGroup -> UpdateState ()
+verifyFlag' (FN (PI pn i) fn) lg = do
+    vs <- get
+    let flags = map (\pp' -> FN (PI (Q pp' pn) i) fn) (S.toList (lgMembers lg))
+        vals  = map (`M.lookup` vsFlags vs) flags
+    if allEqual (catMaybes vals) -- We ignore not-yet assigned flags
+      then return ()
+      else conflict ( S.fromList (map F flags) `S.union` lgConflictSet lg
+                    , "flag " ++ show fn ++ " incompatible"
+                    )
+
+verifyStanza' :: SN PN -> LinkGroup -> UpdateState ()
+verifyStanza' (SN (PI pn i) sn) lg = do
+    vs <- get
+    let stanzas = map (\pp' -> SN (PI (Q pp' pn) i) sn) (S.toList (lgMembers lg))
+        vals    = map (`M.lookup` vsStanzas vs) stanzas
+    if allEqual (catMaybes vals) -- We ignore not-yet assigned stanzas
+      then return ()
+      else conflict ( S.fromList (map S stanzas) `S.union` lgConflictSet lg
+                    , "stanza " ++ show sn ++ " incompatible"
+                    )
+
+{-------------------------------------------------------------------------------
+  Link groups
+-------------------------------------------------------------------------------}
+
+-- | Set of packages that must be linked together
+data LinkGroup = LinkGroup {
+      -- | The name of the package of this link group
+      lgPackage :: PN
+
+      -- | The version of the package of this link group
+      --
+      -- We may not know this version yet (if we are constructing link groups
+      -- for dependencies)
+    , lgInstance :: Maybe I
+
+      -- | The canonical member of this link group (the one where we picked
+      -- a concrete instance). Once we have picked a canonical member, all
+      -- other packages must link to this one.
+    , lgCanon :: Maybe PP
+
+      -- | The members of the link group
+    , lgMembers :: Set PP
+
+      -- | The set of variables that should be added to the conflict set if
+      -- something goes wrong with this link set (in addition to the members
+      -- of the link group itself)
+    , lgBlame :: [Var QPN]
+    }
+    deriving Show
+
+showLinkGroup :: LinkGroup -> String
+showLinkGroup lg =
+    "{" ++ intercalate "," (map showMember (S.toList (lgMembers lg))) ++ "}"
+  where
+    showMember :: PP -> String
+    showMember pp = (if lgCanon lg == Just pp then "*" else "")
+                 ++ case lgInstance lg of
+                      Nothing -> showQPN (qpn pp)
+                      Just i  -> showPI (PI (qpn pp) i)
+
+    qpn :: PP -> QPN
+    qpn pp = Q pp (lgPackage lg)
+
+lgSingleton :: QPN -> Maybe I -> LinkGroup
+lgSingleton (Q pp pn) inst = LinkGroup {
+      lgPackage  = pn
+    , lgInstance = inst
+    , lgCanon    = Nothing
+    , lgMembers  = S.singleton pp
+    , lgBlame    = []
+    }
+
+lgMerge :: [Var QPN] -> LinkGroup -> LinkGroup -> Either Conflict LinkGroup
+lgMerge blame lg lg' = do
+    canon <- pick (lgCanon    lg) (lgCanon    lg')
+    inst  <- pick (lgInstance lg) (lgInstance lg')
+    return LinkGroup {
+        lgPackage  = lgPackage lg
+      , lgInstance = inst
+      , lgCanon    = canon
+      , lgMembers  = lgMembers lg `S.union` lgMembers lg'
+      , lgBlame    = blame ++ lgBlame lg ++ lgBlame lg'
+      }
+  where
+    pick :: Eq a => Maybe a -> Maybe a -> Either Conflict (Maybe a)
+    pick Nothing  Nothing  = Right Nothing
+    pick (Just x) Nothing  = Right $ Just x
+    pick Nothing  (Just y) = Right $ Just y
+    pick (Just x) (Just y) =
+      if x == y then Right $ Just x
+                else Left ( S.unions [
+                               S.fromList blame
+                             , lgConflictSet lg
+                             , lgConflictSet lg'
+                             ]
+                          ,    "cannot merge "++ showLinkGroup lg
+                            ++ " and " ++ showLinkGroup lg'
+                          )
+
+lgConflictSet :: LinkGroup -> ConflictSet QPN
+lgConflictSet lg = S.fromList (map aux (S.toList (lgMembers lg)) ++ lgBlame lg)
+  where
+    aux pp = P (Q pp (lgPackage lg))
+
+lgAddMember :: QPN -> I -> LinkGroup -> Either Conflict LinkGroup
+lgAddMember qpn@(Q pp pn) i lg = do
+    assert (pn == lgPackage lg) $ Right ()
+    let lg' = lg { lgMembers = S.insert pp (lgMembers lg) }
+    case lgInstance lg of
+      Nothing             -> Right $ lg' { lgInstance = Just i }
+      Just i' | i == i'   -> Right lg'
+              | otherwise -> Left ( lgConflictSet lg'
+                                  ,    "cannot add " ++ showQPN qpn
+                                    ++ " to " ++ showLinkGroup lg
+                                  )
+
+{-------------------------------------------------------------------------------
+  Auxiliary
+-------------------------------------------------------------------------------}
+
+-- | Extract the package instance from a Var
+varPI :: Var QPN -> (QPN, Maybe I)
+varPI (P qpn)               = (qpn, Nothing)
+varPI (F (FN (PI qpn i) _)) = (qpn, Just i)
+varPI (S (SN (PI qpn i) _)) = (qpn, Just i)
+
+allEqual :: Eq a => [a] -> Bool
+allEqual []       = True
+allEqual [_]      = True
+allEqual (x:y:ys) = x == y && allEqual (y:ys)
+
+concatMapUnzip :: (a -> ([b], [c])) -> [a] -> ([b], [c])
+concatMapUnzip f = (\(xs, ys) -> (concat xs, concat ys)) . unzip . map f
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Message.hs b/cabal-install/Distribution/Client/Dependency/Modular/Message.hs
index b933ddc7c92..cf5dcd7a3d4 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Message.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Message.hs
@@ -100,6 +100,7 @@ showFR _ ManualFlag                     = " (manual flag can only be changed exp
 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 ++ ")"
 -- 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 069064ba11b..dd93f289449 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs
@@ -52,6 +52,7 @@ solve sc idx userPrefs userConstraints userGoals =
     validationPhase  = P.enforceManualFlags . -- can only be done after user constraints
                        P.enforcePackageConstraints userConstraints .
                        P.enforceSingleInstanceRestriction .
+                       validateLinking idx .
                        validateTree idx
     prunePhase       = (if avoidReinstalls sc then P.avoidReinstalls (const True) else id) .
                        -- packages that can never be "upgraded":
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs b/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs
index 7bf47f2f0f3..cdcd5760e79 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs
@@ -52,6 +52,7 @@ data FailReason = InconsistentInitialConstraints
                 | EmptyGoalChoice
                 | Backjump
                 | MultipleInstances
+                | DependenciesNotLinked String
   deriving (Eq, Show)
 
 -- | Functor for the tree type.

From d56e1d8a93a35d057916148d495e5de65ae17924 Mon Sep 17 00:00:00 2001
From: Edsko de Vries <edsko@well-typed.com>
Date: Thu, 5 Mar 2015 16:26:39 +0000
Subject: [PATCH 10/28] Deal with independent goals in plan validation

In particular, in the definition of dependencyInconsistencies.

One slightly annoying thing is that in order to validate an install plan, we
need to know if the goals are to be considered independent. This means we need
to pass an additional Bool to a few functions; to limit the number of functions
where this is necessary, also recorded whether or not goals are independent as
part of the InstallPlan itself.
---
 .../Distribution/Client/Dependency.hs         |  9 +--
 .../Modular/ConfiguredConversion.hs           |  6 +-
 .../Distribution/Client/InstallPlan.hs        | 61 +++++++++++--------
 .../Distribution/Client/PlanIndex.hs          | 55 ++++++++++++++---
 4 files changed, 90 insertions(+), 41 deletions(-)

diff --git a/cabal-install/Distribution/Client/Dependency.hs b/cabal-install/Distribution/Client/Dependency.hs
index ad518f2af12..0560ff0f89e 100644
--- a/cabal-install/Distribution/Client/Dependency.hs
+++ b/cabal-install/Distribution/Client/Dependency.hs
@@ -513,12 +513,12 @@ resolveDependencies :: Platform
     --TODO: is this needed here? see dontUpgradeNonUpgradeablePackages
 resolveDependencies platform comp _solver params
   | null (depResolverTargets params)
-  = return (mkInstallPlan platform comp [])
+  = return (mkInstallPlan platform comp (depResolverIndependentGoals params) [])
 
 resolveDependencies platform comp  solver params =
 
     Step (debugDepResolverParams finalparams)
-  $ fmap (mkInstallPlan platform comp)
+  $ fmap (mkInstallPlan platform comp indGoals)
   $ runSolver solver (SolverConfig reorderGoals indGoals noReinstalls
                       shadowing strFlags maxBkjumps)
                      platform comp installedPkgIndex sourcePkgIndex
@@ -553,10 +553,11 @@ resolveDependencies platform comp  solver params =
 --
 mkInstallPlan :: Platform
               -> CompilerInfo
+              -> Bool
               -> [InstallPlan.PlanPackage] -> InstallPlan
-mkInstallPlan platform comp pkgIndex =
+mkInstallPlan platform comp indepGoals pkgIndex =
   let index = InstalledPackageIndex.fromList pkgIndex in
-  case InstallPlan.new platform comp index of
+  case InstallPlan.new platform comp indepGoals index of
     Right plan     -> plan
     Left  problems -> error $ unlines $
         "internal error: could not construct a valid install plan."
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs b/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs
index 97d22a52d99..405c69bcdce 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs
@@ -13,11 +13,11 @@ import Distribution.System
 import Distribution.Client.Dependency.Modular.Configured
 import Distribution.Client.Dependency.Modular.Package
 
-mkPlan :: Platform -> CompilerInfo ->
+mkPlan :: Platform -> CompilerInfo -> Bool ->
           SI.InstalledPackageIndex -> CI.PackageIndex SourcePackage ->
           [CP QPN] -> Either [PlanProblem] InstallPlan
-mkPlan plat comp iidx sidx cps =
-  new plat comp (SI.fromList (map (convCP iidx sidx) cps))
+mkPlan plat comp indepGoals iidx sidx cps =
+  new plat comp indepGoals (SI.fromList (map (convCP iidx sidx) cps))
 
 convCP :: SI.InstalledPackageIndex -> CI.PackageIndex SourcePackage ->
           CP QPN -> PlanPackage
diff --git a/cabal-install/Distribution/Client/InstallPlan.hs b/cabal-install/Distribution/Client/InstallPlan.hs
index 741d3124702..431f8263507 100644
--- a/cabal-install/Distribution/Client/InstallPlan.hs
+++ b/cabal-install/Distribution/Client/InstallPlan.hs
@@ -188,19 +188,24 @@ instance HasInstalledPackageId PlanPackage where
   installedPackageId (Failed      pkg _) = installedPackageId pkg
 
 data InstallPlan = InstallPlan {
-    planIndex    :: PlanIndex,
-    planFakeMap  :: FakeMap,
-    planGraph    :: Graph,
-    planGraphRev :: Graph,
-    planPkgOf    :: Graph.Vertex -> PlanPackage,
-    planVertexOf :: InstalledPackageId -> Graph.Vertex,
-    planPlatform :: Platform,
-    planCompiler :: CompilerInfo
+    planIndex      :: PlanIndex,
+    planFakeMap    :: FakeMap,
+    planGraph      :: Graph,
+    planGraphRev   :: Graph,
+    planPkgOf      :: Graph.Vertex -> PlanPackage,
+    planVertexOf   :: InstalledPackageId -> Graph.Vertex,
+    planPlatform   :: Platform,
+    planCompiler   :: CompilerInfo,
+    planIndepGoals :: Bool
   }
 
 invariant :: InstallPlan -> Bool
 invariant plan =
-  valid (planPlatform plan) (planCompiler plan) (planFakeMap plan) (planIndex plan)
+    valid (planPlatform plan)
+          (planCompiler plan)
+          (planFakeMap plan)
+          (planIndepGoals plan)
+          (planIndex plan)
 
 internalError :: String -> a
 internalError msg = error $ "InstallPlan: internal error: " ++ msg
@@ -228,9 +233,9 @@ showPlanPackageTag (Failed _ _)    = "Failed"
 
 -- | Build an installation plan from a valid set of resolved packages.
 --
-new :: Platform -> CompilerInfo -> PlanIndex
+new :: Platform -> CompilerInfo -> Bool -> PlanIndex
     -> Either [PlanProblem] InstallPlan
-new platform cinfo index =
+new platform cinfo indepGoals index =
   -- NB: Need to pre-initialize the fake-map with pre-existing
   -- packages
   let isPreExisting (PreExisting _) = True
@@ -239,16 +244,17 @@ new platform cinfo index =
               . map (\p -> (fakeInstalledPackageId (packageId p), installedPackageId p))
               . filter isPreExisting
               $ PackageIndex.allPackages index in
-  case problems platform cinfo fakeMap index of
+  case problems platform cinfo fakeMap indepGoals index of
     [] -> Right InstallPlan {
-            planIndex    = index,
-            planFakeMap  = fakeMap,
-            planGraph    = graph,
-            planGraphRev = Graph.transposeG graph,
-            planPkgOf    = vertexToPkgId,
-            planVertexOf = fromMaybe noSuchPkgId . pkgIdToVertex,
-            planPlatform = platform,
-            planCompiler = cinfo
+            planIndex      = index,
+            planFakeMap    = fakeMap,
+            planGraph      = graph,
+            planGraphRev   = Graph.transposeG graph,
+            planPkgOf      = vertexToPkgId,
+            planVertexOf   = fromMaybe noSuchPkgId . pkgIdToVertex,
+            planPlatform   = platform,
+            planCompiler   = cinfo,
+            planIndepGoals = indepGoals
           }
       where (graph, vertexToPkgId, pkgIdToVertex) =
               PlanIndex.dependencyGraph fakeMap index
@@ -268,7 +274,7 @@ remove :: (PlanPackage -> Bool)
        -> InstallPlan
        -> Either [PlanProblem] InstallPlan
 remove shouldRemove plan =
-    new (planPlatform plan) (planCompiler plan) newIndex
+    new (planPlatform plan) (planCompiler plan) (planIndepGoals plan) newIndex
   where
     newIndex = PackageIndex.fromList $
                  filter (not . shouldRemove) (toList plan)
@@ -414,8 +420,9 @@ checkConfiguredPackage pkg                =
 --
 -- * if the result is @False@ use 'problems' to get a detailed list.
 --
-valid :: Platform -> CompilerInfo -> FakeMap -> PlanIndex -> Bool
-valid platform cinfo fakeMap index = null (problems platform cinfo fakeMap index)
+valid :: Platform -> CompilerInfo -> FakeMap -> Bool -> PlanIndex -> Bool
+valid platform cinfo fakeMap indepGoals index =
+    null $ problems platform cinfo fakeMap indepGoals index
 
 data PlanProblem =
      PackageInvalid       ConfiguredPackage [PackageProblem]
@@ -465,9 +472,9 @@ showPlanProblem (PackageStateInvalid pkg pkg') =
 -- error messages. This is mainly intended for debugging purposes.
 -- Use 'showPlanProblem' for a human readable explanation.
 --
-problems :: Platform -> CompilerInfo -> FakeMap
+problems :: Platform -> CompilerInfo -> FakeMap -> Bool
          -> PlanIndex -> [PlanProblem]
-problems platform cinfo fakeMap index =
+problems platform cinfo fakeMap indepGoals index =
      [ PackageInvalid pkg packageProblems
      | Configured pkg <- PackageIndex.allPackages index
      , let packageProblems = configuredPackageProblems platform cinfo pkg
@@ -480,7 +487,7 @@ problems platform cinfo fakeMap index =
      | cycleGroup <- PlanIndex.dependencyCycles fakeMap index ]
 
   ++ [ PackageInconsistency name inconsistencies
-     | (name, inconsistencies) <- PlanIndex.dependencyInconsistencies fakeMap index ]
+     | (name, inconsistencies) <- PlanIndex.dependencyInconsistencies fakeMap indepGoals index ]
 
   ++ [ PackageStateInvalid pkg pkg'
      | pkg <- PackageIndex.allPackages index
@@ -522,7 +529,7 @@ closed fakeMap = null . PlanIndex.brokenPackages fakeMap
 --   find out which packages are.
 --
 consistent :: FakeMap -> PlanIndex -> Bool
-consistent fakeMap = null . PlanIndex.dependencyInconsistencies fakeMap
+consistent fakeMap = null . PlanIndex.dependencyInconsistencies fakeMap False
 
 -- | The states of packages have that depend on each other must respect
 -- this relation. That is for very case where package @a@ depends on
diff --git a/cabal-install/Distribution/Client/PlanIndex.hs b/cabal-install/Distribution/Client/PlanIndex.hs
index b4f96e30507..4668d920330 100644
--- a/cabal-install/Distribution/Client/PlanIndex.hs
+++ b/cabal-install/Distribution/Client/PlanIndex.hs
@@ -29,6 +29,7 @@ import Data.Array ((!))
 import Data.List (sortBy)
 import Data.Map (Map)
 import Data.Maybe (isNothing, fromMaybe)
+import Data.Either (lefts)
 
 #if !MIN_VERSION_base(4,8,0)
 import Data.Monoid (Monoid(..))
@@ -116,6 +117,47 @@ brokenPackages fakeMap index =
                  , isNothing (fakeLookupInstalledPackageId fakeMap index pkg') ]
   , not (null missing) ]
 
+
+dependencyInconsistencies :: forall pkg. (PackageFixedDeps pkg, HasInstalledPackageId pkg)
+                          => FakeMap
+                          -> Bool
+                          -> PackageIndex pkg
+                          -> [(PackageName, [(PackageIdentifier, Version)])]
+dependencyInconsistencies fakeMap indepGoals index  =
+    concatMap (dependencyInconsistencies' fakeMap) subplans
+  where
+    subplans :: [PackageIndex pkg]
+    subplans = lefts $
+                 map (dependencyClosure fakeMap index)
+                     (rootSets fakeMap indepGoals index)
+
+-- | Compute the root sets of a plan
+--
+-- A root set is a set of packages whose dependency closure must be consistent.
+-- This is the set of all top-level library roots (taken together normally, or
+-- as singletons sets if we are considering them as independent goals), along
+-- with all setup dependencies of all packages.
+rootSets :: (PackageFixedDeps pkg, HasInstalledPackageId pkg)
+         => FakeMap -> Bool -> PackageIndex pkg -> [[InstalledPackageId]]
+rootSets fakeMap indepGoals index =
+       if indepGoals then map (:[]) libRoots else [libRoots]
+  where
+    libRoots = libraryRoots fakeMap index
+
+-- | Compute the library roots of a plan
+--
+-- The library roots are the set of packages with no reverse dependencies
+-- (no reverse library dependencies but also no reverse setup dependencies).
+libraryRoots :: (PackageFixedDeps pkg, HasInstalledPackageId pkg)
+             => FakeMap -> PackageIndex pkg -> [InstalledPackageId]
+libraryRoots fakeMap index =
+    map (installedPackageId . toPkgId) roots
+  where
+    (graph, toPkgId, _) = dependencyGraph fakeMap index
+    indegree = Graph.indegree graph
+    roots    = filter isRoot (Graph.vertices graph)
+    isRoot v = indegree ! v == 0
+
 -- | Given a package index where we assume we want to use all the packages
 -- (use 'dependencyClosure' if you need to get such a index subset) find out
 -- if the dependencies within it use consistent versions of each package.
@@ -126,12 +168,12 @@ brokenPackages fakeMap index =
 -- depend on it and the versions they require. These are guaranteed to be
 -- distinct.
 --
-dependencyInconsistencies :: forall pkg.
-                             (PackageFixedDeps pkg, HasInstalledPackageId pkg)
-                          => FakeMap
-                          -> PackageIndex pkg
-                          -> [(PackageName, [(PackageIdentifier, Version)])]
-dependencyInconsistencies fakeMap index =
+dependencyInconsistencies' :: forall pkg.
+                              (PackageFixedDeps pkg, HasInstalledPackageId pkg)
+                           => FakeMap
+                           -> PackageIndex pkg
+                           -> [(PackageName, [(PackageIdentifier, Version)])]
+dependencyInconsistencies' fakeMap index =
     [ (name, [ (pid,packageVersion dep) | (dep,pids) <- uses, pid <- pids])
     | (name, ipid_map) <- Map.toList inverseIndex
     , let uses = Map.elems ipid_map
@@ -196,7 +238,6 @@ dependencyCycles fakeMap index =
 --
 -- * Note that if the result is @Right []@ it is because at least one of
 -- the original given 'PackageIdentifier's do not occur in the index.
---
 dependencyClosure :: (PackageFixedDeps pkg, HasInstalledPackageId pkg)
                   => FakeMap
                   -> PackageIndex pkg

From 1885fb8997126410a83b27fa94cd68151ab896ac Mon Sep 17 00:00:00 2001
From: Edsko de Vries <edsko@well-typed.com>
Date: Thu, 12 Feb 2015 10:17:19 +0000
Subject: [PATCH 11/28] Unit tests for the solver

Since we didn't really have a unit test setup for the solver yet, this
introduces some basic tests for solver, as well as tests for independent goals
specifically.
---
 cabal-install/cabal-install.cabal             |   1 +
 cabal-install/tests/UnitTests.hs              |  14 +-
 .../Client/Dependency/Modular/Solver.hs       | 506 ++++++++++++++++++
 3 files changed, 520 insertions(+), 1 deletion(-)
 create mode 100644 cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs

diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal
index 321b025c913..583a79b35bd 100644
--- a/cabal-install/cabal-install.cabal
+++ b/cabal-install/cabal-install.cabal
@@ -180,6 +180,7 @@ Test-Suite unit-tests
   other-modules:
     UnitTests.Distribution.Client.Targets
     UnitTests.Distribution.Client.Dependency.Modular.PSQ
+    UnitTests.Distribution.Client.Dependency.Modular.Solver
     UnitTests.Distribution.Client.Sandbox
     UnitTests.Distribution.Client.UserConfig
   build-depends:
diff --git a/cabal-install/tests/UnitTests.hs b/cabal-install/tests/UnitTests.hs
index f457d266d4f..28ee60fe553 100644
--- a/cabal-install/tests/UnitTests.hs
+++ b/cabal-install/tests/UnitTests.hs
@@ -2,11 +2,13 @@ module Main
        where
 
 import Test.Tasty
+import Test.Tasty.Options
 
 import qualified UnitTests.Distribution.Client.Sandbox
 import qualified UnitTests.Distribution.Client.UserConfig
 import qualified UnitTests.Distribution.Client.Targets
 import qualified UnitTests.Distribution.Client.Dependency.Modular.PSQ
+import qualified UnitTests.Distribution.Client.Dependency.Modular.Solver
 
 tests :: TestTree
 tests = testGroup "Unit Tests" [
@@ -18,7 +20,17 @@ tests = testGroup "Unit Tests" [
        UnitTests.Distribution.Client.Targets.tests
   ,testGroup "UnitTests.Distribution.Client.Dependency.Modular.PSQ"
         UnitTests.Distribution.Client.Dependency.Modular.PSQ.tests
+  ,testGroup "UnitTests.Distribution.Client.Dependency.Modular.Solver"
+        UnitTests.Distribution.Client.Dependency.Modular.Solver.tests
+  ]
+
+-- Extra options for running the test suite
+extraOptions :: [OptionDescription]
+extraOptions = concat [
+    UnitTests.Distribution.Client.Dependency.Modular.Solver.options
   ]
 
 main :: IO ()
-main = defaultMain tests
+main = defaultMainWithIngredients
+         (includingOptions extraOptions : defaultIngredients)
+         tests
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs b/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs
new file mode 100644
index 00000000000..b82d6ff29fc
--- /dev/null
+++ b/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs
@@ -0,0 +1,506 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE CPP #-}
+module UnitTests.Distribution.Client.Dependency.Modular.Solver (tests, options) where
+
+-- base
+import Control.Monad
+import Data.Maybe (catMaybes, isNothing)
+import Data.Either (partitionEithers)
+import Data.Typeable
+import Data.Version
+import qualified Data.Map as Map
+
+#if !MIN_VERSION_base(4,8,0)
+import Data.Monoid
+#endif
+
+-- test-framework
+import Test.Tasty as TF
+import Test.Tasty.HUnit (testCase, assertEqual, assertBool)
+import Test.Tasty.Options
+
+-- Cabal
+import qualified Distribution.Compiler             as C
+import qualified Distribution.InstalledPackageInfo as C
+import qualified Distribution.Package              as C hiding (HasInstalledPackageId(..))
+import qualified Distribution.PackageDescription   as C
+import qualified Distribution.Simple.PackageIndex  as C.PackageIndex
+import qualified Distribution.System               as C
+import qualified Distribution.Version              as C
+
+-- cabal-install
+import Distribution.Client.Dependency
+import Distribution.Client.Dependency.Types
+import Distribution.Client.Types
+import qualified Distribution.Client.InstallPlan  as CI.InstallPlan
+import qualified Distribution.Client.PackageIndex as CI.PackageIndex
+
+tests :: [TF.TestTree]
+tests = [
+      testGroup "Simple dependencies" [
+          runTest $         mkTest db1 "alreadyInstalled"   ["A"]      (Just [])
+        , runTest $         mkTest db1 "installLatest"      ["B"]      (Just [("B", 2)])
+        , runTest $         mkTest db1 "simpleDep1"         ["C"]      (Just [("B", 1), ("C", 1)])
+        , runTest $         mkTest db1 "simpleDep2"         ["D"]      (Just [("B", 2), ("D", 1)])
+        , runTest $         mkTest db1 "failTwoVersions"    ["C", "D"] Nothing
+        , runTest $ indep $ mkTest db1 "indepTwoVersions"   ["C", "D"] (Just [("B", 1), ("B", 2), ("C", 1), ("D", 1)])
+        , runTest $ indep $ mkTest db1 "aliasWhenPossible1" ["C", "E"] (Just [("B", 1), ("C", 1), ("E", 1)])
+        , runTest $ indep $ mkTest db1 "aliasWhenPossible2" ["D", "E"] (Just [("B", 2), ("D", 1), ("E", 1)])
+        , runTest $ indep $ mkTest db2 "aliasWhenPossible3" ["C", "D"] (Just [("A", 1), ("A", 2), ("B", 1), ("B", 2), ("C", 1), ("D", 1)])
+        , runTest $         mkTest db1 "buildDepAgainstOld" ["F"]      (Just [("B", 1), ("E", 1), ("F", 1)])
+        , runTest $         mkTest db1 "buildDepAgainstNew" ["G"]      (Just [("B", 2), ("E", 1), ("G", 1)])
+        , runTest $ indep $ mkTest db1 "multipleInstances"  ["F", "G"] Nothing
+        ]
+    , testGroup "Flagged dependencies" [
+          runTest $         mkTest db3 "forceFlagOn"  ["C"]      (Just [("A", 1), ("B", 1), ("C", 1)])
+        , 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
+        ]
+    , testGroup "Stanzas" [
+          runTest $         mkTest db5 "simpleTest1" ["C"]      (Just [("A", 2), ("C", 1)])
+        , runTest $         mkTest db5 "simpleTest2" ["D"]      Nothing
+        , runTest $         mkTest db5 "simpleTest3" ["E"]      (Just [("A", 1), ("E", 1)])
+        , runTest $         mkTest db5 "simpleTest4" ["F"]      Nothing -- TODO
+        , runTest $         mkTest db5 "simpleTest5" ["G"]      (Just [("A", 2), ("G", 1)])
+        , runTest $         mkTest db5 "simpleTest6" ["E", "G"] Nothing
+        , runTest $ indep $ mkTest db5 "simpleTest7" ["E", "G"] (Just [("A", 1), ("A", 2), ("E", 1), ("G", 1)])
+        , runTest $         mkTest db6 "depsWithTests1" ["C"]      (Just [("A", 1), ("B", 1), ("C", 1)])
+        , runTest $ indep $ mkTest db6 "depsWithTests2" ["C", "D"] (Just [("A", 1), ("B", 1), ("C", 1), ("D", 1)])
+        ]
+    ]
+  where
+    indep test = test { testIndepGoals = True }
+
+{-------------------------------------------------------------------------------
+  Solver tests
+-------------------------------------------------------------------------------}
+
+data SolverTest = SolverTest {
+    testLabel      :: String
+  , testTargets    :: [String]
+  , testResult     :: Maybe [(String, Int)]
+  , testIndepGoals :: Bool
+  , testDb         :: ExampleDb
+  }
+
+mkTest :: ExampleDb
+       -> String
+       -> [String]
+       -> Maybe [(String, Int)]
+       -> SolverTest
+mkTest db label targets result = SolverTest {
+    testLabel      = label
+  , testTargets    = targets
+  , testResult     = result
+  , testIndepGoals = False
+  , testDb         = db
+  }
+
+runTest :: SolverTest -> TF.TestTree
+runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) ->
+    testCase testLabel $ do
+      let (_msgs, result) = exResolve testDb testTargets testIndepGoals
+      when showSolverLog $ mapM_ putStrLn _msgs
+      case result of
+        Left  err  -> assertBool ("Unexpected error:\n" ++ err) (isNothing testResult)
+        Right plan -> assertEqual "" testResult (Just (extractInstallPlan plan))
+
+{-------------------------------------------------------------------------------
+  Specific example database for the tests
+-------------------------------------------------------------------------------}
+
+db1 :: ExampleDb
+db1 =
+    let a = ExInst "A" 1 "A-1" []
+    in [ Left a
+       , Right $ ExAv "B" 1 [ExAny "A"]
+       , Right $ ExAv "B" 2 [ExAny "A"]
+       , Right $ ExAv "C" 1 [ExFix "B" 1]
+       , Right $ ExAv "D" 1 [ExFix "B" 2]
+       , Right $ ExAv "E" 1 [ExAny "B"]
+       , Right $ ExAv "F" 1 [ExFix "B" 1, ExAny "E"]
+       , Right $ ExAv "G" 1 [ExFix "B" 2, ExAny "E"]
+       , Right $ ExAv "Z" 1 []
+       ]
+
+-- In this example, we _can_ install C and D as independent goals, but we have
+-- to pick two diferent versions for B (arbitrarily)
+db2 :: ExampleDb
+db2 = [
+    Right $ ExAv "A" 1 []
+  , Right $ ExAv "A" 2 []
+  , Right $ ExAv "B" 1 [ExAny "A"]
+  , Right $ ExAv "B" 2 [ExAny "A"]
+  , Right $ ExAv "C" 1 [ExAny "B", ExFix "A" 1]
+  , Right $ ExAv "D" 1 [ExAny "B", ExFix "A" 2]
+  ]
+
+db3 :: ExampleDb
+db3 = [
+     Right $ ExAv "A" 1 []
+   , Right $ ExAv "A" 2 []
+   , Right $ ExAv "B" 1 [ExFlag "flagB" [ExFix "A" 1] [ExFix "A" 2]]
+   , Right $ ExAv "C" 1 [ExFix "A" 1, ExAny "B"]
+   , Right $ ExAv "D" 1 [ExFix "A" 2, ExAny "B"]
+   ]
+
+-- | Like exampleDb2, but the flag picks a different package rather than a
+-- different package version
+--
+-- In exampleDb2 we cannot install C and D as independent goals because:
+--
+-- * The multiple instance restriction says C and D _must_ share B
+-- * Since C relies on A.1, C needs B to be compiled with flagB on
+-- * Since D relies on A.2, D needs B to be compiled with flagsB off
+-- * Hence C and D have incompatible requirements on B's flags.
+--
+-- However, _even_ if we don't check explicitly that we pick the same flag
+-- assignment for 0.B and 1.B, we will still detect the problem because
+-- 0.B depends on 0.A-1, 1.B depends on 1.A-2, hence we cannot link 0.A to
+-- 1.B and therefore we cannot link 0.B to 1.B.
+--
+-- In exampleDb3 the situation however is trickier. We again cannot install
+-- packages C and D as independent goals because:
+--
+-- * As above, the multiple instance restriction says that C and D _must_ share B
+-- * Since C relies on Ax-2, it requires B to be compiled with flagB off
+-- * Since D relies on Ay-2, it requires B to be compiled with flagB on
+-- * Hence C and D have incompatible requirements on B's flags.
+--
+-- But now this requirement is more indirect. If we only check dependencies
+-- we don't see the problem:
+--
+-- * We link 0.B to 1.B
+-- * 0.B relies on Ay.1
+-- * 1.B relies on Ax.1
+--
+-- We will insist that 0.Ay will be linked to 1.Ay, and 0.Ax to 1.A, but since
+-- we only ever assign to one of these, these constraints are never broken.
+db4 :: ExampleDb
+db4 = [
+     Right $ ExAv "Ax" 1 []
+   , Right $ ExAv "Ax" 2 []
+   , Right $ ExAv "Ay" 1 []
+   , Right $ ExAv "Ay" 2 []
+   , Right $ ExAv "B"  1 [ExFlag "flagB" [ExFix "Ax" 1] [ExFix "Ay" 1]]
+   , Right $ ExAv "C"  1 [ExFix "Ax" 2, ExAny "B"]
+   , Right $ ExAv "D"  1 [ExFix "Ay" 2, ExAny "B"]
+   ]
+
+-- | Some tests involving testsuites
+--
+-- Note that in this test framework test suites are always enabled; if you
+-- want to test without test suites just set up a test database without
+-- test suites.
+--
+-- * C depends on A (through its test suite)
+-- * D depends on B-2 (through its test suite), but B-2 is unavailable
+-- * E depends on A-1 directly and on A through its test suite. We prefer
+--     to use A-1 for the test suite in this case.
+-- * F depends on A-1 directly and on A-2 through its test suite. In this
+--     case we currently fail to install F, although strictly speaking
+--     test suites should be considered independent goals.
+-- * G is like E, but for version A-2. This means that if we cannot install
+--     E and G together, unless we regard them as independent goals.
+db5 :: ExampleDb
+db5 = [
+    Right $ ExAv "A" 1 []
+  , Right $ ExAv "A" 2 []
+  , Right $ ExAv "B" 1 []
+  , Right $ ExAv "C" 1 [ExTest "testC" [ExAny "A"]]
+  , Right $ ExAv "D" 1 [ExTest "testD" [ExFix "B" 2]]
+  , Right $ ExAv "E" 1 [ExFix "A" 1, ExTest "testE" [ExAny "A"]]
+  , Right $ ExAv "F" 1 [ExFix "A" 1, ExTest "testF" [ExFix "A" 2]]
+  , Right $ ExAv "G" 1 [ExFix "A" 2, ExTest "testG" [ExAny "A"]]
+  ]
+
+-- Now the _dependencies_ have test suites
+--
+-- * Installing C is a simple example. C wants version 1 of A, but depends on
+--   B, and B's testsuite depends on an any version of A. In this case we prefer
+--   to link (if we don't regard test suites as independent goals then of course
+--   linking here doesn't even come into it).
+-- * Installing [C, D] means that we prefer to link B -- depending on how we
+--   set things up, this means that we should also link their test suites.
+db6 :: ExampleDb
+db6 = [
+    Right $ ExAv "A" 1 []
+  , Right $ ExAv "A" 2 []
+  , Right $ ExAv "B" 1 [ExTest "testA" [ExAny "A"]]
+  , Right $ ExAv "C" 1 [ExFix "A" 1, ExAny "B"]
+  , Right $ ExAv "D" 1 [ExAny "B"]
+  ]
+
+{-------------------------------------------------------------------------------
+  Example package database DSL
+
+  In order to be able to set simple examples up quickly, we define a very
+  simple version of the package database here explicitly designed for use in
+  tests.
+
+  The design of `ExampleDb` takes the perspective of the solver, not the
+  perspective of the package DB. This makes it easier to set up tests for
+  various parts of the solver, but makes the mapping somewhat awkward,  because
+  it means we first map from "solver perspective" `ExampleDb` to the package
+  database format, and then the modular solver internally in `IndexConversion`
+  maps this back to the solver specific data structures.
+
+  IMPLEMENTATION NOTES
+  --------------------
+
+  TODO: Perhaps these should be made comments of the corresponding data type
+  definitions. For now these are just my own conclusions and may be wrong.
+
+  * The difference between `GenericPackageDescription` and `PackageDescription`
+    is that `PackageDescription` describes a particular _configuration_ of a
+    package (for instance, see documentation for `checkPackage`). A
+    `GenericPackageDescription` can be returned into a `PackageDescription` in
+    two ways:
+
+      a. `finalizePackageDescription` does the proper translation, by taking
+         into account the platform, available dependencies, etc. and picks a
+         flag assignment (or gives an error if no flag assignment can be found)
+      b. `flattenPackageDescription` ignores flag assignment and just joins all
+         components together.
+
+    The slightly odd thing is that a `GenericPackageDescription` contains a
+    `PackageDescription` as a field; both of the above functions do the same
+    thing: they take the embedded `PackageDescription` as a basis for the result
+    value, but override `library`, `executables`, `testSuites`, `benchmarks`
+    and `buildDepends`.
+  * The `condTreeComponents` fields of a `CondTree` is a list of triples
+    `(condition, then-branch, else-branch)`, where the `else-branch` is
+    optional.
+-------------------------------------------------------------------------------}
+
+type ExamplePkgName    = String
+type ExamplePkgVersion = Int
+type ExamplePkgHash    = String  -- for example "installed" packages
+type ExampleFlagName   = String
+type ExampleTestName   = String
+
+data ExampleDependency =
+    -- | Simple dependency on any version
+    ExAny ExamplePkgName
+
+    -- | Simple dependency on a fixed version
+  | ExFix ExamplePkgName ExamplePkgVersion
+
+    -- | Dependencies indexed by a flag
+  | ExFlag ExampleFlagName [ExampleDependency] [ExampleDependency]
+
+    -- | Dependency if tests are enabled
+  | ExTest ExampleTestName [ExampleDependency]
+
+data ExampleAvailable = ExAv {
+    exAvName    :: ExamplePkgName
+  , exAvVersion :: ExamplePkgVersion
+  , exAvDeps    :: [ExampleDependency]
+  }
+
+data ExampleInstalled = ExInst {
+    exInstName         :: ExamplePkgName
+  , exInstVersion      :: ExamplePkgVersion
+  , exInstHash         :: ExamplePkgHash
+  , exInstBuildAgainst :: [ExampleInstalled]
+  }
+
+type ExampleDb = [Either ExampleInstalled ExampleAvailable]
+
+type DependencyTree a = C.CondTree C.ConfVar [C.Dependency] a
+
+exDbPkgs :: ExampleDb -> [ExamplePkgName]
+exDbPkgs = map (either exInstName exAvName)
+
+exAvSrcPkg :: ExampleAvailable -> SourcePackage
+exAvSrcPkg ex =
+    let (libraryDeps, testSuites) = splitTopLevel (exAvDeps ex)
+    in SourcePackage {
+           packageInfoId        = exAvPkgId ex
+         , packageSource        = LocalTarballPackage "<<path>>"
+         , packageDescrOverride = Nothing
+         , packageDescription   = C.GenericPackageDescription{
+               C.packageDescription = C.emptyPackageDescription {
+                   C.package      = exAvPkgId ex
+                 , C.library      = error "not yet configured: library"
+                 , C.executables  = error "not yet configured: executables"
+                 , C.testSuites   = error "not yet configured: testSuites"
+                 , C.benchmarks   = error "not yet configured: benchmarks"
+                 , C.buildDepends = error "not yet configured: buildDepends"
+                 }
+             , C.genPackageFlags = concatMap extractFlags (exAvDeps ex)
+             , C.condLibrary     = Just $ mkCondTree libraryDeps
+             , C.condExecutables = []
+             , C.condTestSuites  = map (\(t, deps) -> (t, mkCondTree deps)) testSuites
+             , C.condBenchmarks  = []
+             }
+         }
+  where
+    splitTopLevel :: [ExampleDependency]
+                  -> ( [ExampleDependency]
+                     , [(ExampleTestName, [ExampleDependency])]
+                     )
+    splitTopLevel []                = ([], [])
+    splitTopLevel (ExTest t a:deps) = let (other, testSuites) = splitTopLevel deps
+                                      in (other, (t, a):testSuites)
+    splitTopLevel (dep:deps)        = let (other, testSuites) = splitTopLevel deps
+                                      in (dep:other, testSuites)
+
+    extractFlags :: ExampleDependency -> [C.Flag]
+    extractFlags (ExAny _)      = []
+    extractFlags (ExFix _ _)    = []
+    extractFlags (ExFlag f a b) = C.MkFlag {
+                                      C.flagName        = C.FlagName f
+                                    , C.flagDescription = ""
+                                    , C.flagDefault     = False
+                                    , C.flagManual      = False
+                                    }
+                                : concatMap extractFlags (a ++ b)
+    extractFlags (ExTest _ a)   = concatMap extractFlags a
+
+    mkCondTree :: Monoid a => [ExampleDependency] -> DependencyTree a
+    mkCondTree deps =
+      let (directDeps, flaggedDeps) = splitDeps deps
+      in C.CondNode {
+             C.condTreeData        = mempty -- irrelevant to the solver
+           , C.condTreeConstraints = map mkDirect  directDeps
+           , C.condTreeComponents  = map mkFlagged flaggedDeps
+           }
+
+    mkDirect :: (ExamplePkgName, Maybe ExamplePkgVersion) -> C.Dependency
+    mkDirect (dep, Nothing) = C.Dependency (C.PackageName dep) C.anyVersion
+    mkDirect (dep, Just n)  = C.Dependency (C.PackageName dep) (C.thisVersion v)
+      where
+        v = Version [n, 0, 0] []
+
+    mkFlagged :: Monoid a
+              => (ExampleFlagName, [ExampleDependency], [ExampleDependency])
+              -> (C.Condition C.ConfVar, DependencyTree a, Maybe (DependencyTree a))
+    mkFlagged (f, a, b) = ( C.Var (C.Flag (C.FlagName f))
+                          , mkCondTree a
+                          , Just (mkCondTree b)
+                          )
+
+    splitDeps :: [ExampleDependency]
+              -> ( [(ExamplePkgName, Maybe Int)]
+                 , [(ExampleFlagName, [ExampleDependency], [ExampleDependency])]
+                 )
+    splitDeps [] =
+      ([], [])
+    splitDeps (ExAny p:deps) =
+      let (directDeps, flaggedDeps) = splitDeps deps
+      in ((p, Nothing):directDeps, flaggedDeps)
+    splitDeps (ExFix p v:deps) =
+      let (directDeps, flaggedDeps) = splitDeps deps
+      in ((p, Just v):directDeps, flaggedDeps)
+    splitDeps (ExFlag f a b:deps) =
+      let (directDeps, flaggedDeps) = splitDeps deps
+      in (directDeps, (f, a, b):flaggedDeps)
+    splitDeps (ExTest _ _:_) =
+      error "Unexpected nested test"
+
+exAvPkgId :: ExampleAvailable -> C.PackageIdentifier
+exAvPkgId ex = C.PackageIdentifier {
+      pkgName    = C.PackageName (exAvName ex)
+    , pkgVersion = Version [exAvVersion ex, 0, 0] []
+    }
+
+exInstInfo :: ExampleInstalled -> C.InstalledPackageInfo
+exInstInfo ex = C.emptyInstalledPackageInfo {
+      C.installedPackageId = C.InstalledPackageId (exInstHash ex)
+    , C.sourcePackageId    = exInstPkgId ex
+    , C.packageKey         = exInstKey ex
+    , C.depends            = map (C.InstalledPackageId . exInstHash)
+                                 (exInstBuildAgainst ex)
+    }
+
+exInstPkgId :: ExampleInstalled -> C.PackageIdentifier
+exInstPkgId ex = C.PackageIdentifier {
+      pkgName    = C.PackageName (exInstName ex)
+    , pkgVersion = Version [exInstVersion ex, 0, 0] []
+    }
+
+exInstKey :: ExampleInstalled -> C.PackageKey
+exInstKey ex =
+    C.mkPackageKey True
+                   (exInstPkgId ex)
+                   (map exInstKey (exInstBuildAgainst ex))
+                   []
+
+exAvIdx :: [ExampleAvailable] -> CI.PackageIndex.PackageIndex SourcePackage
+exAvIdx = CI.PackageIndex.fromList . map exAvSrcPkg
+
+exInstIdx :: [ExampleInstalled] -> C.PackageIndex.InstalledPackageIndex
+exInstIdx = C.PackageIndex.fromList . map exInstInfo
+
+exResolve :: ExampleDb
+          -> [ExamplePkgName]
+          -> Bool
+          -> ([String], Either String CI.InstallPlan.InstallPlan)
+exResolve db targets indepGoals = runProgress $
+    resolveDependencies C.buildPlatform
+                        (C.unknownCompilerInfo C.buildCompilerId C.NoAbiTag)
+                        Modular
+                        params
+  where
+    (inst, avai) = partitionEithers db
+    instIdx      = exInstIdx inst
+    avaiIdx      = SourcePackageDb {
+                       packageIndex       = exAvIdx avai
+                     , packagePreferences = Map.empty
+                     }
+    enableTests  = map (\p -> PackageConstraintStanzas (C.PackageName p) [TestStanzas])
+                       (exDbPkgs db)
+    targets'     = map (\p -> NamedPackage (C.PackageName p) []) targets
+    params       = addConstraints enableTests
+                 $ (standardInstallPolicy instIdx avaiIdx targets') {
+                       depResolverIndependentGoals = indepGoals
+                     }
+
+extractInstallPlan :: CI.InstallPlan.InstallPlan
+                   -> [(ExamplePkgName, ExamplePkgVersion)]
+extractInstallPlan = catMaybes . map confPkg . CI.InstallPlan.toList
+  where
+    confPkg :: CI.InstallPlan.PlanPackage -> Maybe (String, Int)
+    confPkg (CI.InstallPlan.Configured pkg) = Just $ srcPkg pkg
+    confPkg _                               = Nothing
+
+    srcPkg :: ConfiguredPackage -> (String, Int)
+    srcPkg (ConfiguredPackage pkg _flags _stanzas _deps) =
+      let C.PackageIdentifier (C.PackageName p) (Version (n:_) _) = packageInfoId pkg
+      in (p, n)
+
+{-------------------------------------------------------------------------------
+  Auxiliary
+-------------------------------------------------------------------------------}
+
+-- | Run Progress computation
+--
+-- Like `runLog`, but for the more general `Progress` type.
+runProgress :: Progress step e a -> ([step], Either e a)
+runProgress = go
+  where
+    go (Step s p) = let (ss, result) = go p in (s:ss, result)
+    go (Fail e)   = ([], Left e)
+    go (Done a)   = ([], Right a)
+
+{-------------------------------------------------------------------------------
+  Test options
+-------------------------------------------------------------------------------}
+
+options :: [OptionDescription]
+options = [
+    Option (Proxy :: Proxy OptionShowSolverLog)
+  ]
+
+newtype OptionShowSolverLog = OptionShowSolverLog Bool
+  deriving Typeable
+
+instance IsOption OptionShowSolverLog where
+  defaultValue   = OptionShowSolverLog False
+  parseValue     = fmap OptionShowSolverLog . safeRead
+  optionName     = return "show-solver-log"
+  optionHelp     = return "Show full log from the solver"
+  optionCLParser = flagCLParser Nothing (OptionShowSolverLog True)

From c178ef70d08610d066ea1148ec28bbcf52dd5434 Mon Sep 17 00:00:00 2001
From: Edsko de Vries <edsko@well-typed.com>
Date: Fri, 27 Mar 2015 16:44:10 +0000
Subject: [PATCH 12/28] Add Modular.Linking to other-modules

---
 cabal-install/cabal-install.cabal | 1 +
 1 file changed, 1 insertion(+)

diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal
index 583a79b35bd..647c066ae33 100644
--- a/cabal-install/cabal-install.cabal
+++ b/cabal-install/cabal-install.cabal
@@ -68,6 +68,7 @@ executable cabal
         Distribution.Client.Dependency.Modular.Flag
         Distribution.Client.Dependency.Modular.Index
         Distribution.Client.Dependency.Modular.IndexConversion
+        Distribution.Client.Dependency.Modular.Linking
         Distribution.Client.Dependency.Modular.Log
         Distribution.Client.Dependency.Modular.Message
         Distribution.Client.Dependency.Modular.Package

From ff890799f36a44dc19cb103d3195ae9d9ce70f65 Mon Sep 17 00:00:00 2001
From: Edsko de Vries <edsko@well-typed.com>
Date: Fri, 27 Mar 2015 18:18:48 +0000
Subject: [PATCH 13/28] Compatibility for 7.4 and 7.8

This address @23Skidoo's comment
https://github.com/haskell/cabal/pull/2500#issuecomment-8703532
---
 cabal-install/cabal-install.cabal                                | 1 +
 .../UnitTests/Distribution/Client/Dependency/Modular/Solver.hs   | 1 +
 2 files changed, 2 insertions(+)

diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal
index 647c066ae33..954644b8a03 100644
--- a/cabal-install/cabal-install.cabal
+++ b/cabal-install/cabal-install.cabal
@@ -203,6 +203,7 @@ Test-Suite unit-tests
         tasty,
         tasty-hunit,
         tasty-quickcheck,
+        tagged,
         QuickCheck >= 2.5
 
   if flag(old-directory)
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 b82d6ff29fc..9619f897fd4 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs
@@ -7,6 +7,7 @@ module UnitTests.Distribution.Client.Dependency.Modular.Solver (tests, options)
 import Control.Monad
 import Data.Maybe (catMaybes, isNothing)
 import Data.Either (partitionEithers)
+import Data.Proxy
 import Data.Typeable
 import Data.Version
 import qualified Data.Map as Map

From ac47cbc44d20c033b1cc6d0e5b9eede3f204f450 Mon Sep 17 00:00:00 2001
From: Edsko de Vries <edsko@well-typed.com>
Date: Sat, 28 Mar 2015 11:58:44 +0000
Subject: [PATCH 14/28] Use the standard graph construction code

I don't know why we we constructed this graph manually here rather than calling
`graphFromEdges`; it doesn't really matter except that we will want to change
the structure of this graph somewhat once we have more fine-grained
dependencies, and then the manual construction becomes a bit more painful;
easier to use the standard construction.
---
 .../Distribution/Client/PlanIndex.hs          | 35 ++++++++-----------
 1 file changed, 14 insertions(+), 21 deletions(-)

diff --git a/cabal-install/Distribution/Client/PlanIndex.hs b/cabal-install/Distribution/Client/PlanIndex.hs
index 4668d920330..ae489600c4e 100644
--- a/cabal-install/Distribution/Client/PlanIndex.hs
+++ b/cabal-install/Distribution/Client/PlanIndex.hs
@@ -24,11 +24,9 @@ import Prelude hiding (lookup)
 import qualified Data.Map as Map
 import qualified Data.Tree  as Tree
 import qualified Data.Graph as Graph
-import qualified Data.Array as Array
 import Data.Array ((!))
-import Data.List (sortBy)
 import Data.Map (Map)
-import Data.Maybe (isNothing, fromMaybe)
+import Data.Maybe (isNothing, fromMaybe, fromJust)
 import Data.Either (lefts)
 
 #if !MIN_VERSION_base(4,8,0)
@@ -41,8 +39,6 @@ import Distribution.Package
          )
 import Distribution.Version
          ( Version )
-import Distribution.Simple.Utils
-         ( comparing )
 
 import Distribution.Client.PackageIndex
          ( PackageFixedDeps(..) )
@@ -313,19 +309,16 @@ dependencyGraph :: (PackageFixedDeps pkg, HasInstalledPackageId pkg)
                     InstalledPackageId -> Maybe Graph.Vertex)
 dependencyGraph fakeMap index = (graph, vertexToPkg, idToVertex)
   where
-    graph = Array.listArray bounds
-              [ [ v | Just v <- map idToVertex (depends pkg) ]
-              | pkg <- pkgs ]
-
-    pkgs      = sortBy (comparing packageId) (allPackages index)
-    pkgTable  = Array.listArray bounds pkgs
-    bounds    = (0, topBound)
-    topBound  = length pkgs - 1
-    vertexToPkg vertex = pkgTable ! vertex
-
-    -- Old implementation used to use an array for vertices as well, with a
-    -- binary search algorithm. Not sure why this changed, but sticking with
-    -- this linear search for now.
-    vertices  = zip (map installedPackageId pkgs) [0..]
-    vertexMap = Map.fromList vertices
-    idToVertex pid = Map.lookup (Map.findWithDefault pid pid fakeMap) vertexMap
+    (graph, vertexToPkg', idToVertex) = Graph.graphFromEdges edges
+    vertexToPkg = fromJust
+                . (\((), key, _targets) -> lookupInstalledPackageId index key)
+                . vertexToPkg'
+
+    pkgs  = allPackages index
+    edges = map edgesFrom pkgs
+
+    resolve   pid = Map.findWithDefault pid pid fakeMap
+    edgesFrom pkg = ( ()
+                    , resolve (installedPackageId pkg)
+                    , fakeDepends fakeMap pkg
+                    )

From c2c73da936d295a6246f22bf30ef63da6ea8b12a Mon Sep 17 00:00:00 2001
From: Edsko de Vries <edsko@well-typed.com>
Date: Fri, 27 Mar 2015 16:39:19 +0000
Subject: [PATCH 15/28] Code layout

This commit does nothing but rearrange the Modular.Dependency module into a
number of separate sections, so that's a bit clearer to see what's what. No
actual code changes here whatsoever.
---
 .../Client/Dependency/Modular/Dependency.hs   | 126 ++++++++++++++----
 1 file changed, 97 insertions(+), 29 deletions(-)

diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs b/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs
index 31d841115ee..5282de4d71b 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs
@@ -1,5 +1,42 @@
 {-# LANGUAGE DeriveFunctor #-}
-module Distribution.Client.Dependency.Modular.Dependency where
+module Distribution.Client.Dependency.Modular.Dependency (
+    -- * Variables
+    Var(..)
+  , simplifyVar
+  , showVar
+    -- * Conflict sets
+  , ConflictSet
+  , showCS
+    -- * Constrained instances
+  , CI(..)
+  , showCI
+  , merge
+    -- * Flagged dependencies
+  , FlaggedDeps
+  , FlaggedDep(..)
+  , TrueFlaggedDeps
+  , FalseFlaggedDeps
+  , Dep(..)
+  , showDep
+    -- * Reverse dependency map
+  , RevDepMap
+    -- * Goals
+  , Goal(..)
+  , GoalReason(..)
+  , GoalReasonChain
+  , QGoalReasonChain
+  , ResetGoal(..)
+  , toConflictSet
+  , goalReasonToVars
+  , goalReasonChainToVars
+  , goalReasonChainsToVars
+    -- * Open goals
+  , OpenGoal(..)
+  , close
+    -- * Version ranges pairsed with origins (goals)
+  , VROrigin
+  , collapse
+  ) where
 
 import Prelude hiding (pi)
 
@@ -11,6 +48,10 @@ import Distribution.Client.Dependency.Modular.Flag
 import Distribution.Client.Dependency.Modular.Package
 import Distribution.Client.Dependency.Modular.Version
 
+{-------------------------------------------------------------------------------
+  Variables
+-------------------------------------------------------------------------------}
+
 -- | The type of variables that play a role in the solver.
 -- Note that the tree currently does not use this type directly,
 -- and rather has separate tree nodes for the different types of
@@ -37,11 +78,19 @@ showVar (P qpn) = showQPN qpn
 showVar (F qfn) = showQFN qfn
 showVar (S qsn) = showQSN qsn
 
+{-------------------------------------------------------------------------------
+  Conflict sets
+-------------------------------------------------------------------------------}
+
 type ConflictSet qpn = Set (Var qpn)
 
 showCS :: ConflictSet QPN -> String
 showCS = intercalate ", " . L.map showVar . S.toList
 
+{-------------------------------------------------------------------------------
+  Constrained instances
+-------------------------------------------------------------------------------}
+
 -- | Constrained instance. If the choice has already been made, this is
 -- a fixed instance, and we record the package name for which the choice
 -- is for convenience. Otherwise, it is a list of version ranges paired with
@@ -49,17 +98,6 @@ showCS = intercalate ", " . L.map showVar . S.toList
 data CI qpn = Fixed I (Goal qpn) | Constrained [VROrigin qpn]
   deriving (Eq, Show, Functor)
 
-instance ResetGoal CI where
-  resetGoal g (Fixed i _)       = Fixed i g
-  resetGoal g (Constrained vrs) = Constrained (L.map (\ (x, y) -> (x, resetGoal g y)) vrs)
-
-type VROrigin qpn = (VR, Goal qpn)
-
--- | Helper function to collapse a list of version ranges with origins into
--- a single, simplified, version range.
-collapse :: [VROrigin qpn] -> VR
-collapse = simplifyVR . L.foldr (.&&.) anyVR . L.map fst
-
 showCI :: CI QPN -> String
 showCI (Fixed i _)      = "==" ++ showI i
 showCI (Constrained vr) = showVR (collapse vr)
@@ -91,6 +129,9 @@ merge c@(Fixed (I v _) g1)   (Constrained rs) = go rs -- I tried "reverse rs" he
 merge c@(Constrained _)    d@(Fixed _ _)      = merge d c
 merge   (Constrained rs)     (Constrained ss) = Right (Constrained (rs ++ ss))
 
+{-------------------------------------------------------------------------------
+  Flagged dependencies
+-------------------------------------------------------------------------------}
 
 type FlaggedDeps qpn = [FlaggedDep qpn]
 
@@ -119,29 +160,23 @@ showDep (Dep qpn (Constrained [(vr, Goal v _)])) =
 showDep (Dep qpn ci                            ) =
   showQPN qpn ++ showCI ci
 
-instance ResetGoal Dep where
-  resetGoal g (Dep qpn ci) = Dep qpn (resetGoal g ci)
+{-------------------------------------------------------------------------------
+  Reverse dependency map
+-------------------------------------------------------------------------------}
 
 -- | A map containing reverse dependencies between qualified
 -- package names.
 type RevDepMap = Map QPN [QPN]
 
+{-------------------------------------------------------------------------------
+  Goals
+-------------------------------------------------------------------------------}
+
 -- | Goals are solver variables paired with information about
 -- why they have been introduced.
 data Goal qpn = Goal (Var qpn) (GoalReasonChain qpn)
   deriving (Eq, Show, Functor)
 
-class ResetGoal f where
-  resetGoal :: Goal qpn -> f qpn -> f qpn
-
-instance ResetGoal Goal where
-  resetGoal = const
-
--- | For open goals as they occur during the build phase, we need to store
--- additional information about flags.
-data OpenGoal = OpenGoal (FlaggedDep QPN) QGoalReasonChain
-  deriving (Eq, Show)
-
 -- | Reasons why a goal can be added to a goal set.
 data GoalReason qpn =
     UserGoal
@@ -156,6 +191,24 @@ type GoalReasonChain qpn = [GoalReason qpn]
 
 type QGoalReasonChain = GoalReasonChain QPN
 
+class ResetGoal f where
+  resetGoal :: Goal qpn -> f qpn -> f qpn
+
+instance ResetGoal CI where
+  resetGoal g (Fixed i _)       = Fixed i g
+  resetGoal g (Constrained vrs) = Constrained (L.map (\ (x, y) -> (x, resetGoal g y)) vrs)
+
+instance ResetGoal Dep where
+  resetGoal g (Dep qpn ci) = Dep qpn (resetGoal g ci)
+
+instance ResetGoal Goal where
+  resetGoal = const
+
+-- | Compute a conflic set from a goal. The conflict set contains the
+-- closure of goal reasons as well as the variable of the goal itself.
+toConflictSet :: Ord qpn => Goal qpn -> ConflictSet qpn
+toConflictSet (Goal g grs) = S.insert (simplifyVar g) (goalReasonChainToVars grs)
+
 goalReasonToVars :: GoalReason qpn -> ConflictSet qpn
 goalReasonToVars UserGoal                 = S.empty
 goalReasonToVars (PDependency (PI qpn _)) = S.singleton (P qpn)
@@ -168,6 +221,15 @@ goalReasonChainToVars = S.unions . L.map goalReasonToVars
 goalReasonChainsToVars :: Ord qpn => [GoalReasonChain qpn] -> ConflictSet qpn
 goalReasonChainsToVars = S.unions . L.map goalReasonChainToVars
 
+{-------------------------------------------------------------------------------
+  Open goals
+-------------------------------------------------------------------------------}
+
+-- | For open goals as they occur during the build phase, we need to store
+-- additional information about flags.
+data OpenGoal = OpenGoal (FlaggedDep QPN) QGoalReasonChain
+  deriving (Eq, Show)
+
 -- | Closes a goal, i.e., removes all the extraneous information that we
 -- need only during the build phase.
 close :: OpenGoal -> Goal QPN
@@ -175,7 +237,13 @@ close (OpenGoal (Simple (Dep qpn _)) gr) = Goal (P qpn) gr
 close (OpenGoal (Flagged qfn _ _ _ ) gr) = Goal (F qfn) gr
 close (OpenGoal (Stanza  qsn _)      gr) = Goal (S qsn) gr
 
--- | Compute a conflic set from a goal. The conflict set contains the
--- closure of goal reasons as well as the variable of the goal itself.
-toConflictSet :: Ord qpn => Goal qpn -> ConflictSet qpn
-toConflictSet (Goal g grs) = S.insert (simplifyVar g) (goalReasonChainToVars grs)
+{-------------------------------------------------------------------------------
+  Version ranges paired with origins
+-------------------------------------------------------------------------------}
+
+type VROrigin qpn = (VR, Goal qpn)
+
+-- | Helper function to collapse a list of version ranges with origins into
+-- a single, simplified, version range.
+collapse :: [VROrigin qpn] -> VR
+collapse = simplifyVR . L.foldr (.&&.) anyVR . L.map fst

From 601966737ae0b41c5c1b3d532ae49c7a8be8faa8 Mon Sep 17 00:00:00 2001
From: Edsko de Vries <edsko@well-typed.com>
Date: Tue, 24 Mar 2015 10:36:53 +0000
Subject: [PATCH 16/28] Introduce ComponentDeps

The ComponentDeps datatype will give us fine-grained information about the
dependencies of a package's components.  This commit just introduces the
datatype, we don't use it anywhere yet.
---
 .../Distribution/Client/ComponentDeps.hs      | 113 ++++++++++++++++++
 cabal-install/cabal-install.cabal             |   1 +
 2 files changed, 114 insertions(+)
 create mode 100644 cabal-install/Distribution/Client/ComponentDeps.hs

diff --git a/cabal-install/Distribution/Client/ComponentDeps.hs b/cabal-install/Distribution/Client/ComponentDeps.hs
new file mode 100644
index 00000000000..f6ee4d9a779
--- /dev/null
+++ b/cabal-install/Distribution/Client/ComponentDeps.hs
@@ -0,0 +1,113 @@
+-- | Fine-grained package dependencies
+--
+-- Like many others, this module is meant to be "double-imported":
+--
+-- > import Distribution.Client.ComponentDeps (
+-- >     Component
+-- >   , ComponentDep
+-- >   , ComponentDeps
+-- >   )
+-- > import qualified Distribution.Client.ComponentDeps as CD
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFunctor #-}
+module Distribution.Client.ComponentDeps (
+    -- * Fine-grained package dependencies
+    Component(..)
+  , ComponentDep
+  , ComponentDeps -- opaque
+    -- ** Constructing ComponentDeps
+  , empty
+  , fromList
+  , singleton
+  , insert
+  , fromLibraryDeps
+  , fromInstalled
+    -- ** Deconstructing ComponentDeps
+  , toList
+  , flatDeps
+  ) where
+
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Foldable (fold)
+
+#if !MIN_VERSION_base(4,8,0)
+import Data.Foldable (Foldable(foldMap))
+import Data.Monoid (Monoid(..))
+import Data.Traversable (Traversable(traverse))
+#endif
+
+{-------------------------------------------------------------------------------
+  Types
+-------------------------------------------------------------------------------}
+
+-- | Component of a package
+data Component =
+    ComponentLib
+  | ComponentExe   String
+  | ComponentTest  String
+  | ComponentBench String
+  deriving (Show, Eq, Ord)
+
+-- | Dependency for a single component
+type ComponentDep a = (Component, a)
+
+-- | Fine-grained dependencies for a package
+newtype ComponentDeps a = ComponentDeps { unComponentDeps :: Map Component a }
+  deriving (Show, Functor, Eq, Ord)
+
+instance Monoid a => Monoid (ComponentDeps a) where
+  mempty =
+    ComponentDeps Map.empty
+  (ComponentDeps d) `mappend` (ComponentDeps d') =
+    ComponentDeps (Map.unionWith mappend d d')
+
+instance Foldable ComponentDeps where
+  foldMap f = foldMap f . unComponentDeps
+
+instance Traversable ComponentDeps where
+  traverse f = fmap ComponentDeps . traverse f . unComponentDeps
+
+{-------------------------------------------------------------------------------
+  Construction
+-------------------------------------------------------------------------------}
+
+empty :: ComponentDeps a
+empty = ComponentDeps $ Map.empty
+
+fromList :: Monoid a => [ComponentDep a] -> ComponentDeps a
+fromList = ComponentDeps . Map.fromListWith mappend
+
+singleton :: Component -> a -> ComponentDeps a
+singleton comp = ComponentDeps . Map.singleton comp
+
+insert :: Monoid a => Component -> a -> ComponentDeps a -> ComponentDeps a
+insert comp a = ComponentDeps . Map.alter aux comp . unComponentDeps
+  where
+    aux Nothing   = Just a
+    aux (Just a') = Just $ a `mappend` a'
+
+-- | ComponentDeps containing library dependencies only
+fromLibraryDeps :: a -> ComponentDeps a
+fromLibraryDeps = singleton ComponentLib
+
+-- | ComponentDeps for installed packages
+--
+-- We assume that installed packages only record their library dependencies
+fromInstalled :: a -> ComponentDeps a
+fromInstalled = fromLibraryDeps
+
+{-------------------------------------------------------------------------------
+  Deconstruction
+-------------------------------------------------------------------------------}
+
+toList :: ComponentDeps a -> [ComponentDep a]
+toList = Map.toList . unComponentDeps
+
+-- | All dependencies of a package
+--
+-- This is just a synonym for 'fold', but perhaps a use of 'flatDeps' is more
+-- obvious than a use of 'fold', and moreover this avoids introducing lots of
+-- @#ifdef@s for 7.10 just for the use of 'fold'.
+flatDeps :: Monoid a => ComponentDeps a -> a
+flatDeps = fold
diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal
index 954644b8a03..8e54000c37d 100644
--- a/cabal-install/cabal-install.cabal
+++ b/cabal-install/cabal-install.cabal
@@ -51,6 +51,7 @@ executable cabal
         Distribution.Client.BuildReports.Types
         Distribution.Client.BuildReports.Upload
         Distribution.Client.Check
+        Distribution.Client.ComponentDeps
         Distribution.Client.Config
         Distribution.Client.Configure
         Distribution.Client.Dependency

From a5a823d47b44802e535dbdf3d225da706b78f3bf Mon Sep 17 00:00:00 2001
From: Edsko de Vries <edsko@well-typed.com>
Date: Fri, 27 Mar 2015 14:33:02 +0000
Subject: [PATCH 17/28] Fine-grained dependencies in solver input

The modular solver has its own representation for a package (PInfo). In this
commit we modify PInfo to keep track of the different kinds of dependencies.

This is a bit intricate because the solver also regards top-level goals as
dependencies, but of course those dependencies are not part of any 'component'
as such, unlike "real" dependencies. We model this by adding a type parameter
to FlaggedDeps and go which indicates whether or not we have component
information; crucially, underneath flag choices we _always_ have component
information available.

Consequently, the modular solver itself will not make use of the ComponentDeps
datatype (but only using the Component type, classifying components); we will
use ComponentDeps when we translate out of the results from the modular solver
into cabal-install's main datatypes.

We don't yet _return_ fine-grained dependencies from the solver; this will be
the subject of the next commit.
---
 .../Client/Dependency/Modular/Builder.hs      | 51 +++++++------
 .../Client/Dependency/Modular/Dependency.hs   | 73 ++++++++++++++++---
 .../Client/Dependency/Modular/Index.hs        |  4 +-
 .../Dependency/Modular/IndexConversion.hs     | 57 +++++++++------
 .../Client/Dependency/Modular/Linking.hs      | 17 +++--
 .../Client/Dependency/Modular/Preference.hs   |  8 +-
 .../Client/Dependency/Modular/Tree.hs         | 16 ++--
 .../Client/Dependency/Modular/Validate.hs     | 13 ++--
 8 files changed, 158 insertions(+), 81 deletions(-)

diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs b/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs
index 1a9bb2cd342..3c6e4b082e0 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs
@@ -27,38 +27,42 @@ import Distribution.Client.Dependency.Modular.Package
 import Distribution.Client.Dependency.Modular.PSQ as P
 import Distribution.Client.Dependency.Modular.Tree
 
+import Distribution.Client.ComponentDeps (Component)
+
 -- | The state needed during the build phase of the search tree.
 data BuildState = BS {
-  index :: Index,           -- ^ information about packages and their dependencies
-  rdeps :: RevDepMap,       -- ^ set of all package goals, completed and open, with reverse dependencies
-  open  :: PSQ OpenGoal (), -- ^ set of still open goals (flag and package goals)
-  next  :: BuildType        -- ^ kind of node to generate next
+  index :: Index,                -- ^ information about packages and their dependencies
+  rdeps :: RevDepMap,            -- ^ set of all package goals, completed and open, with reverse dependencies
+  open  :: PSQ (OpenGoal ()) (), -- ^ set of still open goals (flag and package goals)
+  next  :: BuildType             -- ^ kind of node to generate next
 }
 
 -- | Extend the set of open goals with the new goals listed.
 --
 -- We also adjust the map of overall goals, and keep track of the
 -- reverse dependencies of each of the goals.
-extendOpen :: QPN -> [OpenGoal] -> BuildState -> BuildState
+extendOpen :: QPN -> [OpenGoal Component] -> BuildState -> BuildState
 extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs
   where
-    go :: RevDepMap -> PSQ OpenGoal () -> [OpenGoal] -> BuildState
-    go g o []                                             = s { rdeps = g, open = o }
-    go g o (ng@(OpenGoal (Flagged _ _ _ _)    _gr) : ngs) = go g (cons ng () o) ngs
+    go :: RevDepMap -> PSQ (OpenGoal ()) () -> [OpenGoal Component] -> BuildState
+    go g o []                                               = s { rdeps = g, open = o }
+    go g o (ng@(OpenGoal (Flagged _ _ _ _)      _gr) : ngs) = go g (cons' ng () o) ngs
       -- Note: for 'Flagged' goals, we always insert, so later additions win.
       -- This is important, because in general, if a goal is inserted twice,
       -- the later addition will have better dependency information.
-    go g o (ng@(OpenGoal (Stanza  _   _  )    _gr) : ngs) = go g (cons ng () o) ngs
-    go g o (ng@(OpenGoal (Simple (Dep qpn _)) _gr) : ngs)
-      | qpn == qpn'                                       = go                       g              o  ngs
-                                       -- we ignore self-dependencies at this point; TODO: more care may be needed
-      | qpn `M.member` g                                  = go (M.adjust (qpn':) qpn g)             o  ngs
-      | otherwise                                         = go (M.insert qpn [qpn']  g) (cons ng () o) ngs
-                                       -- code above is correct; insert/adjust have different arg order
+    go g o (ng@(OpenGoal (Stanza  _   _  )      _gr) : ngs) = go g (cons' ng () o) ngs
+    go g o (ng@(OpenGoal (Simple (Dep qpn _) _) _gr) : ngs)
+      | qpn == qpn'       = go                       g               o  ngs
+          -- we ignore self-dependencies at this point; TODO: more care may be needed
+      | qpn `M.member` g  = go (M.adjust (qpn':) qpn g)              o  ngs
+      | otherwise         = go (M.insert qpn [qpn']  g) (cons' ng () o) ngs
+          -- code above is correct; insert/adjust have different arg order
+
+    cons' = cons . forgetCompOpenGoal
 
 -- | Given the current scope, qualify all the package names in the given set of
 -- dependencies and then extend the set of open goals accordingly.
-scopedExtendOpen :: QPN -> I -> QGoalReasonChain -> FlaggedDeps PN -> FlagInfo ->
+scopedExtendOpen :: QPN -> I -> QGoalReasonChain -> FlaggedDeps Component PN -> FlagInfo ->
                     BuildState -> BuildState
 scopedExtendOpen qpn@(Q pp _pn) i gr fdeps fdefs s = extendOpen qpn gs s
   where
@@ -87,7 +91,7 @@ scopedExtendOpen qpn@(Q pp _pn) i gr fdeps fdefs s = extendOpen qpn gs s
 -- | Datatype that encodes what to build next
 data BuildType =
     Goals                                  -- ^ build a goal choice node
-  | OneGoal OpenGoal                       -- ^ build a node for this goal
+  | OneGoal (OpenGoal ())                  -- ^ build a node for this goal
   | Instance QPN I PInfo QGoalReasonChain  -- ^ build a tree for a concrete instance
   deriving Show
 
@@ -109,7 +113,7 @@ build = ana go
     --
     -- For a package, we look up the instances available in the global info,
     -- and then handle each instance in turn.
-    go bs@(BS { index = idx, next = OneGoal (OpenGoal (Simple (Dep qpn@(Q _ pn) _)) gr) }) =
+    go bs@(BS { index = idx, next = OneGoal (OpenGoal (Simple (Dep qpn@(Q _ pn) _) _) gr) }) =
       case M.lookup pn idx of
         Nothing  -> FailF (toConflictSet (Goal (P qpn) gr)) (BuildFailureNotInIndex pn)
         Just pis -> PChoiceF qpn gr (P.fromList (L.map (\ (i, info) ->
@@ -149,9 +153,14 @@ build = ana go
 -- and computes the initial state and then the tree from there.
 buildTree :: Index -> Bool -> [PN] -> Tree QGoalReasonChain
 buildTree idx ind igs =
-    build (BS idx (M.fromList (L.map (\ qpn -> (qpn, []))                                                     qpns))
-                  (P.fromList (L.map (\ qpn -> (OpenGoal (Simple (Dep qpn (Constrained []))) [UserGoal], ())) qpns))
-                  Goals)
+    build BS {
+        index = idx
+      , rdeps = M.fromList (L.map (\ qpn -> (qpn, []))              qpns)
+      , open  = P.fromList (L.map (\ qpn -> (topLevelGoal qpn, ())) qpns)
+      , next  = Goals
+      }
   where
+    topLevelGoal qpn = OpenGoal (Simple (Dep qpn (Constrained [])) ()) [UserGoal]
+
     qpns | ind       = makeIndependent igs
          | otherwise = L.map (Q None) igs
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs b/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs
index 5282de4d71b..95d59f5ed0a 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs
@@ -18,6 +18,9 @@ module Distribution.Client.Dependency.Modular.Dependency (
   , FalseFlaggedDeps
   , Dep(..)
   , showDep
+    -- ** Setting/forgetting components
+  , forgetCompOpenGoal
+  , setCompFlaggedDeps
     -- * Reverse dependency map
   , RevDepMap
     -- * Goals
@@ -48,6 +51,8 @@ import Distribution.Client.Dependency.Modular.Flag
 import Distribution.Client.Dependency.Modular.Package
 import Distribution.Client.Dependency.Modular.Version
 
+import Distribution.Client.ComponentDeps (Component)
+
 {-------------------------------------------------------------------------------
   Variables
 -------------------------------------------------------------------------------}
@@ -133,18 +138,37 @@ merge   (Constrained rs)     (Constrained ss) = Right (Constrained (rs ++ ss))
   Flagged dependencies
 -------------------------------------------------------------------------------}
 
-type FlaggedDeps qpn = [FlaggedDep qpn]
+-- | Flagged dependencies
+--
+-- 'FlaggedDeps' is the modular solver's view of a packages dependencies:
+-- rather than having the dependencies indexed by component, each dependency
+-- defines what component it is in.
+--
+-- However, top-level goals are also modelled as dependencies, but of course
+-- these don't actually belong in any component of any package. Therefore, we
+-- parameterize 'FlaggedDeps' and derived datatypes with a type argument that
+-- specifies whether or not we have a component: we only ever instantiate this
+-- type argument with @()@ for top-level goals, or 'Component' for everything
+-- else (we could express this as a kind at the type-level, but that would
+-- require a very recent GHC).
+--
+-- Note however, crucially, that independent of the type parameters, the list
+-- of dependencies underneath a flag choice or stanza choices _always_ uses
+-- Component as the type argument. This is important: when we pick a value for
+-- a flag, we _must_ know what component the new dependencies belong to, or
+-- else we don't be able to construct fine-grained reverse dependencies.
+type FlaggedDeps comp qpn = [FlaggedDep comp qpn]
 
 -- | Flagged dependencies can either be plain dependency constraints,
 -- or flag-dependent dependency trees.
-data FlaggedDep qpn =
+data FlaggedDep comp qpn =
     Flagged (FN qpn) FInfo (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn)
   | Stanza  (SN qpn)       (TrueFlaggedDeps qpn)
-  | Simple (Dep qpn)
+  | Simple (Dep qpn) comp
   deriving (Eq, Show, Functor)
 
-type TrueFlaggedDeps  qpn = FlaggedDeps qpn
-type FalseFlaggedDeps qpn = FlaggedDeps qpn
+type TrueFlaggedDeps  qpn = FlaggedDeps Component qpn
+type FalseFlaggedDeps qpn = FlaggedDeps Component qpn
 
 -- | A dependency (constraint) associates a package name with a
 -- constrained instance.
@@ -160,6 +184,35 @@ showDep (Dep qpn (Constrained [(vr, Goal v _)])) =
 showDep (Dep qpn ci                            ) =
   showQPN qpn ++ showCI ci
 
+{-------------------------------------------------------------------------------
+  Setting/forgetting the Component
+-------------------------------------------------------------------------------}
+
+forgetCompOpenGoal :: OpenGoal Component -> OpenGoal ()
+forgetCompOpenGoal = mapCompOpenGoal $ const ()
+
+setCompFlaggedDeps :: Component -> FlaggedDeps () qpn -> FlaggedDeps Component qpn
+setCompFlaggedDeps = mapCompFlaggedDeps . const
+
+{-------------------------------------------------------------------------------
+  Auxiliary: Mapping over the Component goal
+
+  We don't export these, because the only type instantiations for 'a' and 'b'
+  here should be () or Component. (We could express this at the type level
+  if we relied on newer versions of GHC.)
+-------------------------------------------------------------------------------}
+
+mapCompOpenGoal :: (a -> b) -> OpenGoal a -> OpenGoal b
+mapCompOpenGoal g (OpenGoal d gr) = OpenGoal (mapCompFlaggedDep g d) gr
+
+mapCompFlaggedDeps :: (a -> b) -> FlaggedDeps a qpn -> FlaggedDeps b qpn
+mapCompFlaggedDeps = L.map . mapCompFlaggedDep
+
+mapCompFlaggedDep :: (a -> b) -> FlaggedDep a qpn -> FlaggedDep b qpn
+mapCompFlaggedDep _ (Flagged fn nfo t f) = Flagged fn nfo   t f
+mapCompFlaggedDep _ (Stanza  sn     t  ) = Stanza  sn       t
+mapCompFlaggedDep g (Simple  pn a      ) = Simple  pn (g a)
+
 {-------------------------------------------------------------------------------
   Reverse dependency map
 -------------------------------------------------------------------------------}
@@ -227,15 +280,15 @@ goalReasonChainsToVars = S.unions . L.map goalReasonChainToVars
 
 -- | For open goals as they occur during the build phase, we need to store
 -- additional information about flags.
-data OpenGoal = OpenGoal (FlaggedDep QPN) QGoalReasonChain
+data OpenGoal comp = OpenGoal (FlaggedDep comp QPN) QGoalReasonChain
   deriving (Eq, Show)
 
 -- | Closes a goal, i.e., removes all the extraneous information that we
 -- need only during the build phase.
-close :: OpenGoal -> Goal QPN
-close (OpenGoal (Simple (Dep qpn _)) gr) = Goal (P qpn) gr
-close (OpenGoal (Flagged qfn _ _ _ ) gr) = Goal (F qfn) gr
-close (OpenGoal (Stanza  qsn _)      gr) = Goal (S qsn) gr
+close :: OpenGoal comp -> Goal QPN
+close (OpenGoal (Simple (Dep qpn _) _) gr) = Goal (P qpn) gr
+close (OpenGoal (Flagged qfn _ _ _ )   gr) = Goal (F qfn) gr
+close (OpenGoal (Stanza  qsn _)        gr) = Goal (S qsn) gr
 
 {-------------------------------------------------------------------------------
   Version ranges paired with origins
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Index.hs b/cabal-install/Distribution/Client/Dependency/Modular/Index.hs
index ac3450379a7..9af767aa971 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Index.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Index.hs
@@ -9,6 +9,8 @@ import Distribution.Client.Dependency.Modular.Flag
 import Distribution.Client.Dependency.Modular.Package
 import Distribution.Client.Dependency.Modular.Tree
 
+import Distribution.Client.ComponentDeps (Component)
+
 -- | An index contains information about package instances. This is a nested
 -- dictionary. Package names are mapped to instances, which in turn is mapped
 -- to info.
@@ -20,7 +22,7 @@ type Index = Map PN (Map I PInfo)
 -- globally, for reasons external to the solver. We currently use this
 -- for shadowing which essentially is a GHC limitation, and for
 -- installed packages that are broken.
-data PInfo = PInfo (FlaggedDeps PN) FlagInfo (Maybe FailReason)
+data PInfo = PInfo (FlaggedDeps Component PN) FlagInfo (Maybe FailReason)
   deriving (Show)
 
 mkIndex :: [(PN, I, PInfo)] -> Index
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs b/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs
index 53b5a46a4db..681a6d30144 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs
@@ -21,6 +21,8 @@ import Distribution.Client.Dependency.Modular.Package
 import Distribution.Client.Dependency.Modular.Tree
 import Distribution.Client.Dependency.Modular.Version
 
+import Distribution.Client.ComponentDeps (Component(..))
+
 -- | Convert both the installed package index and the source package
 -- index into one uniform solver index.
 --
@@ -62,8 +64,11 @@ convIP idx ipi =
       i = I (pkgVersion (sourcePackageId ipi)) (Inst ipid)
       pn = pkgName (sourcePackageId ipi)
   in  case mapM (convIPId pn idx) (IPI.depends ipi) of
-        Nothing  -> (pn, i, PInfo []  M.empty (Just Broken))
-        Just fds -> (pn, i, PInfo fds M.empty Nothing)
+        Nothing  -> (pn, i, PInfo []            M.empty (Just Broken))
+        Just fds -> (pn, i, PInfo (setComp fds) M.empty Nothing)
+ where
+  -- We assume that all dependencies of installed packages are _library_ deps
+  setComp = setCompFlaggedDeps ComponentLib
 -- TODO: Installed packages should also store their encapsulations!
 
 -- | Convert dependencies specified by an installed package id into
@@ -72,13 +77,13 @@ convIP idx ipi =
 -- May return Nothing if the package can't be found in the index. That
 -- indicates that the original package having this dependency is broken
 -- and should be ignored.
-convIPId :: PN -> SI.InstalledPackageIndex -> InstalledPackageId -> Maybe (FlaggedDep PN)
+convIPId :: PN -> SI.InstalledPackageIndex -> InstalledPackageId -> Maybe (FlaggedDep () PN)
 convIPId pn' idx ipid =
   case SI.lookupInstalledPackageId idx ipid of
     Nothing  -> Nothing
     Just ipi -> let i = I (pkgVersion (sourcePackageId ipi)) (Inst ipid)
                     pn = pkgName (sourcePackageId ipi)
-                in  Just (D.Simple (Dep pn (Fixed i (Goal (P pn') []))))
+                in  Just (D.Simple (Dep pn (Fixed i (Goal (P pn') []))) ())
 
 -- | Convert a cabal-install source package index to the simpler,
 -- more uniform index format of the solver.
@@ -101,27 +106,25 @@ convSP os arch cinfo strfl (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) =
 -- want to keep the condition tree, but simplify much of the test.
 
 -- | Convert a generic package description to a solver-specific 'PInfo'.
---
--- TODO: We currently just take all dependencies from all specified library,
--- executable and test components. This does not quite seem fair.
 convGPD :: OS -> Arch -> CompilerInfo -> Bool ->
            PI PN -> GenericPackageDescription -> PInfo
 convGPD os arch comp strfl pi
         (GenericPackageDescription _ flags libs exes tests benchs) =
   let
-    fds = flagInfo strfl flags
+    fds  = flagInfo strfl flags
+    conv = convCondTree os arch comp pi fds (const True)
   in
     PInfo
-      (maybe []    (convCondTree os arch comp pi fds (const True)          ) libs    ++
-       concatMap   (convCondTree os arch comp pi fds (const True)     . snd) exes    ++
+      (maybe []    (conv ComponentLib                       ) libs    ++
+       concatMap   (\(nm, ds) -> conv (ComponentExe nm)   ds) exes    ++
       prefix (Stanza (SN pi TestStanzas))
-        (L.map     (convCondTree os arch comp pi fds (const True)     . snd) tests)  ++
+        (L.map     (\(nm, ds) -> conv (ComponentTest nm)  ds) tests)  ++
       prefix (Stanza (SN pi BenchStanzas))
-        (L.map     (convCondTree os arch comp pi fds (const True)     . snd) benchs))
+        (L.map     (\(nm, ds) -> conv (ComponentBench nm) ds) benchs))
       fds
       Nothing
 
-prefix :: (FlaggedDeps qpn -> FlaggedDep qpn) -> [FlaggedDeps qpn] -> FlaggedDeps qpn
+prefix :: (FlaggedDeps comp qpn -> FlaggedDep comp' qpn) -> [FlaggedDeps comp qpn] -> FlaggedDeps comp' qpn
 prefix _ []  = []
 prefix f fds = [f (concat fds)]
 
@@ -133,10 +136,11 @@ flagInfo strfl = M.fromList . L.map (\ (MkFlag fn _ b m) -> (fn, FInfo b m (not
 -- | Convert condition trees to flagged dependencies.
 convCondTree :: OS -> Arch -> CompilerInfo -> PI PN -> FlagInfo ->
                 (a -> Bool) -> -- how to detect if a branch is active
-                CondTree ConfVar [Dependency] a -> FlaggedDeps PN
-convCondTree os arch comp pi@(PI pn _) fds p (CondNode info ds branches)
-  | p info    = L.map (D.Simple . convDep pn) ds  -- unconditional dependencies
-              ++ concatMap (convBranch os arch comp pi fds p) branches
+                Component ->
+                CondTree ConfVar [Dependency] a -> FlaggedDeps Component PN
+convCondTree os arch cinfo pi@(PI pn _) fds p comp (CondNode info ds branches)
+  | p info    = L.map (\d -> D.Simple (convDep pn d) comp) ds  -- unconditional dependencies
+              ++ concatMap (convBranch os arch cinfo pi fds p comp) branches
   | otherwise = []
 
 -- | Branch interpreter.
@@ -150,15 +154,16 @@ convCondTree os arch comp pi@(PI pn _) fds p (CondNode info ds branches)
 convBranch :: OS -> Arch -> CompilerInfo ->
               PI PN -> FlagInfo ->
               (a -> Bool) -> -- how to detect if a branch is active
+              Component ->
               (Condition ConfVar,
                CondTree ConfVar [Dependency] a,
-               Maybe (CondTree ConfVar [Dependency] a)) -> FlaggedDeps PN
-convBranch os arch cinfo pi fds p (c', t', mf') =
-  go c' (          convCondTree os arch cinfo pi fds p   t')
-        (maybe [] (convCondTree os arch cinfo pi fds p) mf')
+               Maybe (CondTree ConfVar [Dependency] a)) -> FlaggedDeps Component PN
+convBranch os arch cinfo pi fds p comp (c', t', mf') =
+  go c' (          convCondTree os arch cinfo pi fds p comp   t')
+        (maybe [] (convCondTree os arch cinfo pi fds p comp) mf')
   where
     go :: Condition ConfVar ->
-          FlaggedDeps PN -> FlaggedDeps PN -> FlaggedDeps PN
+          FlaggedDeps Component PN -> FlaggedDeps Component PN -> FlaggedDeps Component PN
     go (Lit True)  t _ = t
     go (Lit False) _ f = f
     go (CNot c)    t f = go c f t
@@ -187,8 +192,12 @@ convBranch os arch cinfo pi fds p (c', t', mf') =
     -- with deferring flag choices will then usually first resolve this package,
     -- and try an already installed version before imposing a default flag choice
     -- that might not be what we want.
-    extractCommon :: FlaggedDeps PN -> FlaggedDeps PN -> FlaggedDeps PN
-    extractCommon ps ps' = [ D.Simple (Dep pn (Constrained [])) | D.Simple (Dep pn _) <- ps, D.Simple (Dep pn' _) <- ps', pn == pn' ]
+    extractCommon :: FlaggedDeps Component PN -> FlaggedDeps Component PN -> FlaggedDeps Component PN
+    extractCommon ps ps' = [ D.Simple (Dep pn (Constrained [])) comp
+                           | D.Simple (Dep pn  _) _ <- ps
+                           , D.Simple (Dep pn' _) _ <- ps'
+                           , pn == pn'
+                           ]
 
 -- | Convert a Cabal dependency to a solver-specific dependency.
 convDep :: PN -> Dependency -> Dep PN
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Linking.hs b/cabal-install/Distribution/Client/Dependency/Modular/Linking.hs
index b9b5aea078c..9a394ac5bf0 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Linking.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Linking.hs
@@ -30,6 +30,7 @@ import Distribution.Client.Dependency.Modular.Tree
 import qualified Distribution.Client.Dependency.Modular.PSQ as P
 
 import Distribution.Client.Types (OptionalStanza(..))
+import Distribution.Client.ComponentDeps (Component)
 
 {-------------------------------------------------------------------------------
   Add linking
@@ -167,7 +168,7 @@ conflict = lift' . Left
 execUpdateState :: UpdateState () -> ValidateState -> Either Conflict ValidateState
 execUpdateState = execStateT . unUpdateState
 
-pickPOption :: QPN -> POption -> FlaggedDeps QPN -> UpdateState ()
+pickPOption :: QPN -> POption -> FlaggedDeps comp QPN -> UpdateState ()
 pickPOption qpn (POption i Nothing)    _deps = pickConcrete qpn i
 pickPOption qpn (POption i (Just pp'))  deps = pickLink     qpn i pp' deps
 
@@ -185,7 +186,7 @@ pickConcrete qpn@(Q pp _) i = do
       Just lg ->
         makeCanonical lg qpn
 
-pickLink :: QPN -> I -> PP -> FlaggedDeps QPN -> UpdateState ()
+pickLink :: QPN -> I -> PP -> FlaggedDeps comp QPN -> UpdateState ()
 pickLink qpn@(Q _ pn) i pp' deps = do
     vs <- get
     -- Find the link group for the package we are linking to, and add this package
@@ -211,11 +212,11 @@ makeCanonical lg qpn@(Q pp _) =
         let lg' = lg { lgCanon = Just pp }
         updateLinkGroup lg'
 
-linkDeps :: [Var QPN] -> PP -> FlaggedDeps QPN -> UpdateState ()
+linkDeps :: [Var QPN] -> PP -> FlaggedDeps comp QPN -> UpdateState ()
 linkDeps parents pp' = mapM_ go
   where
-    go :: FlaggedDep QPN -> UpdateState ()
-    go (Simple (Dep qpn@(Q _ pn) _)) = do
+    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
@@ -258,11 +259,11 @@ linkNewDeps var b = do
         linkedTo                = S.delete pp (lgMembers lg)
     forM_ (S.toList linkedTo) $ \pp' -> linkDeps (P qpn : parents) pp' newDeps
   where
-    findNewDeps :: ValidateState -> FlaggedDeps QPN -> ([Var QPN], FlaggedDeps QPN)
+    findNewDeps :: ValidateState -> FlaggedDeps comp QPN -> ([Var QPN], FlaggedDeps Component QPN)
     findNewDeps vs = concatMapUnzip (findNewDeps' vs)
 
-    findNewDeps' :: ValidateState -> FlaggedDep QPN -> ([Var QPN], FlaggedDeps QPN)
-    findNewDeps' _  (Simple _)          = ([], [])
+    findNewDeps' :: ValidateState -> FlaggedDep comp QPN -> ([Var QPN], FlaggedDeps Component QPN)
+    findNewDeps' _  (Simple _ _)        = ([], [])
     findNewDeps' vs (Flagged qfn _ t f) =
       case (F qfn == var, M.lookup qfn (vsFlags vs)) of
         (True, _)    -> ([F qfn], if b then t else f)
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs b/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
index 8e8b98dba65..eb45b1b0435 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
@@ -254,10 +254,10 @@ preferBaseGoalChoice = trav go
     go (GoalChoiceF xs) = GoalChoiceF (P.sortByKeys preferBase xs)
     go x                = x
 
-    preferBase :: OpenGoal -> OpenGoal -> Ordering
-    preferBase (OpenGoal (Simple (Dep (Q _pp pn) _)) _) _ | unPN pn == "base" = LT
-    preferBase _ (OpenGoal (Simple (Dep (Q _pp pn) _)) _) | unPN pn == "base" = GT
-    preferBase _ _                                                            = EQ
+    preferBase :: OpenGoal comp -> OpenGoal comp -> Ordering
+    preferBase (OpenGoal (Simple (Dep (Q _pp pn) _) _) _) _ | unPN pn == "base" = LT
+    preferBase _ (OpenGoal (Simple (Dep (Q _pp pn) _) _) _) | unPN pn == "base" = GT
+    preferBase _ _                                                              = EQ
 
 -- | Transformation that sorts choice nodes so that
 -- child nodes with a small branching degree are preferred. As a
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs b/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs
index cdcd5760e79..307af38fc32 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs
@@ -14,10 +14,10 @@ import Distribution.Client.Dependency.Modular.Version
 
 -- | Type of the search tree. Inlining the choice nodes for now.
 data Tree a =
-    PChoice     QPN a           (PSQ POption  (Tree a))
-  | FChoice     QFN a Bool Bool (PSQ Bool     (Tree a)) -- Bool indicates whether it's weak/trivial, second Bool whether it's manual
-  | SChoice     QSN a Bool      (PSQ Bool     (Tree a)) -- Bool indicates whether it's trivial
-  | GoalChoice                  (PSQ OpenGoal (Tree a)) -- PSQ should never be empty
+    PChoice     QPN a           (PSQ POption       (Tree a))
+  | FChoice     QFN a Bool Bool (PSQ Bool          (Tree a)) -- Bool indicates whether it's weak/trivial, second Bool whether it's manual
+  | SChoice     QSN a Bool      (PSQ Bool          (Tree a)) -- Bool indicates whether it's trivial
+  | GoalChoice                  (PSQ (OpenGoal ()) (Tree a)) -- PSQ should never be empty
   | Done        RevDepMap
   | Fail        (ConflictSet QPN) FailReason
   deriving (Eq, Show, Functor)
@@ -57,10 +57,10 @@ data FailReason = InconsistentInitialConstraints
 
 -- | Functor for the tree type.
 data TreeF a b =
-    PChoiceF    QPN a           (PSQ POption  b)
-  | FChoiceF    QFN a Bool Bool (PSQ Bool     b)
-  | SChoiceF    QSN a Bool      (PSQ Bool     b)
-  | GoalChoiceF                 (PSQ OpenGoal b)
+    PChoiceF    QPN a           (PSQ POption       b)
+  | FChoiceF    QFN a Bool Bool (PSQ Bool          b)
+  | SChoiceF    QSN a Bool      (PSQ Bool          b)
+  | GoalChoiceF                 (PSQ (OpenGoal ()) b)
   | DoneF       RevDepMap
   | FailF       (ConflictSet QPN) FailReason
   deriving (Functor, Foldable, Traversable)
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs b/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs
index c28700e142b..4d96bf280f7 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs
@@ -21,6 +21,8 @@ import Distribution.Client.Dependency.Modular.Package
 import Distribution.Client.Dependency.Modular.PSQ as P
 import Distribution.Client.Dependency.Modular.Tree
 
+import Distribution.Client.ComponentDeps (Component)
+
 -- In practice, most constraints are implication constraints (IF we have made
 -- a number of choices, THEN we also have to ensure that). We call constraints
 -- that for which the preconditions are fulfilled ACTIVE. We maintain a set
@@ -74,7 +76,7 @@ import Distribution.Client.Dependency.Modular.Tree
 -- | The state needed during validation.
 data ValidateState = VS {
   index :: Index,
-  saved :: Map QPN (FlaggedDeps QPN), -- saved, scoped, dependencies
+  saved :: Map QPN (FlaggedDeps Component QPN), -- saved, scoped, dependencies
   pa    :: PreAssignment
 }
 
@@ -188,11 +190,11 @@ validate = cata go
 -- | We try to extract as many concrete dependencies from the given flagged
 -- dependencies as possible. We make use of all the flag knowledge we have
 -- already acquired.
-extractDeps :: FAssignment -> SAssignment -> FlaggedDeps QPN -> [Dep QPN]
+extractDeps :: FAssignment -> SAssignment -> FlaggedDeps comp QPN -> [Dep QPN]
 extractDeps fa sa deps = do
   d <- deps
   case d of
-    Simple sd           -> return sd
+    Simple sd _         -> return sd
     Flagged qfn _ td fd -> case M.lookup qfn fa of
                              Nothing    -> mzero
                              Just True  -> extractDeps fa sa td
@@ -205,13 +207,14 @@ extractDeps fa sa deps = do
 -- | We try to find new dependencies that become available due to the given
 -- flag or stanza choice. We therefore look for the choice in question, and then call
 -- 'extractDeps' for everything underneath.
-extractNewDeps :: Var QPN -> QGoalReasonChain -> Bool -> FAssignment -> SAssignment -> FlaggedDeps QPN -> [Dep QPN]
+extractNewDeps :: Var QPN -> QGoalReasonChain -> Bool -> FAssignment -> SAssignment -> FlaggedDeps comp QPN -> [Dep QPN]
 extractNewDeps v gr b fa sa = go
   where
+    go :: FlaggedDeps comp QPN -> [Dep QPN] -- Type annotation necessary (polymorphic recursion)
     go deps = do
       d <- deps
       case d of
-        Simple _             -> mzero
+        Simple _ _           -> mzero
         Flagged qfn' _ td fd
           | v == F qfn'      -> L.map (resetGoal (Goal v gr)) $
                                 if b then extractDeps fa sa td else extractDeps fa sa fd

From 6b77ea23129f8c91d3f1a3dd5d7103b2bbe811b9 Mon Sep 17 00:00:00 2001
From: Edsko de Vries <edsko@well-typed.com>
Date: Sat, 28 Mar 2015 09:50:04 +0000
Subject: [PATCH 18/28] Fine-grained dependencies in solver output

In this commit we modify the _output_ of the modular solver (CP, the modular's
solver internal version of ConfiguredPackage) to have fine-grained dependency.
This doesn't yet modify the rest of cabal-install, so once we translate from CP
to ConfiguredPackage we still lose the distinctions between different kinds of
dependencies; this will be the topic of the next commit.

In the modular solver (and elsewhere) we use Data.Graph to represent the
dependency graph (and the reverse dependency graph). However, now that we have
more fine-grained dependencies, we really want an _edge-labeled_ graph, which
unfortunately it not available in the `containers` package. Therefore I've
written a very simple wrapper around Data.Graph that supports edge labels; we
don't need many fancy graph algorithms, and can still use Data.Graph on these
edged graphs when we want (by calling them on the underlying unlabeled graph),
so adding a dependency on `fgl` does not seem worth it.
---
 .../Client/Dependency/Modular/Assignment.hs   |  25 ++--
 .../Client/Dependency/Modular/Builder.hs      |  13 +-
 .../Client/Dependency/Modular/Configured.hs   |   3 +-
 .../Modular/ConfiguredConversion.hs           |   4 +-
 .../Client/Dependency/Modular/Dependency.hs   |   2 +-
 .../Dependency/Modular/IndexConversion.hs     |  11 +-
 .../Client/Dependency/Modular/Package.hs      |   2 +
 .../Distribution/Client/Utils/LabeledGraph.hs | 114 ++++++++++++++++++
 cabal-install/cabal-install.cabal             |   1 +
 9 files changed, 153 insertions(+), 22 deletions(-)
 create mode 100644 cabal-install/Distribution/Client/Utils/LabeledGraph.hs

diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Assignment.hs b/cabal-install/Distribution/Client/Dependency/Modular/Assignment.hs
index 91db3c1279c..e5a5080a374 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Assignment.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Assignment.hs
@@ -6,11 +6,13 @@ import Data.Array as A
 import Data.List as L
 import Data.Map as M
 import Data.Maybe
-import Data.Graph
 import Prelude hiding (pi)
 
 import Distribution.PackageDescription (FlagAssignment) -- from Cabal
 import Distribution.Client.Types (OptionalStanza)
+import Distribution.Client.Utils.LabeledGraph
+import Distribution.Client.ComponentDeps (ComponentDeps, Component)
+import qualified Distribution.Client.ComponentDeps as CD
 
 import Distribution.Client.Dependency.Modular.Configured
 import Distribution.Client.Dependency.Modular.Dependency
@@ -77,13 +79,13 @@ toCPs :: Assignment -> RevDepMap -> [CP QPN]
 toCPs (A pa fa sa) rdm =
   let
     -- get hold of the graph
-    g   :: Graph
-    vm  :: Vertex -> ((), QPN, [QPN])
+    g   :: Graph Component
+    vm  :: Vertex -> ((), QPN, [(Component, QPN)])
     cvm :: QPN -> Maybe Vertex
     -- Note that the RevDepMap contains duplicate dependencies. Therefore the nub.
     (g, vm, cvm) = graphFromEdges (L.map (\ (x, xs) -> ((), x, nub xs))
                                   (M.toList rdm))
-    tg :: Graph
+    tg :: Graph Component
     tg = transposeG g
     -- Topsort the dependency graph, yielding a list of pkgs in the right order.
     -- The graph will still contain all the installed packages, and it might
@@ -106,17 +108,20 @@ toCPs (A pa fa sa) rdm =
            M.toList $
            sa
     -- Dependencies per package.
-    depp :: QPN -> [PI QPN]
+    depp :: QPN -> [(Component, PI QPN)]
     depp qpn = let v :: Vertex
                    v   = fromJust (cvm qpn)
-                   dvs :: [Vertex]
+                   dvs :: [(Component, Vertex)]
                    dvs = tg A.! v
-               in L.map (\ dv -> case vm dv of (_, x, _) -> PI x (pa M.! x)) dvs
+               in L.map (\ (comp, dv) -> case vm dv of (_, x, _) -> (comp, PI x (pa M.! x))) dvs
+    -- Translated to PackageDeps
+    depp' :: QPN -> ComponentDeps [PI QPN]
+    depp' = CD.fromList . L.map (\(comp, d) -> (comp, [d])) . depp
   in
     L.map (\ pi@(PI qpn _) -> CP pi
                                  (M.findWithDefault [] qpn fapp)
                                  (M.findWithDefault [] qpn sapp)
-                                 (depp qpn))
+                                 (depp' qpn))
           ps
 
 -- | Finalize an assignment and a reverse dependency map.
@@ -126,8 +131,8 @@ finalize :: Index -> Assignment -> RevDepMap -> IO ()
 finalize idx (A pa fa _) rdm =
   let
     -- get hold of the graph
-    g  :: Graph
-    vm :: Vertex -> ((), QPN, [QPN])
+    g  :: Graph Component
+    vm :: Vertex -> ((), QPN, [(Component, QPN)])
     (g, vm) = graphFromEdges' (L.map (\ (x, xs) -> ((), x, xs)) (M.toList rdm))
     -- topsort the dependency graph, yielding a list of pkgs in the right order
     f :: [PI QPN]
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs b/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs
index 3c6e4b082e0..84cc3d4a0b3 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 module Distribution.Client.Dependency.Modular.Builder (buildTree) where
 
 -- Building the search tree.
@@ -51,11 +52,11 @@ extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs
       -- This is important, because in general, if a goal is inserted twice,
       -- the later addition will have better dependency information.
     go g o (ng@(OpenGoal (Stanza  _   _  )      _gr) : ngs) = go g (cons' ng () o) ngs
-    go g o (ng@(OpenGoal (Simple (Dep qpn _) _) _gr) : ngs)
-      | qpn == qpn'       = go                       g               o  ngs
+    go g o (ng@(OpenGoal (Simple (Dep qpn _) c) _gr) : ngs)
+      | qpn == qpn'       = go                            g               o  ngs
           -- we ignore self-dependencies at this point; TODO: more care may be needed
-      | qpn `M.member` g  = go (M.adjust (qpn':) qpn g)              o  ngs
-      | otherwise         = go (M.insert qpn [qpn']  g) (cons' ng () o) ngs
+      | qpn `M.member` g  = go (M.adjust ((c, qpn'):) qpn g)              o  ngs
+      | otherwise         = go (M.insert qpn [(c, qpn')]  g) (cons' ng () o) ngs
           -- code above is correct; insert/adjust have different arg order
 
     cons' = cons . forgetCompOpenGoal
@@ -67,7 +68,7 @@ scopedExtendOpen :: QPN -> I -> QGoalReasonChain -> FlaggedDeps Component PN ->
 scopedExtendOpen qpn@(Q pp _pn) i gr fdeps fdefs s = extendOpen qpn gs s
   where
     -- Qualify all package names
-    qfdeps = L.map (fmap (Q pp)) fdeps -- qualify all the package names
+    qfdeps = L.map (fmap (Q pp)) fdeps
     -- Introduce all package flags
     qfdefs = L.map (\ (fn, b) -> Flagged (FN (PI qpn i) fn) b [] []) $ M.toList fdefs
     -- Combine new package and flag goals
@@ -136,7 +137,7 @@ build = ana go
 
     go bs@(BS { next = OneGoal (OpenGoal (Stanza qsn@(SN (PI qpn _) _) t) gr) }) =
       SChoiceF qsn gr trivial (P.fromList
-        [(False,                                                                        bs  { next = Goals }),
+        [(False,                                                                  bs  { next = Goals }),
          (True,  (extendOpen qpn (L.map (flip OpenGoal (SDependency qsn : gr)) t) bs) { next = Goals })])
       where
         trivial = L.null t
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Configured.hs b/cabal-install/Distribution/Client/Dependency/Modular/Configured.hs
index d6f2bc28dbe..0d7f2301549 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Configured.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Configured.hs
@@ -2,9 +2,10 @@ module Distribution.Client.Dependency.Modular.Configured where
 
 import Distribution.PackageDescription (FlagAssignment) -- from Cabal
 import Distribution.Client.Types (OptionalStanza)
+import Distribution.Client.ComponentDeps (ComponentDeps)
 
 import Distribution.Client.Dependency.Modular.Package
 
 -- | A configured package is a package instance together with
 -- a flag assignment and complete dependencies.
-data CP qpn = CP (PI qpn) FlagAssignment [OptionalStanza] [PI qpn]
+data CP qpn = CP (PI qpn) FlagAssignment [OptionalStanza] (ComponentDeps [PI qpn])
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs b/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs
index 405c69bcdce..6121db82d6f 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs
@@ -13,6 +13,8 @@ import Distribution.System
 import Distribution.Client.Dependency.Modular.Configured
 import Distribution.Client.Dependency.Modular.Package
 
+import qualified Distribution.Client.ComponentDeps as CD
+
 mkPlan :: Platform -> CompilerInfo -> Bool ->
           SI.InstalledPackageIndex -> CI.PackageIndex SourcePackage ->
           [CP QPN] -> Either [PlanProblem] InstallPlan
@@ -33,7 +35,7 @@ convCP iidx sidx (CP qpi fa es ds) =
                   ds'
   where
     ds' :: [ConfiguredId]
-    ds' = map convConfId ds
+    ds' = CD.flatDeps $ fmap (map convConfId) ds
 
 convPI :: PI QPN -> Either InstalledPackageId PackageId
 convPI (PI _ (I _ (Inst pi))) = Left pi
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs b/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs
index 95d59f5ed0a..6f39d85e5c8 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs
@@ -219,7 +219,7 @@ mapCompFlaggedDep g (Simple  pn a      ) = Simple  pn (g a)
 
 -- | A map containing reverse dependencies between qualified
 -- package names.
-type RevDepMap = Map QPN [QPN]
+type RevDepMap = Map QPN [(Component, QPN)]
 
 {-------------------------------------------------------------------------------
   Goals
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs b/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs
index 681a6d30144..47d4538c0a2 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs
@@ -1,4 +1,10 @@
-module Distribution.Client.Dependency.Modular.IndexConversion where
+module Distribution.Client.Dependency.Modular.IndexConversion (
+    convPIs
+    -- * TODO: The following don't actually seem to be used anywhere?
+  , convIPI
+  , convSPI
+  , convPI
+  ) where
 
 import Data.List as L
 import Data.Map as M
@@ -7,6 +13,7 @@ import Prelude hiding (pi)
 
 import qualified Distribution.Client.PackageIndex as CI
 import Distribution.Client.Types
+import Distribution.Client.ComponentDeps (Component(..))
 import Distribution.Compiler
 import Distribution.InstalledPackageInfo as IPI
 import Distribution.Package                          -- from Cabal
@@ -21,8 +28,6 @@ import Distribution.Client.Dependency.Modular.Package
 import Distribution.Client.Dependency.Modular.Tree
 import Distribution.Client.Dependency.Modular.Version
 
-import Distribution.Client.ComponentDeps (Component(..))
-
 -- | Convert both the installed package index and the source package
 -- index into one uniform solver index.
 --
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Package.hs b/cabal-install/Distribution/Client/Dependency/Modular/Package.hs
index 4cd9fe8bf0d..22ba01e7e85 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Package.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Package.hs
@@ -67,6 +67,8 @@ instI (I _ (Inst _)) = True
 instI _              = False
 
 -- | Package path.
+--
+-- Stored in reverse order
 data PP = Independent Int PP | Setup PN PP | None
   deriving (Eq, Ord, Show)
 
diff --git a/cabal-install/Distribution/Client/Utils/LabeledGraph.hs b/cabal-install/Distribution/Client/Utils/LabeledGraph.hs
new file mode 100644
index 00000000000..567f15609ac
--- /dev/null
+++ b/cabal-install/Distribution/Client/Utils/LabeledGraph.hs
@@ -0,0 +1,114 @@
+-- | Wrapper around Data.Graph with support for edge labels
+{-# LANGUAGE ScopedTypeVariables #-}
+module Distribution.Client.Utils.LabeledGraph (
+    -- * Graphs
+    Graph
+  , Vertex
+    -- ** Building graphs
+  , graphFromEdges
+  , graphFromEdges'
+  , buildG
+  , transposeG
+    -- ** Graph properties
+  , vertices
+  , edges
+    -- ** Operations on the underlying unlabeled graph
+  , forgetLabels
+  , topSort
+  ) where
+
+import Data.Array
+import Data.Graph (Vertex, Bounds)
+import Data.List (sortBy)
+import Data.Maybe (mapMaybe)
+import qualified Data.Graph as G
+
+{-------------------------------------------------------------------------------
+  Types
+-------------------------------------------------------------------------------}
+
+type Graph e = Array Vertex [(e, Vertex)]
+type Edge  e = (Vertex, e, Vertex)
+
+{-------------------------------------------------------------------------------
+  Building graphs
+-------------------------------------------------------------------------------}
+
+-- | Construct an edge-labeled graph
+--
+-- This is a simple adaptation of the definition in Data.Graph
+graphFromEdges :: forall key node edge. Ord key
+               => [ (node, key, [(edge, key)]) ]
+               -> ( Graph edge
+                  , Vertex -> (node, key, [(edge, key)])
+                  , key -> Maybe Vertex
+                  )
+graphFromEdges edges0 =
+    (graph, \v -> vertex_map ! v, key_vertex)
+  where
+    max_v        = length edges0 - 1
+    bounds0      = (0, max_v) :: (Vertex, Vertex)
+    sorted_edges = sortBy lt edges0
+    edges1       = zipWith (,) [0..] sorted_edges
+
+    graph        = array bounds0 [(v, (mapMaybe mk_edge ks)) | (v, (_, _, ks)) <- edges1]
+    key_map      = array bounds0 [(v, k                    ) | (v, (_, k, _ )) <- edges1]
+    vertex_map   = array bounds0 edges1
+
+    (_,k1,_) `lt` (_,k2,_) = k1 `compare` k2
+
+    mk_edge :: (edge, key) -> Maybe (edge, Vertex)
+    mk_edge (edge, key) = do v <- key_vertex key ; return (edge, v)
+
+    --  returns Nothing for non-interesting vertices
+    key_vertex :: key -> Maybe Vertex
+    key_vertex k = findVertex 0 max_v
+      where
+        findVertex a b
+          | a > b     = Nothing
+          | otherwise = case compare k (key_map ! mid) of
+              LT -> findVertex a (mid-1)
+              EQ -> Just mid
+              GT -> findVertex (mid+1) b
+          where
+            mid = a + (b - a) `div` 2
+
+graphFromEdges' :: Ord key
+                => [ (node, key, [(edge, key)]) ]
+                -> ( Graph edge
+                   , Vertex -> (node, key, [(edge, key)])
+                   )
+graphFromEdges' x = (a,b)
+  where
+    (a,b,_) = graphFromEdges x
+
+transposeG :: Graph e -> Graph e
+transposeG g = buildG (bounds g) (reverseE g)
+
+buildG :: Bounds -> [Edge e] -> Graph e
+buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 (map reassoc edges0)
+  where
+    reassoc (v, e, w) = (v, (e, w))
+
+reverseE :: Graph e -> [Edge e]
+reverseE g = [ (w, e, v) | (v, e, w) <- edges g ]
+
+{-------------------------------------------------------------------------------
+  Graph properties
+-------------------------------------------------------------------------------}
+
+vertices :: Graph e -> [Vertex]
+vertices = indices
+
+edges :: Graph e -> [Edge e]
+edges g = [ (v, e, w) | v <- vertices g, (e, w) <- g!v ]
+
+{-------------------------------------------------------------------------------
+  Operations on the underlying unlabelled graph
+-------------------------------------------------------------------------------}
+
+forgetLabels :: Graph e -> G.Graph
+forgetLabels = fmap (map snd)
+
+topSort :: Graph e -> [Vertex]
+topSort = G.topSort . forgetLabels
diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal
index 8e54000c37d..b2c834dd939 100644
--- a/cabal-install/cabal-install.cabal
+++ b/cabal-install/cabal-install.cabal
@@ -116,6 +116,7 @@ executable cabal
         Distribution.Client.Update
         Distribution.Client.Upload
         Distribution.Client.Utils
+        Distribution.Client.Utils.LabeledGraph
         Distribution.Client.World
         Distribution.Client.Win32SelfUpgrade
         Distribution.Client.Compat.Environment

From 87a79be901c47d40a972566cbed010feee78e3cc Mon Sep 17 00:00:00 2001
From: Edsko de Vries <edsko@well-typed.com>
Date: Sat, 28 Mar 2015 09:59:41 +0000
Subject: [PATCH 19/28] Keep fine-grained deps after solver

The crucial change in this commit is the change to PackageFixedDeps to return a
ComponentDeps structure, rather than a flat list of dependencies, as long with
corresponding changes in ConfiguredPackage and ReadyPackage to accomodate this.

We don't actually take _advantage_ of these more fine-grained dependencies yet;
any use of

    depends

is now a use of

   CD.flatDeps . depends

but we will :)

Note that I have not updated the top-down solver, so in the output of the
top-down solver we cheat and pretend that all dependencies are library
dependencies.
---
 .../Client/BuildReports/Storage.hs            |  5 +--
 .../Distribution/Client/Configure.hs          |  5 +--
 .../Modular/ConfiguredConversion.hs           |  7 ++--
 .../Distribution/Client/Dependency/TopDown.hs |  8 ++++-
 .../Client/Dependency/TopDown/Types.hs        |  6 ++--
 cabal-install/Distribution/Client/Install.hs  |  9 ++---
 .../Distribution/Client/InstallPlan.hs        | 34 +++++++++++++------
 .../Distribution/Client/InstallSymlink.hs     |  3 +-
 .../Distribution/Client/PackageIndex.hs       |  7 ++--
 .../Distribution/Client/PlanIndex.hs          | 20 ++++++-----
 cabal-install/Distribution/Client/Types.hs    | 22 +++++++-----
 11 files changed, 80 insertions(+), 46 deletions(-)

diff --git a/cabal-install/Distribution/Client/BuildReports/Storage.hs b/cabal-install/Distribution/Client/BuildReports/Storage.hs
index 20a4cc58471..a64bf9068a5 100644
--- a/cabal-install/Distribution/Client/BuildReports/Storage.hs
+++ b/cabal-install/Distribution/Client/BuildReports/Storage.hs
@@ -28,6 +28,7 @@ import Distribution.Client.BuildReports.Anonymous (BuildReport)
 
 import Distribution.Client.Types
 import qualified Distribution.Client.InstallPlan as InstallPlan
+import qualified Distribution.Client.ComponentDeps as CD
 import Distribution.Client.InstallPlan
          ( InstallPlan )
 
@@ -129,13 +130,13 @@ fromPlanPackage :: Platform -> CompilerId
 fromPlanPackage (Platform arch os) comp planPackage = case planPackage of
   InstallPlan.Installed (ReadyPackage srcPkg flags _ deps) result
     -> Just $ ( BuildReport.new os arch comp
-                                (packageId srcPkg) flags (map packageId deps)
+                                (packageId srcPkg) flags (map packageId (CD.flatDeps deps))
                                 (Right result)
               , extractRepo srcPkg)
 
   InstallPlan.Failed (ConfiguredPackage srcPkg flags _ deps) result
     -> Just $ ( BuildReport.new os arch comp
-                                (packageId srcPkg) flags (map confSrcId deps)
+                                (packageId srcPkg) flags (map confSrcId (CD.flatDeps deps))
                                 (Left result)
               , extractRepo srcPkg )
 
diff --git a/cabal-install/Distribution/Client/Configure.hs b/cabal-install/Distribution/Client/Configure.hs
index 4d209d98c78..aa0d610d097 100644
--- a/cabal-install/Distribution/Client/Configure.hs
+++ b/cabal-install/Distribution/Client/Configure.hs
@@ -29,6 +29,7 @@ import Distribution.Client.SetupWrapper
          ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )
 import Distribution.Client.Targets
          ( userToPackageConstraint )
+import qualified Distribution.Client.ComponentDeps as CD
 
 import Distribution.Simple.Compiler
          ( Compiler, CompilerInfo, compilerInfo, PackageDB(..), PackageDBStack )
@@ -236,10 +237,10 @@ configurePackage verbosity platform comp scriptOptions configFlags
       -- deps.  In the end only one set gets passed to Setup.hs configure,
       -- depending on the Cabal version we are talking to.
       configConstraints  = [ thisPackageVersion (packageId deppkg)
-                           | deppkg <- deps ],
+                           | deppkg <- CD.flatDeps deps ],
       configDependencies = [ (packageName (Installed.sourcePackageId deppkg),
                               Installed.installedPackageId deppkg)
-                           | deppkg <- deps ],
+                           | deppkg <- CD.flatDeps deps ],
       -- Use '--exact-configuration' if supported.
       configExactConfiguration = toFlag True,
       configVerbosity          = toFlag verbosity,
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs b/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs
index 6121db82d6f..8a5d4b60602 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs
@@ -13,6 +13,7 @@ import Distribution.System
 import Distribution.Client.Dependency.Modular.Configured
 import Distribution.Client.Dependency.Modular.Package
 
+import Distribution.Client.ComponentDeps (ComponentDeps)
 import qualified Distribution.Client.ComponentDeps as CD
 
 mkPlan :: Platform -> CompilerInfo -> Bool ->
@@ -27,15 +28,15 @@ convCP iidx sidx (CP qpi fa es ds) =
   case convPI qpi of
     Left  pi -> PreExisting $ InstalledPackage
                   (fromJust $ SI.lookupInstalledPackageId iidx pi)
-                  (map confSrcId ds')
+                  (map confSrcId $ CD.flatDeps ds')
     Right pi -> Configured $ ConfiguredPackage
                   (fromJust $ CI.lookupPackageId sidx pi)
                   fa
                   es
                   ds'
   where
-    ds' :: [ConfiguredId]
-    ds' = CD.flatDeps $ fmap (map convConfId) ds
+    ds' :: ComponentDeps [ConfiguredId]
+    ds' = fmap (map convConfId) ds
 
 convPI :: PI QPN -> Either InstalledPackageId PackageId
 convPI (PI _ (I _ (Inst pi))) = Left pi
diff --git a/cabal-install/Distribution/Client/Dependency/TopDown.hs b/cabal-install/Distribution/Client/Dependency/TopDown.hs
index a6f75e6090e..74f5d24961f 100644
--- a/cabal-install/Distribution/Client/Dependency/TopDown.hs
+++ b/cabal-install/Distribution/Client/Dependency/TopDown.hs
@@ -33,6 +33,9 @@ import Distribution.Client.Dependency.Types
          , Progress(..), foldProgress )
 
 import qualified Distribution.Client.PackageIndex as PackageIndex
+import Distribution.Client.ComponentDeps
+         ( ComponentDeps )
+import qualified Distribution.Client.ComponentDeps as CD
 import Distribution.Client.PackageIndex
          ( PackageIndex )
 import Distribution.Package
@@ -562,7 +565,10 @@ finaliseSelectedPackages pref selected constraints =
     finaliseSource mipkg (SemiConfiguredPackage pkg flags stanzas deps) =
       InstallPlan.Configured (ConfiguredPackage pkg flags stanzas deps')
       where
-        deps' = map (confId . pickRemaining mipkg) deps
+        -- We cheat in the cabal solver, and classify all dependencies as
+        -- library dependencies.
+        deps' :: ComponentDeps [ConfiguredId]
+        deps' = CD.fromLibraryDeps $ map (confId . pickRemaining mipkg) deps
 
     -- InstalledOrSource indicates that we either have a source package
     -- available, or an installed one, or both. In the case that we have both
diff --git a/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs b/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs
index c6cc5baa73b..6f31385994a 100644
--- a/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs
+++ b/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs
@@ -10,6 +10,7 @@
 --
 -- Types for the top-down dependency resolver.
 -----------------------------------------------------------------------------
+{-# LANGUAGE CPP #-}
 module Distribution.Client.Dependency.TopDown.Types where
 
 import Distribution.Client.Types
@@ -17,6 +18,7 @@ import Distribution.Client.Types
          , OptionalStanza, ConfiguredId(..) )
 import Distribution.Client.InstallPlan
          ( ConfiguredPackage(..), PlanPackage(..) )
+import qualified Distribution.Client.ComponentDeps as CD
 
 import Distribution.Package
          ( PackageIdentifier, Dependency
@@ -113,10 +115,10 @@ instance PackageSourceDeps InstalledPackageEx where
   sourceDeps (InstalledPackageEx _ _ deps) = deps
 
 instance PackageSourceDeps ConfiguredPackage where
-  sourceDeps (ConfiguredPackage _ _ _ deps) = map confSrcId deps
+  sourceDeps (ConfiguredPackage _ _ _ deps) = map confSrcId $ CD.flatDeps deps
 
 instance PackageSourceDeps ReadyPackage where
-  sourceDeps (ReadyPackage _ _ _ deps) = map packageId deps
+  sourceDeps (ReadyPackage _ _ _ deps) = map packageId $ CD.flatDeps deps
 
 instance PackageSourceDeps InstalledPackage where
   sourceDeps (InstalledPackage _ deps) = deps
diff --git a/cabal-install/Distribution/Client/Install.hs b/cabal-install/Distribution/Client/Install.hs
index 69083afb956..568d722c269 100644
--- a/cabal-install/Distribution/Client/Install.hs
+++ b/cabal-install/Distribution/Client/Install.hs
@@ -103,6 +103,7 @@ import qualified Distribution.Client.World as World
 import qualified Distribution.InstalledPackageInfo as Installed
 import Distribution.Client.Compat.ExecutablePath
 import Distribution.Client.JobControl
+import qualified Distribution.Client.ComponentDeps as CD
 
 import Distribution.Utils.NubList
 import Distribution.Simple.Compiler
@@ -563,8 +564,8 @@ packageStatus _comp installedPkgIndex cpkg =
             -> [MergeResult PackageIdentifier PackageIdentifier]
     changes pkg pkg' = filter changed $
       mergeBy (comparing packageName)
-        (resolveInstalledIds $ Installed.depends pkg) -- deps of installed pkg
-        (resolveInstalledIds $ depends $ pkg')        -- deps of configured pkg
+        (resolveInstalledIds $ Installed.depends pkg)      -- deps of installed pkg
+        (resolveInstalledIds $ CD.flatDeps (depends pkg')) -- deps of configured pkg
 
     -- convert to source pkg ids via index
     resolveInstalledIds :: [InstalledPackageId] -> [PackageIdentifier]
@@ -1191,10 +1192,10 @@ installReadyPackage platform cinfo configFlags
     -- In the end only one set gets passed to Setup.hs configure, depending on
     -- the Cabal version we are talking to.
     configConstraints  = [ thisPackageVersion (packageId deppkg)
-                         | deppkg <- deps ],
+                         | deppkg <- CD.flatDeps deps ],
     configDependencies = [ (packageName (Installed.sourcePackageId deppkg),
                             Installed.installedPackageId deppkg)
-                         | deppkg <- deps ],
+                         | deppkg <- CD.flatDeps deps ],
     -- Use '--exact-configuration' if supported.
     configExactConfiguration = toFlag True,
     configBenchmarks         = toFlag False,
diff --git a/cabal-install/Distribution/Client/InstallPlan.hs b/cabal-install/Distribution/Client/InstallPlan.hs
index 431f8263507..e1de07657e5 100644
--- a/cabal-install/Distribution/Client/InstallPlan.hs
+++ b/cabal-install/Distribution/Client/InstallPlan.hs
@@ -70,6 +70,8 @@ import Distribution.Client.PackageUtils
          ( externalBuildDepends )
 import Distribution.Client.PackageIndex
          ( PackageFixedDeps(..) )
+import Distribution.Client.ComponentDeps (ComponentDeps)
+import qualified Distribution.Client.ComponentDeps as CD
 import Distribution.PackageDescription.Configuration
          ( finalizePackageDescription )
 import Distribution.Simple.PackageIndex
@@ -100,6 +102,7 @@ import Control.Exception
          ( assert )
 import Data.Maybe (catMaybes)
 import qualified Data.Map as Map
+import qualified Data.Traversable as T
 
 type PlanIndex = PackageIndex PlanPackage
 
@@ -300,8 +303,8 @@ ready plan = assert check readyPackages
       , deps <- maybeToList (hasAllInstalledDeps pkg)
       ]
 
-    hasAllInstalledDeps :: ConfiguredPackage -> Maybe [Installed.InstalledPackageInfo]
-    hasAllInstalledDeps = mapM isInstalledDep . depends
+    hasAllInstalledDeps :: ConfiguredPackage -> Maybe (ComponentDeps [Installed.InstalledPackageInfo])
+    hasAllInstalledDeps = T.mapM (mapM isInstalledDep) . depends
 
     isInstalledDep :: InstalledPackageId -> Maybe Installed.InstalledPackageInfo
     isInstalledDep pkgid =
@@ -491,7 +494,7 @@ problems platform cinfo fakeMap indepGoals index =
 
   ++ [ PackageStateInvalid pkg pkg'
      | pkg <- PackageIndex.allPackages index
-     , Just pkg' <- map (PlanIndex.fakeLookupInstalledPackageId fakeMap index) (depends pkg)
+     , Just pkg' <- map (PlanIndex.fakeLookupInstalledPackageId fakeMap index) (CD.flatDeps (depends pkg))
      , not (stateDependencyRelation pkg pkg') ]
 
 -- | The graph of packages (nodes) and dependencies (edges) must be acyclic.
@@ -612,24 +615,19 @@ configuredPackageProblems platform cinfo
   ++ [ MissingFlag flag | OnlyInLeft  flag <- mergedFlags ]
   ++ [ ExtraFlag   flag | OnlyInRight flag <- mergedFlags ]
   ++ [ DuplicateDeps pkgs
-     | pkgs <- duplicatesBy (comparing packageName) specifiedDeps ]
+     | pkgs <- CD.flatDeps (fmap (duplicatesBy (comparing packageName)) specifiedDeps) ]
   ++ [ MissingDep dep       | OnlyInLeft  dep       <- mergedDeps ]
   ++ [ ExtraDep       pkgid | OnlyInRight     pkgid <- mergedDeps ]
   ++ [ InvalidDep dep pkgid | InBoth      dep pkgid <- mergedDeps
                             , not (packageSatisfiesDependency pkgid dep) ]
   where
-    specifiedDeps :: [PackageId]
-    specifiedDeps = map confSrcId specifiedDeps'
+    specifiedDeps :: ComponentDeps [PackageId]
+    specifiedDeps = fmap (map confSrcId) specifiedDeps'
 
     mergedFlags = mergeBy compare
       (sort $ map flagName (genPackageFlags (packageDescription pkg)))
       (sort $ map fst specifiedFlags)
 
-    mergedDeps = mergeBy
-      (\dep pkgid -> dependencyName dep `compare` packageName pkgid)
-      (sortBy (comparing dependencyName) requiredDeps)
-      (sortBy (comparing packageName)    specifiedDeps)
-
     packageSatisfiesDependency
       (PackageIdentifier name  version)
       (Dependency        name' versionRange) = assert (name == name') $
@@ -637,6 +635,20 @@ configuredPackageProblems platform cinfo
 
     dependencyName (Dependency name _) = name
 
+    mergedDeps :: [MergeResult Dependency PackageId]
+    mergedDeps = mergeDeps requiredDeps (CD.flatDeps specifiedDeps)
+
+    mergeDeps :: [Dependency] -> [PackageId] -> [MergeResult Dependency PackageId]
+    mergeDeps required specified =
+      mergeBy
+        (\dep pkgid -> dependencyName dep `compare` packageName pkgid)
+        (sortBy (comparing dependencyName) required)
+        (sortBy (comparing packageName)    specified)
+
+    -- TODO: It would be nicer to use PackageDeps here so we can be more precise
+    -- in our checks. That's a bit tricky though, as this currently relies on
+    -- the 'buildDepends' field of 'PackageDescription'. (OTOH, that field is
+    -- deprecated and should be removed anyway.)
     requiredDeps :: [Dependency]
     requiredDeps =
       --TODO: use something lower level than finalizePackageDescription
diff --git a/cabal-install/Distribution/Client/InstallSymlink.hs b/cabal-install/Distribution/Client/InstallSymlink.hs
index d19386c9bd2..dffc8321cac 100644
--- a/cabal-install/Distribution/Client/InstallSymlink.hs
+++ b/cabal-install/Distribution/Client/InstallSymlink.hs
@@ -48,6 +48,7 @@ import Distribution.Package
 import Distribution.Compiler
          ( CompilerId(..) )
 import qualified Distribution.PackageDescription as PackageDescription
+import qualified Distribution.Client.ComponentDeps as CD
 import Distribution.PackageDescription
          ( PackageDescription )
 import Distribution.PackageDescription.Configuration
@@ -122,7 +123,7 @@ symlinkBinaries comp configFlags installFlags plan =
         | (ReadyPackage _ _flags _ deps, pkg, exe) <- exes
         , let pkgid  = packageId pkg
               pkg_key = mkPackageKey (packageKeySupported comp) pkgid
-                                     (map Installed.packageKey deps) []
+                                     (map Installed.packageKey (CD.flatDeps deps)) []
               publicExeName  = PackageDescription.exeName exe
               privateExeName = prefix ++ publicExeName ++ suffix
               prefix = substTemplate pkgid pkg_key prefixTemplate
diff --git a/cabal-install/Distribution/Client/PackageIndex.hs b/cabal-install/Distribution/Client/PackageIndex.hs
index f259798b6a3..c975177d613 100644
--- a/cabal-install/Distribution/Client/PackageIndex.hs
+++ b/cabal-install/Distribution/Client/PackageIndex.hs
@@ -70,6 +70,9 @@ import Distribution.InstalledPackageInfo
 import Distribution.Simple.Utils
          ( lowercase, comparing )
 
+import Distribution.Client.ComponentDeps (ComponentDeps)
+import qualified Distribution.Client.ComponentDeps as CD
+
 -- | Subclass of packages that have specific versioned dependencies.
 --
 -- So for example a not-yet-configured package has dependencies on version
@@ -78,10 +81,10 @@ import Distribution.Simple.Utils
 --  dependency graphs) only make sense on this subclass of package types.
 --
 class Package pkg => PackageFixedDeps pkg where
-  depends :: pkg -> [InstalledPackageId]
+  depends :: pkg -> ComponentDeps [InstalledPackageId]
 
 instance PackageFixedDeps (InstalledPackageInfo_ str) where
-  depends info = installedDepends info
+  depends = CD.fromInstalled . installedDepends
 
 -- | The collection of information about packages from one or more 'PackageDB's.
 --
diff --git a/cabal-install/Distribution/Client/PlanIndex.hs b/cabal-install/Distribution/Client/PlanIndex.hs
index ae489600c4e..16813b48494 100644
--- a/cabal-install/Distribution/Client/PlanIndex.hs
+++ b/cabal-install/Distribution/Client/PlanIndex.hs
@@ -40,6 +40,8 @@ import Distribution.Package
 import Distribution.Version
          ( Version )
 
+import Distribution.Client.ComponentDeps (ComponentDeps)
+import qualified Distribution.Client.ComponentDeps as CD
 import Distribution.Client.PackageIndex
          ( PackageFixedDeps(..) )
 import Distribution.Simple.PackageIndex
@@ -84,8 +86,8 @@ type FakeMap = Map InstalledPackageId InstalledPackageId
 -- | Variant of `depends` which accepts a `FakeMap`
 --
 -- Analogous to `fakeInstalledDepends`. See Note [FakeMap].
-fakeDepends :: PackageFixedDeps pkg => FakeMap -> pkg -> [InstalledPackageId]
-fakeDepends fakeMap = map resolveFakeId . depends
+fakeDepends :: PackageFixedDeps pkg => FakeMap -> pkg -> ComponentDeps [InstalledPackageId]
+fakeDepends fakeMap = fmap (map resolveFakeId) . depends
   where
     resolveFakeId :: InstalledPackageId -> InstalledPackageId
     resolveFakeId ipid = Map.findWithDefault ipid ipid fakeMap
@@ -109,7 +111,7 @@ brokenPackages fakeMap index =
   [ (pkg, missing)
   | pkg  <- allPackages index
   , let missing =
-          [ pkg' | pkg' <- depends pkg
+          [ pkg' | pkg' <- CD.flatDeps (depends pkg)
                  , isNothing (fakeLookupInstalledPackageId fakeMap index pkg') ]
   , not (null missing) ]
 
@@ -186,7 +188,7 @@ dependencyInconsistencies' fakeMap index =
       | -- For each package @pkg@
         pkg <- allPackages index
         -- Find out which @ipid@ @pkg@ depends on
-      , ipid <- fakeDepends fakeMap pkg
+      , ipid <- CD.flatDeps (fakeDepends fakeMap pkg)
         -- And look up those @ipid@ (i.e., @ipid@ is the ID of @dep@)
       , Just dep <- [fakeLookupInstalledPackageId fakeMap index ipid]
       ]
@@ -202,8 +204,8 @@ dependencyInconsistencies' fakeMap index =
     reallyIsInconsistent [p1, p2] =
       let pid1 = installedPackageId p1
           pid2 = installedPackageId p2
-      in Map.findWithDefault pid1 pid1 fakeMap `notElem` fakeDepends fakeMap p2
-      && Map.findWithDefault pid2 pid2 fakeMap `notElem` fakeDepends fakeMap p1
+      in Map.findWithDefault pid1 pid1 fakeMap `notElem` CD.flatDeps (fakeDepends fakeMap p2)
+      && Map.findWithDefault pid2 pid2 fakeMap `notElem` CD.flatDeps (fakeDepends fakeMap p1)
     reallyIsInconsistent _ = True
 
 
@@ -223,7 +225,7 @@ dependencyCycles :: (PackageFixedDeps pkg, HasInstalledPackageId pkg)
 dependencyCycles fakeMap index =
   [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ]
   where
-    adjacencyList = [ (pkg, installedPackageId pkg, fakeDepends fakeMap pkg)
+    adjacencyList = [ (pkg, installedPackageId pkg, CD.flatDeps (fakeDepends fakeMap pkg))
                     | pkg <- allPackages index ]
 
 
@@ -254,7 +256,7 @@ dependencyClosure fakeMap index pkgids0 = case closure mempty [] pkgids0 of
             Just _  -> closure completed  failed pkgids
             Nothing -> closure completed' failed pkgids'
               where completed' = insert pkg completed
-                    pkgids'    = depends pkg ++ pkgids
+                    pkgids'    = CD.flatDeps (depends pkg) ++ pkgids
 
 
 topologicalOrder :: (PackageFixedDeps pkg, HasInstalledPackageId pkg)
@@ -320,5 +322,5 @@ dependencyGraph fakeMap index = (graph, vertexToPkg, idToVertex)
     resolve   pid = Map.findWithDefault pid pid fakeMap
     edgesFrom pkg = ( ()
                     , resolve (installedPackageId pkg)
-                    , fakeDepends fakeMap pkg
+                    , CD.flatDeps (fakeDepends fakeMap pkg)
                     )
diff --git a/cabal-install/Distribution/Client/Types.hs b/cabal-install/Distribution/Client/Types.hs
index 9e0a9793031..1c349b84ce9 100644
--- a/cabal-install/Distribution/Client/Types.hs
+++ b/cabal-install/Distribution/Client/Types.hs
@@ -27,6 +27,9 @@ import Distribution.PackageDescription.Configuration
          ( mapTreeData )
 import Distribution.Client.PackageIndex
          ( PackageIndex, PackageFixedDeps(..) )
+import Distribution.Client.ComponentDeps
+         ( ComponentDeps )
+import qualified Distribution.Client.ComponentDeps as CD
 import Distribution.Version
          ( VersionRange )
 import Distribution.Simple.Compiler
@@ -91,7 +94,8 @@ data ConfiguredPackage = ConfiguredPackage
        SourcePackage       -- package info, including repo
        FlagAssignment      -- complete flag assignment for the package
        [OptionalStanza]    -- list of enabled optional stanzas for the package
-       [ConfiguredId]      -- set of exact dependencies (installed or source).
+       (ComponentDeps [ConfiguredId])
+                           -- set of exact dependencies (installed or source).
                            -- These must be consistent with the 'buildDepends'
                            -- in the 'PackageDescription' that you'd get by
                            -- applying the flag assignment and optional stanzas.
@@ -121,7 +125,7 @@ instance Package ConfiguredPackage where
   packageId (ConfiguredPackage pkg _ _ _) = packageId pkg
 
 instance PackageFixedDeps ConfiguredPackage where
-  depends (ConfiguredPackage _ _ _ deps) = map confInstId deps
+  depends (ConfiguredPackage _ _ _ deps) = fmap (map confInstId) deps
 
 instance HasInstalledPackageId ConfiguredPackage where
   installedPackageId = fakeInstalledPackageId . packageId
@@ -129,17 +133,17 @@ instance HasInstalledPackageId ConfiguredPackage where
 -- | Like 'ConfiguredPackage', but with all dependencies guaranteed to be
 -- installed already, hence itself ready to be installed.
 data ReadyPackage = ReadyPackage
-       SourcePackage           -- see 'ConfiguredPackage'.
-       FlagAssignment          --
-       [OptionalStanza]        --
-       [InstalledPackageInfo]  -- Installed dependencies.
+       SourcePackage                           -- see 'ConfiguredPackage'.
+       FlagAssignment                          --
+       [OptionalStanza]                        --
+       (ComponentDeps [InstalledPackageInfo])  -- Installed dependencies.
   deriving Show
 
 instance Package ReadyPackage where
   packageId (ReadyPackage pkg _ _ _) = packageId pkg
 
 instance PackageFixedDeps ReadyPackage where
-  depends (ReadyPackage _ _ _ deps) = map installedPackageId deps
+  depends (ReadyPackage _ _ _ deps) = fmap (map installedPackageId) deps
 
 instance HasInstalledPackageId ReadyPackage where
   installedPackageId = fakeInstalledPackageId . packageId
@@ -150,7 +154,7 @@ instance HasInstalledPackageId ReadyPackage where
 readyPackageKey :: Compiler -> ReadyPackage -> PackageKey
 readyPackageKey comp (ReadyPackage pkg _ _ deps) =
     mkPackageKey (packageKeySupported comp) (packageId pkg)
-                 (map Info.packageKey deps) []
+                 (map Info.packageKey (CD.flatDeps deps)) []
 
 
 -- | Sometimes we need to convert a 'ReadyPackage' back to a
@@ -158,7 +162,7 @@ readyPackageKey comp (ReadyPackage pkg _ _ deps) =
 -- Ready or Configured.
 readyPackageToConfiguredPackage :: ReadyPackage -> ConfiguredPackage
 readyPackageToConfiguredPackage (ReadyPackage srcpkg flags stanzas deps) =
-    ConfiguredPackage srcpkg flags stanzas (map aux deps)
+    ConfiguredPackage srcpkg flags stanzas (fmap (map aux) deps)
   where
     aux :: InstalledPackageInfo -> ConfiguredId
     aux info = ConfiguredId {

From f88c9b68fab1687c3a50759ecbd71e41951b5ef5 Mon Sep 17 00:00:00 2001
From: Edsko de Vries <edsko@well-typed.com>
Date: Mon, 6 Apr 2015 12:47:44 +0100
Subject: [PATCH 20/28] Allow for dups in configuredPackageProblems

---
 cabal-install/Distribution/Client/InstallPlan.hs | 13 +++++++++----
 1 file changed, 9 insertions(+), 4 deletions(-)

diff --git a/cabal-install/Distribution/Client/InstallPlan.hs b/cabal-install/Distribution/Client/InstallPlan.hs
index e1de07657e5..50e593e9559 100644
--- a/cabal-install/Distribution/Client/InstallPlan.hs
+++ b/cabal-install/Distribution/Client/InstallPlan.hs
@@ -93,10 +93,11 @@ import Distribution.Simple.Utils
 import qualified Distribution.InstalledPackageInfo as Installed
 
 import Data.List
-         ( sort, sortBy )
+         ( sort, sortBy, nubBy )
 import Data.Maybe
          ( fromMaybe, maybeToList )
 import qualified Data.Graph as Graph
+import Data.Function (on)
 import Data.Graph (Graph)
 import Control.Exception
          ( assert )
@@ -640,15 +641,19 @@ configuredPackageProblems platform cinfo
 
     mergeDeps :: [Dependency] -> [PackageId] -> [MergeResult Dependency PackageId]
     mergeDeps required specified =
+      let sortNubOn f = nubBy ((==) `on` f) . sortBy (compare `on` f) in
       mergeBy
         (\dep pkgid -> dependencyName dep `compare` packageName pkgid)
-        (sortBy (comparing dependencyName) required)
-        (sortBy (comparing packageName)    specified)
+        (sortNubOn dependencyName required)
+        (sortNubOn packageName    specified)
 
-    -- TODO: It would be nicer to use PackageDeps here so we can be more precise
+    -- TODO: It would be nicer to use ComponentDeps here so we can be more precise
     -- in our checks. That's a bit tricky though, as this currently relies on
     -- the 'buildDepends' field of 'PackageDescription'. (OTOH, that field is
     -- deprecated and should be removed anyway.)
+    -- As long as we _do_ use a flat list here, we have to allow for duplicates
+    -- when we fold specifiedDeps; once we have proper ComponentDeps here we
+    -- should get rid of the `nubOn` in `mergeDeps`.
     requiredDeps :: [Dependency]
     requiredDeps =
       --TODO: use something lower level than finalizePackageDescription

From 1effd34bdb5507c29f6fcae70825d5126627c2cf Mon Sep 17 00:00:00 2001
From: Edsko de Vries <edsko@well-typed.com>
Date: Mon, 30 Mar 2015 16:41:14 +0100
Subject: [PATCH 21/28] Add ComponentSetup to ComponentDeps

Although we don't use the new setup dependency component anywhere yet, I've
replaced all uses of CD.flatDeps with CD.nonSetupDeps. This means that when we
do introduce the setup dependencies, all code in Cabal will still use all
dependencies except the setup dependencies, just like now. In other words,
using the setup dependencies in some places would be a conscious decision; the
default is that we leave the behaviour unchanged.
---
 .../Client/BuildReports/Storage.hs            |  4 +--
 .../Distribution/Client/ComponentDeps.hs      | 29 +++++++++++++++++++
 .../Distribution/Client/Configure.hs          |  4 +--
 .../Modular/ConfiguredConversion.hs           |  2 +-
 .../Client/Dependency/TopDown/Types.hs        |  4 +--
 cabal-install/Distribution/Client/Install.hs  |  8 ++---
 .../Distribution/Client/InstallPlan.hs        |  6 ++--
 .../Distribution/Client/InstallSymlink.hs     |  2 +-
 .../Distribution/Client/PlanIndex.hs          | 14 ++++-----
 cabal-install/Distribution/Client/Types.hs    |  2 +-
 10 files changed, 52 insertions(+), 23 deletions(-)

diff --git a/cabal-install/Distribution/Client/BuildReports/Storage.hs b/cabal-install/Distribution/Client/BuildReports/Storage.hs
index a64bf9068a5..a4f20de32d5 100644
--- a/cabal-install/Distribution/Client/BuildReports/Storage.hs
+++ b/cabal-install/Distribution/Client/BuildReports/Storage.hs
@@ -130,13 +130,13 @@ fromPlanPackage :: Platform -> CompilerId
 fromPlanPackage (Platform arch os) comp planPackage = case planPackage of
   InstallPlan.Installed (ReadyPackage srcPkg flags _ deps) result
     -> Just $ ( BuildReport.new os arch comp
-                                (packageId srcPkg) flags (map packageId (CD.flatDeps deps))
+                                (packageId srcPkg) flags (map packageId (CD.nonSetupDeps deps))
                                 (Right result)
               , extractRepo srcPkg)
 
   InstallPlan.Failed (ConfiguredPackage srcPkg flags _ deps) result
     -> Just $ ( BuildReport.new os arch comp
-                                (packageId srcPkg) flags (map confSrcId (CD.flatDeps deps))
+                                (packageId srcPkg) flags (map confSrcId (CD.nonSetupDeps deps))
                                 (Left result)
               , extractRepo srcPkg )
 
diff --git a/cabal-install/Distribution/Client/ComponentDeps.hs b/cabal-install/Distribution/Client/ComponentDeps.hs
index f6ee4d9a779..ef38a251483 100644
--- a/cabal-install/Distribution/Client/ComponentDeps.hs
+++ b/cabal-install/Distribution/Client/ComponentDeps.hs
@@ -21,10 +21,15 @@ module Distribution.Client.ComponentDeps (
   , singleton
   , insert
   , fromLibraryDeps
+  , fromSetupDeps
   , fromInstalled
     -- ** Deconstructing ComponentDeps
   , toList
   , flatDeps
+  , nonSetupDeps
+  , libraryDeps
+  , setupDeps
+  , select
   ) where
 
 import Data.Map (Map)
@@ -47,6 +52,7 @@ data Component =
   | ComponentExe   String
   | ComponentTest  String
   | ComponentBench String
+  | ComponentSetup
   deriving (Show, Eq, Ord)
 
 -- | Dependency for a single component
@@ -91,6 +97,10 @@ insert comp a = ComponentDeps . Map.alter aux comp . unComponentDeps
 fromLibraryDeps :: a -> ComponentDeps a
 fromLibraryDeps = singleton ComponentLib
 
+-- | ComponentDeps containing setup dependencies only
+fromSetupDeps :: a -> ComponentDeps a
+fromSetupDeps = singleton ComponentSetup
+
 -- | ComponentDeps for installed packages
 --
 -- We assume that installed packages only record their library dependencies
@@ -111,3 +121,22 @@ toList = Map.toList . unComponentDeps
 -- @#ifdef@s for 7.10 just for the use of 'fold'.
 flatDeps :: Monoid a => ComponentDeps a -> a
 flatDeps = fold
+
+-- | All dependencies except the setup dependencies
+--
+-- Prior to the introduction of setup dependencies (TODO: Version? 1.23) this
+-- would have been _all_ dependencies
+nonSetupDeps :: Monoid a => ComponentDeps a -> a
+nonSetupDeps = select (/= ComponentSetup)
+
+-- | Library dependencies proper only
+libraryDeps :: Monoid a => ComponentDeps a -> a
+libraryDeps = select (== ComponentLib)
+
+-- | Setup dependencies
+setupDeps :: Monoid a => ComponentDeps a -> a
+setupDeps = select (== ComponentSetup)
+
+-- | Select dependencies satisfying a given predicate
+select :: Monoid a => (Component -> Bool) -> ComponentDeps a -> a
+select p = foldMap snd . filter (p . fst) . toList
diff --git a/cabal-install/Distribution/Client/Configure.hs b/cabal-install/Distribution/Client/Configure.hs
index aa0d610d097..aadf36a1318 100644
--- a/cabal-install/Distribution/Client/Configure.hs
+++ b/cabal-install/Distribution/Client/Configure.hs
@@ -237,10 +237,10 @@ configurePackage verbosity platform comp scriptOptions configFlags
       -- deps.  In the end only one set gets passed to Setup.hs configure,
       -- depending on the Cabal version we are talking to.
       configConstraints  = [ thisPackageVersion (packageId deppkg)
-                           | deppkg <- CD.flatDeps deps ],
+                           | deppkg <- CD.nonSetupDeps deps ],
       configDependencies = [ (packageName (Installed.sourcePackageId deppkg),
                               Installed.installedPackageId deppkg)
-                           | deppkg <- CD.flatDeps deps ],
+                           | deppkg <- CD.nonSetupDeps deps ],
       -- Use '--exact-configuration' if supported.
       configExactConfiguration = toFlag True,
       configVerbosity          = toFlag verbosity,
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs b/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs
index 8a5d4b60602..47968d19ec2 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs
@@ -28,7 +28,7 @@ convCP iidx sidx (CP qpi fa es ds) =
   case convPI qpi of
     Left  pi -> PreExisting $ InstalledPackage
                   (fromJust $ SI.lookupInstalledPackageId iidx pi)
-                  (map confSrcId $ CD.flatDeps ds')
+                  (map confSrcId $ CD.nonSetupDeps ds')
     Right pi -> Configured $ ConfiguredPackage
                   (fromJust $ CI.lookupPackageId sidx pi)
                   fa
diff --git a/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs b/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs
index 6f31385994a..73c1a273273 100644
--- a/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs
+++ b/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs
@@ -115,10 +115,10 @@ instance PackageSourceDeps InstalledPackageEx where
   sourceDeps (InstalledPackageEx _ _ deps) = deps
 
 instance PackageSourceDeps ConfiguredPackage where
-  sourceDeps (ConfiguredPackage _ _ _ deps) = map confSrcId $ CD.flatDeps deps
+  sourceDeps (ConfiguredPackage _ _ _ deps) = map confSrcId $ CD.nonSetupDeps deps
 
 instance PackageSourceDeps ReadyPackage where
-  sourceDeps (ReadyPackage _ _ _ deps) = map packageId $ CD.flatDeps deps
+  sourceDeps (ReadyPackage _ _ _ deps) = map packageId $ CD.nonSetupDeps deps
 
 instance PackageSourceDeps InstalledPackage where
   sourceDeps (InstalledPackage _ deps) = deps
diff --git a/cabal-install/Distribution/Client/Install.hs b/cabal-install/Distribution/Client/Install.hs
index 568d722c269..81a990cb40d 100644
--- a/cabal-install/Distribution/Client/Install.hs
+++ b/cabal-install/Distribution/Client/Install.hs
@@ -564,8 +564,8 @@ packageStatus _comp installedPkgIndex cpkg =
             -> [MergeResult PackageIdentifier PackageIdentifier]
     changes pkg pkg' = filter changed $
       mergeBy (comparing packageName)
-        (resolveInstalledIds $ Installed.depends pkg)      -- deps of installed pkg
-        (resolveInstalledIds $ CD.flatDeps (depends pkg')) -- deps of configured pkg
+        (resolveInstalledIds $ Installed.depends pkg)          -- deps of installed pkg
+        (resolveInstalledIds $ CD.nonSetupDeps (depends pkg')) -- deps of configured pkg
 
     -- convert to source pkg ids via index
     resolveInstalledIds :: [InstalledPackageId] -> [PackageIdentifier]
@@ -1192,10 +1192,10 @@ installReadyPackage platform cinfo configFlags
     -- In the end only one set gets passed to Setup.hs configure, depending on
     -- the Cabal version we are talking to.
     configConstraints  = [ thisPackageVersion (packageId deppkg)
-                         | deppkg <- CD.flatDeps deps ],
+                         | deppkg <- CD.nonSetupDeps deps ],
     configDependencies = [ (packageName (Installed.sourcePackageId deppkg),
                             Installed.installedPackageId deppkg)
-                         | deppkg <- CD.flatDeps deps ],
+                         | deppkg <- CD.nonSetupDeps deps ],
     -- Use '--exact-configuration' if supported.
     configExactConfiguration = toFlag True,
     configBenchmarks         = toFlag False,
diff --git a/cabal-install/Distribution/Client/InstallPlan.hs b/cabal-install/Distribution/Client/InstallPlan.hs
index 50e593e9559..d345b011a93 100644
--- a/cabal-install/Distribution/Client/InstallPlan.hs
+++ b/cabal-install/Distribution/Client/InstallPlan.hs
@@ -495,7 +495,7 @@ problems platform cinfo fakeMap indepGoals index =
 
   ++ [ PackageStateInvalid pkg pkg'
      | pkg <- PackageIndex.allPackages index
-     , Just pkg' <- map (PlanIndex.fakeLookupInstalledPackageId fakeMap index) (CD.flatDeps (depends pkg))
+     , Just pkg' <- map (PlanIndex.fakeLookupInstalledPackageId fakeMap index) (CD.nonSetupDeps (depends pkg))
      , not (stateDependencyRelation pkg pkg') ]
 
 -- | The graph of packages (nodes) and dependencies (edges) must be acyclic.
@@ -616,7 +616,7 @@ configuredPackageProblems platform cinfo
   ++ [ MissingFlag flag | OnlyInLeft  flag <- mergedFlags ]
   ++ [ ExtraFlag   flag | OnlyInRight flag <- mergedFlags ]
   ++ [ DuplicateDeps pkgs
-     | pkgs <- CD.flatDeps (fmap (duplicatesBy (comparing packageName)) specifiedDeps) ]
+     | pkgs <- CD.nonSetupDeps (fmap (duplicatesBy (comparing packageName)) specifiedDeps) ]
   ++ [ MissingDep dep       | OnlyInLeft  dep       <- mergedDeps ]
   ++ [ ExtraDep       pkgid | OnlyInRight     pkgid <- mergedDeps ]
   ++ [ InvalidDep dep pkgid | InBoth      dep pkgid <- mergedDeps
@@ -637,7 +637,7 @@ configuredPackageProblems platform cinfo
     dependencyName (Dependency name _) = name
 
     mergedDeps :: [MergeResult Dependency PackageId]
-    mergedDeps = mergeDeps requiredDeps (CD.flatDeps specifiedDeps)
+    mergedDeps = mergeDeps requiredDeps (CD.nonSetupDeps specifiedDeps)
 
     mergeDeps :: [Dependency] -> [PackageId] -> [MergeResult Dependency PackageId]
     mergeDeps required specified =
diff --git a/cabal-install/Distribution/Client/InstallSymlink.hs b/cabal-install/Distribution/Client/InstallSymlink.hs
index dffc8321cac..0ea1921688d 100644
--- a/cabal-install/Distribution/Client/InstallSymlink.hs
+++ b/cabal-install/Distribution/Client/InstallSymlink.hs
@@ -123,7 +123,7 @@ symlinkBinaries comp configFlags installFlags plan =
         | (ReadyPackage _ _flags _ deps, pkg, exe) <- exes
         , let pkgid  = packageId pkg
               pkg_key = mkPackageKey (packageKeySupported comp) pkgid
-                                     (map Installed.packageKey (CD.flatDeps deps)) []
+                                     (map Installed.packageKey (CD.nonSetupDeps deps)) []
               publicExeName  = PackageDescription.exeName exe
               privateExeName = prefix ++ publicExeName ++ suffix
               prefix = substTemplate pkgid pkg_key prefixTemplate
diff --git a/cabal-install/Distribution/Client/PlanIndex.hs b/cabal-install/Distribution/Client/PlanIndex.hs
index 16813b48494..d98d3b99639 100644
--- a/cabal-install/Distribution/Client/PlanIndex.hs
+++ b/cabal-install/Distribution/Client/PlanIndex.hs
@@ -111,7 +111,7 @@ brokenPackages fakeMap index =
   [ (pkg, missing)
   | pkg  <- allPackages index
   , let missing =
-          [ pkg' | pkg' <- CD.flatDeps (depends pkg)
+          [ pkg' | pkg' <- CD.nonSetupDeps (depends pkg)
                  , isNothing (fakeLookupInstalledPackageId fakeMap index pkg') ]
   , not (null missing) ]
 
@@ -188,7 +188,7 @@ dependencyInconsistencies' fakeMap index =
       | -- For each package @pkg@
         pkg <- allPackages index
         -- Find out which @ipid@ @pkg@ depends on
-      , ipid <- CD.flatDeps (fakeDepends fakeMap pkg)
+      , ipid <- CD.nonSetupDeps (fakeDepends fakeMap pkg)
         -- And look up those @ipid@ (i.e., @ipid@ is the ID of @dep@)
       , Just dep <- [fakeLookupInstalledPackageId fakeMap index ipid]
       ]
@@ -204,8 +204,8 @@ dependencyInconsistencies' fakeMap index =
     reallyIsInconsistent [p1, p2] =
       let pid1 = installedPackageId p1
           pid2 = installedPackageId p2
-      in Map.findWithDefault pid1 pid1 fakeMap `notElem` CD.flatDeps (fakeDepends fakeMap p2)
-      && Map.findWithDefault pid2 pid2 fakeMap `notElem` CD.flatDeps (fakeDepends fakeMap p1)
+      in Map.findWithDefault pid1 pid1 fakeMap `notElem` CD.nonSetupDeps (fakeDepends fakeMap p2)
+      && Map.findWithDefault pid2 pid2 fakeMap `notElem` CD.nonSetupDeps (fakeDepends fakeMap p1)
     reallyIsInconsistent _ = True
 
 
@@ -225,7 +225,7 @@ dependencyCycles :: (PackageFixedDeps pkg, HasInstalledPackageId pkg)
 dependencyCycles fakeMap index =
   [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ]
   where
-    adjacencyList = [ (pkg, installedPackageId pkg, CD.flatDeps (fakeDepends fakeMap pkg))
+    adjacencyList = [ (pkg, installedPackageId pkg, CD.nonSetupDeps (fakeDepends fakeMap pkg))
                     | pkg <- allPackages index ]
 
 
@@ -256,7 +256,7 @@ dependencyClosure fakeMap index pkgids0 = case closure mempty [] pkgids0 of
             Just _  -> closure completed  failed pkgids
             Nothing -> closure completed' failed pkgids'
               where completed' = insert pkg completed
-                    pkgids'    = CD.flatDeps (depends pkg) ++ pkgids
+                    pkgids'    = CD.nonSetupDeps (depends pkg) ++ pkgids
 
 
 topologicalOrder :: (PackageFixedDeps pkg, HasInstalledPackageId pkg)
@@ -322,5 +322,5 @@ dependencyGraph fakeMap index = (graph, vertexToPkg, idToVertex)
     resolve   pid = Map.findWithDefault pid pid fakeMap
     edgesFrom pkg = ( ()
                     , resolve (installedPackageId pkg)
-                    , CD.flatDeps (fakeDepends fakeMap pkg)
+                    , CD.nonSetupDeps (fakeDepends fakeMap pkg)
                     )
diff --git a/cabal-install/Distribution/Client/Types.hs b/cabal-install/Distribution/Client/Types.hs
index 1c349b84ce9..cf980261079 100644
--- a/cabal-install/Distribution/Client/Types.hs
+++ b/cabal-install/Distribution/Client/Types.hs
@@ -154,7 +154,7 @@ instance HasInstalledPackageId ReadyPackage where
 readyPackageKey :: Compiler -> ReadyPackage -> PackageKey
 readyPackageKey comp (ReadyPackage pkg _ _ deps) =
     mkPackageKey (packageKeySupported comp) (packageId pkg)
-                 (map Info.packageKey (CD.flatDeps deps)) []
+                 (map Info.packageKey (CD.nonSetupDeps deps)) []
 
 
 -- | Sometimes we need to convert a 'ReadyPackage' back to a

From 1cfec90b6691340993394a8256cb003ea624470e Mon Sep 17 00:00:00 2001
From: Duncan Coutts <duncan@community.haskell.org>
Date: Thu, 13 Nov 2014 20:09:07 +0000
Subject: [PATCH 22/28] Extend .cabal format with a custom-setup section

This patch adds it to the package description types and to the parser.
There is a new custom setup section which contains the setup script's
dependencies. Also add some sanity checks.
---
 Cabal/Distribution/PackageDescription.hs      | 28 ++++++++++
 .../Distribution/PackageDescription/Check.hs  | 16 ++++++
 .../Distribution/PackageDescription/Parse.hs  | 56 ++++++++++++++-----
 3 files changed, 85 insertions(+), 15 deletions(-)

diff --git a/Cabal/Distribution/PackageDescription.hs b/Cabal/Distribution/PackageDescription.hs
index c28fe9c37c2..b7b3a619299 100644
--- a/Cabal/Distribution/PackageDescription.hs
+++ b/Cabal/Distribution/PackageDescription.hs
@@ -104,6 +104,9 @@ module Distribution.PackageDescription (
         RepoKind(..),
         RepoType(..),
         knownRepoTypes,
+
+        -- * Custom setup build information
+        SetupBuildInfo(..),
   ) where
 
 import Distribution.Compat.Binary (Binary)
@@ -186,6 +189,7 @@ data PackageDescription
         -- transitioning to specifying just a single version, not a range.
         specVersionRaw :: Either Version VersionRange,
         buildType      :: Maybe BuildType,
+        setupBuildInfo :: Maybe SetupBuildInfo,
         -- components
         library        :: Maybe Library,
         executables    :: [Executable],
@@ -253,6 +257,7 @@ emptyPackageDescription
                       description  = "",
                       category     = "",
                       customFieldsPD = [],
+                      setupBuildInfo = Nothing,
                       library      = Nothing,
                       executables  = [],
                       testSuites   = [],
@@ -297,6 +302,29 @@ instance Text BuildType where
       "Make"      -> Make
       _           -> UnknownBuildType name
 
+-- ---------------------------------------------------------------------------
+-- The SetupBuildInfo type
+
+-- One can see this as a very cut-down version of BuildInfo below.
+-- To keep things simple for tools that compile Setup.hs we limit the
+-- options authors can specify to just Haskell package dependencies.
+
+data SetupBuildInfo = SetupBuildInfo {
+        setupDepends :: [Dependency]
+    }
+    deriving (Generic, Show, Eq, Read, Typeable, Data)
+
+instance Binary SetupBuildInfo
+
+instance Monoid SetupBuildInfo where
+  mempty = SetupBuildInfo {
+    setupDepends = mempty
+  }
+  mappend a b = SetupBuildInfo {
+    setupDepends = combine setupDepends
+  }
+    where combine field = field a `mappend` field b
+
 -- ---------------------------------------------------------------------------
 -- Module renaming
 
diff --git a/Cabal/Distribution/PackageDescription/Check.hs b/Cabal/Distribution/PackageDescription/Check.hs
index 9127acfb7a9..3f48969142a 100644
--- a/Cabal/Distribution/PackageDescription/Check.hs
+++ b/Cabal/Distribution/PackageDescription/Check.hs
@@ -411,6 +411,12 @@ checkFields pkg =
           ++ commaSep (map display knownBuildTypes)
       _ -> Nothing
 
+  , check (isJust (setupBuildInfo pkg) && buildType pkg /= Just Custom) $
+      PackageBuildWarning $
+           "Ignoring the 'custom-setup' section because the 'build-type' is "
+        ++ "not 'Custom'. Use 'build-type: Custom' if you need to use a "
+        ++ "custom Setup.hs script."
+
   , check (not (null unknownCompilers)) $
       PackageBuildWarning $
         "Unknown compiler " ++ commaSep (map quote unknownCompilers)
@@ -1083,6 +1089,16 @@ checkCabalVersion pkg =
         ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require "
         ++ "compatibility with earlier Cabal versions then you may be able to "
         ++ "use an equivalent compiler-specific flag."
+
+  , check (specVersion pkg >= Version [1,21] []
+           && isNothing (setupBuildInfo pkg)
+           && buildType pkg == Just Custom) $
+      PackageBuildWarning $
+           "Packages using 'cabal-version: >= 1.22' with 'build-type: Custom' "
+        ++ "must use a 'custom-setup' section with a 'setup-depends' field "
+        ++ "that specifies the dependencies of the Setup.hs script itself. "
+        ++ "The 'setup-depends' field uses the same syntax as 'build-depends', "
+        ++ "so a simple example would be 'setup-depends: base, Cabal'."
   ]
   where
     -- Perform a check on packages that use a version of the spec less than
diff --git a/Cabal/Distribution/PackageDescription/Parse.hs b/Cabal/Distribution/PackageDescription/Parse.hs
index 0a4f59ecdb4..b16aa541a1a 100644
--- a/Cabal/Distribution/PackageDescription/Parse.hs
+++ b/Cabal/Distribution/PackageDescription/Parse.hs
@@ -528,6 +528,15 @@ sourceRepoFieldDescrs =
         repoSubdir                 (\val repo -> repo { repoSubdir = val })
     ]
 
+------------------------------------------------------------------------------
+
+setupBInfoFieldDescrs :: [FieldDescr SetupBuildInfo]
+setupBInfoFieldDescrs =
+    [ commaListFieldWithSep vcat "setup-depends"
+        disp         parse
+        setupDepends (\xs binfo -> binfo{setupDepends=xs})
+    ]
+
 -- ---------------------------------------------------------------
 -- Parsing
 
@@ -739,13 +748,13 @@ parsePackageDescription file = do
 
           -- 'getBody' assumes that the remaining fields only consist of
           -- flags, lib and exe sections.
-        (repos, flags, mlib, exes, tests, bms) <- getBody
+        (repos, flags, mcsetup, mlib, exes, tests, bms) <- getBody
         warnIfRest  -- warn if getBody did not parse up to the last field.
           -- warn about using old/new syntax with wrong cabal-version:
         maybeWarnCabalVersion (not $ oldSyntax fields0) pkg
         checkForUndefinedFlags flags mlib exes tests
         return $ GenericPackageDescription
-                   pkg { sourceRepos = repos }
+                   pkg { sourceRepos = repos, setupBuildInfo = mcsetup }
                    flags mlib exes tests bms
 
   where
@@ -851,6 +860,7 @@ parsePackageDescription file = do
     -- The body consists of an optional sequence of declarations of flags and
     -- an arbitrary number of executables and at most one library.
     getBody :: PM ([SourceRepo], [Flag]
+                  ,Maybe SetupBuildInfo
                   ,Maybe (CondTree ConfVar [Dependency] Library)
                   ,[(String, CondTree ConfVar [Dependency] Executable)]
                   ,[(String, CondTree ConfVar [Dependency] TestSuite)]
@@ -863,8 +873,8 @@ parsePackageDescription file = do
             exename <- lift $ runP line_no "executable" parseTokenQ sec_label
             flds <- collectFields parseExeFields sec_fields
             skipField
-            (repos, flags, lib, exes, tests, bms) <- getBody
-            return (repos, flags, lib, (exename, flds): exes, tests, bms)
+            (repos, flags, csetup, lib, exes, tests, bms) <- getBody
+            return (repos, flags, csetup, lib, (exename, flds): exes, tests, bms)
 
         | sec_type == "test-suite" -> do
             when (null sec_label) $ lift $ syntaxError line_no
@@ -905,8 +915,9 @@ parsePackageDescription file = do
             if checkTestType emptyTestSuite flds
                 then do
                     skipField
-                    (repos, flags, lib, exes, tests, bms) <- getBody
-                    return (repos, flags, lib, exes, (testname, flds) : tests, bms)
+                    (repos, flags, csetup, lib, exes, tests, bms) <- getBody
+                    return (repos, flags, csetup, lib, exes,
+                            (testname, flds) : tests, bms)
                 else lift $ syntaxError line_no $
                          "Test suite \"" ++ testname
                       ++ "\" is missing required field \"type\" or the field "
@@ -953,8 +964,9 @@ parsePackageDescription file = do
             if checkBenchmarkType emptyBenchmark flds
                 then do
                     skipField
-                    (repos, flags, lib, exes, tests, bms) <- getBody
-                    return (repos, flags, lib, exes, tests, (benchname, flds) : bms)
+                    (repos, flags, csetup, lib, exes, tests, bms) <- getBody
+                    return (repos, flags, csetup, lib, exes,
+                            tests, (benchname, flds) : bms)
                 else lift $ syntaxError line_no $
                          "Benchmark \"" ++ benchname
                       ++ "\" is missing required field \"type\" or the field "
@@ -967,10 +979,10 @@ parsePackageDescription file = do
               syntaxError line_no "'library' expects no argument"
             flds <- collectFields parseLibFields sec_fields
             skipField
-            (repos, flags, lib, exes, tests, bms) <- getBody
+            (repos, flags, csetup, lib, exes, tests, bms) <- getBody
             when (isJust lib) $ lift $ syntaxError line_no
               "There can only be one library section in a package description."
-            return (repos, flags, Just flds, exes, tests, bms)
+            return (repos, flags, csetup, Just flds, exes, tests, bms)
 
         | sec_type == "flag" -> do
             when (null sec_label) $ lift $
@@ -981,8 +993,8 @@ parsePackageDescription file = do
                     (MkFlag (FlagName (lowercase sec_label)) "" True False)
                     sec_fields
             skipField
-            (repos, flags, lib, exes, tests, bms) <- getBody
-            return (repos, flag:flags, lib, exes, tests, bms)
+            (repos, flags, csetup, lib, exes, tests, bms) <- getBody
+            return (repos, flag:flags, csetup, lib, exes, tests, bms)
 
         | sec_type == "source-repository" -> do
             when (null sec_label) $ lift $ syntaxError line_no $
@@ -1006,8 +1018,22 @@ parsePackageDescription file = do
                     }
                     sec_fields
             skipField
-            (repos, flags, lib, exes, tests, bms) <- getBody
-            return (repo:repos, flags, lib, exes, tests, bms)
+            (repos, flags, csetup, lib, exes, tests, bms) <- getBody
+            return (repo:repos, flags, csetup, lib, exes, tests, bms)
+
+        | sec_type == "custom-setup" -> do
+            unless (null sec_label) $ lift $
+              syntaxError line_no "'setup' expects no argument"
+            flds <- lift $ parseFields
+                             setupBInfoFieldDescrs
+                             warnUnrec
+                             mempty
+                             sec_fields
+            skipField
+            (repos, flags, csetup0, lib, exes, tests, bms) <- getBody
+            when (isJust csetup0) $ lift $ syntaxError line_no
+              "There can only be one 'custom-setup' section in a package description."
+            return (repos, flags, Just flds, lib, exes, tests, bms)
 
         | otherwise -> do
             lift $ warning $ "Ignoring unknown section type: " ++ sec_type
@@ -1023,7 +1049,7 @@ parsePackageDescription file = do
               "If-blocks are not allowed in between stanzas: " ++ show f
             skipField
             getBody
-      Nothing -> return ([], [], Nothing, [], [], [])
+      Nothing -> return ([], [], Nothing, Nothing, [], [], [])
 
     -- Extracts all fields in a block and returns a 'CondTree'.
     --

From e6a88ea5dd0594490848b257e70376ecd5efbbf9 Mon Sep 17 00:00:00 2001
From: Edsko de Vries <edsko@well-typed.com>
Date: Mon, 30 Mar 2015 17:10:06 +0100
Subject: [PATCH 23/28] Add setup dependenices to modular solver's input

(and, therefore, also to the modular solver's output)
---
 .../Client/Dependency/Modular/IndexConversion.hs          | 8 +++++++-
 1 file changed, 7 insertions(+), 1 deletion(-)

diff --git a/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs b/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs
index 47d4538c0a2..8df9e34da53 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs
@@ -114,13 +114,14 @@ convSP os arch cinfo strfl (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) =
 convGPD :: OS -> Arch -> CompilerInfo -> Bool ->
            PI PN -> GenericPackageDescription -> PInfo
 convGPD os arch comp strfl pi
-        (GenericPackageDescription _ flags libs exes tests benchs) =
+        (GenericPackageDescription pkg flags libs exes tests benchs) =
   let
     fds  = flagInfo strfl flags
     conv = convCondTree os arch comp pi fds (const True)
   in
     PInfo
       (maybe []    (conv ComponentLib                       ) libs    ++
+       maybe []    (convSetupBuildInfo pi)    (setupBuildInfo pkg)    ++
        concatMap   (\(nm, ds) -> conv (ComponentExe nm)   ds) exes    ++
       prefix (Stanza (SN pi TestStanzas))
         (L.map     (\(nm, ds) -> conv (ComponentTest nm)  ds) tests)  ++
@@ -211,3 +212,8 @@ convDep pn' (Dependency pn vr) = Dep pn (Constrained [(vr, Goal (P pn') [])])
 -- | Convert a Cabal package identifier to a solver-specific dependency.
 convPI :: PN -> PackageIdentifier -> Dep PN
 convPI pn' (PackageIdentifier pn v) = Dep pn (Constrained [(eqVR v, Goal (P pn') [])])
+
+-- | Convert setup dependencies
+convSetupBuildInfo :: PI PN -> SetupBuildInfo -> FlaggedDeps Component PN
+convSetupBuildInfo (PI pn _i) nfo =
+    L.map (\d -> D.Simple (convDep pn d) ComponentSetup) (PD.setupDepends nfo)

From d78cfecc19ae8fe1be3dca27812a5251b8f25f64 Mon Sep 17 00:00:00 2001
From: Edsko de Vries <edsko@well-typed.com>
Date: Mon, 30 Mar 2015 17:37:50 +0100
Subject: [PATCH 24/28] Treat setup dependencies as independent (always)

---
 .../Client/Dependency/Modular/Builder.hs      | 13 +++-
 .../Client/Dependency/Modular/Dependency.hs   | 69 +++++++++++++++++--
 .../Client/Dependency/Modular/Linking.hs      |  6 +-
 .../Client/Dependency/Modular/Validate.hs     |  7 +-
 4 files changed, 85 insertions(+), 10 deletions(-)

diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs b/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs
index 84cc3d4a0b3..e614c3c6d31 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs
@@ -65,10 +65,19 @@ extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs
 -- dependencies and then extend the set of open goals accordingly.
 scopedExtendOpen :: QPN -> I -> QGoalReasonChain -> FlaggedDeps Component PN -> FlagInfo ->
                     BuildState -> BuildState
-scopedExtendOpen qpn@(Q pp _pn) i gr fdeps fdefs s = extendOpen qpn gs s
+scopedExtendOpen qpn@(Q pp pn) i gr fdeps fdefs s = extendOpen qpn gs s
   where
     -- Qualify all package names
-    qfdeps = L.map (fmap (Q pp)) fdeps
+    --
+    -- NOTE: We `fmap` over the setup dependencies to qualify the package name,
+    -- BUT this is _only_ correct because the setup dependencies cannot have
+    -- conditional sections (setup dependencies cannot depend on flags). IF
+    -- setup dependencies _could_ depend on flags, then these flag names should
+    -- NOT be qualified with @Q (Setup pn pp)@ but rather with @pp@: flag
+    -- assignments are package wide, irrespective of whether or not we treat
+    -- certain dependencies as independent or not.
+    qfdeps = L.map (fmap (Q pp))            (nonSetupDeps fdeps)
+          ++ L.map (fmap (Q (Setup pn pp))) (setupDeps    fdeps)
     -- Introduce all package flags
     qfdefs = L.map (\ (fn, b) -> Flagged (FN (PI qpn i) fn) b [] []) $ M.toList fdefs
     -- Combine new package and flag goals
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs b/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs
index 6f39d85e5c8..0525f56f98f 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs
@@ -21,6 +21,10 @@ module Distribution.Client.Dependency.Modular.Dependency (
     -- ** Setting/forgetting components
   , forgetCompOpenGoal
   , setCompFlaggedDeps
+    -- ** Selecting subsets
+  , nonSetupDeps
+  , setupDeps
+  , select
     -- * Reverse dependency map
   , RevDepMap
     -- * Goals
@@ -43,15 +47,18 @@ module Distribution.Client.Dependency.Modular.Dependency (
 
 import Prelude hiding (pi)
 
-import Data.List as L
-import Data.Map as M
-import Data.Set as S
+import Data.List (intercalate)
+import Data.Map (Map)
+import Data.Maybe (mapMaybe)
+import Data.Set (Set)
+import qualified Data.List as L
+import qualified Data.Set  as S
 
 import Distribution.Client.Dependency.Modular.Flag
 import Distribution.Client.Dependency.Modular.Package
 import Distribution.Client.Dependency.Modular.Version
 
-import Distribution.Client.ComponentDeps (Component)
+import Distribution.Client.ComponentDeps (Component(..))
 
 {-------------------------------------------------------------------------------
   Variables
@@ -213,6 +220,60 @@ mapCompFlaggedDep _ (Flagged fn nfo t f) = Flagged fn nfo   t f
 mapCompFlaggedDep _ (Stanza  sn     t  ) = Stanza  sn       t
 mapCompFlaggedDep g (Simple  pn a      ) = Simple  pn (g a)
 
+{-------------------------------------------------------------------------------
+  Selecting FlaggedDeps subsets
+
+  (Correspond to the functions with the same names in ComponentDeps).
+-------------------------------------------------------------------------------}
+
+nonSetupDeps :: FlaggedDeps Component a -> FlaggedDeps Component a
+nonSetupDeps = select (/= ComponentSetup)
+
+setupDeps :: FlaggedDeps Component a -> FlaggedDeps Component a
+setupDeps = select (== ComponentSetup)
+
+-- | Select the dependencies of a given component
+--
+-- The modular solver kind of flattens the dependency trees from the .cabal
+-- file, putting the component of each dependency at the leaves, rather than
+-- indexing per component. For instance, package C might have flagged deps that
+-- look something like
+--
+-- > Flagged <flagName> ..
+-- >   [Simple <package A> ComponentLib]
+-- >   [Simple <package B> ComponentLib]
+--
+-- indicating that the library component of C relies on either A or B, depending
+-- on the flag. This makes it somewhat awkward however to extract certain kinds
+-- of dependencies. In particular, extracting, say, the setup dependencies from
+-- the above set of dependencies could either return the empty list, or else
+--
+-- > Flagged <flagName> ..
+-- >   []
+-- >   []
+--
+-- Both answers are reasonable; we opt to return the empty list in this
+-- case, as it results in simpler search trees in the builder.
+--
+-- (Note that the builder already introduces separate goals for all flags of a
+-- package, independently of whether or not they are used in any component, so
+-- we don't have to worry about preserving flags here.)
+select :: (Component -> Bool) -> FlaggedDeps Component a -> FlaggedDeps Component a
+select p = mapMaybe go
+  where
+    go :: FlaggedDep Component a -> Maybe (FlaggedDep Component a)
+    go (Flagged fn nfo  t f) = let t' = mapMaybe go t
+                                   f' = mapMaybe go f
+                               in if null t' && null f'
+                                     then Nothing
+                                     else Just $ Flagged fn nfo t' f'
+    go (Stanza  sn      t  ) = let t' = mapMaybe go t
+                               in if null t'
+                                     then Nothing
+                                     else Just $ Stanza  sn     t'
+    go (Simple  pn comp    ) = if p comp then Just $ Simple pn comp
+                                         else Nothing
+
 {-------------------------------------------------------------------------------
   Reverse dependency map
 -------------------------------------------------------------------------------}
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Linking.hs b/cabal-install/Distribution/Client/Dependency/Modular/Linking.hs
index 9a394ac5bf0..d6458773511 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Linking.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Linking.hs
@@ -119,7 +119,8 @@ validateLinking index = (`runReader` initVS) . cata go
     goP qpn@(Q pp pn) opt@(POption i _) r = do
       vs <- ask
       let PInfo deps _ _ = vsIndex vs ! pn ! i
-          qdeps          = map (fmap (Q pp)) deps
+          qdeps          = map (fmap (Q pp))            (nonSetupDeps deps)
+                        ++ map (fmap (Q (Setup pn pp))) (setupDeps    deps)
       case execUpdateState (pickPOption qpn opt qdeps) vs of
         Left  (cs, err) -> return $ Fail cs (DependenciesNotLinked err)
         Right vs'       -> local (const vs') r
@@ -253,7 +254,8 @@ linkNewDeps var b = do
     vs <- get
     let (qpn@(Q pp pn), Just i) = varPI var
         PInfo deps _ _          = vsIndex vs ! pn ! i
-        qdeps                   = map (fmap (Q pp)) deps
+        qdeps                   = map (fmap (Q pp))            (nonSetupDeps deps)
+                               ++ map (fmap (Q (Setup pn pp))) (setupDeps    deps)
         lg                      = vsLinks vs ! qpn
         (parents, newDeps)      = findNewDeps vs qdeps
         linkedTo                = S.delete pp (lgMembers lg)
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs b/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs
index 4d96bf280f7..cfc048ebd00 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs
@@ -124,8 +124,11 @@ validate = cata go
       PA ppa pfa psa <- asks pa    -- obtain current preassignment
       idx            <- asks index -- obtain the index
       svd            <- asks saved -- obtain saved dependencies
-      let (PInfo deps _ mfr) = idx ! pn ! i -- obtain dependencies and index-dictated exclusions introduced by the choice
-      let qdeps = L.map (fmap (Q pp)) deps -- qualify the deps in the current scope
+      -- obtain dependencies and index-dictated exclusions introduced by the choice
+      let (PInfo deps _ mfr) = idx ! pn ! i
+      -- qualify the deps in the current scope
+      let qdeps = L.map (fmap (Q pp))            (nonSetupDeps deps)
+               ++ L.map (fmap (Q (Setup pn pp))) (setupDeps    deps)
       -- the new active constraints are given by the instance we have chosen,
       -- plus the dependency information we have for that instance
       let goal = Goal (P qpn) gr

From afeb48f16fcc67538f13060eff19c39e03a03381 Mon Sep 17 00:00:00 2001
From: Edsko de Vries <edsko@well-typed.com>
Date: Thu, 19 Feb 2015 11:57:50 +0100
Subject: [PATCH 25/28] Add "defer setup choices" heuristic.

By chosing setup dependencies after regular dependencies we get more
opportunities for linking setup dependencies against regular dependencies.
---
 .../Client/Dependency/Modular/Preference.hs         | 13 +++++++++++++
 .../Client/Dependency/Modular/Solver.hs             |  1 +
 2 files changed, 14 insertions(+)

diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs b/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
index eb45b1b0435..0834f0a5a05 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
@@ -259,6 +259,19 @@ preferBaseGoalChoice = trav go
     preferBase _ (OpenGoal (Simple (Dep (Q _pp pn) _) _) _) | unPN pn == "base" = GT
     preferBase _ _                                                              = EQ
 
+-- | Deal with setup dependencies after regular dependencies, so that we can
+-- will link setup depencencies against package dependencies when possible
+deferSetupChoices :: Tree a -> Tree a
+deferSetupChoices = trav go
+  where
+    go (GoalChoiceF xs) = GoalChoiceF (P.sortByKeys deferSetup xs)
+    go x                = x
+
+    deferSetup :: OpenGoal comp -> OpenGoal comp -> Ordering
+    deferSetup (OpenGoal (Simple (Dep (Q (Setup _ _) _) _) _) _) _ = GT
+    deferSetup _ (OpenGoal (Simple (Dep (Q (Setup _ _) _) _) _) _) = LT
+    deferSetup _ _                                                 = EQ
+
 -- | Transformation that sorts choice nodes so that
 -- child nodes with a small branching degree are preferred. As a
 -- special case, choices with 0 branches will be preferred (as they
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs b/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs
index dd93f289449..7484fd0c5eb 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs
@@ -42,6 +42,7 @@ solve sc idx userPrefs userConstraints userGoals =
   where
     explorePhase     = exploreTreeLog . backjump
     heuristicsPhase  = P.firstGoal . -- after doing goal-choice heuristics, commit to the first choice (saves space)
+                       P.deferSetupChoices .
                        P.deferWeakFlagChoices .
                        P.preferBaseGoalChoice .
                        P.preferLinked .

From e733f53af821b1b4cf7a7434cd3706ef41521368 Mon Sep 17 00:00:00 2001
From: Edsko de Vries <edsko@well-typed.com>
Date: Tue, 31 Mar 2015 09:38:01 +0100
Subject: [PATCH 26/28] Take setup deps into account in plan validation

---
 cabal-install/Distribution/Client/InstallPlan.hs | 13 +++++++++----
 cabal-install/Distribution/Client/PlanIndex.hs   |  7 +++++++
 2 files changed, 16 insertions(+), 4 deletions(-)

diff --git a/cabal-install/Distribution/Client/InstallPlan.hs b/cabal-install/Distribution/Client/InstallPlan.hs
index d345b011a93..6e9afb80060 100644
--- a/cabal-install/Distribution/Client/InstallPlan.hs
+++ b/cabal-install/Distribution/Client/InstallPlan.hs
@@ -65,7 +65,9 @@ import Distribution.Version
          ( Version, withinRange )
 import Distribution.PackageDescription
          ( GenericPackageDescription(genPackageFlags)
-         , Flag(flagName), FlagName(..) )
+         , Flag(flagName), FlagName(..)
+         , SetupBuildInfo(..), setupBuildInfo
+         )
 import Distribution.Client.PackageUtils
          ( externalBuildDepends )
 import Distribution.Client.PackageIndex
@@ -637,7 +639,7 @@ configuredPackageProblems platform cinfo
     dependencyName (Dependency name _) = name
 
     mergedDeps :: [MergeResult Dependency PackageId]
-    mergedDeps = mergeDeps requiredDeps (CD.nonSetupDeps specifiedDeps)
+    mergedDeps = mergeDeps requiredDeps (CD.flatDeps specifiedDeps)
 
     mergeDeps :: [Dependency] -> [PackageId] -> [MergeResult Dependency PackageId]
     mergeDeps required specified =
@@ -662,8 +664,11 @@ configuredPackageProblems platform cinfo
          platform cinfo
          []
          (enableStanzas stanzas $ packageDescription pkg) of
-        Right (resolvedPkg, _) -> externalBuildDepends resolvedPkg
-        Left  _ -> error "configuredPackageInvalidDeps internal error"
+        Right (resolvedPkg, _) ->
+             externalBuildDepends resolvedPkg
+          ++ maybe [] setupDepends (setupBuildInfo resolvedPkg)
+        Left  _ ->
+          error "configuredPackageInvalidDeps internal error"
 
 -- | Compute the dependency closure of a _source_ package in a install plan
 --
diff --git a/cabal-install/Distribution/Client/PlanIndex.hs b/cabal-install/Distribution/Client/PlanIndex.hs
index d98d3b99639..bc89f7eecc0 100644
--- a/cabal-install/Distribution/Client/PlanIndex.hs
+++ b/cabal-install/Distribution/Client/PlanIndex.hs
@@ -139,6 +139,7 @@ rootSets :: (PackageFixedDeps pkg, HasInstalledPackageId pkg)
          => FakeMap -> Bool -> PackageIndex pkg -> [[InstalledPackageId]]
 rootSets fakeMap indepGoals index =
        if indepGoals then map (:[]) libRoots else [libRoots]
+    ++ setupRoots index
   where
     libRoots = libraryRoots fakeMap index
 
@@ -156,6 +157,12 @@ libraryRoots fakeMap index =
     roots    = filter isRoot (Graph.vertices graph)
     isRoot v = indegree ! v == 0
 
+-- | The setup dependencies of each package in the plan
+setupRoots :: PackageFixedDeps pkg => PackageIndex pkg -> [[InstalledPackageId]]
+setupRoots = filter (not . null)
+           . map (CD.setupDeps . depends)
+           . allPackages
+
 -- | Given a package index where we assume we want to use all the packages
 -- (use 'dependencyClosure' if you need to get such a index subset) find out
 -- if the dependencies within it use consistent versions of each package.

From a721fbf288b9e18febdff0b2980d6559638fadf5 Mon Sep 17 00:00:00 2001
From: Edsko de Vries <edsko@well-typed.com>
Date: Tue, 31 Mar 2015 10:48:29 +0100
Subject: [PATCH 27/28] Unit tests for setup dependencies

---
 .../Client/Dependency/Modular/Solver.hs       | 211 +++++++++++++-----
 1 file changed, 155 insertions(+), 56 deletions(-)

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 9619f897fd4..ac0916cde0c 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs
@@ -5,17 +5,14 @@ module UnitTests.Distribution.Client.Dependency.Modular.Solver (tests, options)
 
 -- base
 import Control.Monad
-import Data.Maybe (catMaybes, isNothing)
 import Data.Either (partitionEithers)
+import Data.Maybe (catMaybes, isNothing)
+import Data.Monoid
 import Data.Proxy
 import Data.Typeable
 import Data.Version
 import qualified Data.Map as Map
 
-#if !MIN_VERSION_base(4,8,0)
-import Data.Monoid
-#endif
-
 -- test-framework
 import Test.Tasty as TF
 import Test.Tasty.HUnit (testCase, assertEqual, assertBool)
@@ -31,11 +28,13 @@ import qualified Distribution.System               as C
 import qualified Distribution.Version              as C
 
 -- cabal-install
+import Distribution.Client.ComponentDeps (ComponentDeps)
 import Distribution.Client.Dependency
 import Distribution.Client.Dependency.Types
 import Distribution.Client.Types
-import qualified Distribution.Client.InstallPlan  as CI.InstallPlan
-import qualified Distribution.Client.PackageIndex as CI.PackageIndex
+import qualified Distribution.Client.InstallPlan   as CI.InstallPlan
+import qualified Distribution.Client.PackageIndex  as CI.PackageIndex
+import qualified Distribution.Client.ComponentDeps as CD
 
 tests :: [TF.TestTree]
 tests = [
@@ -70,6 +69,16 @@ tests = [
         , runTest $         mkTest db6 "depsWithTests1" ["C"]      (Just [("A", 1), ("B", 1), ("C", 1)])
         , 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)])
+        ]
     ]
   where
     indep test = test { testIndepGoals = True }
@@ -114,37 +123,37 @@ runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) ->
 
 db1 :: ExampleDb
 db1 =
-    let a = ExInst "A" 1 "A-1" []
+    let a = exInst "A" 1 "A-1" []
     in [ Left a
-       , Right $ ExAv "B" 1 [ExAny "A"]
-       , Right $ ExAv "B" 2 [ExAny "A"]
-       , Right $ ExAv "C" 1 [ExFix "B" 1]
-       , Right $ ExAv "D" 1 [ExFix "B" 2]
-       , Right $ ExAv "E" 1 [ExAny "B"]
-       , Right $ ExAv "F" 1 [ExFix "B" 1, ExAny "E"]
-       , Right $ ExAv "G" 1 [ExFix "B" 2, ExAny "E"]
-       , Right $ ExAv "Z" 1 []
+       , Right $ exAv "B" 1 [ExAny "A"]
+       , Right $ exAv "B" 2 [ExAny "A"]
+       , Right $ exAv "C" 1 [ExFix "B" 1]
+       , Right $ exAv "D" 1 [ExFix "B" 2]
+       , Right $ exAv "E" 1 [ExAny "B"]
+       , Right $ exAv "F" 1 [ExFix "B" 1, ExAny "E"]
+       , Right $ exAv "G" 1 [ExFix "B" 2, ExAny "E"]
+       , Right $ exAv "Z" 1 []
        ]
 
 -- In this example, we _can_ install C and D as independent goals, but we have
 -- to pick two diferent versions for B (arbitrarily)
 db2 :: ExampleDb
 db2 = [
-    Right $ ExAv "A" 1 []
-  , Right $ ExAv "A" 2 []
-  , Right $ ExAv "B" 1 [ExAny "A"]
-  , Right $ ExAv "B" 2 [ExAny "A"]
-  , Right $ ExAv "C" 1 [ExAny "B", ExFix "A" 1]
-  , Right $ ExAv "D" 1 [ExAny "B", ExFix "A" 2]
+    Right $ exAv "A" 1 []
+  , Right $ exAv "A" 2 []
+  , Right $ exAv "B" 1 [ExAny "A"]
+  , Right $ exAv "B" 2 [ExAny "A"]
+  , Right $ exAv "C" 1 [ExAny "B", ExFix "A" 1]
+  , Right $ exAv "D" 1 [ExAny "B", ExFix "A" 2]
   ]
 
 db3 :: ExampleDb
 db3 = [
-     Right $ ExAv "A" 1 []
-   , Right $ ExAv "A" 2 []
-   , Right $ ExAv "B" 1 [ExFlag "flagB" [ExFix "A" 1] [ExFix "A" 2]]
-   , Right $ ExAv "C" 1 [ExFix "A" 1, ExAny "B"]
-   , Right $ ExAv "D" 1 [ExFix "A" 2, ExAny "B"]
+     Right $ exAv "A" 1 []
+   , Right $ exAv "A" 2 []
+   , Right $ exAv "B" 1 [ExFlag "flagB" [ExFix "A" 1] [ExFix "A" 2]]
+   , Right $ exAv "C" 1 [ExFix "A" 1, ExAny "B"]
+   , Right $ exAv "D" 1 [ExFix "A" 2, ExAny "B"]
    ]
 
 -- | Like exampleDb2, but the flag picks a different package rather than a
@@ -181,13 +190,13 @@ db3 = [
 -- we only ever assign to one of these, these constraints are never broken.
 db4 :: ExampleDb
 db4 = [
-     Right $ ExAv "Ax" 1 []
-   , Right $ ExAv "Ax" 2 []
-   , Right $ ExAv "Ay" 1 []
-   , Right $ ExAv "Ay" 2 []
-   , Right $ ExAv "B"  1 [ExFlag "flagB" [ExFix "Ax" 1] [ExFix "Ay" 1]]
-   , Right $ ExAv "C"  1 [ExFix "Ax" 2, ExAny "B"]
-   , Right $ ExAv "D"  1 [ExFix "Ay" 2, ExAny "B"]
+     Right $ exAv "Ax" 1 []
+   , Right $ exAv "Ax" 2 []
+   , Right $ exAv "Ay" 1 []
+   , Right $ exAv "Ay" 2 []
+   , Right $ exAv "B"  1 [ExFlag "flagB" [ExFix "Ax" 1] [ExFix "Ay" 1]]
+   , Right $ exAv "C"  1 [ExFix "Ax" 2, ExAny "B"]
+   , Right $ exAv "D"  1 [ExFix "Ay" 2, ExAny "B"]
    ]
 
 -- | Some tests involving testsuites
@@ -207,14 +216,14 @@ db4 = [
 --     E and G together, unless we regard them as independent goals.
 db5 :: ExampleDb
 db5 = [
-    Right $ ExAv "A" 1 []
-  , Right $ ExAv "A" 2 []
-  , Right $ ExAv "B" 1 []
-  , Right $ ExAv "C" 1 [ExTest "testC" [ExAny "A"]]
-  , Right $ ExAv "D" 1 [ExTest "testD" [ExFix "B" 2]]
-  , Right $ ExAv "E" 1 [ExFix "A" 1, ExTest "testE" [ExAny "A"]]
-  , Right $ ExAv "F" 1 [ExFix "A" 1, ExTest "testF" [ExFix "A" 2]]
-  , Right $ ExAv "G" 1 [ExFix "A" 2, ExTest "testG" [ExAny "A"]]
+    Right $ exAv "A" 1 []
+  , Right $ exAv "A" 2 []
+  , Right $ exAv "B" 1 []
+  , Right $ exAv "C" 1 [ExTest "testC" [ExAny "A"]]
+  , Right $ exAv "D" 1 [ExTest "testD" [ExFix "B" 2]]
+  , Right $ exAv "E" 1 [ExFix "A" 1, ExTest "testE" [ExAny "A"]]
+  , Right $ exAv "F" 1 [ExFix "A" 1, ExTest "testF" [ExFix "A" 2]]
+  , Right $ exAv "G" 1 [ExFix "A" 2, ExTest "testG" [ExAny "A"]]
   ]
 
 -- Now the _dependencies_ have test suites
@@ -227,13 +236,84 @@ db5 = [
 --   set things up, this means that we should also link their test suites.
 db6 :: ExampleDb
 db6 = [
-    Right $ ExAv "A" 1 []
-  , Right $ ExAv "A" 2 []
-  , Right $ ExAv "B" 1 [ExTest "testA" [ExAny "A"]]
-  , Right $ ExAv "C" 1 [ExFix "A" 1, ExAny "B"]
-  , Right $ ExAv "D" 1 [ExAny "B"]
+    Right $ exAv "A" 1 []
+  , Right $ exAv "A" 2 []
+  , Right $ exAv "B" 1 [ExTest "testA" [ExAny "A"]]
+  , Right $ exAv "C" 1 [ExFix "A" 1, ExAny "B"]
+  , Right $ exAv "D" 1 [ExAny "B"]
+  ]
+
+-- Packages with setup dependencies
+--
+-- Install..
+-- * B: Simple example, just make sure setup deps are taken into account at all
+-- * C: Both the package and the setup script depend on any version of A.
+--      In this case we prefer to link
+-- * D: Variation on C.1 where the package requires a specific (not latest)
+--      version but the setup dependency is not fixed. Again, we prefer to
+--      link (picking the older version)
+-- * E: Variation on C.2 with the setup dependency the more inflexible.
+--      Currently, in this case we do not see the opportunity to link because
+--      we consider setup dependencies after normal dependencies; we will
+--      pick A.2 for E, then realize we cannot link E.setup.A to A.2, and pick
+--      A.1 instead. This isn't so easy to fix (if we want to fix it at all);
+--      in particular, considering setup dependencies _before_ other deps is
+--      not an improvement, because in general we would prefer to link setup
+--      setups to package deps, rather than the other way around. (For example,
+--      if we change this ordering then the test for D would start to install
+--      two versions of A).
+-- * F: The package and the setup script depend on different versions of A.
+--      This will only work if setup dependencies are considered independent.
+db7 :: ExampleDb
+db7 = [
+    Right $ exAv "A" 1 []
+  , Right $ exAv "A" 2 []
+  , Right $ exAv "B" 1 []            `withSetupDeps` [ExAny "A"]
+  , Right $ exAv "C" 1 [ExAny "A"  ] `withSetupDeps` [ExAny "A"  ]
+  , Right $ exAv "D" 1 [ExFix "A" 1] `withSetupDeps` [ExAny "A"  ]
+  , Right $ exAv "E" 1 [ExAny "A"  ] `withSetupDeps` [ExFix "A" 1]
+  , Right $ exAv "F" 1 [ExFix "A" 2] `withSetupDeps` [ExFix "A" 1]
+  ]
+
+-- If we install C and D together (not as independent goals), we need to build
+-- both B.1 and B.2, both of which depend on A.
+db8 :: ExampleDb
+db8 = [
+    Right $ exAv "A" 1 []
+  , Right $ exAv "B" 1 [ExAny "A"]
+  , Right $ exAv "B" 2 [ExAny "A"]
+  , Right $ exAv "C" 1 [] `withSetupDeps` [ExFix "B" 1]
+  , Right $ exAv "D" 1 [] `withSetupDeps` [ExFix "B" 2]
   ]
 
+-- Extended version of `db8` so that we have nested setup dependencies
+db9 :: ExampleDb
+db9 = db8 ++ [
+    Right $ exAv "E" 1 [ExAny "C"]
+  , Right $ exAv "E" 2 [ExAny "D"]
+  , Right $ exAv "F" 1 [] `withSetupDeps` [ExFix "E" 1]
+  , Right $ exAv "G" 1 [] `withSetupDeps` [ExFix "E" 2]
+  ]
+
+-- Multiple already-installed packages with inter-dependencies, and one package
+-- (C) that depends on package A-1 for its setup script and package A-2 as a
+-- library dependency.
+db10 :: ExampleDb
+db10 =
+  let rts         = exInst "rts"         1 "rts-inst"         []
+      ghc_prim    = exInst "ghc-prim"    1 "ghc-prim-inst"    [rts]
+      base        = exInst "base"        1 "base-inst"        [rts, ghc_prim]
+      a1          = exInst "A"           1 "A1-inst"          [base]
+      a2          = exInst "A"           2 "A2-inst"          [base]
+  in [
+      Left rts
+    , Left ghc_prim
+    , Left base
+    , Left a1
+    , Left a2
+    , Right $ exAv "C" 1 [ExFix "A" 2] `withSetupDeps` [ExFix "A" 1]
+    ]
+
 {-------------------------------------------------------------------------------
   Example package database DSL
 
@@ -298,9 +378,17 @@ data ExampleDependency =
 data ExampleAvailable = ExAv {
     exAvName    :: ExamplePkgName
   , exAvVersion :: ExamplePkgVersion
-  , exAvDeps    :: [ExampleDependency]
+  , exAvDeps    :: ComponentDeps [ExampleDependency]
   }
 
+exAv :: ExamplePkgName -> ExamplePkgVersion -> [ExampleDependency] -> ExampleAvailable
+exAv n v ds = ExAv { exAvName = n, exAvVersion = v, exAvDeps = CD.fromLibraryDeps ds }
+
+withSetupDeps :: ExampleAvailable -> [ExampleDependency] -> ExampleAvailable
+withSetupDeps ex setupDeps = ex {
+      exAvDeps = exAvDeps ex <> CD.fromSetupDeps setupDeps
+    }
+
 data ExampleInstalled = ExInst {
     exInstName         :: ExamplePkgName
   , exInstVersion      :: ExamplePkgVersion
@@ -308,6 +396,9 @@ data ExampleInstalled = ExInst {
   , exInstBuildAgainst :: [ExampleInstalled]
   }
 
+exInst :: ExamplePkgName -> ExamplePkgVersion -> ExamplePkgHash -> [ExampleInstalled] -> ExampleInstalled
+exInst = ExInst
+
 type ExampleDb = [Either ExampleInstalled ExampleAvailable]
 
 type DependencyTree a = C.CondTree C.ConfVar [C.Dependency] a
@@ -317,21 +408,24 @@ exDbPkgs = map (either exInstName exAvName)
 
 exAvSrcPkg :: ExampleAvailable -> SourcePackage
 exAvSrcPkg ex =
-    let (libraryDeps, testSuites) = splitTopLevel (exAvDeps ex)
+    let (libraryDeps, testSuites) = splitTopLevel (CD.libraryDeps (exAvDeps ex))
     in SourcePackage {
            packageInfoId        = exAvPkgId ex
          , packageSource        = LocalTarballPackage "<<path>>"
          , packageDescrOverride = Nothing
          , packageDescription   = C.GenericPackageDescription{
                C.packageDescription = C.emptyPackageDescription {
-                   C.package      = exAvPkgId ex
-                 , C.library      = error "not yet configured: library"
-                 , C.executables  = error "not yet configured: executables"
-                 , C.testSuites   = error "not yet configured: testSuites"
-                 , C.benchmarks   = error "not yet configured: benchmarks"
-                 , C.buildDepends = error "not yet configured: buildDepends"
+                   C.package        = exAvPkgId ex
+                 , C.library        = error "not yet configured: library"
+                 , C.executables    = error "not yet configured: executables"
+                 , C.testSuites     = error "not yet configured: testSuites"
+                 , C.benchmarks     = error "not yet configured: benchmarks"
+                 , C.buildDepends   = error "not yet configured: buildDepends"
+                 , C.setupBuildInfo = Just C.SetupBuildInfo {
+                       C.setupDepends = mkSetupDeps (CD.setupDeps (exAvDeps ex))
+                     }
                  }
-             , C.genPackageFlags = concatMap extractFlags (exAvDeps ex)
+             , C.genPackageFlags = concatMap extractFlags (CD.libraryDeps (exAvDeps ex))
              , C.condLibrary     = Just $ mkCondTree libraryDeps
              , C.condExecutables = []
              , C.condTestSuites  = map (\(t, deps) -> (t, mkCondTree deps)) testSuites
@@ -402,6 +496,11 @@ exAvSrcPkg ex =
     splitDeps (ExTest _ _:_) =
       error "Unexpected nested test"
 
+    -- Currently we only support simple setup dependencies
+    mkSetupDeps :: [ExampleDependency] -> [C.Dependency]
+    mkSetupDeps deps =
+      let (directDeps, []) = splitDeps deps in map mkDirect directDeps
+
 exAvPkgId :: ExampleAvailable -> C.PackageIdentifier
 exAvPkgId ex = C.PackageIdentifier {
       pkgName    = C.PackageName (exAvName ex)

From ba317c2cf97dcf1f2922f98cc1bb7b5e17ee2365 Mon Sep 17 00:00:00 2001
From: Edsko de Vries <edsko@well-typed.com>
Date: Fri, 6 Mar 2015 16:09:44 +0000
Subject: [PATCH 28/28] Actually _use_ setup deps in configure and co

The only problematic thing is that when we call `cabal clean` or `cabal
haddock` (and possibly others), _without_ first having called `configure`, we
attempt to build the setup script without calling the solver at all. This means
that if you do, say,

    cabal configure
    cabal clean
    cabal clean

for a package with a custom setup script that really needs setup dependencies
(for instance, because there are two versions of Cabal in the global package DB
and the setup script needs the _older_ one), then first call to `clean` will
succeed, but the second call will fail because we will try to build the setup
script without the solver and that will fail.
---
 .../Distribution/Client/Configure.hs          | 133 +++++++++++++-----
 cabal-install/Distribution/Client/Install.hs  |  42 ++----
 .../Distribution/Client/SetupWrapper.hs       |  29 +++-
 3 files changed, 142 insertions(+), 62 deletions(-)

diff --git a/cabal-install/Distribution/Client/Configure.hs b/cabal-install/Distribution/Client/Configure.hs
index aadf36a1318..b106cb5ee81 100644
--- a/cabal-install/Distribution/Client/Configure.hs
+++ b/cabal-install/Distribution/Client/Configure.hs
@@ -13,6 +13,7 @@
 -----------------------------------------------------------------------------
 module Distribution.Client.Configure (
     configure,
+    configureSetupScript,
     chooseCabalVersion,
   ) where
 
@@ -30,6 +31,8 @@ import Distribution.Client.SetupWrapper
 import Distribution.Client.Targets
          ( userToPackageConstraint )
 import qualified Distribution.Client.ComponentDeps as CD
+import Distribution.Package (PackageId)
+import Distribution.Client.JobControl (Lock)
 
 import Distribution.Simple.Compiler
          ( Compiler, CompilerInfo, compilerInfo, PackageDB(..), PackageDBStack )
@@ -41,7 +44,10 @@ import Distribution.Simple.Utils
          ( defaultPackageDesc )
 import qualified Distribution.InstalledPackageInfo as Installed
 import Distribution.Package
-         ( Package(..), packageName, Dependency(..), thisPackageVersion )
+         ( Package(..), InstalledPackageId, packageName
+         , Dependency(..), thisPackageVersion
+         )
+import qualified Distribution.PackageDescription as PkgDesc
 import Distribution.PackageDescription.Parse
          ( readPackageDescription )
 import Distribution.PackageDescription.Configuration
@@ -60,6 +66,7 @@ import Distribution.Version
 #if !MIN_VERSION_base(4,8,0)
 import Data.Monoid (Monoid(..))
 #endif
+import Data.Maybe (isJust, fromMaybe)
 
 -- | Choose the Cabal version such that the setup scripts compiled against this
 -- version will support the given command-line flags.
@@ -101,52 +108,114 @@ configure verbosity packageDBs repos comp platform conf
                             progress
   case maybePlan of
     Left message -> do
-      info verbosity message
-      setupWrapper verbosity (setupScriptOptions installedPkgIndex) Nothing
+      info verbosity $
+           "Warning: solver failed to find a solution:\n"
+        ++ message
+        ++ "Trying configure anyway."
+      setupWrapper verbosity (setupScriptOptions installedPkgIndex Nothing) Nothing
         configureCommand (const configFlags) extraArgs
 
     Right installPlan -> case InstallPlan.ready installPlan of
-      [pkg@(ReadyPackage (SourcePackage _ _ (LocalUnpackedPackage _) _) _ _ _)] ->
+      [pkg@(ReadyPackage (SourcePackage _ _ (LocalUnpackedPackage _) _) _ _ _)] -> do
         configurePackage verbosity
           (InstallPlan.planPlatform installPlan)
           (InstallPlan.planCompiler installPlan)
-          (setupScriptOptions installedPkgIndex)
+          (setupScriptOptions installedPkgIndex (Just pkg))
           configFlags pkg extraArgs
 
       _ -> die $ "internal error: configure install plan should have exactly "
               ++ "one local ready package."
 
   where
-    setupScriptOptions index = SetupScriptOptions {
-      useCabalVersion  = chooseCabalVersion configExFlags
-                         (flagToMaybe (configCabalVersion configExFlags)),
-      useCompiler      = Just comp,
-      usePlatform      = Just platform,
-      usePackageDB     = packageDBs',
-      usePackageIndex  = index',
-      useProgramConfig = conf,
-      useDistPref      = fromFlagOrDefault
-                           (useDistPref defaultSetupScriptOptions)
-                           (configDistPref configFlags),
-      useLoggingHandle = Nothing,
-      useWorkingDir    = Nothing,
-      useWin32CleanHack        = False,
-      forceExternalSetupMethod = False,
-      setupCacheLock   = Nothing
-    }
-      where
-        -- Hack: we typically want to allow the UserPackageDB for finding the
-        -- Cabal lib when compiling any Setup.hs even if we're doing a global
-        -- install. However we also allow looking in a specific package db.
-        (packageDBs', index') =
-          case packageDBs of
-            (GlobalPackageDB:dbs) | UserPackageDB `notElem` dbs
-                -> (GlobalPackageDB:UserPackageDB:dbs, Nothing)
-            -- but if the user is using an odd db stack, don't touch it
-            dbs -> (dbs, Just index)
+    setupScriptOptions :: InstalledPackageIndex -> Maybe ReadyPackage -> SetupScriptOptions
+    setupScriptOptions =
+      configureSetupScript
+        packageDBs
+        comp
+        platform
+        conf
+        (fromFlagOrDefault
+           (useDistPref defaultSetupScriptOptions)
+           (configDistPref configFlags))
+        (chooseCabalVersion
+           configExFlags
+           (flagToMaybe (configCabalVersion configExFlags)))
+        Nothing
+        False
 
     logMsg message rest = debug verbosity message >> rest
 
+configureSetupScript :: PackageDBStack
+                     -> Compiler
+                     -> Platform
+                     -> ProgramConfiguration
+                     -> FilePath
+                     -> VersionRange
+                     -> Maybe Lock
+                     -> Bool
+                     -> InstalledPackageIndex
+                     -> Maybe ReadyPackage
+                     -> SetupScriptOptions
+configureSetupScript packageDBs
+                     comp
+                     platform
+                     conf
+                     distPref
+                     cabalVersion
+                     lock
+                     forceExternal
+                     index
+                     mpkg
+  = SetupScriptOptions {
+      useCabalVersion   = cabalVersion
+    , useCompiler       = Just comp
+    , usePlatform       = Just platform
+    , usePackageDB      = packageDBs'
+    , usePackageIndex   = index'
+    , useProgramConfig  = conf
+    , useDistPref       = distPref
+    , useLoggingHandle  = Nothing
+    , useWorkingDir     = Nothing
+    , setupCacheLock    = lock
+    , useWin32CleanHack = False
+    , forceExternalSetupMethod = forceExternal
+      -- If we have explicit setup dependencies, list them; otherwise, we give
+      -- the empty list of dependencies; ideally, we would fix the version of
+      -- Cabal here, so that we no longer need the special case for that in
+      -- `compileSetupExecutable` in `externalSetupMethod`, but we don't yet
+      -- know the version of Cabal at this point, but only find this there.
+      -- Therefore, for now, we just leave this blank.
+    , useDependencies          = fromMaybe [] explicitSetupDeps
+    , useDependenciesExclusive = isJust explicitSetupDeps
+    }
+  where
+    -- When we are compiling a legacy setup script without an explicit
+    -- setup stanza, we typically want to allow the UserPackageDB for
+    -- finding the Cabal lib when compiling any Setup.hs even if we're doing
+    -- a global install. However we also allow looking in a specific package
+    -- db.
+    packageDBs' :: PackageDBStack
+    index'      :: Maybe InstalledPackageIndex
+    (packageDBs', index') =
+      case packageDBs of
+        (GlobalPackageDB:dbs) | UserPackageDB `notElem` dbs
+                              , Nothing <- explicitSetupDeps
+            -> (GlobalPackageDB:UserPackageDB:dbs, Nothing)
+        -- but if the user is using an odd db stack, don't touch it
+        _otherwise -> (packageDBs, Just index)
+
+    explicitSetupDeps :: Maybe [(InstalledPackageId, PackageId)]
+    explicitSetupDeps = do
+      ReadyPackage (SourcePackage _ gpkg _ _) _ _ deps <- mpkg
+      -- Check if there is an explicit setup stanza
+      _buildInfo <- PkgDesc.setupBuildInfo (PkgDesc.packageDescription gpkg)
+      -- Return the setup dependencies computed by the solver
+      return [ ( Installed.installedPackageId deppkg
+               , Installed.sourcePackageId    deppkg
+               )
+             | deppkg <- CD.setupDeps deps
+             ]
+
 -- | Make an 'InstallPlan' for the unpacked package in the current directory,
 -- and all its dependencies.
 --
diff --git a/cabal-install/Distribution/Client/Install.hs b/cabal-install/Distribution/Client/Install.hs
index 81a990cb40d..154cac571c6 100644
--- a/cabal-install/Distribution/Client/Install.hs
+++ b/cabal-install/Distribution/Client/Install.hs
@@ -63,7 +63,7 @@ import System.IO.Error
 
 import Distribution.Client.Targets
 import Distribution.Client.Configure
-         ( chooseCabalVersion )
+         ( chooseCabalVersion, configureSetupScript )
 import Distribution.Client.Dependency
 import Distribution.Client.Dependency.Types
          ( Solver(..) )
@@ -1005,7 +1005,7 @@ performInstallations verbosity
         installLocalPackage verbosity buildLimit
                             (packageId pkg) src' distPref $ \mpath ->
           installUnpackedPackage verbosity buildLimit installLock numJobs pkg_key
-                                 (setupScriptOptions installedPkgIndex cacheLock)
+                                 (setupScriptOptions installedPkgIndex cacheLock rpkg)
                                  miscOptions configFlags' installFlags haddockFlags
                                  cinfo platform pkg pkgoverride mpath useLogFile
 
@@ -1019,31 +1019,19 @@ performInstallations verbosity
     distPref        = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)
                       (configDistPref configFlags)
 
-    setupScriptOptions index lock = SetupScriptOptions {
-      useCabalVersion  = chooseCabalVersion configExFlags
-                         (libVersion miscOptions),
-      useCompiler      = Just comp,
-      usePlatform      = Just platform,
-      -- Hack: we typically want to allow the UserPackageDB for finding the
-      -- Cabal lib when compiling any Setup.hs even if we're doing a global
-      -- install. However we also allow looking in a specific package db.
-      usePackageDB     = if UserPackageDB `elem` packageDBs
-                           then packageDBs
-                           else let (db@GlobalPackageDB:dbs) = packageDBs
-                                 in db : UserPackageDB : dbs,
-                                --TODO: use Ord instance:
-                                -- insert UserPackageDB packageDBs
-      usePackageIndex  = if UserPackageDB `elem` packageDBs
-                           then Just index
-                           else Nothing,
-      useProgramConfig = conf,
-      useDistPref      = distPref,
-      useLoggingHandle = Nothing,
-      useWorkingDir    = Nothing,
-      forceExternalSetupMethod = parallelInstall,
-      useWin32CleanHack        = False,
-      setupCacheLock   = Just lock
-    }
+    setupScriptOptions index lock rpkg =
+      configureSetupScript
+        packageDBs
+        comp
+        platform
+        conf
+        distPref
+        (chooseCabalVersion configExFlags (libVersion miscOptions))
+        (Just lock)
+        parallelInstall
+        index
+        (Just rpkg)
+
     reportingLevel = fromFlag (installBuildReports installFlags)
     logsDir        = fromFlag (globalLogsDir globalFlags)
 
diff --git a/cabal-install/Distribution/Client/SetupWrapper.hs b/cabal-install/Distribution/Client/SetupWrapper.hs
index 3ff8a321204..907a6ae48ee 100644
--- a/cabal-install/Distribution/Client/SetupWrapper.hs
+++ b/cabal-install/Distribution/Client/SetupWrapper.hs
@@ -29,7 +29,7 @@ import Distribution.Version
          , withinRange )
 import Distribution.InstalledPackageInfo (installedPackageId)
 import Distribution.Package
-         ( InstalledPackageId(..), PackageIdentifier(..),
+         ( InstalledPackageId(..), PackageIdentifier(..), PackageId,
            PackageName(..), Package(..), packageName
          , packageVersion, Dependency(..) )
 import Distribution.PackageDescription
@@ -128,6 +128,19 @@ data SetupScriptOptions = SetupScriptOptions {
     useWorkingDir            :: Maybe FilePath,
     forceExternalSetupMethod :: Bool,
 
+    -- | List of dependencies to use when building Setup.hs
+    useDependencies :: [(InstalledPackageId, PackageId)],
+
+    -- | Is the list of setup dependencies exclusive?
+    --
+    -- This is here for legacy reasons. Before the introduction of the explicit
+    -- setup stanza in .cabal files we compiled Setup.hs scripts with all
+    -- packages in the environment visible, but we will needed to restrict
+    -- _some_ packages; in particular, we need to restrict the version of Cabal
+    -- that the setup script gets linked against (this was the only "dependency
+    -- constraint" that we had previously for Setup scripts).
+    useDependenciesExclusive :: Bool,
+
     -- Used only by 'cabal clean' on Windows.
     --
     -- Note: win32 clean hack
@@ -161,6 +174,8 @@ defaultSetupScriptOptions = SetupScriptOptions {
     usePlatform              = Nothing,
     usePackageDB             = [GlobalPackageDB, UserPackageDB],
     usePackageIndex          = Nothing,
+    useDependencies          = [],
+    useDependenciesExclusive = False,
     useProgramConfig         = emptyProgramConfiguration,
     useDistPref              = defaultDistPref,
     useLoggingHandle         = Nothing,
@@ -247,6 +262,7 @@ buildTypeAction (UnknownBuildType _) = error "buildTypeAction UnknownBuildType"
 externalSetupMethod :: SetupMethod
 externalSetupMethod verbosity options pkg bt mkargs = do
   debug verbosity $ "Using external setup method with build-type " ++ show bt
+  debug verbosity $ "Using explicit dependencies: " ++ show (useDependenciesExclusive options)
   createDirectoryIfMissingVerbose verbosity True setupDir
   (cabalLibVersion, mCabalLibInstalledPkgId, options') <- cabalLibVersionToUse
   debug verbosity $ "Using Cabal library version " ++ display cabalLibVersion
@@ -491,6 +507,9 @@ externalSetupMethod verbosity options pkg bt mkargs = do
             = case compilerFlavor compiler of
                       GHCJS -> (ghcjsProgram, ["-build-runner"])
                       _     -> (ghcProgram,   ["-threaded"])
+          cabalDep = maybe [] (\ipkgid -> [(ipkgid, cabalPkgid)])
+                              maybeCabalLibInstalledPkgId
+          addRenaming (ipid, pid) = (ipid, pid, defaultRenaming)
           ghcOptions = mempty {
               ghcOptVerbosity       = Flag verbosity
             , ghcOptMode            = Flag GhcModeMake
@@ -501,9 +520,13 @@ externalSetupMethod verbosity options pkg bt mkargs = do
             , ghcOptSourcePathClear = Flag True
             , ghcOptSourcePath      = toNubListR [workingDir]
             , ghcOptPackageDBs      = usePackageDB options''
+            , ghcOptHideAllPackages = Flag (useDependenciesExclusive options')
             , ghcOptPackages        = toNubListR $
-                maybe [] (\ipkgid -> [(ipkgid, cabalPkgid, defaultRenaming)])
-                maybeCabalLibInstalledPkgId
+                                        map addRenaming $
+                                        if useDependenciesExclusive options'
+                                          then useDependencies options'
+                                          else useDependencies options'
+                                                 ++ cabalDep
             , ghcOptExtra           = toNubListR extraOpts
             }
       let ghcCmdLine = renderGhcOptions compiler ghcOptions