diff --git a/cabal-install/Distribution/Client/BuildReports/Storage.hs b/cabal-install/Distribution/Client/BuildReports/Storage.hs
index a4f20de32d50b494953b0a75bff2da5ad749049b..a4e17af306559b287fe5797cd7f5bde2d2871fa3 100644
--- a/cabal-install/Distribution/Client/BuildReports/Storage.hs
+++ b/cabal-install/Distribution/Client/BuildReports/Storage.hs
@@ -75,7 +75,8 @@ storeAnonymous reports = sequence_
. onlyRemote
repoName (_,_,rrepo) = remoteRepoName rrepo
- onlyRemote :: [(BuildReport, Maybe Repo)] -> [(BuildReport, Repo, RemoteRepo)]
+ onlyRemote :: [(BuildReport, Maybe Repo)]
+ -> [(BuildReport, Repo, RemoteRepo)]
onlyRemote rs =
[ (report, repo, remoteRepo)
| (report, Just repo@Repo { repoKind = Left remoteRepo }) <- rs ]
@@ -116,34 +117,39 @@ storeLocal cinfo templates reports platform = sequence_
-- * InstallPlan support
-- ------------------------------------------------------------
-fromInstallPlan :: InstallPlan -> [(BuildReport, Maybe Repo)]
-fromInstallPlan plan = catMaybes
- . map (fromPlanPackage platform comp)
- . InstallPlan.toList
- $ plan
- where platform = InstallPlan.planPlatform plan
- comp = compilerInfoId (InstallPlan.planCompiler plan)
+fromInstallPlan :: Platform -> CompilerId
+ -> InstallPlan
+ -> [(BuildReport, Maybe Repo)]
+fromInstallPlan platform comp plan =
+ catMaybes
+ . map (fromPlanPackage platform comp)
+ . InstallPlan.toList
+ $ plan
fromPlanPackage :: Platform -> CompilerId
-> InstallPlan.PlanPackage
-> Maybe (BuildReport, Maybe Repo)
fromPlanPackage (Platform arch os) comp planPackage = case planPackage of
- InstallPlan.Installed (ReadyPackage srcPkg flags _ deps) result
+ InstallPlan.Installed (ReadyPackage (ConfiguredPackage srcPkg flags _ _) deps)
+ _ result
-> Just $ ( BuildReport.new os arch comp
- (packageId srcPkg) flags (map packageId (CD.nonSetupDeps deps))
+ (packageId srcPkg) flags
+ (map packageId (CD.nonSetupDeps deps))
(Right result)
, extractRepo srcPkg)
InstallPlan.Failed (ConfiguredPackage srcPkg flags _ deps) result
-> Just $ ( BuildReport.new os arch comp
- (packageId srcPkg) flags (map confSrcId (CD.nonSetupDeps deps))
+ (packageId srcPkg) flags
+ (map confSrcId (CD.nonSetupDeps deps))
(Left result)
, extractRepo srcPkg )
_ -> Nothing
where
- extractRepo (SourcePackage { packageSource = RepoTarballPackage repo _ _ }) = Just repo
+ extractRepo (SourcePackage { packageSource = RepoTarballPackage repo _ _ })
+ = Just repo
extractRepo _ = Nothing
fromPlanningFailure :: Platform -> CompilerId
diff --git a/cabal-install/Distribution/Client/Configure.hs b/cabal-install/Distribution/Client/Configure.hs
index b106cb5ee817683834aaf67f3f5cd7137b56a1b8..8c098220d63a45fe684b7cefa26930e0c0291be5 100644
--- a/cabal-install/Distribution/Client/Configure.hs
+++ b/cabal-install/Distribution/Client/Configure.hs
@@ -112,14 +112,16 @@ configure verbosity packageDBs repos comp platform conf
"Warning: solver failed to find a solution:\n"
++ message
++ "Trying configure anyway."
- setupWrapper verbosity (setupScriptOptions installedPkgIndex Nothing) Nothing
- configureCommand (const configFlags) extraArgs
+ setupWrapper verbosity (setupScriptOptions installedPkgIndex Nothing)
+ Nothing configureCommand (const configFlags) extraArgs
Right installPlan -> case InstallPlan.ready installPlan of
- [pkg@(ReadyPackage (SourcePackage _ _ (LocalUnpackedPackage _) _) _ _ _)] -> do
+ [pkg@(ReadyPackage
+ (ConfiguredPackage (SourcePackage _ _ (LocalUnpackedPackage _) _)
+ _ _ _)
+ _)] -> do
configurePackage verbosity
- (InstallPlan.planPlatform installPlan)
- (InstallPlan.planCompiler installPlan)
+ platform (compilerInfo comp)
(setupScriptOptions installedPkgIndex (Just pkg))
configFlags pkg extraArgs
@@ -127,7 +129,9 @@ configure verbosity packageDBs repos comp platform conf
++ "one local ready package."
where
- setupScriptOptions :: InstalledPackageIndex -> Maybe ReadyPackage -> SetupScriptOptions
+ setupScriptOptions :: InstalledPackageIndex
+ -> Maybe ReadyPackage
+ -> SetupScriptOptions
setupScriptOptions =
configureSetupScript
packageDBs
@@ -206,7 +210,8 @@ configureSetupScript packageDBs
explicitSetupDeps :: Maybe [(InstalledPackageId, PackageId)]
explicitSetupDeps = do
- ReadyPackage (SourcePackage _ gpkg _ _) _ _ deps <- mpkg
+ ReadyPackage (ConfiguredPackage (SourcePackage _ gpkg _ _) _ _ _) deps
+ <- mpkg
-- Check if there is an explicit setup stanza
_buildInfo <- PkgDesc.setupBuildInfo (PkgDesc.packageDescription gpkg)
-- Return the setup dependencies computed by the solver
@@ -225,10 +230,12 @@ planLocalPackage :: Verbosity -> Compiler
-> InstalledPackageIndex
-> SourcePackageDb
-> IO (Progress String String InstallPlan)
-planLocalPackage verbosity comp platform configFlags configExFlags installedPkgIndex
+planLocalPackage verbosity comp platform configFlags configExFlags
+ installedPkgIndex
(SourcePackageDb _ packagePrefs) = do
pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity
- solver <- chooseSolver verbosity (fromFlag $ configSolver configExFlags) (compilerInfo comp)
+ solver <- chooseSolver verbosity (fromFlag $ configSolver configExFlags)
+ (compilerInfo comp)
let -- We create a local package and ask to resolve a dependency on it
localPkg = SourcePackage {
@@ -294,7 +301,10 @@ configurePackage :: Verbosity
-> [String]
-> IO ()
configurePackage verbosity platform comp scriptOptions configFlags
- (ReadyPackage (SourcePackage _ gpkg _ _) flags stanzas deps) extraArgs =
+ (ReadyPackage (ConfiguredPackage (SourcePackage _ gpkg _ _)
+ flags stanzas _)
+ deps)
+ extraArgs =
setupWrapper verbosity
scriptOptions (Just pkg) configureCommand configureFlags extraArgs
diff --git a/cabal-install/Distribution/Client/Dependency.hs b/cabal-install/Distribution/Client/Dependency.hs
index da528194c8217d542ce70905cea62fa3df726a3a..e34be5e16f0e2ca63688dbea47c47232984a0614 100644
--- a/cabal-install/Distribution/Client/Dependency.hs
+++ b/cabal-install/Distribution/Client/Dependency.hs
@@ -69,26 +69,34 @@ 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
+ ( PreSolver(..), Solver(..), DependencyResolver, ResolverPackage(..)
+ , PackageConstraint(..), debugPackageConstraint
, AllowNewer(..), PackagePreferences(..), InstalledPreference(..)
, PackagesPreferenceDefault(..)
, Progress(..), foldProgress )
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
@@ -136,9 +151,11 @@ debugDepResolverParams :: DepResolverParams -> String
debugDepResolverParams p =
"targets: " ++ intercalate ", " (map display (depResolverTargets p))
++ "\nconstraints: "
- ++ concatMap (("\n " ++) . debugPackageConstraint) (depResolverConstraints p)
+ ++ concatMap (("\n " ++) . debugPackageConstraint)
+ (depResolverConstraints p)
++ "\npreferences: "
- ++ concatMap (("\n " ++) . debugPackagePreference) (depResolverPreferences p)
+ ++ concatMap (("\n " ++) . debugPackagePreference)
+ (depResolverPreferences p)
++ "\nstrategy: " ++ show (depResolverPreferenceDefault p)
-- | A package selection preference for a particular package.
@@ -513,12 +530,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 +567,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 +599,165 @@ 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
+ -> [ResolverPackage]
+ -> InstallPlan
+validateSolverResult platform comp indepGoals pkgs =
+ case planPackagesProblems platform comp pkgs of
+ [] -> case InstallPlan.new indepGoals index of
+ Right plan -> plan
+ Left problems -> error (formatPlanProblems problems)
+ problems -> error (formatPkgProblems problems)
+
+ where
+ index = InstalledPackageIndex.fromList (map toPlanPackage pkgs)
+
+ toPlanPackage (PreExisting pkg) = InstallPlan.PreExisting pkg
+ toPlanPackage (Configured pkg) = InstallPlan.Configured pkg
+
+ 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
+ -> [ResolverPackage]
+ -> [PlanPackageProblem]
+planPackagesProblems platform cinfo pkgs =
+ [ InvalidConfiguredPackage pkg packageProblems
+ | 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/Dependency/Modular.hs b/cabal-install/Distribution/Client/Dependency/Modular.hs
index 11745fb5dfaaf5da9b2b8d64c3f1260857b5e60b..b2be4fc2fe1429574ce07e7610a3b9c69726ac5b 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular.hs
@@ -26,9 +26,7 @@ import Distribution.Client.Dependency.Modular.Package
import Distribution.Client.Dependency.Modular.Solver
( SolverConfig(..), solve )
import Distribution.Client.Dependency.Types
- ( DependencyResolver, PackageConstraint(..) )
-import Distribution.Client.InstallPlan
- ( PlanPackage )
+ ( DependencyResolver, ResolverPackage, PackageConstraint(..) )
import Distribution.System
( Platform(..) )
@@ -46,7 +44,7 @@ modularResolver sc (Platform arch os) cinfo iidx sidx pprefs pcs pns =
gcs = M.fromListWith (++) (map (\ pc -> (pcName pc, [pc])) pcs)
-- Results have to be converted into an install plan.
- postprocess :: Assignment -> RevDepMap -> [PlanPackage]
+ postprocess :: Assignment -> RevDepMap -> [ResolverPackage]
postprocess a rdm = map (convCP iidx sidx) (toCPs a rdm)
-- Helper function to extract the PN from a constraint.
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs b/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs
index 47968d19ec2ba06cca2c760df581b3ff3666e98b..714eb845391afb2ec2d5ea3f77aa096ef4cdd13f 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs
@@ -3,32 +3,23 @@ module Distribution.Client.Dependency.Modular.ConfiguredConversion where
import Data.Maybe
import Prelude hiding (pi)
-import Distribution.Client.InstallPlan
import Distribution.Client.Types
-import Distribution.Compiler
+import Distribution.Client.Dependency.Types (ResolverPackage(..))
import qualified Distribution.Client.PackageIndex as CI
import qualified Distribution.Simple.PackageIndex as SI
-import Distribution.System
import Distribution.Client.Dependency.Modular.Configured
import Distribution.Client.Dependency.Modular.Package
import Distribution.Client.ComponentDeps (ComponentDeps)
-import qualified Distribution.Client.ComponentDeps as CD
-mkPlan :: Platform -> CompilerInfo -> Bool ->
- SI.InstalledPackageIndex -> CI.PackageIndex SourcePackage ->
- [CP QPN] -> Either [PlanProblem] InstallPlan
-mkPlan plat comp indepGoals iidx sidx cps =
- new plat comp indepGoals (SI.fromList (map (convCP iidx sidx) cps))
convCP :: SI.InstalledPackageIndex -> CI.PackageIndex SourcePackage ->
- CP QPN -> PlanPackage
+ CP QPN -> ResolverPackage
convCP iidx sidx (CP qpi fa es ds) =
case convPI qpi of
- Left pi -> PreExisting $ InstalledPackage
+ Left pi -> PreExisting
(fromJust $ SI.lookupInstalledPackageId iidx pi)
- (map confSrcId $ CD.nonSetupDeps ds')
Right pi -> Configured $ ConfiguredPackage
(fromJust $ CI.lookupPackageId sidx pi)
fa
diff --git a/cabal-install/Distribution/Client/Dependency/TopDown.hs b/cabal-install/Distribution/Client/Dependency/TopDown.hs
index 74f5d24961ff2c871b0a90078abc12003617e285..32a53b130ab1b15792aae496533a12c442c57f52 100644
--- a/cabal-install/Distribution/Client/Dependency/TopDown.hs
+++ b/cabal-install/Distribution/Client/Dependency/TopDown.hs
@@ -19,29 +19,28 @@ import Distribution.Client.Dependency.TopDown.Types
import qualified Distribution.Client.Dependency.TopDown.Constraints as Constraints
import Distribution.Client.Dependency.TopDown.Constraints
( Satisfiable(..) )
-import Distribution.Client.IndexUtils
- ( convert )
-import qualified Distribution.Client.InstallPlan as InstallPlan
-import Distribution.Client.InstallPlan
- ( PlanPackage(..) )
import Distribution.Client.Types
- ( SourcePackage(..), ConfiguredPackage(..), InstalledPackage(..)
+ ( SourcePackage(..), ConfiguredPackage(..)
, enableStanzas, ConfiguredId(..), fakeInstalledPackageId )
import Distribution.Client.Dependency.Types
- ( DependencyResolver, PackageConstraint(..)
+ ( DependencyResolver, ResolverPackage(..), PackageConstraint(..)
, PackagePreferences(..), InstalledPreference(..)
, Progress(..), foldProgress )
import qualified Distribution.Client.PackageIndex as PackageIndex
+import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex
+import Distribution.Simple.PackageIndex (InstalledPackageIndex)
+import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
import Distribution.Client.ComponentDeps
( ComponentDeps )
import qualified Distribution.Client.ComponentDeps as CD
import Distribution.Client.PackageIndex
( PackageIndex )
import Distribution.Package
- ( PackageName(..), PackageId, Package(..), packageVersion, packageName
- , Dependency(Dependency), thisPackageVersion
- , simplifyDependency )
+ ( PackageName(..), PackageId, PackageIdentifier(..)
+ , InstalledPackageId(..)
+ , Package(..), packageVersion, packageName
+ , Dependency(Dependency), thisPackageVersion, simplifyDependency )
import Distribution.PackageDescription
( PackageDescription(buildDepends) )
import Distribution.Client.PackageUtils
@@ -49,7 +48,7 @@ import Distribution.Client.PackageUtils
import Distribution.PackageDescription.Configuration
( finalizePackageDescription, flattenPackageDescription )
import Distribution.Version
- ( VersionRange, withinRange, simplifyVersionRange
+ ( Version(..), VersionRange, withinRange, simplifyVersionRange
, UpperBound(..), asVersionIntervals )
import Distribution.Compiler
( CompilerInfo )
@@ -251,9 +250,12 @@ search configure pref constraints =
topDownResolver :: DependencyResolver
topDownResolver platform cinfo installedPkgIndex sourcePkgIndex
preferences constraints targets =
- mapMessages (topDownResolver' platform cinfo
- (convert installedPkgIndex) sourcePkgIndex
- preferences constraints targets)
+ mapMessages $ topDownResolver'
+ platform cinfo
+ (convertInstalledPackageIndex installedPkgIndex)
+ sourcePkgIndex
+ preferences constraints
+ targets
where
mapMessages :: Progress Log Failure a -> Progress String String a
mapMessages = foldProgress (Step . showLog) (Fail . showFailure) Done
@@ -266,7 +268,7 @@ topDownResolver' :: Platform -> CompilerInfo
-> (PackageName -> PackagePreferences)
-> [PackageConstraint]
-> [PackageName]
- -> Progress Log Failure [PlanPackage]
+ -> Progress Log Failure [ResolverPackage]
topDownResolver' platform cinfo installedPkgIndex sourcePkgIndex
preferences constraints targets =
fmap (uncurry finalise)
@@ -288,11 +290,16 @@ topDownResolver' platform cinfo installedPkgIndex sourcePkgIndex
initialPkgNames = Set.fromList targets
finalise selected' constraints' =
- PackageIndex.allPackages
+ map toResolverPackage
+ . PackageIndex.allPackages
. fst . improvePlan installedPkgIndex' constraints'
. PackageIndex.fromList
$ finaliseSelectedPackages preferences selected' constraints'
+ toResolverPackage :: FinalSelectedPackage -> ResolverPackage
+ toResolverPackage (SelectedInstalled (InstalledPackage pkg _))
+ = PreExisting pkg
+ toResolverPackage (SelectedSource pkg) = Configured pkg
addTopLevelTargets :: [PackageName]
-> Constraints
@@ -538,6 +545,43 @@ selectNeededSubset installedPkgIndex sourcePkgIndex = select mempty mempty
null (PackageIndex.lookupPackageName installedPkgIndex' name)
&& null (PackageIndex.lookupPackageName sourcePkgIndex' name)
+
+-- | The old top down solver assumes that installed packages are indexed by
+-- their source package id. But these days they're actually indexed by an
+-- installed package id and there can be many installed packages with the same
+-- source package id. This function tries to do a convertion, but it can only
+-- be partial.
+--
+convertInstalledPackageIndex :: InstalledPackageIndex
+ -> PackageIndex InstalledPackage
+convertInstalledPackageIndex index' = PackageIndex.fromList
+ -- There can be multiple installed instances of each package version,
+ -- like when the same package is installed in the global & user DBs.
+ -- InstalledPackageIndex.allPackagesBySourcePackageId gives us the
+ -- installed packages with the most preferred instances first, so by
+ -- picking the first we should get the user one. This is almost but not
+ -- quite the same as what ghc does.
+ [ InstalledPackage ipkg (sourceDepsOf index' ipkg)
+ | (_,ipkg:_) <- InstalledPackageIndex.allPackagesBySourcePackageId index' ]
+ where
+ -- The InstalledPackageInfo only lists dependencies by the
+ -- InstalledPackageId, which means we do not directly know the corresponding
+ -- source dependency. The only way to find out is to lookup the
+ -- InstalledPackageId to get the InstalledPackageInfo and look at its
+ -- source PackageId. But if the package is broken because it depends on
+ -- other packages that do not exist then we have a problem we cannot find
+ -- the original source package id. Instead we make up a bogus package id.
+ -- This should have the same effect since it should be a dependency on a
+ -- nonexistent package.
+ sourceDepsOf index ipkg =
+ [ maybe (brokenPackageId depid) packageId mdep
+ | let depids = InstalledPackageInfo.depends ipkg
+ getpkg = InstalledPackageIndex.lookupInstalledPackageId index
+ , (depid, mdep) <- zip depids (map getpkg depids) ]
+
+ brokenPackageId (InstalledPackageId str) =
+ PackageIdentifier (PackageName (str ++ "-broken")) (Version [] [])
+
-- ------------------------------------------------------------
-- * Post processing the solution
-- ------------------------------------------------------------
@@ -545,7 +589,7 @@ selectNeededSubset installedPkgIndex sourcePkgIndex = select mempty mempty
finaliseSelectedPackages :: (PackageName -> PackagePreferences)
-> SelectedPackages
-> Constraints
- -> [PlanPackage]
+ -> [FinalSelectedPackage]
finaliseSelectedPackages pref selected constraints =
map finaliseSelected (PackageIndex.allPackages selected)
where
@@ -561,9 +605,9 @@ finaliseSelectedPackages pref selected constraints =
Just (InstalledOnly _) -> finaliseInstalled ipkg
Just (InstalledAndSource _ _) -> finaliseSource (Just ipkg) apkg
- finaliseInstalled (InstalledPackageEx pkg _ _) = InstallPlan.PreExisting pkg
+ finaliseInstalled (InstalledPackageEx pkg _ _) = SelectedInstalled pkg
finaliseSource mipkg (SemiConfiguredPackage pkg flags stanzas deps) =
- InstallPlan.Configured (ConfiguredPackage pkg flags stanzas deps')
+ SelectedSource (ConfiguredPackage pkg flags stanzas deps')
where
-- We cheat in the cabal solver, and classify all dependencies as
-- library dependencies.
@@ -649,8 +693,8 @@ finaliseSelectedPackages pref selected constraints =
--
improvePlan :: PackageIndex InstalledPackage
-> Constraints
- -> PackageIndex PlanPackage
- -> (PackageIndex PlanPackage, Constraints)
+ -> PackageIndex FinalSelectedPackage
+ -> (PackageIndex FinalSelectedPackage, Constraints)
improvePlan installed constraints0 selected0 =
foldl' improve (selected0, constraints0) (reverseTopologicalOrder selected0)
where
@@ -663,26 +707,26 @@ improvePlan installed constraints0 selected0 =
-- already installed with the exact same dependencies and all the packages
-- in the plan that it depends on are in the installed state
improvePkg selected constraints pkgid = do
- Configured pkg <- PackageIndex.lookupPackageId selected pkgid
- ipkg <- PackageIndex.lookupPackageId installed pkgid
+ SelectedSource pkg <- PackageIndex.lookupPackageId selected pkgid
+ ipkg <- PackageIndex.lookupPackageId installed pkgid
guard $ all (isInstalled selected) (sourceDeps pkg)
tryInstalled selected constraints [ipkg]
isInstalled selected pkgid =
case PackageIndex.lookupPackageId selected pkgid of
- Just (PreExisting _) -> True
- _ -> False
+ Just (SelectedInstalled _) -> True
+ _ -> False
- tryInstalled :: PackageIndex PlanPackage -> Constraints
+ tryInstalled :: PackageIndex FinalSelectedPackage -> Constraints
-> [InstalledPackage]
- -> Maybe (PackageIndex PlanPackage, Constraints)
+ -> Maybe (PackageIndex FinalSelectedPackage, Constraints)
tryInstalled selected constraints [] = Just (selected, constraints)
tryInstalled selected constraints (pkg:pkgs) =
case constraintsOk (packageId pkg) (sourceDeps pkg) constraints of
Nothing -> Nothing
Just constraints' -> tryInstalled selected' constraints' pkgs'
where
- selected' = PackageIndex.insert (PreExisting pkg) selected
+ selected' = PackageIndex.insert (SelectedInstalled pkg) selected
pkgs' = catMaybes (map notSelected (sourceDeps pkg)) ++ pkgs
notSelected pkgid =
case (PackageIndex.lookupPackageId installed pkgid
@@ -698,7 +742,7 @@ improvePlan installed constraints0 selected0 =
where
dep = thisPackageVersion pkgid'
- reverseTopologicalOrder :: PackageIndex PlanPackage -> [PackageId]
+ reverseTopologicalOrder :: PackageIndex FinalSelectedPackage -> [PackageId]
reverseTopologicalOrder index = map (packageId . toPkg)
. Graph.topSort
. Graph.transposeG
@@ -1001,7 +1045,7 @@ listOf disp (x0:x1:xs) = disp x0 ++ go x1 xs
-- this duplication could be avoided, but that's a bit of work and the top-down
-- solver is legacy code anyway.
--
--- (NOTE: This is called at two types: InstalledPackage and PlanPackage.)
+-- (NOTE: This is called at two types: InstalledPackage and FinalSelectedPackage.)
dependencyGraph :: PackageSourceDeps pkg
=> PackageIndex pkg
-> (Graph.Graph,
diff --git a/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs b/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs
index 73c1a27327326279290b9c705dd32842f0f23ecd..d0988c8e37badc89b5b19776e0c4c52ef99794a1 100644
--- a/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs
+++ b/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs
@@ -14,14 +14,14 @@
module Distribution.Client.Dependency.TopDown.Types where
import Distribution.Client.Types
- ( SourcePackage(..), ReadyPackage(..), InstalledPackage(..)
+ ( SourcePackage(..), ConfiguredPackage(..)
, OptionalStanza, ConfiguredId(..) )
-import Distribution.Client.InstallPlan
- ( ConfiguredPackage(..), PlanPackage(..) )
+import Distribution.InstalledPackageInfo
+ ( InstalledPackageInfo )
import qualified Distribution.Client.ComponentDeps as CD
import Distribution.Package
- ( PackageIdentifier, Dependency
+ ( PackageId, PackageIdentifier, Dependency
, Package(packageId) )
import Distribution.PackageDescription
( FlagAssignment )
@@ -42,8 +42,18 @@ data InstalledOrSource installed source
| InstalledAndSource installed source
deriving Eq
+data FinalSelectedPackage
+ = SelectedInstalled InstalledPackage
+ | SelectedSource ConfiguredPackage
+
type TopologicalSortNumber = Int
+-- | InstalledPackage caches its dependencies as source package IDs.
+data InstalledPackage
+ = InstalledPackage
+ InstalledPackageInfo
+ [PackageId]
+
data InstalledPackageEx
= InstalledPackageEx
InstalledPackage
@@ -65,6 +75,9 @@ data SemiConfiguredPackage
[Dependency] -- dependencies we end up with when we apply
-- the flag assignment
+instance Package InstalledPackage where
+ packageId (InstalledPackage pkg _) = packageId pkg
+
instance Package InstalledPackageEx where
packageId (InstalledPackageEx p _ _) = packageId p
@@ -80,6 +93,10 @@ instance (Package installed, Package source)
packageId (SourceOnly p ) = packageId p
packageId (InstalledAndSource p _) = packageId p
+instance Package FinalSelectedPackage where
+ packageId (SelectedInstalled pkg) = packageId pkg
+ packageId (SelectedSource pkg) = packageId pkg
+
-- | We can have constraints on selecting just installed or just source
-- packages.
@@ -117,15 +134,10 @@ instance PackageSourceDeps InstalledPackageEx where
instance PackageSourceDeps ConfiguredPackage where
sourceDeps (ConfiguredPackage _ _ _ deps) = map confSrcId $ CD.nonSetupDeps deps
-instance PackageSourceDeps ReadyPackage where
- sourceDeps (ReadyPackage _ _ _ deps) = map packageId $ CD.nonSetupDeps deps
-
instance PackageSourceDeps InstalledPackage where
sourceDeps (InstalledPackage _ deps) = deps
-instance PackageSourceDeps PlanPackage where
- sourceDeps (PreExisting pkg) = sourceDeps pkg
- sourceDeps (Configured pkg) = sourceDeps pkg
- sourceDeps (Processing pkg) = sourceDeps pkg
- sourceDeps (Installed pkg _) = sourceDeps pkg
- sourceDeps (Failed pkg _) = sourceDeps pkg
+instance PackageSourceDeps FinalSelectedPackage where
+ sourceDeps (SelectedInstalled pkg) = sourceDeps pkg
+ sourceDeps (SelectedSource pkg) = sourceDeps pkg
+
diff --git a/cabal-install/Distribution/Client/Dependency/Types.hs b/cabal-install/Distribution/Client/Dependency/Types.hs
index da10fb92ef87e2725e1bee79f41e8f4fd24760cc..87dde8c903d13f6208c9d0d7477efddb78c9c0b3 100644
--- a/cabal-install/Distribution/Client/Dependency/Types.hs
+++ b/cabal-install/Distribution/Client/Dependency/Types.hs
@@ -13,11 +13,10 @@
-- Common types for dependency resolution.
-----------------------------------------------------------------------------
module Distribution.Client.Dependency.Types (
- ExtDependency(..),
-
PreSolver(..),
Solver(..),
DependencyResolver,
+ ResolverPackage(..),
AllowNewer(..), isAllowNewer,
PackageConstraint(..),
@@ -45,21 +44,19 @@ import Data.Monoid
#endif
import Distribution.Client.Types
- ( OptionalStanza(..), SourcePackage(..) )
-import qualified Distribution.Client.InstallPlan as InstallPlan
-
-import Distribution.Compat.ReadP
- ( (<++) )
+ ( OptionalStanza(..), SourcePackage(..), ConfiguredPackage )
import qualified Distribution.Compat.ReadP as Parse
( pfail, munch1 )
import Distribution.PackageDescription
( FlagAssignment, FlagName(..) )
+import Distribution.InstalledPackageInfo
+ ( InstalledPackageInfo )
import qualified Distribution.Client.PackageIndex as PackageIndex
( PackageIndex )
import Distribution.Simple.PackageIndex ( InstalledPackageIndex )
import Distribution.Package
- ( Dependency, PackageName, InstalledPackageId )
+ ( PackageName )
import Distribution.Version
( VersionRange, simplifyVersionRange )
import Distribution.Compiler
@@ -74,16 +71,6 @@ import Text.PrettyPrint
import Prelude hiding (fail)
--- | Covers source dependencies and installed dependencies in
--- one type.
-data ExtDependency = SourceDependency Dependency
- | InstalledDependency InstalledPackageId
-
-instance Text ExtDependency where
- disp (SourceDependency dep) = disp dep
- disp (InstalledDependency dep) = disp dep
-
- parse = (SourceDependency `fmap` parse) <++ (InstalledDependency `fmap` parse)
-- | All the solvers that can be selected.
data PreSolver = AlwaysTopDown | AlwaysModular | Choose
@@ -120,7 +107,15 @@ type DependencyResolver = Platform
-> (PackageName -> PackagePreferences)
-> [PackageConstraint]
-> [PackageName]
- -> Progress String String [InstallPlan.PlanPackage]
+ -> Progress String String [ResolverPackage]
+
+-- | The dependency resolver picks either pre-existing installed packages
+-- or it picks source packages along with package configuration.
+--
+-- This is like the 'InstallPlan.PlanPackage' but with fewer cases.
+--
+data ResolverPackage = PreExisting InstalledPackageInfo
+ | Configured ConfiguredPackage
-- | Per-package constraints. Package constraints must be respected by the
-- solver. Multiple constraints for each package can be given, though obviously
diff --git a/cabal-install/Distribution/Client/Fetch.hs b/cabal-install/Distribution/Client/Fetch.hs
index cb863525c589cf1ed45464b7501fb03c12b68c05..541e33d60baa082050705eb5ea27e56225888e9a 100644
--- a/cabal-install/Distribution/Client/Fetch.hs
+++ b/cabal-install/Distribution/Client/Fetch.hs
@@ -87,7 +87,7 @@ fetch verbosity packageDBs repos comp platform conf
transport <- configureTransport verbosity (flagToMaybe (globalHttpTransport globalFlags))
- pkgSpecifiers <- resolveUserTargets transport verbosity
+ pkgSpecifiers <- resolveUserTargets verbosity transport
(fromFlag $ globalWorldFile globalFlags)
(packageIndex sourcePkgDb)
userTargets
@@ -139,7 +139,7 @@ planPackages verbosity comp platform fetchFlags
-- that are in the 'InstallPlan.Configured' state.
return
[ pkg
- | (InstallPlan.Configured (InstallPlan.ConfiguredPackage pkg _ _ _))
+ | (InstallPlan.Configured (ConfiguredPackage pkg _ _ _))
<- InstallPlan.toList installPlan ]
| otherwise =
diff --git a/cabal-install/Distribution/Client/Freeze.hs b/cabal-install/Distribution/Client/Freeze.hs
index 98ec58cc73aa06cc8e46454b0f89ea9babfeca6a..197490a9823793adc283076d145fe760b08162ca 100644
--- a/cabal-install/Distribution/Client/Freeze.hs
+++ b/cabal-install/Distribution/Client/Freeze.hs
@@ -23,7 +23,7 @@ import Distribution.Client.Dependency
import Distribution.Client.IndexUtils as IndexUtils
( getSourcePackages, getInstalledPackages )
import Distribution.Client.InstallPlan
- ( PlanPackage )
+ ( InstallPlan, PlanPackage )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.Setup
( GlobalFlags(..), FreezeFlags(..), ConfigExFlags(..) )
@@ -89,9 +89,10 @@ freeze verbosity packageDBs repos comp platform conf mSandboxPkgInfo
installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
sourcePkgDb <- getSourcePackages verbosity repos
- transport <- configureTransport verbosity (flagToMaybe (globalHttpTransport globalFlags))
+ transport <- configureTransport verbosity
+ (flagToMaybe (globalHttpTransport globalFlags))
- pkgSpecifiers <- resolveUserTargets transport verbosity
+ pkgSpecifiers <- resolveUserTargets verbosity transport
(fromFlag $ globalWorldFile globalFlags)
(packageIndex sourcePkgDb)
[UserTargetLocalDir "."]
@@ -193,20 +194,19 @@ planPackages verbosity comp platform mSandboxPkgInfo freezeFlags
-- 2) not a dependency (directly or transitively) of the package we are
-- freezing. This is useful for removing previously installed packages
-- which are no longer required from the install plan.
-pruneInstallPlan :: InstallPlan.InstallPlan
+pruneInstallPlan :: InstallPlan
-> [PackageSpecifier SourcePackage]
-> [PlanPackage]
pruneInstallPlan installPlan pkgSpecifiers =
- mapLeft (removeSelf pkgIds . PackageIndex.allPackages) $
+ either (const brokenPkgsErr)
+ (removeSelf pkgIds . PackageIndex.allPackages) $
InstallPlan.dependencyClosure installPlan pkgIds
where
pkgIds = [ packageId pkg | SpecificSourcePackage pkg <- pkgSpecifiers ]
- mapLeft f (Left v) = f v
- mapLeft _ (Right _) = error "planPackages: installPlan contains broken packages"
removeSelf [thisPkg] = filter (\pp -> packageId pp /= thisPkg)
- removeSelf _ =
- error $ "internal error: 'pruneInstallPlan' given "
- ++ "unexpected package specifiers!"
+ removeSelf _ = error $ "internal error: 'pruneInstallPlan' given "
+ ++ "unexpected package specifiers!"
+ brokenPkgsErr = error "planPackages: installPlan contains broken packages"
freezePackages :: Package pkg => Verbosity -> [pkg] -> IO ()
diff --git a/cabal-install/Distribution/Client/Get.hs b/cabal-install/Distribution/Client/Get.hs
index 8fc36ea3cb1af11a97553afc27f2fb8394c7aed0..a2b882f28843f4b8d70e6495e519b1be789d2789 100644
--- a/cabal-install/Distribution/Client/Get.hs
+++ b/cabal-install/Distribution/Client/Get.hs
@@ -94,7 +94,7 @@ get verbosity repos globalFlags getFlags userTargets = do
transport <- configureTransport verbosity (flagToMaybe (globalHttpTransport globalFlags))
- pkgSpecifiers <- resolveUserTargets transport verbosity
+ pkgSpecifiers <- resolveUserTargets verbosity transport
(fromFlag $ globalWorldFile globalFlags)
(packageIndex sourcePkgDb)
userTargets
diff --git a/cabal-install/Distribution/Client/IndexUtils.hs b/cabal-install/Distribution/Client/IndexUtils.hs
index 7859b547fc695325e5866c8bfb5c9d02891cbe79..d962bcaada64d5cfc2f35f8ccca73720ad3907e7 100644
--- a/cabal-install/Distribution/Client/IndexUtils.hs
+++ b/cabal-install/Distribution/Client/IndexUtils.hs
@@ -16,7 +16,6 @@ module Distribution.Client.IndexUtils (
getInstalledPackages,
getSourcePackages,
getSourcePackagesStrict,
- convert,
readPackageIndexFile,
parsePackageIndex,
@@ -33,12 +32,10 @@ import Distribution.Client.Types
import Distribution.Package
( PackageId, PackageIdentifier(..), PackageName(..)
, Package(..), packageVersion, packageName
- , Dependency(Dependency), InstalledPackageId(..) )
+ , Dependency(Dependency) )
import Distribution.Client.PackageIndex (PackageIndex)
import qualified Distribution.Client.PackageIndex as PackageIndex
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
-import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex
-import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
import qualified Distribution.PackageDescription.Parse as PackageDesc.Parse
import Distribution.PackageDescription
( GenericPackageDescription )
@@ -97,35 +94,6 @@ getInstalledPackages verbosity comp packageDbs conf =
--FIXME: make getInstalledPackages use sensible verbosity in the first place
verbosity' = lessVerbose verbosity
-convert :: InstalledPackageIndex -> PackageIndex InstalledPackage
-convert index' = PackageIndex.fromList
- -- There can be multiple installed instances of each package version,
- -- like when the same package is installed in the global & user DBs.
- -- InstalledPackageIndex.allPackagesBySourcePackageId gives us the
- -- installed packages with the most preferred instances first, so by
- -- picking the first we should get the user one. This is almost but not
- -- quite the same as what ghc does.
- [ InstalledPackage ipkg (sourceDeps index' ipkg)
- | (_,ipkg:_) <- InstalledPackageIndex.allPackagesBySourcePackageId index' ]
- where
- -- The InstalledPackageInfo only lists dependencies by the
- -- InstalledPackageId, which means we do not directly know the corresponding
- -- source dependency. The only way to find out is to lookup the
- -- InstalledPackageId to get the InstalledPackageInfo and look at its
- -- source PackageId. But if the package is broken because it depends on
- -- other packages that do not exist then we have a problem we cannot find
- -- the original source package id. Instead we make up a bogus package id.
- -- This should have the same effect since it should be a dependency on a
- -- nonexistent package.
- sourceDeps index ipkg =
- [ maybe (brokenPackageId depid) packageId mdep
- | let depids = InstalledPackageInfo.depends ipkg
- getpkg = InstalledPackageIndex.lookupInstalledPackageId index
- , (depid, mdep) <- zip depids (map getpkg depids) ]
-
- brokenPackageId (InstalledPackageId str) =
- PackageIdentifier (PackageName (str ++ "-broken")) (Version [] [])
-
------------------------------------------------------------------------
-- Reading the source package index
--
diff --git a/cabal-install/Distribution/Client/Install.hs b/cabal-install/Distribution/Client/Install.hs
index 90f057b30ad5ea4b152a3f5b947a1c39fbb77a59..839b7f4656ee1b93ca12ac4b3e0125ce35883b34 100644
--- a/cabal-install/Distribution/Client/Install.hs
+++ b/cabal-install/Distribution/Client/Install.hs
@@ -96,8 +96,6 @@ import Distribution.Client.BuildReports.Types
( ReportLevel(..) )
import Distribution.Client.SetupWrapper
( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )
-import Distribution.Client.PackageIndex
- ( PackageFixedDeps(..) )
import qualified Distribution.Client.BuildReports.Anonymous as BuildReports
import qualified Distribution.Client.BuildReports.Storage as BuildReports
( storeAnonymous, storeLocal, fromInstallPlan, fromPlanningFailure )
@@ -138,7 +136,9 @@ import Distribution.Simple.InstallDirs as InstallDirs
import Distribution.Package
( PackageIdentifier(..), PackageId, packageName, packageVersion
, Package(..), LibraryName
- , Dependency(..), thisPackageVersion, InstalledPackageId, installedPackageId )
+ , Dependency(..), thisPackageVersion
+ , InstalledPackageId, installedPackageId
+ , HasInstalledPackageId(..) )
import qualified Distribution.PackageDescription as PackageDescription
import Distribution.PackageDescription
( PackageDescription, GenericPackageDescription(..), Flag(..)
@@ -230,7 +230,8 @@ install verbosity packageDBs repos comp platform conf useSandbox mSandboxPkgInfo
-- TODO: Make InstallContext a proper data type with documented fields.
-- | Common context for makeInstallPlan and processInstallPlan.
type InstallContext = ( InstalledPackageIndex, SourcePackageDb
- , [UserTarget], [PackageSpecifier SourcePackage], HttpTransport )
+ , [UserTarget], [PackageSpecifier SourcePackage]
+ , HttpTransport )
-- TODO: Make InstallArgs a proper data type with documented fields or just get
-- rid of it completely.
@@ -257,7 +258,8 @@ makeInstallContext verbosity
installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
sourcePkgDb <- getSourcePackages verbosity repos
- transport <- configureTransport verbosity (flagToMaybe (globalHttpTransport globalFlags))
+ transport <- configureTransport verbosity
+ (flagToMaybe (globalHttpTransport globalFlags))
(userTargets, pkgSpecifiers) <- case mUserTargets of
Nothing ->
@@ -271,13 +273,14 @@ makeInstallContext verbosity
let userTargets | null userTargets0 = [UserTargetLocalDir "."]
| otherwise = userTargets0
- pkgSpecifiers <- resolveUserTargets transport verbosity
+ pkgSpecifiers <- resolveUserTargets verbosity transport
(fromFlag $ globalWorldFile globalFlags)
(packageIndex sourcePkgDb)
userTargets
return (userTargets, pkgSpecifiers)
- return (installedPkgIndex, sourcePkgDb, userTargets, pkgSpecifiers, transport)
+ return (installedPkgIndex, sourcePkgDb, userTargets
+ ,pkgSpecifiers, transport)
-- | Make an install plan given install context and install arguments.
makeInstallPlan :: Verbosity -> InstallArgs -> InstallContext
@@ -301,10 +304,10 @@ processInstallPlan :: Verbosity -> InstallArgs -> InstallContext
-> InstallPlan
-> IO ()
processInstallPlan verbosity
- args@(_,_, comp, _, _, _, _, _, _, _, installFlags, _)
+ args@(_,_, _, _, _, _, _, _, _, _, installFlags, _)
(installedPkgIndex, sourcePkgDb,
userTargets, pkgSpecifiers, _) installPlan = do
- checkPrintPlan verbosity comp installedPkgIndex installPlan sourcePkgDb
+ checkPrintPlan verbosity installedPkgIndex installPlan sourcePkgDb
installFlags pkgSpecifiers
unless (dryRun || nothingToInstall) $ do
@@ -409,8 +412,10 @@ planPackages comp platform mSandboxPkgInfo solver
allowNewer = fromFlag (configAllowNewer configExFlags)
-- | Remove the provided targets from the install plan.
-pruneInstallPlan :: Package pkg => [PackageSpecifier pkg] -> InstallPlan
- -> Progress String String InstallPlan
+pruneInstallPlan :: Package targetpkg
+ => [PackageSpecifier targetpkg]
+ -> InstallPlan
+ -> Progress String String InstallPlan
pruneInstallPlan pkgSpecifiers =
-- TODO: this is a general feature and should be moved to D.C.Dependency
-- Also, the InstallPlan.remove should return info more precise to the
@@ -418,7 +423,7 @@ pruneInstallPlan pkgSpecifiers =
either (Fail . explain) Done
. InstallPlan.remove (\pkg -> packageName pkg `elem` targetnames)
where
- explain :: [InstallPlan.PlanProblem] -> String
+ explain :: [InstallPlan.PlanProblem ipkg srcpkg iresult ifailure] -> String
explain problems =
"Cannot select only the dependencies (as requested by the "
++ "'--only-dependencies' flag), "
@@ -443,14 +448,13 @@ pruneInstallPlan pkgSpecifiers =
-- | Perform post-solver checks of the install plan and print it if
-- either requested or needed.
checkPrintPlan :: Verbosity
- -> Compiler
-> InstalledPackageIndex
-> InstallPlan
-> SourcePackageDb
-> InstallFlags
-> [PackageSpecifier SourcePackage]
-> IO ()
-checkPrintPlan verbosity comp installed installPlan sourcePkgDb
+checkPrintPlan verbosity installed installPlan sourcePkgDb
installFlags pkgSpecifiers = do
-- User targets that are already installed.
@@ -467,7 +471,7 @@ checkPrintPlan verbosity comp installed installPlan sourcePkgDb
: map (display . packageId) preExistingTargets
++ ["Use --reinstall if you want to reinstall anyway."]
- let lPlan = linearizeInstallPlan comp installed installPlan
+ let lPlan = linearizeInstallPlan installed installPlan
-- Are any packages classified as reinstalls?
let reinstalledPkgs = concatMap (extractReinstalls . snd) lPlan
-- Packages that are already broken.
@@ -507,7 +511,8 @@ checkPrintPlan verbosity comp installed installPlan sourcePkgDb
: map (display . Installed.sourcePackageId) newBrokenPkgs
++ if overrideReinstall
then if dryRun then [] else
- ["Continuing even though the plan contains dangerous reinstalls."]
+ ["Continuing even though " ++
+ "the plan contains dangerous reinstalls."]
else
["Use --force-reinstalls if you want to install anyway."]
else unless dryRun $ warn verbosity
@@ -535,11 +540,11 @@ checkPrintPlan verbosity comp installed installPlan sourcePkgDb
dryRun = fromFlag (installDryRun installFlags)
overrideReinstall = fromFlag (installOverrideReinstall installFlags)
-linearizeInstallPlan :: Compiler
- -> InstalledPackageIndex
+--TODO: this type is too specific
+linearizeInstallPlan :: InstalledPackageIndex
-> InstallPlan
-> [(ReadyPackage, PackageStatus)]
-linearizeInstallPlan comp installedPkgIndex plan =
+linearizeInstallPlan installedPkgIndex plan =
unfoldr next plan
where
next plan' = case InstallPlan.ready plan' of
@@ -547,12 +552,13 @@ linearizeInstallPlan comp installedPkgIndex plan =
(pkg:_) -> Just ((pkg, status), plan'')
where
pkgid = installedPackageId pkg
- status = packageStatus comp installedPkgIndex pkg
- plan'' = InstallPlan.completed pkgid
- (BuildOk DocsNotTried TestsNotTried
- (Just $ Installed.emptyInstalledPackageInfo
- { Installed.sourcePackageId = packageId pkg
- , Installed.installedPackageId = pkgid }))
+ status = packageStatus installedPkgIndex pkg
+ ipkg = Installed.emptyInstalledPackageInfo {
+ Installed.sourcePackageId = packageId pkg,
+ Installed.installedPackageId = pkgid
+ }
+ plan'' = InstallPlan.completed pkgid (Just ipkg)
+ (BuildOk DocsNotTried TestsNotTried (Just ipkg))
(InstallPlan.processing [pkg] plan')
--FIXME: This is a bit of a hack,
-- pretending that each package is installed
@@ -569,8 +575,10 @@ extractReinstalls :: PackageStatus -> [InstalledPackageId]
extractReinstalls (Reinstall ipids _) = ipids
extractReinstalls _ = []
-packageStatus :: Compiler -> InstalledPackageIndex -> ReadyPackage -> PackageStatus
-packageStatus _comp installedPkgIndex cpkg =
+packageStatus :: InstalledPackageIndex
+ -> ReadyPackage
+ -> PackageStatus
+packageStatus installedPkgIndex cpkg =
case PackageIndex.lookupPackageName installedPkgIndex
(packageName cpkg) of
[] -> NewPackage
@@ -587,8 +595,10 @@ packageStatus _comp installedPkgIndex cpkg =
-> [MergeResult PackageIdentifier PackageIdentifier]
changes pkg pkg' = filter changed $
mergeBy (comparing packageName)
- (resolveInstalledIds $ Installed.depends pkg) -- deps of installed pkg
- (resolveInstalledIds $ CD.nonSetupDeps (depends pkg')) -- deps of configured pkg
+ -- deps of installed pkg
+ (resolveInstalledIds $ Installed.depends pkg)
+ -- deps of configured pkg
+ (resolveInstalledIds $ CD.nonSetupDeps (depends pkg'))
-- convert to source pkg ids via index
resolveInstalledIds :: [InstalledPackageId] -> [PackageIdentifier]
@@ -624,7 +634,7 @@ printPlan dryRun verbosity plan sourcePkgDb = case plan of
showPkg (pkg, _) = display (packageId pkg) ++
showLatest (pkg)
- showPkgAndReason (pkg', pr) = display (packageId pkg') ++
+ showPkgAndReason (ReadyPackage pkg' _, pr) = display (packageId pkg') ++
showLatest pkg' ++
showFlagAssignment (nonDefaultFlags pkg') ++
showStanzas (stanzas pkg') ++ " " ++
@@ -635,7 +645,7 @@ printPlan dryRun verbosity plan sourcePkgDb = case plan of
[] -> ""
diff -> " changes: " ++ intercalate ", " (map change diff)
- showLatest :: ReadyPackage -> String
+ showLatest :: Package srcpkg => srcpkg -> String
showLatest pkg = case mLatestVersion of
Just latestVersion ->
if packageVersion pkg < latestVersion
@@ -653,15 +663,15 @@ printPlan dryRun verbosity plan sourcePkgDb = case plan of
toFlagAssignment :: [Flag] -> FlagAssignment
toFlagAssignment = map (\ f -> (flagName f, flagDefault f))
- nonDefaultFlags :: ReadyPackage -> FlagAssignment
- nonDefaultFlags (ReadyPackage spkg fa _ _) =
+ nonDefaultFlags :: ConfiguredPackage -> FlagAssignment
+ nonDefaultFlags (ConfiguredPackage spkg fa _ _) =
let defaultAssignment =
toFlagAssignment
(genPackageFlags (Source.packageDescription spkg))
in fa \\ defaultAssignment
- stanzas :: ReadyPackage -> [OptionalStanza]
- stanzas (ReadyPackage _ _ sts _) = sts
+ stanzas :: ConfiguredPackage -> [OptionalStanza]
+ stanzas (ConfiguredPackage _ _ sts _) = sts
showStanzas :: [OptionalStanza] -> String
showStanzas = concatMap ((' ' :) . showStanza)
@@ -686,7 +696,8 @@ printPlan dryRun verbosity plan sourcePkgDb = case plan of
-- | Report a solver failure. This works slightly differently to
-- 'postInstallActions', as (by definition) we don't have an install plan.
-reportPlanningFailure :: Verbosity -> InstallArgs -> InstallContext -> String -> IO ()
+reportPlanningFailure :: Verbosity -> InstallArgs -> InstallContext -> String
+ -> IO ()
reportPlanningFailure verbosity
(_, _, comp, platform, _, _, _
,_, configFlags, _, installFlags, _)
@@ -696,12 +707,13 @@ reportPlanningFailure verbosity
when reportFailure $ do
-- Only create reports for explicitly named packages
- let pkgids =
- filter (SourcePackageIndex.elemByPackageId (packageIndex sourcePkgDb)) $
+ let pkgids = filter
+ (SourcePackageIndex.elemByPackageId (packageIndex sourcePkgDb)) $
mapMaybe theSpecifiedPackage pkgSpecifiers
- buildReports = BuildReports.fromPlanningFailure platform (compilerId comp)
- pkgids (configConfigurationsFlags configFlags)
+ buildReports = BuildReports.fromPlanningFailure platform
+ (compilerId comp) pkgids
+ (configConfigurationsFlags configFlags)
when (not (null buildReports)) $
info verbosity $
@@ -710,7 +722,8 @@ reportPlanningFailure verbosity
-- Save reports
BuildReports.storeLocal (compilerInfo comp)
- (fromNubList $ installSummaryFile installFlags) buildReports platform
+ (fromNubList $ installSummaryFile installFlags)
+ buildReports platform
-- Save solver log
case logFile of
@@ -730,7 +743,8 @@ reportPlanningFailure verbosity
-- So we fail.
dummyLibraryName = error "reportPlanningFailure: library name not available"
--- | If a 'PackageSpecifier' refers to a single package, return Just that package.
+-- | If a 'PackageSpecifier' refers to a single package, return Just that
+-- package.
theSpecifiedPackage :: Package pkg => PackageSpecifier pkg -> Maybe PackageId
theSpecifiedPackage pkgSpec =
case pkgSpec of
@@ -774,9 +788,12 @@ postInstallActions verbosity
[ World.WorldPkgInfo dep []
| UserTargetNamed dep <- targets ]
- let buildReports = BuildReports.fromInstallPlan installPlan
- BuildReports.storeLocal (compilerInfo comp) (fromNubList $ installSummaryFile installFlags) buildReports
- (InstallPlan.planPlatform installPlan)
+ let buildReports = BuildReports.fromInstallPlan platform (compilerId comp)
+ installPlan
+ BuildReports.storeLocal (compilerInfo comp)
+ (fromNubList $ installSummaryFile installFlags)
+ buildReports
+ platform
when (reportingLevel >= AnonymousReports) $
BuildReports.storeAnonymous buildReports
when (reportingLevel == DetailedReports) $
@@ -785,7 +802,7 @@ postInstallActions verbosity
regenerateHaddockIndex verbosity packageDBs comp platform conf useSandbox
configFlags installFlags installPlan
- symlinkBinaries verbosity comp configFlags installFlags installPlan
+ symlinkBinaries verbosity platform comp configFlags installFlags installPlan
printBuildFailures installPlan
@@ -876,8 +893,8 @@ regenerateHaddockIndex verbosity packageDBs comp platform conf useSandbox
normalUserInstall = (UserPackageDB `elem` packageDBs)
&& all (not . isSpecificPackageDB) packageDBs
- installedDocs (InstallPlan.Installed _ (BuildOk DocsOk _ _)) = True
- installedDocs _ = False
+ installedDocs (InstallPlan.Installed _ _ (BuildOk DocsOk _ _)) = True
+ installedDocs _ = False
isSpecificPackageDB (SpecificPackageDB _) = True
isSpecificPackageDB _ = False
@@ -895,12 +912,15 @@ regenerateHaddockIndex verbosity packageDBs comp platform conf useSandbox
symlinkBinaries :: Verbosity
- -> Compiler
+ -> Platform -> Compiler
-> ConfigFlags
-> InstallFlags
- -> InstallPlan -> IO ()
-symlinkBinaries verbosity comp configFlags installFlags plan = do
- failed <- InstallSymlink.symlinkBinaries comp configFlags installFlags plan
+ -> InstallPlan
+ -> IO ()
+symlinkBinaries verbosity platform comp configFlags installFlags plan = do
+ failed <- InstallSymlink.symlinkBinaries platform comp
+ configFlags installFlags
+ plan
case failed of
[] -> return ()
[(_, exe, path)] ->
@@ -922,7 +942,8 @@ symlinkBinaries verbosity comp configFlags installFlags plan = do
bindir = fromFlag (installSymlinkBinDir installFlags)
-printBuildFailures :: InstallPlan -> IO ()
+printBuildFailures :: InstallPlan
+ -> IO ()
printBuildFailures plan =
case [ (pkg, reason)
| InstallPlan.Failed pkg reason <- InstallPlan.toList plan ] of
@@ -966,15 +987,17 @@ printBuildFailures plan =
-- | If we're working inside a sandbox and some add-source deps were installed,
-- update the timestamps of those deps.
updateSandboxTimestampsFile :: UseSandbox -> Maybe SandboxPackageInfo
- -> Compiler -> Platform -> InstallPlan
+ -> Compiler -> Platform
+ -> InstallPlan
-> IO ()
updateSandboxTimestampsFile (UseSandbox sandboxDir)
(Just (SandboxPackageInfo _ _ _ allAddSourceDeps))
comp platform installPlan =
withUpdateTimestamps sandboxDir (compilerId comp) platform $ \_ -> do
- let allInstalled = [ pkg | InstallPlan.Installed pkg _
+ let allInstalled = [ pkg | InstallPlan.Installed pkg _ _
<- InstallPlan.toList installPlan ]
- allSrcPkgs = [ pkg | ReadyPackage pkg _ _ _ <- allInstalled ]
+ allSrcPkgs = [ pkg | ReadyPackage (ConfiguredPackage pkg _ _ _) _
+ <- allInstalled ]
allPaths = [ pth | LocalUnpackedPackage pth
<- map packageSource allSrcPkgs]
allPathsCanonical <- mapM tryCanonicalizePath allPaths
@@ -1001,7 +1024,7 @@ performInstallations :: Verbosity
-> InstallPlan
-> IO InstallPlan
performInstallations verbosity
- (packageDBs, _, comp, _, conf, useSandbox, _,
+ (packageDBs, _, comp, platform, conf, useSandbox, _,
globalFlags, configFlags, configExFlags, installFlags, haddockFlags)
installedPkgIndex installPlan = do
@@ -1018,7 +1041,8 @@ performInstallations verbosity
installLock <- newLock -- serialise installation
cacheLock <- newLock -- serialise access to setup exe cache
- transport <- configureTransport verbosity (flagToMaybe (globalHttpTransport globalFlags))
+ transport <- configureTransport verbosity
+ (flagToMaybe (globalHttpTransport globalFlags))
executeInstallPlan verbosity comp jobControl useLogFile installPlan $ \rpkg ->
-- Calculate the package key (ToDo: Is this right for source install)
@@ -1029,13 +1053,14 @@ performInstallations verbosity
installLocalPackage verbosity buildLimit
(packageId pkg) src' distPref $ \mpath ->
installUnpackedPackage verbosity buildLimit installLock numJobs libname
- (setupScriptOptions installedPkgIndex cacheLock rpkg)
- miscOptions configFlags' installFlags haddockFlags
+ (setupScriptOptions installedPkgIndex
+ cacheLock rpkg)
+ miscOptions configFlags'
+ installFlags haddockFlags
cinfo platform pkg pkgoverride mpath useLogFile
where
- platform = InstallPlan.planPlatform installPlan
- cinfo = InstallPlan.planCompiler installPlan
+ cinfo = compilerInfo comp
numJobs = determineNumJobs (installNumJobs installFlags)
numFetchJobs = 2
@@ -1096,7 +1121,8 @@ performInstallations verbosity
| parallelInstall = False
| otherwise = False
- substLogFileName :: PathTemplate -> PackageIdentifier -> LibraryName -> FilePath
+ substLogFileName :: PathTemplate -> PackageIdentifier -> LibraryName
+ -> FilePath
substLogFileName template pkg libname = fromPathTemplate
. substPathTemplate env
$ template
@@ -1149,12 +1175,15 @@ executeInstallPlan verbosity comp jobCtl useLogFile plan0 installPkg =
plan' = updatePlan pkgid buildResult plan
tryNewTasks taskCount' plan'
- updatePlan :: PackageIdentifier -> BuildResult -> InstallPlan -> InstallPlan
- updatePlan pkgid (Right buildSuccess) =
- InstallPlan.completed (Source.fakeInstalledPackageId pkgid) buildSuccess
+ updatePlan :: PackageIdentifier -> BuildResult -> InstallPlan
+ -> InstallPlan
+ updatePlan pkgid (Right buildSuccess@(BuildOk _ _ mipkg)) =
+ InstallPlan.completed (Source.fakeInstalledPackageId pkgid)
+ mipkg buildSuccess
updatePlan pkgid (Left buildFailure) =
- InstallPlan.failed (Source.fakeInstalledPackageId pkgid) buildFailure depsFailure
+ InstallPlan.failed (Source.fakeInstalledPackageId pkgid)
+ buildFailure depsFailure
where
depsFailure = DependentFailed pkgid
-- So this first pkgid failed for whatever reason (buildFailure).
@@ -1189,16 +1218,20 @@ executeInstallPlan verbosity comp jobCtl useLogFile plan0 installPkg =
-- NB: when updating this function, don't forget to also update
-- 'configurePackage' in D.C.Configure.
installReadyPackage :: Platform -> CompilerInfo
- -> ConfigFlags
- -> ReadyPackage
- -> (ConfigFlags -> PackageLocation (Maybe FilePath)
- -> PackageDescription
- -> PackageDescriptionOverride -> a)
- -> a
+ -> ConfigFlags
+ -> ReadyPackage
+ -> (ConfigFlags -> PackageLocation (Maybe FilePath)
+ -> PackageDescription
+ -> PackageDescriptionOverride
+ -> a)
+ -> a
installReadyPackage platform cinfo configFlags
- (ReadyPackage (SourcePackage _ gpkg source pkgoverride)
- flags stanzas deps)
- installPkg = installPkg configFlags {
+ (ReadyPackage (ConfiguredPackage
+ (SourcePackage _ gpkg source pkgoverride)
+ flags stanzas _)
+ deps)
+ installPkg =
+ installPkg configFlags {
configConfigurationsFlags = flags,
-- We generate the legacy constraints as well as the new style precise deps.
-- In the end only one set gets passed to Setup.hs configure, depending on
@@ -1397,7 +1430,8 @@ installUnpackedPackage verbosity buildLimit installLock numJobs libname
maybePkgConf <- maybeGenPkgConf mLogPath
-- Actual installation
- withWin32SelfUpgrade verbosity libname configFlags cinfo platform pkg $ do
+ withWin32SelfUpgrade verbosity libname configFlags
+ cinfo platform pkg $ do
case rootCmd miscOptions of
(Just cmd) -> reexec cmd
Nothing -> do
@@ -1569,4 +1603,5 @@ withWin32SelfUpgrade verbosity libname configFlags cinfo platform pkg action = d
platform templateDirs
substTemplate = InstallDirs.fromPathTemplate
. InstallDirs.substPathTemplate env
- where env = InstallDirs.initialPathTemplateEnv pkgid libname cinfo platform
+ where env = InstallDirs.initialPathTemplateEnv pkgid libname
+ cinfo platform
diff --git a/cabal-install/Distribution/Client/InstallPlan.hs b/cabal-install/Distribution/Client/InstallPlan.hs
index 6e9afb8006079cfa858505384af054bb55047b35..671cfa903624fa985c0ea3683ca33850c9d1e0ee 100644
--- a/cabal-install/Distribution/Client/InstallPlan.hs
+++ b/cabal-install/Distribution/Client/InstallPlan.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.InstallPlan
@@ -13,8 +14,9 @@
-----------------------------------------------------------------------------
module Distribution.Client.InstallPlan (
InstallPlan,
- ConfiguredPackage(..),
- PlanPackage(..),
+ GenericInstallPlan,
+ PlanPackage,
+ GenericPlanPackage(..),
-- * Operations on 'InstallPlan's
new,
@@ -27,55 +29,34 @@ module Distribution.Client.InstallPlan (
showPlanIndex,
showInstallPlan,
- -- ** Query functions
- planPlatform,
- planCompiler,
-
-- * Checking validity of plans
valid,
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(..)
- , ReadyPackage(..), readyPackageToConfiguredPackage
- , InstalledPackage, BuildFailure, BuildSuccess(..), enableStanzas
- , InstalledPackage(..), fakeInstalledPackageId
- , ConfiguredId(..)
- )
+import Distribution.InstalledPackageInfo
+ ( InstalledPackageInfo )
import Distribution.Package
- ( PackageIdentifier(..), PackageName(..), Package(..), packageName
- , Dependency(..), PackageId, InstalledPackageId
- , HasInstalledPackageId(..) )
+ ( PackageIdentifier(..), PackageName(..), Package(..)
+ , InstalledPackageId, HasInstalledPackageId(..) )
+import Distribution.Client.Types
+ ( BuildSuccess, BuildFailure
+ , PackageFixedDeps(..), ConfiguredPackage
+ , GenericReadyPackage(..), fakeInstalledPackageId )
import Distribution.Version
- ( Version, withinRange )
-import Distribution.PackageDescription
- ( GenericPackageDescription(genPackageFlags)
- , Flag(flagName), FlagName(..)
- , SetupBuildInfo(..), setupBuildInfo
- )
-import Distribution.Client.PackageUtils
- ( externalBuildDepends )
-import Distribution.Client.PackageIndex
- ( PackageFixedDeps(..) )
+ ( 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
@@ -84,22 +65,12 @@ import Distribution.Client.PlanIndex
import qualified Distribution.Client.PlanIndex as PlanIndex
import Distribution.Text
( display )
-import Distribution.System
- ( Platform )
-import Distribution.Compiler
- ( CompilerInfo(..) )
-import Distribution.Client.Utils
- ( duplicates, duplicatesBy, mergeBy, MergeResult(..) )
-import Distribution.Simple.Utils
- ( comparing, intercalate )
-import qualified Distribution.InstalledPackageInfo as Installed
import Data.List
- ( sort, sortBy, nubBy )
+ ( intercalate )
import Data.Maybe
( fromMaybe, maybeToList )
import qualified Data.Graph as Graph
-import Data.Function (on)
import Data.Graph (Graph)
import Control.Exception
( assert )
@@ -107,7 +78,6 @@ import Data.Maybe (catMaybes)
import qualified Data.Map as Map
import qualified Data.Traversable as T
-type PlanIndex = PackageIndex PlanPackage
-- When cabal tries to install a number of packages, including all their
-- dependencies it has a non-trivial problem to solve.
@@ -153,70 +123,87 @@ type PlanIndex = PackageIndex PlanPackage
-- | Packages in an install plan
--
--- NOTE: 'ConfiguredPackage', 'ReadyPackage' and 'PlanPackage' intentionally
--- have no 'PackageInstalled' instance. `This is important: PackageInstalled
--- returns only library dependencies, but for package that aren't yet installed
--- we know many more kinds of dependencies (setup dependencies, exe, test-suite,
--- benchmark, ..). Any functions that operate on dependencies in cabal-install
--- should consider what to do with these dependencies; if we give a
--- 'PackageInstalled' instance it would be too easy to get this wrong (and,
--- for instance, call graph traversal functions from Cabal rather than from
--- cabal-install). Instead, see 'PackageFixedDeps'.
-data PlanPackage = PreExisting InstalledPackage
- | Configured ConfiguredPackage
- | Processing ReadyPackage
- | Installed ReadyPackage BuildSuccess
- | Failed ConfiguredPackage BuildFailure
- -- ^ NB: packages in the Failed state can be *either* Ready
- -- or Configured.
-
-instance Package PlanPackage where
- packageId (PreExisting pkg) = packageId pkg
- packageId (Configured pkg) = packageId pkg
- packageId (Processing pkg) = packageId pkg
- packageId (Installed pkg _) = packageId pkg
- packageId (Failed pkg _) = packageId pkg
-
-instance PackageFixedDeps PlanPackage where
- depends (PreExisting pkg) = depends pkg
- depends (Configured pkg) = depends pkg
- depends (Processing pkg) = depends pkg
- depends (Installed pkg _) = depends pkg
- depends (Failed pkg _) = depends pkg
-
-instance HasInstalledPackageId PlanPackage where
- installedPackageId (PreExisting pkg) = installedPackageId pkg
- installedPackageId (Configured pkg) = installedPackageId pkg
- installedPackageId (Processing pkg) = installedPackageId pkg
+-- NOTE: 'ConfiguredPackage', 'GenericReadyPackage' and 'GenericPlanPackage'
+-- intentionally have no 'PackageInstalled' instance. `This is important:
+-- PackageInstalled returns only library dependencies, but for package that
+-- aren't yet installed we know many more kinds of dependencies (setup
+-- dependencies, exe, test-suite, benchmark, ..). Any functions that operate on
+-- dependencies in cabal-install should consider what to do with these
+-- dependencies; if we give a 'PackageInstalled' instance it would be too easy
+-- to get this wrong (and, for instance, call graph traversal functions from
+-- Cabal rather than from cabal-install). Instead, see 'PackageFixedDeps'.
+data GenericPlanPackage ipkg srcpkg iresult ifailure
+ = PreExisting ipkg
+ | Configured srcpkg
+ | Processing (GenericReadyPackage srcpkg ipkg)
+ | Installed (GenericReadyPackage srcpkg ipkg) (Maybe ipkg) iresult
+ | Failed srcpkg ifailure
+
+type PlanPackage = GenericPlanPackage
+ InstalledPackageInfo ConfiguredPackage
+ BuildSuccess BuildFailure
+
+instance (Package ipkg, Package srcpkg) =>
+ Package (GenericPlanPackage ipkg srcpkg iresult ifailure) where
+ packageId (PreExisting ipkg) = packageId ipkg
+ packageId (Configured spkg) = packageId spkg
+ packageId (Processing rpkg) = packageId rpkg
+ packageId (Installed rpkg _ _) = packageId rpkg
+ packageId (Failed spkg _) = packageId spkg
+
+instance (PackageFixedDeps srcpkg,
+ PackageFixedDeps ipkg, HasInstalledPackageId ipkg) =>
+ PackageFixedDeps (GenericPlanPackage ipkg srcpkg iresult ifailure) where
+ depends (PreExisting pkg) = depends pkg
+ depends (Configured pkg) = depends pkg
+ depends (Processing pkg) = depends pkg
+ depends (Installed pkg _ _) = depends pkg
+ depends (Failed pkg _) = depends pkg
+
+instance (HasInstalledPackageId ipkg, HasInstalledPackageId srcpkg) =>
+ HasInstalledPackageId
+ (GenericPlanPackage ipkg srcpkg iresult ifailure) where
+ installedPackageId (PreExisting ipkg ) = installedPackageId ipkg
+ installedPackageId (Configured spkg) = installedPackageId spkg
+ installedPackageId (Processing rpkg) = installedPackageId rpkg
-- NB: defer to the actual installed package info in this case
- installedPackageId (Installed _ (BuildOk _ _ (Just ipkg))) = installedPackageId ipkg
- installedPackageId (Installed pkg _) = installedPackageId pkg
- installedPackageId (Failed pkg _) = installedPackageId pkg
+ installedPackageId (Installed _ (Just ipkg) _) = installedPackageId ipkg
+ installedPackageId (Installed rpkg _ _) = installedPackageId rpkg
+ installedPackageId (Failed spkg _) = installedPackageId spkg
+
-data InstallPlan = InstallPlan {
- planIndex :: PlanIndex,
+data GenericInstallPlan ipkg srcpkg iresult ifailure = GenericInstallPlan {
+ planIndex :: (PlanIndex ipkg srcpkg iresult ifailure),
planFakeMap :: FakeMap,
planGraph :: Graph,
planGraphRev :: Graph,
- planPkgOf :: Graph.Vertex -> PlanPackage,
+ planPkgOf :: Graph.Vertex
+ -> GenericPlanPackage ipkg srcpkg iresult ifailure,
planVertexOf :: InstalledPackageId -> Graph.Vertex,
- planPlatform :: Platform,
- planCompiler :: CompilerInfo,
planIndepGoals :: Bool
}
-invariant :: InstallPlan -> Bool
+-- | 'GenericInstallPlan' specialised to most commonly used types.
+type InstallPlan = GenericInstallPlan
+ InstalledPackageInfo ConfiguredPackage
+ BuildSuccess BuildFailure
+
+type PlanIndex ipkg srcpkg iresult ifailure =
+ PackageIndex (GenericPlanPackage ipkg srcpkg iresult ifailure)
+
+invariant :: (HasInstalledPackageId ipkg, PackageFixedDeps ipkg,
+ HasInstalledPackageId srcpkg, PackageFixedDeps srcpkg)
+ => GenericInstallPlan ipkg srcpkg iresult ifailure -> Bool
invariant plan =
- valid (planPlatform plan)
- (planCompiler plan)
- (planFakeMap plan)
+ valid (planFakeMap plan)
(planIndepGoals plan)
(planIndex plan)
internalError :: String -> a
internalError msg = error $ "InstallPlan: internal error: " ++ msg
-showPlanIndex :: PlanIndex -> String
+showPlanIndex :: (HasInstalledPackageId ipkg, HasInstalledPackageId srcpkg)
+ => PlanIndex ipkg srcpkg iresult ifailure -> String
showPlanIndex index =
intercalate "\n" (map showPlanPackage (PackageIndex.allPackages index))
where showPlanPackage p =
@@ -224,42 +211,47 @@ showPlanIndex index =
++ display (packageId p) ++ " ("
++ display (installedPackageId p) ++ ")"
-showInstallPlan :: InstallPlan -> String
+showInstallPlan :: (HasInstalledPackageId ipkg, HasInstalledPackageId srcpkg)
+ => GenericInstallPlan ipkg srcpkg iresult ifailure -> String
showInstallPlan plan =
showPlanIndex (planIndex plan) ++ "\n" ++
- "fake map:\n " ++ intercalate "\n " (map showKV (Map.toList (planFakeMap plan)))
+ "fake map:\n " ++
+ intercalate "\n " (map showKV (Map.toList (planFakeMap plan)))
where showKV (k,v) = display k ++ " -> " ++ display v
-showPlanPackageTag :: PlanPackage -> String
-showPlanPackageTag (PreExisting _) = "PreExisting"
-showPlanPackageTag (Configured _) = "Configured"
-showPlanPackageTag (Processing _) = "Processing"
-showPlanPackageTag (Installed _ _) = "Installed"
-showPlanPackageTag (Failed _ _) = "Failed"
+showPlanPackageTag :: GenericPlanPackage ipkg srcpkg iresult ifailure -> String
+showPlanPackageTag (PreExisting _) = "PreExisting"
+showPlanPackageTag (Configured _) = "Configured"
+showPlanPackageTag (Processing _) = "Processing"
+showPlanPackageTag (Installed _ _ _) = "Installed"
+showPlanPackageTag (Failed _ _) = "Failed"
-- | Build an installation plan from a valid set of resolved packages.
--
-new :: Platform -> CompilerInfo -> Bool -> PlanIndex
- -> Either [PlanProblem] InstallPlan
-new platform cinfo indepGoals index =
+new :: (HasInstalledPackageId ipkg, PackageFixedDeps ipkg,
+ HasInstalledPackageId srcpkg, PackageFixedDeps srcpkg)
+ => Bool
+ -> PlanIndex ipkg srcpkg iresult ifailure
+ -> Either [PlanProblem ipkg srcpkg iresult ifailure]
+ (GenericInstallPlan ipkg srcpkg iresult ifailure)
+new indepGoals index =
-- NB: Need to pre-initialize the fake-map with pre-existing
-- packages
let isPreExisting (PreExisting _) = True
isPreExisting _ = False
fakeMap = Map.fromList
- . map (\p -> (fakeInstalledPackageId (packageId p), installedPackageId p))
+ . map (\p -> (fakeInstalledPackageId (packageId p)
+ ,installedPackageId p))
. filter isPreExisting
$ PackageIndex.allPackages index in
- case problems platform cinfo fakeMap indepGoals index of
- [] -> Right InstallPlan {
+ case problems fakeMap indepGoals index of
+ [] -> Right GenericInstallPlan {
planIndex = index,
planFakeMap = fakeMap,
planGraph = graph,
planGraphRev = Graph.transposeG graph,
planPkgOf = vertexToPkgId,
planVertexOf = fromMaybe noSuchPkgId . pkgIdToVertex,
- planPlatform = platform,
- planCompiler = cinfo,
planIndepGoals = indepGoals
}
where (graph, vertexToPkgId, pkgIdToVertex) =
@@ -267,7 +259,8 @@ new platform cinfo indepGoals index =
noSuchPkgId = internalError "package is not in the graph"
probs -> Left probs
-toList :: InstallPlan -> [PlanPackage]
+toList :: GenericInstallPlan ipkg srcpkg iresult ifailure
+ -> [GenericPlanPackage ipkg srcpkg iresult ifailure]
toList = PackageIndex.allPackages . planIndex
-- | Remove packages from the install plan. This will result in an
@@ -276,11 +269,14 @@ toList = PackageIndex.allPackages . planIndex
-- the dependencies of a package or set of packages without actually
-- installing the package itself, as when doing development.
--
-remove :: (PlanPackage -> Bool)
- -> InstallPlan
- -> Either [PlanProblem] InstallPlan
+remove :: (HasInstalledPackageId ipkg, PackageFixedDeps ipkg,
+ HasInstalledPackageId srcpkg, PackageFixedDeps srcpkg)
+ => (GenericPlanPackage ipkg srcpkg iresult ifailure -> Bool)
+ -> GenericInstallPlan ipkg srcpkg iresult ifailure
+ -> Either [PlanProblem ipkg srcpkg iresult ifailure]
+ (GenericInstallPlan ipkg srcpkg iresult ifailure)
remove shouldRemove plan =
- new (planPlatform plan) (planCompiler plan) (planIndepGoals plan) newIndex
+ new (planIndepGoals plan) newIndex
where
newIndex = PackageIndex.fromList $
filter (not . shouldRemove) (toList plan)
@@ -289,7 +285,9 @@ remove shouldRemove plan =
-- configured state and have all their dependencies installed already.
-- The plan is complete if the result is @[]@.
--
-ready :: InstallPlan -> [ReadyPackage]
+ready :: forall ipkg srcpkg iresult ifailure. PackageFixedDeps srcpkg
+ => GenericInstallPlan ipkg srcpkg iresult ifailure
+ -> [GenericReadyPackage srcpkg ipkg]
ready plan = assert check readyPackages
where
check = if null readyPackages && null processingPackages
@@ -298,29 +296,31 @@ ready plan = assert check readyPackages
configuredPackages = [ pkg | Configured pkg <- toList plan ]
processingPackages = [ pkg | Processing pkg <- toList plan]
- readyPackages :: [ReadyPackage]
+ readyPackages :: [GenericReadyPackage srcpkg ipkg]
readyPackages =
- [ ReadyPackage srcPkg flags stanzas deps
- | pkg@(ConfiguredPackage srcPkg flags stanzas _) <- configuredPackages
+ [ ReadyPackage srcpkg deps
+ | srcpkg <- configuredPackages
-- select only the package that have all of their deps installed:
- , deps <- maybeToList (hasAllInstalledDeps pkg)
+ , deps <- maybeToList (hasAllInstalledDeps srcpkg)
]
- hasAllInstalledDeps :: ConfiguredPackage -> Maybe (ComponentDeps [Installed.InstalledPackageInfo])
+ hasAllInstalledDeps :: srcpkg -> Maybe (ComponentDeps [ipkg])
hasAllInstalledDeps = T.mapM (mapM isInstalledDep) . depends
- isInstalledDep :: InstalledPackageId -> Maybe Installed.InstalledPackageInfo
+ isInstalledDep :: InstalledPackageId -> Maybe ipkg
isInstalledDep pkgid =
- -- NB: Need to check if the ID has been updated in planFakeMap, in which case we
- -- might be dealing with an old pointer
- case PlanIndex.fakeLookupInstalledPackageId (planFakeMap plan) (planIndex plan) pkgid of
- Just (Configured _) -> Nothing
- Just (Processing _) -> Nothing
- Just (Failed _ _) -> internalError depOnFailed
- Just (PreExisting (InstalledPackage instPkg _)) -> Just instPkg
- Just (Installed _ (BuildOk _ _ (Just instPkg))) -> Just instPkg
- Just (Installed _ (BuildOk _ _ Nothing)) -> internalError depOnNonLib
- Nothing -> internalError incomplete
+ -- NB: Need to check if the ID has been updated in planFakeMap, in which
+ -- case we might be dealing with an old pointer
+ case PlanIndex.fakeLookupInstalledPackageId
+ (planFakeMap plan) (planIndex plan) pkgid
+ of
+ Just (PreExisting ipkg) -> Just ipkg
+ Just (Configured _) -> Nothing
+ Just (Processing _) -> Nothing
+ Just (Installed _ (Just ipkg) _) -> Just ipkg
+ Just (Installed _ Nothing _) -> internalError depOnNonLib
+ Just (Failed _ _) -> internalError depOnFailed
+ Nothing -> internalError incomplete
incomplete = "install plan is not closed"
depOnFailed = "configured package depends on failed package"
depOnNonLib = "configured package depends on a non-library package"
@@ -329,7 +329,11 @@ ready plan = assert check readyPackages
--
-- * The package must exist in the graph and be in the configured state.
--
-processing :: [ReadyPackage] -> InstallPlan -> InstallPlan
+processing :: (HasInstalledPackageId ipkg, PackageFixedDeps ipkg,
+ HasInstalledPackageId srcpkg, PackageFixedDeps srcpkg)
+ => [GenericReadyPackage srcpkg ipkg]
+ -> GenericInstallPlan ipkg srcpkg iresult ifailure
+ -> GenericInstallPlan ipkg srcpkg iresult ifailure
processing pkgs plan = assert (invariant plan') plan'
where
plan' = plan {
@@ -343,15 +347,18 @@ processing pkgs plan = assert (invariant plan') plan'
-- * The package must exist in the graph and be in the processing state.
-- * The package must have had no uninstalled dependent packages.
--
-completed :: InstalledPackageId
- -> BuildSuccess
- -> InstallPlan -> InstallPlan
-completed pkgid buildResult plan = assert (invariant plan') plan'
+completed :: (HasInstalledPackageId ipkg, PackageFixedDeps ipkg,
+ HasInstalledPackageId srcpkg, PackageFixedDeps srcpkg)
+ => InstalledPackageId
+ -> Maybe ipkg -> iresult
+ -> GenericInstallPlan ipkg srcpkg iresult ifailure
+ -> GenericInstallPlan ipkg srcpkg iresult ifailure
+completed pkgid mipkg buildResult plan = assert (invariant plan') plan'
where
plan' = plan {
-- NB: installation can change the IPID, so better
-- record it in the fake mapping...
- planFakeMap = insert_fake_mapping buildResult
+ planFakeMap = insert_fake_mapping mipkg
$ planFakeMap plan,
planIndex = PackageIndex.insert installed
. PackageIndex.deleteInstalledPackageId pkgid
@@ -359,9 +366,9 @@ completed pkgid buildResult plan = assert (invariant plan') plan'
}
-- ...but be sure to use the *old* IPID for the lookup for the
-- preexisting record
- installed = Installed (lookupProcessingPackage plan pkgid) buildResult
- insert_fake_mapping (BuildOk _ _ (Just ipi)) = Map.insert pkgid (installedPackageId ipi)
- insert_fake_mapping _ = id
+ installed = Installed (lookupProcessingPackage plan pkgid) mipkg buildResult
+ insert_fake_mapping (Just ipkg) = Map.insert pkgid (installedPackageId ipkg)
+ insert_fake_mapping _ = id
-- | Marks a package in the graph as having failed. It also marks all the
-- packages that depended on it as having failed.
@@ -369,28 +376,31 @@ completed pkgid buildResult plan = assert (invariant plan') plan'
-- * The package must exist in the graph and be in the processing
-- state.
--
-failed :: InstalledPackageId -- ^ The id of the package that failed to install
- -> BuildFailure -- ^ The build result to use for the failed package
- -> BuildFailure -- ^ The build result to use for its dependencies
- -> InstallPlan
- -> InstallPlan
+failed :: (HasInstalledPackageId ipkg, PackageFixedDeps ipkg,
+ HasInstalledPackageId srcpkg, PackageFixedDeps srcpkg)
+ => InstalledPackageId -- ^ The id of the package that failed to install
+ -> ifailure -- ^ The build result to use for the failed package
+ -> ifailure -- ^ The build result to use for its dependencies
+ -> GenericInstallPlan ipkg srcpkg iresult ifailure
+ -> GenericInstallPlan ipkg srcpkg iresult ifailure
failed pkgid buildResult buildResult' plan = assert (invariant plan') plan'
where
-- NB: failures don't update IPIDs
plan' = plan {
planIndex = PackageIndex.merge (planIndex plan) failures
}
- pkg = lookupProcessingPackage plan pkgid
+ ReadyPackage srcpkg _deps = lookupProcessingPackage plan pkgid
failures = PackageIndex.fromList
- $ Failed (readyPackageToConfiguredPackage pkg) buildResult
+ $ Failed srcpkg buildResult
: [ Failed pkg' buildResult'
| Just pkg' <- map checkConfiguredPackage
$ packagesThatDependOn plan pkgid ]
-- | Lookup the reachable packages in the reverse dependency graph.
--
-packagesThatDependOn :: InstallPlan
- -> InstalledPackageId -> [PlanPackage]
+packagesThatDependOn :: GenericInstallPlan ipkg srcpkg iresult ifailure
+ -> InstalledPackageId
+ -> [GenericPlanPackage ipkg srcpkg iresult ifailure]
packagesThatDependOn plan pkgid = map (planPkgOf plan)
. tail
. Graph.reachable (planGraphRev plan)
@@ -399,18 +409,22 @@ packagesThatDependOn plan pkgid = map (planPkgOf plan)
-- | Lookup a package that we expect to be in the processing state.
--
-lookupProcessingPackage :: InstallPlan
- -> InstalledPackageId -> ReadyPackage
+lookupProcessingPackage :: GenericInstallPlan ipkg srcpkg iresult ifailure
+ -> InstalledPackageId
+ -> GenericReadyPackage srcpkg ipkg
lookupProcessingPackage plan pkgid =
-- NB: processing packages are guaranteed to not indirect through
-- planFakeMap
case PackageIndex.lookupInstalledPackageId (planIndex plan) pkgid of
Just (Processing pkg) -> pkg
- _ -> internalError $ "not in processing state or no such pkg " ++ display pkgid
+ _ -> internalError $ "not in processing state or no such pkg " ++
+ display pkgid
-- | Check a package that we expect to be in the configured or failed state.
--
-checkConfiguredPackage :: PlanPackage -> Maybe ConfiguredPackage
+checkConfiguredPackage :: (Package srcpkg, Package ipkg)
+ => GenericPlanPackage ipkg srcpkg iresult ifailure
+ -> Maybe srcpkg
checkConfiguredPackage (Configured pkg) = Just pkg
checkConfiguredPackage (Failed _ _) = Nothing
checkConfiguredPackage pkg =
@@ -426,24 +440,24 @@ 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
-
-data PlanProblem =
- PackageInvalid ConfiguredPackage [PackageProblem]
- | PackageMissingDeps PlanPackage [PackageIdentifier]
- | PackageCycle [PlanPackage]
+valid :: (HasInstalledPackageId ipkg, PackageFixedDeps ipkg,
+ HasInstalledPackageId srcpkg, PackageFixedDeps srcpkg)
+ => FakeMap -> Bool
+ -> PlanIndex ipkg srcpkg iresult ifailure
+ -> Bool
+valid fakeMap indepGoals index =
+ null $ problems fakeMap indepGoals index
+
+data PlanProblem ipkg srcpkg iresult ifailure =
+ PackageMissingDeps (GenericPlanPackage ipkg srcpkg iresult ifailure)
+ [PackageIdentifier]
+ | PackageCycle [GenericPlanPackage ipkg srcpkg iresult ifailure]
| 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 ]
+ | PackageStateInvalid (GenericPlanPackage ipkg srcpkg iresult ifailure)
+ (GenericPlanPackage ipkg srcpkg iresult ifailure)
+showPlanProblem :: (Package ipkg, Package srcpkg)
+ => PlanProblem ipkg srcpkg iresult ifailure -> String
showPlanProblem (PackageMissingDeps pkg missingDeps) =
"Package " ++ display (packageId pkg)
++ " depends on the following packages which are missing from the plan: "
@@ -468,36 +482,41 @@ showPlanProblem (PackageStateInvalid pkg pkg') =
++ " which is in the " ++ showPlanState pkg'
++ " state"
where
- showPlanState (PreExisting _) = "pre-existing"
- showPlanState (Configured _) = "configured"
- showPlanState (Processing _) = "processing"
- showPlanState (Installed _ _) = "installed"
- showPlanState (Failed _ _) = "failed"
+ showPlanState (PreExisting _) = "pre-existing"
+ showPlanState (Configured _) = "configured"
+ showPlanState (Processing _) = "processing"
+ showPlanState (Installed _ _ _) = "installed"
+ showPlanState (Failed _ _) = "failed"
-- | For an invalid plan, produce a detailed list of problems as human readable
-- 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) ]
-
- ++ [ PackageMissingDeps pkg (catMaybes (map (fmap packageId . PlanIndex.fakeLookupInstalledPackageId fakeMap index) missingDeps))
+problems :: (HasInstalledPackageId ipkg, PackageFixedDeps ipkg,
+ HasInstalledPackageId srcpkg, PackageFixedDeps srcpkg)
+ => FakeMap -> Bool
+ -> PlanIndex ipkg srcpkg iresult ifailure
+ -> [PlanProblem ipkg srcpkg iresult ifailure]
+problems fakeMap indepGoals index =
+
+ [ PackageMissingDeps pkg
+ (catMaybes
+ (map
+ (fmap packageId . PlanIndex.fakeLookupInstalledPackageId fakeMap index)
+ missingDeps))
| (pkg, missingDeps) <- PlanIndex.brokenPackages fakeMap index ]
++ [ PackageCycle cycleGroup
| cycleGroup <- PlanIndex.dependencyCycles fakeMap index ]
++ [ PackageInconsistency name inconsistencies
- | (name, inconsistencies) <- PlanIndex.dependencyInconsistencies fakeMap indepGoals index ]
+ | (name, inconsistencies) <-
+ PlanIndex.dependencyInconsistencies fakeMap indepGoals index ]
++ [ PackageStateInvalid pkg pkg'
| pkg <- PackageIndex.allPackages index
- , Just pkg' <- map (PlanIndex.fakeLookupInstalledPackageId fakeMap index) (CD.nonSetupDeps (depends pkg))
+ , Just pkg' <- map (PlanIndex.fakeLookupInstalledPackageId fakeMap index)
+ (CD.nonSetupDeps (depends pkg))
, not (stateDependencyRelation pkg pkg') ]
-- | The graph of packages (nodes) and dependencies (edges) must be acyclic.
@@ -505,7 +524,9 @@ problems platform cinfo fakeMap indepGoals index =
-- * if the result is @False@ use 'PackageIndex.dependencyCycles' to find out
-- which packages are involved in dependency cycles.
--
-acyclic :: FakeMap -> PlanIndex -> Bool
+acyclic :: (HasInstalledPackageId ipkg, PackageFixedDeps ipkg,
+ HasInstalledPackageId srcpkg, PackageFixedDeps srcpkg)
+ => FakeMap -> PlanIndex ipkg srcpkg iresult ifailure -> Bool
acyclic fakeMap = null . PlanIndex.dependencyCycles fakeMap
-- | An installation plan is closed if for every package in the set, all of
@@ -515,7 +536,9 @@ acyclic fakeMap = null . PlanIndex.dependencyCycles fakeMap
-- * if the result is @False@ use 'PackageIndex.brokenPackages' to find out
-- which packages depend on packages not in the index.
--
-closed :: FakeMap -> PlanIndex -> Bool
+closed :: (HasInstalledPackageId ipkg, PackageFixedDeps ipkg,
+ PackageFixedDeps srcpkg)
+ => FakeMap -> PlanIndex ipkg srcpkg iresult ifailure -> Bool
closed fakeMap = null . PlanIndex.brokenPackages fakeMap
-- | An installation plan is consistent if all dependencies that target a
@@ -534,148 +557,54 @@ closed fakeMap = null . PlanIndex.brokenPackages fakeMap
-- * if the result is @False@ use 'PackageIndex.dependencyInconsistencies' to
-- find out which packages are.
--
-consistent :: FakeMap -> PlanIndex -> Bool
+consistent :: (HasInstalledPackageId ipkg, PackageFixedDeps ipkg,
+ HasInstalledPackageId srcpkg, PackageFixedDeps srcpkg)
+ => FakeMap -> PlanIndex ipkg srcpkg iresult ifailure -> Bool
consistent fakeMap = null . PlanIndex.dependencyInconsistencies fakeMap False
-- | The states of packages have that depend on each other must respect
-- this relation. That is for very case where package @a@ depends on
-- package @b@ we require that @dependencyStatesOk a b = True@.
--
-stateDependencyRelation :: PlanPackage -> PlanPackage -> Bool
-stateDependencyRelation (PreExisting _) (PreExisting _) = True
+stateDependencyRelation :: GenericPlanPackage ipkg srcpkg iresult ifailure
+ -> GenericPlanPackage ipkg srcpkg iresult ifailure
+ -> Bool
+stateDependencyRelation (PreExisting _) (PreExisting _) = True
-stateDependencyRelation (Configured _) (PreExisting _) = True
-stateDependencyRelation (Configured _) (Configured _) = True
-stateDependencyRelation (Configured _) (Processing _) = True
-stateDependencyRelation (Configured _) (Installed _ _) = True
+stateDependencyRelation (Configured _) (PreExisting _) = True
+stateDependencyRelation (Configured _) (Configured _) = True
+stateDependencyRelation (Configured _) (Processing _) = True
+stateDependencyRelation (Configured _) (Installed _ _ _) = True
-stateDependencyRelation (Processing _) (PreExisting _) = True
-stateDependencyRelation (Processing _) (Installed _ _) = True
+stateDependencyRelation (Processing _) (PreExisting _) = True
+stateDependencyRelation (Processing _) (Installed _ _ _) = True
-stateDependencyRelation (Installed _ _) (PreExisting _) = True
-stateDependencyRelation (Installed _ _) (Installed _ _) = True
+stateDependencyRelation (Installed _ _ _) (PreExisting _) = True
+stateDependencyRelation (Installed _ _ _) (Installed _ _ _) = True
-stateDependencyRelation (Failed _ _) (PreExisting _) = True
+stateDependencyRelation (Failed _ _) (PreExisting _) = True
-- failed can depends on configured because a package can depend on
-- several other packages and if one of the deps fail then we fail
-- but we still depend on the other ones that did not fail:
-stateDependencyRelation (Failed _ _) (Configured _) = True
-stateDependencyRelation (Failed _ _) (Processing _) = True
-stateDependencyRelation (Failed _ _) (Installed _ _) = True
-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"
+stateDependencyRelation (Failed _ _) (Configured _) = True
+stateDependencyRelation (Failed _ _) (Processing _) = True
+stateDependencyRelation (Failed _ _) (Installed _ _ _) = True
+stateDependencyRelation (Failed _ _) (Failed _ _) = True
+
+stateDependencyRelation _ _ = False
+
-- | Compute the dependency closure of a _source_ package in a install plan
--
--- See `Distribution.Simple.dependencyClosure`
-dependencyClosure :: InstallPlan
+-- See `Distribution.Client.PlanIndex.dependencyClosure`
+dependencyClosure :: (HasInstalledPackageId ipkg, PackageFixedDeps ipkg,
+ HasInstalledPackageId srcpkg, PackageFixedDeps srcpkg)
+ => GenericInstallPlan ipkg srcpkg iresult ifailure
-> [PackageIdentifier]
- -> Either (PackageIndex PlanPackage) [(PlanPackage, [InstalledPackageId])]
+ -> Either [(GenericPlanPackage ipkg srcpkg iresult ifailure,
+ [InstalledPackageId])]
+ (PackageIndex
+ (GenericPlanPackage ipkg srcpkg iresult ifailure))
dependencyClosure installPlan pids =
PlanIndex.dependencyClosure
(planFakeMap installPlan)
diff --git a/cabal-install/Distribution/Client/InstallSymlink.hs b/cabal-install/Distribution/Client/InstallSymlink.hs
index 6a171986ea786bd3cc8a90eb9fca44cd5b4433c4..4b9de74b5dfd6f39b98ebac5c33f9e22f6e68904 100644
--- a/cabal-install/Distribution/Client/InstallSymlink.hs
+++ b/cabal-install/Distribution/Client/InstallSymlink.hs
@@ -23,13 +23,16 @@ import Distribution.Client.InstallPlan (InstallPlan)
import Distribution.Client.Setup (InstallFlags)
import Distribution.Simple.Setup (ConfigFlags)
import Distribution.Simple.Compiler
+import Distribution.System
-symlinkBinaries :: Compiler
+symlinkBinaries :: Platform -> Compiler
-> ConfigFlags
-> InstallFlags
- -> InstallPlan
+ -> InstallPlan InstalledPackageInfo
+ ConfiguredPackage
+ iresult ifailure
-> IO [(PackageIdentifier, String, FilePath)]
-symlinkBinaries _ _ _ _ = return []
+symlinkBinaries _ _ _ _ _ = return []
symlinkBinary :: FilePath -> FilePath -> String -> String -> IO Bool
symlinkBinary _ _ _ _ = fail "Symlinking feature not available on Windows"
@@ -37,7 +40,9 @@ symlinkBinary _ _ _ _ = fail "Symlinking feature not available on Windows"
#else
import Distribution.Client.Types
- ( SourcePackage(..), ReadyPackage(..), enableStanzas )
+ ( SourcePackage(..)
+ , GenericReadyPackage(..), ReadyPackage, enableStanzas
+ , ConfiguredPackage(..) )
import Distribution.Client.Setup
( InstallFlags(installSymlinkBinDir) )
import qualified Distribution.Client.InstallPlan as InstallPlan
@@ -59,7 +64,9 @@ import Distribution.Simple.Setup
import qualified Distribution.Simple.InstallDirs as InstallDirs
import qualified Distribution.InstalledPackageInfo as Installed
import Distribution.Simple.Compiler
- ( Compiler, CompilerInfo(..), packageKeySupported )
+ ( Compiler, compilerInfo, CompilerInfo(..), packageKeySupported )
+import Distribution.System
+ ( Platform )
import System.Posix.Files
( getSymbolicLinkStatus, isSymbolicLink, createSymbolicLink
@@ -98,12 +105,12 @@ import Data.Maybe
-- controlled from the config file. Of course it only works on POSIX systems
-- with symlinks so is not available to Windows users.
--
-symlinkBinaries :: Compiler
+symlinkBinaries :: Platform -> Compiler
-> ConfigFlags
-> InstallFlags
-> InstallPlan
-> IO [(PackageIdentifier, String, FilePath)]
-symlinkBinaries comp configFlags installFlags plan =
+symlinkBinaries platform comp configFlags installFlags plan =
case flagToMaybe (installSymlinkBinDir installFlags) of
Nothing -> return []
Just symlinkBinDir
@@ -121,10 +128,11 @@ symlinkBinaries comp configFlags installFlags plan =
then return Nothing
else return (Just (pkgid, publicExeName,
privateBinDir </> privateExeName))
- | (ReadyPackage _ _flags _ deps, pkg, exe) <- exes
+ | (ReadyPackage (ConfiguredPackage _ _flags _ _) deps, pkg, exe) <- exes
, let pkgid = packageId pkg
pkg_key = mkPackageKey (packageKeySupported comp) pkgid
- (map Installed.libraryName (CD.nonSetupDeps deps))
+ (map Installed.libraryName
+ (CD.nonSetupDeps deps))
libname = packageKeyLibraryName pkgid pkg_key
publicExeName = PackageDescription.exeName exe
privateExeName = prefix ++ publicExeName ++ suffix
@@ -133,13 +141,16 @@ symlinkBinaries comp configFlags installFlags plan =
where
exes =
[ (cpkg, pkg, exe)
- | InstallPlan.Installed cpkg _ <- InstallPlan.toList plan
+ | InstallPlan.Installed cpkg _ _ <- InstallPlan.toList plan
, let pkg = pkgDescription cpkg
, exe <- PackageDescription.executables pkg
, PackageDescription.buildable (PackageDescription.buildInfo exe) ]
pkgDescription :: ReadyPackage -> PackageDescription
- pkgDescription (ReadyPackage (SourcePackage _ pkg _ _) flags stanzas _) =
+ pkgDescription (ReadyPackage (ConfiguredPackage
+ (SourcePackage _ pkg _ _)
+ flags stanzas _)
+ _) =
case finalizePackageDescription flags
(const True)
platform cinfo [] (enableStanzas stanzas pkg) of
@@ -170,8 +181,7 @@ symlinkBinaries comp configFlags installFlags plan =
fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "")
prefixTemplate = fromFlagTemplate (configProgPrefix configFlags)
suffixTemplate = fromFlagTemplate (configProgSuffix configFlags)
- platform = InstallPlan.planPlatform plan
- cinfo = InstallPlan.planCompiler plan
+ cinfo = compilerInfo comp
(CompilerId compilerFlavor _) = compilerInfoId cinfo
symlinkBinary :: FilePath -- ^ The canonical path of the public bin dir
diff --git a/cabal-install/Distribution/Client/List.hs b/cabal-install/Distribution/Client/List.hs
index 3ce3dd253335c1d7fd89bce666fb68b60a0eba6b..e94e59cceff94da532bed4194020adedd4aff19d 100644
--- a/cabal-install/Distribution/Client/List.hs
+++ b/cabal-install/Distribution/Client/List.hs
@@ -15,7 +15,8 @@ module Distribution.Client.List (
import Distribution.Package
( PackageName(..), Package(..), packageName, packageVersion
- , Dependency(..), simplifyDependency )
+ , Dependency(..), simplifyDependency
+ , InstalledPackageId )
import Distribution.ModuleName (ModuleName)
import Distribution.License (License)
import qualified Distribution.InstalledPackageInfo as Installed
@@ -44,7 +45,7 @@ import Distribution.Text
import Distribution.Client.Types
( SourcePackage(..), Repo, SourcePackageDb(..) )
import Distribution.Client.Dependency.Types
- ( PackageConstraint(..), ExtDependency(..) )
+ ( PackageConstraint(..) )
import Distribution.Client.Targets
( UserTarget, resolveUserTargets, PackageSpecifier(..) )
import Distribution.Client.Setup
@@ -190,7 +191,7 @@ info verbosity packageDBs repos comp conf
++ map packageId
(PackageIndex.allPackages sourcePkgIndex)
transport <- configureTransport verbosity (flagToMaybe (globalHttpTransport globalFlags))
- pkgSpecifiers <- resolveUserTargets transport verbosity
+ pkgSpecifiers <- resolveUserTargets verbosity transport
(fromFlag $ globalWorldFile globalFlags)
sourcePkgs' userTargets
@@ -292,6 +293,11 @@ data PackageDisplayInfo = PackageDisplayInfo {
haveTarball :: Bool
}
+-- | Covers source dependencies and installed dependencies in
+-- one type.
+data ExtDependency = SourceDependency Dependency
+ | InstalledDependency InstalledPackageId
+
showPackageSummaryInfo :: PackageDisplayInfo -> String
showPackageSummaryInfo pkginfo =
renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $
@@ -344,7 +350,7 @@ showPackageDetailedInfo pkginfo =
, entry "Source repo" sourceRepo orNotSpecified text
, entry "Executables" executables hideIfNull (commaSep text)
, entry "Flags" flags hideIfNull (commaSep dispFlag)
- , entry "Dependencies" dependencies hideIfNull (commaSep disp)
+ , entry "Dependencies" dependencies hideIfNull (commaSep dispExtDep)
, entry "Documentation" haddockHtml showIfInstalled text
, entry "Cached" haveTarball alwaysShow dispYesNo
, if not (hasLib pkginfo) then empty else
@@ -378,6 +384,9 @@ showPackageDetailedInfo pkginfo =
dispYesNo True = text "Yes"
dispYesNo False = text "No"
+ dispExtDep (SourceDependency dep) = disp dep
+ dispExtDep (InstalledDependency dep) = disp dep
+
isInstalled = not (null (installedVersions pkginfo))
hasExes = length (executables pkginfo) >= 2
--TODO: exclude non-buildable exes
diff --git a/cabal-install/Distribution/Client/PackageIndex.hs b/cabal-install/Distribution/Client/PackageIndex.hs
index c975177d613aa1e3ebe206dc0376092e78102628..0efb485c7856025fa78833aba5a9d575633a165b 100644
--- a/cabal-install/Distribution/Client/PackageIndex.hs
+++ b/cabal-install/Distribution/Client/PackageIndex.hs
@@ -16,9 +16,6 @@ module Distribution.Client.PackageIndex (
-- * Package index data type
PackageIndex,
- -- * Fine-grained package dependencies
- PackageFixedDeps(..),
-
-- * Creating an index
fromList,
@@ -61,30 +58,12 @@ import Data.Maybe (isJust, fromMaybe)
import Distribution.Package
( PackageName(..), PackageIdentifier(..)
, Package(..), packageName, packageVersion
- , Dependency(Dependency)
- , InstalledPackageId, installedDepends )
+ , Dependency(Dependency) )
import Distribution.Version
( withinRange )
-import Distribution.InstalledPackageInfo
- ( InstalledPackageInfo_ )
import Distribution.Simple.Utils
( lowercase, comparing )
-import Distribution.Client.ComponentDeps (ComponentDeps)
-import qualified Distribution.Client.ComponentDeps as CD
-
--- | Subclass of packages that have specific versioned dependencies.
---
--- So for example a not-yet-configured package has dependencies on version
--- ranges, not specific versions. A configured or an already installed package
--- depends on exact versions. Some operations or data structures (like
--- dependency graphs) only make sense on this subclass of package types.
---
-class Package pkg => PackageFixedDeps pkg where
- depends :: pkg -> ComponentDeps [InstalledPackageId]
-
-instance PackageFixedDeps (InstalledPackageInfo_ str) where
- depends = CD.fromInstalled . installedDepends
-- | The collection of information about packages from one or more 'PackageDB's.
--
diff --git a/cabal-install/Distribution/Client/PlanIndex.hs b/cabal-install/Distribution/Client/PlanIndex.hs
index 67c2801c0dcc88f783049ba6c7216c1165a71f58..5e837c6eedb3b9b659b2a7831a29a2789eabc988 100644
--- a/cabal-install/Distribution/Client/PlanIndex.hs
+++ b/cabal-install/Distribution/Client/PlanIndex.hs
@@ -27,7 +27,7 @@ import qualified Data.Graph as Graph
import Data.Array ((!))
import Data.Map (Map)
import Data.Maybe (isNothing, fromMaybe, fromJust)
-import Data.Either (lefts)
+import Data.Either (rights)
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid (Monoid(..))
@@ -42,7 +42,7 @@ import Distribution.Version
import Distribution.Client.ComponentDeps (ComponentDeps)
import qualified Distribution.Client.ComponentDeps as CD
-import Distribution.Client.PackageIndex
+import Distribution.Client.Types
( PackageFixedDeps(..) )
import Distribution.Simple.PackageIndex
( PackageIndex, allPackages, insert, lookupInstalledPackageId )
@@ -131,7 +131,7 @@ dependencyInconsistencies fakeMap indepGoals index =
concatMap (dependencyInconsistencies' fakeMap) subplans
where
subplans :: [PackageIndex pkg]
- subplans = lefts $
+ subplans = rights $
map (dependencyClosure fakeMap index)
(rootSets fakeMap indepGoals index)
@@ -253,11 +253,11 @@ dependencyClosure :: (PackageFixedDeps pkg, HasInstalledPackageId pkg)
=> FakeMap
-> PackageIndex pkg
-> [InstalledPackageId]
- -> Either (PackageIndex pkg)
- [(pkg, [InstalledPackageId])]
+ -> Either [(pkg, [InstalledPackageId])]
+ (PackageIndex pkg)
dependencyClosure fakeMap index pkgids0 = case closure mempty [] pkgids0 of
- (completed, []) -> Left completed
- (completed, _) -> Right (brokenPackages fakeMap completed)
+ (completed, []) -> Right completed
+ (completed, _) -> Left (brokenPackages fakeMap completed)
where
closure completed failed [] = (completed, failed)
closure completed failed (pkgid:pkgids) =
diff --git a/cabal-install/Distribution/Client/Targets.hs b/cabal-install/Distribution/Client/Targets.hs
index dbc5731198d98bb3bd454915ea603a56fdb437e7..25b3ec2f61d42fcb41645194b2745fcfbb727679 100644
--- a/cabal-install/Distribution/Client/Targets.hs
+++ b/cabal-install/Distribution/Client/Targets.hs
@@ -351,13 +351,13 @@ reportUserTargetProblems problems = do
-- or they can be named packages (with or without version info).
--
resolveUserTargets :: Package pkg
- => HttpTransport
- -> Verbosity
+ => Verbosity
+ -> HttpTransport
-> FilePath
-> PackageIndex pkg
-> [UserTarget]
-> IO [PackageSpecifier SourcePackage]
-resolveUserTargets transport verbosity worldFile available userTargets = do
+resolveUserTargets verbosity transport worldFile available userTargets = do
-- given the user targets, get a list of fully or partially resolved
-- package references
diff --git a/cabal-install/Distribution/Client/Types.hs b/cabal-install/Distribution/Client/Types.hs
index 129f65b489d7cca51249169b2e075f93ada8b122..a5991d88e23115a015cea41847b650208f988dc0 100644
--- a/cabal-install/Distribution/Client/Types.hs
+++ b/cabal-install/Distribution/Client/Types.hs
@@ -20,14 +20,14 @@ import Distribution.Package
, HasInstalledPackageId(..), PackageInstalled(..)
, LibraryName, packageKeyLibraryName )
import Distribution.InstalledPackageInfo
- ( InstalledPackageInfo )
+ ( InstalledPackageInfo, InstalledPackageInfo_ )
import Distribution.PackageDescription
( Benchmark(..), GenericPackageDescription(..), FlagAssignment
, TestSuite(..) )
import Distribution.PackageDescription.Configuration
( mapTreeData )
import Distribution.Client.PackageIndex
- ( PackageIndex, PackageFixedDeps(..) )
+ ( PackageIndex )
import Distribution.Client.ComponentDeps
( ComponentDeps )
import qualified Distribution.Client.ComponentDeps as CD
@@ -58,20 +58,18 @@ data SourcePackageDb = SourcePackageDb {
-- * Various kinds of information about packages
-- ------------------------------------------------------------
--- | InstalledPackage caches its dependencies as source package IDs.
--- This is for the benefit of the top-down solver only.
-data InstalledPackage = InstalledPackage
- InstalledPackageInfo
- [PackageId]
+-- | Subclass of packages that have specific versioned dependencies.
+--
+-- So for example a not-yet-configured package has dependencies on version
+-- ranges, not specific versions. A configured or an already installed package
+-- depends on exact versions. Some operations or data structures (like
+-- dependency graphs) only make sense on this subclass of package types.
+--
+class Package pkg => PackageFixedDeps pkg where
+ depends :: pkg -> ComponentDeps [InstalledPackageId]
-instance Package InstalledPackage where
- packageId (InstalledPackage pkg _) = packageId pkg
-instance PackageFixedDeps InstalledPackage where
- depends (InstalledPackage pkg _) = depends pkg
-instance HasInstalledPackageId InstalledPackage where
- installedPackageId (InstalledPackage pkg _) = installedPackageId pkg
-instance PackageInstalled InstalledPackage where
- installedDepends (InstalledPackage pkg _) = installedDepends pkg
+instance PackageFixedDeps (InstalledPackageInfo_ str) where
+ depends = CD.fromInstalled . installedDepends
-- | In order to reuse the implementation of PackageIndex which relies on
@@ -133,51 +131,40 @@ instance HasInstalledPackageId ConfiguredPackage where
-- | Like 'ConfiguredPackage', but with all dependencies guaranteed to be
-- installed already, hence itself ready to be installed.
-data ReadyPackage = ReadyPackage
- SourcePackage -- see 'ConfiguredPackage'.
- FlagAssignment --
- [OptionalStanza] --
- (ComponentDeps [InstalledPackageInfo]) -- Installed dependencies.
- deriving Show
+data GenericReadyPackage srcpkg ipkg
+ = ReadyPackage
+ srcpkg -- see 'ConfiguredPackage'.
+ (ComponentDeps [ipkg]) -- Installed dependencies.
+ deriving (Eq, Show)
-instance Package ReadyPackage where
- packageId (ReadyPackage pkg _ _ _) = packageId pkg
+type ReadyPackage = GenericReadyPackage ConfiguredPackage InstalledPackageInfo
-instance PackageFixedDeps ReadyPackage where
- depends (ReadyPackage _ _ _ deps) = fmap (map installedPackageId) deps
+instance Package srcpkg => Package (GenericReadyPackage srcpkg ipkg) where
+ packageId (ReadyPackage srcpkg _deps) = packageId srcpkg
-instance HasInstalledPackageId ReadyPackage where
- installedPackageId = fakeInstalledPackageId . packageId
+instance (Package srcpkg, HasInstalledPackageId ipkg) =>
+ PackageFixedDeps (GenericReadyPackage srcpkg ipkg) where
+ depends (ReadyPackage _ deps) = fmap (map installedPackageId) deps
+
+instance HasInstalledPackageId srcpkg =>
+ HasInstalledPackageId (GenericReadyPackage srcpkg ipkg) where
+ installedPackageId (ReadyPackage pkg _) = installedPackageId pkg
-- | Extracts a package key from ReadyPackage, a common operation needed
-- to calculate build paths.
readyPackageKey :: Compiler -> ReadyPackage -> PackageKey
-readyPackageKey comp (ReadyPackage pkg _ _ deps) =
+readyPackageKey comp (ReadyPackage pkg deps) =
mkPackageKey (packageKeySupported comp) (packageId pkg)
(map Info.libraryName (CD.nonSetupDeps deps))
-- | Extracts a library name from ReadyPackage, a common operation needed
-- to calculate build paths.
readyLibraryName :: Compiler -> ReadyPackage -> LibraryName
-readyLibraryName comp ready@(ReadyPackage pkg _ _ _) =
+readyLibraryName comp ready@(ReadyPackage pkg _) =
packageKeyLibraryName (packageId pkg) (readyPackageKey comp ready)
--- | Sometimes we need to convert a 'ReadyPackage' back to a
--- 'ConfiguredPackage'. For example, a failed 'PlanPackage' can be *either*
--- Ready or Configured.
-readyPackageToConfiguredPackage :: ReadyPackage -> ConfiguredPackage
-readyPackageToConfiguredPackage (ReadyPackage srcpkg flags stanzas deps) =
- ConfiguredPackage srcpkg flags stanzas (fmap (map aux) deps)
- where
- aux :: InstalledPackageInfo -> ConfiguredId
- aux info = ConfiguredId {
- confSrcId = Info.sourcePackageId info
- , confInstId = installedPackageId info
- }
-
-
-- | A package description along with the location of the package sources.
--
data SourcePackage = SourcePackage {
diff --git a/cabal-install/Distribution/Client/Utils/LabeledGraph.hs b/cabal-install/Distribution/Client/Utils/LabeledGraph.hs
index 567f15609acc445dd9edb59760b90647df979e31..1c42a1d51b7db3c8ce40f1ee341201264c839893 100644
--- a/cabal-install/Distribution/Client/Utils/LabeledGraph.hs
+++ b/cabal-install/Distribution/Client/Utils/LabeledGraph.hs
@@ -51,8 +51,10 @@ graphFromEdges edges0 =
sorted_edges = sortBy lt edges0
edges1 = zipWith (,) [0..] sorted_edges
- graph = array bounds0 [(v, (mapMaybe mk_edge ks)) | (v, (_, _, ks)) <- edges1]
- key_map = array bounds0 [(v, k ) | (v, (_, k, _ )) <- edges1]
+ graph = array bounds0 [(v, (mapMaybe mk_edge ks))
+ | (v, (_, _, ks)) <- edges1]
+ key_map = array bounds0 [(v, k )
+ | (v, (_, k, _ )) <- edges1]
vertex_map = array bounds0 edges1
(_,k1,_) `lt` (_,k2,_) = k1 `compare` k2
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 e5e3dd6e5825adc7446b29e6c88fed5413933cc7..b5e67bb28a5f10a1564e3e0a846860bbafe98fb4 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/DSL.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/DSL.hs
@@ -20,7 +20,8 @@ import qualified Data.Map as Map
-- Cabal
import qualified Distribution.Compiler as C
import qualified Distribution.InstalledPackageInfo as C
-import qualified Distribution.Package as C hiding (HasInstalledPackageId(..))
+import qualified Distribution.Package as C
+ hiding (HasInstalledPackageId(..))
import qualified Distribution.PackageDescription as C
import qualified Distribution.Simple.PackageIndex as C.PackageIndex
import qualified Distribution.System as C
@@ -102,8 +103,10 @@ data ExampleAvailable = ExAv {
, exAvDeps :: ComponentDeps [ExampleDependency]
}
-exAv :: ExamplePkgName -> ExamplePkgVersion -> [ExampleDependency] -> ExampleAvailable
-exAv n v ds = ExAv { exAvName = n, exAvVersion = v, exAvDeps = CD.fromLibraryDeps ds }
+exAv :: ExamplePkgName -> ExamplePkgVersion -> [ExampleDependency]
+ -> ExampleAvailable
+exAv n v ds = ExAv { exAvName = n, exAvVersion = v
+ , exAvDeps = CD.fromLibraryDeps ds }
withSetupDeps :: ExampleAvailable -> [ExampleDependency] -> ExampleAvailable
withSetupDeps ex setupDeps = ex {
@@ -117,7 +120,8 @@ data ExampleInstalled = ExInst {
, exInstBuildAgainst :: [ExampleInstalled]
}
-exInst :: ExamplePkgName -> ExamplePkgVersion -> ExamplePkgHash -> [ExampleInstalled] -> ExampleInstalled
+exInst :: ExamplePkgName -> ExamplePkgVersion -> ExamplePkgHash
+ -> [ExampleInstalled] -> ExampleInstalled
exInst = ExInst
type ExampleDb = [Either ExampleInstalled ExampleAvailable]
@@ -146,10 +150,12 @@ exAvSrcPkg ex =
C.setupDepends = mkSetupDeps (CD.setupDeps (exAvDeps ex))
}
}
- , C.genPackageFlags = concatMap extractFlags (CD.libraryDeps (exAvDeps ex))
+ , C.genPackageFlags = concatMap extractFlags
+ (CD.libraryDeps (exAvDeps ex))
, C.condLibrary = Just $ mkCondTree libraryDeps
, C.condExecutables = []
- , C.condTestSuites = map (\(t, deps) -> (t, mkCondTree deps)) testSuites
+ , C.condTestSuites = map (\(t, deps) -> (t, mkCondTree deps))
+ testSuites
, C.condBenchmarks = []
}
}
@@ -159,10 +165,12 @@ exAvSrcPkg ex =
, [(ExampleTestName, [ExampleDependency])]
)
splitTopLevel [] = ([], [])
- splitTopLevel (ExTest t a:deps) = let (other, testSuites) = splitTopLevel deps
- in (other, (t, a):testSuites)
- splitTopLevel (dep:deps) = let (other, testSuites) = splitTopLevel deps
- in (dep:other, testSuites)
+ splitTopLevel (ExTest t a:deps) =
+ let (other, testSuites) = splitTopLevel deps
+ in (other, (t, a):testSuites)
+ splitTopLevel (dep:deps) =
+ let (other, testSuites) = splitTopLevel deps
+ in (dep:other, testSuites)
extractFlags :: ExampleDependency -> [C.Flag]
extractFlags (ExAny _) = []
@@ -193,7 +201,8 @@ exAvSrcPkg ex =
mkFlagged :: Monoid a
=> (ExampleFlagName, [ExampleDependency], [ExampleDependency])
- -> (C.Condition C.ConfVar, DependencyTree a, Maybe (DependencyTree a))
+ -> (C.Condition C.ConfVar
+ , DependencyTree a, Maybe (DependencyTree a))
mkFlagged (f, a, b) = ( C.Var (C.Flag (C.FlagName f))
, mkCondTree a
, Just (mkCondTree b)
@@ -274,7 +283,8 @@ exResolve db targets indepGoals = runProgress $
packageIndex = exAvIdx avai
, packagePreferences = Map.empty
}
- enableTests = map (\p -> PackageConstraintStanzas (C.PackageName p) [TestStanzas])
+ enableTests = map (\p -> PackageConstraintStanzas
+ (C.PackageName p) [TestStanzas])
(exDbPkgs db)
targets' = map (\p -> NamedPackage (C.PackageName p) []) targets
params = addConstraints enableTests
@@ -292,7 +302,8 @@ extractInstallPlan = catMaybes . map confPkg . CI.InstallPlan.toList
srcPkg :: ConfiguredPackage -> (String, Int)
srcPkg (ConfiguredPackage pkg _flags _stanzas _deps) =
- let C.PackageIdentifier (C.PackageName p) (Version (n:_) _) = packageInfoId pkg
+ let C.PackageIdentifier (C.PackageName p) (Version (n:_) _) =
+ packageInfoId pkg
in (p, n)
{-------------------------------------------------------------------------------