----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Dependency.TopDown.Constraints -- Copyright : (c) Duncan Coutts 2008 -- License : BSD-like -- -- Maintainer : duncan@community.haskell.org -- Stability : provisional -- Portability : portable -- -- A set of satisfiable constraints on a set of packages. ----------------------------------------------------------------------------- module Distribution.Client.Dependency.TopDown.Constraints ( Constraints, empty, packages, choices, isPaired, addTarget, constrain, Satisfiable(..), conflicting, ) where import Distribution.Client.Dependency.TopDown.Types import qualified Distribution.Client.PackageIndex as PackageIndex import Distribution.Client.PackageIndex (PackageIndex) import Distribution.Package ( PackageName, PackageId, PackageIdentifier(..) , Package(packageId), packageName, packageVersion , Dependency, PackageFixedDeps(depends) ) import Distribution.Version ( Version ) import Distribution.Client.Utils ( mergeBy, MergeResult(..) ) import Data.Monoid ( Monoid(mempty) ) import Data.Either ( partitionEithers ) import qualified Data.Map as Map import Data.Map (Map) import qualified Data.Set as Set import Data.Set (Set) import Control.Exception ( assert ) -- | A set of satisfiable constraints on a set of packages. -- -- The 'Constraints' type keeps track of a set of targets (identified by -- package name) that we know that we need. It also keeps track of a set of -- constraints over all packages in the environment. -- -- It maintains the guarantee that, for the target set, the constraints are -- satisfiable, meaning that there is at least one instance available for each -- package name that satisfies the constraints on that package name. -- -- Note that it is possible to over-constrain a package in the environment that -- is not in the target set -- the satisfiability guarantee is only maintained -- for the target set. This is useful because it allows us to exclude packages -- without needing to know if it would ever be needed or not (e.g. allows -- excluding broken installed packages). -- -- Adding a constraint for a target package can fail if it would mean that -- there are no remaining choices. -- -- Adding a constraint for package that is not a target never fails. -- -- Adding a new target package can fail if that package already has conflicting -- constraints. -- data Constraints installed source reason = Constraints -- | Targets that we know we need. This is the set for which we -- guarantee the constraints are satisfiable. !(Set PackageName) -- | The available/remaining set. These are packages that have available -- choices remaining. This is guaranteed to cover the target packages, -- but can also cover other packages in the environment. New targets can -- only be added if there are available choices remaining for them. !(PackageIndex (InstalledOrSource installed source)) -- | The excluded set. Choices that we have excluded by applying -- constraints. Excluded choices are tagged with the reason. !(PackageIndex (ExcludedPkg (InstalledOrSource installed source) reason)) -- | Paired choices, this is an ugly hack. !(Map PackageName (Version, Version)) -- | Purely for the invariant, we keep a copy of the original index !(PackageIndex (InstalledOrSource installed source)) -- | Reasons for excluding all, or some choices for a package version. -- -- Each package version can have a source instance, an installed instance or -- both. We distinguish reasons for constraints that excluded both instances, -- from reasons for constraints that excluded just one instance. -- data ExcludedPkg pkg reason = ExcludedPkg pkg [reason] -- ^ reasons for excluding both source and installed instances [reason] -- ^ reasons for excluding the installed instance [reason] -- ^ reasons for excluding the source instance instance Package pkg => Package (ExcludedPkg pkg reason) where packageId (ExcludedPkg p _ _ _) = packageId p -- | There is a conservation of packages property. Packages are never gained or -- lost, they just transfer from the remaining set to the excluded set. -- invariant :: (Package installed, Package source) => Constraints installed source a -> Bool invariant (Constraints targets available excluded _ original) = -- Relationship between available, excluded and original all check merged -- targets is a subset of available && all (PackageIndex.elemByPackageName available) (Set.elems targets) where merged = mergeBy (\a b -> packageId a `compare` mergedPackageId b) (PackageIndex.allPackages original) (mergeBy (\a b -> packageId a `compare` packageId b) (PackageIndex.allPackages available) (PackageIndex.allPackages excluded)) where mergedPackageId (OnlyInLeft p ) = packageId p mergedPackageId (OnlyInRight p) = packageId p mergedPackageId (InBoth p _) = packageId p -- If the package was originally installed only, then check (InBoth (InstalledOnly _) cur) = case cur of -- now it's either still remaining as installed only OnlyInLeft (InstalledOnly _) -> True -- or it has been excluded OnlyInRight (ExcludedPkg (InstalledOnly _) [] (_:_) []) -> True _ -> False -- If the package was originally available only, then check (InBoth (SourceOnly _) cur) = case cur of -- now it's either still remaining as source only OnlyInLeft (SourceOnly _) -> True -- or it has been excluded OnlyInRight (ExcludedPkg (SourceOnly _) [] [] (_:_)) -> True _ -> False -- If the package was originally installed and source, then check (InBoth (InstalledAndSource _ _) cur) = case cur of -- We can have both remaining: OnlyInLeft (InstalledAndSource _ _) -> True -- both excluded, in particular it can have had the just source or -- installed excluded and later had both excluded so we do not mind if -- the source or installed excluded is empty or non-empty. OnlyInRight (ExcludedPkg (InstalledAndSource _ _) _ _ _) -> True -- the installed remaining and the source excluded: InBoth (InstalledOnly _) (ExcludedPkg (SourceOnly _) [] [] (_:_)) -> True -- the source remaining and the installed excluded: InBoth (SourceOnly _) (ExcludedPkg (InstalledOnly _) [] (_:_) []) -> True _ -> False check _ = False -- | An update to the constraints can move packages between the two piles -- but not gain or loose packages. transitionsTo :: (Package installed, Package source) => Constraints installed source a -> Constraints installed source a -> Bool transitionsTo constraints @(Constraints _ available excluded _ _) constraints'@(Constraints _ available' excluded' _ _) = invariant constraints && invariant constraints' && null availableGained && null excludedLost && map (mapInstalledOrSource packageId packageId) availableLost == map (mapInstalledOrSource packageId packageId) excludedGained where (availableLost, availableGained) = partitionEithers (foldr lostAndGained [] availableChange) (excludedLost, excludedGained) = partitionEithers (foldr lostAndGained [] excludedChange) availableChange = mergeBy (\a b -> packageId a `compare` packageId b) (PackageIndex.allPackages available) (PackageIndex.allPackages available') excludedChange = mergeBy (\a b -> packageId a `compare` packageId b) [ pkg | ExcludedPkg pkg _ _ _ <- PackageIndex.allPackages excluded ] [ pkg | ExcludedPkg pkg _ _ _ <- PackageIndex.allPackages excluded' ] lostAndGained mr rest = case mr of OnlyInLeft pkg -> Left pkg : rest InBoth (InstalledAndSource pkg _) (SourceOnly _) -> Left (InstalledOnly pkg) : rest InBoth (InstalledAndSource _ pkg) (InstalledOnly _) -> Left (SourceOnly pkg) : rest InBoth (SourceOnly _) (InstalledAndSource pkg _) -> Right (InstalledOnly pkg) : rest InBoth (InstalledOnly _) (InstalledAndSource _ pkg) -> Right (SourceOnly pkg) : rest OnlyInRight pkg -> Right pkg : rest _ -> rest mapInstalledOrSource f g pkg = case pkg of InstalledOnly a -> InstalledOnly (f a) SourceOnly b -> SourceOnly (g b) InstalledAndSource a b -> InstalledAndSource (f a) (g b) -- | We construct 'Constraints' with an initial 'PackageIndex' of all the -- packages available. -- empty :: (PackageFixedDeps installed, Package source) => PackageIndex installed -> PackageIndex source -> Constraints installed source reason empty installed source = Constraints targets pkgs excluded pairs pkgs where targets = mempty excluded = mempty pkgs = PackageIndex.fromList . map toInstalledOrSource $ mergeBy (\a b -> packageId a `compare` packageId b) (PackageIndex.allPackages installed) (PackageIndex.allPackages source) toInstalledOrSource (OnlyInLeft i ) = InstalledOnly i toInstalledOrSource (OnlyInRight a) = SourceOnly a toInstalledOrSource (InBoth i a) = InstalledAndSource i a -- pick up cases like base-3 and 4 where one version depends on the other: pairs = Map.fromList [ (name, (packageVersion pkgid1, packageVersion pkgid2)) | [pkg1, pkg2] <- PackageIndex.allPackagesByName installed , let name = packageName pkg1 pkgid1 = packageId pkg1 pkgid2 = packageId pkg2 , any ((pkgid1==) . packageId) (depends pkg2) || any ((pkgid2==) . packageId) (depends pkg1) ] -- | The package targets. -- packages :: (Package installed, Package source) => Constraints installed source reason -> Set PackageName packages (Constraints ts _ _ _ _) = ts -- | The package choices that are still available. -- choices :: (Package installed, Package source) => Constraints installed source reason -> PackageIndex (InstalledOrSource installed source) choices (Constraints _ available _ _ _) = available isPaired :: (Package installed, Package source) => Constraints installed source reason -> PackageId -> Maybe PackageId isPaired (Constraints _ _ _ pairs _) (PackageIdentifier name version) = case Map.lookup name pairs of Just (v1, v2) | version == v1 -> Just (PackageIdentifier name v2) | version == v2 -> Just (PackageIdentifier name v1) _ -> Nothing data Satisfiable constraints discarded reason = Satisfiable constraints discarded | Unsatisfiable | ConflictsWith [(PackageId, [reason])] addTarget :: (Package installed, Package source) => PackageName -> Constraints installed source reason -> Satisfiable (Constraints installed source reason) () reason addTarget pkgname constraints@(Constraints targets available excluded paired original) -- If it's already a target then there's no change | pkgname `Set.member` targets = Satisfiable constraints () -- If there is some possible choice available for this target then we're ok | PackageIndex.elemByPackageName available pkgname = let targets' = Set.insert pkgname targets constraints' = Constraints targets' available excluded paired original in assert (constraints `transitionsTo` constraints') $ Satisfiable constraints' () -- If it's not available and it is excluded then we return the conflicts | PackageIndex.elemByPackageName excluded pkgname = ConflictsWith conflicts -- Otherwise, it's not available and it has not been excluded so the -- package is simply completely unknown. | otherwise = Unsatisfiable where conflicts = [ (packageId pkg, reasons) | let excludedChoices = PackageIndex.lookupPackageName excluded pkgname , ExcludedPkg pkg isReasons iReasons sReasons <- excludedChoices , let reasons = isReasons ++ iReasons ++ sReasons ] constrain :: (Package installed, Package source) => PackageName -- ^ which package to constrain -> (Version -> Bool -> Bool) -- ^ the constraint test -> reason -- ^ the reason for the constraint -> Constraints installed source reason -> Satisfiable (Constraints installed source reason) [PackageId] reason constrain pkgname constraint reason constraints@(Constraints targets available excluded paired original) | pkgname `Set.member` targets && not anyRemaining = if null conflicts then Unsatisfiable else ConflictsWith conflicts | otherwise = let constraints' = Constraints targets available' excluded' paired original in assert (constraints `transitionsTo` constraints') $ Satisfiable constraints' (map packageId newExcluded) 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. -- (available', excluded', newExcluded, anyRemaining, conflicts) = updatePkgsStatus available excluded [] False [] (mergeBy (\pkg pkg' -> packageVersion pkg `compare` packageVersion pkg') (PackageIndex.lookupPackageName available pkgname) (PackageIndex.lookupPackageName excluded pkgname)) testConstraint pkg = let ver = packageVersion pkg in case Map.lookup (packageName pkg) paired of Just (v1, v2) | ver == v1 || ver == v2 -> case pkg of InstalledOnly ipkg -> InstalledOnly (ipkg, iOk) SourceOnly spkg -> SourceOnly (spkg, sOk) InstalledAndSource ipkg spkg -> InstalledAndSource (ipkg, iOk) (spkg, sOk) where iOk = constraint v1 True || constraint v2 True sOk = constraint v1 False || constraint v2 False _ -> case pkg of InstalledOnly ipkg -> InstalledOnly (ipkg, iOk) SourceOnly spkg -> SourceOnly (spkg, sOk) InstalledAndSource ipkg spkg -> InstalledAndSource (ipkg, iOk) (spkg, sOk) where iOk = constraint ver True sOk = constraint ver False -- For the info about available and excluded versions of the package in -- question, update the info given the current constraint -- -- We update the available package map and the excluded package map -- we also collect: -- * the change in available packages (for logging) -- * whether there are any remaining choices -- * any constraints that conflict with the current constraint updatePkgsStatus _ _ nePkgs ok cs _ | seq nePkgs $ seq ok $ seq cs False = undefined updatePkgsStatus aPkgs ePkgs nePkgs ok cs [] = (aPkgs, ePkgs, reverse nePkgs, ok, reverse cs) updatePkgsStatus aPkgs ePkgs nePkgs ok cs (pkg:pkgs) = let (aPkgs', ePkgs', mnePkg, ok', mc) = updatePkgStatus aPkgs ePkgs pkg nePkgs' = maybeCons mnePkg nePkgs cs' = maybeCons mc cs in updatePkgsStatus aPkgs' ePkgs' nePkgs' (ok' || ok) cs' pkgs maybeCons Nothing xs = xs maybeCons (Just x) xs = x:xs -- For the info about an available or excluded version of the package in -- question, update the info given the current constraint. -- updatePkgStatus aPkgs ePkgs pkg = case viewPackageStatus pkg of AllAvailable (InstalledOnly (aiPkg, False)) -> removeAvailable False (InstalledOnly aiPkg) (PackageIndex.deletePackageId pkgid) (ExcludedPkg (InstalledOnly aiPkg) [] [reason] []) Nothing AllAvailable (SourceOnly (asPkg, False)) -> removeAvailable False (SourceOnly asPkg) (PackageIndex.deletePackageId pkgid) (ExcludedPkg (SourceOnly asPkg) [] [] [reason]) Nothing AllAvailable (InstalledAndSource (aiPkg, False) (asPkg, False)) -> removeAvailable False (InstalledAndSource aiPkg asPkg) (PackageIndex.deletePackageId pkgid) (ExcludedPkg (InstalledAndSource aiPkg asPkg) [reason] [] []) Nothing AllAvailable (InstalledAndSource (aiPkg, True) (asPkg, False)) -> removeAvailable True (SourceOnly asPkg) (PackageIndex.insert (InstalledOnly aiPkg)) (ExcludedPkg (SourceOnly asPkg) [] [] [reason]) Nothing AllAvailable (InstalledAndSource (aiPkg, False) (asPkg, True)) -> removeAvailable True (InstalledOnly aiPkg) (PackageIndex.insert (SourceOnly asPkg)) (ExcludedPkg (InstalledOnly aiPkg) [] [reason] []) Nothing AllAvailable _ -> noChange True Nothing AvailableExcluded (aiPkg, False) (ExcludedPkg (esPkg, False) _ _ srs) -> removeAvailable False (InstalledOnly aiPkg) (PackageIndex.deletePackageId pkgid) (ExcludedPkg (InstalledAndSource aiPkg esPkg) [reason] [] srs) Nothing AvailableExcluded (_aiPkg, True) (ExcludedPkg (esPkg, False) _ _ srs) -> addExtraExclusion True (ExcludedPkg (SourceOnly esPkg) [] [] (reason:srs)) Nothing AvailableExcluded (aiPkg, False) (ExcludedPkg (esPkg, True) _ _ srs) -> removeAvailable True (InstalledOnly aiPkg) (PackageIndex.deletePackageId pkgid) (ExcludedPkg (InstalledAndSource aiPkg esPkg) [] [reason] srs) (Just (pkgid, srs)) AvailableExcluded (_aiPkg, True) (ExcludedPkg (_esPkg, True) _ _ srs) -> noChange True (Just (pkgid, srs)) ExcludedAvailable (ExcludedPkg (eiPkg, False) _ irs _) (asPkg, False) -> removeAvailable False (SourceOnly asPkg) (PackageIndex.deletePackageId pkgid) (ExcludedPkg (InstalledAndSource eiPkg asPkg) [reason] irs []) Nothing ExcludedAvailable (ExcludedPkg (eiPkg, True) _ irs _) (asPkg, False) -> removeAvailable False (SourceOnly asPkg) (PackageIndex.deletePackageId pkgid) (ExcludedPkg (InstalledAndSource eiPkg asPkg) [] irs [reason]) (Just (pkgid, irs)) ExcludedAvailable (ExcludedPkg (eiPkg, False) _ irs _) (_asPkg, True) -> addExtraExclusion True (ExcludedPkg (InstalledOnly eiPkg) [] (reason:irs) []) Nothing ExcludedAvailable (ExcludedPkg (_eiPkg, True) _ irs _) (_asPkg, True) -> noChange True (Just (pkgid, irs)) AllExcluded (ExcludedPkg (InstalledOnly (eiPkg, False)) _ irs _) -> addExtraExclusion False (ExcludedPkg (InstalledOnly eiPkg) [] (reason:irs) []) Nothing AllExcluded (ExcludedPkg (InstalledOnly (_eiPkg, True)) _ irs _) -> noChange False (Just (pkgid, irs)) AllExcluded (ExcludedPkg (SourceOnly (esPkg, False)) _ _ srs) -> addExtraExclusion False (ExcludedPkg (SourceOnly esPkg) [] [] (reason:srs)) Nothing AllExcluded (ExcludedPkg (SourceOnly (_esPkg, True)) _ _ srs) -> noChange False (Just (pkgid, srs)) AllExcluded (ExcludedPkg (InstalledAndSource (eiPkg, False) (esPkg, False)) isrs irs srs) -> addExtraExclusion False (ExcludedPkg (InstalledAndSource eiPkg esPkg) (reason:isrs) irs srs) Nothing AllExcluded (ExcludedPkg (InstalledAndSource (eiPkg, True) (esPkg, False)) isrs irs srs) -> addExtraExclusion False (ExcludedPkg (InstalledAndSource eiPkg esPkg) isrs irs (reason:srs)) (Just (pkgid, irs)) AllExcluded (ExcludedPkg (InstalledAndSource (eiPkg, False) (esPkg, True)) isrs irs srs) -> addExtraExclusion False (ExcludedPkg (InstalledAndSource eiPkg esPkg) isrs (reason:irs) srs) (Just (pkgid, srs)) AllExcluded (ExcludedPkg (InstalledAndSource (_eiPkg, True) (_esPkg, True)) isrs irs srs) -> noChange False (Just (pkgid, isrs ++ irs ++ srs)) where removeAvailable ok nePkg adjustAvailable ePkg c = let aPkgs' = adjustAvailable aPkgs ePkgs' = PackageIndex.insert ePkg ePkgs in aPkgs' `seq` ePkgs' `seq` (aPkgs', ePkgs', Just nePkg, ok, c) addExtraExclusion ok ePkg c = let ePkgs' = PackageIndex.insert ePkg ePkgs in ePkgs' `seq` (aPkgs, ePkgs', Nothing, ok, c) noChange ok c = (aPkgs, ePkgs, Nothing, ok, c) pkgid = case pkg of OnlyInLeft p -> packageId p OnlyInRight p -> packageId p InBoth p _ -> packageId p viewPackageStatus :: (Package installed, Package source) => MergeResult (InstalledOrSource installed source) (ExcludedPkg (InstalledOrSource installed source) reason) -> PackageStatus (installed, Bool) (source, Bool) reason viewPackageStatus merged = case merged of OnlyInLeft aPkg -> AllAvailable (testConstraint aPkg) OnlyInRight (ExcludedPkg ePkg isrs irs srs) -> AllExcluded (ExcludedPkg (testConstraint ePkg) isrs irs srs) InBoth (InstalledOnly aiPkg) (ExcludedPkg (SourceOnly esPkg) [] [] srs) -> case testConstraint (InstalledAndSource aiPkg esPkg) of InstalledAndSource (aiPkg', iOk) (esPkg', sOk) -> AvailableExcluded (aiPkg', iOk) (ExcludedPkg (esPkg', sOk) [] [] srs) _ -> impossible InBoth (SourceOnly asPkg) (ExcludedPkg (InstalledOnly eiPkg) [] irs []) -> case testConstraint (InstalledAndSource eiPkg asPkg) of InstalledAndSource (eiPkg', iOk) (asPkg', sOk) -> ExcludedAvailable (ExcludedPkg (eiPkg', iOk) [] irs []) (asPkg', sOk) _ -> impossible _ -> impossible where impossible = error "impossible: viewPackageStatus invariant violation" -- A intermediate structure that enumerates all the possible cases given the -- invariant. This helps us to get simpler and complete pattern matching in -- updatePkg above -- data PackageStatus installed source reason = AllAvailable (InstalledOrSource installed source) | AllExcluded (ExcludedPkg (InstalledOrSource installed source) reason) | AvailableExcluded installed (ExcludedPkg source reason) | ExcludedAvailable (ExcludedPkg installed reason) source conflicting :: (Package installed, Package source) => Constraints installed source reason -> Dependency -> [(PackageId, [reason])] conflicting (Constraints _ _ excluded _ _) dep = [ (packageId pkg, reasonsAll ++ reasonsAvail ++ reasonsInstalled) --TODO | ExcludedPkg pkg reasonsAll reasonsAvail reasonsInstalled <- PackageIndex.lookupDependency excluded dep ]