Commit 74c9be20 authored by Duncan Coutts's avatar Duncan Coutts
Browse files

Adjust to the change in the type of getInstalledPackages

It used to return Maybe, now it always gives us a PackageIndex.
This depends on an API change in Cabal-1.9.x.
parent 563fcf9f
......@@ -113,7 +113,7 @@ configure verbosity packageDBs repos comp conf
then packageDBs
else packageDBs ++ [UserPackageDB],
usePackageIndex = if UserPackageDB `elem` packageDBs
then index
then Just index
else Nothing,
useProgramConfig = conf,
useDistPref = fromFlagOrDefault
......@@ -128,7 +128,7 @@ configure verbosity packageDBs repos comp conf
--
planLocalPackage :: Verbosity -> Compiler
-> ConfigFlags -> ConfigExFlags
-> Maybe (PackageIndex InstalledPackage)
-> PackageIndex InstalledPackage
-> AvailablePackageDb
-> IO (Progress String String InstallPlan)
planLocalPackage verbosity comp configFlags configExFlags installed
......@@ -139,7 +139,7 @@ planLocalPackage verbosity comp configFlags configExFlags installed
-- dependency on exactly that package. So the resolver ends up having
-- to pick the local package.
available' = PackageIndex.insert localPkg mempty
installed' = PackageIndex.deletePackageId (packageId localPkg) `fmap` installed
installed' = PackageIndex.deletePackageId (packageId localPkg) installed
localPkg = AvailablePackage {
packageInfoId = packageId pkg,
Available.packageDescription = pkg,
......
......@@ -27,7 +27,6 @@ module Distribution.Client.Dependency (
upgradableDependencies,
) where
import Distribution.Client.Dependency.Bogus (bogusResolver)
import Distribution.Client.Dependency.TopDown (topDownResolver)
import qualified Distribution.Client.PackageIndex as PackageIndex
import Distribution.Client.PackageIndex (PackageIndex)
......@@ -52,7 +51,6 @@ import Distribution.Simple.Utils (comparing)
import Distribution.Client.Utils (mergeBy, MergeResult(..))
import Data.List (maximumBy)
import Data.Monoid (Monoid(mempty))
import Data.Maybe (fromMaybe)
import qualified Data.Map as Map
import qualified Data.Set as Set
......@@ -112,7 +110,7 @@ data PackagePreference
resolveDependencies :: Platform
-> CompilerId
-> Maybe (PackageIndex InstalledPackage)
-> PackageIndex InstalledPackage
-> PackageIndex AvailablePackage
-> PackagesPreference
-> [PackageConstraint]
......@@ -126,18 +124,15 @@ resolveDependencies platform comp installed available
resolveDependenciesWithProgress :: Platform
-> CompilerId
-> Maybe (PackageIndex InstalledPackage)
-> PackageIndex InstalledPackage
-> PackageIndex AvailablePackage
-> PackagesPreference
-> [PackageConstraint]
-> [PackageName]
-> Progress String String InstallPlan
resolveDependenciesWithProgress platform comp (Just installed) =
resolveDependenciesWithProgress platform comp installed =
dependencyResolver defaultResolver platform comp installed
resolveDependenciesWithProgress platform comp Nothing =
dependencyResolver bogusResolver platform comp mempty
hideBrokenPackages :: PackageFixedDeps p => PackageIndex p -> PackageIndex p
hideBrokenPackages index =
check (null . PackageIndex.brokenPackages)
......
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Dependency.Bogus
-- 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 for when we do not know what packages are installed.
-----------------------------------------------------------------------------
module Distribution.Client.Dependency.Bogus (
bogusResolver
) where
import Distribution.Client.Types
( AvailablePackage(..), ConfiguredPackage(..) )
import Distribution.Client.Dependency.Types
( DependencyResolver, Progress(..)
, PackageConstraint(..), PackagePreferences(..) )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Package
( PackageName, PackageIdentifier(..), Dependency(..)
, Package(..), packageVersion )
import Distribution.PackageDescription
( GenericPackageDescription(..), CondTree(..), FlagAssignment )
import Distribution.PackageDescription.Configuration
( finalizePackageDescription )
import qualified Distribution.Client.PackageIndex as PackageIndex
import Distribution.Client.PackageIndex (PackageIndex)
import Distribution.Version
( VersionRange, anyVersion, intersectVersionRanges, withinRange )
import Distribution.Simple.Utils
( comparing )
import Distribution.Text
( display )
import Data.List
( maximumBy )
import Data.Maybe
( fromMaybe )
import qualified Data.Map as Map
-- | This resolver thinks that every package is already installed.
--
-- We need this for hugs and nhc98 which do not track installed packages.
-- We just pretend that everything is installed and hope for the best.
--
bogusResolver :: DependencyResolver
bogusResolver platform comp _ available
preferences constraints targets =
resolveFromAvailable []
(combineConstraints preferences constraints targets)
where
resolveFromAvailable chosen [] = Done chosen
resolveFromAvailable chosen ((name, verConstraint, flags, verPref): deps) =
case latestAvailableSatisfying available name verConstraint verPref of
Nothing -> Fail ("Unresolved dependency: " ++ display dep)
Just apkg@(AvailablePackage _ pkg _) ->
case finalizePackageDescription flags none platform comp [] pkg of
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 :: Dependency -> Bool
none = const True
where
dep = Dependency name verConstraint
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)
combineConstraints :: (PackageName -> PackagePreferences)
-> [PackageConstraint]
-> [PackageName]
-> [(PackageName, VersionRange, FlagAssignment, VersionRange)]
combineConstraints preferences constraints targets =
[ (name, ver, flags, pref)
| name <- targets
, let ver = fromMaybe anyVersion (Map.lookup name versionConstraints)
flags = fromMaybe [] (Map.lookup name flagsConstraints)
PackagePreferences pref _ = preferences name ]
where
versionConstraints = Map.fromListWith intersectVersionRanges
[ (name, versionRange)
| PackageVersionConstraint name versionRange <- constraints ]
flagsConstraints = Map.fromListWith (++)
[ (name, flags)
| PackageFlagsConstraint name flags <- constraints ]
-- | Gets the best available package satisfying a dependency.
--
latestAvailableSatisfying :: PackageIndex AvailablePackage
-> PackageName -> VersionRange -> VersionRange
-> Maybe AvailablePackage
latestAvailableSatisfying index name versionConstraint versionPreference =
case PackageIndex.lookupDependency index dep of
[] -> Nothing
pkgs -> Just (maximumBy best pkgs)
where
dep = Dependency name versionConstraint
best = comparing (\p -> (isPreferred p, packageVersion p))
isPreferred p = packageVersion p `withinRange` versionPreference
......@@ -128,7 +128,7 @@ fetch verbosity packageDBs repos comp conf deps = do
-- 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' = fmap (hideGivenDeps deps') installed
installed' = hideGivenDeps deps' installed
hideGivenDeps pkgs index =
foldr PackageIndex.deletePackageName index
[ name | UnresolvedDependency (Dependency name _) _ <- pkgs ]
......
......@@ -74,10 +74,9 @@ import System.Time
getInstalledPackages :: Verbosity -> Compiler
-> PackageDBStack -> ProgramConfiguration
-> IO (Maybe (PackageIndex InstalledPackage))
-> IO (PackageIndex InstalledPackage)
getInstalledPackages verbosity comp packageDbs conf =
fmap (fmap convert)
(Configure.getInstalledPackages verbosity comp packageDbs conf)
fmap convert (Configure.getInstalledPackages verbosity comp packageDbs conf)
where
convert :: InstalledPackageIndex.PackageIndex -> PackageIndex InstalledPackage
convert index = PackageIndex.fromList $
......
......@@ -170,7 +170,7 @@ upgrade verbosity packageDB repos comp conf
| otherwise = planRepoPackages PreferAllLatest
comp configFlags configExFlags installFlags deps
type Planner = Maybe (PackageIndex InstalledPackage)
type Planner = PackageIndex InstalledPackage
-> AvailablePackageDb
-> IO (Progress String String InstallPlan)
......@@ -249,7 +249,7 @@ installWithPlanner planner verbosity packageDBs repos comp conf
--TODO: use Ord instance:
-- insert UserPackageDB packageDBs
usePackageIndex = if UserPackageDB `elem` packageDBs
then index
then Just index
else Nothing,
useProgramConfig = conf,
useDistPref = fromFlagOrDefault
......@@ -340,9 +340,7 @@ regenerateHaddockIndex verbosity packageDBs comp conf
--TODO: might be nice if the install plan gave us the new InstalledPackageInfo
installed <- getInstalledPackages verbosity comp packageDBs conf
case installed of
Nothing -> return () -- warning ?
Just index -> Haddock.regenerateHaddockIndex verbosity index conf indexFile
Haddock.regenerateHaddockIndex verbosity installed conf indexFile
| otherwise = return ()
where
......@@ -390,7 +388,7 @@ planLocalPackage verbosity comp configFlags configExFlags installed
-- dependency on exactly that package. So the resolver ends up having
-- to pick the local package.
available' = PackageIndex.insert localPkg available
installed' = PackageIndex.deletePackageId (packageId localPkg) `fmap` installed
installed' = PackageIndex.deletePackageId (packageId localPkg) installed
localPkg = AvailablePackage {
packageInfoId = packageId pkg,
Available.packageDescription = pkg,
......@@ -420,7 +418,7 @@ planRepoPackages defaultPref comp configFlags configExFlags installFlags
deps' <- IndexUtils.disambiguateDependencies available deps
let installed'
| fromFlag (installReinstall installFlags)
= fmap (hideGivenDeps deps') installed
= hideGivenDeps deps' installed
| otherwise = installed
targets = dependencyTargets deps'
constraints = dependencyConstraints deps'
......@@ -435,7 +433,7 @@ planRepoPackages defaultPref comp configFlags configExFlags installFlags
[ name | UnresolvedDependency (Dependency name _) _ <- pkgs ]
planUpgradePackages :: Compiler -> ConfigFlags -> ConfigExFlags -> Planner
planUpgradePackages _comp _configFlags _configExFlags (Just installed)
planUpgradePackages _comp _configFlags _configExFlags installed
(AvailablePackageDb available _availablePrefs) = die $
"the 'upgrade' command (when used without any package arguments) has "
++ "been disabled in this release. It has been disabled because it has "
......@@ -459,11 +457,6 @@ planUpgradePackages _comp _configFlags _configExFlags (Just installed)
-- | Dependency name ver <- configConstraints configFlags ]
-- targets = [ name | Dependency name _ <- deps ]
planUpgradePackages comp _ _ _ _ =
die $ display (compilerId comp)
++ " does not track installed packages so cabal cannot figure out what"
++ " packages need to be upgraded."
mergePackagePrefs :: PackagesPreferenceDefault
-> Map.Map PackageName VersionRange
-> ConfigExFlags
......@@ -477,9 +470,9 @@ mergePackagePrefs defaultPref availablePrefs configExFlags =
++ [ PackageVersionPreference name ver
| Dependency name ver <- configPreferences configExFlags ]
printDryRun :: Verbosity -> Maybe (PackageIndex InstalledPackage)
printDryRun :: Verbosity -> PackageIndex InstalledPackage
-> InstallPlan -> IO ()
printDryRun verbosity minstalled plan = case unfoldr next plan of
printDryRun verbosity installed plan = case unfoldr next plan of
[] -> return ()
pkgs
| verbosity >= Verbosity.verbose -> notice verbosity $ unlines $
......@@ -498,9 +491,6 @@ printDryRun verbosity minstalled plan = case unfoldr next plan of
-- pretending that each package is installed
showPkgAndReason pkg' = display (packageId pkg') ++ " " ++
case minstalled of
Nothing -> ""
Just installed ->
case PackageIndex.lookupPackageName installed (packageName pkg') of
[] -> "(new package)"
ps -> case find ((==packageId pkg') . packageId) ps of
......
......@@ -72,7 +72,7 @@ list :: Verbosity
-> [String]
-> IO ()
list verbosity packageDBs repos comp conf listFlags pats = do
Just installed <- getInstalledPackages verbosity comp packageDBs conf
installed <- getInstalledPackages verbosity comp packageDBs conf
AvailablePackageDb available _ <- getAvailablePackages verbosity repos
let pkgs | null pats = (PackageIndex.allPackages installed
,PackageIndex.allPackages available)
......@@ -113,7 +113,7 @@ info :: Verbosity
info verbosity packageDBs repos comp conf _listFlags deps = do
AvailablePackageDb available _ <- getAvailablePackages verbosity repos
deps' <- IndexUtils.disambiguateDependencies available deps
Just installed <- getInstalledPackages verbosity comp packageDBs conf
installed <- getInstalledPackages verbosity comp packageDBs conf
let deps'' = [ name | UnresolvedDependency (Dependency name _) _ <- deps' ]
let pkgs = (concatMap (PackageIndex.lookupPackageName installed) deps''
,concatMap (PackageIndex.lookupPackageName available) deps'')
......
......@@ -71,7 +71,6 @@ import System.Process ( runProcess, waitForProcess )
import Control.Monad ( when, unless )
import Data.List ( maximumBy )
import Data.Maybe ( fromMaybe, isJust )
import Data.Monoid ( Monoid(mempty) )
import Data.Char ( isSpace )
data SetupScriptOptions = SetupScriptOptions {
......@@ -207,8 +206,7 @@ externalSetupMethod verbosity options pkg bt mkargs = do
installedCabalVersion options' comp conf = do
index <- case usePackageIndex options' of
Just index -> return index
Nothing -> fromMaybe mempty
`fmap` getInstalledPackages verbosity
Nothing -> getInstalledPackages verbosity
comp (usePackageDB options') conf
let cabalDep = Dependency (PackageName "Cabal") (useCabalVersion options)
......
......@@ -51,7 +51,6 @@ Executable cabal
Distribution.Client.Config
Distribution.Client.Configure
Distribution.Client.Dependency
Distribution.Client.Dependency.Bogus
Distribution.Client.Dependency.TopDown
Distribution.Client.Dependency.TopDown.Constraints
Distribution.Client.Dependency.TopDown.Types
......@@ -83,7 +82,7 @@ Executable cabal
Paths_cabal_install
build-depends: base >= 2 && < 5,
Cabal >= 1.8 && < 1.9,
Cabal >= 1.9 && < 1.10,
filepath >= 1.0,
network >= 1 && < 3,
HTTP >= 4000.0.2 && < 4001,
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment