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/13] 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/13] 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/13] 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/13] 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/13] 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/13] 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/13] 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/13] 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/13] 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/13] 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/13] 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/13] 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/13] 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