Repository : ssh://darcs.haskell.org//srv/darcs/packages/Cabal On branch : master
http://hackage.haskell.org/trac/ghc/changeset/54d12234eba5b2d59db01acb088211c6df7a72f1 >--------------------------------------------------------------- commit 54d12234eba5b2d59db01acb088211c6df7a72f1 Author: Duncan Coutts <[email protected]> Date: Mon May 17 11:13:36 2010 +0000 In fetch code, move dep resolution into separate function >--------------------------------------------------------------- cabal-install/Distribution/Client/Fetch.hs | 106 ++++++++++++++++++---------- 1 files changed, 68 insertions(+), 38 deletions(-) diff --git a/cabal-install/Distribution/Client/Fetch.hs b/cabal-install/Distribution/Client/Fetch.hs index 6a66f64..d297b1e 100644 --- a/cabal-install/Distribution/Client/Fetch.hs +++ b/cabal-install/Distribution/Client/Fetch.hs @@ -24,8 +24,10 @@ module Distribution.Client.Fetch ( import Distribution.Client.Types ( UnresolvedDependency (..), AvailablePackage(..) , AvailablePackageSource(..), AvailablePackageDb(..) - , Repo(..), RemoteRepo(..), LocalRepo(..) ) -import Distribution.Client.Dependency + , Repo(..), RemoteRepo(..), LocalRepo(..) + , InstalledPackage ) +import Distribution.Client.PackageIndex (PackageIndex) +import Distribution.Client.Dependency as Dependency ( resolveDependenciesWithProgress , dependencyConstraints, dependencyTargets , PackagesPreference(..), PackagesPreferenceDefault(..) @@ -120,46 +122,74 @@ fetch :: Verbosity -> ProgramConfiguration -> [UnresolvedDependency] -> IO () +fetch verbosity _ _ _ _ [] = + notice verbosity "No packages requested. Nothing to do." + fetch verbosity packageDBs repos comp conf deps = do - installed <- getInstalledPackages verbosity comp packageDBs conf - AvailablePackageDb available availablePrefs - <- getAvailablePackages verbosity repos + + availableDb@(AvailablePackageDb available _) + <- getAvailablePackages verbosity repos deps' <- IndexUtils.disambiguateDependencies available deps - let -- Hide the packages given on the command line so that the dep resolver - -- will decide that they need fetching, even if they're already - -- installed. Sicne we want to get the source packages of things we might - -- have installed (but not have the sources for). - installed' = hideGivenDeps deps' installed - hideGivenDeps pkgs index = - foldr PackageIndex.deletePackageName index - [ name | UnresolvedDependency (Dependency name _) _ <- pkgs ] - - let progress = resolveDependenciesWithProgress - buildPlatform (compilerId comp) - installed' available - (PackagesPreference PreferLatestForSelected - [ PackageVersionPreference name ver - | (name, ver) <- Map.toList availablePrefs ]) - (dependencyConstraints deps') - (dependencyTargets deps') + pkgs <- do + installed <- getInstalledPackages verbosity comp packageDBs conf + resolveWithDependencies verbosity comp installed availableDb deps' + + pkgs' <- filterM (fmap not . isFetched) pkgs + when (null pkgs') $ + notice verbosity $ "No packages need to be fetched. " + ++ "All the requested packages are already cached." + sequence_ + [ fetchPackage verbosity repo pkgid + | (AvailablePackage pkgid _ (RepoTarballPackage repo)) <- pkgs' ] + + +resolveWithDependencies :: Verbosity + -> Compiler + -> PackageIndex InstalledPackage + -> AvailablePackageDb + -> [UnresolvedDependency] + -> IO [AvailablePackage] +resolveWithDependencies verbosity comp + installed (AvailablePackageDb available availablePrefs) deps = do + notice verbosity "Resolving dependencies..." - maybePlan <- foldProgress (\message rest -> info verbosity message >> rest) - (return . Left) (return . Right) progress - case maybePlan of - Left message -> die message - Right pkgs -> do - ps <- filterM (fmap not . isFetched) - [ pkg | (InstallPlan.Configured - (InstallPlan.ConfiguredPackage pkg _ _)) - <- InstallPlan.toList pkgs ] - when (null ps) $ - notice verbosity $ "No packages need to be fetched. " - ++ "All the requested packages are already cached." - - sequence_ - [ fetchPackage verbosity repo pkgid - | (AvailablePackage pkgid _ (RepoTarballPackage repo)) <- ps ] + plan <- foldProgress logMsg die return $ + resolveDependenciesWithProgress + buildPlatform (compilerId comp) + installed' available + preferences constraints + targets + + return (selectPackagesToFetch plan) + + where + targets = dependencyTargets deps + constraints = dependencyConstraints deps + preferences = PackagesPreference + PreferLatestForSelected + [ PackageVersionPreference name ver + | (name, ver) <- Map.toList availablePrefs ] + + installed' = hideGivenDeps deps installed + + -- Hide the packages given on the command line so that the dep resolver + -- will decide that they need fetching, even if they're already + -- installed. Sicne we want to get the source packages of things we might + -- have installed (but not have the sources for). + hideGivenDeps pkgs index = + foldr PackageIndex.deletePackageName index + [ name | UnresolvedDependency (Dependency name _) _ <- pkgs ] + + -- The packages we want to fetch are those packages the 'InstallPlan' that + -- are in the 'InstallPlan.Configured' state. + selectPackagesToFetch :: InstallPlan.InstallPlan -> [AvailablePackage] + selectPackagesToFetch plan = + [ pkg | (InstallPlan.Configured (InstallPlan.ConfiguredPackage pkg _ _)) + <- InstallPlan.toList plan ] + + logMsg message rest = info verbosity message >> rest + -- |Generate the full path to the locally cached copy of -- the tarball for a given @PackageIdentifer@. _______________________________________________ Cvs-libraries mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-libraries
