Commit a79b284a authored by kristenk's avatar kristenk

Improve error message for unsatisfiable package constraints (issue #2643)

This commit adds the sources of constraints to debugging and error messages,
e.g., "main config file" or "command line flag".
parent 45d3d0b4
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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]
......
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
......@@ -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.
......
......@@ -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 $
......
......@@ -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
......
......@@ -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
......
......@@ -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"
......@@ -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
......
......@@ -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
......
......@@ -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