From 5258eb8c5127c69a5875baf24b508f8e49971047 Mon Sep 17 00:00:00 2001
From: Kristen Kozak <grayjay@wordroute.com>
Date: Tue, 21 Jul 2015 14:45:14 -0700
Subject: [PATCH] Improve constraint error messages and refactor after code
review
---
cabal-install/Distribution/Client/Config.hs | 21 ++++---
.../Distribution/Client/Configure.hs | 12 ++--
.../Distribution/Client/Dependency.hs | 8 +--
.../Client/Dependency/Modular/Message.hs | 5 +-
.../Client/Dependency/Modular/Preference.hs | 52 ++++++++---------
.../Client/Dependency/Modular/Tree.hs | 8 +--
.../Distribution/Client/Dependency/Types.hs | 57 ++++++++++++++-----
cabal-install/Distribution/Client/Freeze.hs | 2 +-
cabal-install/Distribution/Client/Install.hs | 8 +--
.../Client/Sandbox/PackageEnvironment.hs | 6 +-
cabal-install/Distribution/Client/Targets.hs | 4 +-
.../Client/Dependency/Modular/DSL.hs | 4 +-
12 files changed, 111 insertions(+), 76 deletions(-)
diff --git a/cabal-install/Distribution/Client/Config.hs b/cabal-install/Distribution/Client/Config.hs
index 39f309172b..8b7ec285b1 100644
--- a/cabal-install/Distribution/Client/Config.hs
+++ b/cabal-install/Distribution/Client/Config.hs
@@ -553,7 +553,8 @@ loadConfig verbosity configFileFlag = addBaseConf $ do
readConfigFile :: SavedConfig -> FilePath -> IO (Maybe (ParseResult SavedConfig))
readConfigFile initial file = handleNotExists $
- fmap (Just . parseConfig initial) (readFile file)
+ fmap (Just . parseConfig (ConstraintSourceMainConfig file) initial)
+ (readFile file)
where
handleNotExists action = catchIO action $ \ioe ->
@@ -608,8 +609,8 @@ commentSavedConfig = do
-- | All config file fields.
--
-configFieldDescriptions :: [FieldDescr SavedConfig]
-configFieldDescriptions =
+configFieldDescriptions :: ConstraintSource -> [FieldDescr SavedConfig]
+configFieldDescriptions src =
toSavedConfig liftGlobalFlag
(commandOptions (globalCommand []) ParseArgs)
@@ -678,7 +679,7 @@ configFieldDescriptions =
]
++ toSavedConfig liftConfigExFlag
- (configureExOptions ParseArgs ConstraintSourceMainConfig)
+ (configureExOptions ParseArgs src)
[] []
++ toSavedConfig liftInstallFlag
@@ -789,8 +790,11 @@ liftReportFlag :: FieldDescr ReportFlags -> FieldDescr SavedConfig
liftReportFlag = liftField
savedReportFlags (\flags conf -> conf { savedReportFlags = flags })
-parseConfig :: SavedConfig -> String -> ParseResult SavedConfig
-parseConfig initial = \str -> do
+parseConfig :: ConstraintSource
+ -> SavedConfig
+ -> String
+ -> ParseResult SavedConfig
+parseConfig src initial = \str -> do
fields <- readFields str
let (knownSections, others) = partition isKnownSection fields
config <- parse others
@@ -829,7 +833,7 @@ parseConfig initial = \str -> do
isKnownSection (ParseUtils.Section _ "program-default-options" _ _) = True
isKnownSection _ = False
- parse = parseFields (configFieldDescriptions
+ parse = parseFields (configFieldDescriptions src
++ deprecatedFieldDescriptions) initial
parseSections (rs, h, u, g, p, a)
@@ -887,7 +891,8 @@ showConfigWithComments comment vals = Disp.render $
[] -> Disp.text ""
(x:xs) -> foldl' (\ r r' -> r $+$ Disp.text "" $+$ r') x xs
$+$ Disp.text ""
- $+$ ppFields (skipSomeFields configFieldDescriptions) mcomment vals
+ $+$ ppFields (skipSomeFields (configFieldDescriptions ConstraintSourceUnknown))
+ mcomment vals
$+$ Disp.text ""
$+$ ppSection "haddock" "" haddockFlagsFields
(fmap savedHaddockFlags mcomment) (savedHaddockFlags vals)
diff --git a/cabal-install/Distribution/Client/Configure.hs b/cabal-install/Distribution/Client/Configure.hs
index b80a2755cc..ba416492c0 100644
--- a/cabal-install/Distribution/Client/Configure.hs
+++ b/cabal-install/Distribution/Client/Configure.hs
@@ -19,7 +19,8 @@ module Distribution.Client.Configure (
import Distribution.Client.Dependency
import Distribution.Client.Dependency.Types
- ( AllowNewer(..), isAllowNewer, LabeledPackageConstraint(..) )
+ ( AllowNewer(..), isAllowNewer, ConstraintSource(..)
+ , LabeledPackageConstraint(..) )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.InstallPlan (InstallPlan)
import Distribution.Client.IndexUtils as IndexUtils
@@ -263,22 +264,23 @@ 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.
- [ LabeledPackageConstraint (userToPackageConstraint uc) (Just src)
+ [ LabeledPackageConstraint (userToPackageConstraint uc) src
| (uc, src) <- configExConstraints configExFlags ]
. addConstraints
-- package flags from the config file or command line
[ let pc = PackageConstraintFlags (packageName pkg)
(configConfigurationsFlags configFlags)
- in LabeledPackageConstraint pc Nothing ]
+ in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget
+ ]
. addConstraints
-- '--enable-tests' and '--enable-benchmarks' constraints from
- -- command line
+ -- the config file or command line
[ let pc = PackageConstraintStanzas (packageName pkg) $
[ TestStanzas | testsEnabled ] ++
[ BenchStanzas | benchmarksEnabled ]
- in LabeledPackageConstraint pc Nothing
+ in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget
]
$ standardInstallPolicy
diff --git a/cabal-install/Distribution/Client/Dependency.hs b/cabal-install/Distribution/Client/Dependency.hs
index ceb2123cb3..1389694110 100644
--- a/cabal-install/Distribution/Client/Dependency.hs
+++ b/cabal-install/Distribution/Client/Dependency.hs
@@ -161,8 +161,7 @@ debugDepResolverParams p =
++ "\nstrategy: " ++ show (depResolverPreferenceDefault p)
where
debugLabeledConstraint (LabeledPackageConstraint pc src) =
- debugPackageConstraint pc ++ maybe "" showSrc src
- showSrc src = " (" ++ debugConstraintSource src ++ ")"
+ debugPackageConstraint pc ++ " (" ++ debugConstraintSource src ++ ")"
-- | A package selection preference for a particular package.
--
@@ -281,7 +280,7 @@ dontUpgradeNonUpgradeablePackages params =
extraConstraints =
[ LabeledPackageConstraint
(PackageConstraintInstalled pkgname)
- (Just ConstraintSourceNonUpgradeablePackage)
+ ConstraintSourceNonUpgradeablePackage
| all (/=PackageName "base") (depResolverTargets params)
, pkgname <- map PackageName [ "base", "ghc-prim", "integer-gmp"
, "integer-simple" ]
@@ -484,8 +483,7 @@ applySandboxInstallPolicy
. addConstraints
[ let pc = PackageConstraintVersion (packageName pkg)
(thisVersion (packageVersion pkg))
- in LabeledPackageConstraint pc
- (Just ConstraintSourceModifiedAddSourceDep)
+ in LabeledPackageConstraint pc ConstraintSourceModifiedAddSourceDep
| pkg <- modifiedDeps ]
. addTargets [ packageName pkg | pkg <- modifiedDeps ]
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Message.hs b/cabal-install/Distribution/Client/Dependency/Modular/Message.hs
index df006aa10e..42c3750cf4 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Message.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Message.hs
@@ -113,6 +113,5 @@ showFR _ (MalformedFlagChoice qfn) = " (INTERNAL ERROR: MALFORMED FLAG CH
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
+showConstraintSource :: ConstraintSource -> String
+showConstraintSource src = "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 92970bc4f7..46a7c3efc5 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
@@ -101,18 +101,18 @@ processPackageConstraintP :: ConflictSet QPN
-> 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
+processPackageConstraintP c i (LabeledPackageConstraint pc src) r = go i pc
+ where
+ go (I v _) (PackageConstraintVersion _ vr)
+ | checkVR vr v = r
+ | otherwise = Fail c (GlobalConstraintVersion vr src)
+ go _ (PackageConstraintInstalled _)
+ | instI i = r
+ | otherwise = Fail c (GlobalConstraintInstalled src)
+ go _ (PackageConstraintSource _)
+ | not (instI i) = r
+ | otherwise = Fail c (GlobalConstraintSource src)
+ go _ _ = 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
@@ -124,14 +124,14 @@ processPackageConstraintF :: Flag
-> 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
+processPackageConstraintF f c b' (LabeledPackageConstraint pc src) r = go pc
+ where
+ go (PackageConstraintFlags _ fa) =
+ case L.lookup f fa of
+ Nothing -> r
+ Just b | b == b' -> r
+ | otherwise -> Fail c (GlobalConstraintFlag src)
+ go _ = 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
@@ -143,12 +143,12 @@ processPackageConstraintS :: OptionalStanza
-> 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
+processPackageConstraintS s c b' (LabeledPackageConstraint pc src) r = go pc
+ where
+ go (PackageConstraintStanzas _ ss) =
+ if not b' && s `elem` ss then Fail c (GlobalConstraintFlag src)
+ else r
+ go _ = r
-- | Traversal that tries to establish various kinds of user constraints. Works
-- by selectively disabling choices that have been ruled out by global user
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs b/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs
index ac9766b43c..87ed15b6b2 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs
@@ -56,10 +56,10 @@ data FailReason = InconsistentInitialConstraints
| CannotReinstall
| Shadowed
| Broken
- | GlobalConstraintVersion VR (Maybe ConstraintSource)
- | GlobalConstraintInstalled (Maybe ConstraintSource)
- | GlobalConstraintSource (Maybe ConstraintSource)
- | GlobalConstraintFlag (Maybe ConstraintSource)
+ | GlobalConstraintVersion VR ConstraintSource
+ | GlobalConstraintInstalled ConstraintSource
+ | GlobalConstraintSource ConstraintSource
+ | GlobalConstraintFlag ConstraintSource
| ManualFlag
| BuildFailureNotInIndex PN
| MalformedFlagChoice QFN
diff --git a/cabal-install/Distribution/Client/Dependency/Types.hs b/cabal-install/Distribution/Client/Dependency/Types.hs
index 6b765f2f8f..077467bade 100644
--- a/cabal-install/Distribution/Client/Dependency/Types.hs
+++ b/cabal-install/Distribution/Client/Dependency/Types.hs
@@ -256,29 +256,56 @@ 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.
+-- | 'PackageConstraint' labeled with its source.
data LabeledPackageConstraint
- = LabeledPackageConstraint PackageConstraint (Maybe ConstraintSource)
+ = LabeledPackageConstraint PackageConstraint ConstraintSource
unlabelPackageConstraint :: LabeledPackageConstraint -> PackageConstraint
unlabelPackageConstraint (LabeledPackageConstraint pc _) = pc
-- | Source of a 'PackageConstraint'.
-data ConstraintSource
- = ConstraintSourceMainConfig
- | ConstraintSourceSandboxConfig
- | ConstraintSourceUserConfig
- | ConstraintSourceCommandlineFlag
- | ConstraintSourceUserTarget
- | ConstraintSourceNonUpgradeablePackage
- | ConstraintSourceModifiedAddSourceDep
+data ConstraintSource =
+
+ -- | Main config file, which is ~/.cabal/config by default.
+ ConstraintSourceMainConfig FilePath
+
+ -- | Sandbox config file, which is ./cabal.sandbox.config by default.
+ | ConstraintSourceSandboxConfig FilePath
+
+ -- | ./cabal.config.
+ | ConstraintSourceUserConfig
+
+ -- | Flag specified on the command line.
+ | ConstraintSourceCommandlineFlag
+
+ -- | Target specified by the user, e.g., @cabal install package-0.1.0.0@
+ -- implies @package==0.1.0.0@.
+ | ConstraintSourceUserTarget
+
+ -- | Internal requirement to use installed versions of packages like ghc-prim.
+ | ConstraintSourceNonUpgradeablePackage
+
+ -- | Internal requirement to use the add-source version of a package when that
+ -- version is installed and the source is modified.
+ | ConstraintSourceModifiedAddSourceDep
+
+ -- | Internal constraint used by @cabal freeze@.
+ | ConstraintSourceFreeze
+
+ -- | Constraint specified by a config file, a command line flag, or a user
+ -- target, when a more specific source is not known.
+ | ConstraintSourceConfigFlagOrTarget
+
+ -- | The source of the constraint is not specified.
+ | ConstraintSourceUnknown
deriving (Eq, Show)
-- | Description of a 'ConstraintSource'.
debugConstraintSource :: ConstraintSource -> String
-debugConstraintSource ConstraintSourceMainConfig = "main config file"
-debugConstraintSource ConstraintSourceSandboxConfig = "sandbox config file"
+debugConstraintSource (ConstraintSourceMainConfig path) =
+ "main config " ++ path
+debugConstraintSource (ConstraintSourceSandboxConfig path) =
+ "sandbox config " ++ path
debugConstraintSource ConstraintSourceUserConfig = "cabal.config"
debugConstraintSource ConstraintSourceCommandlineFlag = "command line flag"
debugConstraintSource ConstraintSourceUserTarget = "user target"
@@ -286,3 +313,7 @@ debugConstraintSource ConstraintSourceNonUpgradeablePackage =
"non-upgradeable package"
debugConstraintSource ConstraintSourceModifiedAddSourceDep =
"modified add-source dependency"
+debugConstraintSource ConstraintSourceFreeze = "cabal freeze"
+debugConstraintSource ConstraintSourceConfigFlagOrTarget =
+ "config file, command line flag, or user target"
+debugConstraintSource ConstraintSourceUnknown = "unknown source"
diff --git a/cabal-install/Distribution/Client/Freeze.hs b/cabal-install/Distribution/Client/Freeze.hs
index e850761f9e..04820e8af6 100644
--- a/cabal-install/Distribution/Client/Freeze.hs
+++ b/cabal-install/Distribution/Client/Freeze.hs
@@ -166,7 +166,7 @@ planPackages verbosity comp platform mSandboxPkgInfo freezeFlags
. addConstraints
[ let pkg = pkgSpecifierTarget pkgSpecifier
pc = PackageConstraintStanzas pkg stanzas
- in LabeledPackageConstraint pc Nothing
+ in LabeledPackageConstraint pc ConstraintSourceFreeze
| pkgSpecifier <- pkgSpecifiers ]
. maybe id applySandboxInstallPolicy mSandboxPkgInfo
diff --git a/cabal-install/Distribution/Client/Install.hs b/cabal-install/Distribution/Client/Install.hs
index 66f4622a82..009627f7ef 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(..), LabeledPackageConstraint(..) )
+ ( Solver(..), ConstraintSource(..), LabeledPackageConstraint(..) )
import Distribution.Client.FetchUtils
import Distribution.Client.HttpUtils
( configureTransport, HttpTransport (..) )
@@ -372,7 +372,7 @@ planPackages comp platform mSandboxPkgInfo solver
. addConstraints
-- version constraints from the config file or command line
- [ LabeledPackageConstraint (userToPackageConstraint pc) (Just src)
+ [ LabeledPackageConstraint (userToPackageConstraint pc) src
| (pc, src) <- configExConstraints configExFlags ]
. addConstraints
@@ -380,7 +380,7 @@ planPackages comp platform mSandboxPkgInfo solver
-- is silly. We should check if the flags are appropriate
[ let pc = PackageConstraintFlags
(pkgSpecifierTarget pkgSpecifier) flags
- in LabeledPackageConstraint pc Nothing
+ in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget
| let flags = configConfigurationsFlags configFlags
, not (null flags)
, pkgSpecifier <- pkgSpecifiers ]
@@ -388,7 +388,7 @@ planPackages comp platform mSandboxPkgInfo solver
. addConstraints
[ let pc = PackageConstraintStanzas
(pkgSpecifierTarget pkgSpecifier) stanzas
- in LabeledPackageConstraint pc Nothing
+ in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget
| 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 7e9061915a..15b93d5fa6 100644
--- a/cabal-install/Distribution/Client/Sandbox/PackageEnvironment.hs
+++ b/cabal-install/Distribution/Client/Sandbox/PackageEnvironment.hs
@@ -329,7 +329,7 @@ tryLoadSandboxPackageEnvironmentFile :: Verbosity -> FilePath -> (Flag FilePath)
tryLoadSandboxPackageEnvironmentFile verbosity pkgEnvFile configFileFlag = do
let pkgEnvDir = takeDirectory pkgEnvFile
minp <- readPackageEnvironmentFile
- ConstraintSourceSandboxConfig mempty pkgEnvFile
+ (ConstraintSourceSandboxConfig pkgEnvFile) mempty pkgEnvFile
pkgEnv <- handleParseResult verbosity pkgEnvFile minp
-- Get the saved sandbox directory.
@@ -429,7 +429,7 @@ pkgEnvFieldDescrs src = [
configFieldDescriptions' :: [FieldDescr SavedConfig]
configFieldDescriptions' = filter
(\(FieldDescr name _ _) -> name /= "preference" && name /= "constraint")
- configFieldDescriptions
+ (configFieldDescriptions src)
toPkgEnv :: FieldDescr SavedConfig -> FieldDescr PackageEnvironment
toPkgEnv fieldDescr =
@@ -566,7 +566,7 @@ showPackageEnvironmentWithComments :: (Maybe PackageEnvironment)
-> PackageEnvironment
-> String
showPackageEnvironmentWithComments mdefPkgEnv pkgEnv = Disp.render $
- ppFields (pkgEnvFieldDescrs ConstraintSourceSandboxConfig)
+ ppFields (pkgEnvFieldDescrs ConstraintSourceUnknown)
mdefPkgEnv pkgEnv
$+$ Disp.text ""
$+$ ppSection "install-dirs" "" installDirsFields
diff --git a/cabal-install/Distribution/Client/Targets.hs b/cabal-install/Distribution/Client/Targets.hs
index 1890145c3b..6725bd5faf 100644
--- a/cabal-install/Distribution/Client/Targets.hs
+++ b/cabal-install/Distribution/Client/Targets.hs
@@ -191,9 +191,9 @@ pkgSpecifierConstraints :: Package pkg
=> PackageSpecifier pkg -> [LabeledPackageConstraint]
pkgSpecifierConstraints (NamedPackage _ constraints) = map toLpc constraints
where
- toLpc pc = LabeledPackageConstraint pc (Just ConstraintSourceUserTarget)
+ toLpc pc = LabeledPackageConstraint pc ConstraintSourceUserTarget
pkgSpecifierConstraints (SpecificSourcePackage pkg) =
- [LabeledPackageConstraint pc (Just ConstraintSourceUserTarget)]
+ [LabeledPackageConstraint pc ConstraintSourceUserTarget]
where
pc = PackageConstraintVersion (packageName pkg)
(thisVersion (packageVersion pkg))
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 8066a7c5b5..d76270f8ea 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/DSL.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/DSL.hs
@@ -287,11 +287,11 @@ exResolve db targets indepGoals = runProgress $
(C.PackageName p) [TestStanzas])
(exDbPkgs db)
targets' = map (\p -> NamedPackage (C.PackageName p) []) targets
- params = addConstraints
- (map (\pc -> LabeledPackageConstraint pc Nothing) enableTests)
+ params = addConstraints (map toLpc enableTests)
$ (standardInstallPolicy instIdx avaiIdx targets') {
depResolverIndependentGoals = indepGoals
}
+ toLpc pc = LabeledPackageConstraint pc ConstraintSourceUnknown
extractInstallPlan :: CI.InstallPlan.InstallPlan
-> [(ExamplePkgName, ExamplePkgVersion)]
--
GitLab