Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Upgrade bundled cabal-install from 0.6.0 to 0.6.2

  • Loading branch information...
commit e199c3885807280cc4c52fd812c668db2274015b 1 parent 9561cde
@kolmodin kolmodin authored
Showing with 2,199 additions and 995 deletions.
  1. +0 −183 cabal-install-0.6.0/Distribution/Client/List.hs
  2. +0 −43 cabal-install-0.6.0/Distribution/Client/Update.hs
  3. +0 −60 cabal-install-0.6.0/bootstrap.sh
  4. +0 −29 cabal-install-0.6.0/dist/build/autogen/Paths_cabal_install.hs
  5. +0 −92 cabal-install-0.6.0/dist/build/autogen/cabal_macros.h
  6. 0  {cabal-install-0.6.0 → cabal-install-0.6.2}/Distribution/Client/BuildReports/Anonymous.hs
  7. +33 −21 {cabal-install-0.6.0 → cabal-install-0.6.2}/Distribution/Client/BuildReports/Storage.hs
  8. +44 −0 cabal-install-0.6.2/Distribution/Client/BuildReports/Types.hs
  9. +7 −3 {cabal-install-0.6.0 → cabal-install-0.6.2}/Distribution/Client/BuildReports/Upload.hs
  10. 0  {cabal-install-0.6.0 → cabal-install-0.6.2}/Distribution/Client/Check.hs
  11. +69 −19 {cabal-install-0.6.0 → cabal-install-0.6.2}/Distribution/Client/Config.hs
  12. +210 −0 cabal-install-0.6.2/Distribution/Client/Configure.hs
  13. +87 −62 {cabal-install-0.6.0 → cabal-install-0.6.2}/Distribution/Client/Dependency.hs
  14. +47 −25 {cabal-install-0.6.0 → cabal-install-0.6.2}/Distribution/Client/Dependency/Bogus.hs
  15. +158 −74 {cabal-install-0.6.0 → cabal-install-0.6.2}/Distribution/Client/Dependency/TopDown.hs
  16. +66 −21 {cabal-install-0.6.0 → cabal-install-0.6.2}/Distribution/Client/Dependency/TopDown/Constraints.hs
  17. 0  {cabal-install-0.6.0 → cabal-install-0.6.2}/Distribution/Client/Dependency/TopDown/Types.hs
  18. +24 −20 {cabal-install-0.6.0 → cabal-install-0.6.2}/Distribution/Client/Dependency/Types.hs
  19. +20 −11 {cabal-install-0.6.0 → cabal-install-0.6.2}/Distribution/Client/Fetch.hs
  20. +25 −11 {cabal-install-0.6.0 → cabal-install-0.6.2}/Distribution/Client/HttpUtils.hs
  21. +25 −1 {cabal-install-0.6.0 → cabal-install-0.6.2}/Distribution/Client/IndexUtils.hs
  22. +193 −121 {cabal-install-0.6.0 → cabal-install-0.6.2}/Distribution/Client/Install.hs
  23. +18 −21 {cabal-install-0.6.0 → cabal-install-0.6.2}/Distribution/Client/InstallPlan.hs
  24. +3 −2 {cabal-install-0.6.0 → cabal-install-0.6.2}/Distribution/Client/InstallSymlink.hs
  25. +367 −0 cabal-install-0.6.2/Distribution/Client/List.hs
  26. +209 −61 {cabal-install-0.6.0 → cabal-install-0.6.2}/Distribution/Client/Setup.hs
  27. +10 −3 {cabal-install-0.6.0 → cabal-install-0.6.2}/Distribution/Client/SetupWrapper.hs
  28. +7 −10 {cabal-install-0.6.0 → cabal-install-0.6.2}/Distribution/Client/SrcDist.hs
  29. +23 −15 {cabal-install-0.6.0 → cabal-install-0.6.2}/Distribution/Client/Tar.hs
  30. 0  {cabal-install-0.6.0 → cabal-install-0.6.2}/Distribution/Client/Types.hs
  31. +98 −0 cabal-install-0.6.2/Distribution/Client/Unpack.hs
  32. +73 −0 cabal-install-0.6.2/Distribution/Client/Update.hs
  33. +14 −9 {cabal-install-0.6.0 → cabal-install-0.6.2}/Distribution/Client/Upload.hs
  34. +11 −2 {cabal-install-0.6.0 → cabal-install-0.6.2}/Distribution/Client/Utils.hs
  35. +0 −3  {cabal-install-0.6.0 → cabal-install-0.6.2}/Distribution/Client/Win32SelfUpgrade.hs
  36. +28 −0 cabal-install-0.6.2/Distribution/Compat/TempFile.hs
  37. 0  {cabal-install-0.6.0 → cabal-install-0.6.2}/LICENSE
  38. +106 −59 {cabal-install-0.6.0 → cabal-install-0.6.2}/Main.hs
  39. +1 −1  {cabal-install-0.6.0 → cabal-install-0.6.2}/Paths_cabal_install.hs
  40. +10 −7 {cabal-install-0.6.0 → cabal-install-0.6.2}/README
  41. 0  {cabal-install-0.6.0 → cabal-install-0.6.2}/Setup.hs
  42. 0  {cabal-install-0.6.0 → cabal-install-0.6.2}/bash-completion/cabal
  43. +198 −0 cabal-install-0.6.2/bootstrap.sh
  44. +14 −5 {cabal-install-0.6.0 → cabal-install-0.6.2}/cabal-install.cabal
  45. +1 −1  hackport.cabal
View
183 cabal-install-0.6.0/Distribution/Client/List.hs
@@ -1,183 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Distribution.Client.Install
--- Copyright : (c) David Himmelstrup 2005
--- License : BSD-like
---
--- Maintainer : lemmih@gmail.com
--- Stability : provisional
--- Portability : portable
---
--- High level interface to package installation.
------------------------------------------------------------------------------
-module Distribution.Client.List (
- list
- ) where
-
-import Data.List (sortBy, groupBy, sort, nub, intersperse)
-import Data.Maybe (listToMaybe, fromJust)
-import Control.Monad (MonadPlus(mplus))
-import Control.Exception (assert)
-
-import Text.PrettyPrint.HughesPJ
-import Distribution.Text
- ( Text(disp), display )
-
-import Distribution.Package
- ( PackageIdentifier(..), PackageName(..), Package(..) )
-import Distribution.License (License)
-import qualified Distribution.PackageDescription as Available
-import Distribution.InstalledPackageInfo (InstalledPackageInfo)
-import qualified Distribution.InstalledPackageInfo as Installed
-import qualified Distribution.Simple.PackageIndex as PackageIndex
-import Distribution.Version (Version)
-import Distribution.Verbosity (Verbosity)
-
-import Distribution.Client.IndexUtils (getAvailablePackages)
-import Distribution.Client.Setup (ListFlags(..))
-import Distribution.Client.Types
- ( AvailablePackage(..), Repo, AvailablePackageDb(..) )
-import Distribution.Simple.Configure (getInstalledPackages)
-import Distribution.Simple.Compiler (Compiler,PackageDB)
-import Distribution.Simple.Program (ProgramConfiguration)
-import Distribution.Simple.Utils (equating, comparing, notice)
-import Distribution.Simple.Setup (fromFlag)
-
-import Distribution.Client.Utils (mergeBy, MergeResult(..))
-
--- |Show information about packages
-list :: Verbosity
- -> PackageDB
- -> [Repo]
- -> Compiler
- -> ProgramConfiguration
- -> ListFlags
- -> [String]
- -> IO ()
-list verbosity packageDB repos comp conf listFlags pats = do
- Just installed <- getInstalledPackages verbosity comp packageDB conf
- AvailablePackageDb available _ <- getAvailablePackages verbosity repos
- let pkgs | null pats = (PackageIndex.allPackages installed
- ,PackageIndex.allPackages available)
- | otherwise =
- (concatMap (PackageIndex.searchByNameSubstring installed) pats
- ,concatMap (PackageIndex.searchByNameSubstring available) pats)
- matches = installedFilter
- . map (uncurry mergePackageInfo)
- $ uncurry mergePackages pkgs
-
- if simpleOutput
- then putStr $ unlines
- [ display(name pkg) ++ " " ++ display version
- | pkg <- matches
- , version <- if onlyInstalled
- then installedVersions pkg
- else nub . sort $ installedVersions pkg
- ++ availableVersions pkg ]
- else
- if null matches
- then notice verbosity "No matches found."
- else putStr $ unlines (map showPackageInfo matches)
- where
- installedFilter
- | onlyInstalled = filter (not . null . installedVersions)
- | otherwise = id
- onlyInstalled = fromFlag (listInstalled listFlags)
- simpleOutput = fromFlag (listSimpleOutput listFlags)
-
--- | The info that we can display for each package. It is information per
--- package name and covers all installed and avilable versions.
---
-data PackageDisplayInfo = PackageDisplayInfo {
- name :: PackageName,
- installedVersions :: [Version],
- availableVersions :: [Version],
- homepage :: String,
- category :: String,
- synopsis :: String,
- license :: License
- }
-
-showPackageInfo :: PackageDisplayInfo -> String
-showPackageInfo pkg =
- renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $
- text " *" <+> disp (name pkg)
- $+$
- (nest 6 $ vcat [
- maybeShow (availableVersions pkg)
- "Latest version available:"
- (disp . maximum)
- , maybeShow (installedVersions pkg)
- "Latest version installed:"
- (disp . maximum)
- , maybeShow (homepage pkg) "Homepage:" text
- , maybeShow (category pkg) "Category:" text
- , maybeShow (synopsis pkg) "Synopsis:" reflowParas
- , text "License: " <+> text (show (license pkg))
- ])
- $+$ text ""
- where
- maybeShow [] _ _ = empty
- maybeShow l s f = text s <+> (f l)
- reflowParas = vcat
- . intersperse (text "") -- re-insert blank lines
- . map (fsep . map text . concatMap words) -- reflow paras
- . filter (/= [""])
- . groupBy (\x y -> "" `notElem` [x,y]) -- break on blank lines
- . lines
-
--- | We get the 'PackageDisplayInfo' by combining the info for the installed
--- and available versions of a package.
---
--- * We're building info about a various versions of a single named package so
--- the input package info records are all supposed to refer to the same
--- package name.
---
-mergePackageInfo :: [InstalledPackageInfo]
- -> [AvailablePackage]
- -> PackageDisplayInfo
-mergePackageInfo installed available =
- assert (length installed + length available > 0) $
- PackageDisplayInfo {
- name = combine (pkgName . packageId) latestAvailable
- (pkgName . packageId) latestInstalled,
- installedVersions = map (pkgVersion . packageId) installed,
- availableVersions = map (pkgVersion . packageId) available,
- homepage = combine Available.homepage latestAvailableDesc
- Installed.homepage latestInstalled,
- category = combine Available.category latestAvailableDesc
- Installed.category latestInstalled,
- synopsis = combine Available.synopsis latestAvailableDesc
- Installed.description latestInstalled,
- license = combine Available.license latestAvailableDesc
- Installed.license latestInstalled
- }
- where
- combine f x g y = fromJust (fmap f x `mplus` fmap g y)
- latestInstalled = latestOf installed
- latestAvailable = latestOf available
- latestAvailableDesc = fmap (Available.packageDescription . packageDescription)
- latestAvailable
- latestOf :: Package pkg => [pkg] -> Maybe pkg
- latestOf = listToMaybe . sortBy (comparing (pkgVersion . packageId))
-
--- | Rearrange installed and available packages into groups referring to the
--- same package by name. In the result pairs, the lists are guaranteed to not
--- both be empty.
---
-mergePackages :: [InstalledPackageInfo] -> [AvailablePackage]
- -> [([InstalledPackageInfo], [AvailablePackage])]
-mergePackages installed available =
- map collect
- $ mergeBy (\i a -> fst i `compare` fst a)
- (groupOn (pkgName . packageId) installed)
- (groupOn (pkgName . packageId) available)
- where
- collect (OnlyInLeft (_,is) ) = (is, [])
- collect ( InBoth (_,is) (_,as)) = (is, as)
- collect (OnlyInRight (_,as)) = ([], as)
-
-groupOn :: Ord key => (a -> key) -> [a] -> [(key,[a])]
-groupOn key = map (\xs -> (key (head xs), xs))
- . groupBy (equating key)
- . sortBy (comparing key)
View
43 cabal-install-0.6.0/Distribution/Client/Update.hs
@@ -1,43 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Distribution.Client.Update
--- Copyright : (c) David Himmelstrup 2005
--- License : BSD-like
---
--- Maintainer : lemmih@gmail.com
--- Stability : provisional
--- Portability : portable
---
---
------------------------------------------------------------------------------
-module Distribution.Client.Update
- ( update
- ) where
-
-import Distribution.Client.Types
- ( Repo(..), RemoteRepo(..), LocalRepo(..) )
-import Distribution.Client.Fetch
- ( downloadIndex )
-import qualified Distribution.Client.Utils as BS
- ( writeFileAtomic )
-
-import Distribution.Simple.Utils (notice)
-import Distribution.Verbosity (Verbosity)
-
-import qualified Data.ByteString.Lazy as BS
-import qualified Codec.Compression.GZip as GZip (decompress)
-import System.FilePath (dropExtension)
-
--- | 'update' downloads the package list from all known servers
-update :: Verbosity -> [Repo] -> IO ()
-update verbosity = mapM_ (updateRepo verbosity)
-
-updateRepo :: Verbosity -> Repo -> IO ()
-updateRepo verbosity repo = case repoKind repo of
- Right LocalRepo -> return ()
- Left remoteRepo -> do
- notice verbosity $ "Downloading package list from server '"
- ++ show (remoteRepoURI remoteRepo) ++ "'"
- indexPath <- downloadIndex verbosity remoteRepo (repoLocalDir repo)
- BS.writeFileAtomic (dropExtension indexPath) . GZip.decompress
- =<< BS.readFile indexPath
View
60 cabal-install-0.6.0/bootstrap.sh
@@ -1,60 +0,0 @@
-#!/bin/sh
-
-# A script to bootstrap cabal-install.
-
-# It works by downloading and installing the Cabal, zlib and
-# HTTP packages. It then installs cabal-install itself.
-# It expects to be run inside the cabal-install directory.
-
-CABAL_VER="1.6.0.1"
-HTTP_VER="3001.1.3"
-ZLIB_VER="0.4.0.4"
-
-HACKAGE_URL="http://hackage.haskell.org/packages/archive"
-CABAL_URL=${HACKAGE_URL}/Cabal/${CABAL_VER}/Cabal-${CABAL_VER}.tar.gz
-HTTP_URL=${HACKAGE_URL}/HTTP/${HTTP_VER}/HTTP-${HTTP_VER}.tar.gz
-ZLIB_URL=${HACKAGE_URL}/zlib/${ZLIB_VER}/zlib-${ZLIB_VER}.tar.gz
-
-case `which wget curl` in
- *curl)
- curl -O ${CABAL_URL} -O ${HTTP_URL} -O ${ZLIB_URL}
- ;;
- *wget)
- wget -c ${CABAL_URL} ${HTTP_URL} ${ZLIB_URL}
- ;;
- *)
- echo "Failed to find a downloader. 'wget' or 'curl' is required." >&2
- exit 2
- ;;
-esac
-
-tar -zxf Cabal-${CABAL_VER}.tar.gz
-cd Cabal-${CABAL_VER}
-ghc --make Setup
-./Setup configure --user && ./Setup build && ./Setup install
-cd ..
-
-tar -zxf HTTP-${HTTP_VER}.tar.gz
-cd HTTP-${HTTP_VER}
-runghc Setup configure --user && runghc Setup build && runghc Setup install
-cd ..
-
-tar -zxf zlib-${ZLIB_VER}.tar.gz
-cd zlib-${ZLIB_VER}
-runghc Setup configure --user && runghc Setup build && runghc Setup install
-cd ..
-
-runghc Setup configure --user && runghc Setup build && runghc Setup install
-
-CABAL_BIN="$HOME/.cabal/bin"
-echo
-
-if [ -x "$CABAL_BIN/cabal" ]
-then
- echo "cabal successfully installed in $CABAL_BIN."
- echo "You may want to add $CABAL_BIN to your PATH."
-else
- echo "Sorry, something went wrong."
-fi
-
-echo
View
29 cabal-install-0.6.0/dist/build/autogen/Paths_cabal_install.hs
@@ -1,29 +0,0 @@
-module Paths_cabal_install (
- version,
- getBinDir, getLibDir, getDataDir, getLibexecDir,
- getDataFileName
- ) where
-
-import Data.Version (Version(..))
-import System.Environment (getEnv)
-
-version :: Version
-version = Version {versionBranch = [0,6,0], versionTags = []}
-
-bindir, libdir, datadir, libexecdir :: FilePath
-
-bindir = "/home/kolmodin/.cabal/bin"
-libdir = "/home/kolmodin/.cabal/lib/cabal-install-0.6.0/ghc-6.8.3"
-datadir = "/home/kolmodin/.cabal/share/cabal-install-0.6.0"
-libexecdir = "/home/kolmodin/.cabal/libexec"
-
-getBinDir, getLibDir, getDataDir, getLibexecDir :: IO FilePath
-getBinDir = catch (getEnv "cabal_install_bindir") (\_ -> return bindir)
-getLibDir = catch (getEnv "cabal_install_libdir") (\_ -> return libdir)
-getDataDir = catch (getEnv "cabal_install_datadir") (\_ -> return datadir)
-getLibexecDir = catch (getEnv "cabal_install_libexecdir") (\_ -> return libexecdir)
-
-getDataFileName :: FilePath -> IO FilePath
-getDataFileName name = do
- dir <- getDataDir
- return (dir ++ "/" ++ name)
View
92 cabal-install-0.6.0/dist/build/autogen/cabal_macros.h
@@ -1,92 +0,0 @@
-/* DO NOT EDIT: This file is automatically generated by Cabal */
-
-/* package Cabal-1.6.0.1 */
-#define MIN_VERSION_Cabal(major1,major2,minor) \
- (major1) < 1 || \
- (major1) == 1 && (major2) < 6 || \
- (major1) == 1 && (major2) == 6 && (minor) <= 0
-
-/* package HTTP-3001.1.3 */
-#define MIN_VERSION_HTTP(major1,major2,minor) \
- (major1) < 3001 || \
- (major1) == 3001 && (major2) < 1 || \
- (major1) == 3001 && (major2) == 1 && (minor) <= 3
-
-/* package array-0.1.0.0 */
-#define MIN_VERSION_array(major1,major2,minor) \
- (major1) < 0 || \
- (major1) == 0 && (major2) < 1 || \
- (major1) == 0 && (major2) == 1 && (minor) <= 0
-
-/* package base-3.0.2.0 */
-#define MIN_VERSION_base(major1,major2,minor) \
- (major1) < 3 || \
- (major1) == 3 && (major2) < 0 || \
- (major1) == 3 && (major2) == 0 && (minor) <= 2
-
-/* package bytestring-0.9.1.3 */
-#define MIN_VERSION_bytestring(major1,major2,minor) \
- (major1) < 0 || \
- (major1) == 0 && (major2) < 9 || \
- (major1) == 0 && (major2) == 9 && (minor) <= 1
-
-/* package containers-0.1.0.2 */
-#define MIN_VERSION_containers(major1,major2,minor) \
- (major1) < 0 || \
- (major1) == 0 && (major2) < 1 || \
- (major1) == 0 && (major2) == 1 && (minor) <= 0
-
-/* package directory-1.0.0.1 */
-#define MIN_VERSION_directory(major1,major2,minor) \
- (major1) < 1 || \
- (major1) == 1 && (major2) < 0 || \
- (major1) == 1 && (major2) == 0 && (minor) <= 0
-
-/* package filepath-1.1.0.0 */
-#define MIN_VERSION_filepath(major1,major2,minor) \
- (major1) < 1 || \
- (major1) == 1 && (major2) < 1 || \
- (major1) == 1 && (major2) == 1 && (minor) <= 0
-
-/* package network-2.2.0.0 */
-#define MIN_VERSION_network(major1,major2,minor) \
- (major1) < 2 || \
- (major1) == 2 && (major2) < 2 || \
- (major1) == 2 && (major2) == 2 && (minor) <= 0
-
-/* package old-time-1.0.0.0 */
-#define MIN_VERSION_old_time(major1,major2,minor) \
- (major1) < 1 || \
- (major1) == 1 && (major2) < 0 || \
- (major1) == 1 && (major2) == 0 && (minor) <= 0
-
-/* package pretty-1.0.0.0 */
-#define MIN_VERSION_pretty(major1,major2,minor) \
- (major1) < 1 || \
- (major1) == 1 && (major2) < 0 || \
- (major1) == 1 && (major2) == 0 && (minor) <= 0
-
-/* package process-1.0.0.1 */
-#define MIN_VERSION_process(major1,major2,minor) \
- (major1) < 1 || \
- (major1) == 1 && (major2) < 0 || \
- (major1) == 1 && (major2) == 0 && (minor) <= 0
-
-/* package random-1.0.0.0 */
-#define MIN_VERSION_random(major1,major2,minor) \
- (major1) < 1 || \
- (major1) == 1 && (major2) < 0 || \
- (major1) == 1 && (major2) == 0 && (minor) <= 0
-
-/* package unix-2.3.0.1 */
-#define MIN_VERSION_unix(major1,major2,minor) \
- (major1) < 2 || \
- (major1) == 2 && (major2) < 3 || \
- (major1) == 2 && (major2) == 3 && (minor) <= 0
-
-/* package zlib-0.4.0.4 */
-#define MIN_VERSION_zlib(major1,major2,minor) \
- (major1) < 0 || \
- (major1) == 0 && (major2) < 4 || \
- (major1) == 0 && (major2) == 4 && (minor) <= 0
-
View
0  ...6.0/Distribution/Client/BuildReports/Anonymous.hs → ...6.2/Distribution/Client/BuildReports/Anonymous.hs
File renamed without changes
View
54 ...0.6.0/Distribution/Client/BuildReports/Storage.hs → ...0.6.2/Distribution/Client/BuildReports/Storage.hs
@@ -31,11 +31,12 @@ import Distribution.Client.Types
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.InstallPlan
( InstallPlan, PlanPackage )
-import Distribution.Client.Config
- ( defaultLogsDir )
+import Distribution.Simple.InstallDirs
+ ( PathTemplate, fromPathTemplate
+ , initialPathTemplateEnv, substPathTemplate )
import Distribution.System
- ( OS, Arch )
+ ( Platform(Platform) )
import Distribution.Compiler
( CompilerId )
import Distribution.Simple.Utils
@@ -46,7 +47,7 @@ import Data.List
import Data.Maybe
( catMaybes )
import System.FilePath
- ( (</>) )
+ ( (</>), takeDirectory )
import System.Directory
( createDirectoryIfMissing )
@@ -75,18 +76,30 @@ storeAnonymous reports = sequence_
[ (report, repo, remoteRepo)
| (report, repo@Repo { repoKind = Left remoteRepo }) <- rs ]
-storeLocal :: [(BuildReport, Repo)] -> IO ()
-storeLocal reports = do
- logsDir <- defaultLogsDir
- let file = logsDir </> "build.log"
- createDirectoryIfMissing True logsDir
- appendFile file (concatMap (format . fst) reports)
- --TODO: make this concurrency safe, either lock the report file or make sure
- -- the writes for each report are atomic (under 4k and flush at boundaries)
-
+storeLocal :: [PathTemplate] -> [(BuildReport, Repo)] -> IO ()
+storeLocal templates reports = sequence_
+ [ do createDirectoryIfMissing True (takeDirectory file)
+ appendFile file output
+ --TODO: make this concurrency safe, either lock the report file or make
+ -- sure the writes for each report are atomic
+ | (file, reports') <- groupByFileName
+ [ (reportFileName template report, report)
+ | template <- templates
+ , (report, _repo) <- reports ]
+ , let output = concatMap format reports'
+ ]
where
format r = '\n' : BuildReport.show r ++ "\n"
+ reportFileName template report =
+ fromPathTemplate (substPathTemplate env template)
+ where env = initialPathTemplateEnv
+ (BuildReport.package report)
+ (BuildReport.compiler report)
+
+ groupByFileName = map (\grp@((filename,_):_) -> (filename, map snd grp))
+ . groupBy (equating fst)
+ . sortBy (comparing fst)
-- ------------------------------------------------------------
-- * InstallPlan support
@@ -94,24 +107,23 @@ storeLocal reports = do
fromInstallPlan :: InstallPlan -> [(BuildReport, Repo)]
fromInstallPlan plan = catMaybes
- . map (fromPlanPackage os' arch' comp)
+ . map (fromPlanPackage platform comp)
. InstallPlan.toList
$ plan
- where os' = InstallPlan.planOS plan
- arch' = InstallPlan.planArch plan
- comp = InstallPlan.planCompiler plan
+ where platform = InstallPlan.planPlatform plan
+ comp = InstallPlan.planCompiler plan
-fromPlanPackage :: OS -> Arch -> CompilerId
+fromPlanPackage :: Platform -> CompilerId
-> InstallPlan.PlanPackage
-> Maybe (BuildReport, Repo)
-fromPlanPackage os' arch' comp planPackage = case planPackage of
+fromPlanPackage (Platform arch os) comp planPackage = case planPackage of
InstallPlan.Installed pkg@(ConfiguredPackage (AvailablePackage {
packageSource = RepoTarballPackage repo }) _ _) result
- -> Just $ (BuildReport.new os' arch' comp pkg (Right result), repo)
+ -> Just $ (BuildReport.new os arch comp pkg (Right result), repo)
InstallPlan.Failed pkg@(ConfiguredPackage (AvailablePackage {
packageSource = RepoTarballPackage repo }) _ _) result
- -> Just $ (BuildReport.new os' arch' comp pkg (Left result), repo)
+ -> Just $ (BuildReport.new os arch comp pkg (Left result), repo)
_ -> Nothing
View
44 cabal-install-0.6.2/Distribution/Client/BuildReports/Types.hs
@@ -0,0 +1,44 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Client.BuildReports.Types
+-- Copyright : (c) Duncan Coutts 2009
+-- License : BSD-like
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Portability : portable
+--
+-- Types related to build reporting
+--
+-----------------------------------------------------------------------------
+module Distribution.Client.BuildReports.Types (
+ ReportLevel(..),
+ ) where
+
+import qualified Distribution.Text as Text
+ ( Text(disp, parse) )
+
+import qualified Distribution.Compat.ReadP as Parse
+ ( pfail, munch1 )
+import qualified Text.PrettyPrint.HughesPJ as Disp
+ ( text )
+
+import Data.Char as Char
+ ( isAlpha, toLower )
+
+data ReportLevel = NoReports | AnonymousReports | DetailedReports
+ deriving (Eq, Ord, Show)
+
+instance Text.Text ReportLevel where
+ disp NoReports = Disp.text "none"
+ disp AnonymousReports = Disp.text "anonymous"
+ disp DetailedReports = Disp.text "detailed"
+ parse = do
+ name <- Parse.munch1 Char.isAlpha
+ case lowercase name of
+ "none" -> return NoReports
+ "anonymous" -> return AnonymousReports
+ "detailed" -> return DetailedReports
+ _ -> Parse.pfail
+
+lowercase :: String -> String
+lowercase = map Char.toLower
View
10 ...-0.6.0/Distribution/Client/BuildReports/Upload.hs → ...-0.6.2/Distribution/Client/BuildReports/Upload.hs
@@ -14,6 +14,7 @@ import Network.Browser
import Network.HTTP
( Header(..), HeaderName(..)
, Request(..), RequestMethod(..), Response(..) )
+import Network.TCP (HandleStream)
import Network.URI (URI, uriPath, parseRelativeReference, relativeTo)
import Control.Monad
@@ -26,7 +27,8 @@ import Distribution.Client.BuildReports.Anonymous (BuildReport)
type BuildReportId = URI
type BuildLog = String
-uploadReports :: URI -> [(BuildReport, Maybe BuildLog)] -> BrowserAction ()
+uploadReports :: URI -> [(BuildReport, Maybe BuildLog)]
+ -> BrowserAction (HandleStream BuildLog) ()
uploadReports uri reports
= forM_ reports $ \(report, mbBuildLog) ->
do buildId <- postBuildReport uri report
@@ -34,7 +36,8 @@ uploadReports uri reports
Just buildLog -> putBuildLog buildId buildLog
Nothing -> return ()
-postBuildReport :: URI -> BuildReport -> BrowserAction BuildReportId
+postBuildReport :: URI -> BuildReport
+ -> BrowserAction (HandleStream BuildLog) BuildReportId
postBuildReport uri buildReport = do
setAllowRedirects False
(_, response) <- request Request {
@@ -53,7 +56,8 @@ postBuildReport uri buildReport = do
_ -> error "Unrecognised response from server."
where body = BuildReport.show buildReport
-putBuildLog :: BuildReportId -> BuildLog -> BrowserAction ()
+putBuildLog :: BuildReportId -> BuildLog
+ -> BrowserAction (HandleStream BuildLog) ()
putBuildLog reportId buildLog = do
--FIXME: do something if the request fails
(_, response) <- request Request {
View
0  cabal-install-0.6.0/Distribution/Client/Check.hs → cabal-install-0.6.2/Distribution/Client/Check.hs
File renamed without changes
View
88 cabal-install-0.6.0/Distribution/Client/Config.hs → cabal-install-0.6.2/Distribution/Client/Config.hs
@@ -19,6 +19,7 @@ module Distribution.Client.Config (
parseConfig,
defaultCabalDir,
+ defaultConfigFile,
defaultCacheDir,
defaultLogsDir,
) where
@@ -26,8 +27,11 @@ module Distribution.Client.Config (
import Distribution.Client.Types
( RemoteRepo(..), Username(..), Password(..) )
+import Distribution.Client.BuildReports.Types
+ ( ReportLevel(..) )
import Distribution.Client.Setup
( GlobalFlags(..), globalCommand
+ , ConfigExFlags(..), configureExOptions, defaultConfigExFlags
, InstallFlags(..), installOptions, defaultInstallFlags
, UploadFlags(..), uploadCommand
, showRepo, parseRepo )
@@ -42,11 +46,13 @@ import Distribution.ParseUtils
( FieldDescr(..), liftField
, ParseResult(..), locatedErrorMsg, showPWarning
, readFields, warning, lineNo
- , simpleField, listField, parseFilePathQ, parseTokenQ )
+ , simpleField, listField, parseFilePathQ, showFilePath, parseTokenQ )
import qualified Distribution.ParseUtils as ParseUtils
( Field(..) )
+import qualified Distribution.Text as Text
+ ( Text(..) )
import Distribution.ReadE
- ( succeedReadE )
+ ( readP_to_E )
import Distribution.Simple.Command
( CommandUI(commandOptions), commandDefaultFlags, ShowOrParseArgs(..)
, viewAsFieldDescr, OptionField, option, reqArg )
@@ -62,7 +68,7 @@ import Distribution.Verbosity
( Verbosity, normal )
import Data.List
- ( partition )
+ ( partition, find )
import Data.Maybe
( fromMaybe )
import Data.Monoid
@@ -73,7 +79,7 @@ import qualified Data.Map as Map
import qualified Distribution.Compat.ReadP as Parse
( option )
import qualified Text.PrettyPrint.HughesPJ as Disp
- ( Doc, render, text, colon, vcat, isEmpty, nest )
+ ( Doc, render, text, colon, vcat, empty, isEmpty, nest )
import Text.PrettyPrint.HughesPJ
( (<>), (<+>), ($$), ($+$) )
import System.Directory
@@ -93,6 +99,7 @@ data SavedConfig = SavedConfig {
savedGlobalFlags :: GlobalFlags,
savedInstallFlags :: InstallFlags,
savedConfigureFlags :: ConfigFlags,
+ savedConfigureExFlags :: ConfigExFlags,
savedUserInstallDirs :: InstallDirs (Flag PathTemplate),
savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate),
savedUploadFlags :: UploadFlags
@@ -103,6 +110,7 @@ instance Monoid SavedConfig where
savedGlobalFlags = mempty,
savedInstallFlags = mempty,
savedConfigureFlags = mempty,
+ savedConfigureExFlags = mempty,
savedUserInstallDirs = mempty,
savedGlobalInstallDirs = mempty,
savedUploadFlags = mempty
@@ -111,6 +119,7 @@ instance Monoid SavedConfig where
savedGlobalFlags = combine savedGlobalFlags,
savedInstallFlags = combine savedInstallFlags,
savedConfigureFlags = combine savedConfigureFlags,
+ savedConfigureExFlags = combine savedConfigureExFlags,
savedUserInstallDirs = combine savedUserInstallDirs,
savedGlobalInstallDirs = combine savedGlobalInstallDirs,
savedUploadFlags = combine savedUploadFlags
@@ -167,10 +176,15 @@ baseSavedConfig = do
initialSavedConfig :: IO SavedConfig
initialSavedConfig = do
cacheDir <- defaultCacheDir
+ logsDir <- defaultLogsDir
return mempty {
savedGlobalFlags = mempty {
globalCacheDir = toFlag cacheDir,
globalRemoteRepos = [defaultRemoteRepo]
+ },
+ savedInstallFlags = mempty {
+ installSummaryFile = [toPathTemplate (logsDir </> "build.log")],
+ installBuildReports= toFlag AnonymousReports
}
}
@@ -233,7 +247,7 @@ loadConfig verbosity configFileFlag userInstallFlag = addBaseConf $ do
let (line, msg) = locatedErrorMsg err
warn verbosity $
"Error parsing config file " ++ configFile
- ++ maybe "" (\n -> ":" ++ show n) line ++ ": " ++ show msg
+ ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg
warn verbosity $ "Using default configuration."
initialSavedConfig
@@ -256,7 +270,19 @@ readConfigFile initial file = handleNotExists $
writeConfigFile :: FilePath -> SavedConfig -> SavedConfig -> IO ()
writeConfigFile file comments vals = do
createDirectoryIfMissing True (takeDirectory file)
- writeFile file $ showConfigWithComments comments vals ++ "\n"
+ writeFile file $ explanation ++ showConfigWithComments comments vals ++ "\n"
+ where
+ explanation = unlines
+ ["-- This is the configuration file for the 'cabal' command line tool."
+ ,""
+ ,"-- The available configuration options are listed below."
+ ,"-- Some of them have default values listed."
+ ,""
+ ,"-- Lines (like this one) beginning with '--' are comments."
+ ,"-- Be careful with spaces and indentation because they are"
+ ,"-- used to indicate layout for nested sections."
+ ,"",""
+ ]
-- | These are the default values that get used in Cabal if a no value is
-- given. We use these here to include in comments when we write out the
@@ -270,6 +296,7 @@ commentSavedConfig = do
return SavedConfig {
savedGlobalFlags = commandDefaultFlags globalCommand,
savedInstallFlags = defaultInstallFlags,
+ savedConfigureExFlags = defaultConfigExFlags,
savedConfigureFlags = (defaultConfigFlags defaultProgramConfiguration) {
configUserInstall = toFlag defaultUserInstall
},
@@ -285,26 +312,41 @@ configFieldDescriptions =
toSavedConfig liftGlobalFlag
(commandOptions globalCommand ParseArgs)
- ["version", "numeric-version", "config-file"]
-
- ++ toSavedConfig liftInstallFlag
- (installOptions ParseArgs)
- ["dry-run", "reinstall", "only"]
+ ["version", "numeric-version", "config-file"] []
++ toSavedConfig liftConfigFlag
(configureOptions ParseArgs)
- (["scratchdir", "configure-option"] ++ map fieldName installDirsFields)
+ (["builddir", "configure-option"] ++ map fieldName installDirsFields)
+
+ --FIXME: this is only here because viewAsFieldDescr gives us a parser
+ -- that only recognises 'ghc' etc, the case-sensitive flag names, not
+ -- what the normal case-insensitive parser gives us.
+ [simpleField "compiler"
+ (fromFlagOrDefault Disp.empty . fmap Text.disp) (optional Text.parse)
+ configHcFlavor (\v flags -> flags { configHcFlavor = v })
+ ]
+
+ ++ toSavedConfig liftConfigExFlag
+ (configureExOptions ParseArgs)
+ [] []
+
+ ++ toSavedConfig liftInstallFlag
+ (installOptions ParseArgs)
+ ["dry-run", "reinstall", "only"] []
++ toSavedConfig liftUploadFlag
(commandOptions uploadCommand ParseArgs)
- ["verbose", "check"]
+ ["verbose", "check"] []
where
- toSavedConfig lift options excluded =
- [ lift field
+ toSavedConfig lift options exclusions replacements =
+ [ lift (fromMaybe field replacement)
| opt <- options
- , let field = viewAsFieldDescr opt
- , fieldName field `notElem` excluded ]
+ , let field = viewAsFieldDescr opt
+ name = fieldName field
+ replacement = find ((== name) . fieldName) replacements
+ , name `notElem` exclusions ]
+ optional = Parse.option mempty . fmap toFlag
-- TODO: next step, make the deprecated fields elicit a warning.
--
@@ -354,6 +396,10 @@ liftConfigFlag :: FieldDescr ConfigFlags -> FieldDescr SavedConfig
liftConfigFlag = liftField
savedConfigureFlags (\flags conf -> conf { savedConfigureFlags = flags })
+liftConfigExFlag :: FieldDescr ConfigExFlags -> FieldDescr SavedConfig
+liftConfigExFlag = liftField
+ savedConfigureExFlags (\flags conf -> conf { savedConfigureExFlags = flags })
+
liftInstallFlag :: FieldDescr InstallFlags -> FieldDescr SavedConfig
liftInstallFlag = liftField
savedInstallFlags (\flags conf -> conf { savedInstallFlags = flags })
@@ -367,7 +413,9 @@ parseConfig initial = \str -> do
fields <- readFields str
let (knownSections, others) = partition isKnownSection fields
config <- parse others
- (user, global) <- foldM parseSections (mempty, mempty) knownSections
+ let user0 = savedUserInstallDirs config
+ global0 = savedGlobalInstallDirs config
+ (user, global) <- foldM parseSections (user0, global0) knownSections
return config {
savedUserInstallDirs = user,
savedGlobalInstallDirs = global
@@ -505,4 +553,6 @@ installDirsOptions =
reqArgFlag "DIR" _sf _lf d
(fmap fromPathTemplate . get) (set . fmap toPathTemplate)
- reqArgFlag ad = reqArg ad (succeedReadE toFlag) flagToList
+ reqArgFlag ad = reqArg ad (fmap toFlag (readP_to_E err parseFilePathQ))
+ (map (show . showFilePath) . flagToList)
+ where err _ = "paths with spaces must use Haskell String syntax"
View
210 cabal-install-0.6.2/Distribution/Client/Configure.hs
@@ -0,0 +1,210 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Client.Configure
+-- Copyright : (c) David Himmelstrup 2005,
+-- Duncan Coutts 2005
+-- License : BSD-like
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Portability : portable
+--
+-- High level interface to configuring a package.
+-----------------------------------------------------------------------------
+module Distribution.Client.Configure (
+ configure,
+ ) where
+
+import Data.Monoid
+ ( Monoid(mempty) )
+import qualified Data.Map as Map
+
+import Distribution.Client.Dependency
+ ( resolveDependenciesWithProgress
+ , PackageConstraint(..)
+ , PackagesPreference(..), PackagesPreferenceDefault(..)
+ , PackagePreference(..)
+ , Progress(..), foldProgress, )
+import qualified Distribution.Client.InstallPlan as InstallPlan
+import Distribution.Client.InstallPlan (InstallPlan)
+import Distribution.Client.IndexUtils as IndexUtils
+ ( getAvailablePackages )
+import Distribution.Client.Setup
+ ( ConfigExFlags(..), configureCommand, filterConfigureFlags )
+import Distribution.Client.Types as Available
+ ( AvailablePackage(..), AvailablePackageSource(..), Repo(..)
+ , AvailablePackageDb(..), ConfiguredPackage(..) )
+import Distribution.Client.SetupWrapper
+ ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )
+
+import Distribution.Simple.Compiler
+ ( CompilerId(..), Compiler(compilerId), PackageDB(..) )
+import Distribution.Simple.Program (ProgramConfiguration )
+import Distribution.Simple.Configure (getInstalledPackages)
+import Distribution.Simple.Setup
+ ( ConfigFlags(..), toFlag, flagToMaybe, fromFlagOrDefault )
+import qualified Distribution.Simple.PackageIndex as PackageIndex
+import Distribution.Simple.PackageIndex (PackageIndex)
+import Distribution.Simple.Utils
+ ( defaultPackageDesc )
+import Distribution.Package
+ ( PackageName, packageName, packageVersion
+ , Package(..), Dependency(..), thisPackageVersion )
+import qualified Distribution.PackageDescription as PackageDescription
+import Distribution.PackageDescription
+ ( PackageDescription )
+import Distribution.PackageDescription.Parse
+ ( readPackageDescription )
+import Distribution.PackageDescription.Configuration
+ ( finalizePackageDescription )
+import Distribution.InstalledPackageInfo
+ ( InstalledPackageInfo )
+import Distribution.Version
+ ( VersionRange(AnyVersion, ThisVersion) )
+import Distribution.Simple.Utils as Utils
+ ( notice, info, die )
+import Distribution.System
+ ( Platform(Platform), buildPlatform )
+import Distribution.Verbosity as Verbosity
+ ( Verbosity )
+
+-- | Configure the package found in the local directory
+configure :: Verbosity
+ -> PackageDB
+ -> [Repo]
+ -> Compiler
+ -> ProgramConfiguration
+ -> ConfigFlags
+ -> ConfigExFlags
+ -> [String]
+ -> IO ()
+configure verbosity packageDB repos comp conf
+ configFlags configExFlags extraArgs = do
+
+ installed <- getInstalledPackages verbosity comp packageDB conf
+ available <- getAvailablePackages verbosity repos
+
+ progress <- planLocalPackage verbosity comp configFlags configExFlags
+ installed available
+
+ notice verbosity "Resolving dependencies..."
+ maybePlan <- foldProgress (\message rest -> info verbosity message >> rest)
+ (return . Left) (return . Right) progress
+ case maybePlan of
+ Left message -> do
+ info verbosity message
+ setupWrapper verbosity (setupScriptOptions installed) Nothing
+ configureCommand (const configFlags) extraArgs
+
+ Right installPlan -> case InstallPlan.ready installPlan of
+ [pkg@(ConfiguredPackage (AvailablePackage _ _ LocalUnpackedPackage) _ _)] ->
+ configurePackage verbosity
+ (InstallPlan.planPlatform installPlan)
+ (InstallPlan.planCompiler installPlan)
+ (setupScriptOptions installed)
+ configFlags pkg extraArgs
+
+ _ -> die $ "internal error: configure install plan should have exactly "
+ ++ "one local ready package."
+
+ where
+ setupScriptOptions index = SetupScriptOptions {
+ useCabalVersion = maybe AnyVersion ThisVersion
+ (flagToMaybe (configCabalVersion configExFlags)),
+ useCompiler = Just comp,
+ -- Hack: we typically want to allow the UserPackageDB for finding the
+ -- Cabal lib when compiling any Setup.hs even if we're doing a global
+ -- install. However we also allow looking in a specific package db.
+ -- TODO: if we specify a specific db then we do not look in the user
+ -- package db but we probably should ie [global, user, specific]
+ usePackageDB = if packageDB == GlobalPackageDB then UserPackageDB
+ else packageDB,
+ usePackageIndex = if packageDB == GlobalPackageDB then Nothing
+ else index,
+ useProgramConfig = conf,
+ useDistPref = fromFlagOrDefault
+ (useDistPref defaultSetupScriptOptions)
+ (configDistPref configFlags),
+ useLoggingHandle = Nothing,
+ useWorkingDir = Nothing
+ }
+
+-- | Make an 'InstallPlan' for the unpacked package in the current directory,
+-- and all its dependencies.
+--
+planLocalPackage :: Verbosity -> Compiler
+ -> ConfigFlags -> ConfigExFlags
+ -> Maybe (PackageIndex InstalledPackageInfo)
+ -> AvailablePackageDb
+ -> IO (Progress String String InstallPlan)
+planLocalPackage verbosity comp configFlags configExFlags installed
+ (AvailablePackageDb _ availablePrefs) = do
+ pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity
+ let -- The trick is, we add the local package to the available index and
+ -- remove it from the installed index. Then we ask to resolve a
+ -- 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
+ localPkg = AvailablePackage {
+ packageInfoId = packageId pkg,
+ Available.packageDescription = pkg,
+ packageSource = LocalUnpackedPackage
+ }
+ targets = [packageName pkg]
+ constraints = [PackageVersionConstraint (packageName pkg)
+ (ThisVersion (packageVersion pkg))
+ ,PackageFlagsConstraint (packageName pkg)
+ (configConfigurationsFlags configFlags)]
+ ++ [ PackageVersionConstraint name ver
+ | Dependency name ver <- configConstraints configFlags ]
+ preferences = mergePackagePrefs PreferLatestForSelected
+ availablePrefs configExFlags
+
+ return $ resolveDependenciesWithProgress buildPlatform (compilerId comp)
+ installed' available' preferences constraints targets
+
+
+mergePackagePrefs :: PackagesPreferenceDefault
+ -> Map.Map PackageName VersionRange
+ -> ConfigExFlags
+ -> PackagesPreference
+mergePackagePrefs defaultPref availablePrefs configExFlags =
+ PackagesPreference defaultPref $
+ -- The preferences that come from the hackage index
+ [ PackageVersionPreference name ver
+ | (name, ver) <- Map.toList availablePrefs ]
+ -- additional preferences from the config file or command line
+ ++ [ PackageVersionPreference name ver
+ | Dependency name ver <- configPreferences configExFlags ]
+
+-- | Call an installer for an 'AvailablePackage' but override the configure
+-- flags with the ones given by the 'ConfiguredPackage'. In particular the
+-- 'ConfiguredPackage' specifies an exact 'FlagAssignment' and exactly
+-- versioned package dependencies. So we ignore any previous partial flag
+-- assignment or dependency constraints and use the new ones.
+--
+configurePackage :: Verbosity
+ -> Platform -> CompilerId
+ -> SetupScriptOptions
+ -> ConfigFlags
+ -> ConfiguredPackage
+ -> [String]
+ -> IO ()
+configurePackage verbosity (Platform arch os) comp scriptOptions configFlags
+ (ConfiguredPackage (AvailablePackage _ gpkg _) flags deps) extraArgs =
+
+ setupWrapper verbosity
+ scriptOptions (Just pkg) configureCommand configureFlags extraArgs
+
+ where
+ configureFlags = filterConfigureFlags configFlags {
+ configConfigurationsFlags = flags,
+ configConstraints = map thisPackageVersion deps,
+ configVerbosity = toFlag verbosity
+ }
+
+ pkg = case finalizePackageDescription flags
+ (Nothing :: Maybe (PackageIndex PackageDescription))
+ os arch comp [] gpkg of
+ Left _ -> error "finalizePackageDescription ConfiguredPackage failed"
+ Right (desc, _) -> desc
View
149 ...l-install-0.6.0/Distribution/Client/Dependency.hs → ...l-install-0.6.2/Distribution/Client/Dependency.hs
@@ -13,13 +13,16 @@
-- Top level interface to dependency resolution.
-----------------------------------------------------------------------------
module Distribution.Client.Dependency (
+ module Distribution.Client.Dependency.Types,
resolveDependencies,
resolveDependenciesWithProgress,
+ dependencyConstraints,
+ dependencyTargets,
+
PackagesPreference(..),
- packagesPreference,
- PackagesVersionPreference,
- PackagesInstalledPreference(..),
+ PackagesPreferenceDefault(..),
+ PackagePreference(..),
upgradableDependencies,
) where
@@ -34,18 +37,18 @@ import Distribution.Client.InstallPlan (InstallPlan)
import Distribution.Client.Types
( UnresolvedDependency(..), AvailablePackage(..) )
import Distribution.Client.Dependency.Types
- ( PackageName, DependencyResolver
- , PackagePreference(..), PackageInstalledPreference(..)
+ ( DependencyResolver, PackageConstraint(..)
+ , PackagePreferences(..), InstalledPreference(..)
, Progress(..), foldProgress )
import Distribution.Package
( PackageIdentifier(..), PackageName(..), packageVersion, packageName
, Dependency(..), Package(..), PackageFixedDeps(..) )
import Distribution.Version
- ( VersionRange(AnyVersion), orLaterVersion )
+ ( VersionRange(AnyVersion), orLaterVersion, isAnyVersion )
import Distribution.Compiler
- ( CompilerId )
+ ( CompilerId(..) )
import Distribution.System
- ( OS, Arch )
+ ( Platform )
import Distribution.Simple.Utils (comparing)
import Distribution.Client.Utils (mergeBy, MergeResult(..))
@@ -53,7 +56,6 @@ import Data.List (maximumBy)
import Data.Monoid (Monoid(mempty))
import Data.Maybe (fromMaybe)
import qualified Data.Map as Map
-import Data.Map (Map)
import qualified Data.Set as Set
import Data.Set (Set)
import Control.Exception (assert)
@@ -64,27 +66,27 @@ defaultResolver = topDownResolver
-- | Global policy for the versions of all packages.
--
data PackagesPreference = PackagesPreference
- PackagesInstalledPreference
- PackagesVersionPreference
-
-packagesPreference :: PackagesInstalledPreference
- -> Map PackageName VersionRange
- -> PackagesPreference
-packagesPreference installedPref versionPrefs =
- PackagesPreference installedPref versionPrefs'
- where
- versionPrefs' :: PackageName -> VersionRange
- versionPrefs' pkgname =
- fromMaybe AnyVersion (Map.lookup pkgname versionPrefs)
+ PackagesPreferenceDefault
+ [PackagePreference]
--- | An optional suggested version for each package.
---
-type PackagesVersionPreference = PackageName -> VersionRange
+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 PackagesInstalledPreference =
+data PackagesPreferenceDefault =
-- | Always prefer the latest version irrespective of any existing
-- installed version.
@@ -105,31 +107,37 @@ data PackagesInstalledPreference =
--
| PreferLatestForSelected
-resolveDependencies :: OS
- -> Arch
+data PackagePreference
+ = PackageVersionPreference PackageName VersionRange
+ | PackageInstalledPreference PackageName InstalledPreference
+
+resolveDependencies :: Platform
-> CompilerId
-> Maybe (PackageIndex InstalledPackageInfo)
-> PackageIndex AvailablePackage
-> PackagesPreference
- -> [UnresolvedDependency]
+ -> [PackageConstraint]
+ -> [PackageName]
-> Either String InstallPlan
-resolveDependencies os arch comp installed available pref deps =
+resolveDependencies platform comp installed available
+ preferences constraints targets =
foldProgress (flip const) Left Right $
- resolveDependenciesWithProgress os arch comp installed available pref deps
+ resolveDependenciesWithProgress platform comp installed available
+ preferences constraints targets
-resolveDependenciesWithProgress :: OS
- -> Arch
+resolveDependenciesWithProgress :: Platform
-> CompilerId
-> Maybe (PackageIndex InstalledPackageInfo)
-> PackageIndex AvailablePackage
-> PackagesPreference
- -> [UnresolvedDependency]
+ -> [PackageConstraint]
+ -> [PackageName]
-> Progress String String InstallPlan
-resolveDependenciesWithProgress os arch comp (Just installed) =
- dependencyResolver defaultResolver os arch comp installed
+resolveDependenciesWithProgress platform comp (Just installed) =
+ dependencyResolver defaultResolver platform comp installed
-resolveDependenciesWithProgress os arch comp Nothing =
- dependencyResolver bogusResolver os arch comp mempty
+resolveDependenciesWithProgress platform comp Nothing =
+ dependencyResolver bogusResolver platform comp mempty
hideBrokenPackages :: PackageFixedDeps p => PackageIndex p -> PackageIndex p
hideBrokenPackages index =
@@ -141,53 +149,70 @@ hideBrokenPackages index =
where
check p x = assert (p x) x
-hideBasePackage :: Package p => PackageIndex p -> PackageIndex p
-hideBasePackage = PackageIndex.deletePackageName (PackageName "base")
- . PackageIndex.deletePackageName (PackageName "ghc-prim")
-
dependencyResolver
:: DependencyResolver
- -> OS -> Arch -> CompilerId
+ -> Platform -> CompilerId
-> PackageIndex InstalledPackageInfo
-> PackageIndex AvailablePackage
-> PackagesPreference
- -> [UnresolvedDependency]
+ -> [PackageConstraint]
+ -> [PackageName]
-> Progress String String InstallPlan
-dependencyResolver resolver os arch comp installed available pref deps =
+dependencyResolver resolver platform comp installed available
+ pref constraints targets =
let installed' = hideBrokenPackages installed
- available' = hideBasePackage available
+ -- 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
- $ resolver os arch comp installed' available' preference deps
+ $ resolver platform comp installed' available
+ preferences (extraConstraints ++ constraints) targets
where
toPlan pkgs =
- case InstallPlan.new os arch comp (PackageIndex.fromList pkgs) of
+ 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
- preference = interpretPackagesPreference initialPkgNames pref
- initialPkgNames = Set.fromList
- [ name | UnresolvedDependency (Dependency name _) _ <- deps ]
-
-- | Give an interpretation to the global 'PackagesPreference' as
-- specific per-package 'PackageVersionPreference'.
--
interpretPackagesPreference :: Set PackageName
-> PackagesPreference
- -> (PackageName -> PackagePreference)
-interpretPackagesPreference selected
- (PackagesPreference installPref versionPref) = case installPref of
- PreferAllLatest -> PackagePreference PreferLatest . versionPref
- PreferAllInstalled -> PackagePreference PreferInstalled . versionPref
- 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 PackagePreference PreferLatest (versionPref pkgname)
- else PackagePreference PreferInstalled (versionPref pkgname)
+ -> (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
-- | Given the list of installed packages and available packages, figure
-- out which packages can be upgraded.
View
72 ...all-0.6.0/Distribution/Client/Dependency/Bogus.hs → ...all-0.6.2/Distribution/Client/Dependency/Bogus.hs
@@ -16,14 +16,15 @@ module Distribution.Client.Dependency.Bogus (
) where
import Distribution.Client.Types
- ( UnresolvedDependency(..), AvailablePackage(..)
- , ConfiguredPackage(..) )
+ ( AvailablePackage(..), ConfiguredPackage(..) )
import Distribution.Client.Dependency.Types
- ( DependencyResolver, Progress(..) )
+ ( DependencyResolver, Progress(..)
+ , PackageConstraint(..), PackagePreferences(..) )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Package
- ( PackageIdentifier(..), Dependency(..), Package(..) )
+ ( PackageName, PackageIdentifier(..), Dependency(..)
+ , Package(..), packageVersion )
import Distribution.PackageDescription
( GenericPackageDescription(..), CondTree(..), FlagAssignment )
import Distribution.PackageDescription.Configuration
@@ -31,14 +32,19 @@ import Distribution.PackageDescription.Configuration
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.PackageIndex (PackageIndex)
import Distribution.Version
- ( VersionRange(IntersectVersionRanges) )
+ ( VersionRange(AnyVersion, IntersectVersionRanges), withinRange )
import Distribution.Simple.Utils
- ( equating, comparing )
+ ( comparing )
import Distribution.Text
( display )
+import Distribution.System
+ ( Platform(Platform) )
import Data.List
- ( maximumBy, sortBy, groupBy )
+ ( maximumBy )
+import Data.Maybe
+ ( fromMaybe )
+import qualified Data.Map as Map
-- | This resolver thinks that every package is already installed.
--
@@ -46,12 +52,14 @@ import Data.List
-- We just pretend that everything is installed and hope for the best.
--
bogusResolver :: DependencyResolver
-bogusResolver os arch comp _ available _ = resolveFromAvailable []
- . combineDependencies
+bogusResolver (Platform arch os) comp _ available
+ preferences constraints targets =
+ resolveFromAvailable []
+ (combineConstraints preferences constraints targets)
where
resolveFromAvailable chosen [] = Done chosen
- resolveFromAvailable chosen (UnresolvedDependency dep flags : deps) =
- case latestAvailableSatisfying available dep of
+ 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 os arch comp [] pkg of
@@ -64,6 +72,8 @@ bogusResolver os arch comp _ available _ = resolveFromAvailable []
where
none :: Maybe (PackageIndex PackageIdentifier)
none = Nothing
+ where
+ dep = Dependency name verConstraint
fudgeChosenPackage :: AvailablePackage -> FlagAssignment -> ConfiguredPackage
fudgeChosenPackage (AvailablePackage pkgid pkg source) flags =
@@ -87,23 +97,35 @@ fudgeChosenPackage (AvailablePackage pkgid pkg source) flags =
where
g (cnd, t, me) = (cnd, mapTreeConstrs f t, fmap (mapTreeConstrs f) me)
-combineDependencies :: [UnresolvedDependency] -> [UnresolvedDependency]
-combineDependencies = map combineGroup
- . groupBy (equating depName)
- . sortBy (comparing depName)
+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
- combineGroup deps = UnresolvedDependency (Dependency name ver) flags
- where name = depName (head deps)
- ver = foldr1 IntersectVersionRanges . map depVer $ deps
- flags = concatMap depFlags deps
- depName (UnresolvedDependency (Dependency name _) _) = name
- depVer (UnresolvedDependency (Dependency _ ver) _) = ver
+ versionConstraints = Map.fromListWith IntersectVersionRanges
+ [ (name, versionRange)
+ | PackageVersionConstraint name versionRange <- constraints ]
+
+ flagsConstraints = Map.fromListWith (++)
+ [ (name, flags)
+ | PackageFlagsConstraint name flags <- constraints ]
--- | Gets the latest available package satisfying a dependency.
+-- | Gets the best available package satisfying a dependency.
+--
latestAvailableSatisfying :: PackageIndex AvailablePackage
- -> Dependency
+ -> PackageName -> VersionRange -> VersionRange
-> Maybe AvailablePackage
-latestAvailableSatisfying index dep =
+latestAvailableSatisfying index name versionConstraint versionPreference =
case PackageIndex.lookupDependency index dep of
[] -> Nothing
- pkgs -> Just (maximumBy (comparing (pkgVersion . packageId)) pkgs)
+ pkgs -> Just (maximumBy best pkgs)
+ where
+ dep = Dependency name versionConstraint
+ best = comparing (\p -> (isPreferred p, packageVersion p))
+ isPreferred p = packageVersion p `withinRange` versionPreference
View
232 ...l-0.6.0/Distribution/Client/Dependency/TopDown.hs → ...l-0.6.2/Distribution/Client/Dependency/TopDown.hs
@@ -22,11 +22,10 @@ import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.InstallPlan
( PlanPackage(..) )
import Distribution.Client.Types
- ( UnresolvedDependency(..), AvailablePackage(..)
- , ConfiguredPackage(..) )
+ ( AvailablePackage(..), ConfiguredPackage(..) )
import Distribution.Client.Dependency.Types
- ( PackageName, DependencyResolver, PackagePreference(..)
- , PackageInstalledPreference(..)
+ ( DependencyResolver, PackageConstraint(..)
+ , PackagePreferences(..), InstalledPreference(..)
, Progress(..), foldProgress )
import qualified Distribution.Simple.PackageIndex as PackageIndex
@@ -42,11 +41,11 @@ import Distribution.PackageDescription
import Distribution.PackageDescription.Configuration
( finalizePackageDescription, flattenPackageDescription )
import Distribution.Version
- ( withinRange )
+ ( VersionRange(AnyVersion), withinRange )
import Distribution.Compiler
( CompilerId )
import Distribution.System
- ( OS, Arch )
+ ( Platform(Platform) )
import Distribution.Simple.Utils
( equating, comparing )
import Distribution.Text
@@ -55,7 +54,7 @@ import Distribution.Text
import Data.List
( foldl', maximumBy, minimumBy, nub, sort, groupBy )
import Data.Maybe
- ( fromJust, fromMaybe )
+ ( fromJust, fromMaybe, catMaybes )
import Data.Monoid
( Monoid(mempty) )
import Control.Monad
@@ -65,6 +64,8 @@ import Data.Set (Set)
import qualified Data.Map as Map
import qualified Data.Graph as Graph
import qualified Data.Array as Array
+import Control.Exception
+ ( assert )
-- ------------------------------------------------------------
-- * Search state types
@@ -86,7 +87,7 @@ data SearchSpace inherited pkg
-- * Traverse a search tree
-- ------------------------------------------------------------
-explore :: (PackageName -> PackagePreference)
+explore :: (PackageName -> PackagePreferences)
-> SearchSpace (SelectedPackages, Constraints, SelectionChanges)
SelectablePackage
-> Progress Log Failure (SelectedPackages, Constraints)
@@ -116,7 +117,7 @@ explore pref (ChoiceNode _ choices) =
isInstalled (AvailableOnly _) = False
isInstalled _ = True
isPreferred p = packageVersion p `withinRange` preferredVersions
- (PackagePreference packageInstalledPreference preferredVersions)
+ (PackagePreferences preferredVersions packageInstalledPreference)
= pref pkgname
logInfo node = Select selected discarded
@@ -209,7 +210,7 @@ constrainDeps pkg (dep:deps) cs discard =
-- ------------------------------------------------------------
search :: ConfigurePackage
- -> (PackageName -> PackagePreference)
+ -> (PackageName -> PackagePreferences)
-> Constraints
-> Set PackageName
-> Progress Log Failure (SelectedPackages, Constraints)
@@ -231,45 +232,65 @@ topDownResolver = ((((((mapMessages .).).).).).) . topDownResolver'
-- | The native resolver with detailed structured logging and failure types.
--
-topDownResolver' :: OS -> Arch -> CompilerId
+topDownResolver' :: Platform -> CompilerId
-> PackageIndex InstalledPackageInfo
-> PackageIndex AvailablePackage
- -> (PackageName -> PackagePreference)
- -> [UnresolvedDependency]
+ -> (PackageName -> PackagePreferences)
+ -> [PackageConstraint]
+ -> [PackageName]
-> Progress Log Failure [PlanPackage]
-topDownResolver' os arch comp installed available pref deps =
+topDownResolver' platform comp installed available
+ preferences constraints targets =
fmap (uncurry finalise)
- . (\cs -> search configure pref cs initialPkgNames)
- =<< constrainTopLevelDeps deps constraints
+ . (\cs -> search configure preferences cs initialPkgNames)
+ =<< addTopLevelConstraints constraints constraintSet
where
- configure = configurePackage os arch comp
- constraints = Constraints.empty
- (annotateInstalledPackages topSortNumber installed')
- (annotateAvailablePackages deps topSortNumber available')
+ configure = configurePackage platform comp
+ constraintSet = Constraints.empty
+ (annotateInstalledPackages topSortNumber installed')
+ (annotateAvailablePackages constraints topSortNumber available')
(installed', available') = selectNeededSubset installed available
initialPkgNames
topSortNumber = topologicalSortNumbering installed' available'
- initialDeps = [ dep | UnresolvedDependency dep _ <- deps ]
- initialPkgNames = Set.fromList [ name | Dependency name _ <- initialDeps ]
-
- finalise selected = PackageIndex.allPackages
- . improvePlan installed'
- . PackageIndex.fromList
- . finaliseSelectedPackages pref selected
-
-constrainTopLevelDeps :: [UnresolvedDependency] -> Constraints
- -> Progress a Failure Constraints
-constrainTopLevelDeps [] cs = Done cs
-constrainTopLevelDeps (UnresolvedDependency dep _:deps) cs =
- case addTopLevelDependencyConstraint dep cs of
- Satisfiable cs' _ -> constrainTopLevelDeps deps cs'
- Unsatisfiable -> Fail (TopLevelDependencyUnsatisfiable dep)
- ConflictsWith conflicts -> Fail (TopLevelDependencyConflict dep conflicts)
-
-configurePackage :: OS -> Arch -> CompilerId -> ConfigurePackage
-configurePackage os arch comp available spkg = case spkg of
+ initialPkgNames = Set.fromList targets
+
+ finalise selected' constraints' =
+ PackageIndex.allPackages
+ . fst . improvePlan installed' constraints'
+ . PackageIndex.fromList
+ $ finaliseSelectedPackages preferences selected' constraints'
+
+addTopLevelConstraints :: [PackageConstraint] -> Constraints
+ -> Progress a Failure Constraints
+addTopLevelConstraints [] cs = Done cs
+addTopLevelConstraints (PackageFlagsConstraint _ _ :deps) cs =
+ addTopLevelConstraints deps cs
+
+addTopLevelConstraints (PackageVersionConstraint pkg ver:deps) cs =
+ case addTopLevelVersionConstraint pkg ver cs of
+ Satisfiable cs' _ ->
+ addTopLevelConstraints deps cs'
+
+ Unsatisfiable ->
+ Fail (TopLevelVersionConstraintUnsatisfiable pkg ver)
+
+ ConflictsWith conflicts ->
+ Fail (TopLevelVersionConstraintConflict pkg ver conflicts)
+
+addTopLevelConstraints (PackageInstalledConstraint pkg:deps) cs =
+ case addTopLevelInstalledConstraint pkg cs of
+ Satisfiable cs' _ -> addTopLevelConstraints deps cs'
+
+ Unsatisfiable ->
+ Fail (TopLevelInstallConstraintUnsatisfiable pkg)
+
+ ConflictsWith conflicts ->
+ Fail (TopLevelInstallConstraintConflict pkg conflicts)
+
+configurePackage :: Platform -> CompilerId -> ConfigurePackage
+configurePackage (Platform arch os) comp available spkg = case spkg of
InstalledOnly ipkg -> Right (InstalledOnly ipkg)
AvailableOnly apkg -> fmap AvailableOnly (configure apkg)
InstalledAndAvailable ipkg apkg -> fmap (InstalledAndAvailable ipkg)
@@ -300,11 +321,11 @@ annotateInstalledPackages dfsNumber installed = PackageIndex.fromList
-- | Annotate each available packages with its topological sort number and any
-- user-supplied partial flag assignment.
--
-annotateAvailablePackages :: [UnresolvedDependency]
+annotateAvailablePackages :: [PackageConstraint]
-> (PackageName -> TopologicalSortNumber)
-> PackageIndex AvailablePackage
-> PackageIndex UnconfiguredPackage
-annotateAvailablePackages deps dfsNumber available = PackageIndex.fromList
+annotateAvailablePackages constraints dfsNumber available = PackageIndex.fromList
[ UnconfiguredPackage pkg (dfsNumber name) (flagsFor name)
| pkg <- PackageIndex.allPackages available
, let name = packageName pkg ]
@@ -312,7 +333,7 @@ annotateAvailablePackages deps dfsNumber available = PackageIndex.fromList
flagsFor = fromMaybe [] . flip Map.lookup flagsMap
flagsMap = Map.fromList
[ (name, flags)
- | UnresolvedDependency (Dependency name _) flags <- deps ]
+ | PackageFlagsConstraint name flags <- constraints ]
-- | One of the heuristics we use when guessing which path to take in the
-- search space is an ordering on the choices we make. It's generally better
@@ -400,7 +421,7 @@ selectNeededSubset installed available = select mempty mempty
-- * Post processing the solution
-- ------------------------------------------------------------
-finaliseSelectedPackages :: (PackageName -> PackagePreference)
+finaliseSelectedPackages :: (PackageName -> PackagePreferences)
-> SelectedPackages
-> Constraints
-> [PlanPackage]
@@ -426,7 +447,8 @@ finaliseSelectedPackages pref selected constraints =
case PackageIndex.lookupDependency remainingChoices dep of
[] -> impossible
[pkg'] -> pkg'
- remaining -> maximumBy bestByPref remaining
+ remaining -> assert (checkIsPaired remaining)
+ $ maximumBy bestByPref remaining
-- We order candidate packages to pick for a dependency by these
-- three factors. The last factor is just highest version wins.
bestByPref =
@@ -440,39 +462,74 @@ finaliseSelectedPackages pref selected constraints =
-- Is this package a preferred version acording to the hackage or
-- user's suggested version constraints
isPreferred p = packageVersion p `withinRange` preferredVersions
- where (PackagePreference _ preferredVersions) = pref (packageName p)
+ where (PackagePreferences preferredVersions _) = pref (packageName p)
+
+ -- We really only expect to find more than one choice remaining when
+ -- we're finalising a dependency on a paired package.
+ checkIsPaired [p1, p2] =
+ case Constraints.isPaired constraints (packageId p1) of
+ Just p2' -> packageId p2' == packageId p2
+ Nothing -> False
+ checkIsPaired _ = False
-- | Improve an existing installation plan by, where possible, swapping
-- packages we plan to install with ones that are already installed.
+-- This may add additional constraints due to the dependencies of installed
+-- packages on other installed packages.
--
improvePlan :: PackageIndex InstalledPackageInfo
+ -> Constraints
-> PackageIndex PlanPackage
- -> PackageIndex PlanPackage
-improvePlan installed selected = foldl' improve selected
- $ reverseTopologicalOrder selected
+ -> (PackageIndex PlanPackage, Constraints)
+improvePlan installed constraints0 selected0 =
+ foldl' improve (selected0, constraints0) (reverseTopologicalOrder selected0)
where
- improve selected' = maybe selected' (flip PackageIndex.insert selected')
- . improvePkg selected'
+ improve (selected, constraints) = fromMaybe (selected, constraints)
+ . improvePkg selected constraints
-- The idea is to improve the plan by swapping a configured package for
-- an equivalent installed one. For a particular package the condition is
-- that the package be in a configured state, that a the same version be
-- already installed with the exact same dependencies and all the packages
-- in the plan that it depends on are in the installed state
- improvePkg selected' pkgid = do
- Configured pkg <- PackageIndex.lookupPackageId selected' pkgid
+ improvePkg selected constraints pkgid = do
+ Configured pkg <- PackageIndex.lookupPackageId selected pkgid
ipkg <- PackageIndex.lookupPackageId installed pkgid
- guard $ sort (depends pkg) == nub (sort (depends ipkg))
- guard $ all (isInstalled selected') (depends pkg)
- return (PreExisting ipkg)
+ guard $ all (isInstalled selected) (depends pkg)
+ tryInstalled selected constraints [ipkg]
- isInstalled selected' pkgid =
- case PackageIndex.lookupPackageId selected' pkgid of
+ isInstalled selected pkgid =
+ case PackageIndex.lookupPackageId selected pkgid of
Just (PreExisting _) -> True
_ -> False
- reverseTopologicalOrder :: PackageFixedDeps pkg => PackageIndex pkg
- -> [PackageIdentifier]
+ tryInstalled :: PackageIndex PlanPackage -> Constraints
+ -> [InstalledPackageInfo]
+ -> Maybe (PackageIndex PlanPackage, Constraints)
+ tryInstalled selected constraints [] = Just (selected, constraints)
+ tryInstalled selected constraints (pkg:pkgs) =
+ case constraintsOk (packageId pkg) (depends pkg) constraints of
+ Nothing -> Nothing
+ Just constraints' -> tryInstalled selected' constraints' pkgs'
+ where
+ selected' = PackageIndex.insert (PreExisting pkg) selected
+ pkgs' = catMaybes (map notSelected (depends pkg)) ++ pkgs
+ notSelected pkgid =
+ case (PackageIndex.lookupPackageId installed pkgid
+ ,PackageIndex.lookupPackageId selected pkgid) of
+ (Just pkg', Nothing) -> Just pkg'
+ _ -> Nothing
+
+ constraintsOk _ [] constraints = Just constraints
+ constraintsOk pkgid (pkgid':pkgids) constraints =
+ case addPackageDependencyConstraint pkgid dep constraints of
+ Satisfiable constraints' _ -> constraintsOk pkgid pkgids constraints'
+ _ -> Nothing
+ where
+ dep = TaggedDependency InstalledConstraint (thisPackageVersion pkgid')
+
+ reverseTopologicalOrder :: PackageFixedDeps pkg
+ => PackageIndex pkg -> [PackageIdentifier]
reverseTopologicalOrder index = map (packageId . toPkg)
. Graph.topSort
. Graph.transposeG
@@ -493,8 +550,8 @@ addPackageSelectConstraint pkgid constraints =
reason = SelectedOther pkgid
addPackageExcludeConstraint :: PackageIdentifier -> Constraints
- -> Satisfiable Constraints
- [PackageIdentifier] ExclusionReason
+ -> Satisfiable Constraints
+ [PackageIdentifier] ExclusionReason
addPackageExcludeConstraint pkgid constraints =
Constraints.constrain dep reason constraints
where
@@ -510,14 +567,27 @@ addPackageDependencyConstraint pkgid dep constraints =
where
reason = ExcludedByPackageDependency pkgid dep
-addTopLevelDependencyConstraint :: Dependency -> Constraints
- -> Satisfiable Constraints
- [PackageIdentifier] ExclusionReason
-addTopLevelDependencyConstraint dep constraints =
+addTopLevelVersionConstraint :: PackageName -> VersionRange
+ -> Constraints
+ -> Satisfiable Constraints
+ [PackageIdentifier] ExclusionReason
+addTopLevelVersionConstraint pkg ver constraints =
Constraints.constrain taggedDep reason constraints
where
+ dep = Dependency pkg ver
taggedDep = TaggedDependency NoInstalledConstraint dep
- reason = ExcludedByTopLevelDependency dep
+ reason = ExcludedByTopLevelDependency dep
+
+addTopLevelInstalledConstraint :: PackageName
+ -> Constraints
+ -> Satisfiable Constraints
+ [PackageIdentifier] ExclusionReason
+addTopLevelInstalledConstraint pkg constraints =
+ Constraints.constrain taggedDep reason constraints
+ where
+ dep = Dependency pkg AnyVersion
+ taggedDep = TaggedDependency InstalledConstraint dep
+ reason = ExcludedByTopLevelDependency dep
-- ------------------------------------------------------------
-- * Reasons for constraints
@@ -575,11 +645,16 @@ data Failure
| DependencyConflict
SelectedPackage TaggedDependency
[(PackageIdentifier, [ExclusionReason])]
- | TopLevelDependencyConflict
- Dependency
+ | TopLevelVersionConstraintConflict
+ PackageName VersionRange
[(PackageIdentifier, [ExclusionReason])]
- | TopLevelDependencyUnsatisfiable
- Dependency
+ | TopLevelVersionConstraintUnsatisfiable
+ PackageName VersionRange
+ | TopLevelInstallConstraintConflict
+ PackageName
+ [(PackageIdentifier, [ExclusionReason])]
+ | TopLevelInstallConstraintUnsatisfiable
+ PackageName
showLog :: Log -> String
showLog (Select selected discarded) = case (selectedMsg, discardedMsg) of
@@ -633,16 +708,25 @@ showFailure (DependencyConflict pkg (TaggedDependency _ dep) conflicts) =
++ unlines [ showExclusionReason (packageId pkg') reason
| (pkg', reasons) <- conflicts, reason <- reasons ]
-showFailure (TopLevelDependencyConflict dep conflicts) =
- "dependencies conflict: "
- ++ "top level dependency " ++ display dep ++ " however\n"
+showFailure (TopLevelVersionConstraintConflict name ver conflicts) =
+ "constraints conflict: "
+ ++ "top level constraint " ++ display (Dependency name ver) ++ " however\n"
++ unlines [ showExclusionReason (packageId pkg') reason
| (pkg', reasons) <- conflicts, reason <- reasons ]
-showFailure (TopLevelDependencyUnsatisfiable (Dependency name ver)) =
+showFailure (TopLevelVersionConstraintUnsatisfiable name ver) =
"There is no available version of " ++ display name
++ " that satisfies " ++ display ver
+showFailure (TopLevelInstallConstraintConflict name conflicts) =
+ "constraints conflict: "
+ ++ "top level constraint " ++ display name ++ "-installed however\n"
+ ++ unlines [ showExclusionReason (packageId pkg') reason
+ | (pkg', reasons) <- conflicts, reason <- reasons ]
+
+showFailure (TopLevelInstallConstraintUnsatisfiable name) =
+ "There is no installed version of " ++ display name
+
-- ------------------------------------------------------------
-- * Utils
-- ------------------------------------------------------------
View
87 ...ribution/Client/Dependency/TopDown/Constraints.hs → ...ribution/Client/Dependency/TopDown/Constraints.hs
@@ -15,7 +15,7 @@ module Distribution.Client.Dependency.TopDown.Constraints (
empty,
choices,
isPaired,
-
+
constrain,
Satisfiable(..),
conflicting,
@@ -55,7 +55,7 @@ data (Package installed, Package available)
-- Remaining available choices
(PackageIndex (InstalledOrAvailable installed available))
-
+
-- Paired choices
(Map PackageName (Version, Version))
@@ -63,6 +63,10 @@ data (Package installed, Package available)
-- usually by applying constraints
(PackageIndex (ExcludedPackage PackageIdentifier reason))
+ -- Purely for the invariant, we keep a copy of the original index
+ (PackageIndex (InstalledOrAvailable installed available))
+
+
data ExcludedPackage pkg reason
= ExcludedPackage pkg [reason] -- reasons for excluding just the available
[reason] -- reasons for excluding installed and avail
@@ -70,25 +74,63 @@ data ExcludedPackage pkg reason
instance Package pkg => Package (ExcludedPackage pkg reason) where
packageId (ExcludedPackage p _ _) = packageId p
--- | The intersection between the two indexes is empty
+-- | There is a conservation of packages property. Packages are never gained or
+-- lost, they just transfer from the remaining pot to the excluded pot.
+--
invariant :: (Package installed, Package available)
=> Constraints installed available a -> Bool
-invariant (Constraints available _ excluded) =
- all (uncurry ok) [ (a, e) | InBoth a e <- merged ]
+invariant (Constraints available _ excluded original) = all check merged
where
- merged = mergeBy (\a b -> packageId a `compare` packageId b)
- (PackageIndex.allPackages available)
- (PackageIndex.allPackages excluded)
- ok (InstalledOnly _) (ExcludedPackage _ _ []) = True
- ok _ _ = False
+ 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
+
+ check (InBoth (InstalledOnly _) cur) = case cur of
+ -- If the package was originally installed only then
+ -- now it's either still remaining as installed only
+ -- or it has been excluded in which case we excluded both
+ -- installed and available since it was only installed
+ OnlyInLeft (InstalledOnly _) -> True
+ OnlyInRight (ExcludedPackage _ [] (_:_)) -> True
+ _ -> False
+
+ check (InBoth (AvailableOnly _) cur) = case cur of
+ -- If the package was originally available only then
+ -- now it's either still remaining as available only
+ -- or it has been excluded in which case we excluded both
+ -- installed and available since it was only available
+ OnlyInLeft (AvailableOnly _) -> True
+ OnlyInRight (ExcludedPackage _ [] (_:_)) -> True
+ _ -> True
+
+ -- If the package was originally installed and available
+ -- then there are three cases.
+ check (InBoth (InstalledAndAvailable _ _) cur) = case cur of
+ -- We can have both remaining:
+ OnlyInLeft (InstalledAndAvailable _ _) -> True
+ -- both excluded, in particular it can have had the available excluded
+ -- and later had both excluded so we do not mind if the available excluded
+ -- is empty or non-empty.
+ OnlyInRight (ExcludedPackage _ _ (_:_)) -> True
+ -- the installed remaining and the available excluded:
+ InBoth (InstalledOnly _) (ExcludedPackage _ (_:_) []) -> 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 available)
=> Constraints installed available a
-> Constraints installed available a -> Bool
-transitionsTo constraints @(Constraints available _ excluded )
- constraints'@(Constraints available' _ excluded') =
+transitionsTo constraints @(Constraints available _ excluded _)
+ constraints'@(Constraints available' _ excluded' _) =
invariant constraints && invariant constraints'
&& null availableGained && null excludedLost
&& map packageId availableLost == map packageId excludedGained
@@ -102,6 +144,9 @@ transitionsTo constraints @(Constraints available _ excluded )
availableGained = [ pkg | OnlyInRight pkg <- availableChange ]
excludedLost = [ pkg | OnlyInLeft pkg <- excludedChange ]
excludedGained = [ pkg | OnlyInRight pkg <- excludedChange ]
+ ++ [ pkg | InBoth (ExcludedPackage _ (_:_) [])
+ pkg@(ExcludedPackage _ (_:_) (_:_))
+ <- excludedChange ]
availableChange = mergeBy (\a b -> packageId a `compare` packageId b)
(PackageIndex.allPackages available)
(PackageIndex.allPackages available')
@@ -116,7 +161,7 @@ empty :: (PackageFixedDeps installed, Package available)
=> PackageIndex installed
-> PackageIndex available
-> Constraints installed available reason
-empty installed available = Constraints pkgs pairs mempty
+empty installed available = Constraints pkgs pairs mempty pkgs
where
pkgs = PackageIndex.fromList
. map toInstalledOrAvailable
@@ -142,12 +187,12 @@ empty installed available = Constraints pkgs pairs mempty
choices :: (Package installed, Package available)
=> Constraints installed available reason
-> PackageIndex (InstalledOrAvailable installed available)
-choices (Constraints available _ _) = available
+choices (Constraints available _ _ _) = available
isPaired :: (Package installed, Package available)
=> Constraints installed available reason
-> PackageIdentifier -> Maybe PackageIdentifier
-isPaired (Constraints _ pairs _) (PackageIdentifier name version) =
+isPaired (Constraints _ pairs _ _) (PackageIdentifier name version) =
case Map.lookup name pairs of
Just (v1, v2)
| version == v1 -> Just (PackageIdentifier name v2)
@@ -166,14 +211,14 @@ constrain :: (Package installed, Package available)
-> Satisfiable (Constraints installed available reason)
[PackageIdentifier] reason
constrain (TaggedDependency installedConstraint (Dependency name versionRange))
- reason constraints@(Constraints available paired excluded)
+ reason constraints@(Constraints available paired excluded original)
| not anyRemaining
= if null conflicts then Unsatisfiable
else ConflictsWith conflicts
- | otherwise
- = let constraints' = Constraints available' paired excluded'
+ | otherwise
+ = let constraints' = Constraints available' paired excluded' original
in assert (constraints `transitionsTo` constraints') $
Satisfiable constraints' (map packageId newExcluded)
@@ -199,7 +244,7 @@ constrain (TaggedDependency installedConstraint (Dependency name versionRange))
= id
update pkg = case pkg of
InstalledOnly _ -> id
- AvailableOnly _ -> error "impossible" -- PackageIndex.deletePackageId (packageId pkg)
+ AvailableOnly _ -> PackageIndex.deletePackageId (packageId pkg)
InstalledAndAvailable i _ -> PackageIndex.insert (InstalledOnly i)
-- Applying the constraint means adding exclusions for the packages that
@@ -215,7 +260,7 @@ constrain (TaggedDependency installedConstraint (Dependency name versionRange))
= Nothing
| otherwise = case pkg of
InstalledOnly _ -> Nothing
- AvailableOnly _ -> Just (ExcludedPackage pkgid [reason] [])
+ AvailableOnly _ -> Just (ExcludedPackage pkgid [] [reason])
InstalledAndAvailable _ _ ->
case PackageIndex.lookupPackageId excluded pkgid of
Just (ExcludedPackage _ avail both)
@@ -265,7 +310,7 @@ conflicting :: (Package installed, Package available)
=> Constraints installed available reason
-> Dependency
-> [(PackageIdentifier, [reason])]
-conflicting (Constraints _ _ excluded) dep =
+conflicting (Constraints _ _ excluded _) dep =
[ (pkgid, reasonsAvail ++ reasonsAll) --TODO
| ExcludedPackage pkgid reasonsAvail reasonsAll <-
PackageIndex.lookupDependency excluded dep ]
View
0  ...0/Distribution/Client/Dependency/TopDown/Types.hs → ...2/Distribution/Client/Dependency/TopDown/Types.hs
File renamed without changes
View
44 ...all-0.6.0/Distribution/Client/Dependency/Types.hs → ...all-0.6.2/Distribution/Client/Dependency/Types.hs
@@ -11,23 +11,24 @@
-- Common types for dependency resolution.
-----------------------------------------------------------------------------
module Distribution.Client.Dependency.Types (
- PackageName,
DependencyResolver,
- PackagePreference(..),
- PackageVersionPreference,
- PackageInstalledPreference(..),
+ PackageConstraint(..),
+ PackagePreferences(..),
+ InstalledPreference(..),
Progress(..),
foldProgress,
) where
import Distribution.Client.Types
- ( UnresolvedDependency(..), AvailablePackage(..) )
+ ( AvailablePackage(..) )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.InstalledPackageInfo
( InstalledPackageInfo )
+import Distribution.PackageDescription
+ ( FlagAssignment )
import Distribution.Simple.PackageIndex
( PackageIndex )
import Distribution.Package
@@ -37,7 +38,7 @@ import Distribution.Version
import Distribution.Compiler
( CompilerId )
import Distribution.System
- ( OS, Arch )
+ ( Platform )
import Prelude hiding (fail)
@@ -49,18 +50,28 @@ import Prelude hiding (fail)
-- solving the package dependency problem and we want to make it easy to swap
-- in alternatives.
--
-type DependencyResolver = OS
- -> Arch
+type DependencyResolver = Platform
-> CompilerId
-> PackageIndex InstalledPackageInfo
-> PackageIndex AvailablePackage
- -> (PackageName -> PackagePreference)
- -> [UnresolvedDependency]
+ -> (PackageName -> PackagePreferences)
+ -> [PackageConstraint]
+ -> [PackageName]
-> Progress String String [InstallPlan.PlanPackage]
+-- | Per-package constraints. Package constraints must be respected by the
+-- solver. Multiple constraints for each package can be given, though obviously
+-- it is possible to construct conflicting constraints (eg impossible version
+-- range or inconsistent flag assignment).
+--
+data PackageConstraint
+ = PackageVersionConstraint PackageName VersionRange
+ | PackageInstalledConstraint PackageName
+ | PackageFlagsConstraint PackageName FlagAssignment
+
-- | A per-package preference on the version. It is a soft constraint that the
-- 'DependencyResolver' should try to respect where possible. It consists of
--- a 'PackageInstalledPreference' which says if we prefer versions of packages
+-- a 'InstalledPreference' which says if we prefer versions of packages
-- that are already installed. It also hase a 'PackageVersionPreference' which
-- is a suggested constraint on the version number. The resolver should try to
-- use package versions that satisfy the suggested version constraint.
@@ -68,19 +79,12 @@ type DependencyResolver = OS
-- It is not specified if preferences on some packages are more important than
-- others.
--
-data PackagePreference = PackagePreference
- PackageInstalledPreference
- PackageVersionPreference
-
--- | A suggested constraint on the version number. The resolver should try to
--- use package versions that satisfy the suggested version constraint.
---
-type PackageVersionPreference = VersionRange
+data PackagePreferences = PackagePreferences VersionRange InstalledPreference
-- | Wether we prefer an installed version of a package or simply the latest
-- version.
--
-data PackageInstalledPreference = PreferInstalled | PreferLatest
+data InstalledPreference = PreferInstalled | PreferLatest
-- | A type to represent the unfolding of an expensive long running
-- calculation that may fail. We may get intermediate steps before the final
View
31 cabal-install-0.6.0/Distribution/Client/Fetch.hs → cabal-install-0.6.2/Distribution/Client/Fetch.hs
@@ -26,14 +26,18 @@ import Distribution.Client.Types
, AvailablePackageSource(..), AvailablePackageDb(..)
, Repo(..), RemoteRepo(..), LocalRepo(..) )
import Distribution.Client.Dependency
- ( resolveDependenciesWithProgress, packagesPreference
- , PackagesInstalledPreference(..) )
+ ( resolveDependenciesWithProgress
+ , dependencyConstraints, dependencyTargets
+ , PackagesPreference(..), PackagesPreferenceDefault(..)
+ , PackagePreference(..) )
import Distribution.Client.Dependency.Types
( foldProgress )
import Distribution.Client.IndexUtils as IndexUtils
( getAvailablePackages, disambiguateDependencies )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.HttpUtils (getHTTP, isOldHackageURI)
+import Distribution.Client.Utils
+ ( writeFileAtomic )
import Distribution.Package
( PackageIdentifier, packageName, packageVersion, Dependency(..) )
@@ -46,14 +50,15 @@ import Distribution.Simple.Configure
( getInstalledPackages )
import Distribution.Simple.Utils
( die, notice, info, debug, setupMessage
- , copyFileVerbose, writeFileAtomic )
+ , copyFileVerbose )
import Distribution.System
- ( buildOS, buildArch )
+ ( buildPlatform )
import Distribution.Text
( display )
import Distribution.Verbosity
( Verbosity )
+import qualified Data.Map as Map
import Control.Monad
( when, filterM )
import System.Directory
@@ -83,7 +88,8 @@ downloadURI verbosity path uri = do
Left err -> return (Just err)
Right rsp
| rspCode rsp == (2,0,0)
- -> writeFileAtomic path (rspBody rsp)
+ -> do info verbosity ("Downloaded to " ++ path)
+ writeFileAtomic path (rspBody rsp)
--FIXME: check the content-length header matches the body length.
--TODO: stream the download into the file rather than buffering the whole
-- thing in memory.
@@ -115,7 +121,7 @@ downloadIndex :: Verbosity -> RemoteRepo -> FilePath -> IO FilePath
downloadIndex verbosity repo cacheDir = do
let uri = (remoteRepoURI repo) {