Dependency.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Client.Dependency
-- Copyright   :  (c) David Himmelstrup 2005,
--                    Bjorn Bringert 2007
--                    Duncan Coutts 2008
-- License     :  BSD-like
--
-- Maintainer  :  cabal-devel@gmail.com
-- Stability   :  provisional
-- Portability :  portable
--
-- Top level interface to dependency resolution.
-----------------------------------------------------------------------------
module Distribution.Client.Dependency (
    module Distribution.Client.Dependency.Types,
    resolveDependencies,
    resolveDependenciesWithProgress,

    resolveAvailablePackages,

    dependencyConstraints,
    dependencyTargets,

    PackagesPreference(..),
    PackagesPreferenceDefault(..),
    PackagePreference(..),

    upgradableDependencies,
  ) where

import Distribution.Client.Dependency.TopDown (topDownResolver)
import qualified Distribution.Client.PackageIndex as PackageIndex
import Distribution.Client.PackageIndex (PackageIndex)
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.InstallPlan (InstallPlan)
import Distribution.Client.Types
         ( UnresolvedDependency(..), AvailablePackage(..), InstalledPackage )
import Distribution.Client.Dependency.Types
         ( DependencyResolver, PackageConstraint(..)
         , PackagePreferences(..), InstalledPreference(..)
         , Progress(..), foldProgress )
import Distribution.Package
         ( PackageIdentifier(..), PackageName(..), packageVersion, packageName
         , Dependency(Dependency), Package(..), PackageFixedDeps(..) )
import Distribution.Version
         ( VersionRange, anyVersion, orLaterVersion
         , isAnyVersion, withinRange, simplifyVersionRange )
import Distribution.Compiler
         ( CompilerId(..) )
import Distribution.System
         ( Platform )
import Distribution.Simple.Utils (comparing)
import Distribution.Client.Utils (mergeBy, MergeResult(..))
import Distribution.Text
         ( display )

import Data.List (maximumBy)
import Data.Maybe (fromMaybe, isJust)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Set (Set)
import Control.Exception (assert)

defaultResolver :: DependencyResolver
defaultResolver = topDownResolver

-- | Global policy for the versions of all packages.
--
data PackagesPreference = PackagesPreference
       PackagesPreferenceDefault
       [PackagePreference]

dependencyConstraints :: [UnresolvedDependency] -> [PackageConstraint]
dependencyConstraints deps =
     [ PackageVersionConstraint name versionRange
     | UnresolvedDependency (Dependency name versionRange) _ <- deps
     , not (isAnyVersion versionRange) ]

  ++ [ PackageFlagsConstraint name flags
     | UnresolvedDependency (Dependency name _) flags <- deps
     , not (null flags) ]

dependencyTargets :: [UnresolvedDependency] -> [PackageName]
dependencyTargets deps =
  [ name | UnresolvedDependency (Dependency name _) _ <- deps ]

-- | Global policy for all packages to say if we prefer package versions that
-- are already installed locally or if we just prefer the latest available.
--
data PackagesPreferenceDefault =

     -- | Always prefer the latest version irrespective of any existing
     -- installed version.
     --
     -- * This is the standard policy for upgrade.
     --
     PreferAllLatest

     -- | Always prefer the installed versions over ones that would need to be
     -- installed. Secondarily, prefer latest versions (eg the latest installed
     -- version or if there are none then the latest available version).
   | PreferAllInstalled

     -- | Prefer the latest version for packages that are explicitly requested
     -- but prefers the installed version for any other packages.
     --
     -- * This is the standard policy for install.
     --
   | PreferLatestForSelected

data PackagePreference
   = PackageVersionPreference   PackageName VersionRange
   | PackageInstalledPreference PackageName InstalledPreference

resolveDependencies :: Platform
                    -> CompilerId
                    -> PackageIndex InstalledPackage
                    -> PackageIndex AvailablePackage
                    -> PackagesPreference
                    -> [PackageConstraint]
                    -> [PackageName]
                    -> Either String InstallPlan
resolveDependencies platform comp installed available
                    preferences constraints targets =
  foldProgress (flip const) Left Right $
    resolveDependenciesWithProgress
      platform comp installed available
      preferences constraints targets

resolveDependenciesWithProgress :: Platform
                                -> CompilerId
                                -> PackageIndex InstalledPackage
                                -> PackageIndex AvailablePackage
                                -> PackagesPreference
                                -> [PackageConstraint]
                                -> [PackageName]
                                -> Progress String String InstallPlan
resolveDependenciesWithProgress platform comp installed available
                                pref constraints targets
    -- TODO: the top down resolver chokes on the base constraints
    -- below when there are no targets and thus no dep on base.
    -- Need to refactor contraints separate from needing packages.
  | null targets = return (toPlan [])
  | otherwise    =
  let installed' = hideBrokenPackages installed
      -- If the user is not explicitly asking to upgrade base then lets
      -- prevent that from happening accidentally since it is usually not what
      -- you want and it probably does not work anyway. We do it by adding a
      -- constraint to only pick an installed version of base and ghc-prim.
      extraConstraints =
        [ PackageInstalledConstraint pkgname
        | all (/=PackageName "base") targets
        , pkgname <-  [ PackageName "base", PackageName "ghc-prim" ]
        , not (null (PackageIndex.lookupPackageName installed pkgname)) ]
      preferences = interpretPackagesPreference (Set.fromList targets) pref
   in fmap toPlan
    $ defaultResolver platform comp installed' available
                      preferences (extraConstraints ++ constraints) targets

  where
    toPlan pkgs =
      case InstallPlan.new platform comp (PackageIndex.fromList pkgs) of
        Right plan     -> plan
        Left  problems -> error $ unlines $
            "internal error: could not construct a valid install plan."
          : "The proposed (invalid) plan contained the following problems:"
          : map InstallPlan.showPlanProblem problems

hideBrokenPackages :: PackageFixedDeps p => PackageIndex p -> PackageIndex p
hideBrokenPackages index =
    check (null . PackageIndex.brokenPackages)
  . foldr (PackageIndex.deletePackageId . packageId) index
  . PackageIndex.reverseDependencyClosure index
  . map (packageId . fst)
  $ PackageIndex.brokenPackages index
  where
    check p x = assert (p x) x

-- | Give an interpretation to the global 'PackagesPreference' as
--  specific per-package 'PackageVersionPreference'.
--
interpretPackagesPreference :: Set PackageName
                            -> PackagesPreference
                            -> (PackageName -> PackagePreferences)
interpretPackagesPreference selected (PackagesPreference defaultPref prefs) =
  \pkgname -> PackagePreferences (versionPref pkgname) (installPref pkgname)

  where
    versionPref pkgname =
      fromMaybe anyVersion (Map.lookup pkgname versionPrefs)
    versionPrefs = Map.fromList
      [ (pkgname, pref)
      | PackageVersionPreference pkgname pref <- prefs ]

    installPref pkgname =
      fromMaybe (installPrefDefault pkgname) (Map.lookup pkgname installPrefs)
    installPrefs = Map.fromList
      [ (pkgname, pref)
      | PackageInstalledPreference pkgname pref <- prefs ]
    installPrefDefault = case defaultPref of
      PreferAllLatest         -> \_       -> PreferLatest
      PreferAllInstalled      -> \_       -> PreferInstalled
      PreferLatestForSelected -> \pkgname ->
        -- When you say cabal install foo, what you really mean is, prefer the
        -- latest version of foo, but the installed version of everything else
        if pkgname `Set.member` selected then PreferLatest
                                         else PreferInstalled

-- ------------------------------------------------------------
-- * Simple resolver that ignores dependencies
-- ------------------------------------------------------------

-- | A simplistic method of resolving a list of target package names to
-- available packages.
--
-- Specifically, it does not consider package dependencies at all. Unlike
-- 'resolveDependencies', no attempt is made to ensure that the selected
-- packages have dependencies that are satisfiable or consistent with
-- each other.
--
-- It is suitable for tasks such as selecting packages to download for user
-- inspection. It is not suitable for selecting packages to install.
--
-- Note: if no installed package index is available, it is ok to pass 'mempty'.
-- It simply means preferences for installed packages will be ignored.
--
resolveAvailablePackages
  :: PackageIndex InstalledPackage
  -> PackageIndex AvailablePackage
  -> PackagesPreference
  -> [PackageConstraint]
  -> [PackageName]
  -> Either [ResolveNoDepsError] [AvailablePackage]
resolveAvailablePackages installed available preferences constraints targets =
    collectEithers (map selectPackage targets)
  where
    selectPackage :: PackageName -> Either ResolveNoDepsError AvailablePackage
    selectPackage pkgname
      | null choices = Left  $! ResolveUnsatisfiable pkgname requiredVersions
      | otherwise    = Right $! maximumBy bestByPrefs choices

      where
        -- Constraints
        requiredVersions = packageConstraints pkgname
        pkgDependency    = Dependency pkgname requiredVersions
        choices          = PackageIndex.lookupDependency available pkgDependency

        -- Preferences
        PackagePreferences preferredVersions preferInstalled
          = packagePreferences pkgname

        bestByPrefs   = comparing $ \pkg ->
                          (installPref pkg, versionPref pkg, packageVersion pkg)
        installPref   = case preferInstalled of
          PreferLatest    -> const False
          PreferInstalled -> isJust . PackageIndex.lookupPackageId installed
                           . packageId
        versionPref   pkg = packageVersion pkg `withinRange` preferredVersions

    packageConstraints :: PackageName -> VersionRange
    packageConstraints pkgname =
      Map.findWithDefault anyVersion pkgname packageVersionConstraintMap
    packageVersionConstraintMap =
      Map.fromList [ (name, range)
                   | PackageVersionConstraint name range <- constraints ]

    packagePreferences :: PackageName -> PackagePreferences
    packagePreferences = interpretPackagesPreference (Set.fromList targets) preferences


collectEithers :: [Either a b] -> Either [a] [b]
collectEithers = collect . partitionEithers
  where
    collect ([], xs) = Right xs
    collect (errs,_) = Left errs
    partitionEithers :: [Either a b] -> ([a],[b])
    partitionEithers = foldr (either left right) ([],[])
     where
       left  a (l, r) = (a:l, r)
       right a (l, r) = (l, a:r)

-- | Errors for 'resolveWithoutDependencies'.
--
data ResolveNoDepsError =

     -- | A package name which cannot be resolved to a specific package.
     -- Also gives the constraint on the version and whether there was
     -- a constraint on the package being installed.
     ResolveUnsatisfiable PackageName VersionRange

instance Show ResolveNoDepsError where
  show (ResolveUnsatisfiable name ver) =
       "There is no available version of " ++ display name
    ++ " that satisfies " ++ display (simplifyVersionRange ver)

-- ------------------------------------------------------------
-- * Finding upgradable packages
-- ------------------------------------------------------------

-- | Given the list of installed packages and available packages, figure
-- out which packages can be upgraded.
--
upgradableDependencies :: PackageIndex InstalledPackage
                       -> PackageIndex AvailablePackage
                       -> [Dependency]
upgradableDependencies installed available =
  [ Dependency name (orLaterVersion latestVersion)
    -- This is really quick (linear time). The trick is that we're doing a
    -- merge join of two tables. We can do it as a merge because they're in
    -- a comparable order because we're getting them from the package indexs.
  | InBoth latestInstalled allAvailable
      <- mergeBy (\a (b:_) -> packageName a `compare` packageName b)
                 [ maximumBy (comparing packageVersion) pkgs
                 | pkgs <- PackageIndex.allPackagesByName installed ]
                 (PackageIndex.allPackagesByName available)
  , let (PackageIdentifier name latestVersion) = packageId latestInstalled
  , any (\p -> packageVersion p > latestVersion) allAvailable ]