Repository : ssh://darcs.haskell.org//srv/darcs/packages/Cabal On branch : master
http://hackage.haskell.org/trac/ghc/changeset/b3247338ab98f5bed71b5fae997d107bf1dd3c9f >--------------------------------------------------------------- commit b3247338ab98f5bed71b5fae997d107bf1dd3c9f Author: Duncan Coutts <[email protected]> Date: Mon Jun 16 17:55:11 2008 +0000 Overhaul the bogus dependency resolver so it works again The bogusResolver is used for compilers like hugs and nhc98 where we do not know what packages are already installed. We do it by altering the descriptions of the packages we're going to install to remove all of their dependencies. Doing this gives us a valid install plan. We rely on hope to minimise the difference between this install plan and reality. >--------------------------------------------------------------- cabal-install/Hackage/Dependency/Bogus.hs | 84 ++++++++++++++++++++-------- 1 files changed, 60 insertions(+), 24 deletions(-) diff --git a/cabal-install/Hackage/Dependency/Bogus.hs b/cabal-install/Hackage/Dependency/Bogus.hs index af8bea8..e7a7f44 100644 --- a/cabal-install/Hackage/Dependency/Bogus.hs +++ b/cabal-install/Hackage/Dependency/Bogus.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- | --- Module : Hackage.Dependency +-- Module : Hackage.Dependency.Bogus -- Copyright : (c) David Himmelstrup 2005, Bjorn Bringert 2007 -- Duncan Coutts 2008 -- License : BSD-like @@ -15,23 +15,30 @@ module Hackage.Dependency.Bogus ( bogusResolver ) where -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.PackageIndex (PackageIndex) -import qualified Hackage.InstallPlan as InstallPlan import Hackage.Types ( UnresolvedDependency(..), AvailablePackage(..) , ConfiguredPackage(..) ) import Hackage.Dependency.Types ( DependencyResolver, Progress(..) ) +import qualified Hackage.InstallPlan as InstallPlan + import Distribution.Package ( PackageIdentifier(..), Dependency(..), Package(..) ) +import Distribution.PackageDescription + ( GenericPackageDescription(..), CondTree(..), FlagAssignment ) import Distribution.PackageDescription.Configuration - ( finalizePackageDescription) -import Distribution.Simple.Utils (comparing) -import Hackage.Utils - ( showDependencies ) + ( finalizePackageDescription ) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PackageIndex (PackageIndex) +import Distribution.Version + ( VersionRange(IntersectVersionRanges) ) +import Distribution.Simple.Utils + ( equating, comparing ) +import Distribution.Text + ( display ) -import Data.List (maximumBy) +import Data.List + ( maximumBy, sortBy, groupBy ) -- | This resolver thinks that every package is already installed. -- @@ -39,26 +46,59 @@ import Data.List (maximumBy) -- We just pretend that everything is installed and hope for the best. -- bogusResolver :: DependencyResolver a -bogusResolver os arch comp _ available _ deps = - case unzipEithers (map resolveFromAvailable deps) of - (ok, []) -> Done ok - (_ , missing) -> Fail $ "Unresolved dependencies: " - ++ showDependencies missing +bogusResolver os arch comp _ available _ = resolveFromAvailable [] + . combineDependencies where - resolveFromAvailable (UnresolvedDependency dep flags) = + resolveFromAvailable chosen [] = Done chosen + resolveFromAvailable chosen (UnresolvedDependency dep flags : deps) = case latestAvailableSatisfying available dep of - Nothing -> Right dep + Nothing -> Fail ("Unresolved dependency: " ++ display dep) Just apkg@(AvailablePackage _ pkg _) -> case finalizePackageDescription flags none os arch comp [] pkg of - Right (_, flags') -> Left $ InstallPlan.Configured $ - ConfiguredPackage apkg flags' [] - --TODO: we have to add PreExisting deps of pkg, otherwise - -- the install plan verifier will say we're missing deps. + Right (_, flags') -> Step msg (resolveFromAvailable chosen' deps) + where + msg = "selecting " ++ display (packageId pkg) + cpkg = fudgeChosenPackage apkg flags' + chosen' = InstallPlan.Configured cpkg : chosen _ -> error "bogusResolver: impossible happened" where none :: Maybe (PackageIndex PackageIdentifier) none = Nothing +fudgeChosenPackage :: AvailablePackage -> FlagAssignment -> ConfiguredPackage +fudgeChosenPackage (AvailablePackage pkgid pkg source) flags = + ConfiguredPackage (AvailablePackage pkgid (stripDependencies pkg) source) + flags ([] :: [PackageIdentifier]) -- empty list of deps + where + -- | Pretend that a package has no dependencies. Go through the + -- 'GenericPackageDescription' and strip them all out. + -- + stripDependencies :: GenericPackageDescription -> GenericPackageDescription + stripDependencies gpkg = gpkg { + condLibrary = fmap stripDeps (condLibrary gpkg), + condExecutables = [ (name, stripDeps tree) + | (name, tree) <- condExecutables gpkg ] + } + stripDeps :: CondTree v [Dependency] a -> CondTree v [Dependency] a + stripDeps = mapTreeConstrs (const []) + + mapTreeConstrs :: (c -> c) -> CondTree v c a -> CondTree v c a + mapTreeConstrs f (CondNode a c ifs) = CondNode a (f c) (map g ifs) + where + g (cnd, t, me) = (cnd, mapTreeConstrs f t, fmap (mapTreeConstrs f) me) + +combineDependencies :: [UnresolvedDependency] -> [UnresolvedDependency] +combineDependencies = map combineGroup + . groupBy (equating depName) + . sortBy (comparing depName) + where + combineGroup deps = UnresolvedDependency (Dependency name ver) flags + where name = depName (head deps) + ver = foldr1 IntersectVersionRanges . map depVer $ deps + flags = concatMap depFlags deps + depName (UnresolvedDependency (Dependency name _) _) = name + depVer (UnresolvedDependency (Dependency _ ver) _) = ver + -- | Gets the latest available package satisfying a dependency. latestAvailableSatisfying :: PackageIndex AvailablePackage -> Dependency @@ -67,7 +107,3 @@ latestAvailableSatisfying index dep = case PackageIndex.lookupDependency index dep of [] -> Nothing pkgs -> Just (maximumBy (comparing (pkgVersion . packageId)) pkgs) - -unzipEithers :: [Either a b] -> ([a], [b]) -unzipEithers = foldr (flip consEither) ([], []) - where consEither ~(ls,rs) = either (\l -> (l:ls,rs)) (\r -> (ls,r:rs)) _______________________________________________ Cvs-libraries mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-libraries
