Skip to content
Snippets Groups Projects
Commit 3138ffdf authored by Duncan Coutts's avatar Duncan Coutts Committed by Mikhail Glushenkov
Browse files

Move the ConfiguredPackage validation out of the InstallPlan module 

The InstallPlan can be generalised by abstracting over the specific
package types. The only thing that really relies on a lot of the
details of the concrete ConfiguredPackage type is the bit that
validates them individually (as opposed to validating packages
within the plan in relation to other packages, graph structure etc).

So as a prelude to generalising the InstallPlan, move the checks
on the ConfiguredPackage into the Dependency module and use them
when checking the output of the solver.
parent a28a2968
No related branches found
No related tags found
No related merge requests found
Hide whitespace changes
Inline Side-by-side
cabal-install/Distribution/Client/Dependency.hs
+ 180
− 27
View file @ 3138ffdf
......@@ -69,8 +69,8 @@ import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.InstallPlan (InstallPlan)
import Distribution.Client.Types
( SourcePackageDb(SourcePackageDb)
, SourcePackage(..) )
( SourcePackageDb(SourcePackageDb), SourcePackage(..)
, ConfiguredPackage(..), ConfiguredId(..), enableStanzas )
import Distribution.Client.Dependency.Types
( PreSolver(..), Solver(..), DependencyResolver, PackageConstraint(..)
, debugPackageConstraint
......@@ -80,15 +80,23 @@ import Distribution.Client.Dependency.Types
import Distribution.Client.Sandbox.Types
( SandboxPackageInfo(..) )
import Distribution.Client.Targets
import Distribution.Client.ComponentDeps (ComponentDeps)
import qualified Distribution.Client.ComponentDeps as CD
import qualified Distribution.InstalledPackageInfo as Installed
import Distribution.Package
( PackageName(..), PackageId, Package(..), packageName, packageVersion
( PackageName(..), PackageIdentifier(PackageIdentifier), PackageId
, Package(..), packageName, packageVersion
, InstalledPackageId, Dependency(Dependency))
import qualified Distribution.PackageDescription as PD
( PackageDescription(..), GenericPackageDescription(..)
, Library(..), Executable(..), TestSuite(..), Benchmark(..), CondTree)
( PackageDescription(..), Library(..), Executable(..)
, TestSuite(..), Benchmark(..), SetupBuildInfo(..)
, GenericPackageDescription(..), CondTree
, Flag(flagName), FlagName(..) )
import Distribution.PackageDescription (BuildInfo(targetBuildDepends))
import Distribution.PackageDescription.Configuration (mapCondTree)
import Distribution.PackageDescription.Configuration
( mapCondTree, finalizePackageDescription )
import Distribution.Client.PackageUtils
( externalBuildDepends )
import Distribution.Version
( VersionRange, anyVersion, thisVersion, withinRange
, removeUpperBound, simplifyVersionRange )
......@@ -96,6 +104,8 @@ import Distribution.Compiler
( CompilerInfo(..) )
import Distribution.System
( Platform )
import Distribution.Client.Utils
( duplicates, duplicatesBy, mergeBy, MergeResult(..) )
import Distribution.Simple.Utils
( comparing, warn, info )
import Distribution.Text
......@@ -103,11 +113,16 @@ import Distribution.Text
import Distribution.Verbosity
( Verbosity )
import Data.List (maximumBy, foldl', intercalate)
import Data.List
( foldl', sort, sortBy, nubBy, maximumBy, intercalate )
import Data.Function (on)
import Data.Maybe (fromMaybe)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Set (Set)
import Control.Exception
( assert )
-- ------------------------------------------------------------
-- * High level planner policy
......@@ -513,12 +528,14 @@ resolveDependencies :: Platform
--TODO: is this needed here? see dontUpgradeNonUpgradeablePackages
resolveDependencies platform comp _solver params
| null (depResolverTargets params)
= return (mkInstallPlan platform comp (depResolverIndependentGoals params) [])
= return (validateSolverResult platform comp indGoals [])
where
indGoals = depResolverIndependentGoals params
resolveDependencies platform comp solver params =
Step (debugDepResolverParams finalparams)
$ fmap (mkInstallPlan platform comp indGoals)
$ fmap (validateSolverResult platform comp indGoals)
$ runSolver solver (SolverConfig reorderGoals indGoals noReinstalls
shadowing strFlags maxBkjumps)
platform comp installedPkgIndex sourcePkgIndex
......@@ -548,24 +565,6 @@ resolveDependencies platform comp solver params =
preferences = interpretPackagesPreference
(Set.fromList targets) defpref prefs
-- | Make an install plan from the output of the dep resolver.
-- It checks that the plan is valid, or it's an error in the dep resolver.
--
mkInstallPlan :: Platform
-> CompilerInfo
-> Bool
-> [InstallPlan.PlanPackage] -> InstallPlan
mkInstallPlan platform comp indepGoals pkgIndex =
let index = InstalledPackageIndex.fromList pkgIndex in
case InstallPlan.new platform comp indepGoals index of
Right plan -> plan
Left problems -> error $ unlines $
"internal error: could not construct a valid install plan."
: "The proposed (invalid) plan contained the following problems:"
: map InstallPlan.showPlanProblem problems
++ "Proposed plan:"
: [InstallPlan.showPlanIndex index]
-- | Give an interpretation to the global 'PackagesPreference' as
-- specific per-package 'PackageVersionPreference'.
......@@ -598,6 +597,160 @@ interpretPackagesPreference selected defaultPref prefs =
if pkgname `Set.member` selected then PreferLatest
else PreferInstalled
-- ------------------------------------------------------------
-- * Checking the result of the solver
-- ------------------------------------------------------------
-- | Make an install plan from the output of the dep resolver.
-- It checks that the plan is valid, or it's an error in the dep resolver.
--
validateSolverResult :: Platform
-> CompilerInfo
-> Bool
-> [InstallPlan.PlanPackage]
-> InstallPlan
validateSolverResult platform comp indepGoals pkgs =
case planPackagesProblems platform comp pkgs of
[] -> case InstallPlan.new platform comp indepGoals index of
Right plan -> plan
Left problems -> error (formatPlanProblems problems)
problems -> error (formatPkgProblems problems)
where
index = InstalledPackageIndex.fromList pkgs
formatPkgProblems = formatProblemMessage . map showPlanPackageProblem
formatPlanProblems = formatProblemMessage . map InstallPlan.showPlanProblem
formatProblemMessage problems =
unlines $
"internal error: could not construct a valid install plan."
: "The proposed (invalid) plan contained the following problems:"
: problems
++ "Proposed plan:"
: [InstallPlan.showPlanIndex index]
data PlanPackageProblem =
InvalidConfiguredPackage ConfiguredPackage [PackageProblem]
showPlanPackageProblem :: PlanPackageProblem -> String
showPlanPackageProblem (InvalidConfiguredPackage pkg packageProblems) =
"Package " ++ display (packageId pkg)
++ " has an invalid configuration, in particular:\n"
++ unlines [ " " ++ showPackageProblem problem
| problem <- packageProblems ]
planPackagesProblems :: Platform -> CompilerInfo
-> [InstallPlan.PlanPackage]
-> [PlanPackageProblem]
planPackagesProblems platform cinfo pkgs =
[ InvalidConfiguredPackage pkg packageProblems
| InstallPlan.Configured pkg <- pkgs
, let packageProblems = configuredPackageProblems platform cinfo pkg
, not (null packageProblems) ]
data PackageProblem = DuplicateFlag PD.FlagName
| MissingFlag PD.FlagName
| ExtraFlag PD.FlagName
| DuplicateDeps [PackageId]
| MissingDep Dependency
| ExtraDep PackageId
| InvalidDep Dependency PackageId
showPackageProblem :: PackageProblem -> String
showPackageProblem (DuplicateFlag (PD.FlagName flag)) =
"duplicate flag in the flag assignment: " ++ flag
showPackageProblem (MissingFlag (PD.FlagName flag)) =
"missing an assignment for the flag: " ++ flag
showPackageProblem (ExtraFlag (PD.FlagName flag)) =
"extra flag given that is not used by the package: " ++ flag
showPackageProblem (DuplicateDeps pkgids) =
"duplicate packages specified as selected dependencies: "
++ intercalate ", " (map display pkgids)
showPackageProblem (MissingDep dep) =
"the package has a dependency " ++ display dep
++ " but no package has been selected to satisfy it."
showPackageProblem (ExtraDep pkgid) =
"the package configuration specifies " ++ display pkgid
++ " but (with the given flag assignment) the package does not actually"
++ " depend on any version of that package."
showPackageProblem (InvalidDep dep pkgid) =
"the package depends on " ++ display dep
++ " but the configuration specifies " ++ display pkgid
++ " which does not satisfy the dependency."
-- | A 'ConfiguredPackage' is valid if the flag assignment is total and if
-- in the configuration given by the flag assignment, all the package
-- dependencies are satisfied by the specified packages.
--
configuredPackageProblems :: Platform -> CompilerInfo
-> ConfiguredPackage -> [PackageProblem]
configuredPackageProblems platform cinfo
(ConfiguredPackage pkg specifiedFlags stanzas specifiedDeps') =
[ DuplicateFlag flag | ((flag,_):_) <- duplicates specifiedFlags ]
++ [ MissingFlag flag | OnlyInLeft flag <- mergedFlags ]
++ [ ExtraFlag flag | OnlyInRight flag <- mergedFlags ]
++ [ DuplicateDeps pkgs
| pkgs <- CD.nonSetupDeps (fmap (duplicatesBy (comparing packageName)) specifiedDeps) ]
++ [ MissingDep dep | OnlyInLeft dep <- mergedDeps ]
++ [ ExtraDep pkgid | OnlyInRight pkgid <- mergedDeps ]
++ [ InvalidDep dep pkgid | InBoth dep pkgid <- mergedDeps
, not (packageSatisfiesDependency pkgid dep) ]
where
specifiedDeps :: ComponentDeps [PackageId]
specifiedDeps = fmap (map confSrcId) specifiedDeps'
mergedFlags = mergeBy compare
(sort $ map PD.flagName (PD.genPackageFlags (packageDescription pkg)))
(sort $ map fst specifiedFlags)
packageSatisfiesDependency
(PackageIdentifier name version)
(Dependency name' versionRange) = assert (name == name') $
version `withinRange` versionRange
dependencyName (Dependency name _) = name
mergedDeps :: [MergeResult Dependency PackageId]
mergedDeps = mergeDeps requiredDeps (CD.flatDeps specifiedDeps)
mergeDeps :: [Dependency] -> [PackageId] -> [MergeResult Dependency PackageId]
mergeDeps required specified =
let sortNubOn f = nubBy ((==) `on` f) . sortBy (compare `on` f) in
mergeBy
(\dep pkgid -> dependencyName dep `compare` packageName pkgid)
(sortNubOn dependencyName required)
(sortNubOn packageName specified)
-- TODO: It would be nicer to use ComponentDeps here so we can be more precise
-- in our checks. That's a bit tricky though, as this currently relies on
-- the 'buildDepends' field of 'PackageDescription'. (OTOH, that field is
-- deprecated and should be removed anyway.)
-- As long as we _do_ use a flat list here, we have to allow for duplicates
-- when we fold specifiedDeps; once we have proper ComponentDeps here we
-- should get rid of the `nubOn` in `mergeDeps`.
requiredDeps :: [Dependency]
requiredDeps =
--TODO: use something lower level than finalizePackageDescription
case finalizePackageDescription specifiedFlags
(const True)
platform cinfo
[]
(enableStanzas stanzas $ packageDescription pkg) of
Right (resolvedPkg, _) ->
externalBuildDepends resolvedPkg
++ maybe [] PD.setupDepends (PD.setupBuildInfo resolvedPkg)
Left _ ->
error "configuredPackageInvalidDeps internal error"
-- ------------------------------------------------------------
-- * Simple resolver that ignores dependencies
-- ------------------------------------------------------------
......
cabal-install/Distribution/Client/InstallPlan.hs
+ 18
− 154
View file @ 3138ffdf
......@@ -36,44 +36,30 @@ module Distribution.Client.InstallPlan (
closed,
consistent,
acyclic,
configuredPackageValid,
-- ** Details on invalid plans
PlanProblem(..),
showPlanProblem,
PackageProblem(..),
showPackageProblem,
problems,
configuredPackageProblems,
-- ** Querying the install plan
dependencyClosure,
) where
import Distribution.Client.Types
( SourcePackage(packageDescription), ConfiguredPackage(..)
( ConfiguredPackage(..)
, ReadyPackage(..), readyPackageToConfiguredPackage
, InstalledPackage, BuildFailure, BuildSuccess(..), enableStanzas
, InstalledPackage, BuildFailure, BuildSuccess(..)
, InstalledPackage(..), fakeInstalledPackageId
, ConfiguredId(..), PackageFixedDeps(..)
, PackageFixedDeps(..)
)
import Distribution.Package
( PackageIdentifier(..), PackageName(..), Package(..), packageName
, Dependency(..), PackageId, InstalledPackageId
, HasInstalledPackageId(..) )
( PackageIdentifier(..), PackageName(..), Package(..)
, InstalledPackageId, HasInstalledPackageId(..) )
import Distribution.Version
( Version, withinRange )
import Distribution.PackageDescription
( GenericPackageDescription(genPackageFlags)
, Flag(flagName), FlagName(..)
, SetupBuildInfo(..), setupBuildInfo
)
import Distribution.Client.PackageUtils
( externalBuildDepends )
( Version )
import Distribution.Client.ComponentDeps (ComponentDeps)
import qualified Distribution.Client.ComponentDeps as CD
import Distribution.PackageDescription.Configuration
( finalizePackageDescription )
import Distribution.Simple.PackageIndex
( PackageIndex )
import qualified Distribution.Simple.PackageIndex as PackageIndex
......@@ -86,18 +72,13 @@ import Distribution.System
( Platform )
import Distribution.Compiler
( CompilerInfo(..) )
import Distribution.Client.Utils
( duplicates, duplicatesBy, mergeBy, MergeResult(..) )
import Distribution.Simple.Utils
( comparing, intercalate )
( intercalate )
import qualified Distribution.InstalledPackageInfo as Installed
import Data.List
( sort, sortBy, nubBy )
import Data.Maybe
( fromMaybe, maybeToList )
import qualified Data.Graph as Graph
import Data.Function (on)
import Data.Graph (Graph)
import Control.Exception
( assert )
......@@ -205,9 +186,7 @@ data InstallPlan = InstallPlan {
invariant :: InstallPlan -> Bool
invariant plan =
valid (planPlatform plan)
(planCompiler plan)
(planFakeMap plan)
valid (planFakeMap plan)
(planIndepGoals plan)
(planIndex plan)
......@@ -248,7 +227,7 @@ new platform cinfo indepGoals index =
. map (\p -> (fakeInstalledPackageId (packageId p), installedPackageId p))
. filter isPreExisting
$ PackageIndex.allPackages index in
case problems platform cinfo fakeMap indepGoals index of
case problems fakeMap indepGoals index of
[] -> Right InstallPlan {
planIndex = index,
planFakeMap = fakeMap,
......@@ -256,8 +235,8 @@ new platform cinfo indepGoals index =
planGraphRev = Graph.transposeG graph,
planPkgOf = vertexToPkgId,
planVertexOf = fromMaybe noSuchPkgId . pkgIdToVertex,
planPlatform = platform,
planCompiler = cinfo,
planPlatform = platform, --TODO: now unused
planCompiler = cinfo, --TODO: now unused
planIndepGoals = indepGoals
}
where (graph, vertexToPkgId, pkgIdToVertex) =
......@@ -424,24 +403,17 @@ checkConfiguredPackage pkg =
--
-- * if the result is @False@ use 'problems' to get a detailed list.
--
valid :: Platform -> CompilerInfo -> FakeMap -> Bool -> PlanIndex -> Bool
valid platform cinfo fakeMap indepGoals index =
null $ problems platform cinfo fakeMap indepGoals index
valid :: FakeMap -> Bool -> PlanIndex -> Bool
valid fakeMap indepGoals index =
null $ problems fakeMap indepGoals index
data PlanProblem =
PackageInvalid ConfiguredPackage [PackageProblem]
| PackageMissingDeps PlanPackage [PackageIdentifier]
PackageMissingDeps PlanPackage [PackageIdentifier]
| PackageCycle [PlanPackage]
| PackageInconsistency PackageName [(PackageIdentifier, Version)]
| PackageStateInvalid PlanPackage PlanPackage
showPlanProblem :: PlanProblem -> String
showPlanProblem (PackageInvalid pkg packageProblems) =
"Package " ++ display (packageId pkg)
++ " has an invalid configuration, in particular:\n"
++ unlines [ " " ++ showPackageProblem problem
| problem <- packageProblems ]
showPlanProblem (PackageMissingDeps pkg missingDeps) =
"Package " ++ display (packageId pkg)
++ " depends on the following packages which are missing from the plan: "
......@@ -476,15 +448,10 @@ showPlanProblem (PackageStateInvalid pkg pkg') =
-- error messages. This is mainly intended for debugging purposes.
-- Use 'showPlanProblem' for a human readable explanation.
--
problems :: Platform -> CompilerInfo -> FakeMap -> Bool
-> PlanIndex -> [PlanProblem]
problems platform cinfo fakeMap indepGoals index =
[ PackageInvalid pkg packageProblems
| Configured pkg <- PackageIndex.allPackages index
, let packageProblems = configuredPackageProblems platform cinfo pkg
, not (null packageProblems) ]
problems :: FakeMap -> Bool -> PlanIndex -> [PlanProblem]
problems fakeMap indepGoals index =
++ [ PackageMissingDeps pkg (catMaybes (map (fmap packageId . PlanIndex.fakeLookupInstalledPackageId fakeMap index) missingDeps))
[ PackageMissingDeps pkg (catMaybes (map (fmap packageId . PlanIndex.fakeLookupInstalledPackageId fakeMap index) missingDeps))
| (pkg, missingDeps) <- PlanIndex.brokenPackages fakeMap index ]
++ [ PackageCycle cycleGroup
......@@ -564,109 +531,6 @@ stateDependencyRelation (Failed _ _) (Failed _ _) = True
stateDependencyRelation _ _ = False
-- | A 'ConfiguredPackage' is valid if the flag assignment is total and if
-- in the configuration given by the flag assignment, all the package
-- dependencies are satisfied by the specified packages.
--
configuredPackageValid :: Platform -> CompilerInfo -> ConfiguredPackage -> Bool
configuredPackageValid platform cinfo pkg =
null (configuredPackageProblems platform cinfo pkg)
data PackageProblem = DuplicateFlag FlagName
| MissingFlag FlagName
| ExtraFlag FlagName
| DuplicateDeps [PackageIdentifier]
| MissingDep Dependency
| ExtraDep PackageIdentifier
| InvalidDep Dependency PackageIdentifier
showPackageProblem :: PackageProblem -> String
showPackageProblem (DuplicateFlag (FlagName flag)) =
"duplicate flag in the flag assignment: " ++ flag
showPackageProblem (MissingFlag (FlagName flag)) =
"missing an assignment for the flag: " ++ flag
showPackageProblem (ExtraFlag (FlagName flag)) =
"extra flag given that is not used by the package: " ++ flag
showPackageProblem (DuplicateDeps pkgids) =
"duplicate packages specified as selected dependencies: "
++ intercalate ", " (map display pkgids)
showPackageProblem (MissingDep dep) =
"the package has a dependency " ++ display dep
++ " but no package has been selected to satisfy it."
showPackageProblem (ExtraDep pkgid) =
"the package configuration specifies " ++ display pkgid
++ " but (with the given flag assignment) the package does not actually"
++ " depend on any version of that package."
showPackageProblem (InvalidDep dep pkgid) =
"the package depends on " ++ display dep
++ " but the configuration specifies " ++ display pkgid
++ " which does not satisfy the dependency."
configuredPackageProblems :: Platform -> CompilerInfo
-> ConfiguredPackage -> [PackageProblem]
configuredPackageProblems platform cinfo
(ConfiguredPackage pkg specifiedFlags stanzas specifiedDeps') =
[ DuplicateFlag flag | ((flag,_):_) <- duplicates specifiedFlags ]
++ [ MissingFlag flag | OnlyInLeft flag <- mergedFlags ]
++ [ ExtraFlag flag | OnlyInRight flag <- mergedFlags ]
++ [ DuplicateDeps pkgs
| pkgs <- CD.nonSetupDeps (fmap (duplicatesBy (comparing packageName)) specifiedDeps) ]
++ [ MissingDep dep | OnlyInLeft dep <- mergedDeps ]
++ [ ExtraDep pkgid | OnlyInRight pkgid <- mergedDeps ]
++ [ InvalidDep dep pkgid | InBoth dep pkgid <- mergedDeps
, not (packageSatisfiesDependency pkgid dep) ]
where
specifiedDeps :: ComponentDeps [PackageId]
specifiedDeps = fmap (map confSrcId) specifiedDeps'
mergedFlags = mergeBy compare
(sort $ map flagName (genPackageFlags (packageDescription pkg)))
(sort $ map fst specifiedFlags)
packageSatisfiesDependency
(PackageIdentifier name version)
(Dependency name' versionRange) = assert (name == name') $
version `withinRange` versionRange
dependencyName (Dependency name _) = name
mergedDeps :: [MergeResult Dependency PackageId]
mergedDeps = mergeDeps requiredDeps (CD.flatDeps specifiedDeps)
mergeDeps :: [Dependency] -> [PackageId] -> [MergeResult Dependency PackageId]
mergeDeps required specified =
let sortNubOn f = nubBy ((==) `on` f) . sortBy (compare `on` f) in
mergeBy
(\dep pkgid -> dependencyName dep `compare` packageName pkgid)
(sortNubOn dependencyName required)
(sortNubOn packageName specified)
-- TODO: It would be nicer to use ComponentDeps here so we can be more precise
-- in our checks. That's a bit tricky though, as this currently relies on
-- the 'buildDepends' field of 'PackageDescription'. (OTOH, that field is
-- deprecated and should be removed anyway.)
-- As long as we _do_ use a flat list here, we have to allow for duplicates
-- when we fold specifiedDeps; once we have proper ComponentDeps here we
-- should get rid of the `nubOn` in `mergeDeps`.
requiredDeps :: [Dependency]
requiredDeps =
--TODO: use something lower level than finalizePackageDescription
case finalizePackageDescription specifiedFlags
(const True)
platform cinfo
[]
(enableStanzas stanzas $ packageDescription pkg) of
Right (resolvedPkg, _) ->
externalBuildDepends resolvedPkg
++ maybe [] setupDepends (setupBuildInfo resolvedPkg)
Left _ ->
error "configuredPackageInvalidDeps internal error"
-- | Compute the dependency closure of a _source_ package in a install plan
--
......
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