diff --git a/cabal-install/Distribution/Client/Config.hs b/cabal-install/Distribution/Client/Config.hs
index 2768c13f3f82cb5200ddab0ef4f5ec0833d2a72e..39f309172b6e77cc62f1082d81d1e337a86b2eb4 100644
--- a/cabal-install/Distribution/Client/Config.hs
+++ b/cabal-install/Distribution/Client/Config.hs
@@ -44,6 +44,8 @@ import Distribution.Client.Types
( RemoteRepo(..), Username(..), Password(..), emptyRemoteRepo )
import Distribution.Client.BuildReports.Types
( ReportLevel(..) )
+import Distribution.Client.Dependency.Types
+ ( ConstraintSource(..) )
import Distribution.Client.Setup
( GlobalFlags(..), globalCommand, defaultGlobalFlags
, ConfigExFlags(..), configureExOptions, defaultConfigExFlags
@@ -676,7 +678,7 @@ configFieldDescriptions =
]
++ toSavedConfig liftConfigExFlag
- (configureExOptions ParseArgs)
+ (configureExOptions ParseArgs ConstraintSourceMainConfig)
[] []
++ toSavedConfig liftInstallFlag
diff --git a/cabal-install/Distribution/Client/Configure.hs b/cabal-install/Distribution/Client/Configure.hs
index 8c098220d63a45fe684b7cefa26930e0c0291be5..b80a2755ccd1f002c731a96c83b794b991f3c987 100644
--- a/cabal-install/Distribution/Client/Configure.hs
+++ b/cabal-install/Distribution/Client/Configure.hs
@@ -18,7 +18,8 @@ module Distribution.Client.Configure (
) where
import Distribution.Client.Dependency
-import Distribution.Client.Dependency.Types (AllowNewer(..), isAllowNewer)
+import Distribution.Client.Dependency.Types
+ ( AllowNewer(..), isAllowNewer, LabeledPackageConstraint(..) )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.InstallPlan (InstallPlan)
import Distribution.Client.IndexUtils as IndexUtils
@@ -262,19 +263,22 @@ planLocalPackage verbosity comp platform configFlags configExFlags
-- version constraints from the config file or command line
-- TODO: should warn or error on constraints that are not on direct
-- deps or flag constraints not on the package in question.
- (map userToPackageConstraint (configExConstraints configExFlags))
+ [ LabeledPackageConstraint (userToPackageConstraint uc) (Just src)
+ | (uc, src) <- configExConstraints configExFlags ]
. addConstraints
-- package flags from the config file or command line
- [ PackageConstraintFlags (packageName pkg)
- (configConfigurationsFlags configFlags) ]
+ [ let pc = PackageConstraintFlags (packageName pkg)
+ (configConfigurationsFlags configFlags)
+ in LabeledPackageConstraint pc Nothing ]
. addConstraints
-- '--enable-tests' and '--enable-benchmarks' constraints from
-- command line
- [ PackageConstraintStanzas (packageName pkg) $
- [ TestStanzas | testsEnabled ] ++
- [ BenchStanzas | benchmarksEnabled ]
+ [ let pc = PackageConstraintStanzas (packageName pkg) $
+ [ TestStanzas | testsEnabled ] ++
+ [ BenchStanzas | benchmarksEnabled ]
+ in LabeledPackageConstraint pc Nothing
]
$ standardInstallPolicy
diff --git a/cabal-install/Distribution/Client/Dependency.hs b/cabal-install/Distribution/Client/Dependency.hs
index e34be5e16f0e2ca63688dbea47c47232984a0614..ceb2123cb341ee32ddfc5bf515231b0fb57d83ed 100644
--- a/cabal-install/Distribution/Client/Dependency.hs
+++ b/cabal-install/Distribution/Client/Dependency.hs
@@ -74,6 +74,8 @@ import Distribution.Client.Types
import Distribution.Client.Dependency.Types
( PreSolver(..), Solver(..), DependencyResolver, ResolverPackage(..)
, PackageConstraint(..), debugPackageConstraint
+ , LabeledPackageConstraint(..), unlabelPackageConstraint
+ , ConstraintSource(..), debugConstraintSource
, AllowNewer(..), PackagePreferences(..), InstalledPreference(..)
, PackagesPreferenceDefault(..)
, Progress(..), foldProgress )
@@ -134,7 +136,7 @@ import Control.Exception
--
data DepResolverParams = DepResolverParams {
depResolverTargets :: [PackageName],
- depResolverConstraints :: [PackageConstraint],
+ depResolverConstraints :: [LabeledPackageConstraint],
depResolverPreferences :: [PackagePreference],
depResolverPreferenceDefault :: PackagesPreferenceDefault,
depResolverInstalledPkgIndex :: InstalledPackageIndex,
@@ -151,12 +153,16 @@ debugDepResolverParams :: DepResolverParams -> String
debugDepResolverParams p =
"targets: " ++ intercalate ", " (map display (depResolverTargets p))
++ "\nconstraints: "
- ++ concatMap (("\n " ++) . debugPackageConstraint)
+ ++ concatMap (("\n " ++) . debugLabeledConstraint)
(depResolverConstraints p)
++ "\npreferences: "
++ concatMap (("\n " ++) . debugPackagePreference)
(depResolverPreferences p)
++ "\nstrategy: " ++ show (depResolverPreferenceDefault p)
+ where
+ debugLabeledConstraint (LabeledPackageConstraint pc src) =
+ debugPackageConstraint pc ++ maybe "" showSrc src
+ showSrc src = " (" ++ debugConstraintSource src ++ ")"
-- | A package selection preference for a particular package.
--
@@ -207,7 +213,7 @@ addTargets extraTargets params =
depResolverTargets = extraTargets ++ depResolverTargets params
}
-addConstraints :: [PackageConstraint]
+addConstraints :: [LabeledPackageConstraint]
-> DepResolverParams -> DepResolverParams
addConstraints extraConstraints params =
params {
@@ -273,7 +279,9 @@ dontUpgradeNonUpgradeablePackages params =
addConstraints extraConstraints params
where
extraConstraints =
- [ PackageConstraintInstalled pkgname
+ [ LabeledPackageConstraint
+ (PackageConstraintInstalled pkgname)
+ (Just ConstraintSourceNonUpgradeablePackage)
| all (/=PackageName "base") (depResolverTargets params)
, pkgname <- map PackageName [ "base", "ghc-prim", "integer-gmp"
, "integer-simple" ]
@@ -474,8 +482,11 @@ applySandboxInstallPolicy
(thisVersion (packageVersion pkg)) | pkg <- otherDeps ]
. addConstraints
- [ PackageConstraintVersion (packageName pkg)
- (thisVersion (packageVersion pkg)) | pkg <- modifiedDeps ]
+ [ let pc = PackageConstraintVersion (packageName pkg)
+ (thisVersion (packageVersion pkg))
+ in LabeledPackageConstraint pc
+ (Just ConstraintSourceModifiedAddSourceDep)
+ | pkg <- modifiedDeps ]
. addTargets [ packageName pkg | pkg <- modifiedDeps ]
@@ -814,8 +825,9 @@ resolveWithoutDependencies (DepResolverParams targets constraints
packageConstraints pkgname =
Map.findWithDefault anyVersion pkgname packageVersionConstraintMap
packageVersionConstraintMap =
- Map.fromList [ (name, range)
- | PackageConstraintVersion name range <- constraints ]
+ let pcs = map unlabelPackageConstraint constraints
+ in Map.fromList [ (name, range)
+ | PackageConstraintVersion name range <- pcs ]
packagePreferences :: PackageName -> PackagePreferences
packagePreferences = interpretPackagesPreference
diff --git a/cabal-install/Distribution/Client/Dependency/Modular.hs b/cabal-install/Distribution/Client/Dependency/Modular.hs
index b2be4fc2fe1429574ce07e7610a3b9c69726ac5b..60fde9aed74f9d5f46fca64bad4d04b5d3481aaa 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular.hs
@@ -26,7 +26,8 @@ import Distribution.Client.Dependency.Modular.Package
import Distribution.Client.Dependency.Modular.Solver
( SolverConfig(..), solve )
import Distribution.Client.Dependency.Types
- ( DependencyResolver, ResolverPackage, PackageConstraint(..) )
+ ( DependencyResolver, ResolverPackage
+ , PackageConstraint(..), unlabelPackageConstraint )
import Distribution.System
( Platform(..) )
@@ -41,7 +42,9 @@ modularResolver sc (Platform arch os) cinfo iidx sidx pprefs pcs pns =
-- Indices have to be converted into solver-specific uniform index.
idx = convPIs os arch cinfo (shadowPkgs sc) (strongFlags sc) iidx sidx
-- Constraints have to be converted into a finite map indexed by PN.
- gcs = M.fromListWith (++) (map (\ pc -> (pcName pc, [pc])) pcs)
+ gcs = M.fromListWith (++) (map pair pcs)
+ where
+ pair lpc = (pcName $ unlabelPackageConstraint lpc, [lpc])
-- Results have to be converted into an install plan.
postprocess :: Assignment -> RevDepMap -> [ResolverPackage]
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Message.hs b/cabal-install/Distribution/Client/Dependency/Modular/Message.hs
index cf5dcd7a3d49971051156f6a5a551a0b985b6563..df006aa10ea53546ae8bcd9ceb74412850ef2db2 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Message.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Message.hs
@@ -1,4 +1,7 @@
-module Distribution.Client.Dependency.Modular.Message where
+module Distribution.Client.Dependency.Modular.Message (
+ Message(..),
+ showMessages
+ ) where
import qualified Data.List as L
import Prelude hiding (pi)
@@ -9,6 +12,8 @@ import Distribution.Client.Dependency.Modular.Dependency
import Distribution.Client.Dependency.Modular.Flag
import Distribution.Client.Dependency.Modular.Package
import Distribution.Client.Dependency.Modular.Tree
+import Distribution.Client.Dependency.Types
+ ( ConstraintSource(..), debugConstraintSource )
data Message =
Enter -- ^ increase indentation level
@@ -86,24 +91,28 @@ showGR (FDependency qfn b) = " (dependency of " ++ showQFNBool qfn b ++ ")"
showGR (SDependency qsn) = " (dependency of " ++ showQSNBool qsn True ++ ")"
showFR :: ConflictSet QPN -> FailReason -> String
-showFR _ InconsistentInitialConstraints = " (inconsistent initial constraints)"
-showFR _ (Conflicting ds) = " (conflict: " ++ L.intercalate ", " (map showDep ds) ++ ")"
-showFR _ CannotInstall = " (only already installed instances can be used)"
-showFR _ CannotReinstall = " (avoiding to reinstall a package with same version but new dependencies)"
-showFR _ Shadowed = " (shadowed by another installed package with same version)"
-showFR _ Broken = " (package is broken)"
-showFR _ (GlobalConstraintVersion vr) = " (global constraint requires " ++ display vr ++ ")"
-showFR _ GlobalConstraintInstalled = " (global constraint requires installed instance)"
-showFR _ GlobalConstraintSource = " (global constraint requires source instance)"
-showFR _ GlobalConstraintFlag = " (global constraint requires opposite flag selection)"
-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)"
-showFR c (DependenciesNotLinked msg) = " (dependencies not linked: " ++ msg ++ "; conflict set: " ++ showCS c ++ ")"
+showFR _ InconsistentInitialConstraints = " (inconsistent initial constraints)"
+showFR _ (Conflicting ds) = " (conflict: " ++ L.intercalate ", " (map showDep ds) ++ ")"
+showFR _ CannotInstall = " (only already installed instances can be used)"
+showFR _ CannotReinstall = " (avoiding to reinstall a package with same version but new dependencies)"
+showFR _ Shadowed = " (shadowed by another installed package with same version)"
+showFR _ Broken = " (package is broken)"
+showFR _ (GlobalConstraintVersion vr src) = " (" ++ showConstraintSource src ++ " requires " ++ display vr ++ ")"
+showFR _ (GlobalConstraintInstalled src) = " (" ++ showConstraintSource src ++ " requires installed instance)"
+showFR _ (GlobalConstraintSource src) = " (" ++ showConstraintSource src ++ " requires source instance)"
+showFR _ (GlobalConstraintFlag src) = " (" ++ showConstraintSource src ++ " requires opposite flag selection)"
+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)"
+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.
-showFR _ (MalformedFlagChoice qfn) = " (INTERNAL ERROR: MALFORMED FLAG CHOICE: " ++ showQFN qfn ++ ")"
-showFR _ (MalformedStanzaChoice qsn) = " (INTERNAL ERROR: MALFORMED STANZA CHOICE: " ++ showQSN qsn ++ ")"
-showFR _ EmptyGoalChoice = " (INTERNAL ERROR: EMPTY GOAL CHOICE)"
+showFR _ (MalformedFlagChoice qfn) = " (INTERNAL ERROR: MALFORMED FLAG CHOICE: " ++ showQFN qfn ++ ")"
+showFR _ (MalformedStanzaChoice qsn) = " (INTERNAL ERROR: MALFORMED STANZA CHOICE: " ++ showQSN qsn ++ ")"
+showFR _ EmptyGoalChoice = " (INTERNAL ERROR: EMPTY GOAL CHOICE)"
+
+showConstraintSource :: Maybe ConstraintSource -> String
+showConstraintSource Nothing = "global constraint"
+showConstraintSource (Just src) = "global constraint from " ++ debugConstraintSource src
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs b/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
index 6b6ca343df6330be4f962487acc32fee4d3fb343..92970bc4f7e25760a3a3e6323923d02f8ac1be51 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
@@ -17,7 +17,8 @@ import Data.Map (Map)
import Data.Traversable (sequence)
import Distribution.Client.Dependency.Types
- ( PackageConstraint(..), PackagePreferences(..), InstalledPreference(..) )
+ ( PackageConstraint(..), LabeledPackageConstraint(..)
+ , PackagePreferences(..), InstalledPreference(..) )
import Distribution.Client.Types
( OptionalStanza(..) )
@@ -95,44 +96,66 @@ preferLatestOrdering (I v1 _) (I v2 _) = compare v1 v2
-- given instance for a P-node. Translates the constraint into a
-- tree-transformer that either leaves the subtree untouched, or replaces it
-- with an appropriate failure node.
-processPackageConstraintP :: ConflictSet QPN -> I -> PackageConstraint -> Tree a -> Tree a
-processPackageConstraintP c (I v _) (PackageConstraintVersion _ vr) r
- | checkVR vr v = r
- | otherwise = Fail c (GlobalConstraintVersion vr)
-processPackageConstraintP c i (PackageConstraintInstalled _) r
- | instI i = r
- | otherwise = Fail c GlobalConstraintInstalled
-processPackageConstraintP c i (PackageConstraintSource _) r
- | not (instI i) = r
- | otherwise = Fail c GlobalConstraintSource
-processPackageConstraintP _ _ _ r = r
+processPackageConstraintP :: ConflictSet QPN
+ -> I
+ -> LabeledPackageConstraint
+ -> Tree a
+ -> Tree a
+processPackageConstraintP c i (LabeledPackageConstraint pc src) r =
+ case (i, pc) of
+ (I v _, PackageConstraintVersion _ vr)
+ | checkVR vr v -> r
+ | otherwise -> Fail c (GlobalConstraintVersion vr src)
+ (_, PackageConstraintInstalled _)
+ | instI i -> r
+ | otherwise -> Fail c (GlobalConstraintInstalled src)
+ (_, PackageConstraintSource _)
+ | not (instI i) -> r
+ | otherwise -> Fail c (GlobalConstraintSource src)
+ (_, _) -> r
-- | Helper function that tries to enforce a single package constraint on a
-- given flag setting for an F-node. Translates the constraint into a
-- tree-transformer that either leaves the subtree untouched, or replaces it
-- with an appropriate failure node.
-processPackageConstraintF :: Flag -> ConflictSet QPN -> Bool -> PackageConstraint -> Tree a -> Tree a
-processPackageConstraintF f c b' (PackageConstraintFlags _ fa) r =
- case L.lookup f fa of
- Nothing -> r
- Just b | b == b' -> r
- | otherwise -> Fail c GlobalConstraintFlag
-processPackageConstraintF _ _ _ _ r = r
+processPackageConstraintF :: Flag
+ -> ConflictSet QPN
+ -> Bool
+ -> LabeledPackageConstraint
+ -> Tree a
+ -> Tree a
+processPackageConstraintF f c b' (LabeledPackageConstraint pc src) r =
+ case pc of
+ PackageConstraintFlags _ fa ->
+ case L.lookup f fa of
+ Nothing -> r
+ Just b | b == b' -> r
+ | otherwise -> Fail c (GlobalConstraintFlag src)
+ _ -> r
-- | Helper function that tries to enforce a single package constraint on a
-- given flag setting for an F-node. Translates the constraint into a
-- tree-transformer that either leaves the subtree untouched, or replaces it
-- with an appropriate failure node.
-processPackageConstraintS :: OptionalStanza -> ConflictSet QPN -> Bool -> PackageConstraint -> Tree a -> Tree a
-processPackageConstraintS s c b' (PackageConstraintStanzas _ ss) r =
- if not b' && s `elem` ss then Fail c GlobalConstraintFlag
- else r
-processPackageConstraintS _ _ _ _ r = r
+processPackageConstraintS :: OptionalStanza
+ -> ConflictSet QPN
+ -> Bool
+ -> LabeledPackageConstraint
+ -> Tree a
+ -> Tree a
+processPackageConstraintS s c b' (LabeledPackageConstraint pc src) r =
+ case pc of
+ PackageConstraintStanzas _ ss ->
+ if not b' && s `elem` ss then Fail c (GlobalConstraintFlag src)
+ else r
+ _ -> r
-- | Traversal that tries to establish various kinds of user constraints. Works
-- by selectively disabling choices that have been ruled out by global user
-- constraints.
-enforcePackageConstraints :: M.Map PN [PackageConstraint] -> Tree QGoalReasonChain -> Tree QGoalReasonChain
+enforcePackageConstraints :: M.Map PN [LabeledPackageConstraint]
+ -> Tree QGoalReasonChain
+ -> Tree QGoalReasonChain
enforcePackageConstraints pcs = trav go
where
go (PChoiceF qpn@(Q _ pn) gr ts) =
@@ -169,8 +192,8 @@ enforceManualFlags = trav go
([], y : ys) -> P.fromList (y : L.map (\ (b, _) -> (b, Fail c ManualFlag)) ys)
_ -> ts -- something has been manually selected, leave things alone
where
- isDisabled (_, Fail _ GlobalConstraintFlag) = True
- isDisabled _ = False
+ isDisabled (_, Fail _ (GlobalConstraintFlag _)) = True
+ isDisabled _ = False
go x = x
-- | Prefer installed packages over non-installed packages, generally.
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs b/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs
index 4e489a44beea27c66be0387a8ad894c47e06ab6d..af5901f62816a098756bd1940ddec4ea7a0be075 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs
@@ -26,11 +26,11 @@ data SolverConfig = SolverConfig {
maxBackjumps :: Maybe Int
}
-solve :: SolverConfig -> -- solver parameters
- Index -> -- all available packages as an index
- (PN -> PackagePreferences) -> -- preferences
- Map PN [PackageConstraint] -> -- global constraints
- [PN] -> -- global goals
+solve :: SolverConfig -> -- solver parameters
+ Index -> -- all available packages as an index
+ (PN -> PackagePreferences) -> -- preferences
+ Map PN [LabeledPackageConstraint] -> -- global constraints
+ [PN] -> -- global goals
Log Message (Assignment, RevDepMap)
solve sc idx userPrefs userConstraints userGoals =
explorePhase $
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs b/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs
index 01ba37a67837514a57a5c356388f8f8f10fb00f7..ac9766b43cc02d6217fdbcfe315001d28e2e74cb 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs
@@ -11,6 +11,7 @@ import Distribution.Client.Dependency.Modular.Flag
import Distribution.Client.Dependency.Modular.Package
import Distribution.Client.Dependency.Modular.PSQ as P
import Distribution.Client.Dependency.Modular.Version
+import Distribution.Client.Dependency.Types ( ConstraintSource(..) )
-- | Type of the search tree. Inlining the choice nodes for now.
data Tree a =
@@ -55,10 +56,10 @@ data FailReason = InconsistentInitialConstraints
| CannotReinstall
| Shadowed
| Broken
- | GlobalConstraintVersion VR
- | GlobalConstraintInstalled
- | GlobalConstraintSource
- | GlobalConstraintFlag
+ | GlobalConstraintVersion VR (Maybe ConstraintSource)
+ | GlobalConstraintInstalled (Maybe ConstraintSource)
+ | GlobalConstraintSource (Maybe ConstraintSource)
+ | GlobalConstraintFlag (Maybe ConstraintSource)
| ManualFlag
| BuildFailureNotInIndex PN
| MalformedFlagChoice QFN
diff --git a/cabal-install/Distribution/Client/Dependency/TopDown.hs b/cabal-install/Distribution/Client/Dependency/TopDown.hs
index 32a53b130ab1b15792aae496533a12c442c57f52..52f8fa5822c7d4988f0d31b911027e1795f87447 100644
--- a/cabal-install/Distribution/Client/Dependency/TopDown.hs
+++ b/cabal-install/Distribution/Client/Dependency/TopDown.hs
@@ -23,7 +23,8 @@ import Distribution.Client.Types
( SourcePackage(..), ConfiguredPackage(..)
, enableStanzas, ConfiguredId(..), fakeInstalledPackageId )
import Distribution.Client.Dependency.Types
- ( DependencyResolver, ResolverPackage(..), PackageConstraint(..)
+ ( DependencyResolver, ResolverPackage(..)
+ , PackageConstraint(..), unlabelPackageConstraint
, PackagePreferences(..), InstalledPreference(..)
, Progress(..), foldProgress )
@@ -254,7 +255,8 @@ topDownResolver platform cinfo installedPkgIndex sourcePkgIndex
platform cinfo
(convertInstalledPackageIndex installedPkgIndex)
sourcePkgIndex
- preferences constraints
+ preferences
+ (map unlabelPackageConstraint constraints)
targets
where
mapMessages :: Progress Log Failure a -> Progress String String a
diff --git a/cabal-install/Distribution/Client/Dependency/Types.hs b/cabal-install/Distribution/Client/Dependency/Types.hs
index 87dde8c903d13f6208c9d0d7477efddb78c9c0b3..6b765f2f8fd6a0de9d3c11e644495a1077035592 100644
--- a/cabal-install/Distribution/Client/Dependency/Types.hs
+++ b/cabal-install/Distribution/Client/Dependency/Types.hs
@@ -27,6 +27,11 @@ module Distribution.Client.Dependency.Types (
Progress(..),
foldProgress,
+
+ LabeledPackageConstraint(..),
+ ConstraintSource(..),
+ unlabelPackageConstraint,
+ debugConstraintSource
) where
#if !MIN_VERSION_base(4,8,0)
@@ -105,7 +110,7 @@ type DependencyResolver = Platform
-> InstalledPackageIndex
-> PackageIndex.PackageIndex SourcePackage
-> (PackageName -> PackagePreferences)
- -> [PackageConstraint]
+ -> [LabeledPackageConstraint]
-> [PackageName]
-> Progress String String [ResolverPackage]
@@ -250,3 +255,34 @@ instance Applicative (Progress step fail) where
instance Monoid fail => Alternative (Progress step fail) where
empty = Fail mempty
p <|> q = foldProgress Step (const q) Done p
+
+-- | 'PackageConstraint' labeled with its source. The source is optional
+-- because not all constraints are tracked currently.
+data LabeledPackageConstraint
+ = LabeledPackageConstraint PackageConstraint (Maybe ConstraintSource)
+
+unlabelPackageConstraint :: LabeledPackageConstraint -> PackageConstraint
+unlabelPackageConstraint (LabeledPackageConstraint pc _) = pc
+
+-- | Source of a 'PackageConstraint'.
+data ConstraintSource
+ = ConstraintSourceMainConfig
+ | ConstraintSourceSandboxConfig
+ | ConstraintSourceUserConfig
+ | ConstraintSourceCommandlineFlag
+ | ConstraintSourceUserTarget
+ | ConstraintSourceNonUpgradeablePackage
+ | ConstraintSourceModifiedAddSourceDep
+ deriving (Eq, Show)
+
+-- | Description of a 'ConstraintSource'.
+debugConstraintSource :: ConstraintSource -> String
+debugConstraintSource ConstraintSourceMainConfig = "main config file"
+debugConstraintSource ConstraintSourceSandboxConfig = "sandbox config file"
+debugConstraintSource ConstraintSourceUserConfig = "cabal.config"
+debugConstraintSource ConstraintSourceCommandlineFlag = "command line flag"
+debugConstraintSource ConstraintSourceUserTarget = "user target"
+debugConstraintSource ConstraintSourceNonUpgradeablePackage =
+ "non-upgradeable package"
+debugConstraintSource ConstraintSourceModifiedAddSourceDep =
+ "modified add-source dependency"
diff --git a/cabal-install/Distribution/Client/Freeze.hs b/cabal-install/Distribution/Client/Freeze.hs
index 197490a9823793adc283076d145fe760b08162ca..e850761f9e16eab51cfc6e4c067caabf67bfb18a 100644
--- a/cabal-install/Distribution/Client/Freeze.hs
+++ b/cabal-install/Distribution/Client/Freeze.hs
@@ -20,6 +20,8 @@ import Distribution.Client.Config ( SavedConfig(..) )
import Distribution.Client.Types
import Distribution.Client.Targets
import Distribution.Client.Dependency
+import Distribution.Client.Dependency.Types
+ ( ConstraintSource(..), LabeledPackageConstraint(..) )
import Distribution.Client.IndexUtils as IndexUtils
( getSourcePackages, getInstalledPackages )
import Distribution.Client.InstallPlan
@@ -162,7 +164,9 @@ planPackages verbosity comp platform mSandboxPkgInfo freezeFlags
. setStrongFlags strongFlags
. addConstraints
- [ PackageConstraintStanzas (pkgSpecifierTarget pkgSpecifier) stanzas
+ [ let pkg = pkgSpecifierTarget pkgSpecifier
+ pc = PackageConstraintStanzas pkg stanzas
+ in LabeledPackageConstraint pc Nothing
| pkgSpecifier <- pkgSpecifiers ]
. maybe id applySandboxInstallPolicy mSandboxPkgInfo
@@ -218,14 +222,15 @@ freezePackages verbosity pkgs = do
addFrozenConstraints config =
config {
savedConfigureExFlags = (savedConfigureExFlags config) {
- configExConstraints = constraints pkgs
+ configExConstraints = map constraint pkgs
}
}
- constraints = map $ pkgIdToConstraint . packageId
+ constraint pkg =
+ (pkgIdToConstraint $ packageId pkg, ConstraintSourceUserConfig)
where
- pkgIdToConstraint pkg =
- UserConstraintVersion (packageName pkg)
- (thisVersion $ packageVersion pkg)
+ pkgIdToConstraint pkgId =
+ UserConstraintVersion (packageName pkgId)
+ (thisVersion $ packageVersion pkgId)
createPkgEnv config = mempty { pkgEnvSavedConfig = config }
showPkgEnv = BS.Char8.pack . showPackageEnvironment
diff --git a/cabal-install/Distribution/Client/Install.hs b/cabal-install/Distribution/Client/Install.hs
index 839b7f4656ee1b93ca12ac4b3e0125ce35883b34..66f4622a826af973094f8b6c8e62711feeba8339 100644
--- a/cabal-install/Distribution/Client/Install.hs
+++ b/cabal-install/Distribution/Client/Install.hs
@@ -70,7 +70,7 @@ import Distribution.Client.Configure
( chooseCabalVersion, configureSetupScript )
import Distribution.Client.Dependency
import Distribution.Client.Dependency.Types
- ( Solver(..) )
+ ( Solver(..), LabeledPackageConstraint(..) )
import Distribution.Client.FetchUtils
import Distribution.Client.HttpUtils
( configureTransport, HttpTransport (..) )
@@ -372,18 +372,23 @@ planPackages comp platform mSandboxPkgInfo solver
. addConstraints
-- version constraints from the config file or command line
- (map userToPackageConstraint (configExConstraints configExFlags))
+ [ LabeledPackageConstraint (userToPackageConstraint pc) (Just src)
+ | (pc, src) <- configExConstraints configExFlags ]
. addConstraints
--FIXME: this just applies all flags to all targets which
-- is silly. We should check if the flags are appropriate
- [ PackageConstraintFlags (pkgSpecifierTarget pkgSpecifier) flags
+ [ let pc = PackageConstraintFlags
+ (pkgSpecifierTarget pkgSpecifier) flags
+ in LabeledPackageConstraint pc Nothing
| let flags = configConfigurationsFlags configFlags
, not (null flags)
, pkgSpecifier <- pkgSpecifiers ]
. addConstraints
- [ PackageConstraintStanzas (pkgSpecifierTarget pkgSpecifier) stanzas
+ [ let pc = PackageConstraintStanzas
+ (pkgSpecifierTarget pkgSpecifier) stanzas
+ in LabeledPackageConstraint pc Nothing
| pkgSpecifier <- pkgSpecifiers ]
. maybe id applySandboxInstallPolicy mSandboxPkgInfo
diff --git a/cabal-install/Distribution/Client/Sandbox/PackageEnvironment.hs b/cabal-install/Distribution/Client/Sandbox/PackageEnvironment.hs
index dffa98aaf888bf6a02edaa72f87d2e40d49e8d7d..7e9061915ad4261251c969d940f79f9c03ecbec7 100644
--- a/cabal-install/Distribution/Client/Sandbox/PackageEnvironment.hs
+++ b/cabal-install/Distribution/Client/Sandbox/PackageEnvironment.hs
@@ -36,6 +36,7 @@ import Distribution.Client.Config ( SavedConfig(..), commentSavedConfig
, installDirsFields, withProgramsFields
, withProgramOptionsFields
, defaultCompiler )
+import Distribution.Client.Dependency.Types ( ConstraintSource (..) )
import Distribution.Client.ParseUtils ( parseFields, ppFields, ppSection )
import Distribution.Client.Setup ( GlobalFlags(..), ConfigExFlags(..)
, InstallFlags(..)
@@ -284,7 +285,7 @@ inheritedPackageEnvironment verbosity pkgEnv = do
userPackageEnvironment :: Verbosity -> FilePath -> IO PackageEnvironment
userPackageEnvironment verbosity pkgEnvDir = do
let path = pkgEnvDir </> userPackageEnvironmentFile
- minp <- readPackageEnvironmentFile mempty path
+ minp <- readPackageEnvironmentFile ConstraintSourceUserConfig mempty path
case minp of
Nothing -> return mempty
Just (ParseOk warns parseResult) -> do
@@ -327,7 +328,8 @@ tryLoadSandboxPackageEnvironmentFile :: Verbosity -> FilePath -> (Flag FilePath)
-> IO (FilePath, PackageEnvironment)
tryLoadSandboxPackageEnvironmentFile verbosity pkgEnvFile configFileFlag = do
let pkgEnvDir = takeDirectory pkgEnvFile
- minp <- readPackageEnvironmentFile mempty pkgEnvFile
+ minp <- readPackageEnvironmentFile
+ ConstraintSourceSandboxConfig mempty pkgEnvFile
pkgEnv <- handleParseResult verbosity pkgEnvFile minp
-- Get the saved sandbox directory.
@@ -401,15 +403,15 @@ createPackageEnvironmentFile verbosity sandboxDir pkgEnvFile incComments
writePackageEnvironmentFile pkgEnvFile incComments commentPkgEnv initialPkgEnv
-- | Descriptions of all fields in the package environment file.
-pkgEnvFieldDescrs :: [FieldDescr PackageEnvironment]
-pkgEnvFieldDescrs = [
+pkgEnvFieldDescrs :: ConstraintSource -> [FieldDescr PackageEnvironment]
+pkgEnvFieldDescrs src = [
simpleField "inherit"
(fromFlagOrDefault Disp.empty . fmap Disp.text) (optional parseFilePathQ)
pkgEnvInherit (\v pkgEnv -> pkgEnv { pkgEnvInherit = v })
-- FIXME: Should we make these fields part of ~/.cabal/config ?
, commaNewLineListField "constraints"
- Text.disp Text.parse
+ (Text.disp . fst) ((\pc -> (pc, src)) `fmap` Text.parse)
(configExConstraints . savedConfigureExFlags . pkgEnvSavedConfig)
(\v pkgEnv -> updateConfigureExFlags pkgEnv
(\flags -> flags { configExConstraints = v }))
@@ -446,11 +448,11 @@ pkgEnvFieldDescrs = [
}
-- | Read the package environment file.
-readPackageEnvironmentFile :: PackageEnvironment -> FilePath
+readPackageEnvironmentFile :: ConstraintSource -> PackageEnvironment -> FilePath
-> IO (Maybe (ParseResult PackageEnvironment))
-readPackageEnvironmentFile initial file =
+readPackageEnvironmentFile src initial file =
handleNotExists $
- fmap (Just . parsePackageEnvironment initial) (readFile file)
+ fmap (Just . parsePackageEnvironment src initial) (readFile file)
where
handleNotExists action = catchIO action $ \ioe ->
if isDoesNotExistError ioe
@@ -458,9 +460,9 @@ readPackageEnvironmentFile initial file =
else ioError ioe
-- | Parse the package environment file.
-parsePackageEnvironment :: PackageEnvironment -> String
+parsePackageEnvironment :: ConstraintSource -> PackageEnvironment -> String
-> ParseResult PackageEnvironment
-parsePackageEnvironment initial str = do
+parsePackageEnvironment src initial str = do
fields <- readFields str
let (knownSections, others) = partition isKnownSection fields
pkgEnv <- parse others
@@ -491,7 +493,7 @@ parsePackageEnvironment initial str = do
isKnownSection _ = False
parse :: [ParseUtils.Field] -> ParseResult PackageEnvironment
- parse = parseFields pkgEnvFieldDescrs initial
+ parse = parseFields (pkgEnvFieldDescrs src) initial
parseSections :: SectionsAccum -> ParseUtils.Field
-> ParseResult SectionsAccum
@@ -564,7 +566,8 @@ showPackageEnvironmentWithComments :: (Maybe PackageEnvironment)
-> PackageEnvironment
-> String
showPackageEnvironmentWithComments mdefPkgEnv pkgEnv = Disp.render $
- ppFields pkgEnvFieldDescrs mdefPkgEnv pkgEnv
+ ppFields (pkgEnvFieldDescrs ConstraintSourceSandboxConfig)
+ mdefPkgEnv pkgEnv
$+$ Disp.text ""
$+$ ppSection "install-dirs" "" installDirsFields
(fmap installDirsSection mdefPkgEnv) (installDirsSection pkgEnv)
diff --git a/cabal-install/Distribution/Client/Setup.hs b/cabal-install/Distribution/Client/Setup.hs
index 759b13bc0123c740b131a8d38f47bb64f6f049ca..f189fe960645d2317cea35df58c9a991aa3c0892 100644
--- a/cabal-install/Distribution/Client/Setup.hs
+++ b/cabal-install/Distribution/Client/Setup.hs
@@ -52,7 +52,7 @@ import Distribution.Client.Types
import Distribution.Client.BuildReports.Types
( ReportLevel(..) )
import Distribution.Client.Dependency.Types
- ( AllowNewer(..), PreSolver(..) )
+ ( AllowNewer(..), PreSolver(..), ConstraintSource(..) )
import qualified Distribution.Client.Init.Types as IT
( InitFlags(..), PackageType(..) )
import Distribution.Client.Targets
@@ -453,7 +453,7 @@ filterConfigureFlags flags cabalLibVersion
--
data ConfigExFlags = ConfigExFlags {
configCabalVersion :: Flag Version,
- configExConstraints:: [UserConstraint],
+ configExConstraints:: [(UserConstraint, ConstraintSource)],
configPreferences :: [Dependency],
configSolver :: Flag PreSolver,
configAllowNewer :: Flag AllowNewer
@@ -470,14 +470,17 @@ configureExCommand = configureCommand {
liftOptions fst setFst
(filter ((`notElem` ["constraint", "dependency", "exact-configuration"])
. optionName) $ configureOptions showOrParseArgs)
- ++ liftOptions snd setSnd (configureExOptions showOrParseArgs)
+ ++ liftOptions snd setSnd
+ (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag)
}
where
setFst a (_,b) = (a,b)
setSnd b (a,_) = (a,b)
-configureExOptions :: ShowOrParseArgs -> [OptionField ConfigExFlags]
-configureExOptions _showOrParseArgs =
+configureExOptions :: ShowOrParseArgs
+ -> ConstraintSource
+ -> [OptionField ConfigExFlags]
+configureExOptions _showOrParseArgs src =
[ option [] ["cabal-lib-version"]
("Select which version of the Cabal lib to use to build packages "
++ "(useful for testing).")
@@ -489,8 +492,8 @@ configureExOptions _showOrParseArgs =
"Specify constraints on a package (version, installed/source, flags)"
configExConstraints (\v flags -> flags { configExConstraints = v })
(reqArg "CONSTRAINT"
- (fmap (\x -> [x]) (ReadE readUserConstraint))
- (map display))
+ ((\x -> [(x, src)]) `fmap` ReadE readUserConstraint)
+ (map $ display . fst))
, option [] ["preference"]
"Specify preferences (soft constraints) on the version of a package"
@@ -1332,7 +1335,7 @@ installCommand = CommandUI {
, "exact-configuration"])
. optionName) $
configureOptions showOrParseArgs)
- ++ liftOptions get2 set2 (configureExOptions showOrParseArgs)
+ ++ liftOptions get2 set2 (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag)
++ liftOptions get3 set3 (installOptions showOrParseArgs)
++ liftOptions get4 set4 (haddockOptions showOrParseArgs)
}
diff --git a/cabal-install/Distribution/Client/Targets.hs b/cabal-install/Distribution/Client/Targets.hs
index 25b3ec2f61d42fcb41645194b2745fcfbb727679..1890145c3b966e38c4aae019af259766355ab6fb 100644
--- a/cabal-install/Distribution/Client/Targets.hs
+++ b/cabal-install/Distribution/Client/Targets.hs
@@ -52,7 +52,8 @@ import Distribution.Package
import Distribution.Client.Types
( SourcePackage(..), PackageLocation(..), OptionalStanza(..) )
import Distribution.Client.Dependency.Types
- ( PackageConstraint(..) )
+ ( PackageConstraint(..), ConstraintSource(..)
+ , LabeledPackageConstraint(..) )
import qualified Distribution.Client.World as World
import Distribution.Client.PackageIndex (PackageIndex)
@@ -187,12 +188,15 @@ pkgSpecifierTarget (NamedPackage name _) = name
pkgSpecifierTarget (SpecificSourcePackage pkg) = packageName pkg
pkgSpecifierConstraints :: Package pkg
- => PackageSpecifier pkg -> [PackageConstraint]
-pkgSpecifierConstraints (NamedPackage _ constraints) = constraints
+ => PackageSpecifier pkg -> [LabeledPackageConstraint]
+pkgSpecifierConstraints (NamedPackage _ constraints) = map toLpc constraints
+ where
+ toLpc pc = LabeledPackageConstraint pc (Just ConstraintSourceUserTarget)
pkgSpecifierConstraints (SpecificSourcePackage pkg) =
- [PackageConstraintVersion (packageName pkg)
- (thisVersion (packageVersion pkg))]
-
+ [LabeledPackageConstraint pc (Just ConstraintSourceUserTarget)]
+ where
+ pc = PackageConstraintVersion (packageName pkg)
+ (thisVersion (packageVersion pkg))
-- ------------------------------------------------------------
-- * Parsing and checking user targets
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/DSL.hs b/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/DSL.hs
index b5e67bb28a5f10a1564e3e0a846860bbafe98fb4..8066a7c5b5e3f53f8334e89f7115fddad2db547a 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/DSL.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/DSL.hs
@@ -287,7 +287,8 @@ exResolve db targets indepGoals = runProgress $
(C.PackageName p) [TestStanzas])
(exDbPkgs db)
targets' = map (\p -> NamedPackage (C.PackageName p) []) targets
- params = addConstraints enableTests
+ params = addConstraints
+ (map (\pc -> LabeledPackageConstraint pc Nothing) enableTests)
$ (standardInstallPolicy instIdx avaiIdx targets') {
depResolverIndependentGoals = indepGoals
}