cabal-install-0.5.2: Distribution/Client/Dependency/TopDown/Constraints.hs
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Dependency.TopDown.Constraints
-- Copyright : (c) Duncan Coutts 2008
-- License : BSD-like
--
-- Maintainer : duncan@haskell.org
-- Stability : provisional
-- Portability : portable
--
-- A set of satisfiable dependencies (package version constraints).
-----------------------------------------------------------------------------
module Distribution.Client.Dependency.TopDown.Constraints (
Constraints,
empty,
choices,
constrain,
Satisfiable(..),
conflicting,
) where
import Distribution.Client.Dependency.TopDown.Types
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.PackageIndex (PackageIndex)
import Distribution.Package
( PackageIdentifier, Package(packageId), packageVersion, packageName
, Dependency(Dependency) )
import Distribution.Version
( withinRange )
import Distribution.Simple.Utils
( comparing )
import Distribution.Client.Utils
( mergeBy, MergeResult(..) )
import Data.List
( foldl', sortBy )
import Data.Monoid
( Monoid(mempty) )
import Control.Exception
( assert )
-- | A set of constraints on package versions. For each package name we record
-- what other packages depends on it and what constraints they impose on the
-- version of the package.
--
data (Package installed, Package available)
=> Constraints installed available reason
= Constraints
-- Remaining available choices
(PackageIndex (InstalledOrAvailable installed available))
-- Choices that we have excluded for some reason
-- usually by applying constraints
(PackageIndex (ExcludedPackage PackageIdentifier reason))
data ExcludedPackage pkg reason
= ExcludedPackage pkg [reason] -- reasons for excluding just the available
[reason] -- reasons for excluding installed and avail
instance Package pkg => Package (ExcludedPackage pkg reason) where
packageId (ExcludedPackage p _ _) = packageId p
-- | The intersection between the two indexes is empty
invariant :: (Package installed, Package available)
=> Constraints installed available a -> Bool
invariant (Constraints available excluded) =
all (uncurry ok) [ (a, e) | InBoth a e <- merged ]
where
merged = mergeBy (\a b -> packageId a `compare` packageId b)
(PackageIndex.allPackages available)
(PackageIndex.allPackages excluded)
ok (InstalledOnly _) (ExcludedPackage _ _ []) = True
ok _ _ = False
-- | An update to the constraints can move packages between the two piles
-- but not gain or loose packages.
transitionsTo :: (Package installed, Package available)
=> Constraints installed available a
-> Constraints installed available a -> Bool
transitionsTo constraints @(Constraints available excluded )
constraints'@(Constraints available' excluded') =
invariant constraints && invariant constraints'
&& null availableGained && null excludedLost
&& map packageId availableLost == map packageId excludedGained
where
availableLost = foldr lost [] availableChange where
lost (OnlyInLeft pkg) rest = pkg : rest
lost (InBoth (InstalledAndAvailable _ pkg)
(InstalledOnly _)) rest = AvailableOnly pkg : rest
lost _ rest = rest
availableGained = [ pkg | OnlyInRight pkg <- availableChange ]
excludedLost = [ pkg | OnlyInLeft pkg <- excludedChange ]
excludedGained = [ pkg | OnlyInRight pkg <- excludedChange ]
availableChange = mergeBy (\a b -> packageId a `compare` packageId b)
(allPackagesInOrder available)
(allPackagesInOrder available')
excludedChange = mergeBy (\a b -> packageId a `compare` packageId b)
(allPackagesInOrder excluded)
(allPackagesInOrder excluded')
--FIXME: PackageIndex.allPackages returns in sorted order case-insensitively
-- but that's no good for our merge which uses Ord
allPackagesInOrder :: Package pkg => PackageIndex pkg -> [pkg]
allPackagesInOrder index =
concatMap snd
. sortBy (comparing fst)
$ [ (packageName pkg, grp)
| grp@(pkg:_) <- PackageIndex.allPackagesByName index ]
-- | We construct 'Constraints' with an initial 'PackageIndex' of all the
-- packages available.
--
empty :: (Package installed, Package available)
=> PackageIndex installed
-> PackageIndex available
-> Constraints installed available reason
empty installed available = Constraints pkgs mempty
where
pkgs = PackageIndex.fromList
. map toInstalledOrAvailable
$ mergeBy (\a b -> packageId a `compare` packageId b)
(allPackagesInOrder installed)
(allPackagesInOrder available)
toInstalledOrAvailable (OnlyInLeft i ) = InstalledOnly i
toInstalledOrAvailable (OnlyInRight a) = AvailableOnly a
toInstalledOrAvailable (InBoth i a) = InstalledAndAvailable i a
-- | The package choices that are still available.
--
choices :: (Package installed, Package available)
=> Constraints installed available reason
-> PackageIndex (InstalledOrAvailable installed available)
choices (Constraints available _) = available
data Satisfiable a reason
= Satisfiable a
| Unsatisfiable
| ConflictsWith [(PackageIdentifier, [reason])]
constrain :: (Package installed, Package available)
=> TaggedDependency
-> reason
-> Constraints installed available reason
-> Satisfiable (Constraints installed available reason) reason
constrain (TaggedDependency installedConstraint (Dependency name versionRange))
reason constraints@(Constraints available excluded)
| not anyRemaining
= if null conflicts then Unsatisfiable
else ConflictsWith conflicts
| otherwise
= let constraints' = Constraints available' excluded'
in assert (constraints `transitionsTo` constraints') $
Satisfiable constraints'
where
-- This tells us if any packages would remain at all for this package name if
-- we applied this constraint. This amounts to checking if any package
-- satisfies the given constraint, including version range and installation
-- status.
--
anyRemaining = any satisfiesConstraint availableChoices
conflicts = [ (packageId pkg, reasonsAvail ++ reasonsAll)
| ExcludedPackage pkg reasonsAvail reasonsAll <- excludedChoices
, satisfiesVersionConstraint pkg ]
-- Applying this constraint may involve deleting some choices for this
-- package name, or restricting which install states are available.
available' = updateAvailable available
updateAvailable = flip (foldl' (flip update)) availableChoices where
update pkg | not (satisfiesVersionConstraint pkg)
= PackageIndex.deletePackageId (packageId pkg)
update _ | installedConstraint == NoInstalledConstraint
= id
update pkg = case pkg of
InstalledOnly _ -> id
AvailableOnly _ -> error "impossible" -- PackageIndex.deletePackageId (packageId pkg)
InstalledAndAvailable i _ -> PackageIndex.insert (InstalledOnly i)
-- Applying the constraint means adding exclusions for the packages that
-- we're just freshly excluding, ie the ones we're removing from available.
excluded' = addNewExcluded . addOldExcluded $ excluded
addNewExcluded index = foldl' (flip exclude) index availableChoices where
exclude pkg
| not (satisfiesVersionConstraint pkg)
= PackageIndex.insert $ ExcludedPackage pkgid [] [reason]
| installedConstraint == NoInstalledConstraint
= id
| otherwise = case pkg of
InstalledOnly _ -> id
AvailableOnly _ -> PackageIndex.insert
(ExcludedPackage pkgid [reason] [])
InstalledAndAvailable _ _ ->
case PackageIndex.lookupPackageId excluded pkgid of
Just (ExcludedPackage _ avail both) ->
PackageIndex.insert (ExcludedPackage pkgid (reason:avail) both)
Nothing ->
PackageIndex.insert (ExcludedPackage pkgid [reason] [])
where pkgid = packageId pkg
-- Additionally we have to add extra exclusions for any already-excluded
-- packages that happen to be covered by the (inverse of the) constraint.
addOldExcluded = flip (foldl' (flip exclude)) excludedChoices where
exclude (ExcludedPackage pkgid avail both)
-- if it doesn't satisfy the version constraint then we exclude the
-- package as a whole, the available or the installed instances or both.
| not (satisfiesVersionConstraint pkgid)
= PackageIndex.insert (ExcludedPackage pkgid avail (reason:both))
-- if on the other hand it does satisfy the constraint and we were also
-- constraining to just the installed version then we exclude just the
-- available instance.
| installedConstraint == InstalledConstraint
= PackageIndex.insert (ExcludedPackage pkgid (reason:avail) both)
| otherwise = id
-- util definitions
availableChoices = PackageIndex.lookupPackageName available name
excludedChoices = PackageIndex.lookupPackageName excluded name
satisfiesConstraint pkg = satisfiesVersionConstraint pkg
&& satisfiesInstallStateConstraint pkg
satisfiesVersionConstraint pkg =
packageVersion pkg `withinRange` versionRange
satisfiesInstallStateConstraint = case installedConstraint of
NoInstalledConstraint -> \_ -> True
InstalledConstraint -> \pkg -> case pkg of
AvailableOnly _ -> False
_ -> True
conflicting :: (Package installed, Package available)
=> Constraints installed available reason
-> Dependency
-> [(PackageIdentifier, [reason])]
conflicting (Constraints _ excluded) dep =
[ (pkgid, reasonsAvail ++ reasonsAll) --TODO
| ExcludedPackage pkgid reasonsAvail reasonsAll <-
PackageIndex.lookupDependency excluded dep ]