diff --git a/cabal-install/Distribution/Client/Dependency.hs b/cabal-install/Distribution/Client/Dependency.hs
index da528194c8217d542ce70905cea62fa3df726a3a..df0afd2630743be15910e6f842b833ca6b197775 100644
--- a/cabal-install/Distribution/Client/Dependency.hs
+++ b/cabal-install/Distribution/Client/Dependency.hs
@@ -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
-- ------------------------------------------------------------
diff --git a/cabal-install/Distribution/Client/InstallPlan.hs b/cabal-install/Distribution/Client/InstallPlan.hs
index cb9fd048849907067b24bd990124b02032910784..0661f135173f4974d80c8ce9400ae344545c18ad 100644
--- a/cabal-install/Distribution/Client/InstallPlan.hs
+++ b/cabal-install/Distribution/Client/InstallPlan.hs
@@ -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
--