Commit 5258eb8c authored by kristenk's avatar kristenk

Improve constraint error messages and refactor after code review

parent a79b284a
......@@ -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)
......
......@@ -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
......
......@@ -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 ]
......
......@@ -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
......@@ -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
......
......@@ -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
......
......@@ -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"
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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))
......
......@@ -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)]
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment