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] 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 f63b87e560..b933ddc7c9 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 18876c8ae2..1680213401 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 13ec67bc03..48a4faefa4 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 2724402cee..7bf47f2f0f 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.
--
GitLab