cabal-install-0.5.0: Hackage/Dependency/Naive.hs
-----------------------------------------------------------------------------
-- |
-- Module : Hackage.Dependency
-- Copyright : (c) David Himmelstrup 2005, Bjorn Bringert 2007,
-- Duncan Coutts 2008
-- License : BSD-like
--
-- Maintainer : cabal-devel@haskell.org
-- Stability : provisional
-- Portability : portable
--
-- A dependency resolver that is not very sophisticated.
-- It often makes installation plans with inconsistent dependencies.
-----------------------------------------------------------------------------
module Hackage.Dependency.Naive (
naiveResolver
) where
import Distribution.InstalledPackageInfo (InstalledPackageInfo_(package))
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.PackageIndex (PackageIndex)
import Distribution.InstalledPackageInfo (InstalledPackageInfo)
import qualified Hackage.InstallPlan as InstallPlan
import Hackage.Types
( UnresolvedDependency(..), AvailablePackage(..)
, ConfiguredPackage(..) )
import Hackage.Dependency.Types
( DependencyResolver, Progress(..) )
import Distribution.Package
( PackageIdentifier(..), Dependency(..), Package(..) )
import Distribution.PackageDescription
( PackageDescription(buildDepends), GenericPackageDescription
, FlagAssignment )
import Distribution.PackageDescription.Configuration
( finalizePackageDescription)
import Distribution.Compiler
( CompilerId )
import Distribution.System
( OS, Arch )
import Distribution.Simple.Utils (comparing, intercalate)
import Hackage.Utils
( showDependencies )
import Distribution.Text
( display )
import Control.Monad (mplus)
import Data.List (maximumBy)
import Data.Maybe (fromMaybe)
import Data.Monoid (Monoid(mappend))
naiveResolver :: DependencyResolver a
naiveResolver os arch comp installed available _ deps =
packagesToInstall installed
[ resolveDependency os arch comp installed available dep flags
| UnresolvedDependency dep flags <- deps]
resolveDependency :: OS
-> Arch
-> CompilerId
-> PackageIndex InstalledPackageInfo -- ^ Installed packages.
-> PackageIndex AvailablePackage -- ^ Installable packages
-> Dependency
-> FlagAssignment
-> ResolvedDependency
resolveDependency os arch comp installed available dep flags
= fromMaybe (UnavailableDependency dep) $ resolveFromInstalled `mplus` resolveFromAvailable
where
resolveFromInstalled = fmap (InstalledDependency dep) $ latestInstalledSatisfying installed dep
resolveFromAvailable =
do pkg <- latestAvailableSatisfying available dep
(deps, flags') <- getDependencies os arch comp installed available
(packageDescription pkg) flags
return $ AvailableDependency dep pkg flags'
[ resolveDependency os arch comp installed available dep' []
| dep' <- deps ]
-- | Gets the latest installed package satisfying a dependency.
latestInstalledSatisfying :: PackageIndex InstalledPackageInfo -> Dependency -> Maybe PackageIdentifier
latestInstalledSatisfying index dep =
case PackageIndex.lookupDependency index dep of
[] -> Nothing
pkgs -> Just (maximumBy (comparing pkgVersion) (map package pkgs))
-- | Gets the latest available package satisfying a dependency.
latestAvailableSatisfying :: PackageIndex AvailablePackage
-> Dependency
-> Maybe AvailablePackage
latestAvailableSatisfying index dep =
case PackageIndex.lookupDependency index dep of
[] -> Nothing
pkgs -> Just (maximumBy (comparing (pkgVersion . packageId)) pkgs)
-- | Gets the dependencies of an available package.
getDependencies :: OS
-> Arch
-> CompilerId
-> PackageIndex InstalledPackageInfo -- ^ Installed packages.
-> PackageIndex AvailablePackage -- ^ Available packages
-> GenericPackageDescription
-> FlagAssignment
-> Maybe ([Dependency], FlagAssignment)
-- ^ If successful, this is the list of dependencies.
-- If flag assignment failed, this is the list of
-- missing dependencies.
getDependencies os arch comp installed available pkg flags
= case e of
Left _missing -> Nothing
Right (desc,flags') -> Just (buildDepends desc, flags')
where
e = finalizePackageDescription
flags
(let --TODO: find a better way to do this:
flatten :: Package pkg => PackageIndex pkg
-> PackageIndex PackageIdentifier
flatten = PackageIndex.fromList . map packageId
. PackageIndex.allPackages
in Just (flatten available `mappend` flatten installed))
os arch comp [] pkg
packagesToInstall :: PackageIndex InstalledPackageInfo
-> [ResolvedDependency]
-> Progress String String [InstallPlan.PlanPackage a]
-- ^ Either a list of missing dependencies, or a graph
-- of packages to install, with their options.
packagesToInstall allInstalled deps0 =
case unzipEithers (map getAvailable deps0) of
([], ok) ->
let selectedAvailable :: [InstallPlan.ConfiguredPackage]
selectedAvailable = concatMap snd ok
selectedInstalled :: [InstalledPackageInfo]
selectedInstalled =
either PackageIndex.allPackages
(\borked -> error $ unlines
[ "Package " ++ display (packageId pkg)
++ " depends on the following packages which are missing from the plan "
++ intercalate ", " (map display missingDeps)
| (pkg, missingDeps) <- borked ])
$ PackageIndex.dependencyClosure
allInstalled
(getInstalled deps0)
in Done $ map InstallPlan.Configured selectedAvailable
++ map InstallPlan.PreExisting selectedInstalled
(missing, _) -> Fail $ "Unresolved dependencies: "
++ showDependencies (concat missing)
where
getAvailable :: ResolvedDependency
-> Either [Dependency]
(PackageIdentifier, [InstallPlan.ConfiguredPackage])
getAvailable (InstalledDependency _ pkgid )
= Right (pkgid, [])
getAvailable (AvailableDependency _ pkg flags deps) =
case unzipEithers (map getAvailable deps) of
([], ok) -> let resolved = InstallPlan.ConfiguredPackage pkg flags
[ pkgid | (pkgid, _) <- ok ]
: concatMap snd ok
in Right (packageId pkg, resolved)
(missing, _) -> Left (concat missing)
getAvailable (UnavailableDependency dep) = Left [dep]
getInstalled :: [ResolvedDependency] -> [PackageIdentifier]
getInstalled [] = []
getInstalled (dep:deps) = case dep of
InstalledDependency _ pkgid -> pkgid : getInstalled deps
AvailableDependency _ _ _ deps' -> getInstalled (deps'++deps)
UnavailableDependency _ -> getInstalled deps
-- TODO: kill this data type
data ResolvedDependency
= InstalledDependency Dependency PackageIdentifier
| AvailableDependency Dependency AvailablePackage FlagAssignment [ResolvedDependency]
| UnavailableDependency Dependency
deriving (Show)
unzipEithers :: [Either a b] -> ([a], [b])
unzipEithers = foldr (flip consEither) ([], [])
where consEither ~(ls,rs) = either (\l -> (l:ls,rs)) (\r -> (ls,r:rs))