summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSergeiTrofimovich <>2011-11-28 16:47:36 (GMT)
committerhdiff <hdiff@luite.com>2011-11-28 16:47:36 (GMT)
commit2fc9cad6a21a80484e012762d8a99480efede38e (patch)
tree41b40fe59cfdd24fc2699a4ba3882bfd9ff62cd0
parent7651441712ac7a97d3db69c4d344e2ebe99fb50b (diff)
version 0.2.140.2.14
-rw-r--r--.gitignore1
-rw-r--r--Cabal2Ebuild.hs6
-rw-r--r--Diff.hs12
-rw-r--r--DistroMap.hs6
-rw-r--r--Error.hs2
-rw-r--r--Main.hs4
-rw-r--r--Merge.hs29
-rw-r--r--Portage.hs20
-rw-r--r--Portage/EBuild.hs2
-rw-r--r--Portage/GHCCore.hs2
-rw-r--r--Portage/Host.hs1
-rw-r--r--Portage/Metadata.hs28
-rw-r--r--README.rst26
-rw-r--r--TODO8
-rw-r--r--cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency.hs318
-rw-r--r--cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/TopDown/Constraints.hs316
-rw-r--r--cabal-install-0.9.5_rc20101226/Distribution/Client/Fetch.hs259
-rw-r--r--cabal-install-0.9.5_rc20101226/Distribution/Client/List.hs368
-rw-r--r--cabal-install-0.9.5_rc20101226/Distribution/Client/Unpack.hs138
-rw-r--r--cabal/.darcs-boring6
-rw-r--r--cabal/HACKING10
-rw-r--r--cabal/IMPORTED-FROM7
-rw-r--r--cabal/LICENSE33
-rw-r--r--cabal/README8
-rw-r--r--cabal/cabal-install/Distribution/Client/BuildReports/Anonymous.hs (renamed from cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Anonymous.hs)0
-rw-r--r--cabal/cabal-install/Distribution/Client/BuildReports/Storage.hs (renamed from cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Storage.hs)10
-rw-r--r--cabal/cabal-install/Distribution/Client/BuildReports/Types.hs (renamed from cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Types.hs)0
-rw-r--r--cabal/cabal-install/Distribution/Client/BuildReports/Upload.hs (renamed from cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Upload.hs)19
-rw-r--r--cabal/cabal-install/Distribution/Client/Check.hs (renamed from cabal-install-0.9.5_rc20101226/Distribution/Client/Check.hs)0
-rw-r--r--cabal/cabal-install/Distribution/Client/Config.hs (renamed from cabal-install-0.9.5_rc20101226/Distribution/Client/Config.hs)25
-rw-r--r--cabal/cabal-install/Distribution/Client/Configure.hs (renamed from cabal-install-0.9.5_rc20101226/Distribution/Client/Configure.hs)125
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency.hs449
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/TopDown.hs (renamed from cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/TopDown.hs)502
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/TopDown/Constraints.hs601
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs (renamed from cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/TopDown/Types.hs)50
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Types.hs (renamed from cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/Types.hs)12
-rw-r--r--cabal/cabal-install/Distribution/Client/Fetch.hs173
-rw-r--r--cabal/cabal-install/Distribution/Client/FetchUtils.hs193
-rw-r--r--cabal/cabal-install/Distribution/Client/GZipUtils.hs (renamed from cabal-install-0.9.5_rc20101226/Distribution/Client/GZipUtils.hs)0
-rw-r--r--cabal/cabal-install/Distribution/Client/Haddock.hs (renamed from cabal-install-0.9.5_rc20101226/Distribution/Client/Haddock.hs)0
-rw-r--r--cabal/cabal-install/Distribution/Client/HttpUtils.hs (renamed from cabal-install-0.9.5_rc20101226/Distribution/Client/HttpUtils.hs)2
-rw-r--r--cabal/cabal-install/Distribution/Client/IndexUtils.hs (renamed from cabal-install-0.9.5_rc20101226/Distribution/Client/IndexUtils.hs)107
-rw-r--r--cabal/cabal-install/Distribution/Client/Init.hs (renamed from cabal-install-0.9.5_rc20101226/Distribution/Client/Init.hs)153
-rw-r--r--cabal/cabal-install/Distribution/Client/Init/Heuristics.hs (renamed from cabal-install-0.9.5_rc20101226/Distribution/Client/Init/Heuristics.hs)8
-rw-r--r--cabal/cabal-install/Distribution/Client/Init/Licenses.hs (renamed from cabal-install-0.9.5_rc20101226/Distribution/Client/Init/Licenses.hs)2
-rw-r--r--cabal/cabal-install/Distribution/Client/Init/Types.hs (renamed from cabal-install-0.9.5_rc20101226/Distribution/Client/Init/Types.hs)0
-rw-r--r--cabal/cabal-install/Distribution/Client/Install.hs (renamed from cabal-install-0.9.5_rc20101226/Distribution/Client/Install.hs)429
-rw-r--r--cabal/cabal-install/Distribution/Client/InstallPlan.hs (renamed from cabal-install-0.9.5_rc20101226/Distribution/Client/InstallPlan.hs)38
-rw-r--r--cabal/cabal-install/Distribution/Client/InstallSymlink.hs (renamed from cabal-install-0.9.5_rc20101226/Distribution/Client/InstallSymlink.hs)4
-rw-r--r--cabal/cabal-install/Distribution/Client/List.hs530
-rw-r--r--cabal/cabal-install/Distribution/Client/PackageIndex.hs (renamed from cabal-install-0.9.5_rc20101226/Distribution/Client/PackageIndex.hs)42
-rw-r--r--cabal/cabal-install/Distribution/Client/PackageUtils.hs (renamed from cabal-install-0.9.5_rc20101226/Distribution/Client/PackageUtils.hs)0
-rw-r--r--cabal/cabal-install/Distribution/Client/Setup.hs (renamed from cabal-install-0.9.5_rc20101226/Distribution/Client/Setup.hs)97
-rw-r--r--cabal/cabal-install/Distribution/Client/SetupWrapper.hs (renamed from cabal-install-0.9.5_rc20101226/Distribution/Client/SetupWrapper.hs)0
-rw-r--r--cabal/cabal-install/Distribution/Client/SrcDist.hs (renamed from cabal-install-0.9.5_rc20101226/Distribution/Client/SrcDist.hs)0
-rw-r--r--cabal/cabal-install/Distribution/Client/Tar.hs (renamed from cabal-install-0.9.5_rc20101226/Distribution/Client/Tar.hs)70
-rw-r--r--cabal/cabal-install/Distribution/Client/Targets.hs743
-rw-r--r--cabal/cabal-install/Distribution/Client/Types.hs (renamed from cabal-install-0.9.5_rc20101226/Distribution/Client/Types.hs)122
-rw-r--r--cabal/cabal-install/Distribution/Client/Unpack.hs123
-rw-r--r--cabal/cabal-install/Distribution/Client/Update.hs (renamed from cabal-install-0.9.5_rc20101226/Distribution/Client/Update.hs)10
-rw-r--r--cabal/cabal-install/Distribution/Client/Upload.hs (renamed from cabal-install-0.9.5_rc20101226/Distribution/Client/Upload.hs)57
-rw-r--r--cabal/cabal-install/Distribution/Client/Utils.hs (renamed from cabal-install-0.9.5_rc20101226/Distribution/Client/Utils.hs)0
-rw-r--r--cabal/cabal-install/Distribution/Client/Win32SelfUpgrade.hs (renamed from cabal-install-0.9.5_rc20101226/Distribution/Client/Win32SelfUpgrade.hs)0
-rw-r--r--cabal/cabal-install/Distribution/Client/World.hs (renamed from cabal-install-0.9.5_rc20101226/Distribution/Client/World.hs)129
-rw-r--r--cabal/cabal-install/Distribution/Compat/ExceptionCI.hs (renamed from cabal-install-0.9.5_rc20101226/Distribution/Compat/Exception.hs)2
-rw-r--r--cabal/cabal-install/Distribution/Compat/FilePerms.hs40
-rw-r--r--cabal/cabal-install/LICENSE (renamed from cabal-install-0.9.5_rc20101226/LICENSE)0
-rw-r--r--cabal/cabal-install/Main.hs (renamed from cabal-install-0.9.5_rc20101226/Main.hs)75
-rw-r--r--cabal/cabal-install/Paths_cabal_install.hs (renamed from cabal-install-0.9.5_rc20101226/Paths_cabal_install.hs)2
-rw-r--r--cabal/cabal-install/README (renamed from cabal-install-0.9.5_rc20101226/README)2
-rw-r--r--cabal/cabal-install/Setup.hs (renamed from cabal-install-0.9.5_rc20101226/Setup.hs)0
-rw-r--r--cabal/cabal-install/bash-completion/cabal (renamed from cabal-install-0.9.5_rc20101226/bash-completion/cabal)0
-rw-r--r--cabal/cabal-install/bootstrap.sh (renamed from cabal-install-0.9.5_rc20101226/bootstrap.sh)76
-rw-r--r--cabal/cabal-install/cabal-install.cabal (renamed from cabal-install-0.9.5_rc20101226/cabal-install.cabal)11
-rw-r--r--cabal/cabal-install/changelog (renamed from cabal-install-0.9.5_rc20101226/changelog)21
-rw-r--r--cabal/cabal-install/tests/test-cabal-install (renamed from cabal-install-0.9.5_rc20101226/tests/test-cabal-install)0
-rw-r--r--cabal/cabal-install/tests/test-cabal-install-user (renamed from cabal-install-0.9.5_rc20101226/tests/test-cabal-install-user)0
-rw-r--r--cabal/cabal/Cabal.cabal163
-rw-r--r--cabal/cabal/DefaultSetup.hs2
-rw-r--r--cabal/cabal/Distribution/Compat/CopyFile.hs115
-rw-r--r--cabal/cabal/Distribution/Compat/Exception.hs61
-rw-r--r--cabal/cabal/Distribution/Compat/ReadP.hs470
-rw-r--r--cabal/cabal/Distribution/Compat/TempFile.hs204
-rw-r--r--cabal/cabal/Distribution/Compiler.hs158
-rw-r--r--cabal/cabal/Distribution/GetOpt.hs335
-rw-r--r--cabal/cabal/Distribution/InstalledPackageInfo.hs294
-rw-r--r--cabal/cabal/Distribution/License.hs138
-rw-r--r--cabal/cabal/Distribution/Make.hs213
-rw-r--r--cabal/cabal/Distribution/ModuleName.hs130
-rw-r--r--cabal/cabal/Distribution/Package.hs193
-rw-r--r--cabal/cabal/Distribution/PackageDescription.hs895
-rw-r--r--cabal/cabal/Distribution/PackageDescription/Check.hs1441
-rw-r--r--cabal/cabal/Distribution/PackageDescription/Configuration.hs618
-rw-r--r--cabal/cabal/Distribution/PackageDescription/Parse.hs1074
-rw-r--r--cabal/cabal/Distribution/PackageDescription/PrettyPrint.hs238
-rw-r--r--cabal/cabal/Distribution/ParseUtils.hs715
-rw-r--r--cabal/cabal/Distribution/ReadE.hs81
-rw-r--r--cabal/cabal/Distribution/Simple.hs677
-rw-r--r--cabal/cabal/Distribution/Simple/Build.hs274
-rw-r--r--cabal/cabal/Distribution/Simple/Build/Macros.hs57
-rw-r--r--cabal/cabal/Distribution/Simple/Build/PathsModule.hs258
-rw-r--r--cabal/cabal/Distribution/Simple/BuildPaths.hs150
-rw-r--r--cabal/cabal/Distribution/Simple/Command.hs545
-rw-r--r--cabal/cabal/Distribution/Simple/Compiler.hs194
-rw-r--r--cabal/cabal/Distribution/Simple/Configure.hs1036
-rw-r--r--cabal/cabal/Distribution/Simple/GHC.hs1079
-rw-r--r--cabal/cabal/Distribution/Simple/GHC/IPI641.hs129
-rw-r--r--cabal/cabal/Distribution/Simple/GHC/IPI642.hs164
-rw-r--r--cabal/cabal/Distribution/Simple/Haddock.hs629
-rw-r--r--cabal/cabal/Distribution/Simple/Hpc.hs185
-rw-r--r--cabal/cabal/Distribution/Simple/Hugs.hs632
-rw-r--r--cabal/cabal/Distribution/Simple/Install.hs214
-rw-r--r--cabal/cabal/Distribution/Simple/InstallDirs.hs600
-rw-r--r--cabal/cabal/Distribution/Simple/JHC.hs221
-rw-r--r--cabal/cabal/Distribution/Simple/LHC.hs805
-rw-r--r--cabal/cabal/Distribution/Simple/LocalBuildInfo.hs306
-rw-r--r--cabal/cabal/Distribution/Simple/NHC.hs424
-rw-r--r--cabal/cabal/Distribution/Simple/PackageIndex.hs562
-rw-r--r--cabal/cabal/Distribution/Simple/PreProcess.hs596
-rw-r--r--cabal/cabal/Distribution/Simple/PreProcess/Unlit.hs165
-rw-r--r--cabal/cabal/Distribution/Simple/Program.hs217
-rw-r--r--cabal/cabal/Distribution/Simple/Program/Ar.hs70
-rw-r--r--cabal/cabal/Distribution/Simple/Program/Builtin.hs259
-rw-r--r--cabal/cabal/Distribution/Simple/Program/Db.hs409
-rw-r--r--cabal/cabal/Distribution/Simple/Program/HcPkg.hs338
-rw-r--r--cabal/cabal/Distribution/Simple/Program/Ld.hs62
-rw-r--r--cabal/cabal/Distribution/Simple/Program/Run.hs218
-rw-r--r--cabal/cabal/Distribution/Simple/Program/Script.hs105
-rw-r--r--cabal/cabal/Distribution/Simple/Program/Types.hs122
-rw-r--r--cabal/cabal/Distribution/Simple/Register.hs390
-rw-r--r--cabal/cabal/Distribution/Simple/Setup.hs1584
-rw-r--r--cabal/cabal/Distribution/Simple/SrcDist.hs418
-rw-r--r--cabal/cabal/Distribution/Simple/Test.hs486
-rw-r--r--cabal/cabal/Distribution/Simple/UHC.hs300
-rw-r--r--cabal/cabal/Distribution/Simple/UserHooks.hs220
-rw-r--r--cabal/cabal/Distribution/Simple/Utils.hs1131
-rw-r--r--cabal/cabal/Distribution/System.hs179
-rw-r--r--cabal/cabal/Distribution/TestSuite.hs310
-rw-r--r--cabal/cabal/Distribution/Text.hs68
-rw-r--r--cabal/cabal/Distribution/Verbosity.hs113
-rw-r--r--cabal/cabal/Distribution/Version.hs742
-rw-r--r--cabal/cabal/LICENSE33
-rw-r--r--cabal/cabal/Language/Haskell/Extension.hs516
-rw-r--r--cabal/cabal/Makefile130
-rw-r--r--cabal/cabal/Paths_Cabal.hs8
-rw-r--r--cabal/cabal/README168
-rw-r--r--cabal/cabal/Setup.hs10
-rw-r--r--cabal/cabal/changelog385
-rw-r--r--cabal/cabal/doc/Cabal.css39
-rw-r--r--cabal/cabal/doc/developing-packages.markdown1447
-rw-r--r--cabal/cabal/doc/index.markdown169
-rw-r--r--cabal/cabal/doc/installing-packages.markdown809
-rw-r--r--cabal/cabal/doc/misc.markdown109
-rw-r--r--cabal/cabal/prologue.txt7
-rw-r--r--cabal/cabal/runTests.sh21
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs15
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal20
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs10
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Setup.hs3
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs15
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal20
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Setup.hs3
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs7
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs20
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs10
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Setup.hs3
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal24
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs6
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs12
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs10
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Setup.hs3
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal23
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs6
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs24
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs10
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Setup.hs3
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal23
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs6
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs10
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/Setup.hs3
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal18
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs24
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs10
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Setup.hs3
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal23
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs6
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs10
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/Setup.hs3
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal18
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs24
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs10
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Setup.hs3
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal23
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs6
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs10
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/Setup.hs3
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal18
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs12
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs10
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal31
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Setup.hs3
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs7
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs7
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs18
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs10
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Setup.hs3
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs7
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal22
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs13
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs10
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Setup.hs3
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs5
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal24
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs17
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs10
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Setup.hs3
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs7
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal22
-rw-r--r--cabal/cabal/tests/PackageTests/PackageTester.hs192
-rw-r--r--cabal/cabal/tests/PackageTests/TestStanza/Check.hs57
-rw-r--r--cabal/cabal/tests/PackageTests/TestStanza/Setup.hs3
-rw-r--r--cabal/cabal/tests/PackageTests/TestStanza/my.cabal19
-rw-r--r--cabal/cabal/tests/PackageTests/TestSuiteExeV10/Check.hs47
-rw-r--r--cabal/cabal/tests/PackageTests/TestSuiteExeV10/Foo.hs4
-rw-r--r--cabal/cabal/tests/PackageTests/TestSuiteExeV10/Setup.hs3
-rw-r--r--cabal/cabal/tests/PackageTests/TestSuiteExeV10/my.cabal15
-rw-r--r--cabal/cabal/tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs8
-rw-r--r--cabal/cabal/tests/README14
-rw-r--r--cabal/cabal/tests/Setup.hs3
-rw-r--r--cabal/cabal/tests/Test/Distribution/Version.hs644
-rw-r--r--cabal/cabal/tests/Test/Laws.hs79
-rw-r--r--cabal/cabal/tests/Test/QuickCheck/Utils.hs29
-rw-r--r--cabal/cabal/tests/UnitTest.hs474
-rw-r--r--cabal/cabal/tests/UnitTest/Distribution/PackageDescription.hs416
-rw-r--r--cabal/cabal/tests/UnitTest/Distribution/PackageDescription/Configuration.hs135
-rw-r--r--cabal/cabal/tests/UnitTest/Distribution/ParseUtils.hs215
-rw-r--r--cabal/cabal/tests/UnitTest/Distribution/Simple/PreProcess/UnlitTest.hs60
-rw-r--r--cabal/cabal/tests/UnitTest/Distribution/Version.hs118
-rw-r--r--cabal/cabal/tests/hackage/check.sh25
-rw-r--r--cabal/cabal/tests/hackage/download.sh19
-rw-r--r--cabal/cabal/tests/hackage/unpack.sh16
-rw-r--r--cabal/cabal/tests/misc/ghc-supported-languages.hs99
-rw-r--r--cabal/cabal/tests/suite.cabal30
-rw-r--r--cabal/cabal/tests/suite.hs66
-rw-r--r--cabal/cabal/tests/systemTests/A/A.cabal23
-rw-r--r--cabal/cabal/tests/systemTests/A/A.hs4
-rw-r--r--cabal/cabal/tests/systemTests/A/B/A.lhs4
-rw-r--r--cabal/cabal/tests/systemTests/A/B/MainB.hs5
-rw-r--r--cabal/cabal/tests/systemTests/A/MainA.hs5
-rw-r--r--cabal/cabal/tests/systemTests/A/Makefile1
-rw-r--r--cabal/cabal/tests/systemTests/A/Setup.lhs8
-rw-r--r--cabal/cabal/tests/systemTests/A/c_src/hello.c1
-rw-r--r--cabal/cabal/tests/systemTests/A/hello.c1
-rw-r--r--cabal/cabal/tests/systemTests/buildInfo/Makefile1
-rw-r--r--cabal/cabal/tests/systemTests/buildInfo/Setup.lhs5
-rw-r--r--cabal/cabal/tests/systemTests/buildInfo/buildinfo2.buildinfo5
-rw-r--r--cabal/cabal/tests/systemTests/buildInfo/buildinfo2.cabal19
-rw-r--r--cabal/cabal/tests/systemTests/buildInfo/src/exe1.hs4
-rw-r--r--cabal/cabal/tests/systemTests/buildInfo/src/exe2.hs4
-rw-r--r--cabal/cabal/tests/systemTests/dataDir/Exe.hs17
-rw-r--r--cabal/cabal/tests/systemTests/dataDir/data-file0
-rw-r--r--cabal/cabal/tests/systemTests/dataDir/dataDir.cabal13
-rw-r--r--cabal/cabal/tests/systemTests/depOnLib/Makefile1
-rw-r--r--cabal/cabal/tests/systemTests/depOnLib/Setup.lhs8
-rw-r--r--cabal/cabal/tests/systemTests/depOnLib/libs/A.hs4
-rw-r--r--cabal/cabal/tests/systemTests/depOnLib/mains/Main.hs4
-rw-r--r--cabal/cabal/tests/systemTests/depOnLib/test.cabal13
-rw-r--r--cabal/cabal/tests/systemTests/exeWithC/Makefile1
-rw-r--r--cabal/cabal/tests/systemTests/exeWithC/Setup.lhs2
-rw-r--r--cabal/cabal/tests/systemTests/exeWithC/a.c1
-rw-r--r--cabal/cabal/tests/systemTests/exeWithC/test.hs4
-rw-r--r--cabal/cabal/tests/systemTests/exeWithC/tt.cabal13
-rw-r--r--cabal/cabal/tests/systemTests/ffi-bin/Main.hs7
-rw-r--r--cabal/cabal/tests/systemTests/ffi-bin/Makefile1
-rw-r--r--cabal/cabal/tests/systemTests/ffi-bin/Setup.lhs4
-rw-r--r--cabal/cabal/tests/systemTests/ffi-bin/main.cabal6
-rw-r--r--cabal/cabal/tests/systemTests/ffi-package/Makefile1
-rw-r--r--cabal/cabal/tests/systemTests/ffi-package/Setup.lhs4
-rw-r--r--cabal/cabal/tests/systemTests/ffi-package/TestFFIExe.hs11
-rw-r--r--cabal/cabal/tests/systemTests/ffi-package/src/TestFFI.hs8
-rw-r--r--cabal/cabal/tests/systemTests/ffi-package/testffi.cabal10
-rw-r--r--cabal/cabal/tests/systemTests/preprocess/preprocess.cabal9
-rw-r--r--cabal/cabal/tests/systemTests/preprocess/src/C2HsExample.chs3
-rw-r--r--cabal/cabal/tests/systemTests/preprocess/src/HappyExample.y92
-rw-r--r--cabal/cabal/tests/systemTests/recursive/A.hi-boot2
-rw-r--r--cabal/cabal/tests/systemTests/recursive/A.hs8
-rw-r--r--cabal/cabal/tests/systemTests/recursive/A.hs-boot2
-rw-r--r--cabal/cabal/tests/systemTests/recursive/B.hs8
-rw-r--r--cabal/cabal/tests/systemTests/recursive/C.hs6
-rw-r--r--cabal/cabal/tests/systemTests/recursive/Makefile1
-rw-r--r--cabal/cabal/tests/systemTests/recursive/Setup.lhs8
-rw-r--r--cabal/cabal/tests/systemTests/recursive/recursive.cabal11
-rw-r--r--cabal/cabal/tests/systemTests/sdist/Exe1.hs1
-rw-r--r--cabal/cabal/tests/systemTests/sdist/Exe2.hs1
-rw-r--r--cabal/cabal/tests/systemTests/sdist/sdist.cabal19
-rw-r--r--cabal/cabal/tests/systemTests/twoMains/MainA.hs9
-rw-r--r--cabal/cabal/tests/systemTests/twoMains/MainB.hs9
-rw-r--r--cabal/cabal/tests/systemTests/twoMains/Makefile1
-rw-r--r--cabal/cabal/tests/systemTests/twoMains/Setup.lhs8
-rw-r--r--cabal/cabal/tests/systemTests/twoMains/test.cabal14
-rw-r--r--cabal/cabal/tests/systemTests/wash2hs/CHANGES5
-rw-r--r--cabal/cabal/tests/systemTests/wash2hs/LICENSE27
-rw-r--r--cabal/cabal/tests/systemTests/wash2hs/Makefile1
-rw-r--r--cabal/cabal/tests/systemTests/wash2hs/Setup.lhs9
-rw-r--r--cabal/cabal/tests/systemTests/wash2hs/hs/WASHClean.hs58
-rw-r--r--cabal/cabal/tests/systemTests/wash2hs/hs/WASHData.hs74
-rw-r--r--cabal/cabal/tests/systemTests/wash2hs/hs/WASHExpression.hs158
-rw-r--r--cabal/cabal/tests/systemTests/wash2hs/hs/WASHFlags.hs7
-rw-r--r--cabal/cabal/tests/systemTests/wash2hs/hs/WASHGenerator.hs57
-rw-r--r--cabal/cabal/tests/systemTests/wash2hs/hs/WASHMain.hs36
-rw-r--r--cabal/cabal/tests/systemTests/wash2hs/hs/WASHOut.hs30
-rw-r--r--cabal/cabal/tests/systemTests/wash2hs/hs/WASHParser.hs541
-rw-r--r--cabal/cabal/tests/systemTests/wash2hs/hs/WASHUtil.hs82
-rw-r--r--cabal/cabal/tests/systemTests/wash2hs/test/Counter.wash19
-rw-r--r--cabal/cabal/tests/systemTests/wash2hs/test/ManuelsTable.wash45
-rw-r--r--cabal/cabal/tests/systemTests/wash2hs/test/Tutorial.wash241
-rw-r--r--cabal/cabal/tests/systemTests/wash2hs/wash2hs.cabal14
-rw-r--r--cabal/cabal/tests/systemTests/withHooks/C.testSuffix4
-rw-r--r--cabal/cabal/tests/systemTests/withHooks/D.gc4
-rw-r--r--cabal/cabal/tests/systemTests/withHooks/Main.hs3
-rw-r--r--cabal/cabal/tests/systemTests/withHooks/Makefile1
-rw-r--r--cabal/cabal/tests/systemTests/withHooks/Setup.buildinfo.in5
-rw-r--r--cabal/cabal/tests/systemTests/withHooks/Setup.lhs78
-rw-r--r--cabal/cabal/tests/systemTests/withHooks/WithHooks.hs3
-rw-r--r--cabal/cabal/tests/systemTests/withHooks/withHooks.cabal11
-rw-r--r--cabal/ghc-packages2
-rw-r--r--hackport.cabal13
327 files changed, 38779 insertions, 2415 deletions
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..7773828
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1 @@
+dist/ \ No newline at end of file
diff --git a/Cabal2Ebuild.hs b/Cabal2Ebuild.hs
index b699d4c..d56405f 100644
--- a/Cabal2Ebuild.hs
+++ b/Cabal2Ebuild.hs
@@ -48,12 +48,14 @@ cabal2ebuild pkg = Portage.ebuildTemplate {
E.version = display (Cabal.pkgVersion (Cabal.package pkg)),
E.description = if null (Cabal.synopsis pkg) then Cabal.description pkg
else Cabal.synopsis pkg,
+ E.long_desc = if null (Cabal.description pkg) then Cabal.synopsis pkg
+ else Cabal.description pkg,
E.homepage = thisHomepage,
E.license = Cabal.license pkg,
E.my_pn = if any isUpper cabalPkgName then Just cabalPkgName else Nothing,
E.features = E.features E.ebuildTemplate
++ (if hasExe then ["bin"] else [])
- ++ maybe [] (const (["lib","profile","haddock"]
+ ++ maybe [] (const (["lib","profile","haddock","hoogle"]
++ if cabalPkgName == "hscolour" then [] else ["hscolour"])
) (Cabal.library pkg) -- hscolour can't colour its own sources
} where
@@ -117,7 +119,7 @@ coreLibs = map Cabal.PackageName
,"random"
,"readline" --has ebuild, but only in the overlay
,"rts"
- ,"syb" -- intentionally no ebuild. use ghc's version
+ -- ,"syb" -- was splitted off from ghc again
,"template-haskell"
,"unix" --has ebuild, but only in the overlay
]
diff --git a/Diff.hs b/Diff.hs
index ef2a597..9f1559e 100644
--- a/Diff.hs
+++ b/Diff.hs
@@ -23,7 +23,7 @@ import qualified Distribution.Client.PackageIndex as Index
import Distribution.Simple.Utils (equating)
-- cabal-install
-import qualified Distribution.Client.IndexUtils as Index (getAvailablePackages )
+import qualified Distribution.Client.IndexUtils as Index (getSourcePackages)
import qualified Distribution.Client.Types as Cabal
import Distribution.Client.Utils (mergeBy, MergeResult(..))
@@ -61,8 +61,8 @@ showDiffState pkg st = (tabs (display pkg)) ++ " [" ++ (case st of
runDiff :: Verbosity -> FilePath -> DiffMode -> Cabal.Repo -> IO ()
runDiff verbosity overlayPath dm repo = do
-- get package list from hackage
- pkgDB <- Index.getAvailablePackages verbosity [ repo ]
- let (Cabal.AvailablePackageDb hackageIndex _) = pkgDB
+ pkgDB <- Index.getSourcePackages verbosity [ repo ]
+ let (Cabal.SourcePackageDb hackageIndex _) = pkgDB
-- get package list from the overlay
overlay0 <- (Portage.loadLazy overlayPath)
@@ -71,8 +71,8 @@ runDiff verbosity overlayPath dm repo = do
let (subHackage, subOverlay)
= case dm of
ShowPackages pkgs ->
- (concatMap (Index.searchByNameSubstring hackageIndex) pkgs
- ,concatMap (Index.searchByNameSubstring overlayIndex) pkgs)
+ (concatMap (concatMap snd . Index.searchByNameSubstring hackageIndex) pkgs
+ ,concatMap (concatMap snd . Index.searchByNameSubstring overlayIndex) pkgs)
_ ->
(Index.allPackages hackageIndex
,Index.allPackages overlayIndex)
@@ -100,7 +100,7 @@ showPackageCompareInfo pkgCmpInfo =
GT -> ">"
LT -> "<"
-diff :: [Cabal.AvailablePackage]
+diff :: [Cabal.SourcePackage]
-> [Portage.ExistingEbuild]
-> DiffMode
-> IO ()
diff --git a/DistroMap.hs b/DistroMap.hs
index 64a72ab..0e34294 100644
--- a/DistroMap.hs
+++ b/DistroMap.hs
@@ -46,7 +46,7 @@ import Data.Maybe ( fromJust )
import Distribution.Verbosity
import Distribution.Text ( display )
-import Distribution.Client.Types ( Repo, AvailablePackageDb(..), AvailablePackage(..) )
+import Distribution.Client.Types ( Repo, SourcePackageDb(..), SourcePackage(..) )
import Distribution.Simple.Utils ( info )
import qualified Data.Version as Cabal
@@ -83,8 +83,8 @@ distroMap verbosity repo portagePath overlayPath args = do
info verbosity ("overlay map: " ++ show (Map.size overlayMap))
info verbosity ("complete map: " ++ show (Map.size completeMap))
- AvailablePackageDb { packageIndex = packageIndex } <-
- CabalInstall.getAvailablePackages verbosity [repo]
+ SourcePackageDb { packageIndex = packageIndex } <-
+ CabalInstall.getSourcePackages verbosity [repo]
let pkgs0 = map (map packageInfoId) (CabalInstall.allPackagesByName packageIndex)
hackagePkgs = [ (Cabal.pkgName (head p), map Cabal.pkgVersion p) | p <- pkgs0 ]
diff --git a/Error.hs b/Error.hs
index 7a6fa66..c0ff2d1 100644
--- a/Error.hs
+++ b/Error.hs
@@ -55,7 +55,7 @@ hackPortShowError err = case err of
CabalParseFailed file reason -> "Error while parsing cabal file '"++file++"': "++reason
BashNotFound -> "The 'bash' executable was not found. It is required to figure out your portage-overlay. If you don't want to install bash, use '-p path-to-overlay'"
BashError str -> "Error while guessing your portage-overlay. Either set PORTDIR_OVERLAY in /etc/make.conf or use '-p path-to-overlay'.\nThe error was: \""++str++"\""
- MultipleOverlays overlays -> "You have the following overlays available: '"++unwords overlays++"'. Please choose one by using '-p path-to-overlay'"
+ MultipleOverlays overlays -> "You have the following overlays available: '"++unwords overlays++"'. Please choose one by using 'hackport -p path-to-overlay' <command>"
NoOverlay -> "You don't have PORTDIR_OVERLAY set in '/etc/make.conf'. Please set it or use '-p path-to-overlay'"
UnknownVerbosityLevel str -> "The verbosity level '"++str++"' is invalid. Please use debug,normal or silent"
InvalidServer srv -> "Invalid server address, could not parse: " ++ srv
diff --git a/Main.hs b/Main.hs
index 377e244..53477e9 100644
--- a/Main.hs
+++ b/Main.hs
@@ -102,10 +102,10 @@ listAction flags extraArgs globalFlags = do
let verbosity = fromFlag (listVerbosity flags)
overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags)
let repo = defaultRepo overlayPath
- index <- fmap packageIndex (Index.getAvailablePackages verbosity [ repo ])
+ index <- fmap packageIndex (Index.getSourcePackages verbosity [ repo ])
overlay <- Overlay.loadLazy overlayPath
let pkgs | null extraArgs = Index.allPackages index
- | otherwise = concatMap (Index.searchByNameSubstring index) extraArgs
+ | otherwise = concatMap (concatMap snd . Index.searchByNameSubstring index) extraArgs
normalized = map (normalizeCabalPackageId . packageInfoId) pkgs
let decorated = map (\p -> (Overlay.inOverlay overlay p, p)) normalized
mapM_ (putStrLn . pretty) decorated
diff --git a/Merge.hs b/Merge.hs
index e064bfe..69a8f2c 100644
--- a/Merge.hs
+++ b/Merge.hs
@@ -21,6 +21,7 @@ import Distribution.Text (display)
import System.Directory ( getCurrentDirectory
, setCurrentDirectory
, createDirectoryIfMissing
+ , doesFileExist
)
import System.Cmd (system)
import System.FilePath ((</>))
@@ -38,7 +39,7 @@ import Distribution.Simple.Utils
import Network.URI
-import Distribution.Client.IndexUtils ( getAvailablePackages )
+import Distribution.Client.IndexUtils ( getSourcePackages )
import Distribution.Client.HttpUtils ( downloadURI )
import qualified Distribution.Client.PackageIndex as Index
import Distribution.Client.Types
@@ -46,6 +47,7 @@ import Distribution.Client.Types
import qualified Portage.PackageId as Portage
import qualified Portage.Version as Portage
import qualified Portage.Host as Host
+import qualified Portage.Metadata as Portage
import qualified Portage.Overlay as Overlay
import qualified Portage.Resolve as Portage
@@ -92,7 +94,7 @@ readPackageString args = do
-- | Given a list of available packages, and maybe a preferred version,
-- return the available package with that version. Latest version is chosen
-- if no preference.
-resolveVersion :: [AvailablePackage] -> Maybe Cabal.Version -> Maybe AvailablePackage
+resolveVersion :: [SourcePackage] -> Maybe Cabal.Version -> Maybe SourcePackage
resolveVersion avails Nothing = Just $ maximumBy (comparing packageInfoId) avails
resolveVersion avails (Just ver) = listToMaybe (filter match avails)
where
@@ -119,14 +121,14 @@ merge verbosity repo serverURI args overlayPath = do
overlay <- Overlay.loadLazy overlayPath
-- portage_path <- Host.portage_dir `fmap` Host.getInfo
-- portage <- Overlay.loadLazy portage_path
- index <- fmap packageIndex $ getAvailablePackages verbosity [ repo ]
+ index <- fmap packageIndex $ getSourcePackages verbosity [ repo ]
-- find all packages that maches the user specified package name
availablePkgs <-
- case Index.searchByName index user_pname_str of
- Index.None -> throwEx (PackageNotFound user_pname_str)
- Index.Ambiguous pkgs -> throwEx (ArgumentError ("Ambiguous name: " ++ unwords (map show pkgs)))
- Index.Unambiguous pkg -> return pkg
+ case map snd (Index.searchByName index user_pname_str) of
+ [] -> throwEx (PackageNotFound user_pname_str)
+ [pkg] -> return pkg
+ pkgs -> throwEx (ArgumentError ("Ambiguous name: " ++ unwords (map show pkgs)))
-- select a single package taking into account the user specified version
selectedPkg <-
@@ -235,6 +237,17 @@ mergeEbuild verbosity target cat ebuild = do
let edir = target </> cat </> E.name ebuild
elocal = E.name ebuild ++"-"++ E.version ebuild <.> "ebuild"
epath = edir </> elocal
+ emeta = "metadata.xml"
+ mpath = edir </> emeta
+ default_meta = Portage.makeDefaultMetadata (E.long_desc ebuild)
createDirectoryIfMissing True edir
- info verbosity $ "Writing " ++ elocal
+ notice verbosity $ "Writing " ++ elocal
writeFile epath (display ebuild)
+
+ yet_meta <- doesFileExist mpath
+ if (not yet_meta) -- TODO: add --force-meta-rewrite to opts
+ then do notice verbosity $ "Writing " ++ emeta
+ writeFile mpath default_meta
+ else do current_meta <- readFile mpath
+ when (current_meta /= default_meta) $
+ notice verbosity $ "Default and current " ++ emeta ++ " differ."
diff --git a/Portage.hs b/Portage.hs
deleted file mode 100644
index 4b870b6..0000000
--- a/Portage.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-module Portage where
-
-import System.Directory
-import Text.Regex
-import Data.Maybe
-
-ebuildVersionRegex :: String -> Regex
-ebuildVersionRegex name = mkRegex ("^"++name++"-(.*)\\.ebuild$")
-
-filterPackages :: String -> [String] -> IO [String]
-filterPackages _ [] = return []
-filterPackages base (x:xs) = do
- ak <- case x of
- "." -> return Nothing
- ".." -> return Nothing
- dir -> do
- exists <- doesDirectoryExist (base++dir)
- return (if exists then Just dir else Nothing)
- rest <- filterPackages base xs
- return (maybe rest (:rest) ak)
diff --git a/Portage/EBuild.hs b/Portage/EBuild.hs
index 637ccff..1a6d058 100644
--- a/Portage/EBuild.hs
+++ b/Portage/EBuild.hs
@@ -19,6 +19,7 @@ data EBuild = EBuild {
version :: String,
hackportVersion :: String,
description :: String,
+ long_desc :: String,
homepage :: String,
license :: Cabal.License,
slot :: String,
@@ -42,6 +43,7 @@ ebuildTemplate = EBuild {
version = "0.1",
hackportVersion = getHackportVersion Paths_hackport.version,
description = "",
+ long_desc = "",
homepage = "http://hackage.haskell.org/package/${PN}",
license = Cabal.UnknownLicense "xxx UNKNOWN xxx",
slot = "0",
diff --git a/Portage/GHCCore.hs b/Portage/GHCCore.hs
index 564f8ea..19af330 100644
--- a/Portage/GHCCore.hs
+++ b/Portage/GHCCore.hs
@@ -21,8 +21,6 @@ import Distribution.Text
import Data.Maybe
import Data.List ( nub )
-import Text.PrettyPrint.HughesPJ
-
defaultGHC :: (CompilerId, [PackageName])
defaultGHC = let (g,pix) = ghc6123 in (g, packageNamesFromPackageIndex pix)
diff --git a/Portage/Host.hs b/Portage/Host.hs
index 1c20a5c..5733a7b 100644
--- a/Portage/Host.hs
+++ b/Portage/Host.hs
@@ -4,7 +4,6 @@ module Portage.Host
) where
import Util (run_cmd)
-import Data.Char (isSpace)
import Data.Maybe (fromJust, isJust, catMaybes)
import Control.Applicative ( (<$>) )
diff --git a/Portage/Metadata.hs b/Portage/Metadata.hs
index e36b1e5..1190209 100644
--- a/Portage/Metadata.hs
+++ b/Portage/Metadata.hs
@@ -1,6 +1,7 @@
module Portage.Metadata
( Metadata(..)
, metadataFromFile
+ , makeDefaultMetadata
) where
import qualified Data.ByteString as B
@@ -9,8 +10,6 @@ import Control.Applicative
import Text.XML.Light
-import Control.Monad
-
data Metadata = Metadata
{ metadataHerds :: [String]
-- , metadataMaintainers :: [String],
@@ -29,3 +28,28 @@ parseMetadata xml = do
{
metadataHerds = herds
}
+
+-- don't use Text.XML.Light as we like our own pretty printer
+makeDefaultMetadata :: String -> String
+makeDefaultMetadata long_description =
+ unlines [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
+ , "<!DOCTYPE pkgmetadata SYSTEM \"http://www.gentoo.org/dtd/metadata.dtd\">"
+ , "<pkgmetadata>"
+ , "\t<herd>haskell</herd>"
+ , "\t<maintainer>"
+ , "\t\t<email>haskell@gentoo.org</email>"
+ , "\t</maintainer>"
+ , (init {- strip trailing newline-}
+ . unlines
+ . map (\l -> if l `elem` ["<longdescription>", "</longdescription>"]
+ then "\t" ++ l -- leading/trailing lines
+ else "\t\t" ++ l -- description itself
+ )
+ . lines
+ . showElement
+ . unode "longdescription"
+ . ("\n" ++) -- prepend newline to separate form <longdescription>
+ . (++ "\n") -- append newline
+ ) long_description
+ , "</pkgmetadata>"
+ ]
diff --git a/README.rst b/README.rst
index ebe91ab..80deae4 100644
--- a/README.rst
+++ b/README.rst
@@ -11,13 +11,35 @@ The main purpose for Hackport is to interact with Hackage and create
Ebuilds from Cabal packages. It also does handy functions to compare
hackage, the overlay and the portage tree.
+Quick start
+-----------
+
+1. Build hackport binary by hand (or install it from haskell overlay).
+2. Setup hackport database into overlay you plan to merge new ebuilds:
+
+::
+
+ $ mkdir ~/overlays
+ $ cd ~/overlays
+ $ git clone git clone git://github.com/gentoo-haskell/gentoo-haskell.git
+ $ cd gentoo-haskell
+ $ hackport update
+ $ ls -1 .hackport/
+ 00-index.tar
+ 00-index.tar.gz
+
+3. Add your ~/overlays/gentoo-haskell to PORTDIR_OVERLAY in /etc/make.conf.
+
+Done! Now you can `hackport merge <package-name>` to get an ebuild merged to
+your overlay!
+
Features
--------
'hackport update'
Update the local copy of hackage's package list. You should run this
every once in a while to get a more recent copy.
-
+
'hackport list [FILTER]'
Print packages from hackage, with an optional substring matching.
@@ -99,7 +121,7 @@ Features
- the ebuilds differ, or
- the overlay has a more recent version
- 'hackport make-ebuild <path/to/package.ebuild>'
+ 'hackport make-ebuild <path/to/package.cabal>'
Generates standalone .ebuild file from .cabal spec and stores result in same
directory.
Option is useful for packages not-on-hackage and for debug purposes.
diff --git a/TODO b/TODO
index e8a3db8..f4ed04a 100644
--- a/TODO
+++ b/TODO
@@ -9,13 +9,13 @@ Easier
still are any missing. set good default values, and make sure we don't
get any 'fromFlag' errors due to missing defaults for all commands
-* catch baseconstraints and upgrade ghc requirement
+* catch base constraints and upgrade ghc requirement
(like in vty-4.0.0.1: base >= 4 leads to ghc >= 6.10)
Harder
======
-* translate the dev-db/libpq dependency into virtual/postgresql-base
+* translate the dev-db/libpq dependency into dev-db/postgresql-base
the cabal field to describe c libs should be translated if we know the
proper gentoo package name.
@@ -33,3 +33,7 @@ Harder
* Merge the separate tool keyword-stat into hackport, and make it use the
hackport API.
See http://code.haskell.org/gentoo/keyword-stat/
+
+* Pick keywords from latest available ebuild
+
+* hacport status --to-portage should warn about different 'ChangeLog' and 'metadata.xml' files
diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency.hs
deleted file mode 100644
index 9a30450..0000000
--- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency.hs
+++ /dev/null
@@ -1,318 +0,0 @@
------------------------------------------------------------------------------
--- |
--- 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 ]
diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/TopDown/Constraints.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/TopDown/Constraints.hs
deleted file mode 100644
index 07b6b1a..0000000
--- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/TopDown/Constraints.hs
+++ /dev/null
@@ -1,316 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Distribution.Client.Dependency.TopDown.Constraints
--- Copyright : (c) Duncan Coutts 2008
--- License : BSD-like
---
--- Maintainer : duncan@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- A set of satisfiable dependencies (package version constraints).
------------------------------------------------------------------------------
-module Distribution.Client.Dependency.TopDown.Constraints (
- Constraints,
- empty,
- choices,
- isPaired,
-
- constrain,
- Satisfiable(..),
- conflicting,
- ) where
-
-import Distribution.Client.Dependency.TopDown.Types
-import qualified Distribution.Client.PackageIndex as PackageIndex
-import Distribution.Client.PackageIndex (PackageIndex)
-import Distribution.Package
- ( PackageName, PackageIdentifier(..)
- , Package(packageId), packageName, packageVersion
- , PackageFixedDeps(depends)
- , Dependency(Dependency) )
-import Distribution.Version
- ( Version, withinRange )
-import Distribution.Client.Utils
- ( mergeBy, MergeResult(..) )
-
-import Data.List
- ( foldl' )
-import Data.Monoid
- ( Monoid(mempty) )
-import Data.Maybe
- ( catMaybes )
-import qualified Data.Map as Map
-import Data.Map (Map)
-import Control.Exception
- ( assert )
-
--- | A set of constraints on package versions. For each package name we record
--- what other packages depends on it and what constraints they impose on the
--- version of the package.
---
-data (Package installed, Package available)
- => Constraints installed available reason
- = Constraints
-
- -- Remaining available choices
- (PackageIndex (InstalledOrAvailable installed available))
-
- -- Paired choices
- (Map PackageName (Version, Version))
-
- -- Choices that we have excluded for some reason
- -- 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
-
-instance Package pkg => Package (ExcludedPackage pkg reason) where
- packageId (ExcludedPackage p _ _) = packageId p
-
--- | 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 original) = all check merged
- where
- merged = mergeBy (\a b -> packageId a `compare` mergedPackageId b)
- (PackageIndex.allPackages original)
- (mergeBy (\a b -> packageId a `compare` packageId b)
- (PackageIndex.allPackages available)
- (PackageIndex.allPackages excluded))
- where
- mergedPackageId (OnlyInLeft p ) = packageId p
- mergedPackageId (OnlyInRight p) = packageId p
- mergedPackageId (InBoth p _) = packageId p
-
- 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' _) =
- invariant constraints && invariant constraints'
- && null availableGained && null excludedLost
- && map packageId availableLost == map packageId excludedGained
-
- where
- availableLost = foldr lost [] availableChange where
- lost (OnlyInLeft pkg) rest = pkg : rest
- lost (InBoth (InstalledAndAvailable _ pkg)
- (InstalledOnly _)) rest = AvailableOnly pkg : rest
- lost _ rest = rest
- availableGained = [ pkg | OnlyInRight pkg <- availableChange ]
- excludedLost = [ pkg | OnlyInLeft pkg <- excludedChange ]
- excludedGained = [ pkg | OnlyInRight pkg <- excludedChange ]
- ++ [ pkg | InBoth (ExcludedPackage _ (_:_) [])
- pkg@(ExcludedPackage _ (_:_) (_:_))
- <- excludedChange ]
- availableChange = mergeBy (\a b -> packageId a `compare` packageId b)
- (PackageIndex.allPackages available)
- (PackageIndex.allPackages available')
- excludedChange = mergeBy (\a b -> packageId a `compare` packageId b)
- (PackageIndex.allPackages excluded)
- (PackageIndex.allPackages excluded')
-
--- | We construct 'Constraints' with an initial 'PackageIndex' of all the
--- packages available.
---
-empty :: (PackageFixedDeps installed, Package available)
- => PackageIndex installed
- -> PackageIndex available
- -> Constraints installed available reason
-empty installed available = Constraints pkgs pairs mempty pkgs
- where
- pkgs = PackageIndex.fromList
- . map toInstalledOrAvailable
- $ mergeBy (\a b -> packageId a `compare` packageId b)
- (PackageIndex.allPackages installed)
- (PackageIndex.allPackages available)
- toInstalledOrAvailable (OnlyInLeft i ) = InstalledOnly i
- toInstalledOrAvailable (OnlyInRight a) = AvailableOnly a
- toInstalledOrAvailable (InBoth i a) = InstalledAndAvailable i a
-
- -- pick up cases like base-3 and 4 where one version depends on the other:
- pairs = Map.fromList
- [ (name, (packageVersion pkgid1, packageVersion pkgid2))
- | [pkg1, pkg2] <- PackageIndex.allPackagesByName installed
- , let name = packageName pkg1
- pkgid1 = packageId pkg1
- pkgid2 = packageId pkg2
- , any ((pkgid1==) . packageId) (depends pkg2)
- || any ((pkgid2==) . packageId) (depends pkg1) ]
-
--- | The package choices that are still available.
---
-choices :: (Package installed, Package available)
- => Constraints installed available reason
- -> PackageIndex (InstalledOrAvailable installed available)
-choices (Constraints available _ _ _) = available
-
-isPaired :: (Package installed, Package available)
- => Constraints installed available reason
- -> PackageIdentifier -> Maybe PackageIdentifier
-isPaired (Constraints _ pairs _ _) (PackageIdentifier name version) =
- case Map.lookup name pairs of
- Just (v1, v2)
- | version == v1 -> Just (PackageIdentifier name v2)
- | version == v2 -> Just (PackageIdentifier name v1)
- _ -> Nothing
-
-data Satisfiable constraints discarded reason
- = Satisfiable constraints discarded
- | Unsatisfiable
- | ConflictsWith [(PackageIdentifier, [reason])]
-
-constrain :: (Package installed, Package available)
- => TaggedDependency
- -> reason
- -> Constraints installed available reason
- -> Satisfiable (Constraints installed available reason)
- [PackageIdentifier] reason
-constrain (TaggedDependency installedConstraint (Dependency name versionRange))
- reason constraints@(Constraints available paired excluded original)
-
- | not anyRemaining
- = if null conflicts then Unsatisfiable
- else ConflictsWith conflicts
-
- | otherwise
- = let constraints' = Constraints available' paired excluded' original
- in assert (constraints `transitionsTo` constraints') $
- Satisfiable constraints' (map packageId newExcluded)
-
- where
- -- This tells us if any packages would remain at all for this package name if
- -- we applied this constraint. This amounts to checking if any package
- -- satisfies the given constraint, including version range and installation
- -- status.
- --
- anyRemaining = any satisfiesConstraint availableChoices
-
- conflicts = [ (packageId pkg, reasonsAvail ++ reasonsAll)
- | ExcludedPackage pkg reasonsAvail reasonsAll <- excludedChoices
- , satisfiesVersionConstraint pkg ]
-
- -- Applying this constraint may involve deleting some choices for this
- -- package name, or restricting which install states are available.
- available' = updateAvailable available
- updateAvailable = flip (foldl' (flip update)) availableChoices where
- update pkg | not (satisfiesVersionConstraint pkg)
- = PackageIndex.deletePackageId (packageId pkg)
- update _ | installedConstraint == NoInstalledConstraint
- = id
- update pkg = case pkg of
- InstalledOnly _ -> id
- AvailableOnly _ -> PackageIndex.deletePackageId (packageId pkg)
- InstalledAndAvailable i _ -> PackageIndex.insert (InstalledOnly i)
-
- -- Applying the constraint means adding exclusions for the packages that
- -- we're just freshly excluding, ie the ones we're removing from available.
- excluded' = foldl' (flip PackageIndex.insert) excluded
- (newExcluded ++ oldExcluded)
-
- newExcluded = catMaybes (map exclude availableChoices) where
- exclude pkg
- | not (satisfiesVersionConstraint pkg)
- = Just (ExcludedPackage pkgid [] [reason])
- | installedConstraint == NoInstalledConstraint
- = Nothing
- | otherwise = case pkg of
- InstalledOnly _ -> Nothing
- AvailableOnly _ -> Just (ExcludedPackage pkgid [] [reason])
- InstalledAndAvailable _ _ ->
- case PackageIndex.lookupPackageId excluded pkgid of
- Just (ExcludedPackage _ avail both)
- -> Just (ExcludedPackage pkgid (reason:avail) both)
- Nothing -> Just (ExcludedPackage pkgid [reason] [])
- where pkgid = packageId pkg
-
- -- Additionally we have to add extra exclusions for any already-excluded
- -- packages that happen to be covered by the (inverse of the) constraint.
- oldExcluded = catMaybes (map exclude excludedChoices) where
- exclude (ExcludedPackage pkgid avail both)
- -- if it doesn't satisfy the version constraint then we exclude the
- -- package as a whole, the available or the installed instances or both.
- | not (satisfiesVersionConstraint pkgid)
- = Just (ExcludedPackage pkgid avail (reason:both))
- -- if on the other hand it does satisfy the constraint and we were also
- -- constraining to just the installed version then we exclude just the
- -- available instance.
- | installedConstraint == InstalledConstraint
- = Just (ExcludedPackage pkgid (reason:avail) both)
- | otherwise = Nothing
-
- -- util definitions
- availableChoices = PackageIndex.lookupPackageName available name
- excludedChoices = PackageIndex.lookupPackageName excluded name
-
- satisfiesConstraint pkg = satisfiesVersionConstraint pkg
- && satisfiesInstallStateConstraint pkg
-
- satisfiesVersionConstraint :: Package pkg => pkg -> Bool
- satisfiesVersionConstraint = case Map.lookup name paired of
- Nothing -> \pkg ->
- packageVersion pkg `withinRange` versionRange
- Just (v1, v2) -> \pkg -> case packageVersion pkg of
- v | v == v1
- || v == v2 -> v1 `withinRange` versionRange
- || v2 `withinRange` versionRange
- | otherwise -> v `withinRange` versionRange
-
- satisfiesInstallStateConstraint = case installedConstraint of
- NoInstalledConstraint -> \_ -> True
- InstalledConstraint -> \pkg -> case pkg of
- AvailableOnly _ -> False
- _ -> True
-
-conflicting :: (Package installed, Package available)
- => Constraints installed available reason
- -> Dependency
- -> [(PackageIdentifier, [reason])]
-conflicting (Constraints _ _ excluded _) dep =
- [ (pkgid, reasonsAvail ++ reasonsAll) --TODO
- | ExcludedPackage pkgid reasonsAvail reasonsAll <-
- PackageIndex.lookupDependency excluded dep ]
diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Fetch.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Fetch.hs
deleted file mode 100644
index 6e8a91a..0000000
--- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Fetch.hs
+++ /dev/null
@@ -1,259 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Distribution.Client.Fetch
--- Copyright : (c) David Himmelstrup 2005
--- License : BSD-like
---
--- Maintainer : lemmih@gmail.com
--- Stability : provisional
--- Portability : portable
---
---
------------------------------------------------------------------------------
-module Distribution.Client.Fetch (
-
- -- * Commands
- fetch,
-
- -- * Utilities
- fetchPackage,
- isFetched,
- downloadIndex,
- ) where
-
-import Distribution.Client.Types
- ( UnresolvedDependency (..), AvailablePackage(..)
- , AvailablePackageSource(..), AvailablePackageDb(..)
- , Repo(..), RemoteRepo(..), LocalRepo(..)
- , InstalledPackage )
-import Distribution.Client.PackageIndex (PackageIndex)
-import Distribution.Client.Dependency as Dependency
- ( resolveDependenciesWithProgress
- , resolveAvailablePackages
- , dependencyConstraints, dependencyTargets
- , PackagesPreference(..), PackagesPreferenceDefault(..)
- , PackagePreference(..) )
-import Distribution.Client.Dependency.Types
- ( foldProgress )
-import Distribution.Client.IndexUtils as IndexUtils
- ( getAvailablePackages, disambiguateDependencies
- , getInstalledPackages )
-import qualified Distribution.Client.InstallPlan as InstallPlan
-import Distribution.Client.HttpUtils
- ( downloadURI, isOldHackageURI )
-import Distribution.Client.Setup
- ( FetchFlags(..) )
-
-import Distribution.Package
- ( PackageIdentifier, packageId, packageName, packageVersion
- , Dependency(..) )
-import qualified Distribution.Client.PackageIndex as PackageIndex
-import Distribution.Simple.Compiler
- ( Compiler(compilerId), PackageDBStack )
-import Distribution.Simple.Program
- ( ProgramConfiguration )
-import Distribution.Simple.Setup
- ( fromFlag )
-import Distribution.Simple.Utils
- ( die, notice, info, debug, setupMessage )
-import Distribution.System
- ( buildPlatform )
-import Distribution.Text
- ( display )
-import Distribution.Verbosity
- ( Verbosity )
-
-import qualified Data.Map as Map
-import Control.Monad
- ( when, filterM )
-import System.Directory
- ( doesFileExist, createDirectoryIfMissing )
-import System.FilePath
- ( (</>), (<.>) )
-import qualified System.FilePath.Posix as FilePath.Posix
- ( combine, joinPath )
-import Network.URI
- ( URI(uriPath) )
-
-
--- Downloads a package to [config-dir/packages/package-id] and returns the path to the package.
-downloadPackage :: Verbosity -> Repo -> PackageIdentifier -> IO String
-downloadPackage _ repo@Repo{ repoKind = Right LocalRepo } pkgid =
- return (packageFile repo pkgid)
-
-downloadPackage verbosity repo@Repo{ repoKind = Left remoteRepo } pkgid = do
- let uri = packageURI remoteRepo pkgid
- dir = packageDir repo pkgid
- path = packageFile repo pkgid
- debug verbosity $ "GET " ++ show uri
- createDirectoryIfMissing True dir
- downloadURI verbosity uri path
- return path
-
--- Downloads an index file to [config-dir/packages/serv-id].
-downloadIndex :: Verbosity -> RemoteRepo -> FilePath -> IO FilePath
-downloadIndex verbosity repo cacheDir = do
- let uri = (remoteRepoURI repo) {
- uriPath = uriPath (remoteRepoURI repo)
- `FilePath.Posix.combine` "00-index.tar.gz"
- }
- path = cacheDir </> "00-index" <.> "tar.gz"
- createDirectoryIfMissing True cacheDir
- downloadURI verbosity uri path
- return path
-
--- |Returns @True@ if the package has already been fetched.
-isFetched :: AvailablePackage -> IO Bool
-isFetched (AvailablePackage pkgid _ source) = case source of
- LocalUnpackedPackage _ -> return True
- LocalTarballPackage _ -> return True
- RemoteTarballPackage _ -> return False --TODO: ad-hoc download caching
- RepoTarballPackage repo -> doesFileExist (packageFile repo pkgid)
-
--- |Fetch a package if we don't have it already.
-fetchPackage :: Verbosity -> Repo -> PackageIdentifier -> IO String
-fetchPackage verbosity repo pkgid = do
- fetched <- doesFileExist (packageFile repo pkgid)
- if fetched
- then do info verbosity $ display pkgid ++ " has already been downloaded."
- return (packageFile repo pkgid)
- else do setupMessage verbosity "Downloading" pkgid
- downloadPackage verbosity repo pkgid
-
--- |Fetch a list of packages and their dependencies.
-fetch :: Verbosity
- -> PackageDBStack
- -> [Repo]
- -> Compiler
- -> ProgramConfiguration
- -> FetchFlags
- -> [UnresolvedDependency]
- -> IO ()
-fetch verbosity _ _ _ _ _ [] =
- notice verbosity "No packages requested. Nothing to do."
-
-fetch verbosity packageDBs repos comp conf flags deps = do
-
- installed <- getInstalledPackages verbosity comp packageDBs conf
- availableDb@(AvailablePackageDb available _)
- <- getAvailablePackages verbosity repos
- deps' <- IndexUtils.disambiguateDependencies available deps
-
- pkgs <- resolvePackages verbosity
- includeDeps comp
- installed availableDb deps'
-
- pkgs' <- filterM (fmap not . isFetched) pkgs
- when (null pkgs') $
- notice verbosity $ "No packages need to be fetched. "
- ++ "All the requested packages are already cached."
- if dryRun
- then notice verbosity $ unlines $
- "The following packages would be fetched:"
- : map (display . packageId) pkgs'
- else sequence_
- [ fetchPackage verbosity repo pkgid
- | (AvailablePackage pkgid _ (RepoTarballPackage repo)) <- pkgs' ]
- where
- includeDeps = fromFlag (fetchDeps flags)
- dryRun = fromFlag (fetchDryRun flags)
-
-
-resolvePackages
- :: Verbosity
- -> Bool
- -> Compiler
- -> PackageIndex InstalledPackage
- -> AvailablePackageDb
- -> [UnresolvedDependency]
- -> IO [AvailablePackage]
-resolvePackages verbosity includeDependencies comp
- installed (AvailablePackageDb available availablePrefs) deps
-
- | includeDependencies = do
-
- notice verbosity "Resolving dependencies..."
- plan <- foldProgress logMsg die return $
- resolveDependenciesWithProgress
- buildPlatform (compilerId comp)
- installed' available
- preferences constraints
- targets
- --TODO: suggest using --no-deps, unpack or fetch -o
- -- if cannot satisfy deps
- --TODO: add commandline constraint and preference args for fetch
-
- return (selectPackagesToFetch plan)
-
- | otherwise = do
-
- either (die . unlines . map show) return $
- resolveAvailablePackages
- installed available
- preferences constraints
- targets
-
- where
- targets = dependencyTargets deps
- constraints = dependencyConstraints deps
- preferences = PackagesPreference
- PreferLatestForSelected
- [ PackageVersionPreference name ver
- | (name, ver) <- Map.toList availablePrefs ]
-
- installed' = hideGivenDeps deps installed
-
- -- Hide the packages given on the command line so that the dep resolver
- -- will decide that they need fetching, even if they're already
- -- installed. Sicne we want to get the source packages of things we might
- -- have installed (but not have the sources for).
-
- -- TODO: to allow for preferences on selecting an available version
- -- corresponding to a package we've got installed, instead of hiding the
- -- installed instances, we should add a constraint on using an installed
- -- instance.
- hideGivenDeps pkgs index =
- foldr PackageIndex.deletePackageName index
- [ name | UnresolvedDependency (Dependency name _) _ <- pkgs ]
-
- -- The packages we want to fetch are those packages the 'InstallPlan' that
- -- are in the 'InstallPlan.Configured' state.
- selectPackagesToFetch :: InstallPlan.InstallPlan -> [AvailablePackage]
- selectPackagesToFetch plan =
- [ pkg | (InstallPlan.Configured (InstallPlan.ConfiguredPackage pkg _ _))
- <- InstallPlan.toList plan ]
-
- logMsg message rest = info verbosity message >> rest
-
-
--- |Generate the full path to the locally cached copy of
--- the tarball for a given @PackageIdentifer@.
-packageFile :: Repo -> PackageIdentifier -> FilePath
-packageFile repo pkgid = packageDir repo pkgid
- </> display pkgid
- <.> "tar.gz"
-
--- |Generate the full path to the directory where the local cached copy of
--- the tarball for a given @PackageIdentifer@ is stored.
-packageDir :: Repo -> PackageIdentifier -> FilePath
-packageDir repo pkgid = repoLocalDir repo
- </> display (packageName pkgid)
- </> display (packageVersion pkgid)
-
--- | Generate the URI of the tarball for a given package.
-packageURI :: RemoteRepo -> PackageIdentifier -> URI
-packageURI repo pkgid | isOldHackageURI (remoteRepoURI repo) =
- (remoteRepoURI repo) {
- uriPath = FilePath.Posix.joinPath
- [uriPath (remoteRepoURI repo)
- ,display (packageName pkgid)
- ,display (packageVersion pkgid)
- ,display pkgid <.> "tar.gz"]
- }
-packageURI repo pkgid =
- (remoteRepoURI repo) {
- uriPath = FilePath.Posix.joinPath
- [uriPath (remoteRepoURI repo)
- ,"package"
- ,display pkgid <.> "tar.gz"]
- }
diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/List.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/List.hs
deleted file mode 100644
index 0633d15..0000000
--- a/cabal-install-0.9.5_rc20101226/Distribution/Client/List.hs
+++ /dev/null
@@ -1,368 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Distribution.Client.List
--- Copyright : (c) David Himmelstrup 2005
--- Duncan Coutts 2008-2009
--- License : BSD-like
---
--- Maintainer : cabal-devel@haskell.org
---
--- Search for and print information about packages
------------------------------------------------------------------------------
-module Distribution.Client.List (
- list, info
- ) where
-
-import Distribution.Package
- ( PackageName(..), packageName, packageVersion
- , Dependency(..), thisPackageVersion, depends )
-import Distribution.ModuleName (ModuleName)
-import Distribution.License (License)
-import qualified Distribution.InstalledPackageInfo as Installed
-import qualified Distribution.PackageDescription as Available
-import Distribution.PackageDescription
- ( Flag(..), FlagName(..) )
-import Distribution.PackageDescription.Configuration
- ( flattenPackageDescription )
-
-import Distribution.Simple.Compiler
- ( Compiler, PackageDBStack )
-import Distribution.Simple.Program (ProgramConfiguration)
-import Distribution.Simple.Utils (equating, comparing, notice)
-import Distribution.Simple.Setup (fromFlag)
-import qualified Distribution.Client.PackageIndex as PackageIndex
-import Distribution.Version (Version)
-import Distribution.Verbosity (Verbosity)
-import Distribution.Text
- ( Text(disp), display )
-
-import Distribution.Client.Types
- ( AvailablePackage(..), Repo, AvailablePackageDb(..)
- , UnresolvedDependency(..), InstalledPackage(..) )
-import Distribution.Client.Setup
- ( ListFlags(..), InfoFlags(..) )
-import Distribution.Client.Utils
- ( mergeBy, MergeResult(..) )
-import Distribution.Client.IndexUtils as IndexUtils
- ( getAvailablePackages, disambiguateDependencies
- , getInstalledPackages )
-import Distribution.Client.Fetch
- ( isFetched )
-
-import Data.List
- ( sortBy, groupBy, sort, nub, intersperse, maximumBy )
-import Data.Maybe
- ( listToMaybe, fromJust, fromMaybe, isJust, isNothing )
-import Control.Monad
- ( MonadPlus(mplus), join )
-import Control.Exception
- ( assert )
-import Text.PrettyPrint.HughesPJ as Disp
-import System.Directory
- ( doesDirectoryExist )
-
-
--- |Show information about packages
-list :: Verbosity
- -> PackageDBStack
- -> [Repo]
- -> Compiler
- -> ProgramConfiguration
- -> ListFlags
- -> [String]
- -> IO ()
-list verbosity packageDBs repos comp conf listFlags pats = do
- installed <- getInstalledPackages verbosity comp packageDBs 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 (pkgname 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 showPackageSummaryInfo matches)
- where
- installedFilter
- | onlyInstalled = filter (not . null . installedVersions)
- | otherwise = id
- onlyInstalled = fromFlag (listInstalled listFlags)
- simpleOutput = fromFlag (listSimpleOutput listFlags)
-
-info :: Verbosity
- -> PackageDBStack
- -> [Repo]
- -> Compiler
- -> ProgramConfiguration
- -> InfoFlags
- -> [UnresolvedDependency] --FIXME: just package names? or actually use the constraint
- -> IO ()
-info verbosity packageDBs repos comp conf _listFlags deps = do
- AvailablePackageDb available _ <- getAvailablePackages verbosity repos
- deps' <- IndexUtils.disambiguateDependencies available deps
- installed <- getInstalledPackages verbosity comp packageDBs conf
- let deps'' = [ name | UnresolvedDependency (Dependency name _) _ <- deps' ]
- let pkgs = (concatMap (PackageIndex.lookupPackageName installed) deps''
- ,concatMap (PackageIndex.lookupPackageName available) deps'')
- pkgsinfo = map (uncurry mergePackageInfo)
- $ uncurry mergePackages pkgs
-
- pkgsinfo' <- mapM updateFileSystemPackageDetails pkgsinfo
- putStr $ unlines (map showPackageDetailedInfo pkgsinfo')
-
--- | 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 {
- pkgname :: PackageName,
- allInstalled :: [InstalledPackage],
- allAvailable :: [AvailablePackage],
- latestInstalled :: Maybe InstalledPackage,
- latestAvailable :: Maybe AvailablePackage,
- homepage :: String,
- bugReports :: String,
- sourceRepo :: String,
- synopsis :: String,
- description :: String,
- category :: String,
- license :: License,
--- copyright :: String, --TODO: is this useful?
- author :: String,
- maintainer :: String,
- dependencies :: [Dependency],
- flags :: [Flag],
- hasLib :: Bool,
- hasExe :: Bool,
- executables :: [String],
- modules :: [ModuleName],
- haddockHtml :: FilePath,
- haveTarball :: Bool
- }
-
-installedVersions :: PackageDisplayInfo -> [Version]
-installedVersions = map packageVersion . allInstalled
-
-availableVersions :: PackageDisplayInfo -> [Version]
-availableVersions = map packageVersion . allAvailable
-
-showPackageSummaryInfo :: PackageDisplayInfo -> String
-showPackageSummaryInfo pkginfo =
- renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $
- char '*' <+> disp (pkgname pkginfo)
- $+$
- (nest 4 $ vcat [
- maybeShow (synopsis pkginfo) "Synopsis:" reflowParagraphs
- , text "Latest version available:" <+>
- case latestAvailable pkginfo of
- Nothing -> text "[ Not available from server ]"
- Just pkg -> disp (packageVersion pkg)
- , text "Latest version installed:" <+>
- case latestInstalled pkginfo of
- Nothing | hasLib pkginfo -> text "[ Not installed ]"
- | otherwise -> text "[ Unknown ]"
- Just pkg -> disp (packageVersion pkg)
- , maybeShow (homepage pkginfo) "Homepage:" text
- , text "License: " <+> text (display (license pkginfo))
- ])
- $+$ text ""
- where
- maybeShow [] _ _ = empty
- maybeShow l s f = text s <+> (f l)
-
-showPackageDetailedInfo :: PackageDisplayInfo -> String
-showPackageDetailedInfo pkginfo =
- renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $
- char '*' <+> disp (pkgname pkginfo)
- <+> text (replicate (16 - length (display (pkgname pkginfo))) ' ')
- <> parens pkgkind
- $+$
- (nest 4 $ vcat [
- entry "Synopsis" synopsis alwaysShow reflowParagraphs
- , entry "Latest version available" latestAvailable
- (altText isNothing "[ Not available from server ]")
- (disp . packageVersion . fromJust)
- , entry "Latest version installed" latestInstalled
- (altText isNothing (if hasLib pkginfo then "[ Not installed ]"
- else "[ Unknown ]"))
- (disp . packageVersion . fromJust)
- , entry "Homepage" homepage orNotSpecified text
- , entry "Bug reports" bugReports orNotSpecified text
- , entry "Description" description alwaysShow reflowParagraphs
- , entry "Category" category hideIfNull text
- , entry "License" license alwaysShow disp
- , entry "Author" author hideIfNull reflowLines
- , entry "Maintainer" maintainer hideIfNull reflowLines
- , entry "Source repo" sourceRepo orNotSpecified text
- , entry "Executables" executables hideIfNull (commaSep text)
- , entry "Flags" flags hideIfNull (commaSep dispFlag)
- , entry "Dependencies" dependencies hideIfNull (commaSep disp)
- , entry "Documentation" haddockHtml showIfInstalled text
- , entry "Cached" haveTarball alwaysShow dispYesNo
- , if not (hasLib pkginfo) then empty else
- text "Modules:" $+$ nest 4 (vcat (map disp . sort . modules $ pkginfo))
- ])
- $+$ text ""
- where
- entry fname field cond format = case cond (field pkginfo) of
- Nothing -> label <+> format (field pkginfo)
- Just Nothing -> empty
- Just (Just other) -> label <+> text other
- where
- label = text fname <> char ':' <> padding
- padding = text (replicate (13 - length fname ) ' ')
-
- normal = Nothing
- hide = Just Nothing
- replace msg = Just (Just msg)
-
- alwaysShow = const normal
- hideIfNull v = if null v then hide else normal
- showIfInstalled v
- | not isInstalled = hide
- | null v = replace "[ Not installed ]"
- | otherwise = normal
- altText nul msg v = if nul v then replace msg else normal
- orNotSpecified = altText null "[ Not specified ]"
-
- commaSep f = Disp.fsep . Disp.punctuate (Disp.char ',') . map f
- dispFlag f = case flagName f of FlagName n -> text n
- dispYesNo True = text "Yes"
- dispYesNo False = text "No"
-
- isInstalled = not (null (installedVersions pkginfo))
- hasExes = length (executables pkginfo) >= 2
- --TODO: exclude non-buildable exes
- pkgkind | hasLib pkginfo && hasExes = text "programs and library"
- | hasLib pkginfo && hasExe pkginfo = text "program and library"
- | hasLib pkginfo = text "library"
- | hasExes = text "programs"
- | hasExe pkginfo = text "program"
- | otherwise = empty
-
-reflowParagraphs :: String -> Doc
-reflowParagraphs =
- vcat
- . intersperse (text "") -- re-insert blank lines
- . map (fsep . map text . concatMap words) -- reflow paragraphs
- . filter (/= [""])
- . groupBy (\x y -> "" `notElem` [x,y]) -- break on blank lines
- . lines
-
-reflowLines :: String -> Doc
-reflowLines = vcat . map text . 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 :: [InstalledPackage]
- -> [AvailablePackage]
- -> PackageDisplayInfo
-mergePackageInfo installedPkgs availablePkgs =
- assert (length installedPkgs + length availablePkgs > 0) $
- PackageDisplayInfo {
- pkgname = combine packageName available
- packageName installed,
- allInstalled = installedPkgs,
- allAvailable = availablePkgs,
- latestInstalled = latest installedPkgs,
- latestAvailable = latest availablePkgs,
- license = combine Available.license available
- Installed.license installed,
- maintainer = combine Available.maintainer available
- Installed.maintainer installed,
- author = combine Available.author available
- Installed.author installed,
- homepage = combine Available.homepage available
- Installed.homepage installed,
- bugReports = maybe "" Available.bugReports available,
- sourceRepo = fromMaybe "" . join
- . fmap (uncons Nothing Available.repoLocation
- . sortBy (comparing Available.repoKind)
- . Available.sourceRepos)
- $ available,
- synopsis = combine Available.synopsis available
- Installed.description installed,
- description = combine Available.description available
- Installed.description installed,
- category = combine Available.category available
- Installed.category installed,
- flags = maybe [] Available.genPackageFlags availableGeneric,
- hasLib = isJust installed
- || fromMaybe False
- (fmap (isJust . Available.condLibrary) availableGeneric),
- hasExe = fromMaybe False
- (fmap (not . null . Available.condExecutables) availableGeneric),
- executables = map fst (maybe [] Available.condExecutables availableGeneric),
- modules = combine Installed.exposedModules installed
- (maybe [] Available.exposedModules
- . Available.library) available,
- dependencies = combine Available.buildDepends available
- (map thisPackageVersion . depends) installed',
- haddockHtml = fromMaybe "" . join
- . fmap (listToMaybe . Installed.haddockHTMLs)
- $ installed,
- haveTarball = False
- }
- where
- combine f x g y = fromJust (fmap f x `mplus` fmap g y)
- installed' = latest installedPkgs
- installed = fmap (\(InstalledPackage p _) -> p) installed'
- availableGeneric = fmap packageDescription (latest availablePkgs)
- available = fmap flattenPackageDescription availableGeneric
- latest [] = Nothing
- latest pkgs = Just (maximumBy (comparing packageVersion) pkgs)
-
- uncons :: b -> (a -> b) -> [a] -> b
- uncons z _ [] = z
- uncons _ f (x:_) = f x
-
--- | Not all the info is pure. We have to check if the docs really are
--- installed, because the registered package info lies. Similarly we have to
--- check if the tarball has indeed been fetched.
---
-updateFileSystemPackageDetails :: PackageDisplayInfo -> IO PackageDisplayInfo
-updateFileSystemPackageDetails pkginfo = do
- fetched <- maybe (return False) isFetched (latestAvailable pkginfo)
- docsExist <- doesDirectoryExist (haddockHtml pkginfo)
- return pkginfo {
- haveTarball = fetched,
- haddockHtml = if docsExist then haddockHtml pkginfo else ""
- }
-
--- | 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 :: [InstalledPackage] -> [AvailablePackage]
- -> [([InstalledPackage], [AvailablePackage])]
-mergePackages installed available =
- map collect
- $ mergeBy (\i a -> fst i `compare` fst a)
- (groupOn packageName installed)
- (groupOn packageName 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)
diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Unpack.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Unpack.hs
deleted file mode 100644
index ce7780b..0000000
--- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Unpack.hs
+++ /dev/null
@@ -1,138 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Distribution.Client.Unpack
--- Copyright : (c) Andrea Vezzosi 2008
--- License : BSD-like
---
--- Maintainer : cabal-devel@haskell.org
--- Stability : provisional
--- Portability : portable
---
---
------------------------------------------------------------------------------
-module Distribution.Client.Unpack (
-
- -- * Commands
- unpack,
-
- ) where
-
-import Distribution.Package
- ( PackageId, Dependency(..) )
-import Distribution.Simple.Setup(fromFlag, fromFlagOrDefault)
-import Distribution.Simple.Utils
- ( notice, die )
-import Distribution.Verbosity
- ( Verbosity )
-import Distribution.Text(display)
-
-import Distribution.Client.Setup(UnpackFlags(unpackVerbosity,
- unpackDestDir))
-import Distribution.Client.Types(UnresolvedDependency(..),
- Repo, AvailablePackageSource(..),
- AvailablePackage(AvailablePackage),
- AvailablePackageDb(AvailablePackageDb))
-import Distribution.Client.Dependency as Dependency
- ( resolveAvailablePackages
- , dependencyConstraints, dependencyTargets
- , PackagesPreference(..), PackagesPreferenceDefault(..)
- , PackagePreference(..) )
-import Distribution.Client.Fetch
- ( fetchPackage )
-import Distribution.Client.HttpUtils
- ( downloadURI )
-import qualified Distribution.Client.Tar as Tar (extractTarGzFile)
-import Distribution.Client.IndexUtils as IndexUtils
- (getAvailablePackages, disambiguateDependencies)
-
-import System.Directory
- ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist
- , getTemporaryDirectory )
-import System.IO
- ( openTempFile, hClose )
-import Control.Monad
- ( unless, when )
-import Data.Monoid
- ( mempty )
-import System.FilePath
- ( (</>), addTrailingPathSeparator )
-import qualified Data.Map as Map
-
-unpack :: UnpackFlags -> [Repo] -> [Dependency] -> IO ()
-unpack flags _ [] =
- notice verbosity "No packages requested. Nothing to do."
- where
- verbosity = fromFlag (unpackVerbosity flags)
-
-unpack flags repos deps = do
- db@(AvailablePackageDb available _)
- <- getAvailablePackages verbosity repos
- deps' <- IndexUtils.disambiguateDependencies available
- . map toUnresolved $ deps
-
- pkgs <- resolvePackages db deps'
-
- unless (null prefix) $
- createDirectoryIfMissing True prefix
-
- flip mapM_ pkgs $ \pkg -> case pkg of
-
- AvailablePackage pkgid _ (LocalTarballPackage tarballPath) ->
- unpackPackage verbosity prefix pkgid tarballPath
-
- AvailablePackage pkgid _ (RemoteTarballPackage tarballURL) -> do
- tmp <- getTemporaryDirectory
- (tarballPath, hnd) <- openTempFile tmp (display pkgid)
- hClose hnd
- --TODO: perhaps we've already had to download this to a local cache
- -- so we even know what package version it is. So might be able
- -- to get it from the local cache rather than from remote.
- downloadURI verbosity tarballURL tarballPath
- unpackPackage verbosity prefix pkgid tarballPath
-
- AvailablePackage pkgid _ (RepoTarballPackage repo) -> do
- tarballPath <- fetchPackage verbosity repo pkgid
- unpackPackage verbosity prefix pkgid tarballPath
-
- AvailablePackage _ _ (LocalUnpackedPackage _) ->
- error "Distribution.Client.Unpack.unpack: the impossible happened."
-
- where
- verbosity = fromFlag (unpackVerbosity flags)
- prefix = fromFlagOrDefault "" (unpackDestDir flags)
- toUnresolved d = UnresolvedDependency d []
-
-unpackPackage :: Verbosity -> FilePath -> PackageId -> FilePath -> IO ()
-unpackPackage verbosity prefix pkgid pkgPath = do
- let pkgdirname = display pkgid
- pkgdir = prefix </> pkgdirname
- pkgdir' = addTrailingPathSeparator pkgdir
- existsDir <- doesDirectoryExist pkgdir
- when existsDir $ die $
- "The directory \"" ++ pkgdir' ++ "\" already exists, not unpacking."
- existsFile <- doesFileExist pkgdir
- when existsFile $ die $
- "A file \"" ++ pkgdir ++ "\" is in the way, not unpacking."
- notice verbosity $ "Unpacking to " ++ pkgdir'
- Tar.extractTarGzFile prefix pkgdirname pkgPath
-
-resolvePackages :: AvailablePackageDb
- -> [UnresolvedDependency]
- -> IO [AvailablePackage]
-resolvePackages
- (AvailablePackageDb available availablePrefs) deps =
-
- either (die . unlines . map show) return $
- resolveAvailablePackages
- installed available
- preferences constraints
- targets
-
- where
- installed = mempty
- targets = dependencyTargets deps
- constraints = dependencyConstraints deps
- preferences = PackagesPreference
- PreferLatestForSelected
- [ PackageVersionPreference name ver
- | (name, ver) <- Map.toList availablePrefs ]
diff --git a/cabal/.darcs-boring b/cabal/.darcs-boring
new file mode 100644
index 0000000..4eddbbc
--- /dev/null
+++ b/cabal/.darcs-boring
@@ -0,0 +1,6 @@
+^dist(/|$)
+^setup(/|$)
+^GNUmakefile$
+^Makefile.local$
+^.depend(.bak)?$
+^doc/.depend(.bak)?$
diff --git a/cabal/HACKING b/cabal/HACKING
new file mode 100644
index 0000000..5650033
--- /dev/null
+++ b/cabal/HACKING
@@ -0,0 +1,10 @@
+If you want to hack on Cabal, don't be intimidated!
+
+Read the guide to the source code:
+ http://hackage.haskell.org/trac/hackage/wiki/SourceGuide
+
+There are other resources listed on the dev wiki:
+ http://hackage.haskell.org/trac/hackage/
+
+In particular, the open tickets and the cabal-devel mailing list
+which is a good place to ask questions.
diff --git a/cabal/IMPORTED-FROM b/cabal/IMPORTED-FROM
new file mode 100644
index 0000000..ecef606
--- /dev/null
+++ b/cabal/IMPORTED-FROM
@@ -0,0 +1,7 @@
+http://darcs.haskell.org/cabal-branches/cabal-1.12
+
+Fri Jul 15 15:04:46 EEST 2011 Ian Lynagh <igloo@earth.li>
+ * Bump version number
+ hunk ./cabal/Cabal.cabal 2
+ -Version: 1.11.2
+ +Version: 1.12.0
diff --git a/cabal/LICENSE b/cabal/LICENSE
new file mode 100644
index 0000000..489b8a1
--- /dev/null
+++ b/cabal/LICENSE
@@ -0,0 +1,33 @@
+Copyright (c) 2011, Duncan Coutts and Ian Lynagh.
+
+See */LICENSE for the copyright holders of the subcomponents.
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Isaac Jones nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/cabal/README b/cabal/README
new file mode 100644
index 0000000..bab14a4
--- /dev/null
+++ b/cabal/README
@@ -0,0 +1,8 @@
+This Cabal darcs repository contains multiple packages:
+
+ * cabal/ -- the Cabal library package
+ * cabal-install/ -- the cabal-install package containing the 'cabal' tool.
+
+See the README in each subdir for more details.
+
+The canonical upstream repo lives at http://darcs.haskell.org/cabal/
diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Anonymous.hs b/cabal/cabal-install/Distribution/Client/BuildReports/Anonymous.hs
index 53d1f45..53d1f45 100644
--- a/cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Anonymous.hs
+++ b/cabal/cabal-install/Distribution/Client/BuildReports/Anonymous.hs
diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Storage.hs b/cabal/cabal-install/Distribution/Client/BuildReports/Storage.hs
index a8e9150..7b2a4b5 100644
--- a/cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Storage.hs
+++ b/cabal/cabal-install/Distribution/Client/BuildReports/Storage.hs
@@ -26,8 +26,6 @@ import qualified Distribution.Client.BuildReports.Anonymous as BuildReport
import Distribution.Client.BuildReports.Anonymous (BuildReport)
import Distribution.Client.Types
- ( ConfiguredPackage(..), AvailablePackage(..)
- , AvailablePackageSource(..), Repo(..), RemoteRepo(..) )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.InstallPlan
( InstallPlan )
@@ -118,12 +116,12 @@ fromPlanPackage :: Platform -> CompilerId
-> Maybe (BuildReport, Repo)
fromPlanPackage (Platform arch os) comp planPackage = case planPackage of
- InstallPlan.Installed pkg@(ConfiguredPackage (AvailablePackage {
- packageSource = RepoTarballPackage repo }) _ _) result
+ InstallPlan.Installed pkg@(ConfiguredPackage (SourcePackage {
+ packageSource = RepoTarballPackage repo _ _ }) _ _) result
-> Just $ (BuildReport.new os arch comp pkg (Right result), repo)
- InstallPlan.Failed pkg@(ConfiguredPackage (AvailablePackage {
- packageSource = RepoTarballPackage repo }) _ _) result
+ InstallPlan.Failed pkg@(ConfiguredPackage (SourcePackage {
+ packageSource = RepoTarballPackage repo _ _ }) _ _) result
-> Just $ (BuildReport.new os arch comp pkg (Left result), repo)
_ -> Nothing
diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Types.hs b/cabal/cabal-install/Distribution/Client/BuildReports/Types.hs
index ea28e71..ea28e71 100644
--- a/cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Types.hs
+++ b/cabal/cabal-install/Distribution/Client/BuildReports/Types.hs
diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Upload.hs b/cabal/cabal-install/Distribution/Client/BuildReports/Upload.hs
index dc35552..a1ae1f1 100644
--- a/cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Upload.hs
+++ b/cabal/cabal-install/Distribution/Client/BuildReports/Upload.hs
@@ -23,25 +23,28 @@ import System.FilePath.Posix
( (</>) )
import qualified Distribution.Client.BuildReports.Anonymous as BuildReport
import Distribution.Client.BuildReports.Anonymous (BuildReport)
+import Distribution.Text (display)
type BuildReportId = URI
type BuildLog = String
uploadReports :: URI -> [(BuildReport, Maybe BuildLog)]
+ -> BrowserAction (HandleStream String) ()
-> BrowserAction (HandleStream BuildLog) ()
-uploadReports uri reports
- = forM_ reports $ \(report, mbBuildLog) ->
- do buildId <- postBuildReport uri report
- case mbBuildLog of
- Just buildLog -> putBuildLog buildId buildLog
- Nothing -> return ()
+uploadReports uri reports auth = do
+ auth
+ forM_ reports $ \(report, mbBuildLog) -> do
+ buildId <- postBuildReport uri report
+ case mbBuildLog of
+ Just buildLog -> putBuildLog buildId buildLog
+ Nothing -> return ()
postBuildReport :: URI -> BuildReport
-> BrowserAction (HandleStream BuildLog) BuildReportId
postBuildReport uri buildReport = do
setAllowRedirects False
(_, response) <- request Request {
- rqURI = uri { uriPath = "/buildreports" },
+ rqURI = uri { uriPath = "/package" </> display (BuildReport.package buildReport) </> "reports" },
rqMethod = POST,
rqHeaders = [Header HdrContentType ("text/plain"),
Header HdrContentLength (show (length body)),
@@ -61,7 +64,7 @@ putBuildLog :: BuildReportId -> BuildLog
putBuildLog reportId buildLog = do
--FIXME: do something if the request fails
(_, response) <- request Request {
- rqURI = reportId{uriPath = uriPath reportId </> "buildlog"},
+ rqURI = reportId{uriPath = uriPath reportId </> "log"},
rqMethod = PUT,
rqHeaders = [Header HdrContentType ("text/plain"),
Header HdrContentLength (show (length buildLog)),
diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Check.hs b/cabal/cabal-install/Distribution/Client/Check.hs
index 8d5fe23..8d5fe23 100644
--- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Check.hs
+++ b/cabal/cabal-install/Distribution/Client/Check.hs
diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Config.hs b/cabal/cabal-install/Distribution/Client/Config.hs
index 2e20591..c283222 100644
--- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Config.hs
+++ b/cabal/cabal-install/Distribution/Client/Config.hs
@@ -34,6 +34,7 @@ import Distribution.Client.Setup
, ConfigExFlags(..), configureExOptions, defaultConfigExFlags
, InstallFlags(..), installOptions, defaultInstallFlags
, UploadFlags(..), uploadCommand
+ , ReportFlags(..), reportCommand
, showRepo, parseRepo )
import Distribution.Simple.Setup
@@ -101,7 +102,8 @@ data SavedConfig = SavedConfig {
savedConfigureExFlags :: ConfigExFlags,
savedUserInstallDirs :: InstallDirs (Flag PathTemplate),
savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate),
- savedUploadFlags :: UploadFlags
+ savedUploadFlags :: UploadFlags,
+ savedReportFlags :: ReportFlags
}
instance Monoid SavedConfig where
@@ -112,7 +114,8 @@ instance Monoid SavedConfig where
savedConfigureExFlags = mempty,
savedUserInstallDirs = mempty,
savedGlobalInstallDirs = mempty,
- savedUploadFlags = mempty
+ savedUploadFlags = mempty,
+ savedReportFlags = mempty
}
mappend a b = SavedConfig {
savedGlobalFlags = combine savedGlobalFlags,
@@ -121,7 +124,8 @@ instance Monoid SavedConfig where
savedConfigureExFlags = combine savedConfigureExFlags,
savedUserInstallDirs = combine savedUserInstallDirs,
savedGlobalInstallDirs = combine savedGlobalInstallDirs,
- savedUploadFlags = combine savedUploadFlags
+ savedUploadFlags = combine savedUploadFlags,
+ savedReportFlags = combine savedReportFlags
}
where combine field = field a `mappend` field b
@@ -324,7 +328,8 @@ commentSavedConfig = do
},
savedUserInstallDirs = fmap toFlag userInstallDirs,
savedGlobalInstallDirs = fmap toFlag globalInstallDirs,
- savedUploadFlags = commandDefaultFlags uploadCommand
+ savedUploadFlags = commandDefaultFlags uploadCommand,
+ savedReportFlags = commandDefaultFlags reportCommand
}
-- | All config file fields.
@@ -360,6 +365,14 @@ configFieldDescriptions =
(commandOptions uploadCommand ParseArgs)
["verbose", "check"] []
+ ++ toSavedConfig liftReportFlag
+ (commandOptions reportCommand ParseArgs)
+ ["verbose", "username", "password"] []
+ --FIXME: this is a hack, hiding the username and password.
+ -- But otherwise it masks the upload ones. Either need to
+ -- share the options or make then distinct. In any case
+ -- they should probably be per-server.
+
where
toSavedConfig lift options exclusions replacements =
[ lift (fromMaybe field replacement)
@@ -430,6 +443,10 @@ liftUploadFlag :: FieldDescr UploadFlags -> FieldDescr SavedConfig
liftUploadFlag = liftField
savedUploadFlags (\flags conf -> conf { savedUploadFlags = flags })
+liftReportFlag :: FieldDescr ReportFlags -> FieldDescr SavedConfig
+liftReportFlag = liftField
+ savedReportFlags (\flags conf -> conf { savedReportFlags = flags })
+
parseConfig :: SavedConfig -> String -> ParseResult SavedConfig
parseConfig initial = \str -> do
fields <- readFields str
diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Configure.hs b/cabal/cabal-install/Distribution/Client/Configure.hs
index 8e3d177..8da7506 100644
--- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Configure.hs
+++ b/cabal/cabal-install/Distribution/Client/Configure.hs
@@ -14,27 +14,18 @@ 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, getInstalledPackages )
+ ( getSourcePackages, getInstalledPackages )
import Distribution.Client.Setup
( ConfigExFlags(..), configureCommand, filterConfigureFlags )
-import Distribution.Client.Types as Available
- ( AvailablePackage(..), AvailablePackageSource(..), Repo(..)
- , AvailablePackageDb(..), ConfiguredPackage(..), InstalledPackage )
+import Distribution.Client.Types as Source
import Distribution.Client.SetupWrapper
( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )
+import Distribution.Client.Targets
+ ( userToPackageConstraint )
import Distribution.Simple.Compiler
( CompilerId(..), Compiler(compilerId)
@@ -42,26 +33,26 @@ import Distribution.Simple.Compiler
import Distribution.Simple.Program (ProgramConfiguration )
import Distribution.Simple.Setup
( ConfigFlags(..), toFlag, flagToMaybe, fromFlagOrDefault )
-import qualified Distribution.Client.PackageIndex as PackageIndex
import Distribution.Client.PackageIndex (PackageIndex)
import Distribution.Simple.Utils
( defaultPackageDesc )
import Distribution.Package
- ( PackageName, packageName, packageVersion
- , Package(..), Dependency(..), thisPackageVersion )
+ ( Package(..), packageName, Dependency(..), thisPackageVersion )
import Distribution.PackageDescription.Parse
( readPackageDescription )
import Distribution.PackageDescription.Configuration
( finalizePackageDescription )
import Distribution.Version
- ( VersionRange, anyVersion, thisVersion )
+ ( anyVersion, thisVersion )
import Distribution.Simple.Utils as Utils
- ( notice, info, die )
+ ( notice, info, debug, die )
import Distribution.System
( Platform, buildPlatform )
import Distribution.Verbosity as Verbosity
( Verbosity )
+import Data.Monoid (Monoid(..))
+
-- | Configure the package found in the local directory
configure :: Verbosity
-> PackageDBStack
@@ -75,27 +66,27 @@ configure :: Verbosity
configure verbosity packageDBs repos comp conf
configFlags configExFlags extraArgs = do
- installed <- getInstalledPackages verbosity comp packageDBs conf
- available <- getAvailablePackages verbosity repos
+ installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
+ sourcePkgDb <- getSourcePackages verbosity repos
progress <- planLocalPackage verbosity comp configFlags configExFlags
- installed available
+ installedPkgIndex sourcePkgDb
notice verbosity "Resolving dependencies..."
- maybePlan <- foldProgress (\message rest -> info verbosity message >> rest)
- (return . Left) (return . Right) progress
+ maybePlan <- foldProgress logMsg (return . Left) (return . Right)
+ progress
case maybePlan of
Left message -> do
info verbosity message
- setupWrapper verbosity (setupScriptOptions installed) Nothing
+ setupWrapper verbosity (setupScriptOptions installedPkgIndex) Nothing
configureCommand (const configFlags) extraArgs
Right installPlan -> case InstallPlan.ready installPlan of
- [pkg@(ConfiguredPackage (AvailablePackage _ _ (LocalUnpackedPackage _)) _ _)] ->
+ [pkg@(ConfiguredPackage (SourcePackage _ _ (LocalUnpackedPackage _)) _ _)] ->
configurePackage verbosity
(InstallPlan.planPlatform installPlan)
(InstallPlan.planCompiler installPlan)
- (setupScriptOptions installed)
+ (setupScriptOptions installedPkgIndex)
configFlags pkg extraArgs
_ -> die $ "internal error: configure install plan should have exactly "
@@ -123,56 +114,54 @@ configure verbosity packageDBs repos comp conf
useWorkingDir = Nothing
}
+ logMsg message rest = debug verbosity message >> rest
+
-- | Make an 'InstallPlan' for the unpacked package in the current directory,
-- and all its dependencies.
--
planLocalPackage :: Verbosity -> Compiler
-> ConfigFlags -> ConfigExFlags
-> PackageIndex InstalledPackage
- -> AvailablePackageDb
+ -> SourcePackageDb
-> IO (Progress String String InstallPlan)
-planLocalPackage verbosity comp configFlags configExFlags installed
- (AvailablePackageDb _ availablePrefs) = do
+planLocalPackage verbosity comp configFlags configExFlags installedPkgIndex
+ (SourcePackageDb _ packagePrefs) = 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) installed
- localPkg = AvailablePackage {
- packageInfoId = packageId pkg,
- Available.packageDescription = pkg,
- packageSource = LocalUnpackedPackage Nothing
+
+ let -- We create a local package and ask to resolve a dependency on it
+ localPkg = SourcePackage {
+ packageInfoId = packageId pkg,
+ Source.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
+
+ resolverParams =
+
+ addPreferences
+ -- preferences from the config file or command line
+ [ PackageVersionPreference name ver
+ | Dependency name ver <- configPreferences configExFlags ]
+
+ . addConstraints
+ -- version constraints from the config file or command line
+ -- TODO: should warn or error on constraints that are not on direct deps
+ -- or flag constraints not on the package in question.
+ (map userToPackageConstraint (configExConstraints configExFlags))
+
+ . addConstraints
+ -- package flags from the config file or command line
+ [ PackageConstraintFlags (packageName pkg)
+ (configConfigurationsFlags configFlags) ]
+
+ $ standardInstallPolicy
+ installedPkgIndex
+ (SourcePackageDb mempty packagePrefs)
+ [SpecificSourcePackage localPkg]
+
+ return (resolveDependencies buildPlatform (compilerId comp) resolverParams)
+
+
+-- | Call an installer for an 'SourcePackage' 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
@@ -186,7 +175,7 @@ configurePackage :: Verbosity
-> [String]
-> IO ()
configurePackage verbosity platform comp scriptOptions configFlags
- (ConfiguredPackage (AvailablePackage _ gpkg _) flags deps) extraArgs =
+ (ConfiguredPackage (SourcePackage _ gpkg _) flags deps) extraArgs =
setupWrapper verbosity
scriptOptions (Just pkg) configureCommand configureFlags extraArgs
diff --git a/cabal/cabal-install/Distribution/Client/Dependency.hs b/cabal/cabal-install/Distribution/Client/Dependency.hs
new file mode 100644
index 0000000..6946066
--- /dev/null
+++ b/cabal/cabal-install/Distribution/Client/Dependency.hs
@@ -0,0 +1,449 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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 (
+ -- * The main package dependency resolver
+ resolveDependencies,
+ Progress(..),
+ foldProgress,
+
+ -- * Alternate, simple resolver that does not do dependencies recursively
+ resolveWithoutDependencies,
+
+ -- * Constructing resolver policies
+ DepResolverParams(..),
+ PackageConstraint(..),
+ PackagesPreferenceDefault(..),
+ PackagePreference(..),
+ InstalledPreference(..),
+
+ -- ** Standard policy
+ standardInstallPolicy,
+ PackageSpecifier(..),
+
+ -- ** Extra policy options
+ dontUpgradeBasePackage,
+ hideBrokenInstalledPackages,
+ upgradeDependencies,
+ reinstallTargets,
+
+ -- ** Policy utils
+ addConstraints,
+ addPreferences,
+ setPreferenceDefault,
+ addSourcePackages,
+ hideInstalledPackagesSpecific,
+ hideInstalledPackagesAllVersions,
+ ) 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
+ ( SourcePackageDb(SourcePackageDb)
+ , SourcePackage(..), InstalledPackage )
+import Distribution.Client.Dependency.Types
+ ( DependencyResolver, PackageConstraint(..)
+ , PackagePreferences(..), InstalledPreference(..)
+ , Progress(..), foldProgress )
+import Distribution.Client.Targets
+import Distribution.Package
+ ( PackageName(..), PackageId, Package(..), packageVersion
+ , Dependency(Dependency))
+import Distribution.Version
+ ( VersionRange, anyVersion, withinRange, simplifyVersionRange )
+import Distribution.Compiler
+ ( CompilerId(..) )
+import Distribution.System
+ ( Platform )
+import Distribution.Simple.Utils (comparing)
+import Distribution.Text
+ ( display )
+
+import Data.List (maximumBy, foldl')
+import Data.Maybe (fromMaybe, isJust)
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import Data.Set (Set)
+
+
+-- ------------------------------------------------------------
+-- * High level planner policy
+-- ------------------------------------------------------------
+
+-- | The set of parameters to the dependency resolver. These parameters are
+-- relatively low level but many kinds of high level policies can be
+-- implemented in terms of adjustments to the parameters.
+--
+data DepResolverParams = DepResolverParams {
+ depResolverTargets :: [PackageName],
+ depResolverConstraints :: [PackageConstraint],
+ depResolverPreferences :: [PackagePreference],
+ depResolverPreferenceDefault :: PackagesPreferenceDefault,
+ depResolverInstalledPkgIndex :: PackageIndex InstalledPackage,
+ depResolverSourcePkgIndex :: PackageIndex SourcePackage
+ }
+
+
+-- | 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 source 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
+
+
+-- | A package selection preference for a particular package.
+--
+-- Preferences are soft constraints that the dependency resolver should try to
+-- respect where possible. It is not specified if preferences on some packages
+-- are more important than others.
+--
+data PackagePreference =
+
+ -- | A suggested constraint on the version number.
+ PackageVersionPreference PackageName VersionRange
+
+ -- | If we prefer versions of packages that are already installed.
+ | PackageInstalledPreference PackageName InstalledPreference
+
+basicDepResolverParams :: PackageIndex InstalledPackage
+ -> PackageIndex SourcePackage
+ -> DepResolverParams
+basicDepResolverParams installedPkgIndex sourcePkgIndex =
+ DepResolverParams {
+ depResolverTargets = [],
+ depResolverConstraints = [],
+ depResolverPreferences = [],
+ depResolverPreferenceDefault = PreferLatestForSelected,
+ depResolverInstalledPkgIndex = installedPkgIndex,
+ depResolverSourcePkgIndex = sourcePkgIndex
+ }
+
+addTargets :: [PackageName]
+ -> DepResolverParams -> DepResolverParams
+addTargets extraTargets params =
+ params {
+ depResolverTargets = extraTargets ++ depResolverTargets params
+ }
+
+addConstraints :: [PackageConstraint]
+ -> DepResolverParams -> DepResolverParams
+addConstraints extraConstraints params =
+ params {
+ depResolverConstraints = extraConstraints
+ ++ depResolverConstraints params
+ }
+
+addPreferences :: [PackagePreference]
+ -> DepResolverParams -> DepResolverParams
+addPreferences extraPreferences params =
+ params {
+ depResolverPreferences = extraPreferences
+ ++ depResolverPreferences params
+ }
+
+setPreferenceDefault :: PackagesPreferenceDefault
+ -> DepResolverParams -> DepResolverParams
+setPreferenceDefault preferenceDefault params =
+ params {
+ depResolverPreferenceDefault = preferenceDefault
+ }
+
+dontUpgradeBasePackage :: DepResolverParams -> DepResolverParams
+dontUpgradeBasePackage params =
+ addConstraints extraConstraints params
+ where
+ extraConstraints =
+ [ PackageConstraintInstalled pkgname
+ | all (/=PackageName "base") (depResolverTargets params)
+ , pkgname <- [ PackageName "base", PackageName "ghc-prim" ]
+ , isInstalled pkgname ]
+ -- 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.
+ isInstalled = not . null
+ . PackageIndex.lookupPackageName
+ (depResolverInstalledPkgIndex params)
+
+addSourcePackages :: [SourcePackage]
+ -> DepResolverParams -> DepResolverParams
+addSourcePackages pkgs params =
+ params {
+ depResolverSourcePkgIndex =
+ foldl (flip PackageIndex.insert)
+ (depResolverSourcePkgIndex params) pkgs
+ }
+
+hideInstalledPackagesSpecific :: [PackageId]
+ -> DepResolverParams -> DepResolverParams
+hideInstalledPackagesSpecific pkgids params =
+ --TODO: this should work using exclude constraints instead
+ params {
+ depResolverInstalledPkgIndex =
+ foldl' (flip PackageIndex.deletePackageId)
+ (depResolverInstalledPkgIndex params) pkgids
+ }
+
+hideInstalledPackagesAllVersions :: [PackageName]
+ -> DepResolverParams -> DepResolverParams
+hideInstalledPackagesAllVersions pkgnames params =
+ --TODO: this should work using exclude constraints instead
+ params {
+ depResolverInstalledPkgIndex =
+ foldl' (flip PackageIndex.deletePackageName)
+ (depResolverInstalledPkgIndex params) pkgnames
+ }
+
+
+hideBrokenInstalledPackages :: DepResolverParams -> DepResolverParams
+hideBrokenInstalledPackages params =
+ hideInstalledPackagesSpecific pkgids params
+ where
+ pkgids = map packageId
+ . PackageIndex.reverseDependencyClosure
+ (depResolverInstalledPkgIndex params)
+ . map (packageId . fst)
+ . PackageIndex.brokenPackages
+ $ depResolverInstalledPkgIndex params
+
+
+upgradeDependencies :: DepResolverParams -> DepResolverParams
+upgradeDependencies = setPreferenceDefault PreferAllLatest
+
+
+reinstallTargets :: DepResolverParams -> DepResolverParams
+reinstallTargets params =
+ hideInstalledPackagesAllVersions (depResolverTargets params) params
+
+
+standardInstallPolicy :: PackageIndex InstalledPackage
+ -> SourcePackageDb
+ -> [PackageSpecifier SourcePackage]
+ -> DepResolverParams
+standardInstallPolicy
+ installedPkgIndex (SourcePackageDb sourcePkgIndex sourcePkgPrefs)
+ pkgSpecifiers
+
+ = addPreferences
+ [ PackageVersionPreference name ver
+ | (name, ver) <- Map.toList sourcePkgPrefs ]
+
+ . addConstraints
+ (concatMap pkgSpecifierConstraints pkgSpecifiers)
+
+ . addTargets
+ (map pkgSpecifierTarget pkgSpecifiers)
+
+ . hideInstalledPackagesSpecific
+ [ packageId pkg | SpecificSourcePackage pkg <- pkgSpecifiers ]
+
+ . addSourcePackages
+ [ pkg | SpecificSourcePackage pkg <- pkgSpecifiers ]
+
+ $ basicDepResolverParams
+ installedPkgIndex sourcePkgIndex
+
+
+-- ------------------------------------------------------------
+-- * Interface to the standard resolver
+-- ------------------------------------------------------------
+
+defaultResolver :: DependencyResolver
+defaultResolver = topDownResolver
+
+-- | Run the dependency solver.
+--
+-- Since this is potentially an expensive operation, the result is wrapped in a
+-- a 'Progress' structure that can be unfolded to provide progress information,
+-- logging messages and the final result or an error.
+--
+resolveDependencies :: Platform
+ -> CompilerId
+ -> DepResolverParams
+ -> Progress String String InstallPlan
+
+ --TODO: is this needed here? see dontUpgradeBasePackage
+resolveDependencies platform comp params
+ | null (depResolverTargets params)
+ = return (mkInstallPlan platform comp [])
+
+resolveDependencies platform comp params =
+
+ fmap (mkInstallPlan platform comp)
+ $ defaultResolver platform comp installedPkgIndex sourcePkgIndex
+ preferences constraints targets
+ where
+ DepResolverParams
+ targets constraints
+ prefs defpref
+ installedPkgIndex
+ sourcePkgIndex = dontUpgradeBasePackage
+ . hideBrokenInstalledPackages
+ $ params
+
+ preferences = interpretPackagesPreference
+ (Set.fromList targets) defpref prefs
+
+
+-- | Make an install plan from the output of the dep resolver.
+-- It checks that the plan is valid, or it's an error in the dep resolver.
+--
+mkInstallPlan :: Platform
+ -> CompilerId
+ -> [InstallPlan.PlanPackage] -> InstallPlan
+mkInstallPlan platform comp pkgIndex =
+ case InstallPlan.new platform comp (PackageIndex.fromList pkgIndex) 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
+
+
+-- | Give an interpretation to the global 'PackagesPreference' as
+-- specific per-package 'PackageVersionPreference'.
+--
+interpretPackagesPreference :: Set PackageName
+ -> PackagesPreferenceDefault
+ -> [PackagePreference]
+ -> (PackageName -> PackagePreferences)
+interpretPackagesPreference selected 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.
+--
+resolveWithoutDependencies :: DepResolverParams
+ -> Either [ResolveNoDepsError] [SourcePackage]
+resolveWithoutDependencies (DepResolverParams targets constraints
+ prefs defpref installedPkgIndex sourcePkgIndex) =
+ collectEithers (map selectPackage targets)
+ where
+ selectPackage :: PackageName -> Either ResolveNoDepsError SourcePackage
+ 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 sourcePkgIndex
+ 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
+ installedPkgIndex
+ . packageId
+ versionPref pkg = packageVersion pkg `withinRange` preferredVersions
+
+ packageConstraints :: PackageName -> VersionRange
+ packageConstraints pkgname =
+ Map.findWithDefault anyVersion pkgname packageVersionConstraintMap
+ packageVersionConstraintMap =
+ Map.fromList [ (name, range)
+ | PackageConstraintVersion name range <- constraints ]
+
+ packagePreferences :: PackageName -> PackagePreferences
+ packagePreferences = interpretPackagesPreference
+ (Set.fromList targets) defpref prefs
+
+
+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)
diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/TopDown.hs b/cabal/cabal-install/Distribution/Client/Dependency/TopDown.hs
index fbab018..e51d6e8 100644
--- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/TopDown.hs
+++ b/cabal/cabal-install/Distribution/Client/Dependency/TopDown.hs
@@ -22,7 +22,7 @@ import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.InstallPlan
( PlanPackage(..) )
import Distribution.Client.Types
- ( AvailablePackage(..), ConfiguredPackage(..), InstalledPackage(..) )
+ ( SourcePackage(..), ConfiguredPackage(..), InstalledPackage(..) )
import Distribution.Client.Dependency.Types
( DependencyResolver, PackageConstraint(..)
, PackagePreferences(..), InstalledPreference(..)
@@ -31,9 +31,9 @@ import Distribution.Client.Dependency.Types
import qualified Distribution.Client.PackageIndex as PackageIndex
import Distribution.Client.PackageIndex (PackageIndex)
import Distribution.Package
- ( PackageName(..), PackageIdentifier, Package(packageId), packageVersion, packageName
- , Dependency(Dependency), thisPackageVersion, notThisPackageVersion
- , PackageFixedDeps(depends) )
+ ( PackageName(..), PackageId, Package(..), packageVersion, packageName
+ , Dependency(Dependency), thisPackageVersion
+ , simplifyDependency, PackageFixedDeps(depends) )
import Distribution.PackageDescription
( PackageDescription(buildDepends) )
import Distribution.Client.PackageUtils
@@ -41,7 +41,7 @@ import Distribution.Client.PackageUtils
import Distribution.PackageDescription.Configuration
( finalizePackageDescription, flattenPackageDescription )
import Distribution.Version
- ( VersionRange, anyVersion, withinRange, simplifyVersionRange
+ ( VersionRange, withinRange, simplifyVersionRange
, UpperBound(..), asVersionIntervals )
import Distribution.Compiler
( CompilerId )
@@ -53,7 +53,7 @@ import Distribution.Text
( display )
import Data.List
- ( foldl', maximumBy, minimumBy, nub, sort, groupBy )
+ ( foldl', maximumBy, minimumBy, nub, sort, sortBy, groupBy )
import Data.Maybe
( fromJust, fromMaybe, catMaybes )
import Data.Monoid
@@ -105,9 +105,9 @@ explore pref (ChoiceNode _ choices) =
(_, node') = maximumBy (bestByPref pkgname) choice
where
topSortNumber choice = case fst (head choice) of
- InstalledOnly (InstalledPackageEx _ i _) -> i
- AvailableOnly (UnconfiguredPackage _ i _) -> i
- InstalledAndAvailable _ (UnconfiguredPackage _ i _) -> i
+ InstalledOnly (InstalledPackageEx _ i _) -> i
+ SourceOnly (UnconfiguredPackage _ i _) -> i
+ InstalledAndSource _ (UnconfiguredPackage _ i _) -> i
bestByPref pkgname = case packageInstalledPreference of
PreferLatest ->
@@ -115,8 +115,8 @@ explore pref (ChoiceNode _ choices) =
PreferInstalled ->
comparing (\(p,_) -> (isInstalled p, isPreferred p, packageId p))
where
- isInstalled (AvailableOnly _) = False
- isInstalled _ = True
+ isInstalled (SourceOnly _) = False
+ isInstalled _ = True
isPreferred p = packageVersion p `withinRange` preferredVersions
(PackagePreferences preferredVersions packageInstalledPreference)
= pref pkgname
@@ -135,7 +135,7 @@ type ConfigurePackage = PackageIndex SelectablePackage
-> Either [Dependency] SelectedPackage
-- | (packages selected, packages discarded)
-type SelectionChanges = ([SelectedPackage], [PackageIdentifier])
+type SelectionChanges = ([SelectedPackage], [PackageId])
searchSpace :: ConfigurePackage
-> Constraints
@@ -145,6 +145,10 @@ searchSpace :: ConfigurePackage
-> SearchSpace (SelectedPackages, Constraints, SelectionChanges)
SelectablePackage
searchSpace configure constraints selected changes next =
+ assert (Set.null (selectedSet `Set.intersection` next)) $
+ assert (selectedSet `Set.isSubsetOf` Constraints.packages constraints) $
+ assert (next `Set.isSubsetOf` Constraints.packages constraints) $
+
ChoiceNode (selected, constraints, changes)
[ [ (pkg, select name pkg)
| pkg <- PackageIndex.lookupPackageName available name ]
@@ -152,15 +156,18 @@ searchSpace configure constraints selected changes next =
where
available = Constraints.choices constraints
+ selectedSet = Set.fromList (map packageName (PackageIndex.allPackages selected))
+
select name pkg = case configure available pkg of
Left missing -> Failure $ ConfigureFailed pkg
[ (dep, Constraints.conflicting constraints dep)
| dep <- missing ]
- Right pkg' -> case constrainDeps pkg' newDeps constraints [] of
- Left failure -> Failure failure
- Right (constraints', newDiscarded) ->
- searchSpace configure
- constraints' selected' (newSelected, newDiscarded) next'
+ Right pkg' ->
+ case constrainDeps pkg' newDeps (addDeps constraints newPkgs) [] of
+ Left failure -> Failure failure
+ Right (constraints', newDiscarded) ->
+ searchSpace configure
+ constraints' selected' (newSelected, newDiscarded) next'
where
selected' = foldl' (flip PackageIndex.insert) selected newSelected
newSelected =
@@ -172,39 +179,45 @@ searchSpace configure constraints selected changes next =
(PackageIndex.lookupPackageId available pkgid')
newPkgs = [ name'
- | dep <- newDeps
- , let (Dependency name' _) = untagDependency dep
+ | (Dependency name' _, _) <- newDeps
, null (PackageIndex.lookupPackageName selected' name') ]
newDeps = concatMap packageConstraints newSelected
next' = Set.delete name
$ foldl' (flip Set.insert) next newPkgs
-packageConstraints :: SelectedPackage -> [TaggedDependency]
+packageConstraints :: SelectedPackage -> [(Dependency, Bool)]
packageConstraints = either installedConstraints availableConstraints
- . preferAvailable
+ . preferSource
where
- preferAvailable (InstalledOnly pkg) = Left pkg
- preferAvailable (AvailableOnly pkg) = Right pkg
- preferAvailable (InstalledAndAvailable _ pkg) = Right pkg
+ preferSource (InstalledOnly pkg) = Left pkg
+ preferSource (SourceOnly pkg) = Right pkg
+ preferSource (InstalledAndSource _ pkg) = Right pkg
installedConstraints (InstalledPackageEx _ _ deps) =
- [ TaggedDependency InstalledConstraint (thisPackageVersion dep)
+ [ (thisPackageVersion dep, True)
| dep <- deps ]
availableConstraints (SemiConfiguredPackage _ _ deps) =
- [ TaggedDependency NoInstalledConstraint dep | dep <- deps ]
-
-constrainDeps :: SelectedPackage -> [TaggedDependency] -> Constraints
- -> [PackageIdentifier]
- -> Either Failure (Constraints, [PackageIdentifier])
+ [ (dep, False) | dep <- deps ]
+
+addDeps :: Constraints -> [PackageName] -> Constraints
+addDeps =
+ foldr $ \pkgname cs ->
+ case Constraints.addTarget pkgname cs of
+ Satisfiable cs' () -> cs'
+ _ -> impossible "addDeps unsatisfiable"
+
+constrainDeps :: SelectedPackage -> [(Dependency, Bool)] -> Constraints
+ -> [PackageId]
+ -> Either Failure (Constraints, [PackageId])
constrainDeps pkg [] cs discard =
case addPackageSelectConstraint (packageId pkg) cs of
Satisfiable cs' discard' -> Right (cs', discard' ++ discard)
- _ -> impossible
-constrainDeps pkg (dep:deps) cs discard =
- case addPackageDependencyConstraint (packageId pkg) dep cs of
+ _ -> impossible "constrainDeps unsatisfiable(1)"
+constrainDeps pkg ((dep, installedConstraint):deps) cs discard =
+ case addPackageDependencyConstraint (packageId pkg) dep installedConstraint cs of
Satisfiable cs' discard' -> constrainDeps pkg deps cs' (discard' ++ discard)
- Unsatisfiable -> impossible
+ Unsatisfiable -> impossible "constrainDeps unsatisfiable(2)"
ConflictsWith conflicts ->
- Left (DependencyConflict pkg dep conflicts)
+ Left (DependencyConflict pkg dep installedConstraint conflicts)
-- ------------------------------------------------------------
-- * The main algorithm
@@ -235,45 +248,60 @@ topDownResolver = ((((((mapMessages .).).).).).) . topDownResolver'
--
topDownResolver' :: Platform -> CompilerId
-> PackageIndex InstalledPackage
- -> PackageIndex AvailablePackage
+ -> PackageIndex SourcePackage
-> (PackageName -> PackagePreferences)
-> [PackageConstraint]
-> [PackageName]
-> Progress Log Failure [PlanPackage]
-topDownResolver' platform comp installed available
+topDownResolver' platform comp installedPkgIndex sourcePkgIndex
preferences constraints targets =
fmap (uncurry finalise)
. (\cs -> search configure preferences cs initialPkgNames)
- =<< addTopLevelConstraints constraints constraintSet
+ =<< pruneBottomUp platform comp
+ =<< addTopLevelConstraints constraints
+ =<< addTopLevelTargets targets emptyConstraintSet
where
configure = configurePackage platform comp
- constraintSet :: Constraints
- constraintSet = Constraints.empty
- (annotateInstalledPackages topSortNumber installed')
- (annotateAvailablePackages constraints topSortNumber available')
- (installed', available') = selectNeededSubset installed available
- initialPkgNames
- topSortNumber = topologicalSortNumbering installed' available'
+ emptyConstraintSet :: Constraints
+ emptyConstraintSet = Constraints.empty
+ (annotateInstalledPackages topSortNumber installedPkgIndex')
+ (annotateSourcePackages constraints topSortNumber sourcePkgIndex')
+ (installedPkgIndex', sourcePkgIndex') =
+ selectNeededSubset installedPkgIndex sourcePkgIndex initialPkgNames
+ topSortNumber = topologicalSortNumbering installedPkgIndex' sourcePkgIndex'
initialPkgNames = Set.fromList targets
finalise selected' constraints' =
PackageIndex.allPackages
- . fst . improvePlan installed' constraints'
+ . fst . improvePlan installedPkgIndex' constraints'
. PackageIndex.fromList
$ finaliseSelectedPackages preferences selected' constraints'
+
+addTopLevelTargets :: [PackageName]
+ -> Constraints
+ -> Progress a Failure Constraints
+addTopLevelTargets [] cs = Done cs
+addTopLevelTargets (pkg:pkgs) cs =
+ case Constraints.addTarget pkg cs of
+ Satisfiable cs' () -> addTopLevelTargets pkgs cs'
+ Unsatisfiable -> Fail (NoSuchPackage pkg)
+ ConflictsWith _conflicts -> impossible "addTopLevelTargets conflicts"
+
+
addTopLevelConstraints :: [PackageConstraint] -> Constraints
- -> Progress a Failure Constraints
+ -> Progress Log Failure Constraints
addTopLevelConstraints [] cs = Done cs
-addTopLevelConstraints (PackageFlagsConstraint _ _ :deps) cs =
+addTopLevelConstraints (PackageConstraintFlags _ _ :deps) cs =
addTopLevelConstraints deps cs
-addTopLevelConstraints (PackageVersionConstraint pkg ver:deps) cs =
+addTopLevelConstraints (PackageConstraintVersion pkg ver:deps) cs =
case addTopLevelVersionConstraint pkg ver cs of
- Satisfiable cs' _ ->
- addTopLevelConstraints deps cs'
+ Satisfiable cs' pkgids ->
+ Step (AppliedVersionConstraint pkg ver pkgids)
+ (addTopLevelConstraints deps cs')
Unsatisfiable ->
Fail (TopLevelVersionConstraintUnsatisfiable pkg ver)
@@ -281,24 +309,85 @@ addTopLevelConstraints (PackageVersionConstraint pkg ver:deps) cs =
ConflictsWith conflicts ->
Fail (TopLevelVersionConstraintConflict pkg ver conflicts)
-addTopLevelConstraints (PackageInstalledConstraint pkg:deps) cs =
+addTopLevelConstraints (PackageConstraintInstalled pkg:deps) cs =
case addTopLevelInstalledConstraint pkg cs of
- Satisfiable cs' _ -> addTopLevelConstraints deps cs'
+ Satisfiable cs' pkgids ->
+ Step (AppliedInstalledConstraint pkg InstalledConstraint pkgids)
+ (addTopLevelConstraints deps cs')
Unsatisfiable ->
- Fail (TopLevelInstallConstraintUnsatisfiable pkg)
+ Fail (TopLevelInstallConstraintUnsatisfiable pkg InstalledConstraint)
ConflictsWith conflicts ->
- Fail (TopLevelInstallConstraintConflict pkg conflicts)
+ Fail (TopLevelInstallConstraintConflict pkg InstalledConstraint conflicts)
+
+addTopLevelConstraints (PackageConstraintSource pkg:deps) cs =
+ case addTopLevelSourceConstraint pkg cs of
+ Satisfiable cs' pkgids ->
+ Step (AppliedInstalledConstraint pkg SourceConstraint pkgids)
+ (addTopLevelConstraints deps cs')
+
+ Unsatisfiable ->
+ Fail (TopLevelInstallConstraintUnsatisfiable pkg SourceConstraint)
+
+ ConflictsWith conflicts ->
+ Fail (TopLevelInstallConstraintConflict pkg SourceConstraint conflicts)
+
+-- | Add exclusion on available packages that cannot be configured.
+--
+pruneBottomUp :: Platform -> CompilerId
+ -> Constraints -> Progress Log Failure Constraints
+pruneBottomUp platform comp constraints =
+ foldr prune Done (initialPackages constraints) constraints
+
+ where
+ prune pkgs rest cs = foldr addExcludeConstraint rest unconfigurable cs
+ where
+ unconfigurable =
+ [ (pkg, missing) -- if necessary we could look up missing reasons
+ | (Just pkg', pkg) <- zip (map getSourcePkg pkgs) pkgs
+ , Left missing <- [configure cs pkg'] ]
+
+ addExcludeConstraint (pkg, missing) rest cs =
+ let reason = ExcludedByConfigureFail missing in
+ case addPackageExcludeConstraint (packageId pkg) reason cs of
+ Satisfiable cs' [pkgid]| packageId pkg == pkgid
+ -> Step (ExcludeUnconfigurable pkgid) (rest cs')
+ Satisfiable _ _ -> impossible "pruneBottomUp satisfiable"
+ _ -> Fail $ ConfigureFailed pkg
+ [ (dep, Constraints.conflicting cs dep)
+ | dep <- missing ]
+
+ configure cs (UnconfiguredPackage (SourcePackage _ pkg _) _ flags) =
+ finalizePackageDescription flags (dependencySatisfiable cs)
+ platform comp [] pkg
+ dependencySatisfiable cs =
+ not . null . PackageIndex.lookupDependency (Constraints.choices cs)
+
+ -- collect each group of packages (by name) in reverse topsort order
+ initialPackages =
+ reverse
+ . sortBy (comparing (topSortNumber . head))
+ . PackageIndex.allPackagesByName
+ . Constraints.choices
+
+ topSortNumber (InstalledOnly (InstalledPackageEx _ i _)) = i
+ topSortNumber (SourceOnly (UnconfiguredPackage _ i _)) = i
+ topSortNumber (InstalledAndSource _ (UnconfiguredPackage _ i _)) = i
+
+ getSourcePkg (InstalledOnly _ ) = Nothing
+ getSourcePkg (SourceOnly spkg) = Just spkg
+ getSourcePkg (InstalledAndSource _ spkg) = Just spkg
+
configurePackage :: Platform -> CompilerId -> ConfigurePackage
configurePackage platform comp available spkg = case spkg of
- InstalledOnly ipkg -> Right (InstalledOnly ipkg)
- AvailableOnly apkg -> fmap AvailableOnly (configure apkg)
- InstalledAndAvailable ipkg apkg -> fmap (InstalledAndAvailable ipkg)
- (configure apkg)
+ InstalledOnly ipkg -> Right (InstalledOnly ipkg)
+ SourceOnly apkg -> fmap SourceOnly (configure apkg)
+ InstalledAndSource ipkg apkg -> fmap (InstalledAndSource ipkg)
+ (configure apkg)
where
- configure (UnconfiguredPackage apkg@(AvailablePackage _ p _) _ flags) =
+ configure (UnconfiguredPackage apkg@(SourcePackage _ p _) _ flags) =
case finalizePackageDescription flags dependencySatisfiable
platform comp [] p of
Left missing -> Left missing
@@ -317,7 +406,7 @@ annotateInstalledPackages dfsNumber installed = PackageIndex.fromList
[ InstalledPackageEx pkg (dfsNumber (packageName pkg)) (transitiveDepends pkg)
| pkg <- PackageIndex.allPackages installed ]
where
- transitiveDepends :: InstalledPackage -> [PackageIdentifier]
+ transitiveDepends :: InstalledPackage -> [PackageId]
transitiveDepends = map (packageId . toPkg) . tail . Graph.reachable graph
. fromJust . toVertex . packageId
(graph, toPkg, toVertex) = PackageIndex.dependencyGraph installed
@@ -326,19 +415,20 @@ annotateInstalledPackages dfsNumber installed = PackageIndex.fromList
-- | Annotate each available packages with its topological sort number and any
-- user-supplied partial flag assignment.
--
-annotateAvailablePackages :: [PackageConstraint]
- -> (PackageName -> TopologicalSortNumber)
- -> PackageIndex AvailablePackage
- -> PackageIndex UnconfiguredPackage
-annotateAvailablePackages constraints dfsNumber available = PackageIndex.fromList
- [ UnconfiguredPackage pkg (dfsNumber name) (flagsFor name)
- | pkg <- PackageIndex.allPackages available
- , let name = packageName pkg ]
+annotateSourcePackages :: [PackageConstraint]
+ -> (PackageName -> TopologicalSortNumber)
+ -> PackageIndex SourcePackage
+ -> PackageIndex UnconfiguredPackage
+annotateSourcePackages constraints dfsNumber sourcePkgIndex =
+ PackageIndex.fromList
+ [ UnconfiguredPackage pkg (dfsNumber name) (flagsFor name)
+ | pkg <- PackageIndex.allPackages sourcePkgIndex
+ , let name = packageName pkg ]
where
flagsFor = fromMaybe [] . flip Map.lookup flagsMap
flagsMap = Map.fromList
[ (name, flags)
- | PackageFlagsConstraint name flags <- constraints ]
+ | PackageConstraintFlags 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
@@ -352,7 +442,7 @@ annotateAvailablePackages constraints dfsNumber available = PackageIndex.fromLis
-- one possible choice for B in which case we pick that immediately).
--
-- To construct these topological sort numbers we combine and flatten the
--- installed and available package sets. We consider only dependencies between
+-- installed and source package sets. We consider only dependencies between
-- named packages, not including versions and for not-yet-configured packages
-- we look at all the possible dependencies, not just those under any single
-- flag assignment. This means we can actually get impossible combinations of
@@ -360,9 +450,9 @@ annotateAvailablePackages constraints dfsNumber available = PackageIndex.fromLis
-- heuristic.
--
topologicalSortNumbering :: PackageIndex InstalledPackage
- -> PackageIndex AvailablePackage
+ -> PackageIndex SourcePackage
-> (PackageName -> TopologicalSortNumber)
-topologicalSortNumbering installed available =
+topologicalSortNumbering installedPkgIndex sourcePkgIndex =
\pkgname -> let Just vertex = toVertex pkgname
in topologicalSortNumbers Array.! vertex
where
@@ -370,14 +460,14 @@ topologicalSortNumbering installed available =
(zip (Graph.topSort graph) [0..])
(graph, _, toVertex) = Graph.graphFromEdges $
[ ((), packageName pkg, nub deps)
- | pkgs@(pkg:_) <- PackageIndex.allPackagesByName installed
+ | pkgs@(pkg:_) <- PackageIndex.allPackagesByName installedPkgIndex
, let deps = [ packageName dep
| pkg' <- pkgs
, dep <- depends pkg' ] ]
++ [ ((), packageName pkg, nub deps)
- | pkgs@(pkg:_) <- PackageIndex.allPackagesByName available
+ | pkgs@(pkg:_) <- PackageIndex.allPackagesByName sourcePkgIndex
, let deps = [ depName
- | AvailablePackage _ pkg' _ <- pkgs
+ | SourcePackage _ pkg' _ <- pkgs
, Dependency depName _ <-
buildDepends (flattenPackageDescription pkg') ] ]
@@ -387,24 +477,24 @@ topologicalSortNumbering installed available =
-- and looking at the names of all possible dependencies.
--
selectNeededSubset :: PackageIndex InstalledPackage
- -> PackageIndex AvailablePackage
+ -> PackageIndex SourcePackage
-> Set PackageName
-> (PackageIndex InstalledPackage
- ,PackageIndex AvailablePackage)
-selectNeededSubset installed available = select mempty mempty
+ ,PackageIndex SourcePackage)
+selectNeededSubset installedPkgIndex sourcePkgIndex = select mempty mempty
where
select :: PackageIndex InstalledPackage
- -> PackageIndex AvailablePackage
+ -> PackageIndex SourcePackage
-> Set PackageName
-> (PackageIndex InstalledPackage
- ,PackageIndex AvailablePackage)
- select installed' available' remaining
- | Set.null remaining = (installed', available')
- | otherwise = select installed'' available'' remaining''
+ ,PackageIndex SourcePackage)
+ select installedPkgIndex' sourcePkgIndex' remaining
+ | Set.null remaining = (installedPkgIndex', sourcePkgIndex')
+ | otherwise = select installedPkgIndex'' sourcePkgIndex'' remaining''
where
(next, remaining') = Set.deleteFindMin remaining
- moreInstalled = PackageIndex.lookupPackageName installed next
- moreAvailable = PackageIndex.lookupPackageName available next
+ moreInstalled = PackageIndex.lookupPackageName installedPkgIndex next
+ moreSource = PackageIndex.lookupPackageName sourcePkgIndex next
moreRemaining = -- we filter out packages already included in the indexes
-- this avoids an infinite loop if a package depends on itself
-- like base-3.0.3.0 with base-4.0.0.0
@@ -413,14 +503,18 @@ selectNeededSubset installed available = select mempty mempty
| pkg <- moreInstalled
, dep <- depends pkg ]
++ [ name
- | AvailablePackage _ pkg _ <- moreAvailable
+ | SourcePackage _ pkg _ <- moreSource
, Dependency name _ <-
buildDepends (flattenPackageDescription pkg) ]
- installed'' = foldl' (flip PackageIndex.insert) installed' moreInstalled
- available'' = foldl' (flip PackageIndex.insert) available' moreAvailable
- remaining'' = foldl' (flip Set.insert) remaining' moreRemaining
- notAlreadyIncluded name = null (PackageIndex.lookupPackageName installed' name)
- && null (PackageIndex.lookupPackageName available' name)
+ installedPkgIndex'' = foldl' (flip PackageIndex.insert)
+ installedPkgIndex' moreInstalled
+ sourcePkgIndex'' = foldl' (flip PackageIndex.insert)
+ sourcePkgIndex' moreSource
+ remaining'' = foldl' (flip Set.insert)
+ remaining' moreRemaining
+ notAlreadyIncluded name =
+ null (PackageIndex.lookupPackageName installedPkgIndex' name)
+ && null (PackageIndex.lookupPackageName sourcePkgIndex' name)
-- ------------------------------------------------------------
-- * Post processing the solution
@@ -434,24 +528,26 @@ finaliseSelectedPackages pref selected constraints =
map finaliseSelected (PackageIndex.allPackages selected)
where
remainingChoices = Constraints.choices constraints
- finaliseSelected (InstalledOnly ipkg ) = finaliseInstalled ipkg
- finaliseSelected (AvailableOnly apkg) = finaliseAvailable Nothing apkg
- finaliseSelected (InstalledAndAvailable ipkg apkg) =
+ finaliseSelected (InstalledOnly ipkg ) = finaliseInstalled ipkg
+ finaliseSelected (SourceOnly apkg) = finaliseSource Nothing apkg
+ finaliseSelected (InstalledAndSource ipkg apkg) =
case PackageIndex.lookupPackageId remainingChoices (packageId ipkg) of
- Nothing -> impossible --picked package not in constraints
- Just (AvailableOnly _) -> impossible --to constrain to avail only
- Just (InstalledOnly _) -> finaliseInstalled ipkg
- Just (InstalledAndAvailable _ _) -> finaliseAvailable (Just ipkg) apkg
+ --picked package not in constraints
+ Nothing -> impossible "finaliseSelected no pkg"
+ -- to constrain to avail only:
+ Just (SourceOnly _) -> impossible "finaliseSelected src only"
+ Just (InstalledOnly _) -> finaliseInstalled ipkg
+ Just (InstalledAndSource _ _) -> finaliseSource (Just ipkg) apkg
finaliseInstalled (InstalledPackageEx pkg _ _) = InstallPlan.PreExisting pkg
- finaliseAvailable mipkg (SemiConfiguredPackage pkg flags deps) =
+ finaliseSource mipkg (SemiConfiguredPackage pkg flags deps) =
InstallPlan.Configured (ConfiguredPackage pkg flags deps')
where
deps' = map (packageId . pickRemaining mipkg) deps
pickRemaining mipkg dep@(Dependency _name versionRange) =
case PackageIndex.lookupDependency remainingChoices dep of
- [] -> impossible
+ [] -> impossible "pickRemaining no pkg"
[pkg'] -> pkg'
remaining -> assert (checkIsPaired remaining)
$ maximumBy bestByPref remaining
@@ -467,7 +563,7 @@ finaliseSelectedPackages pref selected constraints =
Nothing -> \_ -> False
Just ipkg -> \p -> packageId p `elem` depends ipkg
-- If there is no upper bound on the version range then we apply a
- -- preferred version acording to the hackage or user's suggested
+ -- preferred version according to the hackage or user's suggested
-- version constraints. TODO: distinguish hacks from prefs
bounded = boundedAbove versionRange
isPreferred p
@@ -540,14 +636,14 @@ improvePlan installed constraints0 selected0 =
constraintsOk _ [] constraints = Just constraints
constraintsOk pkgid (pkgid':pkgids) constraints =
- case addPackageDependencyConstraint pkgid dep constraints of
+ case addPackageDependencyConstraint pkgid dep True constraints of
Satisfiable constraints' _ -> constraintsOk pkgid pkgids constraints'
_ -> Nothing
where
- dep = TaggedDependency InstalledConstraint (thisPackageVersion pkgid')
+ dep = thisPackageVersion pkgid'
reverseTopologicalOrder :: PackageFixedDeps pkg
- => PackageIndex pkg -> [PackageIdentifier]
+ => PackageIndex pkg -> [PackageId]
reverseTopologicalOrder index = map (packageId . toPkg)
. Graph.topSort
. Graph.transposeG
@@ -558,54 +654,67 @@ improvePlan installed constraints0 selected0 =
-- * Adding and recording constraints
-- ------------------------------------------------------------
-addPackageSelectConstraint :: PackageIdentifier -> Constraints
+addPackageSelectConstraint :: PackageId -> Constraints
-> Satisfiable Constraints
- [PackageIdentifier] ExclusionReason
-addPackageSelectConstraint pkgid constraints =
- Constraints.constrain dep reason constraints
+ [PackageId] ExclusionReason
+addPackageSelectConstraint pkgid =
+ Constraints.constrain pkgname constraint reason
where
- dep = TaggedDependency NoInstalledConstraint (thisPackageVersion pkgid)
- reason = SelectedOther pkgid
+ pkgname = packageName pkgid
+ constraint ver _ = ver == packageVersion pkgid
+ reason = SelectedOther pkgid
-addPackageExcludeConstraint :: PackageIdentifier -> Constraints
+addPackageExcludeConstraint :: PackageId -> ExclusionReason
+ -> Constraints
-> Satisfiable Constraints
- [PackageIdentifier] ExclusionReason
-addPackageExcludeConstraint pkgid constraints =
- Constraints.constrain dep reason constraints
+ [PackageId] ExclusionReason
+addPackageExcludeConstraint pkgid reason =
+ Constraints.constrain pkgname constraint reason
where
- dep = TaggedDependency NoInstalledConstraint
- (notThisPackageVersion pkgid)
- reason = ExcludedByConfigureFail
+ pkgname = packageName pkgid
+ constraint ver installed
+ | ver == packageVersion pkgid = installed
+ | otherwise = True
-addPackageDependencyConstraint :: PackageIdentifier -> TaggedDependency -> Constraints
+addPackageDependencyConstraint :: PackageId -> Dependency -> Bool
+ -> Constraints
-> Satisfiable Constraints
- [PackageIdentifier] ExclusionReason
-addPackageDependencyConstraint pkgid dep constraints =
- Constraints.constrain dep reason constraints
+ [PackageId] ExclusionReason
+addPackageDependencyConstraint pkgid dep@(Dependency pkgname verrange)
+ installedConstraint =
+ Constraints.constrain pkgname constraint reason
where
- reason = ExcludedByPackageDependency pkgid dep
+ constraint ver installed = ver `withinRange` verrange
+ && if installedConstraint then installed else True
+ reason = ExcludedByPackageDependency pkgid dep installedConstraint
addTopLevelVersionConstraint :: PackageName -> VersionRange
-> Constraints
-> Satisfiable Constraints
- [PackageIdentifier] ExclusionReason
-addTopLevelVersionConstraint pkg ver constraints =
- Constraints.constrain taggedDep reason constraints
+ [PackageId] ExclusionReason
+addTopLevelVersionConstraint pkgname verrange =
+ Constraints.constrain pkgname constraint reason
+ where
+ constraint ver _installed = ver `withinRange` verrange
+ reason = ExcludedByTopLevelConstraintVersion pkgname verrange
+
+addTopLevelInstalledConstraint,
+ addTopLevelSourceConstraint :: PackageName
+ -> Constraints
+ -> Satisfiable Constraints
+ [PackageId] ExclusionReason
+addTopLevelInstalledConstraint pkgname =
+ Constraints.constrain pkgname constraint reason
where
- dep = Dependency pkg ver
- taggedDep = TaggedDependency NoInstalledConstraint dep
- reason = ExcludedByTopLevelDependency dep
+ constraint _ver installed = installed
+ reason = ExcludedByTopLevelConstraintInstalled pkgname
-addTopLevelInstalledConstraint :: PackageName
- -> Constraints
- -> Satisfiable Constraints
- [PackageIdentifier] ExclusionReason
-addTopLevelInstalledConstraint pkg constraints =
- Constraints.constrain taggedDep reason constraints
+addTopLevelSourceConstraint pkgname =
+ Constraints.constrain pkgname constraint reason
where
- dep = Dependency pkg anyVersion
- taggedDep = TaggedDependency InstalledConstraint dep
- reason = ExcludedByTopLevelDependency dep
+ constraint _ver installed = not installed
+ reason = ExcludedByTopLevelConstraintSource pkgname
+
-- ------------------------------------------------------------
-- * Reasons for constraints
@@ -619,60 +728,80 @@ data ExclusionReason =
-- | We selected this other version of the package. That means we exclude
-- all the other versions.
- SelectedOther PackageIdentifier
+ SelectedOther PackageId
-- | We excluded this version of the package because it failed to
-- configure probably because of unsatisfiable deps.
- | ExcludedByConfigureFail
+ | ExcludedByConfigureFail [Dependency]
-- | We excluded this version of the package because another package that
-- we selected imposed a dependency which this package did not satisfy.
- | ExcludedByPackageDependency PackageIdentifier TaggedDependency
+ | ExcludedByPackageDependency PackageId Dependency Bool
-- | We excluded this version of the package because it did not satisfy
-- a dependency given as an original top level input.
--
- | ExcludedByTopLevelDependency Dependency
+ | ExcludedByTopLevelConstraintVersion PackageName VersionRange
+ | ExcludedByTopLevelConstraintInstalled PackageName
+ | ExcludedByTopLevelConstraintSource PackageName
+
+ deriving Eq
-- | Given an excluded package and the reason it was excluded, produce a human
-- readable explanation.
--
-showExclusionReason :: PackageIdentifier -> ExclusionReason -> String
+showExclusionReason :: PackageId -> ExclusionReason -> String
showExclusionReason pkgid (SelectedOther pkgid') =
display pkgid ++ " was excluded because " ++
display pkgid' ++ " was selected instead"
-showExclusionReason pkgid ExcludedByConfigureFail =
- display pkgid ++ " was excluded because it could not be configured"
-showExclusionReason pkgid (ExcludedByPackageDependency pkgid' dep) =
- display pkgid ++ " was excluded because " ++
- display pkgid' ++ " requires " ++ displayDep (untagDependency dep)
-showExclusionReason pkgid (ExcludedByTopLevelDependency dep) =
- display pkgid ++ " was excluded because of the top level dependency " ++
- displayDep dep
+showExclusionReason pkgid (ExcludedByConfigureFail missingDeps) =
+ display pkgid ++ " was excluded because it could not be configured. "
+ ++ "It requires " ++ listOf displayDep missingDeps
+showExclusionReason pkgid (ExcludedByPackageDependency pkgid' dep installedConstraint)
+ = display pkgid ++ " was excluded because " ++ display pkgid' ++ " requires "
+ ++ (if installedConstraint then "an installed instance of " else "")
+ ++ displayDep dep
+showExclusionReason pkgid (ExcludedByTopLevelConstraintVersion pkgname verRange) =
+ display pkgid ++ " was excluded because of the top level constraint " ++
+ displayDep (Dependency pkgname verRange)
+showExclusionReason pkgid (ExcludedByTopLevelConstraintInstalled pkgname)
+ = display pkgid ++ " was excluded because of the top level constraint '"
+ ++ display pkgname ++ " installed' which means that only installed instances "
+ ++ "of the package may be selected."
+showExclusionReason pkgid (ExcludedByTopLevelConstraintSource pkgname)
+ = display pkgid ++ " was excluded because of the top level constraint '"
+ ++ display pkgname ++ " source' which means that only source versions "
+ ++ "of the package may be selected."
-- ------------------------------------------------------------
-- * Logging progress and failures
-- ------------------------------------------------------------
-data Log = Select [SelectedPackage] [PackageIdentifier]
+data Log = Select [SelectedPackage] [PackageId]
+ | AppliedVersionConstraint PackageName VersionRange [PackageId]
+ | AppliedInstalledConstraint PackageName InstalledConstraint [PackageId]
+ | ExcludeUnconfigurable PackageId
+
data Failure
- = ConfigureFailed
+ = NoSuchPackage
+ PackageName
+ | ConfigureFailed
SelectablePackage
- [(Dependency, [(PackageIdentifier, [ExclusionReason])])]
+ [(Dependency, [(PackageId, [ExclusionReason])])]
| DependencyConflict
- SelectedPackage TaggedDependency
- [(PackageIdentifier, [ExclusionReason])]
+ SelectedPackage Dependency Bool
+ [(PackageId, [ExclusionReason])]
| TopLevelVersionConstraintConflict
PackageName VersionRange
- [(PackageIdentifier, [ExclusionReason])]
+ [(PackageId, [ExclusionReason])]
| TopLevelVersionConstraintUnsatisfiable
PackageName VersionRange
| TopLevelInstallConstraintConflict
- PackageName
- [(PackageIdentifier, [ExclusionReason])]
+ PackageName InstalledConstraint
+ [(PackageId, [ExclusionReason])]
| TopLevelInstallConstraintUnsatisfiable
- PackageName
+ PackageName InstalledConstraint
showLog :: Log -> String
showLog (Select selected discarded) = case (selectedMsg, discardedMsg) of
@@ -689,9 +818,9 @@ showLog (Select selected discarded) = case (selectedMsg, discardedMsg) of
: [ display (packageVersion s') ++ " " ++ kind s'
| s' <- ss ]
- kind (InstalledOnly _) = "(installed)"
- kind (AvailableOnly _) = "(hackage)"
- kind (InstalledAndAvailable _ _) = "(installed or hackage)"
+ kind (InstalledOnly _) = "(installed)"
+ kind (SourceOnly _) = "(source)"
+ kind (InstalledAndSource _ _) = "(installed or source)"
discardedMsg = case discarded of
[] -> ""
@@ -699,8 +828,23 @@ showLog (Select selected discarded) = case (selectedMsg, discardedMsg) of
[ element
| (pkgid:pkgids) <- groupBy (equating packageName) (sort discarded)
, element <- display pkgid : map (display . packageVersion) pkgids ]
+showLog (AppliedVersionConstraint pkgname ver pkgids) =
+ "applying constraint " ++ display (Dependency pkgname ver)
+ ++ if null pkgids
+ then ""
+ else "which excludes " ++ listOf display pkgids
+showLog (AppliedInstalledConstraint pkgname inst pkgids) =
+ "applying constraint " ++ display pkgname ++ " '"
+ ++ (case inst of InstalledConstraint -> "installed"; _ -> "source") ++ "' "
+ ++ if null pkgids
+ then ""
+ else "which excludes " ++ listOf display pkgids
+showLog (ExcludeUnconfigurable pkgid) =
+ "excluding " ++ display pkgid ++ " (it cannot be configured)"
showFailure :: Failure -> String
+showFailure (NoSuchPackage pkgname) =
+ "The package " ++ display pkgname ++ " is unknown."
showFailure (ConfigureFailed pkg missingDeps) =
"cannot configure " ++ displayPkg pkg ++ ". It requires "
++ listOf (displayDep . fst) missingDeps
@@ -720,15 +864,17 @@ showFailure (ConfigureFailed pkg missingDeps) =
where pkgs = map fst conflicts
-showFailure (DependencyConflict pkg (TaggedDependency _ dep) conflicts) =
+showFailure (DependencyConflict pkg dep installedConstraint conflicts) =
"dependencies conflict: "
- ++ displayPkg pkg ++ " requires " ++ displayDep dep ++ " however\n"
+ ++ displayPkg pkg ++ " requires "
+ ++ (if installedConstraint then "an installed instance of " else "")
+ ++ displayDep dep ++ " however:\n"
++ unlines [ showExclusionReason (packageId pkg') reason
| (pkg', reasons) <- conflicts, reason <- reasons ]
showFailure (TopLevelVersionConstraintConflict name ver conflicts) =
- "constraints conflict: "
- ++ "top level constraint " ++ displayDep (Dependency name ver) ++ " however\n"
+ "constraints conflict: we have the top level constraint "
+ ++ displayDep (Dependency name ver) ++ ", but\n"
++ unlines [ showExclusionReason (packageId pkg') reason
| (pkg', reasons) <- conflicts, reason <- reasons ]
@@ -736,31 +882,37 @@ showFailure (TopLevelVersionConstraintUnsatisfiable name ver) =
"There is no available version of " ++ display name
++ " that satisfies " ++ displayVer ver
-showFailure (TopLevelInstallConstraintConflict name conflicts) =
+showFailure (TopLevelInstallConstraintConflict name InstalledConstraint conflicts) =
"constraints conflict: "
- ++ "top level constraint " ++ display name ++ "-installed however\n"
+ ++ "top level constraint '" ++ display name ++ " installed' however\n"
++ unlines [ showExclusionReason (packageId pkg') reason
| (pkg', reasons) <- conflicts, reason <- reasons ]
-showFailure (TopLevelInstallConstraintUnsatisfiable name) =
+showFailure (TopLevelInstallConstraintUnsatisfiable name InstalledConstraint) =
"There is no installed version of " ++ display name
+showFailure (TopLevelInstallConstraintConflict name SourceConstraint conflicts) =
+ "constraints conflict: "
+ ++ "top level constraint '" ++ display name ++ " source' however\n"
+ ++ unlines [ showExclusionReason (packageId pkg') reason
+ | (pkg', reasons) <- conflicts, reason <- reasons ]
+
+showFailure (TopLevelInstallConstraintUnsatisfiable name SourceConstraint) =
+ "There is no available source version of " ++ display name
+
displayVer :: VersionRange -> String
displayVer = display . simplifyVersionRange
displayDep :: Dependency -> String
displayDep = display . simplifyDependency
-simplifyDependency :: Dependency -> Dependency
-simplifyDependency (Dependency name range) =
- Dependency name (simplifyVersionRange range)
-- ------------------------------------------------------------
-- * Utils
-- ------------------------------------------------------------
-impossible :: a
-impossible = internalError "impossible"
+impossible :: String -> a
+impossible msg = internalError $ "assertion failure: " ++ msg
internalError :: String -> a
internalError msg = error $ "internal error: " ++ msg
diff --git a/cabal/cabal-install/Distribution/Client/Dependency/TopDown/Constraints.hs b/cabal/cabal-install/Distribution/Client/Dependency/TopDown/Constraints.hs
new file mode 100644
index 0000000..216cf71
--- /dev/null
+++ b/cabal/cabal-install/Distribution/Client/Dependency/TopDown/Constraints.hs
@@ -0,0 +1,601 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Client.Dependency.TopDown.Constraints
+-- Copyright : (c) Duncan Coutts 2008
+-- License : BSD-like
+--
+-- Maintainer : duncan@community.haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+-- A set of satisfiable constraints on a set of packages.
+-----------------------------------------------------------------------------
+module Distribution.Client.Dependency.TopDown.Constraints (
+ Constraints,
+ empty,
+ packages,
+ choices,
+ isPaired,
+
+ addTarget,
+ constrain,
+ Satisfiable(..),
+ conflicting,
+ ) where
+
+import Distribution.Client.Dependency.TopDown.Types
+import qualified Distribution.Client.PackageIndex as PackageIndex
+import Distribution.Client.PackageIndex (PackageIndex)
+import Distribution.Package
+ ( PackageName, PackageId, PackageIdentifier(..)
+ , Package(packageId), packageName, packageVersion
+ , Dependency, PackageFixedDeps(depends) )
+import Distribution.Version
+ ( Version )
+import Distribution.Client.Utils
+ ( mergeBy, MergeResult(..) )
+
+import Data.Monoid
+ ( Monoid(mempty) )
+import Data.Either
+ ( partitionEithers )
+import qualified Data.Map as Map
+import Data.Map (Map)
+import qualified Data.Set as Set
+import Data.Set (Set)
+import Control.Exception
+ ( assert )
+
+
+-- | A set of satisfiable constraints on a set of packages.
+--
+-- The 'Constraints' type keeps track of a set of targets (identified by
+-- package name) that we know that we need. It also keeps track of a set of
+-- constraints over all packages in the environment.
+--
+-- It maintains the guarantee that, for the target set, the constraints are
+-- satisfiable, meaning that there is at least one instance available for each
+-- package name that satisfies the constraints on that package name.
+--
+-- Note that it is possible to over-constrain a package in the environment that
+-- is not in the target set -- the satisfiability guarantee is only maintained
+-- for the target set. This is useful because it allows us to exclude packages
+-- without needing to know if it would ever be needed or not (e.g. allows
+-- excluding broken installed packages).
+--
+-- Adding a constraint for a target package can fail if it would mean that
+-- there are no remaining choices.
+--
+-- Adding a constraint for package that is not a target never fails.
+--
+-- Adding a new target package can fail if that package already has conflicting
+-- constraints.
+--
+data (Package installed, Package source)
+ => Constraints installed source reason
+ = Constraints
+
+ -- | Targets that we know we need. This is the set for which we
+ -- guarantee the constraints are satisfiable.
+ !(Set PackageName)
+
+ -- | The available/remaining set. These are packages that have available
+ -- choices remaining. This is guaranteed to cover the target packages,
+ -- but can also cover other packages in the environment. New targets can
+ -- only be added if there are available choices remaining for them.
+ !(PackageIndex (InstalledOrSource installed source))
+
+ -- | The excluded set. Choices that we have excluded by applying
+ -- constraints. Excluded choices are tagged with the reason.
+ !(PackageIndex (ExcludedPkg (InstalledOrSource installed source) reason))
+
+ -- | Paired choices, this is an ugly hack.
+ !(Map PackageName (Version, Version))
+
+ -- | Purely for the invariant, we keep a copy of the original index
+ !(PackageIndex (InstalledOrSource installed source))
+
+
+-- | Reasons for excluding all, or some choices for a package version.
+--
+-- Each package version can have a source instance, an installed instance or
+-- both. We distinguish reasons for constraints that excluded both instances,
+-- from reasons for constraints that excluded just one instance.
+--
+data ExcludedPkg pkg reason
+ = ExcludedPkg pkg
+ [reason] -- ^ reasons for excluding both source and installed instances
+ [reason] -- ^ reasons for excluding the installed instance
+ [reason] -- ^ reasons for excluding the source instance
+
+instance Package pkg => Package (ExcludedPkg pkg reason) where
+ packageId (ExcludedPkg p _ _ _) = packageId p
+
+
+-- | There is a conservation of packages property. Packages are never gained or
+-- lost, they just transfer from the remaining set to the excluded set.
+--
+invariant :: (Package installed, Package source)
+ => Constraints installed source a -> Bool
+invariant (Constraints targets available excluded _ original) =
+
+ -- Relationship between available, excluded and original
+ all check merged
+
+ -- targets is a subset of available
+ && all (PackageIndex.elemByPackageName available) (Set.elems targets)
+
+ where
+ merged = mergeBy (\a b -> packageId a `compare` mergedPackageId b)
+ (PackageIndex.allPackages original)
+ (mergeBy (\a b -> packageId a `compare` packageId b)
+ (PackageIndex.allPackages available)
+ (PackageIndex.allPackages excluded))
+ where
+ mergedPackageId (OnlyInLeft p ) = packageId p
+ mergedPackageId (OnlyInRight p) = packageId p
+ mergedPackageId (InBoth p _) = packageId p
+
+ -- If the package was originally installed only, then
+ check (InBoth (InstalledOnly _) cur) = case cur of
+ -- now it's either still remaining as installed only
+ OnlyInLeft (InstalledOnly _) -> True
+ -- or it has been excluded
+ OnlyInRight (ExcludedPkg (InstalledOnly _) [] (_:_) []) -> True
+ _ -> False
+
+ -- If the package was originally available only, then
+ check (InBoth (SourceOnly _) cur) = case cur of
+ -- now it's either still remaining as source only
+ OnlyInLeft (SourceOnly _) -> True
+ -- or it has been excluded
+ OnlyInRight (ExcludedPkg (SourceOnly _) [] [] (_:_)) -> True
+ _ -> False
+
+ -- If the package was originally installed and source, then
+ check (InBoth (InstalledAndSource _ _) cur) = case cur of
+ -- We can have both remaining:
+ OnlyInLeft (InstalledAndSource _ _) -> True
+
+ -- both excluded, in particular it can have had the just source or
+ -- installed excluded and later had both excluded so we do not mind if
+ -- the source or installed excluded is empty or non-empty.
+ OnlyInRight (ExcludedPkg (InstalledAndSource _ _) _ _ _) -> True
+
+ -- the installed remaining and the source excluded:
+ InBoth (InstalledOnly _)
+ (ExcludedPkg (SourceOnly _) [] [] (_:_)) -> True
+
+ -- the source remaining and the installed excluded:
+ InBoth (SourceOnly _)
+ (ExcludedPkg (InstalledOnly _) [] (_:_) []) -> True
+ _ -> False
+
+ check _ = False
+
+
+-- | An update to the constraints can move packages between the two piles
+-- but not gain or loose packages.
+transitionsTo :: (Package installed, Package source)
+ => Constraints installed source a
+ -> Constraints installed source a -> Bool
+transitionsTo constraints @(Constraints _ available excluded _ _)
+ constraints'@(Constraints _ available' excluded' _ _) =
+
+ invariant constraints && invariant constraints'
+ && null availableGained && null excludedLost
+ && map (mapInstalledOrSource packageId packageId) availableLost
+ == map (mapInstalledOrSource packageId packageId) excludedGained
+
+ where
+ (availableLost, availableGained)
+ = partitionEithers (foldr lostAndGained [] availableChange)
+
+ (excludedLost, excludedGained)
+ = partitionEithers (foldr lostAndGained [] excludedChange)
+
+ availableChange =
+ mergeBy (\a b -> packageId a `compare` packageId b)
+ (PackageIndex.allPackages available)
+ (PackageIndex.allPackages available')
+
+ excludedChange =
+ mergeBy (\a b -> packageId a `compare` packageId b)
+ [ pkg | ExcludedPkg pkg _ _ _ <- PackageIndex.allPackages excluded ]
+ [ pkg | ExcludedPkg pkg _ _ _ <- PackageIndex.allPackages excluded' ]
+
+ lostAndGained mr rest = case mr of
+ OnlyInLeft pkg -> Left pkg : rest
+ InBoth (InstalledAndSource pkg _)
+ (SourceOnly _) -> Left (InstalledOnly pkg) : rest
+ InBoth (InstalledAndSource _ pkg)
+ (InstalledOnly _) -> Left (SourceOnly pkg) : rest
+ InBoth (SourceOnly _)
+ (InstalledAndSource pkg _) -> Right (InstalledOnly pkg) : rest
+ InBoth (InstalledOnly _)
+ (InstalledAndSource _ pkg) -> Right (SourceOnly pkg) : rest
+ OnlyInRight pkg -> Right pkg : rest
+ _ -> rest
+
+ mapInstalledOrSource f g pkg = case pkg of
+ InstalledOnly a -> InstalledOnly (f a)
+ SourceOnly b -> SourceOnly (g b)
+ InstalledAndSource a b -> InstalledAndSource (f a) (g b)
+
+
+-- | We construct 'Constraints' with an initial 'PackageIndex' of all the
+-- packages available.
+--
+empty :: (PackageFixedDeps installed, Package source)
+ => PackageIndex installed
+ -> PackageIndex source
+ -> Constraints installed source reason
+empty installed source =
+ Constraints targets pkgs excluded pairs pkgs
+ where
+ targets = mempty
+ excluded = mempty
+ pkgs = PackageIndex.fromList
+ . map toInstalledOrSource
+ $ mergeBy (\a b -> packageId a `compare` packageId b)
+ (PackageIndex.allPackages installed)
+ (PackageIndex.allPackages source)
+ toInstalledOrSource (OnlyInLeft i ) = InstalledOnly i
+ toInstalledOrSource (OnlyInRight a) = SourceOnly a
+ toInstalledOrSource (InBoth i a) = InstalledAndSource i a
+
+ -- pick up cases like base-3 and 4 where one version depends on the other:
+ pairs = Map.fromList
+ [ (name, (packageVersion pkgid1, packageVersion pkgid2))
+ | [pkg1, pkg2] <- PackageIndex.allPackagesByName installed
+ , let name = packageName pkg1
+ pkgid1 = packageId pkg1
+ pkgid2 = packageId pkg2
+ , any ((pkgid1==) . packageId) (depends pkg2)
+ || any ((pkgid2==) . packageId) (depends pkg1) ]
+
+
+-- | The package targets.
+--
+packages :: (Package installed, Package source)
+ => Constraints installed source reason
+ -> Set PackageName
+packages (Constraints ts _ _ _ _) = ts
+
+
+-- | The package choices that are still available.
+--
+choices :: (Package installed, Package source)
+ => Constraints installed source reason
+ -> PackageIndex (InstalledOrSource installed source)
+choices (Constraints _ available _ _ _) = available
+
+isPaired :: (Package installed, Package source)
+ => Constraints installed source reason
+ -> PackageId -> Maybe PackageId
+isPaired (Constraints _ _ _ pairs _) (PackageIdentifier name version) =
+ case Map.lookup name pairs of
+ Just (v1, v2)
+ | version == v1 -> Just (PackageIdentifier name v2)
+ | version == v2 -> Just (PackageIdentifier name v1)
+ _ -> Nothing
+
+
+data Satisfiable constraints discarded reason
+ = Satisfiable constraints discarded
+ | Unsatisfiable
+ | ConflictsWith [(PackageId, [reason])]
+
+
+addTarget :: (Package installed, Package source)
+ => PackageName
+ -> Constraints installed source reason
+ -> Satisfiable (Constraints installed source reason)
+ () reason
+addTarget pkgname
+ constraints@(Constraints targets available excluded paired original)
+
+ -- If it's already a target then there's no change
+ | pkgname `Set.member` targets
+ = Satisfiable constraints ()
+
+ -- If there is some possible choice available for this target then we're ok
+ | PackageIndex.elemByPackageName available pkgname
+ = let targets' = Set.insert pkgname targets
+ constraints' = Constraints targets' available excluded paired original
+ in assert (constraints `transitionsTo` constraints') $
+ Satisfiable constraints' ()
+
+ -- If it's not available and it is excluded then we return the conflicts
+ | PackageIndex.elemByPackageName excluded pkgname
+ = ConflictsWith conflicts
+
+ -- Otherwise, it's not available and it has not been excluded so the
+ -- package is simply completely unknown.
+ | otherwise
+ = Unsatisfiable
+
+ where
+ conflicts =
+ [ (packageId pkg, reasons)
+ | let excludedChoices = PackageIndex.lookupPackageName excluded pkgname
+ , ExcludedPkg pkg isReasons iReasons sReasons <- excludedChoices
+ , let reasons = isReasons ++ iReasons ++ sReasons ]
+
+
+constrain :: (Package installed, Package source)
+ => PackageName -- ^ which package to constrain
+ -> (Version -> Bool -> Bool) -- ^ the constraint test
+ -> reason -- ^ the reason for the constraint
+ -> Constraints installed source reason
+ -> Satisfiable (Constraints installed source reason)
+ [PackageId] reason
+constrain pkgname constraint reason
+ constraints@(Constraints targets available excluded paired original)
+
+ | pkgname `Set.member` targets && not anyRemaining
+ = if null conflicts then Unsatisfiable
+ else ConflictsWith conflicts
+
+ | otherwise
+ = let constraints' = Constraints targets available' excluded' paired original
+ in assert (constraints `transitionsTo` constraints') $
+ Satisfiable constraints' (map packageId newExcluded)
+
+ where
+ -- This tells us if any packages would remain at all for this package name if
+ -- we applied this constraint. This amounts to checking if any package
+ -- satisfies the given constraint, including version range and installation
+ -- status.
+ --
+ (available', excluded', newExcluded, anyRemaining, conflicts) =
+ updatePkgsStatus
+ available excluded
+ [] False []
+ (mergeBy (\pkg pkg' -> packageVersion pkg `compare` packageVersion pkg')
+ (PackageIndex.lookupPackageName available pkgname)
+ (PackageIndex.lookupPackageName excluded pkgname))
+
+ testConstraint pkg =
+ let ver = packageVersion pkg in
+ case Map.lookup (packageName pkg) paired of
+
+ Just (v1, v2)
+ | ver == v1 || ver == v2
+ -> case pkg of
+ InstalledOnly ipkg -> InstalledOnly (ipkg, iOk)
+ SourceOnly spkg -> SourceOnly (spkg, sOk)
+ InstalledAndSource ipkg spkg ->
+ InstalledAndSource (ipkg, iOk) (spkg, sOk)
+ where
+ iOk = constraint v1 True || constraint v2 True
+ sOk = constraint v1 False || constraint v2 False
+
+ _ -> case pkg of
+ InstalledOnly ipkg -> InstalledOnly (ipkg, iOk)
+ SourceOnly spkg -> SourceOnly (spkg, sOk)
+ InstalledAndSource ipkg spkg ->
+ InstalledAndSource (ipkg, iOk) (spkg, sOk)
+ where
+ iOk = constraint ver True
+ sOk = constraint ver False
+
+ -- For the info about available and excluded versions of the package in
+ -- question, update the info given the current constraint
+ --
+ -- We update the available package map and the excluded package map
+ -- we also collect:
+ -- * the change in available packages (for logging)
+ -- * whether there are any remaining choices
+ -- * any constraints that conflict with the current constraint
+
+ updatePkgsStatus _ _ nePkgs ok cs _
+ | seq nePkgs $ seq ok $ seq cs False = undefined
+
+ updatePkgsStatus aPkgs ePkgs nePkgs ok cs []
+ = (aPkgs, ePkgs, reverse nePkgs, ok, reverse cs)
+
+ updatePkgsStatus aPkgs ePkgs nePkgs ok cs (pkg:pkgs) =
+ let (aPkgs', ePkgs', mnePkg, ok', mc) = updatePkgStatus aPkgs ePkgs pkg
+ nePkgs' = maybeCons mnePkg nePkgs
+ cs' = maybeCons mc cs
+ in updatePkgsStatus aPkgs' ePkgs' nePkgs' (ok' || ok) cs' pkgs
+
+ maybeCons Nothing xs = xs
+ maybeCons (Just x) xs = x:xs
+
+
+ -- For the info about an available or excluded version of the package in
+ -- question, update the info given the current constraint.
+ --
+ updatePkgStatus aPkgs ePkgs pkg =
+ case viewPackageStatus pkg of
+ AllAvailable (InstalledOnly (aiPkg, False)) ->
+ removeAvailable False
+ (InstalledOnly aiPkg)
+ (PackageIndex.deletePackageId pkgid)
+ (ExcludedPkg (InstalledOnly aiPkg) [] [reason] [])
+ Nothing
+
+ AllAvailable (SourceOnly (asPkg, False)) ->
+ removeAvailable False
+ (SourceOnly asPkg)
+ (PackageIndex.deletePackageId pkgid)
+ (ExcludedPkg (SourceOnly asPkg) [] [] [reason])
+ Nothing
+
+ AllAvailable (InstalledAndSource (aiPkg, False) (asPkg, False)) ->
+ removeAvailable False
+ (InstalledAndSource aiPkg asPkg)
+ (PackageIndex.deletePackageId pkgid)
+ (ExcludedPkg (InstalledAndSource aiPkg asPkg) [reason] [] [])
+ Nothing
+
+ AllAvailable (InstalledAndSource (aiPkg, True) (asPkg, False)) ->
+ removeAvailable True
+ (SourceOnly asPkg)
+ (PackageIndex.insert (InstalledOnly aiPkg))
+ (ExcludedPkg (SourceOnly asPkg) [] [] [reason])
+ Nothing
+
+ AllAvailable (InstalledAndSource (aiPkg, False) (asPkg, True)) ->
+ removeAvailable True
+ (InstalledOnly aiPkg)
+ (PackageIndex.insert (SourceOnly asPkg))
+ (ExcludedPkg (InstalledOnly aiPkg) [] [reason] [])
+ Nothing
+
+ AllAvailable _ -> noChange True Nothing
+
+ AvailableExcluded (aiPkg, False) (ExcludedPkg (esPkg, False) _ _ srs) ->
+ removeAvailable False
+ (InstalledOnly aiPkg)
+ (PackageIndex.deletePackageId pkgid)
+ (ExcludedPkg (InstalledAndSource aiPkg esPkg) [reason] [] srs)
+ Nothing
+
+ AvailableExcluded (_aiPkg, True) (ExcludedPkg (esPkg, False) _ _ srs) ->
+ addExtraExclusion True
+ (ExcludedPkg (SourceOnly esPkg) [] [] (reason:srs))
+ Nothing
+
+ AvailableExcluded (aiPkg, False) (ExcludedPkg (esPkg, True) _ _ srs) ->
+ removeAvailable True
+ (InstalledOnly aiPkg)
+ (PackageIndex.deletePackageId pkgid)
+ (ExcludedPkg (InstalledAndSource aiPkg esPkg) [] [reason] srs)
+ (Just (pkgid, srs))
+
+ AvailableExcluded (_aiPkg, True) (ExcludedPkg (_esPkg, True) _ _ srs) ->
+ noChange True
+ (Just (pkgid, srs))
+
+ ExcludedAvailable (ExcludedPkg (eiPkg, False) _ irs _) (asPkg, False) ->
+ removeAvailable False
+ (SourceOnly asPkg)
+ (PackageIndex.deletePackageId pkgid)
+ (ExcludedPkg (InstalledAndSource eiPkg asPkg) [reason] irs [])
+ Nothing
+
+ ExcludedAvailable (ExcludedPkg (eiPkg, True) _ irs _) (asPkg, False) ->
+ removeAvailable False
+ (SourceOnly asPkg)
+ (PackageIndex.deletePackageId pkgid)
+ (ExcludedPkg (InstalledAndSource eiPkg asPkg) [] irs [reason])
+ (Just (pkgid, irs))
+
+ ExcludedAvailable (ExcludedPkg (eiPkg, False) _ irs _) (_asPkg, True) ->
+ addExtraExclusion True
+ (ExcludedPkg (InstalledOnly eiPkg) [] (reason:irs) [])
+ Nothing
+
+ ExcludedAvailable (ExcludedPkg (_eiPkg, True) _ irs _) (_asPkg, True) ->
+ noChange True
+ (Just (pkgid, irs))
+
+ AllExcluded (ExcludedPkg (InstalledOnly (eiPkg, False)) _ irs _) ->
+ addExtraExclusion False
+ (ExcludedPkg (InstalledOnly eiPkg) [] (reason:irs) [])
+ Nothing
+
+ AllExcluded (ExcludedPkg (InstalledOnly (_eiPkg, True)) _ irs _) ->
+ noChange False
+ (Just (pkgid, irs))
+
+ AllExcluded (ExcludedPkg (SourceOnly (esPkg, False)) _ _ srs) ->
+ addExtraExclusion False
+ (ExcludedPkg (SourceOnly esPkg) [] [] (reason:srs))
+ Nothing
+
+ AllExcluded (ExcludedPkg (SourceOnly (_esPkg, True)) _ _ srs) ->
+ noChange False
+ (Just (pkgid, srs))
+
+ AllExcluded (ExcludedPkg (InstalledAndSource (eiPkg, False) (esPkg, False)) isrs irs srs) ->
+ addExtraExclusion False
+ (ExcludedPkg (InstalledAndSource eiPkg esPkg) (reason:isrs) irs srs)
+ Nothing
+
+ AllExcluded (ExcludedPkg (InstalledAndSource (eiPkg, True) (esPkg, False)) isrs irs srs) ->
+ addExtraExclusion False
+ (ExcludedPkg (InstalledAndSource eiPkg esPkg) isrs irs (reason:srs))
+ (Just (pkgid, irs))
+
+ AllExcluded (ExcludedPkg (InstalledAndSource (eiPkg, False) (esPkg, True)) isrs irs srs) ->
+ addExtraExclusion False
+ (ExcludedPkg (InstalledAndSource eiPkg esPkg) isrs (reason:irs) srs)
+ (Just (pkgid, srs))
+
+ AllExcluded (ExcludedPkg (InstalledAndSource (_eiPkg, True) (_esPkg, True)) isrs irs srs) ->
+ noChange False
+ (Just (pkgid, isrs ++ irs ++ srs))
+
+ where
+ removeAvailable ok nePkg adjustAvailable ePkg c =
+ let aPkgs' = adjustAvailable aPkgs
+ ePkgs' = PackageIndex.insert ePkg ePkgs
+ in aPkgs' `seq` ePkgs' `seq`
+ (aPkgs', ePkgs', Just nePkg, ok, c)
+
+ addExtraExclusion ok ePkg c =
+ let ePkgs' = PackageIndex.insert ePkg ePkgs
+ in ePkgs' `seq`
+ (aPkgs, ePkgs', Nothing, ok, c)
+
+ noChange ok c =
+ (aPkgs, ePkgs, Nothing, ok, c)
+
+ pkgid = case pkg of OnlyInLeft p -> packageId p
+ OnlyInRight p -> packageId p
+ InBoth p _ -> packageId p
+
+
+ viewPackageStatus
+ :: (Package installed, Package source)
+ => MergeResult (InstalledOrSource installed source)
+ (ExcludedPkg (InstalledOrSource installed source) reason)
+ -> PackageStatus (installed, Bool) (source, Bool) reason
+ viewPackageStatus merged =
+ case merged of
+ OnlyInLeft aPkg ->
+ AllAvailable (testConstraint aPkg)
+
+ OnlyInRight (ExcludedPkg ePkg isrs irs srs) ->
+ AllExcluded (ExcludedPkg (testConstraint ePkg) isrs irs srs)
+
+ InBoth (InstalledOnly aiPkg)
+ (ExcludedPkg (SourceOnly esPkg) [] [] srs) ->
+ case testConstraint (InstalledAndSource aiPkg esPkg) of
+ InstalledAndSource (aiPkg', iOk) (esPkg', sOk) ->
+ AvailableExcluded (aiPkg', iOk) (ExcludedPkg (esPkg', sOk) [] [] srs)
+ _ -> impossible
+
+ InBoth (SourceOnly asPkg)
+ (ExcludedPkg (InstalledOnly eiPkg) [] irs []) ->
+ case testConstraint (InstalledAndSource eiPkg asPkg) of
+ InstalledAndSource (eiPkg', iOk) (asPkg', sOk) ->
+ ExcludedAvailable (ExcludedPkg (eiPkg', iOk) [] irs []) (asPkg', sOk)
+ _ -> impossible
+ _ -> impossible
+ where
+ impossible = error "impossible: viewPackageStatus invariant violation"
+
+-- A intermediate structure that enumerates all the possible cases given the
+-- invariant. This helps us to get simpler and complete pattern matching in
+-- updatePkg above
+--
+data PackageStatus installed source reason
+ = AllAvailable (InstalledOrSource installed source)
+ | AllExcluded (ExcludedPkg (InstalledOrSource installed source) reason)
+ | AvailableExcluded installed (ExcludedPkg source reason)
+ | ExcludedAvailable (ExcludedPkg installed reason) source
+
+
+conflicting :: (Package installed, Package source)
+ => Constraints installed source reason
+ -> Dependency
+ -> [(PackageId, [reason])]
+conflicting (Constraints _ _ excluded _ _) dep =
+ [ (packageId pkg, reasonsAll ++ reasonsAvail ++ reasonsInstalled) --TODO
+ | ExcludedPkg pkg reasonsAll reasonsAvail reasonsInstalled <-
+ PackageIndex.lookupDependency excluded dep ]
diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/TopDown/Types.hs b/cabal/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs
index 39c9ed5..5c83775 100644
--- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/TopDown/Types.hs
+++ b/cabal/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs
@@ -13,7 +13,7 @@
module Distribution.Client.Dependency.TopDown.Types where
import Distribution.Client.Types
- ( AvailablePackage(..), InstalledPackage )
+ ( SourcePackage(..), InstalledPackage )
import Distribution.Package
( PackageIdentifier, Dependency
@@ -26,15 +26,16 @@ import Distribution.PackageDescription
-- ------------------------------------------------------------
type SelectablePackage
- = InstalledOrAvailable InstalledPackageEx UnconfiguredPackage
+ = InstalledOrSource InstalledPackageEx UnconfiguredPackage
type SelectedPackage
- = InstalledOrAvailable InstalledPackageEx SemiConfiguredPackage
+ = InstalledOrSource InstalledPackageEx SemiConfiguredPackage
-data InstalledOrAvailable installed available
- = InstalledOnly installed
- | AvailableOnly available
- | InstalledAndAvailable installed available
+data InstalledOrSource installed source
+ = InstalledOnly installed
+ | SourceOnly source
+ | InstalledAndSource installed source
+ deriving Eq
type TopologicalSortNumber = Int
@@ -46,13 +47,13 @@ data InstalledPackageEx
data UnconfiguredPackage
= UnconfiguredPackage
- AvailablePackage
+ SourcePackage
!TopologicalSortNumber
FlagAssignment
data SemiConfiguredPackage
= SemiConfiguredPackage
- AvailablePackage -- package info
+ SourcePackage -- package info
FlagAssignment -- total flag assignment for the package
[Dependency] -- dependencies we end up with when we apply
-- the flag assignment
@@ -69,25 +70,20 @@ instance Package UnconfiguredPackage where
instance Package SemiConfiguredPackage where
packageId (SemiConfiguredPackage p _ _) = packageId p
-instance (Package installed, Package available)
- => Package (InstalledOrAvailable installed available) where
- packageId (InstalledOnly p ) = packageId p
- packageId (AvailableOnly p ) = packageId p
- packageId (InstalledAndAvailable p _) = packageId p
+instance (Package installed, Package source)
+ => Package (InstalledOrSource installed source) where
+ packageId (InstalledOnly p ) = packageId p
+ packageId (SourceOnly p ) = packageId p
+ packageId (InstalledAndSource p _) = packageId p
--- ------------------------------------------------------------
--- * Tagged Dependency type
--- ------------------------------------------------------------
--- | Installed packages can only depend on other installed packages while
--- packages that are not yet installed but which we plan to install can depend
--- on installed or other not-yet-installed packages.
+-- | We can have constraints on selecting just installed or just source
+-- packages.
--
--- This makes life more complex as we have to remember these constraints.
+-- In particular, installed packages can only depend on other installed
+-- packages while packages that are not yet installed but which we plan to
+-- install can depend on installed or other not-yet-installed packages.
--
-data TaggedDependency = TaggedDependency InstalledConstraint Dependency
-data InstalledConstraint = InstalledConstraint | NoInstalledConstraint
- deriving Eq
-
-untagDependency :: TaggedDependency -> Dependency
-untagDependency (TaggedDependency _ dep) = dep
+data InstalledConstraint = InstalledConstraint
+ | SourceConstraint
+ deriving (Eq, Show)
diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/Types.hs b/cabal/cabal-install/Distribution/Client/Dependency/Types.hs
index e5da64e..5b245a1 100644
--- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/Types.hs
+++ b/cabal/cabal-install/Distribution/Client/Dependency/Types.hs
@@ -22,7 +22,7 @@ module Distribution.Client.Dependency.Types (
) where
import Distribution.Client.Types
- ( AvailablePackage(..), InstalledPackage )
+ ( SourcePackage(..), InstalledPackage )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.PackageDescription
@@ -51,7 +51,7 @@ import Prelude hiding (fail)
type DependencyResolver = Platform
-> CompilerId
-> PackageIndex InstalledPackage
- -> PackageIndex AvailablePackage
+ -> PackageIndex SourcePackage
-> (PackageName -> PackagePreferences)
-> [PackageConstraint]
-> [PackageName]
@@ -63,9 +63,11 @@ type DependencyResolver = Platform
-- range or inconsistent flag assignment).
--
data PackageConstraint
- = PackageVersionConstraint PackageName VersionRange
- | PackageInstalledConstraint PackageName
- | PackageFlagsConstraint PackageName FlagAssignment
+ = PackageConstraintVersion PackageName VersionRange
+ | PackageConstraintInstalled PackageName
+ | PackageConstraintSource PackageName
+ | PackageConstraintFlags PackageName FlagAssignment
+ deriving (Show,Eq)
-- | A per-package preference on the version. It is a soft constraint that the
-- 'DependencyResolver' should try to respect where possible. It consists of
diff --git a/cabal/cabal-install/Distribution/Client/Fetch.hs b/cabal/cabal-install/Distribution/Client/Fetch.hs
new file mode 100644
index 0000000..f69bf85
--- /dev/null
+++ b/cabal/cabal-install/Distribution/Client/Fetch.hs
@@ -0,0 +1,173 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Client.Fetch
+-- Copyright : (c) David Himmelstrup 2005
+-- Duncan Coutts 2011
+-- License : BSD-like
+--
+-- Maintainer : cabal-devel@gmail.com
+-- Stability : provisional
+-- Portability : portable
+--
+-- The cabal fetch command
+-----------------------------------------------------------------------------
+module Distribution.Client.Fetch (
+ fetch,
+ ) where
+
+import Distribution.Client.Types
+import Distribution.Client.Targets
+import Distribution.Client.FetchUtils hiding (fetchPackage)
+import Distribution.Client.Dependency
+import Distribution.Client.PackageIndex (PackageIndex)
+import Distribution.Client.IndexUtils as IndexUtils
+ ( getSourcePackages, getInstalledPackages )
+import qualified Distribution.Client.InstallPlan as InstallPlan
+import Distribution.Client.Setup
+ ( GlobalFlags(..), FetchFlags(..) )
+
+import Distribution.Package
+ ( packageId )
+import Distribution.Simple.Compiler
+ ( Compiler(compilerId), PackageDBStack )
+import Distribution.Simple.Program
+ ( ProgramConfiguration )
+import Distribution.Simple.Setup
+ ( fromFlag )
+import Distribution.Simple.Utils
+ ( die, notice, debug )
+import Distribution.System
+ ( buildPlatform )
+import Distribution.Text
+ ( display )
+import Distribution.Verbosity
+ ( Verbosity )
+
+import Control.Monad
+ ( filterM )
+
+-- ------------------------------------------------------------
+-- * The fetch command
+-- ------------------------------------------------------------
+
+--TODO:
+-- * add fetch -o support
+-- * support tarball URLs via ad-hoc download cache (or in -o mode?)
+-- * suggest using --no-deps, unpack or fetch -o if deps cannot be satisfied
+-- * Port various flags from install:
+-- * --updage-dependencies
+-- * --constraint and --preference
+-- * --only-dependencies, but note it conflicts with --no-deps
+
+
+-- | Fetch a list of packages and their dependencies.
+--
+fetch :: Verbosity
+ -> PackageDBStack
+ -> [Repo]
+ -> Compiler
+ -> ProgramConfiguration
+ -> GlobalFlags
+ -> FetchFlags
+ -> [UserTarget]
+ -> IO ()
+fetch verbosity _ _ _ _ _ _ [] =
+ notice verbosity "No packages requested. Nothing to do."
+
+fetch verbosity packageDBs repos comp conf
+ globalFlags fetchFlags userTargets = do
+
+ mapM_ checkTarget userTargets
+
+ installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
+ sourcePkgDb <- getSourcePackages verbosity repos
+
+ pkgSpecifiers <- resolveUserTargets verbosity
+ (fromFlag $ globalWorldFile globalFlags)
+ (packageIndex sourcePkgDb)
+ userTargets
+
+ pkgs <- planPackages
+ verbosity comp fetchFlags
+ installedPkgIndex sourcePkgDb pkgSpecifiers
+
+ pkgs' <- filterM (fmap not . isFetched . packageSource) pkgs
+ if null pkgs'
+ --TODO: when we add support for remote tarballs then this message
+ -- will need to be changed because for remote tarballs we fetch them
+ -- at the earlier phase.
+ then notice verbosity $ "No packages need to be fetched. "
+ ++ "All the requested packages are already local "
+ ++ "or cached locally."
+ else if dryRun
+ then notice verbosity $ unlines $
+ "The following packages would be fetched:"
+ : map (display . packageId) pkgs'
+
+ else mapM_ (fetchPackage verbosity . packageSource) pkgs'
+
+ where
+ dryRun = fromFlag (fetchDryRun fetchFlags)
+
+planPackages :: Verbosity
+ -> Compiler
+ -> FetchFlags
+ -> PackageIndex InstalledPackage
+ -> SourcePackageDb
+ -> [PackageSpecifier SourcePackage]
+ -> IO [SourcePackage]
+planPackages verbosity comp fetchFlags
+ installedPkgIndex sourcePkgDb pkgSpecifiers
+
+ | includeDependencies = do
+ notice verbosity "Resolving dependencies..."
+ installPlan <- foldProgress logMsg die return $
+ resolveDependencies
+ buildPlatform (compilerId comp)
+ resolverParams
+
+ -- The packages we want to fetch are those packages the 'InstallPlan'
+ -- that are in the 'InstallPlan.Configured' state.
+ return
+ [ pkg
+ | (InstallPlan.Configured (InstallPlan.ConfiguredPackage pkg _ _))
+ <- InstallPlan.toList installPlan ]
+
+ | otherwise =
+ either (die . unlines . map show) return $
+ resolveWithoutDependencies resolverParams
+
+ where
+ resolverParams =
+
+ -- Reinstall the targets given on the command line so that the dep
+ -- resolver will decide that they need fetching, even if they're
+ -- already installed. Sicne we want to get the source packages of
+ -- things we might have installed (but not have the sources for).
+ reinstallTargets
+
+ $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers
+
+ includeDependencies = fromFlag (fetchDeps fetchFlags)
+ logMsg message rest = debug verbosity message >> rest
+
+
+checkTarget :: UserTarget -> IO ()
+checkTarget target = case target of
+ UserTargetRemoteTarball _uri
+ -> die $ "The 'fetch' command does not yet support remote tarballs. "
+ ++ "In the meantime you can use the 'unpack' commands."
+ _ -> return ()
+
+fetchPackage :: Verbosity -> PackageLocation a -> IO ()
+fetchPackage verbosity pkgsrc = case pkgsrc of
+ LocalUnpackedPackage _dir -> return ()
+ LocalTarballPackage _file -> return ()
+
+ RemoteTarballPackage _uri _ ->
+ die $ "The 'fetch' command does not yet support remote tarballs. "
+ ++ "In the meantime you can use the 'unpack' commands."
+
+ RepoTarballPackage repo pkgid _ -> do
+ _ <- fetchRepoTarball verbosity repo pkgid
+ return ()
diff --git a/cabal/cabal-install/Distribution/Client/FetchUtils.hs b/cabal/cabal-install/Distribution/Client/FetchUtils.hs
new file mode 100644
index 0000000..3f5be0a
--- /dev/null
+++ b/cabal/cabal-install/Distribution/Client/FetchUtils.hs
@@ -0,0 +1,193 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Client.FetchUtils
+-- Copyright : (c) David Himmelstrup 2005
+-- Duncan Coutts 2011
+-- License : BSD-like
+--
+-- Maintainer : cabal-devel@gmail.com
+-- Stability : provisional
+-- Portability : portable
+--
+-- Functions for fetching packages
+-----------------------------------------------------------------------------
+module Distribution.Client.FetchUtils (
+
+ -- * fetching packages
+ fetchPackage,
+ isFetched,
+ checkFetched,
+
+ -- ** specifically for repo packages
+ fetchRepoTarball,
+
+ -- * fetching other things
+ downloadIndex,
+ ) where
+
+import Distribution.Client.Types
+import Distribution.Client.HttpUtils
+ ( downloadURI, isOldHackageURI )
+
+import Distribution.Package
+ ( PackageId, packageName, packageVersion )
+import Distribution.Simple.Utils
+ ( notice, info, setupMessage )
+import Distribution.Text
+ ( display )
+import Distribution.Verbosity
+ ( Verbosity )
+
+import Data.Maybe
+import System.Directory
+ ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory )
+import System.IO
+ ( openTempFile, hClose )
+import System.FilePath
+ ( (</>), (<.>) )
+import qualified System.FilePath.Posix as FilePath.Posix
+ ( combine, joinPath )
+import Network.URI
+ ( URI(uriPath) )
+
+-- ------------------------------------------------------------
+-- * Actually fetch things
+-- ------------------------------------------------------------
+
+-- | Returns @True@ if the package has already been fetched
+-- or does not need fetching.
+--
+isFetched :: PackageLocation (Maybe FilePath) -> IO Bool
+isFetched loc = case loc of
+ LocalUnpackedPackage _dir -> return True
+ LocalTarballPackage _file -> return True
+ RemoteTarballPackage _uri local -> return (isJust local)
+ RepoTarballPackage repo pkgid _ -> doesFileExist (packageFile repo pkgid)
+
+
+checkFetched :: PackageLocation (Maybe FilePath)
+ -> IO (Maybe (PackageLocation FilePath))
+checkFetched loc = case loc of
+ LocalUnpackedPackage dir ->
+ return (Just $ LocalUnpackedPackage dir)
+ LocalTarballPackage file ->
+ return (Just $ LocalTarballPackage file)
+ RemoteTarballPackage uri (Just file) ->
+ return (Just $ RemoteTarballPackage uri file)
+ RepoTarballPackage repo pkgid (Just file) ->
+ return (Just $ RepoTarballPackage repo pkgid file)
+
+ RemoteTarballPackage _uri Nothing -> return Nothing
+ RepoTarballPackage repo pkgid Nothing -> do
+ let file = packageFile repo pkgid
+ exists <- doesFileExist file
+ if exists
+ then return (Just $ RepoTarballPackage repo pkgid file)
+ else return Nothing
+
+
+-- | Fetch a package if we don't have it already.
+--
+fetchPackage :: Verbosity
+ -> PackageLocation (Maybe FilePath)
+ -> IO (PackageLocation FilePath)
+fetchPackage verbosity loc = case loc of
+ LocalUnpackedPackage dir ->
+ return (LocalUnpackedPackage dir)
+ LocalTarballPackage file ->
+ return (LocalTarballPackage file)
+ RemoteTarballPackage uri (Just file) ->
+ return (RemoteTarballPackage uri file)
+ RepoTarballPackage repo pkgid (Just file) ->
+ return (RepoTarballPackage repo pkgid file)
+
+ RemoteTarballPackage uri Nothing -> do
+ path <- downloadTarballPackage uri
+ return (RemoteTarballPackage uri path)
+ RepoTarballPackage repo pkgid Nothing -> do
+ local <- fetchRepoTarball verbosity repo pkgid
+ return (RepoTarballPackage repo pkgid local)
+ where
+ downloadTarballPackage uri = do
+ notice verbosity ("Downloading " ++ show uri)
+ tmpdir <- getTemporaryDirectory
+ (path, hnd) <- openTempFile tmpdir "cabal-.tar.gz"
+ hClose hnd
+ downloadURI verbosity uri path
+ return path
+
+
+-- | Fetch a repo package if we don't have it already.
+--
+fetchRepoTarball :: Verbosity -> Repo -> PackageId -> IO FilePath
+fetchRepoTarball verbosity repo pkgid = do
+ fetched <- doesFileExist (packageFile repo pkgid)
+ if fetched
+ then do info verbosity $ display pkgid ++ " has already been downloaded."
+ return (packageFile repo pkgid)
+ else do setupMessage verbosity "Downloading" pkgid
+ downloadRepoPackage
+ where
+ downloadRepoPackage = case repoKind repo of
+ Right LocalRepo -> return (packageFile repo pkgid)
+
+ Left remoteRepo -> do
+ let uri = packageURI remoteRepo pkgid
+ dir = packageDir repo pkgid
+ path = packageFile repo pkgid
+ createDirectoryIfMissing True dir
+ downloadURI verbosity uri path
+ return path
+
+-- | Downloads an index file to [config-dir/packages/serv-id].
+--
+downloadIndex :: Verbosity -> RemoteRepo -> FilePath -> IO FilePath
+downloadIndex verbosity repo cacheDir = do
+ let uri = (remoteRepoURI repo) {
+ uriPath = uriPath (remoteRepoURI repo)
+ `FilePath.Posix.combine` "00-index.tar.gz"
+ }
+ path = cacheDir </> "00-index" <.> "tar.gz"
+ createDirectoryIfMissing True cacheDir
+ downloadURI verbosity uri path
+ return path
+
+
+-- ------------------------------------------------------------
+-- * Path utilities
+-- ------------------------------------------------------------
+
+-- | Generate the full path to the locally cached copy of
+-- the tarball for a given @PackageIdentifer@.
+--
+packageFile :: Repo -> PackageId -> FilePath
+packageFile repo pkgid = packageDir repo pkgid
+ </> display pkgid
+ <.> "tar.gz"
+
+-- | Generate the full path to the directory where the local cached copy of
+-- the tarball for a given @PackageIdentifer@ is stored.
+--
+packageDir :: Repo -> PackageId -> FilePath
+packageDir repo pkgid = repoLocalDir repo
+ </> display (packageName pkgid)
+ </> display (packageVersion pkgid)
+
+-- | Generate the URI of the tarball for a given package.
+--
+packageURI :: RemoteRepo -> PackageId -> URI
+packageURI repo pkgid | isOldHackageURI (remoteRepoURI repo) =
+ (remoteRepoURI repo) {
+ uriPath = FilePath.Posix.joinPath
+ [uriPath (remoteRepoURI repo)
+ ,display (packageName pkgid)
+ ,display (packageVersion pkgid)
+ ,display pkgid <.> "tar.gz"]
+ }
+packageURI repo pkgid =
+ (remoteRepoURI repo) {
+ uriPath = FilePath.Posix.joinPath
+ [uriPath (remoteRepoURI repo)
+ ,"package"
+ ,display pkgid <.> "tar.gz"]
+ }
diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/GZipUtils.hs b/cabal/cabal-install/Distribution/Client/GZipUtils.hs
index e4ce1aa..e4ce1aa 100644
--- a/cabal-install-0.9.5_rc20101226/Distribution/Client/GZipUtils.hs
+++ b/cabal/cabal-install/Distribution/Client/GZipUtils.hs
diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Haddock.hs b/cabal/cabal-install/Distribution/Client/Haddock.hs
index 72cebc5..72cebc5 100644
--- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Haddock.hs
+++ b/cabal/cabal-install/Distribution/Client/Haddock.hs
diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/HttpUtils.hs b/cabal/cabal-install/Distribution/Client/HttpUtils.hs
index 81f6d12..16a9a4c 100644
--- a/cabal-install-0.9.5_rc20101226/Distribution/Client/HttpUtils.hs
+++ b/cabal/cabal-install/Distribution/Client/HttpUtils.hs
@@ -31,7 +31,7 @@ import System.Win32.Registry
, regQueryValue, regQueryValueEx )
import Control.Exception
( bracket )
-import Distribution.Compat.Exception
+import Distribution.Compat.ExceptionCI
( handleIO )
import Foreign
( toBool, Storable(peek, sizeOf), castPtr, alloca )
diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/IndexUtils.hs b/cabal/cabal-install/Distribution/Client/IndexUtils.hs
index 9427586..0522a96 100644
--- a/cabal-install-0.9.5_rc20101226/Distribution/Client/IndexUtils.hs
+++ b/cabal/cabal-install/Distribution/Client/IndexUtils.hs
@@ -4,7 +4,7 @@
-- Copyright : (c) Duncan Coutts 2008
-- License : BSD-like
--
--- Maintainer : duncan@haskell.org
+-- Maintainer : duncan@community.haskell.org
-- Stability : provisional
-- Portability : portable
--
@@ -12,23 +12,18 @@
-----------------------------------------------------------------------------
module Distribution.Client.IndexUtils (
getInstalledPackages,
- getAvailablePackages,
+ getSourcePackages,
readPackageIndexFile,
parseRepoIndex,
-
- disambiguatePackageName,
- disambiguateDependencies
) where
import qualified Distribution.Client.Tar as Tar
import Distribution.Client.Types
- ( UnresolvedDependency(..), AvailablePackage(..)
- , AvailablePackageSource(..), Repo(..), RemoteRepo(..)
- , AvailablePackageDb(..), InstalledPackage(..) )
import Distribution.Package
- ( PackageId, PackageIdentifier(..), PackageName(..), Package(..)
+ ( PackageId, PackageIdentifier(..), PackageName(..)
+ , Package(..), packageVersion
, Dependency(Dependency), InstalledPackageId(..) )
import Distribution.Client.PackageIndex (PackageIndex)
import qualified Distribution.Client.PackageIndex as PackageIndex
@@ -49,12 +44,14 @@ import Distribution.ParseUtils
import Distribution.Version
( Version(Version), intersectVersionRanges )
import Distribution.Text
- ( display, simpleParse )
-import Distribution.Verbosity (Verbosity)
-import Distribution.Simple.Utils (die, warn, info, intercalate, fromUTF8)
+ ( simpleParse )
+import Distribution.Verbosity
+ ( Verbosity, lessVerbose )
+import Distribution.Simple.Utils
+ ( warn, info, fromUTF8, equating )
import Data.Maybe (catMaybes, fromMaybe)
-import Data.List (isPrefixOf)
+import Data.List (isPrefixOf, groupBy)
import Data.Monoid (Monoid(..))
import qualified Data.Map as Map
import Control.Monad (MonadPlus(mplus), when)
@@ -76,16 +73,23 @@ getInstalledPackages :: Verbosity -> Compiler
-> PackageDBStack -> ProgramConfiguration
-> IO (PackageIndex InstalledPackage)
getInstalledPackages verbosity comp packageDbs conf =
- fmap convert (Configure.getInstalledPackages verbosity comp packageDbs conf)
+ fmap convert (Configure.getInstalledPackages verbosity'
+ comp packageDbs conf)
where
+ --FIXME: make getInstalledPackages use sensible verbosity in the first place
+ verbosity' = lessVerbose verbosity
+
convert :: InstalledPackageIndex.PackageIndex -> PackageIndex InstalledPackage
- convert index = PackageIndex.fromList $
- reverse -- because later ones mask earlier ones, but
- -- InstalledPackageIndex.allPackages gives us the most preferred
- -- instances first, when packages share a package id, like when
- -- the same package is installed in the global & user dbs.
+ convert index = PackageIndex.fromList
+ -- There can be multiple installed instances of each package version,
+ -- like when the same package is installed in the global & user dbs.
+ -- InstalledPackageIndex.allPackagesByName gives us the installed
+ -- packages with the most preferred instances first, so by picking the
+ -- first we should get the user one. This is almost but not quite the
+ -- same as what ghc does.
[ InstalledPackage ipkg (sourceDeps index ipkg)
- | ipkg <- InstalledPackageIndex.allPackages index ]
+ | ipkgs <- InstalledPackageIndex.allPackagesByName index
+ , (ipkg:_) <- groupBy (equating packageVersion) ipkgs ]
-- The InstalledPackageInfo only lists dependencies by the
-- InstalledPackageId, which means we do not directly know the corresponding
@@ -108,20 +112,20 @@ getInstalledPackages verbosity comp packageDbs conf =
-- | Read a repository index from disk, from the local files specified by
-- a list of 'Repo's.
--
--- All the 'AvailablePackage's are marked as having come from the appropriate
+-- All the 'SourcePackage's are marked as having come from the appropriate
-- 'Repo'.
--
-- This is a higher level wrapper used internally in cabal-install.
--
-getAvailablePackages :: Verbosity -> [Repo] -> IO AvailablePackageDb
-getAvailablePackages verbosity [] = do
+getSourcePackages :: Verbosity -> [Repo] -> IO SourcePackageDb
+getSourcePackages verbosity [] = do
warn verbosity $ "No remote package servers have been specified. Usually "
++ "you would have one specified in the config file."
- return AvailablePackageDb {
+ return SourcePackageDb {
packageIndex = mempty,
packagePreferences = mempty
}
-getAvailablePackages verbosity repos = do
+getSourcePackages verbosity repos = do
info verbosity "Reading available packages..."
pkgss <- mapM (readRepoIndex verbosity) repos
let (pkgs, prefs) = mconcat pkgss
@@ -129,7 +133,7 @@ getAvailablePackages verbosity repos = do
[ (name, range) | Dependency name range <- prefs ]
_ <- evaluate pkgs
_ <- evaluate prefs'
- return AvailablePackageDb {
+ return SourcePackageDb {
packageIndex = pkgs,
packagePreferences = prefs'
}
@@ -137,12 +141,12 @@ getAvailablePackages verbosity repos = do
-- | Read a repository index from disk, from the local file specified by
-- the 'Repo'.
--
--- All the 'AvailablePackage's are marked as having come from the given 'Repo'.
+-- All the 'SourcePackage's are marked as having come from the given 'Repo'.
--
-- This is a higher level wrapper used internally in cabal-install.
--
readRepoIndex :: Verbosity -> Repo
- -> IO (PackageIndex AvailablePackage, [Dependency])
+ -> IO (PackageIndex SourcePackage, [Dependency])
readRepoIndex verbosity repo = handleNotFound $ do
let indexFile = repoLocalDir repo </> "00-index.tar"
(pkgs, prefs) <- either fail return
@@ -150,10 +154,10 @@ readRepoIndex verbosity repo = handleNotFound $ do
=<< BS.readFile indexFile
pkgIndex <- evaluate $ PackageIndex.fromList
- [ AvailablePackage {
+ [ SourcePackage {
packageInfoId = pkgid,
packageDescription = pkg,
- packageSource = RepoTarballPackage repo
+ packageSource = RepoTarballPackage repo pkgid Nothing
}
| (pkgid, pkg) <- pkgs]
@@ -167,10 +171,15 @@ readRepoIndex verbosity repo = handleNotFound $ do
extractPrefs :: Tar.Entry -> Maybe [Dependency]
extractPrefs entry = case Tar.entryContent entry of
+ {-
+ -- get rid of hackage's preferred-versions
+ -- I'd like to have bleeding-edge packages in system and I don't fear of
+ -- broken packages with improper depends
Tar.NormalFile content _
| takeFileName (Tar.entryPath entry) == "preferred-versions"
-> Just . parsePreferredVersions
. BS.Char8.unpack $ content
+ -}
_ -> Nothing
handleNotFound action = catch action $ \e -> if isDoesNotExistError e
@@ -259,41 +268,3 @@ foldlTarball f z = either Left (Right . foldl f z) . check [] . Tar.read
check _ (Tar.Fail err) = Left err
check ok Tar.Done = Right ok
check ok (Tar.Next e es) = check (e:ok) es
-
--- | Disambiguate a set of packages using 'disambiguatePackage' and report any
--- ambiguities to the user.
---
-disambiguateDependencies :: PackageIndex AvailablePackage
- -> [UnresolvedDependency]
- -> IO [UnresolvedDependency]
-disambiguateDependencies index deps = do
- let names = [ (name, disambiguatePackageName index name)
- | UnresolvedDependency (Dependency name _) _ <- deps ]
- in case [ (name, matches) | (name, Right matches) <- names ] of
- [] -> return
- [ UnresolvedDependency (Dependency name vrange) flags
- | (UnresolvedDependency (Dependency _ vrange) flags,
- (_, Left name)) <- zip deps names ]
- ambigious -> die $ unlines
- [ if null matches
- then "There is no package named " ++ display name ++ ". "
- ++ "Perhaps you need to run 'hackport update' first?"
- else "The package name " ++ display name ++ "is ambigious. "
- ++ "It could be: " ++ intercalate ", " (map display matches)
- | (name, matches) <- ambigious ]
-
--- | Given an index of known packages and a package name, figure out which one it
--- might be referring to. If there is an exact case-sensitive match then that's
--- ok. If it matches just one package case-insensitively then that's also ok.
--- The only problem is if it matches multiple packages case-insensitively, in
--- that case it is ambigious.
---
-disambiguatePackageName :: PackageIndex AvailablePackage
- -> PackageName
- -> Either PackageName [PackageName]
-disambiguatePackageName index (PackageName name) =
- case PackageIndex.searchByName index name of
- PackageIndex.None -> Right []
- PackageIndex.Unambiguous pkgs -> Left (pkgName (packageId (head pkgs)))
- PackageIndex.Ambiguous pkgss -> Right [ pkgName (packageId pkg)
- | (pkg:_) <- pkgss ]
diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Init.hs b/cabal/cabal-install/Distribution/Client/Init.hs
index 429a484..62ba1d6 100644
--- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Init.hs
+++ b/cabal/cabal-install/Distribution/Client/Init.hs
@@ -29,7 +29,7 @@ import Data.Time
( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone )
import Data.List
- ( intersperse )
+ ( intersperse, (\\) )
import Data.Maybe
( fromMaybe, isJust )
import Data.Traversable
@@ -38,7 +38,7 @@ import Control.Monad
( when )
#if MIN_VERSION_base(3,0,0)
import Control.Monad
- ( (>=>) )
+ ( (>=>), join )
#endif
import Text.PrettyPrint.HughesPJ hiding (mode, cat)
@@ -94,6 +94,7 @@ extendFlags = getPackageName
>=> getSynopsis
>=> getCategory
>=> getLibOrExec
+ >=> getGenComments
>=> getSrcDir
>=> getModulesAndBuildTools
@@ -138,11 +139,13 @@ getVersion flags = do
getLicense :: InitFlags -> IO InitFlags
getLicense flags = do
lic <- return (flagToMaybe $ license flags)
- ?>> fmap (fmap (either UnknownLicense id))
+ ?>> fmap (fmap (either UnknownLicense id) . join)
(maybePrompt flags
- (promptList "Please choose a license"
- knownLicenses (Just BSD3) True))
+ (promptListOptional "Please choose a license" listedLicenses))
return $ flags { license = maybeToFlag lic }
+ where
+ listedLicenses =
+ knownLicenses \\ [GPL Nothing, LGPL Nothing, OtherLicense]
-- | The author's name and email. Prompt, or try to guess from an existing
-- darcs repo.
@@ -190,8 +193,8 @@ getSynopsis flags = do
getCategory :: InitFlags -> IO InitFlags
getCategory flags = do
cat <- return (flagToMaybe $ category flags)
- ?>> maybePrompt flags (promptList "Project category" [Codec ..]
- Nothing True)
+ ?>> fmap join (maybePrompt flags
+ (promptListOptional "Project category" [Codec ..]))
return $ flags { category = maybeToFlag cat }
-- | Ask whether the project builds a library or executable.
@@ -201,11 +204,21 @@ getLibOrExec flags = do
?>> maybePrompt flags (either (const Library) id `fmap`
(promptList "What does the package build"
[Library, Executable]
- Nothing False))
+ Nothing display False))
?>> return (Just Library)
return $ flags { packageType = maybeToFlag isLib }
+-- | Ask whether to generate explanitory comments.
+getGenComments :: InitFlags -> IO InitFlags
+getGenComments flags = do
+ genComments <- return (flagToMaybe $ noComments flags)
+ ?>> maybePrompt flags (promptYesNo promptMsg (Just False))
+ ?>> return (Just False)
+ return $ flags { noComments = maybeToFlag (fmap not genComments) }
+ where
+ promptMsg = "Include documentation on what each field means y/n"
+
-- | Try to guess the source root directory (don't prompt the user).
getSrcDir :: InitFlags -> IO InitFlags
getSrcDir flags = do
@@ -254,6 +267,18 @@ maybePrompt flags p =
promptStr :: String -> Maybe String -> IO String
promptStr = promptDefault' Just id
+-- | Create a yes/no prompt with optional default value.
+--
+promptYesNo :: String -> Maybe Bool -> IO Bool
+promptYesNo =
+ promptDefault' recogniseYesNo showYesNo
+ where
+ recogniseYesNo s | s == "y" || s == "Y" = Just True
+ | s == "n" || s == "N" = Just False
+ | otherwise = Nothing
+ showYesNo True = "y"
+ showYesNo False = "n"
+
-- | Create a prompt with optional default value that returns a value
-- of some Text instance.
prompt :: Text t => String -> Maybe t -> IO t
@@ -280,34 +305,46 @@ promptDefault' parser pretty pr def = do
-- | Create a prompt from a prompt string and a String representation
-- of an optional default value.
mkDefPrompt :: String -> Maybe String -> String
-mkDefPrompt pr def = pr ++ defStr def ++ "? "
- where defStr Nothing = ""
- defStr (Just s) = " [default \"" ++ s ++ "\"]"
+mkDefPrompt pr def = pr ++ "?" ++ defStr def
+ where defStr Nothing = " "
+ defStr (Just s) = " [default: " ++ s ++ "] "
+
+promptListOptional :: (Text t, Eq t)
+ => String -- ^ prompt
+ -> [t] -- ^ choices
+ -> IO (Maybe (Either String t))
+promptListOptional pr choices =
+ fmap rearrange
+ $ promptList pr (Nothing : map Just choices) (Just Nothing)
+ (maybe "(none)" display) True
+ where
+ rearrange = either (Just . Left) (maybe Nothing (Just . Right))
-- | Create a prompt from a list of items.
-promptList :: (Text t, Eq t)
+promptList :: Eq t
=> String -- ^ prompt
-> [t] -- ^ choices
-> Maybe t -- ^ optional default value
+ -> (t -> String) -- ^ show an item
-> Bool -- ^ whether to allow an 'other' option
-> IO (Either String t)
-promptList pr choices def other = do
+promptList pr choices def displayItem other = do
putStrLn $ pr ++ ":"
- let options1 = map (\c -> (Just c == def, display c)) choices
+ let options1 = map (\c -> (Just c == def, displayItem c)) choices
options2 = zip ([1..]::[Int])
(options1 ++ if other then [(False, "Other (specify)")]
else [])
mapM_ (putStrLn . \(n,(i,s)) -> showOption n i ++ s) options2
- promptList' (length options2) choices def other
+ promptList' displayItem (length options2) choices def other
where showOption n i | n < 10 = " " ++ star i ++ " " ++ rest
| otherwise = " " ++ star i ++ rest
where rest = show n ++ ") "
star True = "*"
star False = " "
-promptList' :: Text t => Int -> [t] -> Maybe t -> Bool -> IO (Either String t)
-promptList' numChoices choices def other = do
- putStr $ mkDefPrompt "Your choice" (display `fmap` def)
+promptList' :: (t -> String) -> Int -> [t] -> Maybe t -> Bool -> IO (Either String t)
+promptList' displayItem numChoices choices def other = do
+ putStr $ mkDefPrompt "Your choice" (displayItem `fmap` def)
inp <- getLine
case (inp, def) of
("", Just d) -> return $ Right d
@@ -315,7 +352,7 @@ promptList' numChoices choices def other = do
Nothing -> invalidChoice inp
Just n -> getChoice n
where invalidChoice inp = do putStrLn $ inp ++ " is not a valid choice."
- promptList' numChoices choices def other
+ promptList' displayItem numChoices choices def other
getChoice n | n < 1 || n > numChoices = invalidChoice (show n)
| n < numChoices ||
(n == numChoices && not other)
@@ -398,105 +435,111 @@ writeCabalFile flags@(InitFlags{packageName = Flag p}) = do
-- structure onto a low-level AST structure and use the existing
-- pretty-printing code to generate the file.
generateCabalFile :: String -> InitFlags -> String
-generateCabalFile fileName c = render $
+generateCabalFile fileName c =
+ renderStyle style { lineLength = 79, ribbonsPerLine = 1.1 } $
(if (minimal c /= Flag True)
- then showComment (Just $ fileName ++ " auto-generated by cabal init. For additional options, see http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.")
+ then showComment (Just $ "Initial " ++ fileName ++ " generated by cabal "
+ ++ "init. For further documentation, see "
+ ++ "http://haskell.org/cabal/users-guide/")
+ $$ text ""
else empty)
$$
- vcat [ fieldS "Name" (packageName c)
+ vcat [ fieldS "name" (packageName c)
(Just "The name of the package.")
True
- , field "Version" (version c)
+ , field "version" (version c)
(Just "The package version. See the Haskell package versioning policy (http://www.haskell.org/haskellwiki/Package_versioning_policy) for standards guiding when and how versions should be incremented.")
True
- , fieldS "Synopsis" (synopsis c)
+ , fieldS "synopsis" (synopsis c)
(Just "A short (one-line) description of the package.")
True
- , fieldS "Description" NoFlag
+ , fieldS "description" NoFlag
(Just "A longer description of the package.")
True
- , fieldS "Homepage" (homepage c)
+ , fieldS "homepage" (homepage c)
(Just "URL for the project homepage or repository.")
False
- , fieldS "Bug-reports" NoFlag
+ , fieldS "bug-reports" NoFlag
(Just "A URL where users can report bugs.")
False
- , field "License" (license c)
+ , field "license" (license c)
(Just "The license under which the package is released.")
True
- , fieldS "License-file" (Flag "LICENSE")
+ , fieldS "license-file" (Flag "LICENSE")
(Just "The file containing the license text.")
True
- , fieldS "Author" (author c)
+ , fieldS "author" (author c)
(Just "The package author(s).")
True
- , fieldS "Maintainer" (email c)
+ , fieldS "maintainer" (email c)
(Just "An email address to which users can send suggestions, bug reports, and patches.")
True
- , fieldS "Copyright" NoFlag
+ , fieldS "copyright" NoFlag
(Just "A copyright notice.")
True
- , fieldS "Category" (either id display `fmap` category c)
+ , fieldS "category" (either id display `fmap` category c)
Nothing
True
- , fieldS "Build-type" (Flag "Simple")
+ , fieldS "build-type" (Flag "Simple")
Nothing
True
- , fieldS "Extra-source-files" NoFlag
+ , fieldS "extra-source-files" NoFlag
(Just "Extra files to be distributed with the package, such as examples or a README.")
- True
+ False
- , field "Cabal-version" (Flag $ orLaterVersion (Version [1,2] []))
+ , field "cabal-version" (Flag $ orLaterVersion (Version [1,8] []))
(Just "Constraint on the version of Cabal needed to build this package.")
False
, case packageType c of
Flag Executable ->
- text "\nExecutable" <+> text (fromMaybe "" . flagToMaybe $ packageName c) $$ (nest 2 $ vcat
- [ fieldS "Main-is" NoFlag (Just ".hs or .lhs file containing the Main module.") True
+ text "\nexecutable" <+> text (fromMaybe "" . flagToMaybe $ packageName c) $$ (nest 2 $ vcat
+ [ fieldS "main-is" NoFlag (Just ".hs or .lhs file containing the Main module.") True
- , generateBuildInfo c
+ , generateBuildInfo Executable c
])
- Flag Library -> text "\nLibrary" $$ (nest 2 $ vcat
- [ fieldS "Exposed-modules" (listField (exposedModules c))
+ Flag Library -> text "\nlibrary" $$ (nest 2 $ vcat
+ [ fieldS "exposed-modules" (listField (exposedModules c))
(Just "Modules exported by the library.")
True
- , generateBuildInfo c
+ , generateBuildInfo Library c
])
_ -> empty
]
where
- generateBuildInfo :: InitFlags -> Doc
- generateBuildInfo c' = vcat
- [ fieldS "Build-depends" (listField (dependencies c'))
- (Just "Packages needed in order to build this package.")
+ generateBuildInfo :: PackageType -> InitFlags -> Doc
+ generateBuildInfo pkgtype c' = vcat
+ [ fieldS "other-modules" (listField (otherModules c'))
+ (Just $ case pkgtype of
+ Library -> "Modules included in this library but not exported."
+ Executable -> "Modules included in this executable, other than Main.")
True
- , fieldS "Other-modules" (listField (otherModules c'))
- (Just "Modules not exported by this package.")
+ , fieldS "build-depends" (listField (dependencies c'))
+ (Just "Other library packages from which modules are imported.")
True
, fieldS "hs-source-dirs" (listFieldS (sourceDirs c'))
- (Just "Directories other than the root containing source files.")
+ (Just "Directories containing source files.")
False
- , fieldS "Build-tools" (listFieldS (buildTools c'))
+ , fieldS "build-tools" (listFieldS (buildTools c'))
(Just "Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.")
- True
+ False
]
listField :: Text s => Maybe [s] -> Flag String
@@ -531,7 +574,11 @@ generateCabalFile fileName c = render $
showComment :: Maybe String -> Doc
showComment (Just t) = vcat . map text
. map ("-- "++) . lines
- . render . fsep . map text . words $ t
+ . renderStyle style {
+ lineLength = 76,
+ ribbonsPerLine = 1.05
+ }
+ . fsep . map text . words $ t
showComment Nothing = text ""
-- | Generate warnings for missing fields etc.
diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Init/Heuristics.hs b/cabal/cabal-install/Distribution/Client/Init/Heuristics.hs
index 19ec668..ba0cb12 100644
--- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Init/Heuristics.hs
+++ b/cabal/cabal-install/Distribution/Client/Init/Heuristics.hs
@@ -28,7 +28,7 @@ import qualified Distribution.PackageDescription as PD
import Distribution.Simple.Utils
( intercalate )
-import Distribution.Client.Types ( packageDescription, AvailablePackageDb(..) )
+import Distribution.Client.Types ( packageDescription, SourcePackageDb(..) )
import Control.Monad (liftM )
import Data.Char ( isUpper, isLower, isSpace )
#if MIN_VERSION_base(3,0,3)
@@ -134,9 +134,9 @@ guessAuthorNameMail =
authorRepoFile = "_darcs" </> "prefs" </> "author"
-- |Get list of categories used in hackage. NOTE: Very slow, needs to be cached
-knownCategories :: AvailablePackageDb -> [String]
-knownCategories (AvailablePackageDb available _) = nubSet $
- [ cat | pkg <- map head (allPackagesByName available)
+knownCategories :: SourcePackageDb -> [String]
+knownCategories (SourcePackageDb sourcePkgIndex _) = nubSet $
+ [ cat | pkg <- map head (allPackagesByName sourcePkgIndex)
, let catList = (PD.category . PD.packageDescription . packageDescription) pkg
, cat <- splitString ',' catList
]
diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Init/Licenses.hs b/cabal/cabal-install/Distribution/Client/Init/Licenses.hs
index 73bba06..7cc07c3 100644
--- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Init/Licenses.hs
+++ b/cabal/cabal-install/Distribution/Client/Init/Licenses.hs
@@ -12,7 +12,7 @@ type License = String
bsd3 :: String -> String -> License
bsd3 authors year = unlines
- [ "Copyright (c)" ++ year ++ ", " ++ authors
+ [ "Copyright (c) " ++ year ++ ", " ++ authors
, ""
, "All rights reserved."
, ""
diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Init/Types.hs b/cabal/cabal-install/Distribution/Client/Init/Types.hs
index aace727..aace727 100644
--- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Init/Types.hs
+++ b/cabal/cabal-install/Distribution/Client/Init/Types.hs
diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Install.hs b/cabal/cabal-install/Distribution/Client/Install.hs
index 3cc204e..20e8510 100644
--- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Install.hs
+++ b/cabal/cabal-install/Distribution/Client/Install.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Install
@@ -18,10 +19,9 @@ module Distribution.Client.Install (
) where
import Data.List
- ( unfoldr, find, nub, sort, partition )
+ ( unfoldr, find, nub, sort )
import Data.Maybe
( isJust, fromMaybe )
-import qualified Data.Map as Map
import Control.Exception as Exception
( handleJust )
#if MIN_VERSION_base(4,0,0)
@@ -33,7 +33,7 @@ import System.Exit
import Control.Exception as Exception
( Exception(IOException, ExitException) )
#endif
-import Distribution.Compat.Exception
+import Distribution.Compat.ExceptionCI
( SomeException, catchIO, catchExit )
import Control.Monad
( when, unless )
@@ -46,21 +46,13 @@ import System.IO
import System.IO.Error
( isDoesNotExistError, ioeGetFileName )
+import Distribution.Client.Targets
import Distribution.Client.Dependency
- ( resolveDependenciesWithProgress
- , PackageConstraint(..), dependencyConstraints, dependencyTargets
- , PackagesPreference(..), PackagesPreferenceDefault(..)
- , PackagePreference(..)
- , Progress(..), foldProgress, )
-import Distribution.Client.Fetch
- ( fetchPackage )
-import Distribution.Client.HttpUtils
- ( downloadURI )
+import Distribution.Client.FetchUtils
import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex)
-- import qualified Distribution.Client.Info as Info
import Distribution.Client.IndexUtils as IndexUtils
- ( getAvailablePackages, disambiguateDependencies
- , getInstalledPackages )
+ ( getSourcePackages, getInstalledPackages )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.InstallPlan (InstallPlan)
import Distribution.Client.Setup
@@ -70,13 +62,7 @@ import Distribution.Client.Setup
import Distribution.Client.Config
( defaultCabalDir )
import Distribution.Client.Tar (extractTarGzFile)
-import Distribution.Client.Types as Available
- ( UnresolvedDependency(..), AvailablePackage(..)
- , AvailablePackageSource(..), AvailablePackageDb(..)
- , Repo(..), ConfiguredPackage(..)
- , BuildResult, BuildFailure(..), BuildSuccess(..)
- , DocsResult(..), TestsResult(..), RemoteRepo(..)
- , InstalledPackage )
+import Distribution.Client.Types as Source
import Distribution.Client.BuildReports.Types
( ReportLevel(..) )
import Distribution.Client.SetupWrapper
@@ -104,25 +90,23 @@ import Distribution.Simple.Setup
import qualified Distribution.Simple.Setup as Cabal
( installCommand, InstallFlags(..), emptyInstallFlags )
import Distribution.Simple.Utils
- ( defaultPackageDesc, rawSystemExit, comparing )
+ ( rawSystemExit, comparing )
import Distribution.Simple.InstallDirs as InstallDirs
( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate
, initialPathTemplateEnv, installDirsTemplateEnv )
import Distribution.Package
- ( PackageName(..), PackageIdentifier, packageName, packageVersion
+ ( PackageIdentifier, packageName, packageVersion
, Package(..), PackageFixedDeps(..)
, Dependency(..), thisPackageVersion )
import qualified Distribution.PackageDescription as PackageDescription
import Distribution.PackageDescription
- ( PackageDescription )
-import Distribution.PackageDescription.Parse
- ( readPackageDescription )
+ ( PackageDescription, GenericPackageDescription(..), TestSuite(..) )
import Distribution.PackageDescription.Configuration
- ( finalizePackageDescription )
+ ( finalizePackageDescription, mapTreeData )
import Distribution.Version
- ( Version, VersionRange, anyVersion, thisVersion )
+ ( Version, anyVersion, thisVersion )
import Distribution.Simple.Utils as Utils
- ( notice, info, warn, die, intercalate, withTempDirectory )
+ ( notice, info, debug, warn, die, intercalate, withTempDirectory )
import Distribution.Client.Utils
( inDir, mergeBy, MergeResult(..) )
import Distribution.System
@@ -134,9 +118,6 @@ import Distribution.Verbosity as Verbosity
import Distribution.Simple.BuildPaths ( exeExtension )
--TODO:
--- * add --upgrade-deps flag
--- * add --only-deps flag
--- * eliminate upgrade, replaced by --upgrade-deps and world target
-- * assign flags to packages individually
-- * complain about flags that do not apply to any package given as target
-- so flags do not apply to dependencies, only listed, can use flag
@@ -152,12 +133,6 @@ import Distribution.Simple.BuildPaths ( exeExtension )
-- * Top level user actions
-- ------------------------------------------------------------
--- | An installation target given by the user. At the moment this
--- is just a named package, possibly with a version constraint.
--- It should be generalised to handle other targets like http or dirs.
---
-type InstallTarget = UnresolvedDependency
-
-- | Installs the packages needed to satisfy a list of dependencies.
--
install, upgrade
@@ -170,30 +145,44 @@ install, upgrade
-> ConfigFlags
-> ConfigExFlags
-> InstallFlags
- -> [InstallTarget]
+ -> [UserTarget]
-> IO ()
-install verbosity packageDB repos comp conf
- globalFlags configFlags configExFlags installFlags targets =
+install verbosity packageDBs repos comp conf
+ globalFlags configFlags configExFlags installFlags userTargets0 = do
+
+ installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
+ sourcePkgDb <- getSourcePackages verbosity repos
+
+ let -- For install, if no target is given it means we use the
+ -- current directory as the single target
+ userTargets | null userTargets0 = [UserTargetLocalDir "."]
+ | otherwise = userTargets0
+
+ pkgSpecifiers <- resolveUserTargets verbosity
+ (fromFlag $ globalWorldFile globalFlags)
+ (packageIndex sourcePkgDb)
+ userTargets
- installWithPlanner verbosity context planner targets
+ notice verbosity "Resolving dependencies..."
+ installPlan <- foldProgress logMsg die return $
+ planPackages
+ comp configFlags configExFlags installFlags
+ installedPkgIndex sourcePkgDb pkgSpecifiers
+
+ printPlanMessages verbosity installedPkgIndex installPlan dryRun
+
+ unless dryRun $ do
+ installPlan' <- performInstallations verbosity
+ context installedPkgIndex installPlan
+ postInstallActions verbosity context userTargets installPlan'
where
context :: InstallContext
- context = (packageDB, repos, comp, conf,
+ context = (packageDBs, repos, comp, conf,
globalFlags, configFlags, configExFlags, installFlags)
- planner :: Planner
- planner
- | null targets = planLocalPackage verbosity
- comp configFlags configExFlags
-
- | otherwise = planRepoPackages defaultPref
- comp globalFlags configFlags configExFlags
- installFlags targets
-
- defaultPref
- | fromFlag (installUpgradeDeps installFlags) = PreferAllLatest
- | otherwise = PreferLatestForSelected
+ dryRun = fromFlag (installDryRun installFlags)
+ logMsg message rest = debug verbosity message >> rest
upgrade _ _ _ _ _ _ _ _ _ _ = die $
@@ -209,11 +198,6 @@ upgrade _ _ _ _ _ _ _ _ _ _ = die $
++ "--upgrade-dependencies, it is recommended that you do not upgrade core "
++ "packages (e.g. by using appropriate --constraint= flags)."
-
-type Planner = PackageIndex InstalledPackage
- -> AvailablePackageDb
- -> IO (Progress String String InstallPlan)
-
type InstallContext = ( PackageDBStack
, [Repo]
, Compiler
@@ -223,133 +207,97 @@ type InstallContext = ( PackageDBStack
, ConfigExFlags
, InstallFlags )
--- | Top-level orchestration. Installs the packages generated by a planner.
---
-installWithPlanner :: Verbosity
- -> InstallContext
- -> Planner
- -> [UnresolvedDependency]
- -> IO ()
-installWithPlanner verbosity
- context@(packageDBs, repos, comp, conf, _, _, _, installFlags)
- planner targets = do
-
- installed <- getInstalledPackages verbosity comp packageDBs conf
- available <- getAvailablePackages verbosity repos
-
- notice verbosity "Resolving dependencies..."
- installPlan <- foldProgress logMsg die return =<< planner installed available
-
- printPlanMessages verbosity installed installPlan dryRun
-
- unless dryRun $
- performInstallations verbosity context installed installPlan
- >>= postInstallActions verbosity context targets
-
- where
- dryRun = fromFlag (installDryRun installFlags)
- logMsg message rest = info verbosity message >> rest
-
-- ------------------------------------------------------------
-- * Installation planning
-- ------------------------------------------------------------
--- | Make an 'InstallPlan' for the unpacked package in the current directory,
--- and all its dependencies.
---
-planLocalPackage :: Verbosity
- -> Compiler
- -> ConfigFlags
- -> ConfigExFlags
- -> Planner
-planLocalPackage verbosity comp configFlags configExFlags installed
- (AvailablePackageDb available 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 available
- installed' = PackageIndex.deletePackageId (packageId localPkg) installed
- localPkg = AvailablePackage {
- packageInfoId = packageId pkg,
- Available.packageDescription = pkg,
- packageSource = LocalUnpackedPackage Nothing
- }
- 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
-
-
--- | Make an 'InstallPlan' for the given dependencies.
---
-planRepoPackages :: PackagesPreferenceDefault
- -> Compiler
- -> GlobalFlags
- -> ConfigFlags
- -> ConfigExFlags
- -> InstallFlags
- -> [UnresolvedDependency]
- -> Planner
-planRepoPackages defaultPref comp
- globalFlags configFlags configExFlags installFlags
- deps installed (AvailablePackageDb available availablePrefs) = do
-
- deps' <- addWorldPackages deps
- >>= IndexUtils.disambiguateDependencies available
-
- let installed'
- | fromFlag (installReinstall installFlags)
- = hideGivenDeps deps' installed
- | otherwise = installed
- targets = dependencyTargets deps'
- constraints = dependencyConstraints deps'
- ++ [ PackageVersionConstraint name ver
- | Dependency name ver <- configConstraints configFlags ]
- preferences = mergePackagePrefs defaultPref availablePrefs configExFlags
- return $ resolveDependenciesWithProgress buildPlatform (compilerId comp)
- installed' available preferences constraints targets
- where
- hideGivenDeps pkgs index =
- foldr PackageIndex.deletePackageName index
- [ name | UnresolvedDependency (Dependency name _) _ <- pkgs ]
-
- addWorldPackages :: [UnresolvedDependency] -> IO [UnresolvedDependency]
- addWorldPackages targets = case partition World.isWorldTarget targets of
- ([], _) -> return targets
- (world, otherTargets) -> do
- unless (all World.isGoodWorldTarget world) $
- die $ "The virtual package 'world' does not take any version "
- ++ "or configuration flags."
- worldTargets <- World.getContents worldFile
- --TODO: should we warn if there are no world targets?
- return (otherTargets ++ worldTargets)
- where
- worldFile = fromFlag $ globalWorldFile globalFlags
+planPackages :: Compiler
+ -> ConfigFlags
+ -> ConfigExFlags
+ -> InstallFlags
+ -> PackageIndex InstalledPackage
+ -> SourcePackageDb
+ -> [PackageSpecifier SourcePackage]
+ -> Progress String String InstallPlan
+planPackages comp configFlags configExFlags installFlags
+ installedPkgIndex sourcePkgDb pkgSpecifiers =
+ resolveDependencies
+ buildPlatform (compilerId comp)
+ resolverParams
-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 ]
+ >>= if onlyDeps then adjustPlanOnlyDeps else return
+ where
+ resolverParams =
+
+ setPreferenceDefault (if upgradeDeps then PreferAllLatest
+ else PreferLatestForSelected)
+
+ . addPreferences
+ -- preferences from the config file or command line
+ [ PackageVersionPreference name ver
+ | Dependency name ver <- configPreferences configExFlags ]
+
+ . addConstraints
+ -- version constraints from the config file or command line
+ (map userToPackageConstraint (configExConstraints configExFlags))
+
+ . addConstraints
+ --FIXME: this just applies all flags to all targets which
+ -- is silly. We should check if the flags are appropriate
+ [ PackageConstraintFlags (pkgSpecifierTarget pkgSpecifier) flags
+ | let flags = configConfigurationsFlags configFlags
+ , not (null flags)
+ , pkgSpecifier <- pkgSpecifiers' ]
+
+ . (if reinstall then reinstallTargets else id)
+
+ $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers'
+
+ -- Mark test suites as enabled if invoked with '--enable-tests'. This
+ -- ensures that test suite dependencies are included.
+ pkgSpecifiers' = map enableTests pkgSpecifiers
+ testsEnabled = fromFlagOrDefault False $ configTests configFlags
+ enableTests (SpecificSourcePackage pkg) =
+ let pkgDescr = Source.packageDescription pkg
+ suites = condTestSuites pkgDescr
+ enable = mapTreeData (\t -> t { testEnabled = testsEnabled })
+ in SpecificSourcePackage $ pkg { Source.packageDescription = pkgDescr
+ { condTestSuites = map (\(n, t) -> (n, enable t)) suites } }
+ enableTests x = x
+
+
+ --TODO: this is a general feature and should be moved to D.C.Dependency
+ -- Also, the InstallPlan.remove should return info more precise to the
+ -- problem, rather than the very general PlanProblem type.
+ adjustPlanOnlyDeps :: InstallPlan -> Progress String String InstallPlan
+ adjustPlanOnlyDeps =
+ either (Fail . explain) Done
+ . InstallPlan.remove isTarget
+ where
+ isTarget pkg = packageName pkg `elem` targetnames
+ targetnames = map pkgSpecifierTarget pkgSpecifiers
+
+ explain :: [InstallPlan.PlanProblem] -> String
+ explain problems =
+ "Cannot select only the dependencies (as requested by the "
+ ++ "'--only-dependencies' flag), "
+ ++ (case pkgids of
+ [pkgid] -> "the package " ++ display pkgid ++ " is "
+ _ -> "the packages "
+ ++ intercalate ", " (map display pkgids) ++ " are ")
+ ++ "required by a dependency of one of the other targets."
+ where
+ pkgids =
+ nub [ depid
+ | InstallPlan.PackageMissingDeps _ depids <- problems
+ , depid <- depids
+ , packageName depid `elem` targetnames ]
+
+ reinstall = fromFlag (installReinstall installFlags)
+ upgradeDeps = fromFlag (installUpgradeDeps installFlags)
+ onlyDeps = fromFlag (installOnlyDeps installFlags)
-- ------------------------------------------------------------
-- * Informational messages
@@ -379,7 +327,7 @@ printDryRun :: Verbosity
-> PackageIndex InstalledPackage
-> InstallPlan
-> IO ()
-printDryRun verbosity installed plan = case unfoldr next plan of
+printDryRun verbosity installedPkgIndex plan = case unfoldr next plan of
[] -> return ()
pkgs
| verbosity >= Verbosity.verbose -> notice verbosity $ unlines $
@@ -398,7 +346,8 @@ printDryRun verbosity installed plan = case unfoldr next plan of
-- pretending that each package is installed
showPkgAndReason pkg' = display (packageId pkg') ++ " " ++
- case PackageIndex.lookupPackageName installed (packageName pkg') of
+ case PackageIndex.lookupPackageName installedPkgIndex
+ (packageName pkg') of
[] -> "(new package)"
ps -> case find ((==packageId pkg') . packageId) ps of
Nothing -> "(new version)"
@@ -431,7 +380,7 @@ printDryRun verbosity installed plan = case unfoldr next plan of
--
postInstallActions :: Verbosity
-> InstallContext
- -> [InstallTarget]
+ -> [UserTarget]
-> InstallPlan
-> IO ()
postInstallActions verbosity
@@ -439,7 +388,10 @@ postInstallActions verbosity
targets installPlan = do
unless oneShot $
- World.insert verbosity worldFile targets'
+ World.insert verbosity worldFile
+ --FIXME: does not handle flags
+ [ World.WorldPkgInfo dep []
+ | UserTargetNamed dep <- targets ]
let buildReports = BuildReports.fromInstallPlan installPlan
BuildReports.storeLocal (installSummaryFile installFlags) buildReports
@@ -460,7 +412,6 @@ postInstallActions verbosity
logsDir = fromFlag (globalLogsDir globalFlags)
oneShot = fromFlag (installOneShot installFlags)
worldFile = fromFlag $ globalWorldFile globalFlags
- targets' = filter (not . World.isWorldTarget) targets
storeDetailedBuildReports :: Verbosity -> FilePath
-> [(BuildReports.BuildReport, Repo)] -> IO ()
@@ -522,8 +473,8 @@ regenerateHaddockIndex verbosity packageDBs comp conf
"Updating documentation index " ++ indexFile
--TODO: might be nice if the install plan gave us the new InstalledPackageInfo
- installed <- getInstalledPackages verbosity comp packageDBs conf
- Haddock.regenerateHaddockIndex verbosity installed conf indexFile
+ installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
+ Haddock.regenerateHaddockIndex verbosity installedPkgIndex conf indexFile
| otherwise = return ()
where
@@ -627,15 +578,17 @@ performInstallations :: Verbosity
performInstallations verbosity
(packageDBs, _, comp, conf,
globalFlags, configFlags, configExFlags, installFlags)
- installed installPlan = do
+ installedPkgIndex installPlan = do
executeInstallPlan installPlan $ \cpkg ->
installConfiguredPackage platform compid configFlags
cpkg $ \configFlags' src pkg ->
- installAvailablePackage verbosity (packageId pkg) src $ \mpath ->
- installUnpackedPackage verbosity (setupScriptOptions installed)
- miscOptions configFlags' installFlags
- compid pkg mpath useLogFile
+ fetchSourcePackage verbosity src $ \src' ->
+ installLocalPackage verbosity (packageId pkg) src' $ \mpath ->
+ installUnpackedPackage verbosity
+ (setupScriptOptions installedPkgIndex)
+ miscOptions configFlags' installFlags
+ compid pkg mpath useLogFile
where
platform = InstallPlan.planPlatform installPlan
@@ -709,7 +662,7 @@ executeInstallPlan plan installPkg = case InstallPlan.ready plan of
-- which kind of means it was not their fault.
--- | Call an installer for an 'AvailablePackage' but override the configure
+-- | Call an installer for an 'SourcePackage' 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
@@ -717,11 +670,11 @@ executeInstallPlan plan installPkg = case InstallPlan.ready plan of
--
installConfiguredPackage :: Platform -> CompilerId
-> ConfigFlags -> ConfiguredPackage
- -> (ConfigFlags -> AvailablePackageSource
+ -> (ConfigFlags -> PackageLocation (Maybe FilePath)
-> PackageDescription -> a)
-> a
installConfiguredPackage platform comp configFlags
- (ConfiguredPackage (AvailablePackage _ gpkg source) flags deps)
+ (ConfiguredPackage (SourcePackage _ gpkg source) flags deps)
installPkg = installPkg configFlags {
configConfigurationsFlags = flags,
configConstraints = map thisPackageVersion deps
@@ -733,59 +686,57 @@ installConfiguredPackage platform comp configFlags
Left _ -> error "finalizePackageDescription ConfiguredPackage failed"
Right (desc, _) -> desc
+fetchSourcePackage
+ :: Verbosity
+ -> PackageLocation (Maybe FilePath)
+ -> (PackageLocation FilePath -> IO BuildResult)
+ -> IO BuildResult
+fetchSourcePackage verbosity src installPkg = do
+ fetched <- checkFetched src
+ case fetched of
+ Just src' -> installPkg src'
+ Nothing -> onFailure DownloadFailed $
+ fetchPackage verbosity src >>= installPkg
+
-installAvailablePackage
- :: Verbosity -> PackageIdentifier -> AvailablePackageSource
+installLocalPackage
+ :: Verbosity -> PackageIdentifier -> PackageLocation FilePath
-> (Maybe FilePath -> IO BuildResult)
-> IO BuildResult
-installAvailablePackage _ _ (LocalUnpackedPackage dir) installPkg =
- installPkg dir
+installLocalPackage verbosity pkgid location installPkg = case location of
-installAvailablePackage verbosity pkgid
- (LocalTarballPackage tarballPath) installPkg = do
- tmp <- getTemporaryDirectory
- withTempDirectory verbosity tmp (display pkgid) $ \tmpDirPath ->
- installLocalTarballPackage verbosity pkgid
- tarballPath tmpDirPath installPkg
+ LocalUnpackedPackage dir ->
+ installPkg (Just dir)
+
+ LocalTarballPackage tarballPath ->
+ installLocalTarballPackage verbosity pkgid tarballPath installPkg
+
+ RemoteTarballPackage _ tarballPath ->
+ installLocalTarballPackage verbosity pkgid tarballPath installPkg
+
+ RepoTarballPackage _ _ tarballPath ->
+ installLocalTarballPackage verbosity pkgid tarballPath installPkg
-installAvailablePackage verbosity pkgid
- (RemoteTarballPackage tarballURL) installPkg = do
- tmp <- getTemporaryDirectory
- withTempDirectory verbosity tmp (display pkgid) $ \tmpDirPath ->
- onFailure DownloadFailed $ do
- let tarballPath = tmpDirPath </> display pkgid <.> "tar.gz"
- --TODO: perhaps we've already had to download this to a local cache
- -- so we even know what package version it is. So might be able
- -- to get it from the local cache rather than from remote.
- downloadURI verbosity tarballURL tarballPath
- installLocalTarballPackage verbosity pkgid
- tarballPath tmpDirPath installPkg
-
-installAvailablePackage verbosity pkgid (RepoTarballPackage repo) installPkg =
- onFailure DownloadFailed $ do
- tarballPath <- fetchPackage verbosity repo pkgid
- tmp <- getTemporaryDirectory
- withTempDirectory verbosity tmp (display pkgid) $ \tmpDirPath ->
- installLocalTarballPackage verbosity pkgid
- tarballPath tmpDirPath installPkg
installLocalTarballPackage
- :: Verbosity -> PackageIdentifier -> FilePath -> FilePath
+ :: Verbosity -> PackageIdentifier -> FilePath
-> (Maybe FilePath -> IO BuildResult)
-> IO BuildResult
-installLocalTarballPackage verbosity pkgid tarballPath tmpDirPath installPkg =
- onFailure UnpackFailed $ do
- info verbosity $ "Extracting " ++ tarballPath
- ++ " to " ++ tmpDirPath ++ "..."
- let relUnpackedPath = display pkgid
- absUnpackedPath = tmpDirPath </> relUnpackedPath
- descFilePath = absUnpackedPath
- </> display (packageName pkgid) <.> "cabal"
- extractTarGzFile tmpDirPath relUnpackedPath tarballPath
- exists <- doesFileExist descFilePath
- when (not exists) $
- die $ "Package .cabal file not found: " ++ show descFilePath
- installPkg (Just absUnpackedPath)
+installLocalTarballPackage verbosity pkgid tarballPath installPkg = do
+ tmp <- getTemporaryDirectory
+ withTempDirectory verbosity tmp (display pkgid) $ \tmpDirPath ->
+ onFailure UnpackFailed $ do
+ info verbosity $ "Extracting " ++ tarballPath
+ ++ " to " ++ tmpDirPath ++ "..."
+ let relUnpackedPath = display pkgid
+ absUnpackedPath = tmpDirPath </> relUnpackedPath
+ descFilePath = absUnpackedPath
+ </> display (packageName pkgid) <.> "cabal"
+ extractTarGzFile tmpDirPath relUnpackedPath tarballPath
+ exists <- doesFileExist descFilePath
+ when (not exists) $
+ die $ "Package .cabal file not found: " ++ show descFilePath
+ installPkg (Just absUnpackedPath)
installUnpackedPackage :: Verbosity
diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/InstallPlan.hs b/cabal/cabal-install/Distribution/Client/InstallPlan.hs
index 71fa6a9..157c140 100644
--- a/cabal-install-0.9.5_rc20101226/Distribution/Client/InstallPlan.hs
+++ b/cabal/cabal-install/Distribution/Client/InstallPlan.hs
@@ -4,7 +4,7 @@
-- Copyright : (c) Duncan Coutts 2008
-- License : BSD-like
--
--- Maintainer : duncan@haskell.org
+-- Maintainer : duncan@community.haskell.org
-- Stability : provisional
-- Portability : portable
--
@@ -22,6 +22,7 @@ module Distribution.Client.InstallPlan (
ready,
completed,
failed,
+ remove,
-- ** Query functions
planPlatform,
@@ -44,7 +45,7 @@ module Distribution.Client.InstallPlan (
) where
import Distribution.Client.Types
- ( AvailablePackage(packageDescription), ConfiguredPackage(..)
+ ( SourcePackage(packageDescription), ConfiguredPackage(..)
, InstalledPackage
, BuildFailure, BuildSuccess )
import Distribution.Package
@@ -87,32 +88,32 @@ import Control.Exception
--
-- The Problem:
--
--- In general we start with a set of installed packages and a set of available
+-- In general we start with a set of installed packages and a set of source
-- packages.
--
-- Installed packages have fixed dependencies. They have already been built and
-- we know exactly what packages they were built against, including their exact
-- versions.
--
--- Available package have somewhat flexible dependencies. They are specified as
+-- Source package have somewhat flexible dependencies. They are specified as
-- version ranges, though really they're predicates. To make matters worse they
-- have conditional flexible dependencies. Configuration flags can affect which
-- packages are required and can place additional constraints on their
-- versions.
--
-- These two sets of package can and usually do overlap. There can be installed
--- packages that are also available which means they could be re-installed if
--- required, though there will also be packages which are not available and
--- cannot be re-installed. Very often there will be extra versions available
--- than are installed. Sometimes we may like to prefer installed packages over
--- available ones or perhaps always prefer the latest available version whether
--- installed or not.
+-- packages that are also available as source packages which means they could
+-- be re-installed if required, though there will also be packages which are
+-- not available as source and cannot be re-installed. Very often there will be
+-- extra versions available than are installed. Sometimes we may like to prefer
+-- installed packages over source ones or perhaps always prefer the latest
+-- available version whether installed or not.
--
-- The goal is to calculate an installation plan that is closed, acyclic and
-- consistent and where every configured package is valid.
--
-- An installation plan is a set of packages that are going to be used
--- together. It will consist of a mixture of installed packages and available
+-- together. It will consist of a mixture of installed packages and source
-- packages along with their exact version dependencies. An installation plan
-- is closed if for every package in the set, all of its dependencies are
-- also in the set. It is consistent if for every package in the set, all
@@ -181,6 +182,21 @@ new platform compiler index =
toList :: InstallPlan -> [PlanPackage]
toList = PackageIndex.allPackages . planIndex
+-- | Remove packages from the install plan. This will result in an
+-- error if there are remaining packages that depend on any matching
+-- package. This is primarily useful for obtaining an install plan for
+-- the dependencies of a package or set of packages without actually
+-- installing the package itself, as when doing development.
+--
+remove :: (PlanPackage -> Bool)
+ -> InstallPlan
+ -> Either [PlanProblem] InstallPlan
+remove shouldRemove plan =
+ new (planPlatform plan) (planCompiler plan) newIndex
+ where
+ newIndex = PackageIndex.fromList $
+ filter (not . shouldRemove) (toList plan)
+
-- | The packages that are ready to be installed. That is they are in the
-- configured state and have all their dependencies installed already.
-- The plan is complete if the result is @[]@.
diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/InstallSymlink.hs b/cabal/cabal-install/Distribution/Client/InstallSymlink.hs
index 8b6a375..635f2be 100644
--- a/cabal-install-0.9.5_rc20101226/Distribution/Client/InstallSymlink.hs
+++ b/cabal/cabal-install/Distribution/Client/InstallSymlink.hs
@@ -40,7 +40,7 @@ symlinkBinary _ _ _ _ = fail "Symlinking feature not available on Windows"
#else
import Distribution.Client.Types
- ( AvailablePackage(..), ConfiguredPackage(..) )
+ ( SourcePackage(..), ConfiguredPackage(..) )
import Distribution.Client.Setup
( InstallFlags(installSymlinkBinDir) )
import qualified Distribution.Client.InstallPlan as InstallPlan
@@ -132,7 +132,7 @@ symlinkBinaries configFlags installFlags plan =
, PackageDescription.buildable (PackageDescription.buildInfo exe) ]
pkgDescription :: ConfiguredPackage -> PackageDescription
- pkgDescription (ConfiguredPackage (AvailablePackage _ pkg _) flags _) =
+ pkgDescription (ConfiguredPackage (SourcePackage _ pkg _) flags _) =
case finalizePackageDescription flags
(const True)
platform compilerId [] pkg of
diff --git a/cabal/cabal-install/Distribution/Client/List.hs b/cabal/cabal-install/Distribution/Client/List.hs
new file mode 100644
index 0000000..d0dbcec
--- /dev/null
+++ b/cabal/cabal-install/Distribution/Client/List.hs
@@ -0,0 +1,530 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Client.List
+-- Copyright : (c) David Himmelstrup 2005
+-- Duncan Coutts 2008-2011
+-- License : BSD-like
+--
+-- Maintainer : cabal-devel@haskell.org
+--
+-- Search for and print information about packages
+-----------------------------------------------------------------------------
+module Distribution.Client.List (
+ list, info
+ ) where
+
+import Distribution.Package
+ ( PackageName(..), Package(..), packageName, packageVersion
+ , Dependency(..), thisPackageVersion, depends, simplifyDependency )
+import Distribution.ModuleName (ModuleName)
+import Distribution.License (License)
+import qualified Distribution.InstalledPackageInfo as Installed
+import qualified Distribution.PackageDescription as Source
+import Distribution.PackageDescription
+ ( Flag(..), FlagName(..) )
+import Distribution.PackageDescription.Configuration
+ ( flattenPackageDescription )
+
+import Distribution.Simple.Compiler
+ ( Compiler, PackageDBStack )
+import Distribution.Simple.Program (ProgramConfiguration)
+import Distribution.Simple.Utils
+ ( equating, comparing, die, notice )
+import Distribution.Simple.Setup (fromFlag)
+import qualified Distribution.Client.PackageIndex as PackageIndex
+import Distribution.Version
+ ( Version(..), VersionRange, withinRange, anyVersion
+ , intersectVersionRanges, simplifyVersionRange )
+import Distribution.Verbosity (Verbosity)
+import Distribution.Text
+ ( Text(disp), display )
+
+import Distribution.Client.Types
+ ( SourcePackage(..), Repo, SourcePackageDb(..)
+ , InstalledPackage(..) )
+import Distribution.Client.Dependency.Types
+ ( PackageConstraint(..) )
+import Distribution.Client.Targets
+ ( UserTarget, resolveUserTargets, PackageSpecifier(..) )
+import Distribution.Client.Setup
+ ( GlobalFlags(..), ListFlags(..), InfoFlags(..) )
+import Distribution.Client.Utils
+ ( mergeBy, MergeResult(..) )
+import Distribution.Client.IndexUtils as IndexUtils
+ ( getSourcePackages, getInstalledPackages )
+import Distribution.Client.FetchUtils
+ ( isFetched )
+
+import Data.List
+ ( sortBy, groupBy, sort, nub, intersperse, maximumBy, partition )
+import Data.Maybe
+ ( listToMaybe, fromJust, fromMaybe, isJust )
+import qualified Data.Map as Map
+import Data.Tree as Tree
+import Control.Monad
+ ( MonadPlus(mplus), join )
+import Control.Exception
+ ( assert )
+import Text.PrettyPrint.HughesPJ as Disp
+import System.Directory
+ ( doesDirectoryExist )
+
+
+-- |Show information about packages
+list :: Verbosity
+ -> PackageDBStack
+ -> [Repo]
+ -> Compiler
+ -> ProgramConfiguration
+ -> ListFlags
+ -> [String]
+ -> IO ()
+list verbosity packageDBs repos comp conf listFlags pats = do
+
+ installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
+ sourcePkgDb <- getSourcePackages verbosity repos
+ let sourcePkgIndex = packageIndex sourcePkgDb
+ prefs name = fromMaybe anyVersion
+ (Map.lookup name (packagePreferences sourcePkgDb))
+
+ pkgsInfo :: [(PackageName, [InstalledPackage], [SourcePackage])]
+ pkgsInfo
+ -- gather info for all packages
+ | null pats = mergePackages (PackageIndex.allPackages installedPkgIndex)
+ (PackageIndex.allPackages sourcePkgIndex)
+
+ -- gather info for packages matching search term
+ | otherwise = mergePackages (matchingPackages installedPkgIndex)
+ (matchingPackages sourcePkgIndex)
+
+ matches :: [PackageDisplayInfo]
+ matches = [ mergePackageInfo pref
+ installedPkgs sourcePkgs selectedPkg False
+ | (pkgname, installedPkgs, sourcePkgs) <- pkgsInfo
+ , not onlyInstalled || not (null installedPkgs)
+ , let pref = prefs pkgname
+ selectedPkg = latestWithPref pref sourcePkgs ]
+
+ if simpleOutput
+ then putStr $ unlines
+ [ display (pkgName pkg) ++ " " ++ display version
+ | pkg <- matches
+ , version <- if onlyInstalled
+ then installedVersions pkg
+ else nub . sort $ installedVersions pkg
+ ++ sourceVersions pkg ]
+ -- Note: this only works because for 'list', one cannot currently
+ -- specify any version constraints, so listing all installed
+ -- and source ones works.
+ else
+ if null matches
+ then notice verbosity "No matches found."
+ else putStr $ unlines (map showPackageSummaryInfo matches)
+ where
+ onlyInstalled = fromFlag (listInstalled listFlags)
+ simpleOutput = fromFlag (listSimpleOutput listFlags)
+
+ matchingPackages index =
+ [ pkg
+ | pat <- pats
+ , (_, pkgs) <- PackageIndex.searchByNameSubstring index pat
+ , pkg <- pkgs ]
+
+info :: Verbosity
+ -> PackageDBStack
+ -> [Repo]
+ -> Compiler
+ -> ProgramConfiguration
+ -> GlobalFlags
+ -> InfoFlags
+ -> [UserTarget]
+ -> IO ()
+info verbosity packageDBs repos comp conf
+ globalFlags _listFlags userTargets = do
+
+ installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
+ sourcePkgDb <- getSourcePackages verbosity repos
+ let sourcePkgIndex = packageIndex sourcePkgDb
+ prefs name = fromMaybe anyVersion
+ (Map.lookup name (packagePreferences sourcePkgDb))
+
+ -- Users may specify names of packages that are only installed, not
+ -- just available source packages, so we must resolve targets using
+ -- the combination of installed and source packages.
+ let sourcePkgs' = PackageIndex.fromList
+ $ map packageId (PackageIndex.allPackages installedPkgIndex)
+ ++ map packageId (PackageIndex.allPackages sourcePkgIndex)
+ pkgSpecifiers <- resolveUserTargets verbosity
+ (fromFlag $ globalWorldFile globalFlags)
+ sourcePkgs' userTargets
+
+ pkgsinfo <- sequence
+ [ do pkginfo <- either die return $
+ gatherPkgInfo prefs
+ installedPkgIndex sourcePkgIndex
+ pkgSpecifier
+ updateFileSystemPackageDetails pkginfo
+ | pkgSpecifier <- pkgSpecifiers ]
+
+ putStr $ unlines (map showPackageDetailedInfo pkgsinfo)
+
+ where
+ gatherPkgInfo prefs installedPkgIndex sourcePkgIndex (NamedPackage name constraints)
+ | null (selectedInstalledPkgs) && null (selectedSourcePkgs)
+ = Left $ "There is no available version of " ++ display name
+ ++ " that satisfies "
+ ++ display (simplifyVersionRange verConstraint)
+
+ | otherwise
+ = Right $ mergePackageInfo pref installedPkgs
+ sourcePkgs selectedSourcePkg
+ showPkgVersion
+ where
+ pref = prefs name
+ installedPkgs = PackageIndex.lookupPackageName installedPkgIndex name
+ sourcePkgs = PackageIndex.lookupPackageName sourcePkgIndex name
+
+ selectedInstalledPkgs = PackageIndex.lookupDependency installedPkgIndex
+ (Dependency name verConstraint)
+ selectedSourcePkgs = PackageIndex.lookupDependency sourcePkgIndex
+ (Dependency name verConstraint)
+ selectedSourcePkg = latestWithPref pref selectedSourcePkgs
+
+ -- display a specific package version if the user
+ -- supplied a non-trivial version constraint
+ showPkgVersion = not (null verConstraints)
+ verConstraint = foldr intersectVersionRanges anyVersion verConstraints
+ verConstraints = [ vr | PackageConstraintVersion _ vr <- constraints ]
+
+ gatherPkgInfo prefs installedPkgIndex sourcePkgIndex (SpecificSourcePackage pkg) =
+ Right $ mergePackageInfo pref installedPkgs sourcePkgs
+ selectedPkg True
+ where
+ name = packageName pkg
+ pref = prefs name
+ installedPkgs = PackageIndex.lookupPackageName installedPkgIndex name
+ sourcePkgs = PackageIndex.lookupPackageName sourcePkgIndex name
+ selectedPkg = Just pkg
+
+
+-- | 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 {
+ pkgName :: PackageName,
+ selectedVersion :: Maybe Version,
+ selectedSourcePkg :: Maybe SourcePackage,
+ installedVersions :: [Version],
+ sourceVersions :: [Version],
+ preferredVersions :: VersionRange,
+ homepage :: String,
+ bugReports :: String,
+ sourceRepo :: String,
+ synopsis :: String,
+ description :: String,
+ category :: String,
+ license :: License,
+ author :: String,
+ maintainer :: String,
+ dependencies :: [Dependency],
+ flags :: [Flag],
+ hasLib :: Bool,
+ hasExe :: Bool,
+ executables :: [String],
+ modules :: [ModuleName],
+ haddockHtml :: FilePath,
+ haveTarball :: Bool
+ }
+
+showPackageSummaryInfo :: PackageDisplayInfo -> String
+showPackageSummaryInfo pkginfo =
+ renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $
+ char '*' <+> disp (pkgName pkginfo)
+ $+$
+ (nest 4 $ vcat [
+ maybeShow (synopsis pkginfo) "Synopsis:" reflowParagraphs
+ , text "Default available version:" <+>
+ case selectedSourcePkg pkginfo of
+ Nothing -> text "[ Not available from any configured repository ]"
+ Just pkg -> disp (packageVersion pkg)
+ , text "Installed versions:" <+>
+ case installedVersions pkginfo of
+ [] | hasLib pkginfo -> text "[ Not installed ]"
+ | otherwise -> text "[ Unknown ]"
+ versions -> dispTopVersions 4
+ (preferredVersions pkginfo) versions
+ , maybeShow (homepage pkginfo) "Homepage:" text
+ , text "License: " <+> text (display (license pkginfo))
+ ])
+ $+$ text ""
+ where
+ maybeShow [] _ _ = empty
+ maybeShow l s f = text s <+> (f l)
+
+showPackageDetailedInfo :: PackageDisplayInfo -> String
+showPackageDetailedInfo pkginfo =
+ renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $
+ char '*' <+> disp (pkgName pkginfo)
+ <> maybe empty (\v -> char '-' <> disp v) (selectedVersion pkginfo)
+ <+> text (replicate (16 - length (display (pkgName pkginfo))) ' ')
+ <> parens pkgkind
+ $+$
+ (nest 4 $ vcat [
+ entry "Synopsis" synopsis hideIfNull reflowParagraphs
+ , entry "Versions available" sourceVersions
+ (altText null "[ Not available from server ]")
+ (dispTopVersions 9 (preferredVersions pkginfo))
+ , entry "Versions installed" installedVersions
+ (altText null (if hasLib pkginfo then "[ Not installed ]"
+ else "[ Unknown ]"))
+ (dispTopVersions 4 (preferredVersions pkginfo))
+ , entry "Homepage" homepage orNotSpecified text
+ , entry "Bug reports" bugReports orNotSpecified text
+ , entry "Description" description hideIfNull reflowParagraphs
+ , entry "Category" category hideIfNull text
+ , entry "License" license alwaysShow disp
+ , entry "Author" author hideIfNull reflowLines
+ , entry "Maintainer" maintainer hideIfNull reflowLines
+ , entry "Source repo" sourceRepo orNotSpecified text
+ , entry "Executables" executables hideIfNull (commaSep text)
+ , entry "Flags" flags hideIfNull (commaSep dispFlag)
+ , entry "Dependencies" dependencies hideIfNull (commaSep disp)
+ , entry "Documentation" haddockHtml showIfInstalled text
+ , entry "Cached" haveTarball alwaysShow dispYesNo
+ , if not (hasLib pkginfo) then empty else
+ text "Modules:" $+$ nest 4 (vcat (map disp . sort . modules $ pkginfo))
+ ])
+ $+$ text ""
+ where
+ entry fname field cond format = case cond (field pkginfo) of
+ Nothing -> label <+> format (field pkginfo)
+ Just Nothing -> empty
+ Just (Just other) -> label <+> text other
+ where
+ label = text fname <> char ':' <> padding
+ padding = text (replicate (13 - length fname ) ' ')
+
+ normal = Nothing
+ hide = Just Nothing
+ replace msg = Just (Just msg)
+
+ alwaysShow = const normal
+ hideIfNull v = if null v then hide else normal
+ showIfInstalled v
+ | not isInstalled = hide
+ | null v = replace "[ Not installed ]"
+ | otherwise = normal
+ altText nul msg v = if nul v then replace msg else normal
+ orNotSpecified = altText null "[ Not specified ]"
+
+ commaSep f = Disp.fsep . Disp.punctuate (Disp.char ',') . map f
+ dispFlag f = case flagName f of FlagName n -> text n
+ dispYesNo True = text "Yes"
+ dispYesNo False = text "No"
+
+ isInstalled = not (null (installedVersions pkginfo))
+ hasExes = length (executables pkginfo) >= 2
+ --TODO: exclude non-buildable exes
+ pkgkind | hasLib pkginfo && hasExes = text "programs and library"
+ | hasLib pkginfo && hasExe pkginfo = text "program and library"
+ | hasLib pkginfo = text "library"
+ | hasExes = text "programs"
+ | hasExe pkginfo = text "program"
+ | otherwise = empty
+
+
+reflowParagraphs :: String -> Doc
+reflowParagraphs =
+ vcat
+ . intersperse (text "") -- re-insert blank lines
+ . map (fsep . map text . concatMap words) -- reflow paragraphs
+ . filter (/= [""])
+ . groupBy (\x y -> "" `notElem` [x,y]) -- break on blank lines
+ . lines
+
+reflowLines :: String -> Doc
+reflowLines = vcat . map text . 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 :: VersionRange
+ -> [InstalledPackage]
+ -> [SourcePackage]
+ -> Maybe SourcePackage
+ -> Bool
+ -> PackageDisplayInfo
+mergePackageInfo versionPref installedPkgs sourcePkgs selectedPkg showVer =
+ assert (length installedPkgs + length sourcePkgs > 0) $
+ PackageDisplayInfo {
+ pkgName = combine packageName source
+ packageName installed,
+ selectedVersion = if showVer then fmap packageVersion selectedPkg
+ else Nothing,
+ selectedSourcePkg = sourceSelected,
+ installedVersions = map packageVersion installedPkgs,
+ sourceVersions = map packageVersion sourcePkgs,
+ preferredVersions = versionPref,
+
+ license = combine Source.license source
+ Installed.license installed,
+ maintainer = combine Source.maintainer source
+ Installed.maintainer installed,
+ author = combine Source.author source
+ Installed.author installed,
+ homepage = combine Source.homepage source
+ Installed.homepage installed,
+ bugReports = maybe "" Source.bugReports source,
+ sourceRepo = fromMaybe "" . join
+ . fmap (uncons Nothing Source.repoLocation
+ . sortBy (comparing Source.repoKind)
+ . Source.sourceRepos)
+ $ source,
+ --TODO: installed package info is missing synopsis
+ synopsis = maybe "" Source.synopsis source,
+ description = combine Source.description source
+ Installed.description installed,
+ category = combine Source.category source
+ Installed.category installed,
+ flags = maybe [] Source.genPackageFlags sourceGeneric,
+ hasLib = isJust installed
+ || fromMaybe False
+ (fmap (isJust . Source.condLibrary) sourceGeneric),
+ hasExe = fromMaybe False
+ (fmap (not . null . Source.condExecutables) sourceGeneric),
+ executables = map fst (maybe [] Source.condExecutables sourceGeneric),
+ modules = combine Installed.exposedModules installed
+ (maybe [] Source.exposedModules
+ . Source.library) source,
+ dependencies = map simplifyDependency
+ $ combine Source.buildDepends source
+ (map thisPackageVersion . depends) installed',
+ haddockHtml = fromMaybe "" . join
+ . fmap (listToMaybe . Installed.haddockHTMLs)
+ $ installed,
+ haveTarball = False
+ }
+ where
+ combine f x g y = fromJust (fmap f x `mplus` fmap g y)
+ installed' = latestWithPref versionPref installedPkgs
+ installed = fmap (\(InstalledPackage p _) -> p) installed'
+
+ sourceSelected
+ | isJust selectedPkg = selectedPkg
+ | otherwise = latestWithPref versionPref sourcePkgs
+ sourceGeneric = fmap packageDescription sourceSelected
+ source = fmap flattenPackageDescription sourceGeneric
+
+ uncons :: b -> (a -> b) -> [a] -> b
+ uncons z _ [] = z
+ uncons _ f (x:_) = f x
+
+
+-- | Not all the info is pure. We have to check if the docs really are
+-- installed, because the registered package info lies. Similarly we have to
+-- check if the tarball has indeed been fetched.
+--
+updateFileSystemPackageDetails :: PackageDisplayInfo -> IO PackageDisplayInfo
+updateFileSystemPackageDetails pkginfo = do
+ fetched <- maybe (return False) (isFetched . packageSource)
+ (selectedSourcePkg pkginfo)
+ docsExist <- doesDirectoryExist (haddockHtml pkginfo)
+ return pkginfo {
+ haveTarball = fetched,
+ haddockHtml = if docsExist then haddockHtml pkginfo else ""
+ }
+
+latestWithPref :: Package pkg => VersionRange -> [pkg] -> Maybe pkg
+latestWithPref _ [] = Nothing
+latestWithPref pref pkgs = Just (maximumBy (comparing prefThenVersion) pkgs)
+ where
+ prefThenVersion pkg = let ver = packageVersion pkg
+ in (withinRange ver pref, ver)
+
+
+-- | Rearrange installed and source packages into groups referring to the
+-- same package by name. In the result pairs, the lists are guaranteed to not
+-- both be empty.
+--
+mergePackages :: [InstalledPackage]
+ -> [SourcePackage]
+ -> [( PackageName
+ , [InstalledPackage]
+ , [SourcePackage] )]
+mergePackages installedPkgs sourcePkgs =
+ map collect
+ $ mergeBy (\i a -> fst i `compare` fst a)
+ (groupOn packageName installedPkgs)
+ (groupOn packageName sourcePkgs)
+ where
+ collect (OnlyInLeft (name,is) ) = (name, is, [])
+ collect ( InBoth (_,is) (name,as)) = (name, is, as)
+ collect (OnlyInRight (name,as)) = (name, [], as)
+
+groupOn :: Ord key => (a -> key) -> [a] -> [(key,[a])]
+groupOn key = map (\xs -> (key (head xs), xs))
+ . groupBy (equating key)
+ . sortBy (comparing key)
+
+dispTopVersions :: Int -> VersionRange -> [Version] -> Doc
+dispTopVersions n pref vs =
+ (Disp.fsep . Disp.punctuate (Disp.char ',')
+ . map (\ver -> if ispref ver then disp ver else parens (disp ver))
+ . sort . take n . interestingVersions ispref
+ $ vs)
+ <+> trailingMessage
+
+ where
+ ispref ver = withinRange ver pref
+ extra = length vs - n
+ trailingMessage
+ | extra <= 0 = Disp.empty
+ | otherwise = Disp.parens $ Disp.text "and"
+ <+> Disp.int (length vs - n)
+ <+> if extra == 1 then Disp.text "other"
+ else Disp.text "others"
+
+-- | Reorder a bunch of versions to put the most interesting / significant
+-- versions first. A preferred version range is taken into account.
+--
+-- This may be used in a user interface to select a small number of versions
+-- to present to the user, e.g.
+--
+-- > let selectVersions = sort . take 5 . interestingVersions pref
+--
+interestingVersions :: (Version -> Bool) -> [Version] -> [Version]
+interestingVersions pref =
+ map ((\ns -> Version ns []) . fst) . filter snd
+ . concat . Tree.levels
+ . swizzleTree
+ . reorderTree (\(Node (v,_) _) -> pref (Version v []))
+ . reverseTree
+ . mkTree
+ . map versionBranch
+
+ where
+ swizzleTree = unfoldTree (spine [])
+ where
+ spine ts' (Node x []) = (x, ts')
+ spine ts' (Node x (t:ts)) = spine (Node x ts:ts') t
+
+ reorderTree _ (Node x []) = Node x []
+ reorderTree p (Node x ts) = Node x (ts' ++ ts'')
+ where
+ (ts',ts'') = partition p (map (reorderTree p) ts)
+
+ reverseTree (Node x cs) = Node x (reverse (map reverseTree cs))
+
+ mkTree xs = unfoldTree step (False, [], xs)
+ where
+ step (node,ns,vs) =
+ ( (reverse ns, node)
+ , [ (any null vs', n:ns, filter (not . null) vs')
+ | (n, vs') <- groups vs ]
+ )
+ groups = map (\g -> (head (head g), map tail g))
+ . groupBy (equating head)
diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/PackageIndex.hs b/cabal/cabal-install/Distribution/Client/PackageIndex.hs
index 2f336f5..59b8b00 100644
--- a/cabal-install-0.9.5_rc20101226/Distribution/Client/PackageIndex.hs
+++ b/cabal/cabal-install/Distribution/Client/PackageIndex.hs
@@ -27,6 +27,8 @@ module Distribution.Client.PackageIndex (
-- * Queries
-- ** Precise lookups
+ elemByPackageId,
+ elemByPackageName,
lookupPackageName,
lookupPackageId,
lookupDependency,
@@ -59,9 +61,9 @@ import qualified Data.Tree as Tree
import qualified Data.Graph as Graph
import qualified Data.Array as Array
import Data.Array ((!))
-import Data.List (groupBy, sortBy, nub, find, isInfixOf)
+import Data.List (groupBy, sortBy, nub, isInfixOf)
import Data.Monoid (Monoid(..))
-import Data.Maybe (isNothing, fromMaybe)
+import Data.Maybe (isJust, isNothing, fromMaybe)
import Distribution.Package
( PackageName(..), PackageIdentifier(..)
@@ -236,6 +238,13 @@ allPackagesByName (PackageIndex m) = Map.elems m
-- * Lookups
--
+elemByPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Bool
+elemByPackageId index = isJust . lookupPackageId index
+
+elemByPackageName :: Package pkg => PackageIndex pkg -> PackageName -> Bool
+elemByPackageName index = not . null . lookupPackageName index
+
+
-- | Does a lookup by package id (name & version).
--
-- Since multiple package DBs mask each other case-sensitively by package name,
@@ -283,16 +292,14 @@ lookupDependency index (Dependency name versionRange) =
-- packages. The list of ambiguous results is split by exact package name. So
-- it is a non-empty list of non-empty lists.
--
-searchByName :: Package pkg => PackageIndex pkg -> String -> SearchResult [pkg]
+searchByName :: Package pkg => PackageIndex pkg
+ -> String -> [(PackageName, [pkg])]
searchByName (PackageIndex m) name =
- case [ pkgs | pkgs@(PackageName name',_) <- Map.toList m
- , lowercase name' == lname ] of
- [] -> None
- [(_,pkgs)] -> Unambiguous pkgs
- pkgss -> case find ((PackageName name==) . fst) pkgss of
- Just (_,pkgs) -> Unambiguous pkgs
- Nothing -> Ambiguous (map snd pkgss)
- where lname = lowercase name
+ [ pkgs
+ | pkgs@(PackageName name',_) <- Map.toList m
+ , lowercase name' == lname ]
+ where
+ lname = lowercase name
data SearchResult a = None | Unambiguous a | Ambiguous [a]
@@ -300,13 +307,14 @@ data SearchResult a = None | Unambiguous a | Ambiguous [a]
--
-- That is, all packages that contain the given string in their name.
--
-searchByNameSubstring :: Package pkg => PackageIndex pkg -> String -> [pkg]
+searchByNameSubstring :: Package pkg => PackageIndex pkg
+ -> String -> [(PackageName, [pkg])]
searchByNameSubstring (PackageIndex m) searchterm =
- [ pkg
- | (PackageName name, pkgs) <- Map.toList m
- , lsearchterm `isInfixOf` lowercase name
- , pkg <- pkgs ]
- where lsearchterm = lowercase searchterm
+ [ pkgs
+ | pkgs@(PackageName name, _) <- Map.toList m
+ , lsearchterm `isInfixOf` lowercase name ]
+ where
+ lsearchterm = lowercase searchterm
--
-- * Special queries
diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/PackageUtils.hs b/cabal/cabal-install/Distribution/Client/PackageUtils.hs
index bd2b1df..bd2b1df 100644
--- a/cabal-install-0.9.5_rc20101226/Distribution/Client/PackageUtils.hs
+++ b/cabal/cabal-install/Distribution/Client/PackageUtils.hs
diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Setup.hs b/cabal/cabal-install/Distribution/Client/Setup.hs
index 34316c6..2865260 100644
--- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Setup.hs
+++ b/cabal/cabal-install/Distribution/Client/Setup.hs
@@ -23,7 +23,7 @@ module Distribution.Client.Setup
, fetchCommand, FetchFlags(..)
, checkCommand
, uploadCommand, UploadFlags(..)
- , reportCommand
+ , reportCommand, ReportFlags(..)
, unpackCommand, UnpackFlags(..)
, initCommand, IT.InitFlags(..)
@@ -39,6 +39,8 @@ import Distribution.Client.BuildReports.Types
( ReportLevel(..) )
import qualified Distribution.Client.Init.Types as IT
( InitFlags(..), PackageType(..) )
+import Distribution.Client.Targets
+ ( UserConstraint, readUserConstraint )
import Distribution.Simple.Program
( defaultProgramConfiguration )
@@ -60,7 +62,7 @@ import Distribution.Package
import Distribution.Text
( Text(parse), display )
import Distribution.ReadE
- ( readP_to_E, succeedReadE )
+ ( ReadE(..), readP_to_E, succeedReadE )
import qualified Distribution.Compat.ReadP as Parse
( ReadP, readP_to_S, char, munch1, pfail, (+++) )
import Distribution.Verbosity
@@ -90,7 +92,7 @@ data GlobalFlags = GlobalFlags {
globalVersion :: Flag Bool,
globalNumericVersion :: Flag Bool,
globalConfigFile :: Flag FilePath,
- globalRemoteRepos :: [RemoteRepo], -- ^Available Hackage servers.
+ globalRemoteRepos :: [RemoteRepo], -- ^ Available Hackage servers.
globalCacheDir :: Flag FilePath,
globalLocalRepos :: [FilePath],
globalLogsDir :: Flag FilePath,
@@ -231,6 +233,7 @@ filterConfigureFlags flags cabalLibVersion
--
data ConfigExFlags = ConfigExFlags {
configCabalVersion :: Flag Version,
+ configExConstraints:: [UserConstraint],
configPreferences :: [Dependency]
}
@@ -241,7 +244,8 @@ configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags)
configureExCommand = configureCommand {
commandDefaultFlags = (mempty, defaultConfigExFlags),
commandOptions = \showOrParseArgs ->
- liftOptions fst setFst (configureOptions showOrParseArgs)
+ liftOptions fst setFst (filter ((/="constraint") . optionName) $
+ configureOptions showOrParseArgs)
++ liftOptions snd setSnd (configureExOptions showOrParseArgs)
}
where
@@ -257,22 +261,31 @@ configureExOptions _showOrParseArgs =
(reqArg "VERSION" (readP_to_E ("Cannot parse cabal lib version: "++)
(fmap toFlag parse))
(map display . flagToList))
+ , option [] ["constraint"]
+ "Specify constraints on a package (version, installed/source, flags)"
+ configExConstraints (\v flags -> flags { configExConstraints = v })
+ (reqArg "CONSTRAINT"
+ (fmap (\x -> [x]) (ReadE readUserConstraint))
+ (map display))
, option [] ["preference"]
"Specify preferences (soft constraints) on the version of a package"
configPreferences (\v flags -> flags { configPreferences = v })
- (reqArg "DEPENDENCY"
- (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parse))
- (map (\x -> display x)))
+ (reqArg "CONSTRAINT"
+ (readP_to_E (const "dependency expected")
+ (fmap (\x -> [x]) parse))
+ (map display))
]
instance Monoid ConfigExFlags where
mempty = ConfigExFlags {
configCabalVersion = mempty,
+ configExConstraints= mempty,
configPreferences = mempty
}
mappend a b = ConfigExFlags {
configCabalVersion = combine configCabalVersion,
+ configExConstraints= combine configExConstraints,
configPreferences = combine configPreferences
}
where combine field = field a `mappend` field b
@@ -373,16 +386,62 @@ checkCommand = CommandUI {
commandOptions = \_ -> []
}
-reportCommand :: CommandUI (Flag Verbosity)
+-- ------------------------------------------------------------
+-- * Report flags
+-- ------------------------------------------------------------
+
+data ReportFlags = ReportFlags {
+ reportUsername :: Flag Username,
+ reportPassword :: Flag Password,
+ reportVerbosity :: Flag Verbosity
+ }
+
+defaultReportFlags :: ReportFlags
+defaultReportFlags = ReportFlags {
+ reportUsername = mempty,
+ reportPassword = mempty,
+ reportVerbosity = toFlag normal
+ }
+
+reportCommand :: CommandUI ReportFlags
reportCommand = CommandUI {
commandName = "report",
commandSynopsis = "Upload build reports to a remote server.",
- commandDescription = Nothing,
- commandUsage = \pname -> "Usage: " ++ pname ++ " report\n",
- commandDefaultFlags = toFlag normal,
- commandOptions = \_ -> [optionVerbosity id const]
+ commandDescription = Just $ \_ ->
+ "You can store your Hackage login in the ~/.cabal/config file\n",
+ commandUsage = \pname -> "Usage: " ++ pname ++ " report [FLAGS]\n\n"
+ ++ "Flags for upload:",
+ commandDefaultFlags = defaultReportFlags,
+ commandOptions = \_ ->
+ [optionVerbosity reportVerbosity (\v flags -> flags { reportVerbosity = v })
+
+ ,option ['u'] ["username"]
+ "Hackage username."
+ reportUsername (\v flags -> flags { reportUsername = v })
+ (reqArg' "USERNAME" (toFlag . Username)
+ (flagToList . fmap unUsername))
+
+ ,option ['p'] ["password"]
+ "Hackage password."
+ reportPassword (\v flags -> flags { reportPassword = v })
+ (reqArg' "PASSWORD" (toFlag . Password)
+ (flagToList . fmap unPassword))
+ ]
}
+instance Monoid ReportFlags where
+ mempty = ReportFlags {
+ reportUsername = mempty,
+ reportPassword = mempty,
+ reportVerbosity = mempty
+ }
+ mappend a b = ReportFlags {
+ reportUsername = combine reportUsername,
+ reportPassword = combine reportPassword,
+ reportVerbosity = combine reportVerbosity
+ }
+ where combine field = field a `mappend` field b
+
-- ------------------------------------------------------------
-- * Unpack flags
-- ------------------------------------------------------------
@@ -517,6 +576,7 @@ data InstallFlags = InstallFlags {
installReinstall :: Flag Bool,
installUpgradeDeps :: Flag Bool,
installOnly :: Flag Bool,
+ installOnlyDeps :: Flag Bool,
installRootCmd :: Flag String,
installSummaryFile :: [PathTemplate],
installLogFile :: Flag PathTemplate,
@@ -533,6 +593,7 @@ defaultInstallFlags = InstallFlags {
installReinstall = Flag False,
installUpgradeDeps = Flag False,
installOnly = Flag False,
+ installOnlyDeps = Flag False,
installRootCmd = mempty,
installSummaryFile = mempty,
installLogFile = mempty,
@@ -564,7 +625,8 @@ installCommand = CommandUI {
++ " Constrained package version\n",
commandDefaultFlags = (mempty, mempty, mempty),
commandOptions = \showOrParseArgs ->
- liftOptions get1 set1 (configureOptions showOrParseArgs)
+ liftOptions get1 set1 (filter ((/="constraint") . optionName) $
+ configureOptions showOrParseArgs)
++ liftOptions get2 set2 (configureExOptions showOrParseArgs)
++ liftOptions get3 set3 (installOptions showOrParseArgs)
}
@@ -601,6 +663,13 @@ installOptions showOrParseArgs =
installUpgradeDeps (\v flags -> flags { installUpgradeDeps = v })
trueArg
+
+ , option [] ["only-dependencies"]
+ "Install only the dependencies necessary to build the given packages"
+ installOnlyDeps (\v flags -> flags { installOnlyDeps = v })
+ trueArg
+
+
, option [] ["root-cmd"]
"Command used to gain root privileges, when installing with --global."
installRootCmd (\v flags -> flags { installRootCmd = v })
@@ -651,6 +720,7 @@ instance Monoid InstallFlags where
installReinstall = mempty,
installUpgradeDeps = mempty,
installOnly = mempty,
+ installOnlyDeps = mempty,
installRootCmd = mempty,
installSummaryFile = mempty,
installLogFile = mempty,
@@ -665,6 +735,7 @@ instance Monoid InstallFlags where
installReinstall = combine installReinstall,
installUpgradeDeps = combine installUpgradeDeps,
installOnly = combine installOnly,
+ installOnlyDeps = combine installOnlyDeps,
installRootCmd = combine installRootCmd,
installSummaryFile = combine installSummaryFile,
installLogFile = combine installLogFile,
diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/SetupWrapper.hs b/cabal/cabal-install/Distribution/Client/SetupWrapper.hs
index 9315339..9315339 100644
--- a/cabal-install-0.9.5_rc20101226/Distribution/Client/SetupWrapper.hs
+++ b/cabal/cabal-install/Distribution/Client/SetupWrapper.hs
diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/SrcDist.hs b/cabal/cabal-install/Distribution/Client/SrcDist.hs
index f17a5ce..f17a5ce 100644
--- a/cabal-install-0.9.5_rc20101226/Distribution/Client/SrcDist.hs
+++ b/cabal/cabal-install/Distribution/Client/SrcDist.hs
diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Tar.hs b/cabal/cabal-install/Distribution/Client/Tar.hs
index f80509f..7063292 100644
--- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Tar.hs
+++ b/cabal/cabal-install/Distribution/Client/Tar.hs
@@ -7,7 +7,7 @@
-- 2008-2009 Duncan Coutts
-- License : BSD3
--
--- Maintainer : duncan@haskell.org
+-- Maintainer : duncan@community.haskell.org
-- Portability : portable
--
-- Reading, writing and manipulating \"@.tar@\" archive files.
@@ -51,19 +51,22 @@ module Distribution.Client.Tar (
-- ** Sequences of tar entries
Entries(..),
- foldEntries,
- unfoldEntries,
+ foldrEntries,
+ foldlEntries,
+ unfoldrEntries,
mapEntries,
+ filterEntries,
+ entriesIndex,
) where
import Data.Char (ord)
import Data.Int (Int64)
-import Data.Bits (Bits, shiftL)
+import Data.Bits (Bits, shiftL, testBit)
import Data.List (foldl')
import Numeric (readOct, showOct)
-import Control.Monad (MonadPlus(mplus))
-
+import Control.Monad (MonadPlus(mplus), when)
+import qualified Data.Map as Map
import qualified Data.ByteString.Lazy as BS
import qualified Data.ByteString.Lazy.Char8 as BS.Char8
import Data.ByteString.Lazy (ByteString)
@@ -80,6 +83,8 @@ import System.Directory
, getPermissions, createDirectoryIfMissing, copyFile )
import qualified System.Directory as Permissions
( Permissions(executable) )
+import Distribution.Compat.FilePerms
+ ( setFileExecutable )
import System.Posix.Types
( FileMode )
import System.Time
@@ -213,6 +218,9 @@ executableFilePermissions = 0o0755
directoryPermissions :: Permissions
directoryPermissions = 0o0755
+isExecutable :: Permissions -> Bool
+isExecutable p = testBit p 0 || testBit p 6 -- user or other exectuable
+
-- | An 'Entry' with all default values except for the file name and type. It
-- uses the portable USTAR/POSIX format (see 'UstarHeader').
--
@@ -382,24 +390,49 @@ data Entries = Next Entry Entries
| Done
| Fail String
-unfoldEntries :: (a -> Either String (Maybe (Entry, a))) -> a -> Entries
-unfoldEntries f = unfold
+unfoldrEntries :: (a -> Either String (Maybe (Entry, a))) -> a -> Entries
+unfoldrEntries f = unfold
where
unfold x = case f x of
Left err -> Fail err
Right Nothing -> Done
Right (Just (e, x')) -> Next e (unfold x')
-foldEntries :: (Entry -> a -> a) -> a -> (String -> a) -> Entries -> a
-foldEntries next done fail' = fold
+foldrEntries :: (Entry -> a -> a) -> a -> (String -> a) -> Entries -> a
+foldrEntries next done fail' = fold
where
fold (Next e es) = next e (fold es)
fold Done = done
fold (Fail err) = fail' err
-mapEntries :: (Entry -> Either String Entry) -> Entries -> Entries
-mapEntries f =
- foldEntries (\entry rest -> either Fail (flip Next rest) (f entry)) Done Fail
+foldlEntries :: (a -> Entry -> a) -> a -> Entries -> Either String a
+foldlEntries f = fold
+ where
+ fold a (Next e es) = (fold $! f a e) es
+ fold a Done = Right a
+ fold _ (Fail err) = Left err
+
+mapEntries :: (Entry -> Entry) -> Entries -> Entries
+mapEntries f = foldrEntries (Next . f) Done Fail
+
+filterEntries :: (Entry -> Bool) -> Entries -> Entries
+filterEntries p =
+ foldrEntries
+ (\entry rest -> if p entry
+ then Next entry rest
+ else rest)
+ Done Fail
+
+checkEntries :: (Entry -> Maybe String) -> Entries -> Entries
+checkEntries checkEntry =
+ foldrEntries
+ (\entry rest -> case checkEntry entry of
+ Nothing -> Next entry rest
+ Just err -> Fail err)
+ Done Fail
+
+entriesIndex :: Entries -> Either String (Map.Map TarPath Entry)
+entriesIndex = foldlEntries (\m e -> Map.insert (entryTarPath e) e m) Map.empty
--
-- * Checking
@@ -463,16 +496,13 @@ checkEntryTarbomb expectedTopDir entry =
_ -> Just $ "File in tar archive is not in the expected directory "
++ show expectedTopDir
-checkEntries :: (Entry -> Maybe String) -> Entries -> Entries
-checkEntries checkEntry =
- mapEntries (\entry -> maybe (Right entry) Left (checkEntry entry))
--
-- * Reading
--
read :: ByteString -> Entries
-read = unfoldEntries getEntry
+read = unfoldrEntries getEntry
getEntry :: ByteString -> Either String (Maybe (Entry, ByteString))
getEntry bs
@@ -741,7 +771,7 @@ unpack baseDir entries = unpackEntries [] (checkSecurity entries)
unpackEntries _ (Fail err) = fail err
unpackEntries links Done = return links
unpackEntries links (Next entry es) = case entryContent entry of
- NormalFile file _ -> extractFile path file
+ NormalFile file _ -> extractFile entry path file
>> unpackEntries links es
Directory -> extractDir path
>> unpackEntries links es
@@ -751,12 +781,14 @@ unpack baseDir entries = unpackEntries [] (checkSecurity entries)
where
path = entryPath entry
- extractFile path content = do
+ extractFile entry path content = do
-- Note that tar archives do not make sure each directory is created
-- before files they contain, indeed we may have to create several
-- levels of directory.
createDirectoryIfMissing True absDir
BS.writeFile absPath content
+ when (isExecutable (entryPermissions entry))
+ (setFileExecutable absPath)
where
absDir = baseDir </> FilePath.Native.takeDirectory path
absPath = baseDir </> path
diff --git a/cabal/cabal-install/Distribution/Client/Targets.hs b/cabal/cabal-install/Distribution/Client/Targets.hs
new file mode 100644
index 0000000..be754a2
--- /dev/null
+++ b/cabal/cabal-install/Distribution/Client/Targets.hs
@@ -0,0 +1,743 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Client.Targets
+-- Copyright : (c) Duncan Coutts 2011
+-- License : BSD-like
+--
+-- Maintainer : duncan@community.haskell.org
+--
+-- Handling for user-specified targets
+-----------------------------------------------------------------------------
+module Distribution.Client.Targets (
+ -- * User targets
+ UserTarget(..),
+ readUserTargets,
+
+ -- * Package specifiers
+ PackageSpecifier(..),
+ pkgSpecifierTarget,
+ pkgSpecifierConstraints,
+
+ -- * Resolving user targets to package specifiers
+ resolveUserTargets,
+
+ -- ** Detailed interface
+ UserTargetProblem(..),
+ readUserTarget,
+ reportUserTargetProblems,
+ expandUserTarget,
+
+ PackageTarget(..),
+ fetchPackageTarget,
+ readPackageTarget,
+
+ PackageTargetProblem(..),
+ reportPackageTargetProblems,
+
+ disambiguatePackageTargets,
+ disambiguatePackageName,
+
+ -- * User constraints
+ UserConstraint(..),
+ readUserConstraint,
+ userToPackageConstraint
+
+ ) where
+
+import Distribution.Package
+ ( Package(..), PackageName(..)
+ , PackageIdentifier(..), packageName, packageVersion
+ , Dependency(Dependency) )
+import Distribution.Client.Types
+ ( SourcePackage(..), PackageLocation(..) )
+import Distribution.Client.Dependency.Types
+ ( PackageConstraint(..) )
+
+import qualified Distribution.Client.World as World
+import Distribution.Client.PackageIndex (PackageIndex)
+import qualified Distribution.Client.PackageIndex as PackageIndex
+import qualified Distribution.Client.Tar as Tar
+import Distribution.Client.FetchUtils
+
+import Distribution.PackageDescription
+ ( GenericPackageDescription, FlagName(..), FlagAssignment )
+import Distribution.PackageDescription.Parse
+ ( readPackageDescription, parsePackageDescription, ParseResult(..) )
+import Distribution.Version
+ ( Version(Version), thisVersion, anyVersion, isAnyVersion
+ , VersionRange )
+import Distribution.Text
+ ( Text(..), display )
+import Distribution.Verbosity (Verbosity)
+import Distribution.Simple.Utils
+ ( die, warn, intercalate, findPackageDesc, fromUTF8, lowercase )
+
+import Data.List
+ ( find, nub )
+import Data.Maybe
+ ( listToMaybe )
+import Data.Either
+ ( partitionEithers )
+import Data.Monoid
+ ( Monoid(..) )
+import qualified Data.Map as Map
+import qualified Data.ByteString.Lazy as BS
+import qualified Data.ByteString.Lazy.Char8 as BS.Char8
+import qualified Distribution.Client.GZipUtils as GZipUtils
+import Control.Monad (liftM)
+import qualified Distribution.Compat.ReadP as Parse
+import Distribution.Compat.ReadP
+ ( (+++), (<++) )
+import qualified Text.PrettyPrint as Disp
+import Text.PrettyPrint
+ ( (<>), (<+>) )
+import Data.Char
+ ( isSpace, isAlphaNum )
+import System.FilePath
+ ( takeExtension, dropExtension, takeDirectory, splitPath )
+import System.Directory
+ ( doesFileExist, doesDirectoryExist )
+import Network.URI
+ ( URI(..), URIAuth(..), parseAbsoluteURI )
+
+-- ------------------------------------------------------------
+-- * User targets
+-- ------------------------------------------------------------
+
+-- | Various ways that a user may specify a package or package collection.
+--
+data UserTarget =
+
+ -- | A partially specified package, identified by name and possibly with
+ -- an exact version or a version constraint.
+ --
+ -- > cabal install foo
+ -- > cabal install foo-1.0
+ -- > cabal install 'foo < 2'
+ --
+ UserTargetNamed Dependency
+
+ -- | A special virtual package that refers to the collection of packages
+ -- recorded in the world file that the user specifically installed.
+ --
+ -- > cabal install world
+ --
+ | UserTargetWorld
+
+ -- | A specific package that is unpacked in a local directory, often the
+ -- current directory.
+ --
+ -- > cabal install .
+ -- > cabal install ../lib/other
+ --
+ -- * Note: in future, if multiple @.cabal@ files are allowed in a single
+ -- directory then this will refer to the collection of packages.
+ --
+ | UserTargetLocalDir FilePath
+
+ -- | A specific local unpacked package, identified by its @.cabal@ file.
+ --
+ -- > cabal install foo.cabal
+ -- > cabal install ../lib/other/bar.cabal
+ --
+ | UserTargetLocalCabalFile FilePath
+
+ -- | A specific package that is available as a local tarball file
+ --
+ -- > cabal install dist/foo-1.0.tar.gz
+ -- > cabal install ../build/baz-1.0.tar.gz
+ --
+ | UserTargetLocalTarball FilePath
+
+ -- | A specific package that is available as a remote tarball file
+ --
+ -- > cabal install http://code.haskell.org/~user/foo/foo-0.9.tar.gz
+ --
+ | UserTargetRemoteTarball URI
+ deriving (Show,Eq)
+
+
+-- ------------------------------------------------------------
+-- * Package specifier
+-- ------------------------------------------------------------
+
+-- | A fully or partially resolved reference to a package.
+--
+data PackageSpecifier pkg =
+
+ -- | A partially specified reference to a package (either source or
+ -- installed). It is specified by package name and optionally some
+ -- additional constraints. Use a dependency resolver to pick a specific
+ -- package satisfying these constraints.
+ --
+ NamedPackage PackageName [PackageConstraint]
+
+ -- | A fully specified source package.
+ --
+ | SpecificSourcePackage pkg
+ deriving Show
+
+
+pkgSpecifierTarget :: Package pkg => PackageSpecifier pkg -> PackageName
+pkgSpecifierTarget (NamedPackage name _) = name
+pkgSpecifierTarget (SpecificSourcePackage pkg) = packageName pkg
+
+pkgSpecifierConstraints :: Package pkg
+ => PackageSpecifier pkg -> [PackageConstraint]
+pkgSpecifierConstraints (NamedPackage _ constraints) = constraints
+pkgSpecifierConstraints (SpecificSourcePackage pkg) =
+ [PackageConstraintVersion (packageName pkg)
+ (thisVersion (packageVersion pkg))]
+
+
+-- ------------------------------------------------------------
+-- * Parsing and checking user targets
+-- ------------------------------------------------------------
+
+readUserTargets :: Verbosity -> [String] -> IO [UserTarget]
+readUserTargets _verbosity targetStrs = do
+ (problems, targets) <- liftM partitionEithers
+ (mapM readUserTarget targetStrs)
+ reportUserTargetProblems problems
+ return targets
+
+
+data UserTargetProblem
+ = UserTargetUnexpectedFile String
+ | UserTargetNonexistantFile String
+ | UserTargetUnexpectedUriScheme String
+ | UserTargetUnrecognisedUri String
+ | UserTargetUnrecognised String
+ | UserTargetBadWorldPkg
+ deriving Show
+
+readUserTarget :: String -> IO (Either UserTargetProblem UserTarget)
+readUserTarget targetstr =
+ case testNamedTargets targetstr of
+ Just (Dependency (PackageName "world") verrange)
+ | verrange == anyVersion -> return (Right UserTargetWorld)
+ | otherwise -> return (Left UserTargetBadWorldPkg)
+ Just dep -> return (Right (UserTargetNamed dep))
+ Nothing -> do
+ fileTarget <- testFileTargets targetstr
+ case fileTarget of
+ Just target -> return target
+ Nothing ->
+ case testUriTargets targetstr of
+ Just target -> return target
+ Nothing -> return (Left (UserTargetUnrecognised targetstr))
+ where
+ testNamedTargets = readPToMaybe parseDependencyOrPackageId
+
+ testFileTargets filename = do
+ isDir <- doesDirectoryExist filename
+ isFile <- doesFileExist filename
+ parentDirExists <- case takeDirectory filename of
+ [] -> return False
+ dir -> doesDirectoryExist dir
+ let result
+ | isDir
+ = Just (Right (UserTargetLocalDir filename))
+
+ | isFile && extensionIsTarGz filename
+ = Just (Right (UserTargetLocalTarball filename))
+
+ | isFile && takeExtension filename == ".cabal"
+ = Just (Right (UserTargetLocalCabalFile filename))
+
+ | isFile
+ = Just (Left (UserTargetUnexpectedFile filename))
+
+ | parentDirExists
+ = Just (Left (UserTargetNonexistantFile filename))
+
+ | otherwise
+ = Nothing
+ return result
+
+ testUriTargets str =
+ case parseAbsoluteURI str of
+ Just uri@URI {
+ uriScheme = scheme,
+ uriAuthority = Just URIAuth { uriRegName = host }
+ }
+ | scheme /= "http:" ->
+ Just (Left (UserTargetUnexpectedUriScheme targetstr))
+
+ | null host ->
+ Just (Left (UserTargetUnrecognisedUri targetstr))
+
+ | otherwise ->
+ Just (Right (UserTargetRemoteTarball uri))
+ _ -> Nothing
+
+ extensionIsTarGz f = takeExtension f == ".gz"
+ && takeExtension (dropExtension f) == ".tar"
+
+ parseDependencyOrPackageId :: Parse.ReadP r Dependency
+ parseDependencyOrPackageId = parse
+ +++ liftM pkgidToDependency parse
+ where
+ pkgidToDependency :: PackageIdentifier -> Dependency
+ pkgidToDependency p = case packageVersion p of
+ Version [] _ -> Dependency (packageName p) anyVersion
+ version -> Dependency (packageName p) (thisVersion version)
+
+readPToMaybe :: Parse.ReadP a a -> String -> Maybe a
+readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str
+ , all isSpace s ]
+
+
+reportUserTargetProblems :: [UserTargetProblem] -> IO ()
+reportUserTargetProblems problems = do
+ case [ target | UserTargetUnrecognised target <- problems ] of
+ [] -> return ()
+ target -> die
+ $ unlines
+ [ "Unrecognised target '" ++ name ++ "'."
+ | name <- target ]
+ ++ "Targets can be:\n"
+ ++ " - package names, e.g. 'pkgname', 'pkgname-1.0.1', 'pkgname < 2.0'\n"
+ ++ " - the special 'world' target\n"
+ ++ " - cabal files 'pkgname.cabal' or package directories 'pkgname/'\n"
+ ++ " - package tarballs 'pkgname.tar.gz' or 'http://example.com/pkgname.tar.gz'"
+
+ case [ () | UserTargetBadWorldPkg <- problems ] of
+ [] -> return ()
+ _ -> die "The special 'world' target does not take any version."
+
+ case [ target | UserTargetNonexistantFile target <- problems ] of
+ [] -> return ()
+ target -> die
+ $ unlines
+ [ "The file does not exist '" ++ name ++ "'."
+ | name <- target ]
+
+ case [ target | UserTargetUnexpectedFile target <- problems ] of
+ [] -> return ()
+ target -> die
+ $ unlines
+ [ "Unrecognised file target '" ++ name ++ "'."
+ | name <- target ]
+ ++ "File targets can be either package tarballs 'pkgname.tar.gz' "
+ ++ "or cabal files 'pkgname.cabal'."
+
+ case [ target | UserTargetUnexpectedUriScheme target <- problems ] of
+ [] -> return ()
+ target -> die
+ $ unlines
+ [ "URL target not supported '" ++ name ++ "'."
+ | name <- target ]
+ ++ "Only 'http://' URLs are supported."
+
+ case [ target | UserTargetUnrecognisedUri target <- problems ] of
+ [] -> return ()
+ target -> die
+ $ unlines
+ [ "Unrecognise URL target '" ++ name ++ "'."
+ | name <- target ]
+
+
+-- ------------------------------------------------------------
+-- * Resolving user targets to package specifiers
+-- ------------------------------------------------------------
+
+-- | Given a bunch of user-specified targets, try to resolve what it is they
+-- refer to. They can either be specific packages (local dirs, tarballs etc)
+-- or they can be named packages (with or without version info).
+--
+resolveUserTargets :: Package pkg
+ => Verbosity
+ -> FilePath
+ -> PackageIndex pkg
+ -> [UserTarget]
+ -> IO [PackageSpecifier SourcePackage]
+resolveUserTargets verbosity worldFile available userTargets = do
+
+ -- given the user targets, get a list of fully or partially resolved
+ -- package references
+ packageTargets <- mapM (readPackageTarget verbosity)
+ =<< mapM (fetchPackageTarget verbosity) . concat
+ =<< mapM (expandUserTarget worldFile) userTargets
+
+ -- users are allowed to give package names case-insensitively, so we must
+ -- disambiguate named package references
+ let (problems, packageSpecifiers) =
+ disambiguatePackageTargets available availableExtra packageTargets
+
+ -- use any extra specific available packages to help us disambiguate
+ availableExtra = [ packageName pkg
+ | PackageTargetLocation pkg <- packageTargets ]
+
+ reportPackageTargetProblems verbosity problems
+
+ return packageSpecifiers
+
+
+-- ------------------------------------------------------------
+-- * Package targets
+-- ------------------------------------------------------------
+
+-- | An intermediate between a 'UserTarget' and a resolved 'PackageSpecifier'.
+-- Unlike a 'UserTarget', a 'PackageTarget' refers only to a single package.
+--
+data PackageTarget pkg =
+ PackageTargetNamed PackageName [PackageConstraint] UserTarget
+
+ -- | A package identified by name, but case insensitively, so it needs
+ -- to be resolved to the right case-sensitive name.
+ | PackageTargetNamedFuzzy PackageName [PackageConstraint] UserTarget
+ | PackageTargetLocation pkg
+ deriving Show
+
+
+-- ------------------------------------------------------------
+-- * Converting user targets to package targets
+-- ------------------------------------------------------------
+
+-- | Given a user-specified target, expand it to a bunch of package targets
+-- (each of which refers to only one package).
+--
+expandUserTarget :: FilePath
+ -> UserTarget
+ -> IO [PackageTarget (PackageLocation ())]
+expandUserTarget worldFile userTarget = case userTarget of
+
+ UserTargetNamed (Dependency name vrange) ->
+ let constraints = [ PackageConstraintVersion name vrange
+ | not (isAnyVersion vrange) ]
+ in return [PackageTargetNamedFuzzy name constraints userTarget]
+
+ UserTargetWorld -> do
+ worldPkgs <- World.getContents worldFile
+ --TODO: should we warn if there are no world targets?
+ return [ PackageTargetNamed name constraints userTarget
+ | World.WorldPkgInfo (Dependency name vrange) flags <- worldPkgs
+ , let constraints = [ PackageConstraintVersion name vrange
+ | not (isAnyVersion vrange) ]
+ ++ [ PackageConstraintFlags name flags
+ | not (null flags) ] ]
+
+ UserTargetLocalDir dir ->
+ return [ PackageTargetLocation (LocalUnpackedPackage dir) ]
+
+ UserTargetLocalCabalFile file -> do
+ let dir = takeDirectory file
+ _ <- findPackageDesc dir -- just as a check
+ return [ PackageTargetLocation (LocalUnpackedPackage dir) ]
+
+ UserTargetLocalTarball tarballFile ->
+ return [ PackageTargetLocation (LocalTarballPackage tarballFile) ]
+
+ UserTargetRemoteTarball tarballURL ->
+ return [ PackageTargetLocation (RemoteTarballPackage tarballURL ()) ]
+
+
+-- ------------------------------------------------------------
+-- * Fetching and reading package targets
+-- ------------------------------------------------------------
+
+
+-- | Fetch any remote targets so that they can be read.
+--
+fetchPackageTarget :: Verbosity
+ -> PackageTarget (PackageLocation ())
+ -> IO (PackageTarget (PackageLocation FilePath))
+fetchPackageTarget verbosity target = case target of
+ PackageTargetNamed n cs ut -> return (PackageTargetNamed n cs ut)
+ PackageTargetNamedFuzzy n cs ut -> return (PackageTargetNamedFuzzy n cs ut)
+ PackageTargetLocation location -> do
+ location' <- fetchPackage verbosity (fmap (const Nothing) location)
+ return (PackageTargetLocation location')
+
+
+-- | Given a package target that has been fetched, read the .cabal file.
+--
+-- This only affects targets given by location, named targets are unaffected.
+--
+readPackageTarget :: Verbosity
+ -> PackageTarget (PackageLocation FilePath)
+ -> IO (PackageTarget SourcePackage)
+readPackageTarget verbosity target = case target of
+
+ PackageTargetNamed pkgname constraints userTarget ->
+ return (PackageTargetNamed pkgname constraints userTarget)
+
+ PackageTargetNamedFuzzy pkgname constraints userTarget ->
+ return (PackageTargetNamedFuzzy pkgname constraints userTarget)
+
+ PackageTargetLocation location -> case location of
+
+ LocalUnpackedPackage dir -> do
+ pkg <- readPackageDescription verbosity =<< findPackageDesc dir
+ return $ PackageTargetLocation $
+ SourcePackage {
+ packageInfoId = packageId pkg,
+ packageDescription = pkg,
+ packageSource = fmap Just location
+ }
+
+ LocalTarballPackage tarballFile ->
+ readTarballPackageTarget location tarballFile tarballFile
+
+ RemoteTarballPackage tarballURL tarballFile ->
+ readTarballPackageTarget location tarballFile (show tarballURL)
+
+ RepoTarballPackage _repo _pkgid _ ->
+ error "TODO: readPackageTarget RepoTarballPackage"
+ -- For repo tarballs this info should be obtained from the index.
+
+ where
+ readTarballPackageTarget location tarballFile tarballOriginalLoc = do
+ (filename, content) <- extractTarballPackageCabalFile
+ tarballFile tarballOriginalLoc
+ case parsePackageDescription' content of
+ Nothing -> die $ "Could not parse the cabal file "
+ ++ filename ++ " in " ++ tarballFile
+ Just pkg ->
+ return $ PackageTargetLocation $
+ SourcePackage {
+ packageInfoId = packageId pkg,
+ packageDescription = pkg,
+ packageSource = fmap Just location
+ }
+
+ extractTarballPackageCabalFile :: FilePath -> String
+ -> IO (FilePath, BS.ByteString)
+ extractTarballPackageCabalFile tarballFile tarballOriginalLoc =
+ either (die . formatErr) return
+ . check
+ . Tar.entriesIndex
+ . Tar.filterEntries isCabalFile
+ . Tar.read
+ . GZipUtils.maybeDecompress
+ =<< BS.readFile tarballFile
+ where
+ formatErr msg = "Error reading " ++ tarballOriginalLoc ++ ": " ++ msg
+
+ check (Left e) = Left e
+ check (Right m) = case Map.elems m of
+ [] -> Left noCabalFile
+ [file] -> case Tar.entryContent file of
+ Tar.NormalFile content _ -> Right (Tar.entryPath file, content)
+ _ -> Left noCabalFile
+ _files -> Left multipleCabalFiles
+ where
+ noCabalFile = "No cabal file found"
+ multipleCabalFiles = "Multiple cabal files found"
+
+ isCabalFile e = case splitPath (Tar.entryPath e) of
+ [ _dir, file] -> takeExtension file == ".cabal"
+ [".", _dir, file] -> takeExtension file == ".cabal"
+ _ -> False
+
+ parsePackageDescription' :: BS.ByteString -> Maybe GenericPackageDescription
+ parsePackageDescription' content =
+ case parsePackageDescription . fromUTF8 . BS.Char8.unpack $ content of
+ ParseOk _ pkg -> Just pkg
+ _ -> Nothing
+
+
+-- ------------------------------------------------------------
+-- * Checking package targets
+-- ------------------------------------------------------------
+
+data PackageTargetProblem
+ = PackageNameUnknown PackageName UserTarget
+ | PackageNameAmbigious PackageName [PackageName] UserTarget
+ deriving Show
+
+
+-- | Users are allowed to give package names case-insensitively, so we must
+-- disambiguate named package references.
+--
+disambiguatePackageTargets :: Package pkg'
+ => PackageIndex pkg'
+ -> [PackageName]
+ -> [PackageTarget pkg]
+ -> ( [PackageTargetProblem]
+ , [PackageSpecifier pkg] )
+disambiguatePackageTargets availablePkgIndex availableExtra targets =
+ partitionEithers (map disambiguatePackageTarget targets)
+ where
+ disambiguatePackageTarget packageTarget = case packageTarget of
+ PackageTargetLocation pkg -> Right (SpecificSourcePackage pkg)
+
+ PackageTargetNamed pkgname constraints userTarget
+ | null (PackageIndex.lookupPackageName availablePkgIndex pkgname)
+ -> Left (PackageNameUnknown pkgname userTarget)
+ | otherwise -> Right (NamedPackage pkgname constraints)
+
+ PackageTargetNamedFuzzy pkgname constraints userTarget ->
+ case disambiguatePackageName packageNameEnv pkgname of
+ None -> Left (PackageNameUnknown
+ pkgname userTarget)
+ Ambiguous pkgnames -> Left (PackageNameAmbigious
+ pkgname pkgnames userTarget)
+ Unambiguous pkgname' -> Right (NamedPackage pkgname' constraints')
+ where
+ constraints' = map (renamePackageConstraint pkgname') constraints
+
+ -- use any extra specific available packages to help us disambiguate
+ packageNameEnv :: PackageNameEnv
+ packageNameEnv = mappend (indexPackageNameEnv availablePkgIndex)
+ (extraPackageNameEnv availableExtra)
+
+
+-- | Report problems to the user. That is, if there are any problems
+-- then raise an exception.
+reportPackageTargetProblems :: Verbosity
+ -> [PackageTargetProblem] -> IO ()
+reportPackageTargetProblems verbosity problems = do
+ case [ pkg | PackageNameUnknown pkg originalTarget <- problems
+ , not (isUserTagetWorld originalTarget) ] of
+ [] -> return ()
+ pkgs -> die $ unlines
+ [ "There is no package named '" ++ display name ++ "'. "
+ | name <- pkgs ]
+ ++ "You may need to run 'hackport update' to get the latest "
+ ++ "list of available packages."
+
+ case [ (pkg, matches) | PackageNameAmbigious pkg matches _ <- problems ] of
+ [] -> return ()
+ ambiguities -> die $ unlines
+ [ "The package name '" ++ display name
+ ++ "' is ambigious. It could be: "
+ ++ intercalate ", " (map display matches)
+ | (name, matches) <- ambiguities ]
+
+ case [ pkg | PackageNameUnknown pkg UserTargetWorld <- problems ] of
+ [] -> return ()
+ pkgs -> warn verbosity $
+ "The following 'world' packages will be ignored because "
+ ++ "they refer to packages that cannot be found: "
+ ++ intercalate ", " (map display pkgs) ++ "\n"
+ ++ "You can suppress this warning by correcting the world file."
+ where
+ isUserTagetWorld UserTargetWorld = True; isUserTagetWorld _ = False
+
+
+-- ------------------------------------------------------------
+-- * Disambiguating package names
+-- ------------------------------------------------------------
+
+data MaybeAmbigious a = None | Unambiguous a | Ambiguous [a]
+
+-- | Given a package name and a list of matching names, figure out which one it
+-- might be referring to. If there is an exact case-sensitive match then that's
+-- ok. If it matches just one package case-insensitively then that's also ok.
+-- The only problem is if it matches multiple packages case-insensitively, in
+-- that case it is ambigious.
+--
+disambiguatePackageName :: PackageNameEnv
+ -> PackageName
+ -> MaybeAmbigious PackageName
+disambiguatePackageName (PackageNameEnv pkgNameLookup) name =
+ case nub (pkgNameLookup name) of
+ [] -> None
+ [name'] -> Unambiguous name'
+ names -> case find (name==) names of
+ Just name' -> Unambiguous name'
+ Nothing -> Ambiguous names
+
+
+newtype PackageNameEnv = PackageNameEnv (PackageName -> [PackageName])
+
+instance Monoid PackageNameEnv where
+ mempty = PackageNameEnv (const [])
+ mappend (PackageNameEnv lookupA) (PackageNameEnv lookupB) =
+ PackageNameEnv (\name -> lookupA name ++ lookupB name)
+
+indexPackageNameEnv :: Package pkg => PackageIndex pkg -> PackageNameEnv
+indexPackageNameEnv pkgIndex = PackageNameEnv pkgNameLookup
+ where
+ pkgNameLookup (PackageName name) =
+ map fst (PackageIndex.searchByName pkgIndex name)
+
+extraPackageNameEnv :: [PackageName] -> PackageNameEnv
+extraPackageNameEnv names = PackageNameEnv pkgNameLookup
+ where
+ pkgNameLookup (PackageName name) =
+ [ PackageName name'
+ | let lname = lowercase name
+ , PackageName name' <- names
+ , lowercase name' == lname ]
+
+
+-- ------------------------------------------------------------
+-- * Package constraints
+-- ------------------------------------------------------------
+
+data UserConstraint =
+ UserConstraintVersion PackageName VersionRange
+ | UserConstraintInstalled PackageName
+ | UserConstraintSource PackageName
+ | UserConstraintFlags PackageName FlagAssignment
+ deriving (Show,Eq)
+
+
+userToPackageConstraint :: UserConstraint -> PackageConstraint
+-- At the moment, the types happen to be directly equivalent
+userToPackageConstraint uc = case uc of
+ UserConstraintVersion name ver -> PackageConstraintVersion name ver
+ UserConstraintInstalled name -> PackageConstraintInstalled name
+ UserConstraintSource name -> PackageConstraintSource name
+ UserConstraintFlags name flags -> PackageConstraintFlags name flags
+
+renamePackageConstraint :: PackageName -> PackageConstraint -> PackageConstraint
+renamePackageConstraint name pc = case pc of
+ PackageConstraintVersion _ ver -> PackageConstraintVersion name ver
+ PackageConstraintInstalled _ -> PackageConstraintInstalled name
+ PackageConstraintSource _ -> PackageConstraintSource name
+ PackageConstraintFlags _ flags -> PackageConstraintFlags name flags
+
+readUserConstraint :: String -> Either String UserConstraint
+readUserConstraint str =
+ case readPToMaybe parse str of
+ Nothing -> Left msgCannotParse
+ Just c -> Right c
+ where
+ msgCannotParse =
+ "expected a package name followed by a constraint, which is "
+ ++ "either a version range, 'installed', 'source' or flags"
+
+--FIXME: use Text instance for FlagName and FlagAssignment
+instance Text UserConstraint where
+ disp (UserConstraintVersion pkgname verrange) = disp pkgname <+> disp verrange
+ disp (UserConstraintInstalled pkgname) = disp pkgname <+> Disp.text "installed"
+ disp (UserConstraintSource pkgname) = disp pkgname <+> Disp.text "source"
+ disp (UserConstraintFlags pkgname flags) = disp pkgname <+> dispFlagAssignment flags
+ where
+ dispFlagAssignment = Disp.hsep . map dispFlagValue
+ dispFlagValue (f, True) = Disp.char '+' <> dispFlagName f
+ dispFlagValue (f, False) = Disp.char '-' <> dispFlagName f
+ dispFlagName (FlagName f) = Disp.text f
+
+ parse = parse >>= parseConstraint
+ where
+ parseConstraint pkgname =
+ (parse >>= return . UserConstraintVersion pkgname)
+ +++ (do Parse.skipSpaces
+ _ <- Parse.string "installed"
+ return (UserConstraintInstalled pkgname))
+ +++ (do Parse.skipSpaces
+ _ <- Parse.string "source"
+ return (UserConstraintSource pkgname))
+ <++ (parseFlagAssignment >>= (return . UserConstraintFlags pkgname))
+
+ parseFlagAssignment = Parse.many1 (Parse.skipSpaces >> parseFlagValue)
+ parseFlagValue =
+ (do Parse.optional (Parse.char '+')
+ f <- parseFlagName
+ return (f, True))
+ +++ (do _ <- Parse.char '-'
+ f <- parseFlagName
+ return (f, False))
+ parseFlagName = liftM FlagName ident
+
+ ident :: Parse.ReadP r String
+ ident = Parse.munch1 identChar >>= \s -> check s >> return s
+ where
+ identChar c = isAlphaNum c || c == '_' || c == '-'
+ check ('-':_) = Parse.pfail
+ check _ = return ()
diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Types.hs b/cabal/cabal-install/Distribution/Client/Types.hs
index a0da743..192a271 100644
--- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Types.hs
+++ b/cabal/cabal-install/Distribution/Client/Types.hs
@@ -2,37 +2,31 @@
-- |
-- Module : Distribution.Client.Types
-- Copyright : (c) David Himmelstrup 2005
+-- Duncan Coutts 2011
-- License : BSD-like
--
--- Maintainer : lemmih@gmail.com
+-- Maintainer : cabal-devel@haskell.org
-- Stability : provisional
-- Portability : portable
--
--- All data types for the entire cabal-install system gathered here to avoid some .hs-boot files.
+-- Various common data types for the entire cabal-install system
-----------------------------------------------------------------------------
module Distribution.Client.Types where
import Distribution.Package
- ( PackageName, PackageId, Package(..)
- , PackageFixedDeps(..), Dependency )
+ ( PackageName, PackageId, Package(..), PackageFixedDeps(..) )
import Distribution.InstalledPackageInfo
( InstalledPackageInfo )
import Distribution.PackageDescription
- ( GenericPackageDescription, FlagAssignment, FlagName(FlagName) )
+ ( GenericPackageDescription, FlagAssignment )
import Distribution.Client.PackageIndex
( PackageIndex )
import Distribution.Version
( VersionRange )
-import Distribution.Text
- ( Text(disp,parse) )
-import qualified Distribution.Compat.ReadP as Parse
-import qualified Text.PrettyPrint as Disp
-
-import Data.Char as Char
import Data.Map (Map)
import Network.URI (URI)
-import Distribution.Compat.Exception
+import Distribution.Compat.ExceptionCI
( SomeException )
newtype Username = Username { unUsername :: String }
@@ -40,11 +34,15 @@ newtype Password = Password { unPassword :: String }
-- | This is the information we get from a @00-index.tar.gz@ hackage index.
--
-data AvailablePackageDb = AvailablePackageDb {
- packageIndex :: PackageIndex AvailablePackage,
+data SourcePackageDb = SourcePackageDb {
+ packageIndex :: PackageIndex SourcePackage,
packagePreferences :: Map PackageName VersionRange
}
+-- ------------------------------------------------------------
+-- * Various kinds of information about packages
+-- ------------------------------------------------------------
+
-- | TODO: This is a hack to help us transition from Cabal-1.6 to 1.8.
-- What is new in 1.8 is that installed packages and dependencies between
-- installed packages are now identified by an opaque InstalledPackageId
@@ -74,7 +72,7 @@ instance PackageFixedDeps InstalledPackage where
-- final configure process will be independent of the environment.
--
data ConfiguredPackage = ConfiguredPackage
- AvailablePackage -- package info, including repo
+ SourcePackage -- package info, including repo
FlagAssignment -- complete flag assignment for the package
[PackageId] -- set of exact dependencies. These must be
-- consistent with the 'buildDepends' in the
@@ -89,39 +87,49 @@ instance PackageFixedDeps ConfiguredPackage where
depends (ConfiguredPackage _ _ deps) = deps
--- | We re-use @GenericPackageDescription@ and use the @package-url@
--- field to store the tarball URI.
-data AvailablePackage = AvailablePackage {
+-- | A package description along with the location of the package sources.
+--
+data SourcePackage = SourcePackage {
packageInfoId :: PackageId,
packageDescription :: GenericPackageDescription,
- packageSource :: AvailablePackageSource
+ packageSource :: PackageLocation (Maybe FilePath)
}
deriving Show
-instance Package AvailablePackage where packageId = packageInfoId
+instance Package SourcePackage where packageId = packageInfoId
+
+-- ------------------------------------------------------------
+-- * Package locations and repositories
+-- ------------------------------------------------------------
-data AvailablePackageSource =
+data PackageLocation local =
-- | An unpacked package in the given dir, or current dir
- LocalUnpackedPackage (Maybe FilePath)
+ LocalUnpackedPackage FilePath
-- | A package as a tarball that's available as a local tarball
| LocalTarballPackage FilePath
-- | A package as a tarball from a remote URI
- | RemoteTarballPackage URI
+ | RemoteTarballPackage URI local
-- | A package available as a tarball from a repository.
--
-- It may be from a local repository or from a remote repository, with a
-- locally cached copy. ie a package available from hackage
- | RepoTarballPackage Repo
+ | RepoTarballPackage Repo PackageId local
+--TODO:
+-- * add support for darcs and other SCM style remote repos with a local cache
-- | ScmPackage
deriving Show
---TODO:
--- * add support for darcs and other SCM style remote repos with a local cache
+instance Functor PackageLocation where
+ fmap _ (LocalUnpackedPackage dir) = LocalUnpackedPackage dir
+ fmap _ (LocalTarballPackage file) = LocalTarballPackage file
+ fmap f (RemoteTarballPackage uri x) = RemoteTarballPackage uri (f x)
+ fmap f (RepoTarballPackage repo pkg x) = RepoTarballPackage repo pkg (f x)
+
data LocalRepo = LocalRepo
deriving (Show,Eq)
@@ -138,65 +146,9 @@ data Repo = Repo {
}
deriving (Show,Eq)
-data UnresolvedDependency
- = UnresolvedDependency
- { dependency :: Dependency
- , depFlags :: FlagAssignment
- }
- deriving (Show,Eq)
-
-
-instance Text UnresolvedDependency where
- disp udep = disp (dependency udep) Disp.<+> dispFlags (depFlags udep)
- where
- dispFlags [] = Disp.empty
- dispFlags fs = Disp.text "--flags="
- Disp.<>
- (Disp.doubleQuotes $ flagAssToDoc fs)
- flagAssToDoc = foldr (\(FlagName fname,val) flagAssDoc ->
- (if not val then Disp.char '-'
- else Disp.empty)
- Disp.<> Disp.text fname
- Disp.<+> flagAssDoc)
- Disp.empty
- parse = do
- dep <- parse
- Parse.skipSpaces
- flagAss <- Parse.option [] parseFlagAssignment
- return $ UnresolvedDependency dep flagAss
- where
- parseFlagAssignment :: Parse.ReadP r FlagAssignment
- parseFlagAssignment = do
- Parse.string "--flags"
- Parse.skipSpaces
- Parse.char '='
- Parse.skipSpaces
- inDoubleQuotes $ Parse.many1 flag
- where
- inDoubleQuotes :: Parse.ReadP r a -> Parse.ReadP r a
- inDoubleQuotes = Parse.between (Parse.char '"') (Parse.char '"')
-
- flag = do
- Parse.skipSpaces
- val <- negative Parse.+++ positive
- name <- ident
- Parse.skipSpaces
- return (FlagName name,val)
- negative = do
- Parse.char '-'
- return False
- positive = return True
-
- ident :: Parse.ReadP r String
- ident = do
- -- First character must be a letter/digit to avoid flags
- -- like "+-debug":
- c <- Parse.satisfy Char.isAlphaNum
- cs <- Parse.munch (\ch -> Char.isAlphaNum ch || ch == '_'
- || ch == '-')
- return (c:cs)
-
-
+-- ------------------------------------------------------------
+-- * Build results
+-- ------------------------------------------------------------
type BuildResult = Either BuildFailure BuildSuccess
data BuildFailure = DependentFailed PackageId
diff --git a/cabal/cabal-install/Distribution/Client/Unpack.hs b/cabal/cabal-install/Distribution/Client/Unpack.hs
new file mode 100644
index 0000000..ccc9ed7
--- /dev/null
+++ b/cabal/cabal-install/Distribution/Client/Unpack.hs
@@ -0,0 +1,123 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Client.Unpack
+-- Copyright : (c) Andrea Vezzosi 2008
+-- Duncan Coutts 2011
+-- License : BSD-like
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+--
+-----------------------------------------------------------------------------
+module Distribution.Client.Unpack (
+
+ -- * Commands
+ unpack,
+
+ ) where
+
+import Distribution.Package
+ ( PackageId, packageId )
+import Distribution.Simple.Setup
+ ( fromFlag, fromFlagOrDefault )
+import Distribution.Simple.Utils
+ ( notice, die )
+import Distribution.Verbosity
+ ( Verbosity )
+import Distribution.Text(display)
+
+import Distribution.Client.Setup
+ ( GlobalFlags(..), UnpackFlags(..) )
+import Distribution.Client.Types
+import Distribution.Client.Targets
+import Distribution.Client.Dependency
+import Distribution.Client.FetchUtils
+import qualified Distribution.Client.Tar as Tar (extractTarGzFile)
+import Distribution.Client.IndexUtils as IndexUtils
+ ( getSourcePackages )
+
+import System.Directory
+ ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist )
+import Control.Monad
+ ( unless, when )
+import Data.Monoid
+ ( mempty )
+import System.FilePath
+ ( (</>), addTrailingPathSeparator )
+
+
+unpack :: Verbosity
+ -> [Repo]
+ -> GlobalFlags
+ -> UnpackFlags
+ -> [UserTarget]
+ -> IO ()
+unpack verbosity _ _ _ [] =
+ notice verbosity "No packages requested. Nothing to do."
+
+unpack verbosity repos globalFlags unpackFlags userTargets = do
+ mapM_ checkTarget userTargets
+
+ sourcePkgDb <- getSourcePackages verbosity repos
+
+ pkgSpecifiers <- resolveUserTargets verbosity
+ (fromFlag $ globalWorldFile globalFlags)
+ (packageIndex sourcePkgDb)
+ userTargets
+
+ pkgs <- either (die . unlines . map show) return $
+ resolveWithoutDependencies
+ (resolverParams sourcePkgDb pkgSpecifiers)
+
+ unless (null prefix) $
+ createDirectoryIfMissing True prefix
+
+ flip mapM_ pkgs $ \pkg -> do
+ location <- fetchPackage verbosity (packageSource pkg)
+ let pkgid = packageId pkg
+ case location of
+ LocalTarballPackage tarballPath ->
+ unpackPackage verbosity prefix pkgid tarballPath
+
+ RemoteTarballPackage _tarballURL tarballPath ->
+ unpackPackage verbosity prefix pkgid tarballPath
+
+ RepoTarballPackage _repo _pkgid tarballPath ->
+ unpackPackage verbosity prefix pkgid tarballPath
+
+ LocalUnpackedPackage _ ->
+ error "Distribution.Client.Unpack.unpack: the impossible happened."
+
+ where
+ resolverParams sourcePkgDb pkgSpecifiers =
+ --TODO: add commandline constraint and preference args for unpack
+
+ standardInstallPolicy mempty sourcePkgDb pkgSpecifiers
+
+ prefix = fromFlagOrDefault "" (unpackDestDir unpackFlags)
+
+checkTarget :: UserTarget -> IO ()
+checkTarget target = case target of
+ UserTargetLocalDir dir -> die (notTarball dir)
+ UserTargetLocalCabalFile file -> die (notTarball file)
+ _ -> return ()
+ where
+ notTarball t =
+ "The 'unpack' command is for tarball packages. "
+ ++ "The target '" ++ t ++ "' is not a tarball."
+
+unpackPackage :: Verbosity -> FilePath -> PackageId -> FilePath -> IO ()
+unpackPackage verbosity prefix pkgid pkgPath = do
+ let pkgdirname = display pkgid
+ pkgdir = prefix </> pkgdirname
+ pkgdir' = addTrailingPathSeparator pkgdir
+ existsDir <- doesDirectoryExist pkgdir
+ when existsDir $ die $
+ "The directory \"" ++ pkgdir' ++ "\" already exists, not unpacking."
+ existsFile <- doesFileExist pkgdir
+ when existsFile $ die $
+ "A file \"" ++ pkgdir ++ "\" is in the way, not unpacking."
+ notice verbosity $ "Unpacking to " ++ pkgdir'
+ Tar.extractTarGzFile prefix pkgdirname pkgPath
diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Update.hs b/cabal/cabal-install/Distribution/Client/Update.hs
index 87f10fa..1de171d 100644
--- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Update.hs
+++ b/cabal/cabal-install/Distribution/Client/Update.hs
@@ -15,12 +15,12 @@ module Distribution.Client.Update
) where
import Distribution.Client.Types
- ( Repo(..), RemoteRepo(..), LocalRepo(..), AvailablePackageDb(..) )
-import Distribution.Client.Fetch
+ ( Repo(..), RemoteRepo(..), LocalRepo(..), SourcePackageDb(..) )
+import Distribution.Client.FetchUtils
( downloadIndex )
import qualified Distribution.Client.PackageIndex as PackageIndex
import Distribution.Client.IndexUtils
- ( getAvailablePackages )
+ ( getSourcePackages )
import qualified Paths_cabal_install
( version )
@@ -63,14 +63,14 @@ updateRepo verbosity repo = case repoKind repo of
checkForSelfUpgrade :: Verbosity -> [Repo] -> IO ()
checkForSelfUpgrade verbosity repos = do
- AvailablePackageDb available prefs <- getAvailablePackages verbosity repos
+ SourcePackageDb sourcePkgIndex prefs <- getSourcePackages verbosity repos
let self = PackageName "cabal-install"
preferredVersionRange = fromMaybe anyVersion (Map.lookup self prefs)
currentVersion = Paths_cabal_install.version
laterPreferredVersions =
[ packageVersion pkg
- | pkg <- PackageIndex.lookupPackageName available self
+ | pkg <- PackageIndex.lookupPackageName sourcePkgIndex self
, let version = packageVersion pkg
, version > currentVersion
, version `withinRange` preferredVersionRange ]
diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Upload.hs b/cabal/cabal-install/Distribution/Client/Upload.hs
index 1e812c7..eb9f892 100644
--- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Upload.hs
+++ b/cabal/cabal-install/Distribution/Client/Upload.hs
@@ -63,27 +63,38 @@ upload verbosity repos mUsername mPassword paths = do
handlePackage verbosity uploadURI auth path
where
targetRepoURI = remoteRepoURI $ last [ remoteRepo | Left remoteRepo <- map repoKind repos ] --FIXME: better error message when no repos are given
- promptUsername :: IO Username
- promptUsername = do
- putStr "Hackage username: "
- hFlush stdout
- fmap Username getLine
-
- promptPassword :: IO Password
- promptPassword = do
- putStr "Hackage password: "
- hFlush stdout
- -- save/restore the terminal echoing status
- passwd <- bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do
- hSetEcho stdin False -- no echoing for entering the password
- fmap Password getLine
- putStrLn ""
- return passwd
-
-report :: Verbosity -> [Repo] -> IO ()
-report verbosity repos
- = forM_ repos $ \repo ->
- case repoKind repo of
+
+promptUsername :: IO Username
+promptUsername = do
+ putStr "Hackage username: "
+ hFlush stdout
+ fmap Username getLine
+
+promptPassword :: IO Password
+promptPassword = do
+ putStr "Hackage password: "
+ hFlush stdout
+ -- save/restore the terminal echoing status
+ passwd <- bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do
+ hSetEcho stdin False -- no echoing for entering the password
+ fmap Password getLine
+ putStrLn ""
+ return passwd
+
+report :: Verbosity -> [Repo] -> Maybe Username -> Maybe Password -> IO ()
+report verbosity repos mUsername mPassword = do
+ let uploadURI = if isOldHackageURI targetRepoURI
+ then legacyUploadURI
+ else targetRepoURI{uriPath = ""}
+ Username username <- maybe promptUsername return mUsername
+ Password password <- maybe promptPassword return mPassword
+ let auth = addAuthority AuthBasic {
+ auRealm = "Hackage",
+ auUsername = username,
+ auPassword = password,
+ auSite = uploadURI
+ }
+ forM_ repos $ \repo -> case repoKind repo of
Left remoteRepo
-> do dotCabal <- defaultCabalDir
let srcDir = dotCabal </> "reports" </> remoteRepoName remoteRepo
@@ -95,9 +106,11 @@ report verbosity repos
Left errs -> do warn verbosity $ "Errors: " ++ errs -- FIXME
Right report' ->
do info verbosity $ "Uploading report for " ++ display (BuildReport.package report')
- browse $ BuildReport.uploadReports (remoteRepoURI remoteRepo) [(report', Just buildLog)]
+ browse $ BuildReport.uploadReports (remoteRepoURI remoteRepo) [(report', Just buildLog)] auth
return ()
Right{} -> return ()
+ where
+ targetRepoURI = remoteRepoURI $ last [ remoteRepo | Left remoteRepo <- map repoKind repos ] --FIXME: better error message when no repos are given
check :: Verbosity -> [FilePath] -> IO ()
check verbosity paths = do
diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Utils.hs b/cabal/cabal-install/Distribution/Client/Utils.hs
index 39035b9..39035b9 100644
--- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Utils.hs
+++ b/cabal/cabal-install/Distribution/Client/Utils.hs
diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Win32SelfUpgrade.hs b/cabal/cabal-install/Distribution/Client/Win32SelfUpgrade.hs
index 0417122..0417122 100644
--- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Win32SelfUpgrade.hs
+++ b/cabal/cabal-install/Distribution/Client/Win32SelfUpgrade.hs
diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/World.hs b/cabal/cabal-install/Distribution/Client/World.hs
index 5c53512..12cfab2 100644
--- a/cabal-install-0.9.5_rc20101226/Distribution/Client/World.hs
+++ b/cabal/cabal-install/Distribution/Client/World.hs
@@ -23,59 +23,71 @@
--
-----------------------------------------------------------------------------
module Distribution.Client.World (
+ WorldPkgInfo(..),
insert,
delete,
getContents,
-
- worldPkg,
- isWorldTarget,
- isGoodWorldTarget,
) where
-import Distribution.Simple.Utils( writeFileAtomic )
-import Distribution.Client.Types
- ( UnresolvedDependency(..) )
import Distribution.Package
- ( PackageName(..), Dependency( Dependency ) )
-import Distribution.Version( anyVersion )
-import Distribution.Text( display, simpleParse )
-import Distribution.Verbosity ( Verbosity )
-import Distribution.Simple.Utils ( die, info, chattyTry )
-import Data.List( unionBy, deleteFirstsBy, nubBy )
-import Data.Maybe( isJust, fromJust )
-import System.IO.Error( isDoesNotExistError, )
+ ( Dependency(..) )
+import Distribution.PackageDescription
+ ( FlagAssignment, FlagName(FlagName) )
+import Distribution.Verbosity
+ ( Verbosity )
+import Distribution.Simple.Utils
+ ( die, info, chattyTry, writeFileAtomic )
+import Distribution.Text
+ ( Text(..), display, simpleParse )
+import qualified Distribution.Compat.ReadP as Parse
+import qualified Text.PrettyPrint as Disp
+import Text.PrettyPrint ( (<>), (<+>) )
+
+
+import Data.Char as Char
+
+import Data.List
+ ( unionBy, deleteFirstsBy, nubBy )
+import Data.Maybe
+ ( isJust, fromJust )
+import System.IO.Error
+ ( isDoesNotExistError )
import qualified Data.ByteString.Lazy.Char8 as B
-import Prelude hiding ( getContents )
+import Prelude hiding (getContents)
+
+
+data WorldPkgInfo = WorldPkgInfo Dependency FlagAssignment
+ deriving (Show,Eq)
-- | Adds packages to the world file; creates the file if it doesn't
-- exist yet. Version constraints and flag assignments for a package are
-- updated if already present. IO errors are non-fatal.
-insert :: Verbosity -> FilePath -> [UnresolvedDependency] -> IO ()
+insert :: Verbosity -> FilePath -> [WorldPkgInfo] -> IO ()
insert = modifyWorld $ unionBy equalUDep
-- | Removes packages from the world file.
-- Note: Currently unused as there is no mechanism in Cabal (yet) to
-- handle uninstalls. IO errors are non-fatal.
-delete :: Verbosity -> FilePath -> [UnresolvedDependency] -> IO ()
+delete :: Verbosity -> FilePath -> [WorldPkgInfo] -> IO ()
delete = modifyWorld $ flip (deleteFirstsBy equalUDep)
--- | UnresolvedDependency values are considered equal if they refer to
+-- | WorldPkgInfo values are considered equal if they refer to
-- the same package, i.e., we don't care about differing versions or flags.
-equalUDep :: UnresolvedDependency -> UnresolvedDependency -> Bool
-equalUDep (UnresolvedDependency (Dependency pkg1 _) _)
- (UnresolvedDependency (Dependency pkg2 _) _) = pkg1 == pkg2
+equalUDep :: WorldPkgInfo -> WorldPkgInfo -> Bool
+equalUDep (WorldPkgInfo (Dependency pkg1 _) _)
+ (WorldPkgInfo (Dependency pkg2 _) _) = pkg1 == pkg2
-- | Modifies the world file by applying an update-function ('unionBy'
-- for 'insert', 'deleteFirstsBy' for 'delete') to the given list of
-- packages. IO errors are considered non-fatal.
-modifyWorld :: ([UnresolvedDependency] -> [UnresolvedDependency]
- -> [UnresolvedDependency])
+modifyWorld :: ([WorldPkgInfo] -> [WorldPkgInfo]
+ -> [WorldPkgInfo])
-- ^ Function that defines how
-- the list of user packages are merged with
-- existing world packages.
-> Verbosity
-> FilePath -- ^ Location of the world file
- -> [UnresolvedDependency] -- ^ list of user supplied packages
+ -> [WorldPkgInfo] -- ^ list of user supplied packages
-> IO ()
modifyWorld _ _ _ [] = return ()
modifyWorld f verbosity world pkgs =
@@ -96,7 +108,7 @@ modifyWorld f verbosity world pkgs =
-- | Returns the content of the world file as a list
-getContents :: FilePath -> IO [UnresolvedDependency]
+getContents :: FilePath -> IO [WorldPkgInfo]
getContents world = do
content <- safelyReadFile world
let result = map simpleParse (lines $ B.unpack content)
@@ -111,22 +123,51 @@ getContents world = do
| otherwise = ioError e
--- | A dummy package that represents the world file.
-worldPkg :: PackageName
-worldPkg = PackageName "world"
+instance Text WorldPkgInfo where
+ disp (WorldPkgInfo dep flags) = disp dep <+> dispFlags flags
+ where
+ dispFlags [] = Disp.empty
+ dispFlags fs = Disp.text "--flags="
+ <> Disp.doubleQuotes (flagAssToDoc fs)
+ flagAssToDoc = foldr (\(FlagName fname,val) flagAssDoc ->
+ (if not val then Disp.char '-'
+ else Disp.empty)
+ Disp.<> Disp.text fname
+ Disp.<+> flagAssDoc)
+ Disp.empty
+ parse = do
+ dep <- parse
+ Parse.skipSpaces
+ flagAss <- Parse.option [] parseFlagAssignment
+ return $ WorldPkgInfo dep flagAss
+ where
+ parseFlagAssignment :: Parse.ReadP r FlagAssignment
+ parseFlagAssignment = do
+ _ <- Parse.string "--flags"
+ Parse.skipSpaces
+ _ <- Parse.char '='
+ Parse.skipSpaces
+ inDoubleQuotes $ Parse.many1 flag
+ where
+ inDoubleQuotes :: Parse.ReadP r a -> Parse.ReadP r a
+ inDoubleQuotes = Parse.between (Parse.char '"') (Parse.char '"')
--- | Currently we have a silly way of representing the world target as
--- an 'UnresolvedDependency' so we need a way to recognise it.
---
--- We should be using a structured type with various target kinds, like
--- local file, repo package etc.
---
-isWorldTarget :: UnresolvedDependency -> Bool
-isWorldTarget (UnresolvedDependency (Dependency pkg _) _) =
- pkg == worldPkg
-
-isGoodWorldTarget :: UnresolvedDependency -> Bool
-isGoodWorldTarget (UnresolvedDependency (Dependency pkg ver) flags) =
- pkg == worldPkg
- && ver == anyVersion
- && null flags
+ flag = do
+ Parse.skipSpaces
+ val <- negative Parse.+++ positive
+ name <- ident
+ Parse.skipSpaces
+ return (FlagName name,val)
+ negative = do
+ _ <- Parse.char '-'
+ return False
+ positive = return True
+
+ ident :: Parse.ReadP r String
+ ident = do
+ -- First character must be a letter/digit to avoid flags
+ -- like "+-debug":
+ c <- Parse.satisfy Char.isAlphaNum
+ cs <- Parse.munch (\ch -> Char.isAlphaNum ch || ch == '_'
+ || ch == '-')
+ return (c:cs)
diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Compat/Exception.hs b/cabal/cabal-install/Distribution/Compat/ExceptionCI.hs
index 2baafb5..5ee8c8f 100644
--- a/cabal-install-0.9.5_rc20101226/Distribution/Compat/Exception.hs
+++ b/cabal/cabal-install/Distribution/Compat/ExceptionCI.hs
@@ -3,7 +3,7 @@
{-# OPTIONS_NHC98 -cpp #-}
{-# OPTIONS_JHC -fcpp #-}
-- #hide
-module Distribution.Compat.Exception (
+module Distribution.Compat.ExceptionCI (
SomeException,
onException,
catchIO,
diff --git a/cabal/cabal-install/Distribution/Compat/FilePerms.hs b/cabal/cabal-install/Distribution/Compat/FilePerms.hs
new file mode 100644
index 0000000..692d7a1
--- /dev/null
+++ b/cabal/cabal-install/Distribution/Compat/FilePerms.hs
@@ -0,0 +1,40 @@
+{-# LANGUAGE CPP #-}
+-- #hide
+module Distribution.Compat.FilePerms (
+ setFileOrdinary,
+ setFileExecutable,
+ ) where
+
+#ifndef mingw32_HOST_OS
+import System.Posix.Types
+ ( FileMode )
+import System.Posix.Internals
+ ( c_chmod )
+import Foreign.C
+ ( withCString )
+#if MIN_VERSION_base(4,0,0)
+import Foreign.C
+ ( throwErrnoPathIfMinus1_ )
+#else
+import Foreign.C
+ ( throwErrnoIfMinus1_ )
+#endif
+#endif /* mingw32_HOST_OS */
+
+setFileOrdinary, setFileExecutable :: FilePath -> IO ()
+#ifndef mingw32_HOST_OS
+setFileOrdinary path = setFileMode path 0o644 -- file perms -rw-r--r--
+setFileExecutable path = setFileMode path 0o755 -- file perms -rwxr-xr-x
+
+setFileMode :: FilePath -> FileMode -> IO ()
+setFileMode name m =
+ withCString name $ \s -> do
+#if __GLASGOW_HASKELL__ >= 608
+ throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m)
+#else
+ throwErrnoIfMinus1_ name (c_chmod s m)
+#endif
+#else
+setFileOrdinary _ = return ()
+setFileExecutable _ = return ()
+#endif
diff --git a/cabal-install-0.9.5_rc20101226/LICENSE b/cabal/cabal-install/LICENSE
index 0d5bcda..0d5bcda 100644
--- a/cabal-install-0.9.5_rc20101226/LICENSE
+++ b/cabal/cabal-install/LICENSE
diff --git a/cabal-install-0.9.5_rc20101226/Main.hs b/cabal/cabal-install/Main.hs
index 31b6a9c..bb6057e 100644
--- a/cabal-install-0.9.5_rc20101226/Main.hs
+++ b/cabal/cabal-install/Main.hs
@@ -25,10 +25,10 @@ import Distribution.Client.Setup
, ListFlags(..), listCommand
, InfoFlags(..), infoCommand
, UploadFlags(..), uploadCommand
+ , ReportFlags(..), reportCommand
, InitFlags, initCommand
, reportCommand
- , unpackCommand, UnpackFlags(..)
- , parsePackageArgs )
+ , unpackCommand, UnpackFlags(..) )
import Distribution.Simple.Setup
( BuildFlags(..), buildCommand
, HaddockFlags(..), haddockCommand
@@ -40,12 +40,13 @@ import Distribution.Simple.Setup
, TestFlags(..), testCommand
, Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe )
-import Distribution.Client.Types
- ( UnresolvedDependency(UnresolvedDependency) )
import Distribution.Client.SetupWrapper
( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )
import Distribution.Client.Config
( SavedConfig(..), loadConfig, defaultConfigFile )
+import Distribution.Client.Targets
+ ( readUserTargets )
+
import Distribution.Client.List (list, info)
import Distribution.Client.Install (install, upgrade)
import Distribution.Client.Configure (configure)
@@ -60,8 +61,9 @@ import Distribution.Client.Init (initCabal)
import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade
import Distribution.Simple.Compiler
- ( PackageDB(..), PackageDBStack )
-import Distribution.Simple.Program (defaultProgramConfiguration)
+ ( Compiler, PackageDB(..), PackageDBStack )
+import Distribution.Simple.Program
+ ( ProgramConfiguration, defaultProgramConfiguration )
import Distribution.Simple.Command
import Distribution.Simple.Configure (configCompilerAux)
import Distribution.Simple.Utils
@@ -69,7 +71,7 @@ import Distribution.Simple.Utils
import Distribution.Text
( display )
import Distribution.Verbosity as Verbosity
- ( Verbosity, normal, intToVerbosity )
+ ( Verbosity, normal, intToVerbosity, lessVerbose )
import qualified Paths_cabal_install (version)
import System.Environment (getArgs, getProgName)
@@ -192,8 +194,8 @@ installAction (configFlags, _, installFlags) _ _globalFlags
installAction (configFlags, configExFlags, installFlags)
extraArgs globalFlags = do
- pkgs <- either die return (parsePackageArgs extraArgs)
let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
+ targets <- readUserTargets verbosity extraArgs
config <- loadConfig verbosity (globalConfigFile globalFlags)
(configUserInstall configFlags)
let configFlags' = savedConfigureFlags config `mappend` configFlags
@@ -201,12 +203,11 @@ installAction (configFlags, configExFlags, installFlags)
installFlags' = defaultInstallFlags `mappend`
savedInstallFlags config `mappend` installFlags
globalFlags' = savedGlobalFlags config `mappend` globalFlags
- (comp, conf) <- configCompilerAux configFlags'
+ (comp, conf) <- configCompilerAux' configFlags'
install verbosity
(configPackageDB' configFlags') (globalRepos globalFlags')
comp conf globalFlags' configFlags' configExFlags' installFlags'
- [ UnresolvedDependency pkg (configConfigurationsFlags configFlags')
- | pkg <- pkgs ]
+ targets
listAction :: ListFlags -> [String] -> GlobalFlags -> IO ()
listAction listFlags extraArgs globalFlags = do
@@ -214,7 +215,7 @@ listAction listFlags extraArgs globalFlags = do
config <- loadConfig verbosity (globalConfigFile globalFlags) mempty
let configFlags = savedConfigureFlags config
globalFlags' = savedGlobalFlags config `mappend` globalFlags
- (comp, conf) <- configCompilerAux configFlags
+ (comp, conf) <- configCompilerAux' configFlags
list verbosity
(configPackageDB' configFlags)
(globalRepos globalFlags')
@@ -225,8 +226,8 @@ listAction listFlags extraArgs globalFlags = do
infoAction :: InfoFlags -> [String] -> GlobalFlags -> IO ()
infoAction infoFlags extraArgs globalFlags = do
- pkgs <- either die return (parsePackageArgs extraArgs)
let verbosity = fromFlag (infoVerbosity infoFlags)
+ targets <- readUserTargets verbosity extraArgs
config <- loadConfig verbosity (globalConfigFile globalFlags) mempty
let configFlags = savedConfigureFlags config
globalFlags' = savedGlobalFlags config `mappend` globalFlags
@@ -236,8 +237,9 @@ infoAction infoFlags extraArgs globalFlags = do
(globalRepos globalFlags')
comp
conf
+ globalFlags'
infoFlags
- [ UnresolvedDependency pkg [] | pkg <- pkgs ]
+ targets
updateAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO ()
updateAction verbosityFlag extraArgs globalFlags = do
@@ -252,8 +254,8 @@ upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags)
-> [String] -> GlobalFlags -> IO ()
upgradeAction (configFlags, configExFlags, installFlags)
extraArgs globalFlags = do
- pkgs <- either die return (parsePackageArgs extraArgs)
let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
+ targets <- readUserTargets verbosity extraArgs
config <- loadConfig verbosity (globalConfigFile globalFlags)
(configUserInstall configFlags)
let configFlags' = savedConfigureFlags config `mappend` configFlags
@@ -261,26 +263,24 @@ upgradeAction (configFlags, configExFlags, installFlags)
installFlags' = defaultInstallFlags `mappend`
savedInstallFlags config `mappend` installFlags
globalFlags' = savedGlobalFlags config `mappend` globalFlags
- (comp, conf) <- configCompilerAux configFlags'
+ (comp, conf) <- configCompilerAux' configFlags'
upgrade verbosity
(configPackageDB' configFlags') (globalRepos globalFlags')
comp conf globalFlags' configFlags' configExFlags' installFlags'
- [ UnresolvedDependency pkg (configConfigurationsFlags configFlags')
- | pkg <- pkgs ]
+ targets
fetchAction :: FetchFlags -> [String] -> GlobalFlags -> IO ()
fetchAction fetchFlags extraArgs globalFlags = do
- pkgs <- either die return (parsePackageArgs extraArgs)
let verbosity = fromFlag (fetchVerbosity fetchFlags)
+ targets <- readUserTargets verbosity extraArgs
config <- loadConfig verbosity (globalConfigFile globalFlags) mempty
let configFlags = savedConfigureFlags config
globalFlags' = savedGlobalFlags config `mappend` globalFlags
- (comp, conf) <- configCompilerAux configFlags
+ (comp, conf) <- configCompilerAux' configFlags
fetch verbosity
(configPackageDB' configFlags) (globalRepos globalFlags')
- comp conf fetchFlags
- [ UnresolvedDependency pkg [] --TODO: flags?
- | pkg <- pkgs ]
+ comp conf globalFlags' fetchFlags
+ targets
uploadAction :: UploadFlags -> [String] -> GlobalFlags -> IO ()
uploadAction uploadFlags extraArgs globalFlags = do
@@ -328,23 +328,31 @@ sdistAction sflags extraArgs _globalFlags = do
die $ "'sdist' doesn't take any extra arguments: " ++ unwords extraArgs
sdist sflags
-reportAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO ()
-reportAction verbosityFlag extraArgs globalFlags = do
+reportAction :: ReportFlags -> [String] -> GlobalFlags -> IO ()
+reportAction reportFlags extraArgs globalFlags = do
unless (null extraArgs) $ do
die $ "'report' doesn't take any extra arguments: " ++ unwords extraArgs
- let verbosity = fromFlag verbosityFlag
+ let verbosity = fromFlag (reportVerbosity reportFlags)
config <- loadConfig verbosity (globalConfigFile globalFlags) mempty
let globalFlags' = savedGlobalFlags config `mappend` globalFlags
+ reportFlags' = savedReportFlags config `mappend` reportFlags
Upload.report verbosity (globalRepos globalFlags')
+ (flagToMaybe $ reportUsername reportFlags')
+ (flagToMaybe $ reportPassword reportFlags')
unpackAction :: UnpackFlags -> [String] -> GlobalFlags -> IO ()
-unpackAction flags extraArgs globalFlags = do
- pkgs <- either die return (parsePackageArgs extraArgs)
- let verbosity = fromFlag (unpackVerbosity flags)
+unpackAction unpackFlags extraArgs globalFlags = do
+ let verbosity = fromFlag (unpackVerbosity unpackFlags)
+ targets <- readUserTargets verbosity extraArgs
config <- loadConfig verbosity (globalConfigFile globalFlags) mempty
- unpack flags (globalRepos (savedGlobalFlags config)) pkgs
+ let globalFlags' = savedGlobalFlags config `mappend` globalFlags
+ unpack verbosity
+ (globalRepos (savedGlobalFlags config))
+ globalFlags'
+ unpackFlags
+ targets
initAction :: InitFlags -> [String] -> GlobalFlags -> IO ()
initAction flags _extraArgs _globalFlags = do
@@ -386,3 +394,10 @@ configPackageDB' cfg =
implicitPackageDbStack userInstall (flagToMaybe (configPackageDB cfg))
where
userInstall = fromFlagOrDefault True (configUserInstall cfg)
+
+configCompilerAux' :: ConfigFlags
+ -> IO (Compiler, ProgramConfiguration)
+configCompilerAux' configFlags =
+ configCompilerAux configFlags
+ --FIXME: make configCompilerAux use a sensible verbosity
+ { configVerbosity = fmap lessVerbose (configVerbosity configFlags) }
diff --git a/cabal-install-0.9.5_rc20101226/Paths_cabal_install.hs b/cabal/cabal-install/Paths_cabal_install.hs
index 4398934..25a44b7 100644
--- a/cabal-install-0.9.5_rc20101226/Paths_cabal_install.hs
+++ b/cabal/cabal-install/Paths_cabal_install.hs
@@ -5,4 +5,4 @@ module Paths_cabal_install (
import Data.Version (Version(..))
version :: Version
-version = Version {versionBranch = [0,9,5], versionTags = []}
+version = Version {versionBranch = [0,12,0], versionTags = []}
diff --git a/cabal-install-0.9.5_rc20101226/README b/cabal/cabal-install/README
index 8c7053c..04331dc 100644
--- a/cabal-install-0.9.5_rc20101226/README
+++ b/cabal/cabal-install/README
@@ -19,7 +19,7 @@ debian or ubuntu it is in "libghc6-network-dev".
It requires a few other Haskell packages that are not always installed:
- * Cabal (version 1.8 or later)
+ * Cabal (version 1.10 or later)
* HTTP (version 4000 or later)
* zlib (version 0.4 or later)
diff --git a/cabal-install-0.9.5_rc20101226/Setup.hs b/cabal/cabal-install/Setup.hs
index 9a994af..9a994af 100644
--- a/cabal-install-0.9.5_rc20101226/Setup.hs
+++ b/cabal/cabal-install/Setup.hs
diff --git a/cabal-install-0.9.5_rc20101226/bash-completion/cabal b/cabal/cabal-install/bash-completion/cabal
index 8ebfabc..8ebfabc 100644
--- a/cabal-install-0.9.5_rc20101226/bash-completion/cabal
+++ b/cabal/cabal-install/bash-completion/cabal
diff --git a/cabal-install-0.9.5_rc20101226/bootstrap.sh b/cabal/cabal-install/bootstrap.sh
index ecacd73..b9950e7 100644
--- a/cabal-install-0.9.5_rc20101226/bootstrap.sh
+++ b/cabal/cabal-install/bootstrap.sh
@@ -16,6 +16,7 @@ GHC=${GHC:-ghc}
GHC_PKG=${GHC_PKG:-ghc-pkg}
WGET=${WGET:-wget}
CURL=${CURL:-curl}
+FETCH=${FETCH:-fetch}
TAR=${TAR:-tar}
GUNZIP=${GUNZIP:-gunzip}
SCOPE_OF_INSTALLATION="--user"
@@ -37,7 +38,7 @@ do
echo
echo "options:"
echo " --user Install for the local user (default)"
- echo " --global Install systemwide"
+ echo " --global Install systemwide (must be run as root)"
exit;;
esac
done
@@ -45,13 +46,14 @@ done
# Versions of the packages to install.
# The version regex says what existing installed versions are ok.
-PARSEC_VER="2.1.0.1"; PARSEC_VER_REGEXP="2\." # == 2.*
-NETWORK_VER="2.2.1.10"; NETWORK_VER_REGEXP="2\." # == 2.*
-CABAL_VER="1.10.0.0"; CABAL_VER_REGEXP="1\.10\." # == 1.10.*
-MTL_VER="1.1.1.0"; MTL_VER_REGEXP="1\.1\." # == 1.1.*
-HTTP_VER="4000.0.10"; HTTP_VER_REGEXP="4000\.0" # == 4000.0.*
-ZLIB_VER="0.5.2.0"; ZLIB_VER_REGEXP="0\.[45]\." # == 0.4.* || ==0.5.*
-TIME_VER="1.2.0.3" TIME_VER_REGEXP="1\.[12]\." # == 0.1.* || ==0.2.*
+PARSEC_VER="3.1.1"; PARSEC_VER_REGEXP="[23]\." # == 2.* || == 3.*
+NETWORK_VER="2.3.0.2"; NETWORK_VER_REGEXP="2\." # == 2.*
+CABAL_VER="1.10.1.0"; CABAL_VER_REGEXP="1\.10\.[^0]" # == 1.10.* && >= 1.10.1
+TRANS_VER="0.2.2.0"; TRANS_VER_REGEXP="0\.2\." # == 0.2.*
+MTL_VER="2.0.1.0"; MTL_VER_REGEXP="[12]\." # == 1.* || == 2.*
+HTTP_VER="4000.1.1"; HTTP_VER_REGEXP="4000\.[01]\." # == 4000.0.* || 4000.1.*
+ZLIB_VER="0.5.3.1"; ZLIB_VER_REGEXP="0\.[45]\." # == 0.4.* || ==0.5.*
+TIME_VER="1.2.0.4" TIME_VER_REGEXP="1\.[12]\." # == 0.1.* || ==0.2.*
HACKAGE_URL="http://hackage.haskell.org/packages/archive"
@@ -77,7 +79,7 @@ GHC_PKG_VER=`${GHC_PKG} --version | cut -d' ' -f 5`
# Cache the list of packages:
echo "Checking installed packages for ghc-${GHC_VER}..."
-${GHC_PKG} list > ghc-pkg.list \
+${GHC_PKG} list --global ${SCOPE_OF_INSTALLATION} > ghc-pkg.list \
|| die "running '${GHC_PKG} list' failed"
# Will we need to install this package, or is a suitable version installed?
@@ -106,23 +108,6 @@ info_pkg () {
fi
}
-dep_pkg () {
- PKG=$1
- VER_MATCH=$2
- if need_pkg ${PKG} ${VER_MATCH}
- then
- echo
- echo "The Haskell package '${PKG}' is required but it is not installed."
- echo "If you are using a ghc package provided by your operating system"
- echo "then install the corresponding packages for 'parsec' and 'network'."
- echo "If you built ghc from source with only the core libraries then you"
- echo "should install these extra packages. You can get them from hackage."
- die "The Haskell package '${PKG}' is required but it is not installed."
- else
- echo "${PKG} is already installed and the version is ok."
- fi
-}
-
fetch_pkg () {
PKG=$1
VER=$2
@@ -130,12 +115,15 @@ fetch_pkg () {
URL=${HACKAGE_URL}/${PKG}/${VER}/${PKG}-${VER}.tar.gz
if which ${CURL} > /dev/null
then
- ${CURL} -C - -O ${URL} || die "Failed to download ${PKG}."
+ ${CURL} --fail -C - -O ${URL} || die "Failed to download ${PKG}."
elif which ${WGET} > /dev/null
then
${WGET} -c ${URL} || die "Failed to download ${PKG}."
+ elif which ${FETCH} > /dev/null
+ then
+ ${FETCH} ${URL} || die "Failed to download ${PKG}."
else
- die "Failed to find a downloader. 'wget' or 'curl' is required."
+ die "Failed to find a downloader. 'curl', 'wget' or 'fetch' is required."
fi
[ -f "${PKG}-${VER}.tar.gz" ] \
|| die "Downloading ${URL} did not create ${PKG}-${VER}.tar.gz"
@@ -195,21 +183,23 @@ do_pkg () {
# Actually do something!
-info_pkg "parsec" ${PARSEC_VER} ${PARSEC_VER_REGEXP}
-info_pkg "network" ${NETWORK_VER} ${NETWORK_VER_REGEXP}
-info_pkg "Cabal" ${CABAL_VER} ${CABAL_VER_REGEXP}
-info_pkg "mtl" ${MTL_VER} ${MTL_VER_REGEXP}
-info_pkg "time" ${TIME_VER} ${TIME_VER_REGEXP}
-info_pkg "HTTP" ${HTTP_VER} ${HTTP_VER_REGEXP}
-info_pkg "zlib" ${ZLIB_VER} ${ZLIB_VER_REGEXP}
-
-do_pkg "parsec" ${PARSEC_VER} ${PARSEC_VER_REGEXP}
-do_pkg "network" ${NETWORK_VER} ${NETWORK_VER_REGEXP}
-do_pkg "Cabal" ${CABAL_VER} ${CABAL_VER_REGEXP}
-do_pkg "mtl" ${MTL_VER} ${MTL_VER_REGEXP}
-do_pkg "time" ${TIME_VER} ${TIME_VER_REGEXP}
-do_pkg "HTTP" ${HTTP_VER} ${HTTP_VER_REGEXP}
-do_pkg "zlib" ${ZLIB_VER} ${ZLIB_VER_REGEXP}
+info_pkg "Cabal" ${CABAL_VER} ${CABAL_VER_REGEXP}
+info_pkg "transformers" ${TRANS_VER} ${TRANS_VER_REGEXP}
+info_pkg "mtl" ${MTL_VER} ${MTL_VER_REGEXP}
+info_pkg "parsec" ${PARSEC_VER} ${PARSEC_VER_REGEXP}
+info_pkg "network" ${NETWORK_VER} ${NETWORK_VER_REGEXP}
+info_pkg "time" ${TIME_VER} ${TIME_VER_REGEXP}
+info_pkg "HTTP" ${HTTP_VER} ${HTTP_VER_REGEXP}
+info_pkg "zlib" ${ZLIB_VER} ${ZLIB_VER_REGEXP}
+
+do_pkg "Cabal" ${CABAL_VER} ${CABAL_VER_REGEXP}
+do_pkg "transformers" ${TRANS_VER} ${TRANS_VER_REGEXP}
+do_pkg "mtl" ${MTL_VER} ${MTL_VER_REGEXP}
+do_pkg "parsec" ${PARSEC_VER} ${PARSEC_VER_REGEXP}
+do_pkg "network" ${NETWORK_VER} ${NETWORK_VER_REGEXP}
+do_pkg "time" ${TIME_VER} ${TIME_VER_REGEXP}
+do_pkg "HTTP" ${HTTP_VER} ${HTTP_VER_REGEXP}
+do_pkg "zlib" ${ZLIB_VER} ${ZLIB_VER_REGEXP}
install_pkg "cabal-install"
diff --git a/cabal-install-0.9.5_rc20101226/cabal-install.cabal b/cabal/cabal-install/cabal-install.cabal
index b143d2f..d0a17c2 100644
--- a/cabal-install-0.9.5_rc20101226/cabal-install.cabal
+++ b/cabal/cabal-install/cabal-install.cabal
@@ -1,5 +1,5 @@
Name: cabal-install
-Version: 0.9.5
+Version: 0.11.2
Synopsis: The command-line interface for Cabal and Hackage.
Description:
The \'cabal\' command-line program simplifies the process of managing
@@ -13,13 +13,13 @@ Author: Lemmih <lemmih@gmail.com>
Paolo Martini <paolo@nemail.it>
Bjorn Bringert <bjorn@bringert.net>
Isaac Potoczny-Jones <ijones@syntaxpolice.org>
- Duncan Coutts <duncan@haskell.org>
+ Duncan Coutts <duncan@community.haskell.org>
Maintainer: cabal-devel@haskell.org
Copyright: 2005 Lemmih <lemmih@gmail.com>
2006 Paolo Martini <paolo@nemail.it>
2007 Bjorn Bringert <bjorn@bringert.net>
2007 Isaac Potoczny-Jones <ijones@syntaxpolice.org>
- 2007-2010 Duncan Coutts <duncan@haskell.org>
+ 2007-2011 Duncan Coutts <duncan@community.haskell.org>
Category: Distribution
Build-type: Simple
Extra-Source-Files: README bash-completion/cabal bootstrap.sh
@@ -56,6 +56,7 @@ Executable cabal
Distribution.Client.Dependency.TopDown.Types
Distribution.Client.Dependency.Types
Distribution.Client.Fetch
+ Distribution.Client.FetchUtils
Distribution.Client.GZipUtils
Distribution.Client.Haddock
Distribution.Client.HttpUtils
@@ -74,6 +75,7 @@ Executable cabal
Distribution.Client.SetupWrapper
Distribution.Client.SrcDist
Distribution.Client.Tar
+ Distribution.Client.Targets
Distribution.Client.Types
Distribution.Client.Unpack
Distribution.Client.Update
@@ -82,10 +84,11 @@ Executable cabal
Distribution.Client.World
Distribution.Client.Win32SelfUpgrade
Distribution.Compat.Exception
+ Distribution.Compat.FilePerms
Paths_cabal_install
build-depends: base >= 2 && < 5,
- Cabal >= 1.10 && < 1.11,
+ Cabal >= 1.10.1 && < 1.11.3,
filepath >= 1.0 && < 1.3,
network >= 1 && < 3,
HTTP >= 4000.0.2 && < 4001,
diff --git a/cabal-install-0.9.5_rc20101226/changelog b/cabal/cabal-install/changelog
index bf0df48..0292a09 100644
--- a/cabal-install-0.9.5_rc20101226/changelog
+++ b/cabal/cabal-install/changelog
@@ -1,5 +1,26 @@
-*-change-log-*-
+0.10.0 Duncan Coutts <duncan@community.haskell.org> February 2011
+ * New package targets: local dirs, local and remote tarballs
+ * Initial support for a "world" package target
+ * Partial fix for situation where user packages mask global ones
+ * Removed cabal upgrade, new --upgrade-dependencies flag
+ * New cabal install --only-dependencies flag
+ * New cabal fetch --no-dependencies and --dry-run flags
+ * Improved output for cabal info
+ * Simpler and faster bash command line completion
+ * Fix for broken proxies that decompress wrongly
+ * Fix for cabal unpack to preserve executable permissions
+ * Adjusted the output for the -v verbosity level in a few places
+
+0.8.2 Duncan Coutts <duncan@community.haskell.org> March 2010
+ * Fix for cabal update on Windows
+ * On windows switch to per-user installs (rather than global)
+ * Handle intra-package dependencies in dependency planning
+ * Minor tweaks to cabal init feature
+ * Fix various -Wall warnings
+ * Fix for cabal sdist --snapshot
+
0.8.0 Duncan Coutts <duncan@haskell.org> Dec 2009
* Works with ghc-6.12
* New "cabal init" command for making initial project .cabal file
diff --git a/cabal-install-0.9.5_rc20101226/tests/test-cabal-install b/cabal/cabal-install/tests/test-cabal-install
index 431afa1..431afa1 100644
--- a/cabal-install-0.9.5_rc20101226/tests/test-cabal-install
+++ b/cabal/cabal-install/tests/test-cabal-install
diff --git a/cabal-install-0.9.5_rc20101226/tests/test-cabal-install-user b/cabal/cabal-install/tests/test-cabal-install-user
index 057494a..057494a 100644
--- a/cabal-install-0.9.5_rc20101226/tests/test-cabal-install-user
+++ b/cabal/cabal-install/tests/test-cabal-install-user
diff --git a/cabal/cabal/Cabal.cabal b/cabal/cabal/Cabal.cabal
new file mode 100644
index 0000000..403b450
--- /dev/null
+++ b/cabal/cabal/Cabal.cabal
@@ -0,0 +1,163 @@
+Name: Cabal
+Version: 1.12.0
+Copyright: 2003-2006, Isaac Jones
+ 2005-2011, Duncan Coutts
+License: BSD3
+License-File: LICENSE
+Author: Isaac Jones <ijones@syntaxpolice.org>
+ Duncan Coutts <duncan@community.haskell.org>
+Maintainer: cabal-devel@haskell.org
+Homepage: http://www.haskell.org/cabal/
+bug-reports: http://hackage.haskell.org/trac/hackage/
+Synopsis: A framework for packaging Haskell software
+Description:
+ The Haskell Common Architecture for Building Applications and
+ Libraries: a framework defining a common interface for authors to more
+ easily build their Haskell applications in a portable way.
+ .
+ The Haskell Cabal is part of a larger infrastructure for distributing,
+ organizing, and cataloging Haskell libraries and tools.
+Category: Distribution
+cabal-version: >=1.10
+Build-Type: Custom
+-- Even though we do use the default Setup.lhs it's vital to bootstrapping
+-- that we build Setup.lhs using our own local Cabal source code.
+
+Extra-Source-Files:
+ README changelog
+
+source-repository head
+ type: darcs
+ location: http://darcs.haskell.org/cabal/
+
+Flag base4
+ Description: Choose the even newer, even smaller, split-up base package.
+
+Flag base3
+ Description: Choose the new smaller, split-up base package.
+
+Library
+ build-depends: base >= 2 && < 5,
+ filepath >= 1 && < 1.3
+ if flag(base4) { build-depends: base >= 4 } else { build-depends: base < 4 }
+ if flag(base3) { build-depends: base >= 3 } else { build-depends: base < 3 }
+ if flag(base3)
+ Build-Depends: directory >= 1 && < 1.2,
+ process >= 1 && < 1.2,
+ old-time >= 1 && < 1.1,
+ containers >= 0.1 && < 0.5,
+ array >= 0.1 && < 0.4,
+ pretty >= 1 && < 1.2
+
+ if !os(windows)
+ Build-Depends: unix >= 2.0 && < 2.6
+
+ ghc-options: -Wall -fno-ignore-asserts
+ if impl(ghc >= 6.8)
+ ghc-options: -fwarn-tabs
+ nhc98-Options: -K4M
+
+ Exposed-Modules:
+ Distribution.Compiler,
+ Distribution.InstalledPackageInfo,
+ Distribution.License,
+ Distribution.Make,
+ Distribution.ModuleName,
+ Distribution.Package,
+ Distribution.PackageDescription,
+ Distribution.PackageDescription.Configuration,
+ Distribution.PackageDescription.Parse,
+ Distribution.PackageDescription.Check,
+ Distribution.PackageDescription.PrettyPrint,
+ Distribution.ParseUtils,
+ Distribution.ReadE,
+ Distribution.Simple,
+ Distribution.Simple.Build,
+ Distribution.Simple.Build.Macros,
+ Distribution.Simple.Build.PathsModule,
+ Distribution.Simple.BuildPaths,
+ Distribution.Simple.Command,
+ Distribution.Simple.Compiler,
+ Distribution.Simple.Configure,
+ Distribution.Simple.GHC,
+ Distribution.Simple.LHC,
+ Distribution.Simple.Haddock,
+ Distribution.Simple.Hpc,
+ Distribution.Simple.Hugs,
+ Distribution.Simple.Install,
+ Distribution.Simple.InstallDirs,
+ Distribution.Simple.JHC,
+ Distribution.Simple.LocalBuildInfo,
+ Distribution.Simple.NHC,
+ Distribution.Simple.PackageIndex,
+ Distribution.Simple.PreProcess,
+ Distribution.Simple.PreProcess.Unlit,
+ Distribution.Simple.Program,
+ Distribution.Simple.Program.Ar,
+ Distribution.Simple.Program.Builtin,
+ Distribution.Simple.Program.Db,
+ Distribution.Simple.Program.HcPkg,
+ Distribution.Simple.Program.Ld,
+ Distribution.Simple.Program.Run,
+ Distribution.Simple.Program.Script,
+ Distribution.Simple.Program.Types,
+ Distribution.Simple.Register,
+ Distribution.Simple.Setup,
+ Distribution.Simple.SrcDist,
+ Distribution.Simple.Test,
+ Distribution.Simple.UHC,
+ Distribution.Simple.UserHooks,
+ Distribution.Simple.Utils,
+ Distribution.System,
+ Distribution.TestSuite,
+ Distribution.Text,
+ Distribution.Verbosity,
+ Distribution.Version,
+ Distribution.Compat.ReadP,
+ Language.Haskell.Extension
+
+ Other-Modules:
+ Distribution.GetOpt,
+ Distribution.Compat.Exception,
+ Distribution.Compat.CopyFile,
+ Distribution.Compat.TempFile,
+ Distribution.Simple.GHC.IPI641,
+ Distribution.Simple.GHC.IPI642,
+ Paths_Cabal
+
+ Default-Language: Haskell98
+ Default-Extensions: CPP
+
+test-suite unit-tests
+ type: exitcode-stdio-1.0
+ main-is: suite.hs
+ other-modules: PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check,
+ PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check,
+ PackageTests.BuildDeps.InternalLibrary0.Check,
+ PackageTests.BuildDeps.InternalLibrary1.Check,
+ PackageTests.BuildDeps.InternalLibrary2.Check,
+ PackageTests.BuildDeps.InternalLibrary3.Check,
+ PackageTests.BuildDeps.InternalLibrary4.Check,
+ PackageTests.BuildDeps.TargetSpecificDeps1.Check,
+ PackageTests.BuildDeps.TargetSpecificDeps2.Check,
+ PackageTests.BuildDeps.TargetSpecificDeps3.Check,
+ PackageTests.BuildDeps.SameDepsAllRound.Check,
+ PackageTests.TestStanza.Check,
+ PackageTests.TestSuiteExeV10.Check,
+ PackageTests.PackageTester
+ hs-source-dirs: tests
+ build-depends:
+ base,
+ test-framework,
+ test-framework-quickcheck2,
+ test-framework-hunit,
+ HUnit,
+ QuickCheck >= 2.1.0.1,
+ Cabal,
+ process,
+ directory,
+ filepath,
+ extensible-exceptions,
+ bytestring,
+ unix
+ Default-Language: Haskell98
diff --git a/cabal/cabal/DefaultSetup.hs b/cabal/cabal/DefaultSetup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/cabal/cabal/DefaultSetup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/cabal/cabal/Distribution/Compat/CopyFile.hs b/cabal/cabal/Distribution/Compat/CopyFile.hs
new file mode 100644
index 0000000..3d96d72
--- /dev/null
+++ b/cabal/cabal/Distribution/Compat/CopyFile.hs
@@ -0,0 +1,115 @@
+{-# OPTIONS -cpp #-}
+-- OPTIONS required for ghc-6.4.x compat, and must appear first
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -cpp #-}
+{-# OPTIONS_NHC98 -cpp #-}
+{-# OPTIONS_JHC -fcpp #-}
+-- #hide
+module Distribution.Compat.CopyFile (
+ copyFile,
+ copyOrdinaryFile,
+ copyExecutableFile,
+ setFileOrdinary,
+ setFileExecutable,
+ setDirOrdinary,
+ ) where
+
+#ifdef __GLASGOW_HASKELL__
+
+import Control.Monad
+ ( when )
+import Control.Exception
+ ( bracket, bracketOnError )
+import Distribution.Compat.Exception
+ ( catchIO )
+#if __GLASGOW_HASKELL__ >= 608
+import Distribution.Compat.Exception
+ ( throwIOIO )
+import System.IO.Error
+ ( ioeSetLocation )
+#endif
+import System.Directory
+ ( renameFile, removeFile )
+import Distribution.Compat.TempFile
+ ( openBinaryTempFile )
+import System.FilePath
+ ( takeDirectory )
+import System.IO
+ ( openBinaryFile, IOMode(ReadMode), hClose, hGetBuf, hPutBuf )
+import Foreign
+ ( allocaBytes )
+#endif /* __GLASGOW_HASKELL__ */
+
+#ifndef mingw32_HOST_OS
+#if __GLASGOW_HASKELL__ >= 611
+import System.Posix.Internals (withFilePath)
+#else
+import Foreign.C (withCString)
+#endif
+import System.Posix.Types
+ ( FileMode )
+import System.Posix.Internals
+ ( c_chmod )
+#if __GLASGOW_HASKELL__ >= 608
+import Foreign.C
+ ( throwErrnoPathIfMinus1_ )
+#else
+import Foreign.C
+ ( throwErrnoIfMinus1_ )
+#endif
+#endif /* mingw32_HOST_OS */
+
+copyOrdinaryFile, copyExecutableFile :: FilePath -> FilePath -> IO ()
+copyOrdinaryFile src dest = copyFile src dest >> setFileOrdinary dest
+copyExecutableFile src dest = copyFile src dest >> setFileExecutable dest
+
+setFileOrdinary, setFileExecutable, setDirOrdinary :: FilePath -> IO ()
+#ifndef mingw32_HOST_OS
+setFileOrdinary path = setFileMode path 0o644 -- file perms -rw-r--r--
+setFileExecutable path = setFileMode path 0o755 -- file perms -rwxr-xr-x
+
+setFileMode :: FilePath -> FileMode -> IO ()
+setFileMode name m =
+#if __GLASGOW_HASKELL__ >= 611
+ withFilePath name $ \s -> do
+#else
+ withCString name $ \s -> do
+#endif
+#if __GLASGOW_HASKELL__ >= 608
+ throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m)
+#else
+ throwErrnoIfMinus1_ name (c_chmod s m)
+#endif
+#else
+setFileOrdinary _ = return ()
+setFileExecutable _ = return ()
+#endif
+-- This happens to be true on Unix and currently on Windows too:
+setDirOrdinary = setFileExecutable
+
+copyFile :: FilePath -> FilePath -> IO ()
+#ifdef __GLASGOW_HASKELL__
+copyFile fromFPath toFPath =
+ copy
+#if __GLASGOW_HASKELL__ >= 608
+ `catchIO` (\ioe -> throwIOIO (ioeSetLocation ioe "copyFile"))
+#endif
+ where copy = bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom ->
+ bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) ->
+ do allocaBytes bufferSize $ copyContents hFrom hTmp
+ hClose hTmp
+ renameFile tmpFPath toFPath
+ openTmp = openBinaryTempFile (takeDirectory toFPath) ".copyFile.tmp"
+ cleanTmp (tmpFPath, hTmp) = do
+ hClose hTmp `catchIO` \_ -> return ()
+ removeFile tmpFPath `catchIO` \_ -> return ()
+ bufferSize = 4096
+
+ copyContents hFrom hTo buffer = do
+ count <- hGetBuf hFrom buffer bufferSize
+ when (count > 0) $ do
+ hPutBuf hTo buffer count
+ copyContents hFrom hTo buffer
+#else
+copyFile fromFPath toFPath = readFile fromFPath >>= writeFile toFPath
+#endif
diff --git a/cabal/cabal/Distribution/Compat/Exception.hs b/cabal/cabal/Distribution/Compat/Exception.hs
new file mode 100644
index 0000000..ae8d9d5
--- /dev/null
+++ b/cabal/cabal/Distribution/Compat/Exception.hs
@@ -0,0 +1,61 @@
+{-# OPTIONS -cpp #-}
+-- OPTIONS required for ghc-6.4.x compat, and must appear first
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -cpp #-}
+{-# OPTIONS_NHC98 -cpp #-}
+{-# OPTIONS_JHC -fcpp #-}
+
+#if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 610))
+#define NEW_EXCEPTION
+#endif
+
+module Distribution.Compat.Exception (
+ Exception.IOException,
+ onException,
+ catchIO,
+ catchExit,
+ throwIOIO,
+ tryIO,
+ ) where
+
+import System.Exit
+import qualified Control.Exception as Exception
+
+onException :: IO a -> IO b -> IO a
+#ifdef NEW_EXCEPTION
+onException = Exception.onException
+#else
+onException io what = io `Exception.catch` \e -> do what
+ Exception.throw e
+#endif
+
+throwIOIO :: Exception.IOException -> IO a
+#ifdef NEW_EXCEPTION
+throwIOIO = Exception.throwIO
+#else
+throwIOIO = Exception.throwIO . Exception.IOException
+#endif
+
+tryIO :: IO a -> IO (Either Exception.IOException a)
+#ifdef NEW_EXCEPTION
+tryIO = Exception.try
+#else
+tryIO = Exception.tryJust Exception.ioErrors
+#endif
+
+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
+#ifdef NEW_EXCEPTION
+catchIO = Exception.catch
+#else
+catchIO = Exception.catchJust Exception.ioErrors
+#endif
+
+catchExit :: IO a -> (ExitCode -> IO a) -> IO a
+#ifdef NEW_EXCEPTION
+catchExit = Exception.catch
+#else
+catchExit = Exception.catchJust exitExceptions
+ where exitExceptions (Exception.ExitException ee) = Just ee
+ exitExceptions _ = Nothing
+#endif
+
diff --git a/cabal/cabal/Distribution/Compat/ReadP.hs b/cabal/cabal/Distribution/Compat/ReadP.hs
new file mode 100644
index 0000000..0c3d989
--- /dev/null
+++ b/cabal/cabal/Distribution/Compat/ReadP.hs
@@ -0,0 +1,470 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Compat.ReadP
+-- Copyright : (c) The University of Glasgow 2002
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Portability : portable
+--
+-- This is a library of parser combinators, originally written by Koen Claessen.
+-- It parses all alternatives in parallel, so it never keeps hold of
+-- the beginning of the input string, a common source of space leaks with
+-- other parsers. The '(+++)' choice combinator is genuinely commutative;
+-- it makes no difference which branch is \"shorter\".
+--
+-- See also Koen's paper /Parallel Parsing Processes/
+-- (<http://www.cs.chalmers.se/~koen/publications.html>).
+--
+-- This version of ReadP has been locally hacked to make it H98, by
+-- Martin Sj&#xF6;gren <mailto:msjogren@gmail.com>
+--
+-----------------------------------------------------------------------------
+
+module Distribution.Compat.ReadP
+ (
+ -- * The 'ReadP' type
+ ReadP, -- :: * -> *; instance Functor, Monad, MonadPlus
+
+ -- * Primitive operations
+ get, -- :: ReadP Char
+ look, -- :: ReadP String
+ (+++), -- :: ReadP a -> ReadP a -> ReadP a
+ (<++), -- :: ReadP a -> ReadP a -> ReadP a
+ gather, -- :: ReadP a -> ReadP (String, a)
+
+ -- * Other operations
+ pfail, -- :: ReadP a
+ satisfy, -- :: (Char -> Bool) -> ReadP Char
+ char, -- :: Char -> ReadP Char
+ string, -- :: String -> ReadP String
+ munch, -- :: (Char -> Bool) -> ReadP String
+ munch1, -- :: (Char -> Bool) -> ReadP String
+ skipSpaces, -- :: ReadP ()
+ choice, -- :: [ReadP a] -> ReadP a
+ count, -- :: Int -> ReadP a -> ReadP [a]
+ between, -- :: ReadP open -> ReadP close -> ReadP a -> ReadP a
+ option, -- :: a -> ReadP a -> ReadP a
+ optional, -- :: ReadP a -> ReadP ()
+ many, -- :: ReadP a -> ReadP [a]
+ many1, -- :: ReadP a -> ReadP [a]
+ skipMany, -- :: ReadP a -> ReadP ()
+ skipMany1, -- :: ReadP a -> ReadP ()
+ sepBy, -- :: ReadP a -> ReadP sep -> ReadP [a]
+ sepBy1, -- :: ReadP a -> ReadP sep -> ReadP [a]
+ endBy, -- :: ReadP a -> ReadP sep -> ReadP [a]
+ endBy1, -- :: ReadP a -> ReadP sep -> ReadP [a]
+ chainr, -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a
+ chainl, -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a
+ chainl1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a
+ chainr1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a
+ manyTill, -- :: ReadP a -> ReadP end -> ReadP [a]
+
+ -- * Running a parser
+ ReadS, -- :: *; = String -> [(a,String)]
+ readP_to_S, -- :: ReadP a -> ReadS a
+ readS_to_P -- :: ReadS a -> ReadP a
+
+ -- * Properties
+ -- $properties
+ )
+ where
+
+import Control.Monad( MonadPlus(..), liftM2 )
+import Data.Char (isSpace)
+
+infixr 5 +++, <++
+
+-- ---------------------------------------------------------------------------
+-- The P type
+-- is representation type -- should be kept abstract
+
+data P s a
+ = Get (s -> P s a)
+ | Look ([s] -> P s a)
+ | Fail
+ | Result a (P s a)
+ | Final [(a,[s])] -- invariant: list is non-empty!
+
+-- Monad, MonadPlus
+
+instance Monad (P s) where
+ return x = Result x Fail
+
+ (Get f) >>= k = Get (\c -> f c >>= k)
+ (Look f) >>= k = Look (\s -> f s >>= k)
+ Fail >>= _ = Fail
+ (Result x p) >>= k = k x `mplus` (p >>= k)
+ (Final r) >>= k = final [ys' | (x,s) <- r, ys' <- run (k x) s]
+
+ fail _ = Fail
+
+instance MonadPlus (P s) where
+ mzero = Fail
+
+ -- most common case: two gets are combined
+ Get f1 `mplus` Get f2 = Get (\c -> f1 c `mplus` f2 c)
+
+ -- results are delivered as soon as possible
+ Result x p `mplus` q = Result x (p `mplus` q)
+ p `mplus` Result x q = Result x (p `mplus` q)
+
+ -- fail disappears
+ Fail `mplus` p = p
+ p `mplus` Fail = p
+
+ -- two finals are combined
+ -- final + look becomes one look and one final (=optimization)
+ -- final + sthg else becomes one look and one final
+ Final r `mplus` Final t = Final (r ++ t)
+ Final r `mplus` Look f = Look (\s -> Final (r ++ run (f s) s))
+ Final r `mplus` p = Look (\s -> Final (r ++ run p s))
+ Look f `mplus` Final r = Look (\s -> Final (run (f s) s ++ r))
+ p `mplus` Final r = Look (\s -> Final (run p s ++ r))
+
+ -- two looks are combined (=optimization)
+ -- look + sthg else floats upwards
+ Look f `mplus` Look g = Look (\s -> f s `mplus` g s)
+ Look f `mplus` p = Look (\s -> f s `mplus` p)
+ p `mplus` Look f = Look (\s -> p `mplus` f s)
+
+-- ---------------------------------------------------------------------------
+-- The ReadP type
+
+newtype Parser r s a = R ((a -> P s r) -> P s r)
+type ReadP r a = Parser r Char a
+
+-- Functor, Monad, MonadPlus
+
+instance Functor (Parser r s) where
+ fmap h (R f) = R (\k -> f (k . h))
+
+instance Monad (Parser r s) where
+ return x = R (\k -> k x)
+ fail _ = R (\_ -> Fail)
+ R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k))
+
+--instance MonadPlus (Parser r s) where
+-- mzero = pfail
+-- mplus = (+++)
+
+-- ---------------------------------------------------------------------------
+-- Operations over P
+
+final :: [(a,[s])] -> P s a
+-- Maintains invariant for Final constructor
+final [] = Fail
+final r = Final r
+
+run :: P c a -> ([c] -> [(a, [c])])
+run (Get f) (c:s) = run (f c) s
+run (Look f) s = run (f s) s
+run (Result x p) s = (x,s) : run p s
+run (Final r) _ = r
+run _ _ = []
+
+-- ---------------------------------------------------------------------------
+-- Operations over ReadP
+
+get :: ReadP r Char
+-- ^ Consumes and returns the next character.
+-- Fails if there is no input left.
+get = R Get
+
+look :: ReadP r String
+-- ^ Look-ahead: returns the part of the input that is left, without
+-- consuming it.
+look = R Look
+
+pfail :: ReadP r a
+-- ^ Always fails.
+pfail = R (\_ -> Fail)
+
+(+++) :: ReadP r a -> ReadP r a -> ReadP r a
+-- ^ Symmetric choice.
+R f1 +++ R f2 = R (\k -> f1 k `mplus` f2 k)
+
+(<++) :: ReadP a a -> ReadP r a -> ReadP r a
+-- ^ Local, exclusive, left-biased choice: If left parser
+-- locally produces any result at all, then right parser is
+-- not used.
+R f <++ q =
+ do s <- look
+ probe (f return) s 0
+ where
+ probe (Get f') (c:s) n = probe (f' c) s (n+1 :: Int)
+ probe (Look f') s n = probe (f' s) s n
+ probe p@(Result _ _) _ n = discard n >> R (p >>=)
+ probe (Final r) _ _ = R (Final r >>=)
+ probe _ _ _ = q
+
+ discard 0 = return ()
+ discard n = get >> discard (n-1 :: Int)
+
+gather :: ReadP (String -> P Char r) a -> ReadP r (String, a)
+-- ^ Transforms a parser into one that does the same, but
+-- in addition returns the exact characters read.
+-- IMPORTANT NOTE: 'gather' gives a runtime error if its first argument
+-- is built using any occurrences of readS_to_P.
+gather (R m) =
+ R (\k -> gath id (m (\a -> return (\s -> k (s,a)))))
+ where
+ gath l (Get f) = Get (\c -> gath (l.(c:)) (f c))
+ gath _ Fail = Fail
+ gath l (Look f) = Look (\s -> gath l (f s))
+ gath l (Result k p) = k (l []) `mplus` gath l p
+ gath _ (Final _) = error "do not use readS_to_P in gather!"
+
+-- ---------------------------------------------------------------------------
+-- Derived operations
+
+satisfy :: (Char -> Bool) -> ReadP r Char
+-- ^ Consumes and returns the next character, if it satisfies the
+-- specified predicate.
+satisfy p = do c <- get; if p c then return c else pfail
+
+char :: Char -> ReadP r Char
+-- ^ Parses and returns the specified character.
+char c = satisfy (c ==)
+
+string :: String -> ReadP r String
+-- ^ Parses and returns the specified string.
+string this = do s <- look; scan this s
+ where
+ scan [] _ = do return this
+ scan (x:xs) (y:ys) | x == y = do get >> scan xs ys
+ scan _ _ = do pfail
+
+munch :: (Char -> Bool) -> ReadP r String
+-- ^ Parses the first zero or more characters satisfying the predicate.
+munch p =
+ do s <- look
+ scan s
+ where
+ scan (c:cs) | p c = do _ <- get; s <- scan cs; return (c:s)
+ scan _ = do return ""
+
+munch1 :: (Char -> Bool) -> ReadP r String
+-- ^ Parses the first one or more characters satisfying the predicate.
+munch1 p =
+ do c <- get
+ if p c then do s <- munch p; return (c:s)
+ else pfail
+
+choice :: [ReadP r a] -> ReadP r a
+-- ^ Combines all parsers in the specified list.
+choice [] = pfail
+choice [p] = p
+choice (p:ps) = p +++ choice ps
+
+skipSpaces :: ReadP r ()
+-- ^ Skips all whitespace.
+skipSpaces =
+ do s <- look
+ skip s
+ where
+ skip (c:s) | isSpace c = do _ <- get; skip s
+ skip _ = do return ()
+
+count :: Int -> ReadP r a -> ReadP r [a]
+-- ^ @ count n p @ parses @n@ occurrences of @p@ in sequence. A list of
+-- results is returned.
+count n p = sequence (replicate n p)
+
+between :: ReadP r open -> ReadP r close -> ReadP r a -> ReadP r a
+-- ^ @ between open close p @ parses @open@, followed by @p@ and finally
+-- @close@. Only the value of @p@ is returned.
+between open close p = do _ <- open
+ x <- p
+ _ <- close
+ return x
+
+option :: a -> ReadP r a -> ReadP r a
+-- ^ @option x p@ will either parse @p@ or return @x@ without consuming
+-- any input.
+option x p = p +++ return x
+
+optional :: ReadP r a -> ReadP r ()
+-- ^ @optional p@ optionally parses @p@ and always returns @()@.
+optional p = (p >> return ()) +++ return ()
+
+many :: ReadP r a -> ReadP r [a]
+-- ^ Parses zero or more occurrences of the given parser.
+many p = return [] +++ many1 p
+
+many1 :: ReadP r a -> ReadP r [a]
+-- ^ Parses one or more occurrences of the given parser.
+many1 p = liftM2 (:) p (many p)
+
+skipMany :: ReadP r a -> ReadP r ()
+-- ^ Like 'many', but discards the result.
+skipMany p = many p >> return ()
+
+skipMany1 :: ReadP r a -> ReadP r ()
+-- ^ Like 'many1', but discards the result.
+skipMany1 p = p >> skipMany p
+
+sepBy :: ReadP r a -> ReadP r sep -> ReadP r [a]
+-- ^ @sepBy p sep@ parses zero or more occurrences of @p@, separated by @sep@.
+-- Returns a list of values returned by @p@.
+sepBy p sep = sepBy1 p sep +++ return []
+
+sepBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a]
+-- ^ @sepBy1 p sep@ parses one or more occurrences of @p@, separated by @sep@.
+-- Returns a list of values returned by @p@.
+sepBy1 p sep = liftM2 (:) p (many (sep >> p))
+
+endBy :: ReadP r a -> ReadP r sep -> ReadP r [a]
+-- ^ @endBy p sep@ parses zero or more occurrences of @p@, separated and ended
+-- by @sep@.
+endBy p sep = many (do x <- p ; _ <- sep ; return x)
+
+endBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a]
+-- ^ @endBy p sep@ parses one or more occurrences of @p@, separated and ended
+-- by @sep@.
+endBy1 p sep = many1 (do x <- p ; _ <- sep ; return x)
+
+chainr :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a
+-- ^ @chainr p op x@ parses zero or more occurrences of @p@, separated by @op@.
+-- Returns a value produced by a /right/ associative application of all
+-- functions returned by @op@. If there are no occurrences of @p@, @x@ is
+-- returned.
+chainr p op x = chainr1 p op +++ return x
+
+chainl :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a
+-- ^ @chainl p op x@ parses zero or more occurrences of @p@, separated by @op@.
+-- Returns a value produced by a /left/ associative application of all
+-- functions returned by @op@. If there are no occurrences of @p@, @x@ is
+-- returned.
+chainl p op x = chainl1 p op +++ return x
+
+chainr1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a
+-- ^ Like 'chainr', but parses one or more occurrences of @p@.
+chainr1 p op = scan
+ where scan = p >>= rest
+ rest x = do f <- op
+ y <- scan
+ return (f x y)
+ +++ return x
+
+chainl1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a
+-- ^ Like 'chainl', but parses one or more occurrences of @p@.
+chainl1 p op = p >>= rest
+ where rest x = do f <- op
+ y <- p
+ rest (f x y)
+ +++ return x
+
+manyTill :: ReadP r a -> ReadP [a] end -> ReadP r [a]
+-- ^ @manyTill p end@ parses zero or more occurrences of @p@, until @end@
+-- succeeds. Returns a list of values returned by @p@.
+manyTill p end = scan
+ where scan = (end >> return []) <++ (liftM2 (:) p scan)
+
+-- ---------------------------------------------------------------------------
+-- Converting between ReadP and Read
+
+readP_to_S :: ReadP a a -> ReadS a
+-- ^ Converts a parser into a Haskell ReadS-style function.
+-- This is the main way in which you can \"run\" a 'ReadP' parser:
+-- the expanded type is
+-- @ readP_to_S :: ReadP a -> String -> [(a,String)] @
+readP_to_S (R f) = run (f return)
+
+readS_to_P :: ReadS a -> ReadP r a
+-- ^ Converts a Haskell ReadS-style function into a parser.
+-- Warning: This introduces local backtracking in the resulting
+-- parser, and therefore a possible inefficiency.
+readS_to_P r =
+ R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s']))
+
+-- ---------------------------------------------------------------------------
+-- QuickCheck properties that hold for the combinators
+
+{- $properties
+The following are QuickCheck specifications of what the combinators do.
+These can be seen as formal specifications of the behavior of the
+combinators.
+
+We use bags to give semantics to the combinators.
+
+> type Bag a = [a]
+
+Equality on bags does not care about the order of elements.
+
+> (=~) :: Ord a => Bag a -> Bag a -> Bool
+> xs =~ ys = sort xs == sort ys
+
+A special equality operator to avoid unresolved overloading
+when testing the properties.
+
+> (=~.) :: Bag (Int,String) -> Bag (Int,String) -> Bool
+> (=~.) = (=~)
+
+Here follow the properties:
+
+> prop_Get_Nil =
+> readP_to_S get [] =~ []
+>
+> prop_Get_Cons c s =
+> readP_to_S get (c:s) =~ [(c,s)]
+>
+> prop_Look s =
+> readP_to_S look s =~ [(s,s)]
+>
+> prop_Fail s =
+> readP_to_S pfail s =~. []
+>
+> prop_Return x s =
+> readP_to_S (return x) s =~. [(x,s)]
+>
+> prop_Bind p k s =
+> readP_to_S (p >>= k) s =~.
+> [ ys''
+> | (x,s') <- readP_to_S p s
+> , ys'' <- readP_to_S (k (x::Int)) s'
+> ]
+>
+> prop_Plus p q s =
+> readP_to_S (p +++ q) s =~.
+> (readP_to_S p s ++ readP_to_S q s)
+>
+> prop_LeftPlus p q s =
+> readP_to_S (p <++ q) s =~.
+> (readP_to_S p s +<+ readP_to_S q s)
+> where
+> [] +<+ ys = ys
+> xs +<+ _ = xs
+>
+> prop_Gather s =
+> forAll readPWithoutReadS $ \p ->
+> readP_to_S (gather p) s =~
+> [ ((pre,x::Int),s')
+> | (x,s') <- readP_to_S p s
+> , let pre = take (length s - length s') s
+> ]
+>
+> prop_String_Yes this s =
+> readP_to_S (string this) (this ++ s) =~
+> [(this,s)]
+>
+> prop_String_Maybe this s =
+> readP_to_S (string this) s =~
+> [(this, drop (length this) s) | this `isPrefixOf` s]
+>
+> prop_Munch p s =
+> readP_to_S (munch p) s =~
+> [(takeWhile p s, dropWhile p s)]
+>
+> prop_Munch1 p s =
+> readP_to_S (munch1 p) s =~
+> [(res,s') | let (res,s') = (takeWhile p s, dropWhile p s), not (null res)]
+>
+> prop_Choice ps s =
+> readP_to_S (choice ps) s =~.
+> readP_to_S (foldr (+++) pfail ps) s
+>
+> prop_ReadS r s =
+> readP_to_S (readS_to_P r) s =~. r s
+-}
+
diff --git a/cabal/cabal/Distribution/Compat/TempFile.hs b/cabal/cabal/Distribution/Compat/TempFile.hs
new file mode 100644
index 0000000..9feddeb
--- /dev/null
+++ b/cabal/cabal/Distribution/Compat/TempFile.hs
@@ -0,0 +1,204 @@
+{-# OPTIONS -cpp #-}
+-- OPTIONS required for ghc-6.4.x compat, and must appear first
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -cpp #-}
+{-# OPTIONS_NHC98 -cpp #-}
+{-# OPTIONS_JHC -fcpp #-}
+-- #hide
+module Distribution.Compat.TempFile (
+ openTempFile,
+ openBinaryTempFile,
+ openNewBinaryFile,
+ createTempDirectory,
+ ) where
+
+
+import System.FilePath ((</>))
+import Foreign.C (eEXIST)
+
+#if __NHC__ || __HUGS__
+import System.IO (openFile, openBinaryFile,
+ Handle, IOMode(ReadWriteMode))
+import System.Directory (doesFileExist)
+import System.FilePath ((<.>), splitExtension)
+import System.IO.Error (try, isAlreadyExistsError)
+#else
+import System.IO (Handle, openTempFile, openBinaryTempFile)
+import Data.Bits ((.|.))
+import System.Posix.Internals (c_open, c_close, o_CREAT, o_EXCL, o_RDWR,
+ o_BINARY, o_NONBLOCK, o_NOCTTY)
+import System.IO.Error (isAlreadyExistsError)
+#if __GLASGOW_HASKELL__ >= 611
+import System.Posix.Internals (withFilePath)
+#else
+import Foreign.C (withCString)
+#endif
+import Foreign.C (CInt)
+#if __GLASGOW_HASKELL__ >= 611
+import GHC.IO.Handle.FD (fdToHandle)
+#else
+import GHC.Handle (fdToHandle)
+#endif
+import Distribution.Compat.Exception (onException, tryIO)
+#endif
+import Foreign.C (getErrno, errnoToIOError)
+
+#if __NHC__
+import System.Posix.Types (CPid(..))
+foreign import ccall unsafe "getpid" c_getpid :: IO CPid
+#else
+import System.Posix.Internals (c_getpid)
+#endif
+
+#ifdef mingw32_HOST_OS
+import System.Directory ( createDirectory )
+#else
+import qualified System.Posix
+#endif
+
+-- ------------------------------------------------------------
+-- * temporary files
+-- ------------------------------------------------------------
+
+-- This is here for Haskell implementations that do not come with
+-- System.IO.openTempFile. This includes nhc-1.20, hugs-2006.9.
+-- TODO: Not sure about jhc
+
+#if __NHC__ || __HUGS__
+-- use a temporary filename that doesn't already exist.
+-- NB. *not* secure (we don't atomically lock the tmp file we get)
+openTempFile :: FilePath -> String -> IO (FilePath, Handle)
+openTempFile tmp_dir template
+ = do x <- getProcessID
+ findTempName x
+ where
+ (templateBase, templateExt) = splitExtension template
+ findTempName :: Int -> IO (FilePath, Handle)
+ findTempName x
+ = do let path = tmp_dir </> (templateBase ++ "-" ++ show x) <.> templateExt
+ b <- doesFileExist path
+ if b then findTempName (x+1)
+ else do hnd <- openFile path ReadWriteMode
+ return (path, hnd)
+
+openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle)
+openBinaryTempFile tmp_dir template
+ = do x <- getProcessID
+ findTempName x
+ where
+ (templateBase, templateExt) = splitExtension template
+ findTempName :: Int -> IO (FilePath, Handle)
+ findTempName x
+ = do let path = tmp_dir </> (templateBase ++ "-" ++ show x) <.> templateExt
+ b <- doesFileExist path
+ if b then findTempName (x+1)
+ else do hnd <- openBinaryFile path ReadWriteMode
+ return (path, hnd)
+
+openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle)
+openNewBinaryFile = openBinaryTempFile
+
+getProcessID :: IO Int
+getProcessID = fmap fromIntegral c_getpid
+#else
+-- This is a copy/paste of the openBinaryTempFile definition, but
+-- if uses 666 rather than 600 for the permissions. The base library
+-- needs to be changed to make this better.
+openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle)
+openNewBinaryFile dir template = do
+ pid <- c_getpid
+ findTempName pid
+ where
+ -- We split off the last extension, so we can use .foo.ext files
+ -- for temporary files (hidden on Unix OSes). Unfortunately we're
+ -- below filepath in the hierarchy here.
+ (prefix,suffix) =
+ case break (== '.') $ reverse template of
+ -- First case: template contains no '.'s. Just re-reverse it.
+ (rev_suffix, "") -> (reverse rev_suffix, "")
+ -- Second case: template contains at least one '.'. Strip the
+ -- dot from the prefix and prepend it to the suffix (if we don't
+ -- do this, the unique number will get added after the '.' and
+ -- thus be part of the extension, which is wrong.)
+ (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix)
+ -- Otherwise, something is wrong, because (break (== '.')) should
+ -- always return a pair with either the empty string or a string
+ -- beginning with '.' as the second component.
+ _ -> error "bug in System.IO.openTempFile"
+
+ oflags = rw_flags .|. o_EXCL .|. o_BINARY
+
+#if __GLASGOW_HASKELL__ < 611
+ withFilePath = withCString
+#endif
+
+ findTempName x = do
+ fd <- withFilePath filepath $ \ f ->
+ c_open f oflags 0o666
+ if fd < 0
+ then do
+ errno <- getErrno
+ if errno == eEXIST
+ then findTempName (x+1)
+ else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir))
+ else do
+ -- TODO: We want to tell fdToHandle what the filepath is,
+ -- as any exceptions etc will only be able to report the
+ -- fd currently
+ h <-
+#if __GLASGOW_HASKELL__ >= 609
+ fdToHandle fd
+#elif __GLASGOW_HASKELL__ <= 606 && defined(mingw32_HOST_OS)
+ -- fdToHandle is borked on Windows with ghc-6.6.x
+ openFd (fromIntegral fd) Nothing False filepath
+ ReadWriteMode True
+#else
+ fdToHandle (fromIntegral fd)
+#endif
+ `onException` c_close fd
+ return (filepath, h)
+ where
+ filename = prefix ++ show x ++ suffix
+ filepath = dir `combine` filename
+
+ -- FIXME: bits copied from System.FilePath
+ combine a b
+ | null b = a
+ | null a = b
+ | last a == pathSeparator = a ++ b
+ | otherwise = a ++ [pathSeparator] ++ b
+
+-- FIXME: Should use filepath library
+pathSeparator :: Char
+#ifdef mingw32_HOST_OS
+pathSeparator = '\\'
+#else
+pathSeparator = '/'
+#endif
+
+-- FIXME: Copied from GHC.Handle
+std_flags, output_flags, rw_flags :: CInt
+std_flags = o_NONBLOCK .|. o_NOCTTY
+output_flags = std_flags .|. o_CREAT
+rw_flags = output_flags .|. o_RDWR
+#endif
+
+createTempDirectory :: FilePath -> String -> IO FilePath
+createTempDirectory dir template = do
+ pid <- c_getpid
+ findTempName pid
+ where
+ findTempName x = do
+ let dirpath = dir </> template ++ "-" ++ show x
+ r <- tryIO $ mkPrivateDir dirpath
+ case r of
+ Right _ -> return dirpath
+ Left e | isAlreadyExistsError e -> findTempName (x+1)
+ | otherwise -> ioError e
+
+mkPrivateDir :: String -> IO ()
+#ifdef mingw32_HOST_OS
+mkPrivateDir s = createDirectory s
+#else
+mkPrivateDir s = System.Posix.createDirectory s 0o700
+#endif
diff --git a/cabal/cabal/Distribution/Compiler.hs b/cabal/cabal/Distribution/Compiler.hs
new file mode 100644
index 0000000..82abd46
--- /dev/null
+++ b/cabal/cabal/Distribution/Compiler.hs
@@ -0,0 +1,158 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Compiler
+-- Copyright : Isaac Jones 2003-2004
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Portability : portable
+--
+-- This has an enumeration of the various compilers that Cabal knows about. It
+-- also specifies the default compiler. Sadly you'll often see code that does
+-- case analysis on this compiler flavour enumeration like:
+--
+-- > case compilerFlavor comp of
+-- > GHC -> GHC.getInstalledPackages verbosity packageDb progconf
+-- > JHC -> JHC.getInstalledPackages verbosity packageDb progconf
+--
+-- Obviously it would be better to use the proper 'Compiler' abstraction
+-- because that would keep all the compiler-specific code together.
+-- Unfortunately we cannot make this change yet without breaking the
+-- 'UserHooks' api, which would break all custom @Setup.hs@ files, so for the
+-- moment we just have to live with this deficiency. If you're interested, see
+-- ticket #50.
+
+{- All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Isaac Jones nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
+
+module Distribution.Compiler (
+ -- * Compiler flavor
+ CompilerFlavor(..),
+ buildCompilerFlavor,
+ defaultCompilerFlavor,
+ parseCompilerFlavorCompat,
+
+ -- * Compiler id
+ CompilerId(..),
+ ) where
+
+import Distribution.Version (Version(..))
+
+import qualified System.Info (compilerName)
+import Distribution.Text (Text(..), display)
+import qualified Distribution.Compat.ReadP as Parse
+import qualified Text.PrettyPrint as Disp
+import Text.PrettyPrint ((<>))
+
+import qualified Data.Char as Char (toLower, isDigit, isAlphaNum)
+import Control.Monad (when)
+
+data CompilerFlavor = GHC | NHC | YHC | Hugs | HBC | Helium | JHC | LHC | UHC
+ | OtherCompiler String
+ deriving (Show, Read, Eq, Ord)
+
+knownCompilerFlavors :: [CompilerFlavor]
+knownCompilerFlavors = [GHC, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC]
+
+instance Text CompilerFlavor where
+ disp (OtherCompiler name) = Disp.text name
+ disp NHC = Disp.text "nhc98"
+ disp other = Disp.text (lowercase (show other))
+
+ parse = do
+ comp <- Parse.munch1 Char.isAlphaNum
+ when (all Char.isDigit comp) Parse.pfail
+ return (classifyCompilerFlavor comp)
+
+classifyCompilerFlavor :: String -> CompilerFlavor
+classifyCompilerFlavor s =
+ case lookup (lowercase s) compilerMap of
+ Just compiler -> compiler
+ Nothing -> OtherCompiler s
+ where
+ compilerMap = [ (display compiler, compiler)
+ | compiler <- knownCompilerFlavors ]
+
+
+--TODO: In some future release, remove 'parseCompilerFlavorCompat' and use
+-- ordinary 'parse'. Also add ("nhc", NHC) to the above 'compilerMap'.
+
+-- | Like 'classifyCompilerFlavor' but compatible with the old ReadS parser.
+--
+-- It is compatible in the sense that it accepts only the same strings,
+-- eg "GHC" but not "ghc". However other strings get mapped to 'OtherCompiler'.
+-- The point of this is that we do not allow extra valid values that would
+-- upset older Cabal versions that had a stricter parser however we cope with
+-- new values more gracefully so that we'll be able to introduce new value in
+-- future without breaking things so much.
+--
+parseCompilerFlavorCompat :: Parse.ReadP r CompilerFlavor
+parseCompilerFlavorCompat = do
+ comp <- Parse.munch1 Char.isAlphaNum
+ when (all Char.isDigit comp) Parse.pfail
+ case lookup comp compilerMap of
+ Just compiler -> return compiler
+ Nothing -> return (OtherCompiler comp)
+ where
+ compilerMap = [ (show compiler, compiler)
+ | compiler <- knownCompilerFlavors
+ , compiler /= YHC ]
+
+buildCompilerFlavor :: CompilerFlavor
+buildCompilerFlavor = classifyCompilerFlavor System.Info.compilerName
+
+-- | The default compiler flavour to pick when compiling stuff. This defaults
+-- to the compiler used to build the Cabal lib.
+--
+-- However if it's not a recognised compiler then it's 'Nothing' and the user
+-- will have to specify which compiler they want.
+--
+defaultCompilerFlavor :: Maybe CompilerFlavor
+defaultCompilerFlavor = case buildCompilerFlavor of
+ OtherCompiler _ -> Nothing
+ _ -> Just buildCompilerFlavor
+
+-- ------------------------------------------------------------
+-- * Compiler Id
+-- ------------------------------------------------------------
+
+data CompilerId = CompilerId CompilerFlavor Version
+ deriving (Eq, Ord, Read, Show)
+
+instance Text CompilerId where
+ disp (CompilerId f (Version [] _)) = disp f
+ disp (CompilerId f v) = disp f <> Disp.char '-' <> disp v
+
+ parse = do
+ flavour <- parse
+ version <- (Parse.char '-' >> parse) Parse.<++ return (Version [] [])
+ return (CompilerId flavour version)
+
+lowercase :: String -> String
+lowercase = map Char.toLower
diff --git a/cabal/cabal/Distribution/GetOpt.hs b/cabal/cabal/Distribution/GetOpt.hs
new file mode 100644
index 0000000..14725d3
--- /dev/null
+++ b/cabal/cabal/Distribution/GetOpt.hs
@@ -0,0 +1,335 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.GetOpt
+-- Copyright : (c) Sven Panne 2002-2005
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Portability : portable
+--
+-- This library provides facilities for parsing the command-line options
+-- in a standalone program. It is essentially a Haskell port of the GNU
+-- @getopt@ library.
+--
+-----------------------------------------------------------------------------
+
+{-
+Sven Panne <Sven.Panne@informatik.uni-muenchen.de> Oct. 1996 (small
+changes Dec. 1997)
+
+Two rather obscure features are missing: The Bash 2.0 non-option hack
+(if you don't already know it, you probably don't want to hear about
+it...) and the recognition of long options with a single dash
+(e.g. '-help' is recognised as '--help', as long as there is no short
+option 'h').
+
+Other differences between GNU's getopt and this implementation:
+
+* To enforce a coherent description of options and arguments, there
+ are explanation fields in the option/argument descriptor.
+
+* Error messages are now more informative, but no longer POSIX
+ compliant... :-(
+
+And a final Haskell advertisement: The GNU C implementation uses well
+over 1100 lines, we need only 195 here, including a 46 line example!
+:-)
+-}
+
+-- #hide
+module Distribution.GetOpt (
+ -- * GetOpt
+ getOpt, getOpt',
+ usageInfo,
+ ArgOrder(..),
+ OptDescr(..),
+ ArgDescr(..),
+
+ -- * Example
+
+ -- $example
+) where
+
+import Data.List ( isPrefixOf, intersperse, find )
+
+-- |What to do with options following non-options
+data ArgOrder a
+ = RequireOrder -- ^ no option processing after first non-option
+ | Permute -- ^ freely intersperse options and non-options
+ | ReturnInOrder (String -> a) -- ^ wrap non-options into options
+
+{-|
+Each 'OptDescr' describes a single option.
+
+The arguments to 'Option' are:
+
+* list of short option characters
+
+* list of long option strings (without \"--\")
+
+* argument descriptor
+
+* explanation of option for user
+-}
+data OptDescr a = -- description of a single options:
+ Option [Char] -- list of short option characters
+ [String] -- list of long option strings (without "--")
+ (ArgDescr a) -- argument descriptor
+ String -- explanation of option for user
+
+-- |Describes whether an option takes an argument or not, and if so
+-- how the argument is injected into a value of type @a@.
+data ArgDescr a
+ = NoArg a -- ^ no argument expected
+ | ReqArg (String -> a) String -- ^ option requires argument
+ | OptArg (Maybe String -> a) String -- ^ optional argument
+
+data OptKind a -- kind of cmd line arg (internal use only):
+ = Opt a -- an option
+ | UnreqOpt String -- an un-recognized option
+ | NonOpt String -- a non-option
+ | EndOfOpts -- end-of-options marker (i.e. "--")
+ | OptErr String -- something went wrong...
+
+-- | Return a string describing the usage of a command, derived from
+-- the header (first argument) and the options described by the
+-- second argument.
+usageInfo :: String -- header
+ -> [OptDescr a] -- option descriptors
+ -> String -- nicely formatted decription of options
+usageInfo header optDescr = unlines (header:table)
+ where (ss,ls,ds) = unzip3 [ (sepBy ", " (map (fmtShort ad) sos)
+ ,concatMap (fmtLong ad) (take 1 los)
+ ,d)
+ | Option sos los ad d <- optDescr ]
+ ssWidth = (maximum . map length) ss
+ lsWidth = (maximum . map length) ls
+ dsWidth = 30 `max` (80 - (ssWidth + lsWidth + 3))
+ table = [ " " ++ padTo ssWidth so' ++
+ " " ++ padTo lsWidth lo' ++
+ " " ++ d'
+ | (so,lo,d) <- zip3 ss ls ds
+ , (so',lo',d') <- fmtOpt dsWidth so lo d ]
+ padTo n x = take n (x ++ repeat ' ')
+ sepBy s = concat . intersperse s
+
+fmtOpt :: Int -> String -> String -> String -> [(String, String, String)]
+fmtOpt descrWidth so lo descr =
+ case wrapText descrWidth descr of
+ [] -> [(so,lo,"")]
+ (d:ds) -> (so,lo,d) : [ ("","",d') | d' <- ds ]
+
+fmtShort :: ArgDescr a -> Char -> String
+fmtShort (NoArg _ ) so = "-" ++ [so]
+fmtShort (ReqArg _ _) so = "-" ++ [so]
+fmtShort (OptArg _ _) so = "-" ++ [so]
+
+fmtLong :: ArgDescr a -> String -> String
+fmtLong (NoArg _ ) lo = "--" ++ lo
+fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad
+fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]"
+
+wrapText :: Int -> String -> [String]
+wrapText width = map unwords . wrap 0 [] . words
+ where wrap :: Int -> [String] -> [String] -> [[String]]
+ wrap 0 [] (w:ws)
+ | length w + 1 > width
+ = wrap (length w) [w] ws
+ wrap col line (w:ws)
+ | col + length w + 1 > width
+ = reverse line : wrap 0 [] (w:ws)
+ wrap col line (w:ws)
+ = let col' = col + length w + 1
+ in wrap col' (w:line) ws
+ wrap _ [] [] = []
+ wrap _ line [] = [reverse line]
+
+{-|
+Process the command-line, and return the list of values that matched
+(and those that didn\'t). The arguments are:
+
+* The order requirements (see 'ArgOrder')
+
+* The option descriptions (see 'OptDescr')
+
+* The actual command line arguments (presumably got from
+ 'System.Environment.getArgs').
+
+'getOpt' returns a triple consisting of the option arguments, a list
+of non-options, and a list of error messages.
+-}
+getOpt :: ArgOrder a -- non-option handling
+ -> [OptDescr a] -- option descriptors
+ -> [String] -- the command-line arguments
+ -> ([a],[String],[String]) -- (options,non-options,error messages)
+getOpt ordering optDescr args = (os,xs,es ++ map errUnrec us)
+ where (os,xs,us,es) = getOpt' ordering optDescr args
+
+{-|
+This is almost the same as 'getOpt', but returns a quadruple
+consisting of the option arguments, a list of non-options, a list of
+unrecognized options, and a list of error messages.
+-}
+getOpt' :: ArgOrder a -- non-option handling
+ -> [OptDescr a] -- option descriptors
+ -> [String] -- the command-line arguments
+ -> ([a],[String], [String] ,[String]) -- (options,non-options,unrecognized,error messages)
+getOpt' _ _ [] = ([],[],[],[])
+getOpt' ordering optDescr (arg:args) = procNextOpt opt ordering
+ where procNextOpt (Opt o) _ = (o:os,xs,us,es)
+ procNextOpt (UnreqOpt u) _ = (os,xs,u:us,es)
+ procNextOpt (NonOpt x) RequireOrder = ([],x:rest,[],[])
+ procNextOpt (NonOpt x) Permute = (os,x:xs,us,es)
+ procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,us,es)
+ procNextOpt EndOfOpts RequireOrder = ([],rest,[],[])
+ procNextOpt EndOfOpts Permute = ([],rest,[],[])
+ procNextOpt EndOfOpts (ReturnInOrder f) = (map f rest,[],[],[])
+ procNextOpt (OptErr e) _ = (os,xs,us,e:es)
+
+ (opt,rest) = getNext arg args optDescr
+ (os,xs,us,es) = getOpt' ordering optDescr rest
+
+-- take a look at the next cmd line arg and decide what to do with it
+getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])
+getNext ('-':'-':[]) rest _ = (EndOfOpts,rest)
+getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr
+getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr
+getNext a rest _ = (NonOpt a,rest)
+
+-- handle long option
+longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])
+longOpt ls rs optDescr = long ads arg rs
+ where (opt,arg) = break (=='=') ls
+ getWith p = [ o | o@(Option _ xs _ _) <- optDescr
+ , find (p opt) xs /= Nothing]
+ exact = getWith (==)
+ options = if null exact then getWith isPrefixOf else exact
+ ads = [ ad | Option _ _ ad _ <- options ]
+ optStr = ("--"++opt)
+
+ long (_:_:_) _ rest = (errAmbig options optStr,rest)
+ long [NoArg a ] [] rest = (Opt a,rest)
+ long [NoArg _ ] ('=':_) rest = (errNoArg optStr,rest)
+ long [ReqArg _ d] [] [] = (errReq d optStr,[])
+ long [ReqArg f _] [] (r:rest) = (Opt (f r),rest)
+ long [ReqArg f _] ('=':xs) rest = (Opt (f xs),rest)
+ long [OptArg f _] [] rest = (Opt (f Nothing),rest)
+ long [OptArg f _] ('=':xs) rest = (Opt (f (Just xs)),rest)
+ long _ _ rest = (UnreqOpt ("--"++ls),rest)
+
+-- handle short option
+shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String])
+shortOpt y ys rs optDescr = short ads ys rs
+ where options = [ o | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s ]
+ ads = [ ad | Option _ _ ad _ <- options ]
+ optStr = '-':[y]
+
+ short (_:_:_) _ rest = (errAmbig options optStr,rest)
+ short (NoArg a :_) [] rest = (Opt a,rest)
+ short (NoArg a :_) xs rest = (Opt a,('-':xs):rest)
+ short (ReqArg _ d:_) [] [] = (errReq d optStr,[])
+ short (ReqArg f _:_) [] (r:rest) = (Opt (f r),rest)
+ short (ReqArg f _:_) xs rest = (Opt (f xs),rest)
+ short (OptArg f _:_) [] rest = (Opt (f Nothing),rest)
+ short (OptArg f _:_) xs rest = (Opt (f (Just xs)),rest)
+ short [] [] rest = (UnreqOpt optStr,rest)
+ short [] xs rest = (UnreqOpt (optStr++xs),rest)
+
+-- miscellaneous error formatting
+
+errAmbig :: [OptDescr a] -> String -> OptKind a
+errAmbig ods optStr = OptErr (usageInfo header ods)
+ where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:"
+
+errReq :: String -> String -> OptKind a
+errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n")
+
+errUnrec :: String -> String
+errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n"
+
+errNoArg :: String -> OptKind a
+errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n")
+
+{-
+-----------------------------------------------------------------------------------------
+-- and here a small and hopefully enlightening example:
+
+data Flag = Verbose | Version | Name String | Output String | Arg String deriving Show
+
+options :: [OptDescr Flag]
+options =
+ [Option ['v'] ["verbose"] (NoArg Verbose) "verbosely list files",
+ Option ['V','?'] ["version","release"] (NoArg Version) "show version info",
+ Option ['o'] ["output"] (OptArg out "FILE") "use FILE for dump",
+ Option ['n'] ["name"] (ReqArg Name "USER") "only dump USER's files"]
+
+out :: Maybe String -> Flag
+out Nothing = Output "stdout"
+out (Just o) = Output o
+
+test :: ArgOrder Flag -> [String] -> String
+test order cmdline = case getOpt order options cmdline of
+ (o,n,[] ) -> "options=" ++ show o ++ " args=" ++ show n ++ "\n"
+ (_,_,errs) -> concat errs ++ usageInfo header options
+ where header = "Usage: foobar [OPTION...] files..."
+
+-- example runs:
+-- putStr (test RequireOrder ["foo","-v"])
+-- ==> options=[] args=["foo", "-v"]
+-- putStr (test Permute ["foo","-v"])
+-- ==> options=[Verbose] args=["foo"]
+-- putStr (test (ReturnInOrder Arg) ["foo","-v"])
+-- ==> options=[Arg "foo", Verbose] args=[]
+-- putStr (test Permute ["foo","--","-v"])
+-- ==> options=[] args=["foo", "-v"]
+-- putStr (test Permute ["-?o","--name","bar","--na=baz"])
+-- ==> options=[Version, Output "stdout", Name "bar", Name "baz"] args=[]
+-- putStr (test Permute ["--ver","foo"])
+-- ==> option `--ver' is ambiguous; could be one of:
+-- -v --verbose verbosely list files
+-- -V, -? --version, --release show version info
+-- Usage: foobar [OPTION...] files...
+-- -v --verbose verbosely list files
+-- -V, -? --version, --release show version info
+-- -o[FILE] --output[=FILE] use FILE for dump
+-- -n USER --name=USER only dump USER's files
+-----------------------------------------------------------------------------------------
+-}
+
+{- $example
+
+To hopefully illuminate the role of the different data
+structures, here\'s the command-line options for a (very simple)
+compiler:
+
+> module Opts where
+>
+> import Distribution.GetOpt
+> import Data.Maybe ( fromMaybe )
+>
+> data Flag
+> = Verbose | Version
+> | Input String | Output String | LibDir String
+> deriving Show
+>
+> options :: [OptDescr Flag]
+> options =
+> [ Option ['v'] ["verbose"] (NoArg Verbose) "chatty output on stderr"
+> , Option ['V','?'] ["version"] (NoArg Version) "show version number"
+> , Option ['o'] ["output"] (OptArg outp "FILE") "output FILE"
+> , Option ['c'] [] (OptArg inp "FILE") "input FILE"
+> , Option ['L'] ["libdir"] (ReqArg LibDir "DIR") "library directory"
+> ]
+>
+> inp,outp :: Maybe String -> Flag
+> outp = Output . fromMaybe "stdout"
+> inp = Input . fromMaybe "stdin"
+>
+> compilerOpts :: [String] -> IO ([Flag], [String])
+> compilerOpts argv =
+> case getOpt Permute options argv of
+> (o,n,[] ) -> return (o,n)
+> (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))
+> where header = "Usage: ic [OPTION...] files..."
+
+-}
diff --git a/cabal/cabal/Distribution/InstalledPackageInfo.hs b/cabal/cabal/Distribution/InstalledPackageInfo.hs
new file mode 100644
index 0000000..db3a3e6
--- /dev/null
+++ b/cabal/cabal/Distribution/InstalledPackageInfo.hs
@@ -0,0 +1,294 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.InstalledPackageInfo
+-- Copyright : (c) The University of Glasgow 2004
+--
+-- Maintainer : libraries@haskell.org
+-- Portability : portable
+--
+-- This is the information about an /installed/ package that
+-- is communicated to the @ghc-pkg@ program in order to register
+-- a package. @ghc-pkg@ now consumes this package format (as of version
+-- 6.4). This is specific to GHC at the moment.
+--
+-- The @.cabal@ file format is for describing a package that is not yet
+-- installed. It has a lot of flexibility, like conditionals and dependency
+-- ranges. As such, that format is not at all suitable for describing a package
+-- that has already been built and installed. By the time we get to that stage,
+-- we have resolved all conditionals and resolved dependency version
+-- constraints to exact versions of dependent packages. So, this module defines
+-- the 'InstalledPackageInfo' data structure that contains all the info we keep
+-- about an installed package. There is a parser and pretty printer. The
+-- textual format is rather simpler than the @.cabal@ format: there are no
+-- sections, for example.
+
+{- All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of the University nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
+
+-- This module is meant to be local-only to Distribution...
+
+module Distribution.InstalledPackageInfo (
+ InstalledPackageInfo_(..), InstalledPackageInfo,
+ ParseResult(..), PError(..), PWarning,
+ emptyInstalledPackageInfo,
+ parseInstalledPackageInfo,
+ showInstalledPackageInfo,
+ showInstalledPackageInfoField,
+ fieldsInstalledPackageInfo,
+ ) where
+
+import Distribution.ParseUtils
+ ( FieldDescr(..), ParseResult(..), PError(..), PWarning
+ , simpleField, listField, parseLicenseQ
+ , showFields, showSingleNamedField, parseFieldsFlat
+ , parseFilePathQ, parseTokenQ, parseModuleNameQ, parsePackageNameQ
+ , showFilePath, showToken, boolField, parseOptVersion
+ , parseFreeText, showFreeText )
+import Distribution.License ( License(..) )
+import Distribution.Package
+ ( PackageName(..), PackageIdentifier(..), PackageId, InstalledPackageId(..)
+ , packageName, packageVersion )
+import qualified Distribution.Package as Package
+ ( Package(..) )
+import Distribution.ModuleName
+ ( ModuleName )
+import Distribution.Version
+ ( Version(..) )
+import Distribution.Text
+ ( Text(disp, parse) )
+
+-- -----------------------------------------------------------------------------
+-- The InstalledPackageInfo type
+
+data InstalledPackageInfo_ m
+ = InstalledPackageInfo {
+ -- these parts are exactly the same as PackageDescription
+ installedPackageId :: InstalledPackageId,
+ sourcePackageId :: PackageId,
+ license :: License,
+ copyright :: String,
+ maintainer :: String,
+ author :: String,
+ stability :: String,
+ homepage :: String,
+ pkgUrl :: String,
+ synopsis :: String,
+ description :: String,
+ category :: String,
+ -- these parts are required by an installed package only:
+ exposed :: Bool,
+ exposedModules :: [m],
+ hiddenModules :: [m],
+ trusted :: Bool,
+ importDirs :: [FilePath], -- contain sources in case of Hugs
+ libraryDirs :: [FilePath],
+ hsLibraries :: [String],
+ extraLibraries :: [String],
+ extraGHCiLibraries:: [String], -- overrides extraLibraries for GHCi
+ includeDirs :: [FilePath],
+ includes :: [String],
+ depends :: [InstalledPackageId],
+ hugsOptions :: [String],
+ ccOptions :: [String],
+ ldOptions :: [String],
+ frameworkDirs :: [FilePath],
+ frameworks :: [String],
+ haddockInterfaces :: [FilePath],
+ haddockHTMLs :: [FilePath]
+ }
+ deriving (Read, Show)
+
+instance Package.Package (InstalledPackageInfo_ str) where
+ packageId = sourcePackageId
+
+type InstalledPackageInfo = InstalledPackageInfo_ ModuleName
+
+emptyInstalledPackageInfo :: InstalledPackageInfo_ m
+emptyInstalledPackageInfo
+ = InstalledPackageInfo {
+ installedPackageId = InstalledPackageId "",
+ sourcePackageId = PackageIdentifier (PackageName "") noVersion,
+ license = AllRightsReserved,
+ copyright = "",
+ maintainer = "",
+ author = "",
+ stability = "",
+ homepage = "",
+ pkgUrl = "",
+ synopsis = "",
+ description = "",
+ category = "",
+ exposed = False,
+ exposedModules = [],
+ hiddenModules = [],
+ trusted = False,
+ importDirs = [],
+ libraryDirs = [],
+ hsLibraries = [],
+ extraLibraries = [],
+ extraGHCiLibraries= [],
+ includeDirs = [],
+ includes = [],
+ depends = [],
+ hugsOptions = [],
+ ccOptions = [],
+ ldOptions = [],
+ frameworkDirs = [],
+ frameworks = [],
+ haddockInterfaces = [],
+ haddockHTMLs = []
+ }
+
+noVersion :: Version
+noVersion = Version{ versionBranch=[], versionTags=[] }
+
+-- -----------------------------------------------------------------------------
+-- Parsing
+
+parseInstalledPackageInfo :: String -> ParseResult InstalledPackageInfo
+parseInstalledPackageInfo =
+ parseFieldsFlat fieldsInstalledPackageInfo emptyInstalledPackageInfo
+
+-- -----------------------------------------------------------------------------
+-- Pretty-printing
+
+showInstalledPackageInfo :: InstalledPackageInfo -> String
+showInstalledPackageInfo = showFields fieldsInstalledPackageInfo
+
+showInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String)
+showInstalledPackageInfoField = showSingleNamedField fieldsInstalledPackageInfo
+
+-- -----------------------------------------------------------------------------
+-- Description of the fields, for parsing/printing
+
+fieldsInstalledPackageInfo :: [FieldDescr InstalledPackageInfo]
+fieldsInstalledPackageInfo = basicFieldDescrs ++ installedFieldDescrs
+
+basicFieldDescrs :: [FieldDescr InstalledPackageInfo]
+basicFieldDescrs =
+ [ simpleField "name"
+ disp parsePackageNameQ
+ packageName (\name pkg -> pkg{sourcePackageId=(sourcePackageId pkg){pkgName=name}})
+ , simpleField "version"
+ disp parseOptVersion
+ packageVersion (\ver pkg -> pkg{sourcePackageId=(sourcePackageId pkg){pkgVersion=ver}})
+ , simpleField "id"
+ disp parse
+ installedPackageId (\ipid pkg -> pkg{installedPackageId=ipid})
+ , simpleField "license"
+ disp parseLicenseQ
+ license (\l pkg -> pkg{license=l})
+ , simpleField "copyright"
+ showFreeText parseFreeText
+ copyright (\val pkg -> pkg{copyright=val})
+ , simpleField "maintainer"
+ showFreeText parseFreeText
+ maintainer (\val pkg -> pkg{maintainer=val})
+ , simpleField "stability"
+ showFreeText parseFreeText
+ stability (\val pkg -> pkg{stability=val})
+ , simpleField "homepage"
+ showFreeText parseFreeText
+ homepage (\val pkg -> pkg{homepage=val})
+ , simpleField "package-url"
+ showFreeText parseFreeText
+ pkgUrl (\val pkg -> pkg{pkgUrl=val})
+ , simpleField "synopsis"
+ showFreeText parseFreeText
+ synopsis (\val pkg -> pkg{synopsis=val})
+ , simpleField "description"
+ showFreeText parseFreeText
+ description (\val pkg -> pkg{description=val})
+ , simpleField "category"
+ showFreeText parseFreeText
+ category (\val pkg -> pkg{category=val})
+ , simpleField "author"
+ showFreeText parseFreeText
+ author (\val pkg -> pkg{author=val})
+ ]
+
+installedFieldDescrs :: [FieldDescr InstalledPackageInfo]
+installedFieldDescrs = [
+ boolField "exposed"
+ exposed (\val pkg -> pkg{exposed=val})
+ , listField "exposed-modules"
+ disp parseModuleNameQ
+ exposedModules (\xs pkg -> pkg{exposedModules=xs})
+ , listField "hidden-modules"
+ disp parseModuleNameQ
+ hiddenModules (\xs pkg -> pkg{hiddenModules=xs})
+ , boolField "trusted"
+ trusted (\val pkg -> pkg{trusted=val})
+ , listField "import-dirs"
+ showFilePath parseFilePathQ
+ importDirs (\xs pkg -> pkg{importDirs=xs})
+ , listField "library-dirs"
+ showFilePath parseFilePathQ
+ libraryDirs (\xs pkg -> pkg{libraryDirs=xs})
+ , listField "hs-libraries"
+ showFilePath parseTokenQ
+ hsLibraries (\xs pkg -> pkg{hsLibraries=xs})
+ , listField "extra-libraries"
+ showToken parseTokenQ
+ extraLibraries (\xs pkg -> pkg{extraLibraries=xs})
+ , listField "extra-ghci-libraries"
+ showToken parseTokenQ
+ extraGHCiLibraries (\xs pkg -> pkg{extraGHCiLibraries=xs})
+ , listField "include-dirs"
+ showFilePath parseFilePathQ
+ includeDirs (\xs pkg -> pkg{includeDirs=xs})
+ , listField "includes"
+ showFilePath parseFilePathQ
+ includes (\xs pkg -> pkg{includes=xs})
+ , listField "depends"
+ disp parse
+ depends (\xs pkg -> pkg{depends=xs})
+ , listField "hugs-options"
+ showToken parseTokenQ
+ hugsOptions (\path pkg -> pkg{hugsOptions=path})
+ , listField "cc-options"
+ showToken parseTokenQ
+ ccOptions (\path pkg -> pkg{ccOptions=path})
+ , listField "ld-options"
+ showToken parseTokenQ
+ ldOptions (\path pkg -> pkg{ldOptions=path})
+ , listField "framework-dirs"
+ showFilePath parseFilePathQ
+ frameworkDirs (\xs pkg -> pkg{frameworkDirs=xs})
+ , listField "frameworks"
+ showToken parseTokenQ
+ frameworks (\xs pkg -> pkg{frameworks=xs})
+ , listField "haddock-interfaces"
+ showFilePath parseFilePathQ
+ haddockInterfaces (\xs pkg -> pkg{haddockInterfaces=xs})
+ , listField "haddock-html"
+ showFilePath parseFilePathQ
+ haddockHTMLs (\xs pkg -> pkg{haddockHTMLs=xs})
+ ]
diff --git a/cabal/cabal/Distribution/License.hs b/cabal/cabal/Distribution/License.hs
new file mode 100644
index 0000000..27e5b30
--- /dev/null
+++ b/cabal/cabal/Distribution/License.hs
@@ -0,0 +1,138 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.License
+-- Copyright : Isaac Jones 2003-2005
+-- Duncan Coutts 2008
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Portability : portable
+--
+-- The License datatype. For more information about these and other
+-- open-source licenses, you may visit <http://www.opensource.org/>.
+--
+-- The @.cabal@ file allows you to specify a license file. Of course you can
+-- use any license you like but people often pick common open source licenses
+-- and it's useful if we can automatically recognise that (eg so we can display
+-- it on the hackage web pages). So you can also specify the license itself in
+-- the @.cabal@ file from a short enumeration defined in this module. It
+-- includes 'GPL', 'LGPL' and 'BSD3' licenses.
+
+{- All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Isaac Jones nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
+
+module Distribution.License (
+ License(..),
+ knownLicenses,
+ ) where
+
+import Distribution.Version (Version(Version))
+
+import Distribution.Text (Text(..), display)
+import qualified Distribution.Compat.ReadP as Parse
+import qualified Text.PrettyPrint as Disp
+import Text.PrettyPrint ((<>))
+import qualified Data.Char as Char (isAlphaNum)
+
+-- |This datatype indicates the license under which your package is
+-- released. It is also wise to add your license to each source file
+-- using the license-file field. The 'AllRightsReserved' constructor
+-- is not actually a license, but states that you are not giving
+-- anyone else a license to use or distribute your work. The comments
+-- below are general guidelines. Please read the licenses themselves
+-- and consult a lawyer if you are unsure of your rights to release
+-- the software.
+--
+data License =
+
+--TODO: * remove BSD4
+
+ -- | GNU Public License. Source code must accompany alterations.
+ GPL (Maybe Version)
+
+ -- | Lesser GPL, Less restrictive than GPL, useful for libraries.
+ | LGPL (Maybe Version)
+
+ -- | 3-clause BSD license, newer, no advertising clause. Very free license.
+ | BSD3
+
+ -- | 4-clause BSD license, older, with advertising clause. You almost
+ -- certainly want to use the BSD3 license instead.
+ | BSD4
+
+ -- | The MIT license, similar to the BSD3. Very free license.
+ | MIT
+
+ -- | Holder makes no claim to ownership, least restrictive license.
+ | PublicDomain
+
+ -- | No rights are granted to others. Undistributable. Most restrictive.
+ | AllRightsReserved
+
+ -- | Some other license.
+ | OtherLicense
+
+ -- | Not a recognised license.
+ -- Allows us to deal with future extensions more gracefully.
+ | UnknownLicense String
+ deriving (Read, Show, Eq)
+
+knownLicenses :: [License]
+knownLicenses = [ GPL unversioned, GPL (version [2]), GPL (version [3])
+ , LGPL unversioned, LGPL (version [2,1]), LGPL (version [3])
+ , BSD3, MIT
+ , PublicDomain, AllRightsReserved, OtherLicense]
+ where
+ unversioned = Nothing
+ version v = Just (Version v [])
+
+instance Text License where
+ disp (GPL version) = Disp.text "GPL" <> dispOptVersion version
+ disp (LGPL version) = Disp.text "LGPL" <> dispOptVersion version
+ disp (UnknownLicense other) = Disp.text other
+ disp other = Disp.text (show other)
+
+ parse = do
+ name <- Parse.munch1 (\c -> Char.isAlphaNum c && c /= '-')
+ version <- Parse.option Nothing (Parse.char '-' >> fmap Just parse)
+ return $! case (name, version :: Maybe Version) of
+ ("GPL", _ ) -> GPL version
+ ("LGPL", _ ) -> LGPL version
+ ("BSD3", Nothing) -> BSD3
+ ("BSD4", Nothing) -> BSD4
+ ("MIT", Nothing) -> MIT
+ ("PublicDomain", Nothing) -> PublicDomain
+ ("AllRightsReserved", Nothing) -> AllRightsReserved
+ ("OtherLicense", Nothing) -> OtherLicense
+ _ -> UnknownLicense $ name
+ ++ maybe "" (('-':) . display) version
+
+dispOptVersion :: Maybe Version -> Disp.Doc
+dispOptVersion Nothing = Disp.empty
+dispOptVersion (Just v) = Disp.char '-' <> disp v
diff --git a/cabal/cabal/Distribution/Make.hs b/cabal/cabal/Distribution/Make.hs
new file mode 100644
index 0000000..d085ce3
--- /dev/null
+++ b/cabal/cabal/Distribution/Make.hs
@@ -0,0 +1,213 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Make
+-- Copyright : Martin Sj&#xF6;gren 2004
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Portability : portable
+--
+-- This is an alternative build system that delegates everything to the @make@
+-- program. All the commands just end up calling @make@ with appropriate
+-- arguments. The intention was to allow preexisting packages that used
+-- makefiles to be wrapped into Cabal packages. In practice essentially all
+-- such packages were converted over to the \"Simple\" build system instead.
+-- Consequently this module is not used much and it certainly only sees cursory
+-- maintenance and no testing. Perhaps at some point we should stop pretending
+-- that it works.
+--
+-- Uses the parsed command-line from "Distribution.Simple.Setup" in order to build
+-- Haskell tools using a backend build system based on make. Obviously we
+-- assume that there is a configure script, and that after the ConfigCmd has
+-- been run, there is a Makefile. Further assumptions:
+--
+-- [ConfigCmd] We assume the configure script accepts
+-- @--with-hc@,
+-- @--with-hc-pkg@,
+-- @--prefix@,
+-- @--bindir@,
+-- @--libdir@,
+-- @--libexecdir@,
+-- @--datadir@.
+--
+-- [BuildCmd] We assume that the default Makefile target will build everything.
+--
+-- [InstallCmd] We assume there is an @install@ target. Note that we assume that
+-- this does *not* register the package!
+--
+-- [CopyCmd] We assume there is a @copy@ target, and a variable @$(destdir)@.
+-- The @copy@ target should probably just invoke @make install@
+-- recursively (e.g. @$(MAKE) install prefix=$(destdir)\/$(prefix)
+-- bindir=$(destdir)\/$(bindir)@. The reason we can\'t invoke @make
+-- install@ directly here is that we don\'t know the value of @$(prefix)@.
+--
+-- [SDistCmd] We assume there is a @dist@ target.
+--
+-- [RegisterCmd] We assume there is a @register@ target and a variable @$(user)@.
+--
+-- [UnregisterCmd] We assume there is an @unregister@ target.
+--
+-- [HaddockCmd] We assume there is a @docs@ or @doc@ target.
+
+
+-- copy :
+-- $(MAKE) install prefix=$(destdir)/$(prefix) \
+-- bindir=$(destdir)/$(bindir) \
+
+{- All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Isaac Jones nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
+
+module Distribution.Make (
+ module Distribution.Package,
+ License(..), Version(..),
+ defaultMain, defaultMainArgs, defaultMainNoRead
+ ) where
+
+-- local
+import Distribution.Compat.Exception
+import Distribution.Package --must not specify imports, since we're exporting moule.
+import Distribution.Simple.Program(defaultProgramConfiguration)
+import Distribution.PackageDescription
+import Distribution.Simple.Setup
+import Distribution.Simple.Command
+
+import Distribution.Simple.Utils (rawSystemExit, cabalVersion)
+
+import Distribution.License (License(..))
+import Distribution.Version
+ ( Version(..) )
+import Distribution.Text
+ ( display )
+
+import System.Environment (getArgs, getProgName)
+import Data.List (intersperse)
+import System.Exit
+
+defaultMain :: IO ()
+defaultMain = getArgs >>= defaultMainArgs
+
+defaultMainArgs :: [String] -> IO ()
+defaultMainArgs = defaultMainHelper
+
+{-# DEPRECATED defaultMainNoRead "it ignores its PackageDescription arg" #-}
+defaultMainNoRead :: PackageDescription -> IO ()
+defaultMainNoRead = const defaultMain
+
+defaultMainHelper :: [String] -> IO ()
+defaultMainHelper args =
+ case commandsRun globalCommand commands args of
+ CommandHelp help -> printHelp help
+ CommandList opts -> printOptionsList opts
+ CommandErrors errs -> printErrors errs
+ CommandReadyToGo (flags, commandParse) ->
+ case commandParse of
+ _ | fromFlag (globalVersion flags) -> printVersion
+ | fromFlag (globalNumericVersion flags) -> printNumericVersion
+ CommandHelp help -> printHelp help
+ CommandList opts -> printOptionsList opts
+ CommandErrors errs -> printErrors errs
+ CommandReadyToGo action -> action
+
+ where
+ printHelp help = getProgName >>= putStr . help
+ printOptionsList = putStr . unlines
+ printErrors errs = do
+ putStr (concat (intersperse "\n" errs))
+ exitWith (ExitFailure 1)
+ printNumericVersion = putStrLn $ display cabalVersion
+ printVersion = putStrLn $ "Cabal library version "
+ ++ display cabalVersion
+
+ progs = defaultProgramConfiguration
+ commands =
+ [configureCommand progs `commandAddAction` configureAction
+ ,buildCommand progs `commandAddAction` buildAction
+ ,installCommand `commandAddAction` installAction
+ ,copyCommand `commandAddAction` copyAction
+ ,haddockCommand `commandAddAction` haddockAction
+ ,cleanCommand `commandAddAction` cleanAction
+ ,sdistCommand `commandAddAction` sdistAction
+ ,registerCommand `commandAddAction` registerAction
+ ,unregisterCommand `commandAddAction` unregisterAction
+ ]
+
+configureAction :: ConfigFlags -> [String] -> IO ()
+configureAction flags args = do
+ noExtraFlags args
+ let verbosity = fromFlag (configVerbosity flags)
+ rawSystemExit verbosity "sh" $
+ "configure"
+ : configureArgs backwardsCompatHack flags
+ where backwardsCompatHack = True
+
+copyAction :: CopyFlags -> [String] -> IO ()
+copyAction flags args = do
+ noExtraFlags args
+ let destArgs = case fromFlag $ copyDest flags of
+ NoCopyDest -> ["install"]
+ CopyTo path -> ["copy", "destdir=" ++ path]
+ rawSystemExit (fromFlag $ copyVerbosity flags) "make" destArgs
+
+installAction :: InstallFlags -> [String] -> IO ()
+installAction flags args = do
+ noExtraFlags args
+ rawSystemExit (fromFlag $ installVerbosity flags) "make" ["install"]
+ rawSystemExit (fromFlag $ installVerbosity flags) "make" ["register"]
+
+haddockAction :: HaddockFlags -> [String] -> IO ()
+haddockAction flags args = do
+ noExtraFlags args
+ rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["docs"]
+ `catchIO` \_ ->
+ rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["doc"]
+
+buildAction :: BuildFlags -> [String] -> IO ()
+buildAction flags args = do
+ noExtraFlags args
+ rawSystemExit (fromFlag $ buildVerbosity flags) "make" []
+
+cleanAction :: CleanFlags -> [String] -> IO ()
+cleanAction flags args = do
+ noExtraFlags args
+ rawSystemExit (fromFlag $ cleanVerbosity flags) "make" ["clean"]
+
+sdistAction :: SDistFlags -> [String] -> IO ()
+sdistAction flags args = do
+ noExtraFlags args
+ rawSystemExit (fromFlag $ sDistVerbosity flags) "make" ["dist"]
+
+registerAction :: RegisterFlags -> [String] -> IO ()
+registerAction flags args = do
+ noExtraFlags args
+ rawSystemExit (fromFlag $ regVerbosity flags) "make" ["register"]
+
+unregisterAction :: RegisterFlags -> [String] -> IO ()
+unregisterAction flags args = do
+ noExtraFlags args
+ rawSystemExit (fromFlag $ regVerbosity flags) "make" ["unregister"]
diff --git a/cabal/cabal/Distribution/ModuleName.hs b/cabal/cabal/Distribution/ModuleName.hs
new file mode 100644
index 0000000..5fe0cc1
--- /dev/null
+++ b/cabal/cabal/Distribution/ModuleName.hs
@@ -0,0 +1,130 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.ModuleName
+-- Copyright : Duncan Coutts 2008
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Portability : portable
+--
+-- Data type for Haskell module names.
+
+{- All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Isaac Jones nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
+
+module Distribution.ModuleName (
+ ModuleName,
+ fromString,
+ components,
+ toFilePath,
+ main,
+ simple,
+ ) where
+
+import Distribution.Text
+ ( Text(..) )
+
+import qualified Distribution.Compat.ReadP as Parse
+import qualified Text.PrettyPrint as Disp
+import qualified Data.Char as Char
+ ( isAlphaNum, isUpper )
+import System.FilePath
+ ( pathSeparator )
+import Data.List
+ ( intersperse )
+
+-- | A valid Haskell module name.
+--
+newtype ModuleName = ModuleName [String]
+ deriving (Eq, Ord, Read, Show)
+
+instance Text ModuleName where
+ disp (ModuleName ms) =
+ Disp.hcat (intersperse (Disp.char '.') (map Disp.text ms))
+
+ parse = do
+ ms <- Parse.sepBy1 component (Parse.char '.')
+ return (ModuleName ms)
+
+ where
+ component = do
+ c <- Parse.satisfy Char.isUpper
+ cs <- Parse.munch validModuleChar
+ return (c:cs)
+
+validModuleChar :: Char -> Bool
+validModuleChar c = Char.isAlphaNum c || c == '_' || c == '\''
+
+validModuleComponent :: String -> Bool
+validModuleComponent [] = False
+validModuleComponent (c:cs) = Char.isUpper c
+ && all validModuleChar cs
+
+{-# DEPRECATED simple "use ModuleName.fromString instead" #-}
+simple :: String -> ModuleName
+simple str = ModuleName [str]
+
+-- | Construct a 'ModuleName' from a valid module name 'String'.
+--
+-- This is just a convenience function intended for valid module strings. It is
+-- an error if it is used with a string that is not a valid module name. If you
+-- are parsing user input then use 'Distribution.Text.simpleParse' instead.
+--
+fromString :: String -> ModuleName
+fromString string
+ | all validModuleComponent components' = ModuleName components'
+ | otherwise = error badName
+
+ where
+ components' = split string
+ badName = "ModuleName.fromString: invalid module name " ++ show string
+
+ split cs = case break (=='.') cs of
+ (chunk,[]) -> chunk : []
+ (chunk,_:rest) -> chunk : split rest
+
+-- | The module name @Main@.
+--
+main :: ModuleName
+main = ModuleName ["Main"]
+
+-- | The individual components of a hierarchical module name. For example
+--
+-- > components (fromString "A.B.C") = ["A", "B", "C"]
+--
+components :: ModuleName -> [String]
+components (ModuleName ms) = ms
+
+-- | Convert a module name to a file path, but without any file extension.
+-- For example:
+--
+-- > toFilePath (fromString "A.B.C") = "A/B/C"
+--
+toFilePath :: ModuleName -> FilePath
+toFilePath = concat . intersperse [pathSeparator] . components
diff --git a/cabal/cabal/Distribution/Package.hs b/cabal/cabal/Distribution/Package.hs
new file mode 100644
index 0000000..fb2f3e0
--- /dev/null
+++ b/cabal/cabal/Distribution/Package.hs
@@ -0,0 +1,193 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Package
+-- Copyright : Isaac Jones 2003-2004
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Portability : portable
+--
+-- Defines a package identifier along with a parser and pretty printer for it.
+-- 'PackageIdentifier's consist of a name and an exact version. It also defines
+-- a 'Dependency' data type. A dependency is a package name and a version
+-- range, like @\"foo >= 1.2 && < 2\"@.
+
+{- All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Isaac Jones nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
+
+module Distribution.Package (
+ -- * Package ids
+ PackageName(..),
+ PackageIdentifier(..),
+ PackageId,
+
+ -- * Installed package identifiers
+ InstalledPackageId(..),
+
+ -- * Package source dependencies
+ Dependency(..),
+ thisPackageVersion,
+ notThisPackageVersion,
+ simplifyDependency,
+
+ -- * Package classes
+ Package(..), packageName, packageVersion,
+ PackageFixedDeps(..),
+ ) where
+
+import Distribution.Version
+ ( Version(..), VersionRange, anyVersion, thisVersion
+ , notThisVersion, simplifyVersionRange )
+
+import Distribution.Text (Text(..))
+import qualified Distribution.Compat.ReadP as Parse
+import Distribution.Compat.ReadP ((<++))
+import qualified Text.PrettyPrint as Disp
+import Text.PrettyPrint ((<>), (<+>), text)
+import qualified Data.Char as Char ( isDigit, isAlphaNum )
+import Data.List ( intersperse )
+
+newtype PackageName = PackageName String
+ deriving (Read, Show, Eq, Ord)
+
+instance Text PackageName where
+ disp (PackageName n) = Disp.text n
+ parse = do
+ ns <- Parse.sepBy1 component (Parse.char '-')
+ return (PackageName (concat (intersperse "-" ns)))
+ where
+ component = do
+ cs <- Parse.munch1 Char.isAlphaNum
+ if all Char.isDigit cs then Parse.pfail else return cs
+ -- each component must contain an alphabetic character, to avoid
+ -- ambiguity in identifiers like foo-1 (the 1 is the version number).
+
+-- | Type alias so we can use the shorter name PackageId.
+type PackageId = PackageIdentifier
+
+-- | The name and version of a package.
+data PackageIdentifier
+ = PackageIdentifier {
+ pkgName :: PackageName, -- ^The name of this package, eg. foo
+ pkgVersion :: Version -- ^the version of this package, eg 1.2
+ }
+ deriving (Read, Show, Eq, Ord)
+
+instance Text PackageIdentifier where
+ disp (PackageIdentifier n v) = case v of
+ Version [] _ -> disp n -- if no version, don't show version.
+ _ -> disp n <> Disp.char '-' <> disp v
+
+ parse = do
+ n <- parse
+ v <- (Parse.char '-' >> parse) <++ return (Version [] [])
+ return (PackageIdentifier n v)
+
+-- ------------------------------------------------------------
+-- * Installed Package Ids
+-- ------------------------------------------------------------
+
+-- | An InstalledPackageId uniquely identifies an instance of an installed package.
+-- There can be at most one package with a given 'InstalledPackageId'
+-- in a package database, or overlay of databases.
+--
+newtype InstalledPackageId = InstalledPackageId String
+ deriving (Read,Show,Eq,Ord)
+
+instance Text InstalledPackageId where
+ disp (InstalledPackageId str) = text str
+
+ parse = InstalledPackageId `fmap` Parse.munch1 abi_char
+ where abi_char c = Char.isAlphaNum c || c `elem` ":-_."
+
+-- ------------------------------------------------------------
+-- * Package source dependencies
+-- ------------------------------------------------------------
+
+-- | Describes a dependency on a source package (API)
+--
+data Dependency = Dependency PackageName VersionRange
+ deriving (Read, Show, Eq)
+
+instance Text Dependency where
+ disp (Dependency name ver) =
+ disp name <+> disp ver
+
+ parse = do name <- parse
+ Parse.skipSpaces
+ ver <- parse <++ return anyVersion
+ Parse.skipSpaces
+ return (Dependency name ver)
+
+thisPackageVersion :: PackageIdentifier -> Dependency
+thisPackageVersion (PackageIdentifier n v) =
+ Dependency n (thisVersion v)
+
+notThisPackageVersion :: PackageIdentifier -> Dependency
+notThisPackageVersion (PackageIdentifier n v) =
+ Dependency n (notThisVersion v)
+
+-- | Simplify the 'VersionRange' expression in a 'Dependency'.
+-- See 'simplifyVersionRange'.
+--
+simplifyDependency :: Dependency -> Dependency
+simplifyDependency (Dependency name range) =
+ Dependency name (simplifyVersionRange range)
+
+-- | Class of things that have a 'PackageIdentifier'
+--
+-- Types in this class are all notions of a package. This allows us to have
+-- different types for the different phases that packages go though, from
+-- simple name\/id, package description, configured or installed packages.
+--
+-- Not all kinds of packages can be uniquely identified by a
+-- 'PackageIdentifier'. In particular, installed packages cannot, there may be
+-- many installed instances of the same source package.
+--
+class Package pkg where
+ packageId :: pkg -> PackageIdentifier
+
+packageName :: Package pkg => pkg -> PackageName
+packageName = pkgName . packageId
+
+packageVersion :: Package pkg => pkg -> Version
+packageVersion = pkgVersion . packageId
+
+instance Package PackageIdentifier where
+ packageId = id
+
+-- | Subclass of packages that have specific versioned dependencies.
+--
+-- So for example a not-yet-configured package has dependencies on version
+-- ranges, not specific versions. A configured or an already installed package
+-- depends on exact versions. Some operations or data structures (like
+-- dependency graphs) only make sense on this subclass of package types.
+--
+class Package pkg => PackageFixedDeps pkg where
+ depends :: pkg -> [PackageIdentifier]
diff --git a/cabal/cabal/Distribution/PackageDescription.hs b/cabal/cabal/Distribution/PackageDescription.hs
new file mode 100644
index 0000000..f4e3622
--- /dev/null
+++ b/cabal/cabal/Distribution/PackageDescription.hs
@@ -0,0 +1,895 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.PackageDescription
+-- Copyright : Isaac Jones 2003-2005
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Portability : portable
+--
+-- This defines the data structure for the @.cabal@ file format. There are
+-- several parts to this structure. It has top level info and then 'Library',
+-- 'Executable', and 'TestSuite' sections each of which have associated
+-- 'BuildInfo' data that's used to build the library, exe, or test. To further
+-- complicate things there is both a 'PackageDescription' and a
+-- 'GenericPackageDescription'. This distinction relates to cabal
+-- configurations. When we initially read a @.cabal@ file we get a
+-- 'GenericPackageDescription' which has all the conditional sections.
+-- Before actually building a package we have to decide
+-- on each conditional. Once we've done that we get a 'PackageDescription'.
+-- It was done this way initially to avoid breaking too much stuff when the
+-- feature was introduced. It could probably do with being rationalised at some
+-- point to make it simpler.
+
+{- All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Isaac Jones nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
+
+module Distribution.PackageDescription (
+ -- * Package descriptions
+ PackageDescription(..),
+ emptyPackageDescription,
+ specVersion,
+ descCabalVersion,
+ BuildType(..),
+ knownBuildTypes,
+
+ -- ** Libraries
+ Library(..),
+ emptyLibrary,
+ withLib,
+ hasLibs,
+ libModules,
+
+ -- ** Executables
+ Executable(..),
+ emptyExecutable,
+ withExe,
+ hasExes,
+ exeModules,
+
+ -- * Tests
+ TestSuite(..),
+ TestSuiteInterface(..),
+ TestType(..),
+ testType,
+ knownTestTypes,
+ emptyTestSuite,
+ hasTests,
+ withTest,
+ testModules,
+ enabledTests,
+
+ -- * Build information
+ BuildInfo(..),
+ emptyBuildInfo,
+ allBuildInfo,
+ allLanguages,
+ allExtensions,
+ usedExtensions,
+ hcOptions,
+
+ -- ** Supplementary build information
+ HookedBuildInfo,
+ emptyHookedBuildInfo,
+ updatePackageDescription,
+
+ -- * package configuration
+ GenericPackageDescription(..),
+ Flag(..), FlagName(..), FlagAssignment,
+ CondTree(..), ConfVar(..), Condition(..),
+
+ -- * Source repositories
+ SourceRepo(..),
+ RepoKind(..),
+ RepoType(..),
+ knownRepoTypes,
+ ) where
+
+import Data.List (nub, intersperse)
+import Data.Maybe (maybeToList)
+import Data.Monoid (Monoid(mempty, mappend))
+import Control.Monad (MonadPlus(mplus))
+import Text.PrettyPrint.HughesPJ as Disp
+import qualified Distribution.Compat.ReadP as Parse
+import qualified Data.Char as Char (isAlphaNum, isDigit, toLower)
+
+import Distribution.Package
+ ( PackageName(PackageName), PackageIdentifier(PackageIdentifier)
+ , Dependency, Package(..) )
+import Distribution.ModuleName ( ModuleName )
+import Distribution.Version
+ ( Version(Version), VersionRange, anyVersion, orLaterVersion
+ , asVersionIntervals, LowerBound(..) )
+import Distribution.License (License(AllRightsReserved))
+import Distribution.Compiler (CompilerFlavor)
+import Distribution.System (OS, Arch)
+import Distribution.Text
+ ( Text(..), display )
+import Language.Haskell.Extension
+ ( Language, Extension )
+
+-- -----------------------------------------------------------------------------
+-- The PackageDescription type
+
+-- | This data type is the internal representation of the file @pkg.cabal@.
+-- It contains two kinds of information about the package: information
+-- which is needed for all packages, such as the package name and version, and
+-- information which is needed for the simple build system only, such as
+-- the compiler options and library name.
+--
+data PackageDescription
+ = PackageDescription {
+ -- the following are required by all packages:
+ package :: PackageIdentifier,
+ license :: License,
+ licenseFile :: FilePath,
+ copyright :: String,
+ maintainer :: String,
+ author :: String,
+ stability :: String,
+ testedWith :: [(CompilerFlavor,VersionRange)],
+ homepage :: String,
+ pkgUrl :: String,
+ bugReports :: String,
+ sourceRepos :: [SourceRepo],
+ synopsis :: String, -- ^A one-line summary of this package
+ description :: String, -- ^A more verbose description of this package
+ category :: String,
+ customFieldsPD :: [(String,String)], -- ^Custom fields starting
+ -- with x-, stored in a
+ -- simple assoc-list.
+ buildDepends :: [Dependency],
+ -- | The version of the Cabal spec that this package description uses.
+ -- For historical reasons this is specified with a version range but
+ -- only ranges of the form @>= v@ make sense. We are in the process of
+ -- transitioning to specifying just a single version, not a range.
+ specVersionRaw :: Either Version VersionRange,
+ buildType :: Maybe BuildType,
+ -- components
+ library :: Maybe Library,
+ executables :: [Executable],
+ testSuites :: [TestSuite],
+ dataFiles :: [FilePath],
+ dataDir :: FilePath,
+ extraSrcFiles :: [FilePath],
+ extraTmpFiles :: [FilePath]
+ }
+ deriving (Show, Read, Eq)
+
+instance Package PackageDescription where
+ packageId = package
+
+-- | The version of the Cabal spec that this package should be interpreted
+-- against.
+--
+-- Historically we used a version range but we are switching to using a single
+-- version. Currently we accept either. This function converts into a single
+-- version by ignoring upper bounds in the version range.
+--
+specVersion :: PackageDescription -> Version
+specVersion pkg = case specVersionRaw pkg of
+ Left version -> version
+ Right versionRange -> case asVersionIntervals versionRange of
+ [] -> Version [0] []
+ ((LowerBound version _, _):_) -> version
+
+-- | The range of versions of the Cabal tools that this package is intended to
+-- work with.
+--
+-- This function is deprecated and should not be used for new purposes, only to
+-- support old packages that rely on the old interpretation.
+--
+descCabalVersion :: PackageDescription -> VersionRange
+descCabalVersion pkg = case specVersionRaw pkg of
+ Left version -> orLaterVersion version
+ Right versionRange -> versionRange
+{-# DEPRECATED descCabalVersion "Use specVersion instead" #-}
+
+emptyPackageDescription :: PackageDescription
+emptyPackageDescription
+ = PackageDescription {
+ package = PackageIdentifier (PackageName "")
+ (Version [] []),
+ license = AllRightsReserved,
+ licenseFile = "",
+ specVersionRaw = Right anyVersion,
+ buildType = Nothing,
+ copyright = "",
+ maintainer = "",
+ author = "",
+ stability = "",
+ testedWith = [],
+ buildDepends = [],
+ homepage = "",
+ pkgUrl = "",
+ bugReports = "",
+ sourceRepos = [],
+ synopsis = "",
+ description = "",
+ category = "",
+ customFieldsPD = [],
+ library = Nothing,
+ executables = [],
+ testSuites = [],
+ dataFiles = [],
+ dataDir = "",
+ extraSrcFiles = [],
+ extraTmpFiles = []
+ }
+
+-- | The type of build system used by this package.
+data BuildType
+ = Simple -- ^ calls @Distribution.Simple.defaultMain@
+ | Configure -- ^ calls @Distribution.Simple.defaultMainWithHooks defaultUserHooks@,
+ -- which invokes @configure@ to generate additional build
+ -- information used by later phases.
+ | Make -- ^ calls @Distribution.Make.defaultMain@
+ | Custom -- ^ uses user-supplied @Setup.hs@ or @Setup.lhs@ (default)
+ | UnknownBuildType String
+ -- ^ a package that uses an unknown build type cannot actually
+ -- be built. Doing it this way rather than just giving a
+ -- parse error means we get better error messages and allows
+ -- you to inspect the rest of the package description.
+ deriving (Show, Read, Eq)
+
+knownBuildTypes :: [BuildType]
+knownBuildTypes = [Simple, Configure, Make, Custom]
+
+instance Text BuildType where
+ disp (UnknownBuildType other) = Disp.text other
+ disp other = Disp.text (show other)
+
+ parse = do
+ name <- Parse.munch1 Char.isAlphaNum
+ return $ case name of
+ "Simple" -> Simple
+ "Configure" -> Configure
+ "Custom" -> Custom
+ "Make" -> Make
+ _ -> UnknownBuildType name
+
+-- ---------------------------------------------------------------------------
+-- The Library type
+
+data Library = Library {
+ exposedModules :: [ModuleName],
+ libExposed :: Bool, -- ^ Is the lib to be exposed by default?
+ libBuildInfo :: BuildInfo
+ }
+ deriving (Show, Eq, Read)
+
+instance Monoid Library where
+ mempty = Library {
+ exposedModules = mempty,
+ libExposed = True,
+ libBuildInfo = mempty
+ }
+ mappend a b = Library {
+ exposedModules = combine exposedModules,
+ libExposed = libExposed a && libExposed b, -- so False propagates
+ libBuildInfo = combine libBuildInfo
+ }
+ where combine field = field a `mappend` field b
+
+emptyLibrary :: Library
+emptyLibrary = mempty
+
+-- |does this package have any libraries?
+hasLibs :: PackageDescription -> Bool
+hasLibs p = maybe False (buildable . libBuildInfo) (library p)
+
+-- |'Maybe' version of 'hasLibs'
+maybeHasLibs :: PackageDescription -> Maybe Library
+maybeHasLibs p =
+ library p >>= \lib -> if buildable (libBuildInfo lib)
+ then Just lib
+ else Nothing
+
+-- |If the package description has a library section, call the given
+-- function with the library build info as argument.
+withLib :: PackageDescription -> (Library -> IO ()) -> IO ()
+withLib pkg_descr f =
+ maybe (return ()) f (maybeHasLibs pkg_descr)
+
+-- | Get all the module names from the library (exposed and internal modules)
+libModules :: Library -> [ModuleName]
+libModules lib = exposedModules lib
+ ++ otherModules (libBuildInfo lib)
+
+-- ---------------------------------------------------------------------------
+-- The Executable type
+
+data Executable = Executable {
+ exeName :: String,
+ modulePath :: FilePath,
+ buildInfo :: BuildInfo
+ }
+ deriving (Show, Read, Eq)
+
+instance Monoid Executable where
+ mempty = Executable {
+ exeName = mempty,
+ modulePath = mempty,
+ buildInfo = mempty
+ }
+ mappend a b = Executable{
+ exeName = combine' exeName,
+ modulePath = combine modulePath,
+ buildInfo = combine buildInfo
+ }
+ where combine field = field a `mappend` field b
+ combine' field = case (field a, field b) of
+ ("","") -> ""
+ ("", x) -> x
+ (x, "") -> x
+ (x, y) -> error $ "Ambiguous values for executable field: '"
+ ++ x ++ "' and '" ++ y ++ "'"
+
+emptyExecutable :: Executable
+emptyExecutable = mempty
+
+-- |does this package have any executables?
+hasExes :: PackageDescription -> Bool
+hasExes p = any (buildable . buildInfo) (executables p)
+
+-- | Perform the action on each buildable 'Executable' in the package
+-- description.
+withExe :: PackageDescription -> (Executable -> IO ()) -> IO ()
+withExe pkg_descr f =
+ sequence_ [f exe | exe <- executables pkg_descr, buildable (buildInfo exe)]
+
+-- | Get all the module names from an exe
+exeModules :: Executable -> [ModuleName]
+exeModules exe = otherModules (buildInfo exe)
+
+-- ---------------------------------------------------------------------------
+-- The TestSuite type
+
+-- | A \"test-suite\" stanza in a cabal file.
+--
+data TestSuite = TestSuite {
+ testName :: String,
+ testInterface :: TestSuiteInterface,
+ testBuildInfo :: BuildInfo,
+ testEnabled :: Bool
+ -- TODO: By having a 'testEnabled' field in the PackageDescription, we
+ -- are mixing build status information (i.e., arguments to 'configure')
+ -- with static package description information. This is undesirable, but
+ -- a better solution is waiting on the next overhaul to the
+ -- GenericPackageDescription -> PackageDescription resolution process.
+ }
+ deriving (Show, Read, Eq)
+
+-- | The test suite interfaces that are currently defined. Each test suite must
+-- specify which interface it supports.
+--
+-- More interfaces may be defined in future, either new revisions or totally
+-- new interfaces.
+--
+data TestSuiteInterface =
+
+ -- | Test interface \"exitcode-stdio-1.0\". The test-suite takes the form
+ -- of an executable. It returns a zero exit code for success, non-zero for
+ -- failure. The stdout and stderr channels may be logged. It takes no
+ -- command line parameters and nothing on stdin.
+ --
+ TestSuiteExeV10 Version FilePath
+
+ -- | Test interface \"detailed-0.9\". The test-suite takes the form of a
+ -- library containing a designated module that exports \"tests :: [Test]\".
+ --
+ | TestSuiteLibV09 Version ModuleName
+
+ -- | A test suite that does not conform to one of the above interfaces for
+ -- the given reason (e.g. unknown test type).
+ --
+ | TestSuiteUnsupported TestType
+ deriving (Eq, Read, Show)
+
+instance Monoid TestSuite where
+ mempty = TestSuite {
+ testName = mempty,
+ testInterface = mempty,
+ testBuildInfo = mempty,
+ testEnabled = False
+ }
+
+ mappend a b = TestSuite {
+ testName = combine' testName,
+ testInterface = combine testInterface,
+ testBuildInfo = combine testBuildInfo,
+ testEnabled = if testEnabled a then True else testEnabled b
+ }
+ where combine field = field a `mappend` field b
+ combine' f = case (f a, f b) of
+ ("", x) -> x
+ (x, "") -> x
+ (x, y) -> error "Ambiguous values for test field: '"
+ ++ x ++ "' and '" ++ y ++ "'"
+
+instance Monoid TestSuiteInterface where
+ mempty = TestSuiteUnsupported (TestTypeUnknown mempty (Version [] []))
+ mappend a (TestSuiteUnsupported _) = a
+ mappend _ b = b
+
+emptyTestSuite :: TestSuite
+emptyTestSuite = mempty
+
+-- | Does this package have any test suites?
+hasTests :: PackageDescription -> Bool
+hasTests = any (buildable . testBuildInfo) . testSuites
+
+-- | Get all the enabled test suites from a package.
+enabledTests :: PackageDescription -> [TestSuite]
+enabledTests = filter testEnabled . testSuites
+
+-- | Perform an action on each buildable 'TestSuite' in a package.
+withTest :: PackageDescription -> (TestSuite -> IO ()) -> IO ()
+withTest pkg_descr f =
+ mapM_ f $ filter (buildable . testBuildInfo) $ enabledTests pkg_descr
+
+-- | Get all the module names from a test suite.
+testModules :: TestSuite -> [ModuleName]
+testModules test = (case testInterface test of
+ TestSuiteLibV09 _ m -> [m]
+ _ -> [])
+ ++ otherModules (testBuildInfo test)
+
+-- | The \"test-type\" field in the test suite stanza.
+--
+data TestType = TestTypeExe Version -- ^ \"type: exitcode-stdio-x.y\"
+ | TestTypeLib Version -- ^ \"type: detailed-x.y\"
+ | TestTypeUnknown String Version -- ^ Some unknown test type e.g. \"type: foo\"
+ deriving (Show, Read, Eq)
+
+knownTestTypes :: [TestType]
+knownTestTypes = [ TestTypeExe (Version [1,0] [])
+ -- 'detailed-0.9' test type is disabled in Cabal-1.10.x
+ -- needs more work on the details of the library interface
+ {- , TestTypeLib (Version [0,9] []) -} ]
+
+instance Text TestType where
+ disp (TestTypeExe ver) = text "exitcode-stdio-" <> disp ver
+ disp (TestTypeLib ver) = text "detailed-" <> disp ver
+ disp (TestTypeUnknown name ver) = text name <> char '-' <> disp ver
+
+ parse = do
+ cs <- Parse.sepBy1 component (Parse.char '-')
+ _ <- Parse.char '-'
+ ver <- parse
+ let name = concat (intersperse "-" cs)
+ return $! case lowercase name of
+ "exitcode-stdio" -> TestTypeExe ver
+ "detailed" -> TestTypeLib ver
+ _ -> TestTypeUnknown name ver
+
+ where
+ component = do
+ cs <- Parse.munch1 Char.isAlphaNum
+ if all Char.isDigit cs then Parse.pfail else return cs
+ -- each component must contain an alphabetic character, to avoid
+ -- ambiguity in identifiers like foo-1 (the 1 is the version number).
+
+testType :: TestSuite -> TestType
+testType test = case testInterface test of
+ TestSuiteExeV10 ver _ -> TestTypeExe ver
+ TestSuiteLibV09 ver _ -> TestTypeLib ver
+ TestSuiteUnsupported testtype -> testtype
+
+-- ---------------------------------------------------------------------------
+-- The BuildInfo type
+
+-- Consider refactoring into executable and library versions.
+data BuildInfo = BuildInfo {
+ buildable :: Bool, -- ^ component is buildable here
+ buildTools :: [Dependency], -- ^ tools needed to build this bit
+ cppOptions :: [String], -- ^ options for pre-processing Haskell code
+ ccOptions :: [String], -- ^ options for C compiler
+ ldOptions :: [String], -- ^ options for linker
+ pkgconfigDepends :: [Dependency], -- ^ pkg-config packages that are used
+ frameworks :: [String], -- ^support frameworks for Mac OS X
+ cSources :: [FilePath],
+ hsSourceDirs :: [FilePath], -- ^ where to look for the haskell module hierarchy
+ otherModules :: [ModuleName], -- ^ non-exposed or non-main modules
+
+ defaultLanguage :: Maybe Language,-- ^ language used when not explicitly specified
+ otherLanguages :: [Language], -- ^ other languages used within the package
+ defaultExtensions :: [Extension], -- ^ language extensions used by all modules
+ otherExtensions :: [Extension], -- ^ other language extensions used within the package
+ oldExtensions :: [Extension], -- ^ the old extensions field, treated same as 'defaultExtensions'
+
+ extraLibs :: [String], -- ^ what libraries to link with when compiling a program that uses your package
+ extraLibDirs :: [String],
+ includeDirs :: [FilePath], -- ^directories to find .h files
+ includes :: [FilePath], -- ^ The .h files to be found in includeDirs
+ installIncludes :: [FilePath], -- ^ .h files to install with the package
+ options :: [(CompilerFlavor,[String])],
+ ghcProfOptions :: [String],
+ ghcSharedOptions :: [String],
+ customFieldsBI :: [(String,String)], -- ^Custom fields starting
+ -- with x-, stored in a
+ -- simple assoc-list.
+ targetBuildDepends :: [Dependency] -- ^ Dependencies specific to a library or executable target
+ }
+ deriving (Show,Read,Eq)
+
+instance Monoid BuildInfo where
+ mempty = BuildInfo {
+ buildable = True,
+ buildTools = [],
+ cppOptions = [],
+ ccOptions = [],
+ ldOptions = [],
+ pkgconfigDepends = [],
+ frameworks = [],
+ cSources = [],
+ hsSourceDirs = [],
+ otherModules = [],
+ defaultLanguage = Nothing,
+ otherLanguages = [],
+ defaultExtensions = [],
+ otherExtensions = [],
+ oldExtensions = [],
+ extraLibs = [],
+ extraLibDirs = [],
+ includeDirs = [],
+ includes = [],
+ installIncludes = [],
+ options = [],
+ ghcProfOptions = [],
+ ghcSharedOptions = [],
+ customFieldsBI = [],
+ targetBuildDepends = []
+ }
+ mappend a b = BuildInfo {
+ buildable = buildable a && buildable b,
+ buildTools = combine buildTools,
+ cppOptions = combine cppOptions,
+ ccOptions = combine ccOptions,
+ ldOptions = combine ldOptions,
+ pkgconfigDepends = combine pkgconfigDepends,
+ frameworks = combineNub frameworks,
+ cSources = combineNub cSources,
+ hsSourceDirs = combineNub hsSourceDirs,
+ otherModules = combineNub otherModules,
+ defaultLanguage = combineMby defaultLanguage,
+ otherLanguages = combineNub otherLanguages,
+ defaultExtensions = combineNub defaultExtensions,
+ otherExtensions = combineNub otherExtensions,
+ oldExtensions = combineNub oldExtensions,
+ extraLibs = combine extraLibs,
+ extraLibDirs = combineNub extraLibDirs,
+ includeDirs = combineNub includeDirs,
+ includes = combineNub includes,
+ installIncludes = combineNub installIncludes,
+ options = combine options,
+ ghcProfOptions = combine ghcProfOptions,
+ ghcSharedOptions = combine ghcSharedOptions,
+ customFieldsBI = combine customFieldsBI,
+ targetBuildDepends = combineNub targetBuildDepends
+ }
+ where
+ combine field = field a `mappend` field b
+ combineNub field = nub (combine field)
+ combineMby field = field b `mplus` field a
+
+emptyBuildInfo :: BuildInfo
+emptyBuildInfo = mempty
+
+-- | The 'BuildInfo' for the library (if there is one and it's buildable), and
+-- all buildable executables and test suites. Useful for gathering dependencies.
+allBuildInfo :: PackageDescription -> [BuildInfo]
+allBuildInfo pkg_descr = [ bi | Just lib <- [library pkg_descr]
+ , let bi = libBuildInfo lib
+ , buildable bi ]
+ ++ [ bi | exe <- executables pkg_descr
+ , let bi = buildInfo exe
+ , buildable bi ]
+ ++ [ bi | tst <- testSuites pkg_descr
+ , let bi = testBuildInfo tst
+ , buildable bi
+ , testEnabled tst ]
+ --FIXME: many of the places where this is used, we actually want to look at
+ -- unbuildable bits too, probably need separate functions
+
+-- | The 'Language's used by this component
+--
+allLanguages :: BuildInfo -> [Language]
+allLanguages bi = maybeToList (defaultLanguage bi)
+ ++ otherLanguages bi
+
+-- | The 'Extension's that are used somewhere by this component
+--
+allExtensions :: BuildInfo -> [Extension]
+allExtensions bi = usedExtensions bi
+ ++ otherExtensions bi
+
+-- | The 'Extensions' that are used by all modules in this component
+--
+usedExtensions :: BuildInfo -> [Extension]
+usedExtensions bi = oldExtensions bi
+ ++ defaultExtensions bi
+
+type HookedBuildInfo = (Maybe BuildInfo, [(String, BuildInfo)])
+
+emptyHookedBuildInfo :: HookedBuildInfo
+emptyHookedBuildInfo = (Nothing, [])
+
+-- |Select options for a particular Haskell compiler.
+hcOptions :: CompilerFlavor -> BuildInfo -> [String]
+hcOptions hc bi = [ opt | (hc',opts) <- options bi
+ , hc' == hc
+ , opt <- opts ]
+
+-- ------------------------------------------------------------
+-- * Source repos
+-- ------------------------------------------------------------
+
+-- | Information about the source revision control system for a package.
+--
+-- When specifying a repo it is useful to know the meaning or intention of the
+-- information as doing so enables automation. There are two obvious common
+-- purposes: one is to find the repo for the latest development version, the
+-- other is to find the repo for this specific release. The 'ReopKind'
+-- specifies which one we mean (or another custom one).
+--
+-- A package can specify one or the other kind or both. Most will specify just
+-- a head repo but some may want to specify a repo to reconstruct the sources
+-- for this package release.
+--
+-- The required information is the 'RepoType' which tells us if it's using
+-- 'Darcs', 'Git' for example. The 'repoLocation' and other details are
+-- interpreted according to the repo type.
+--
+data SourceRepo = SourceRepo {
+ -- | The kind of repo. This field is required.
+ repoKind :: RepoKind,
+
+ -- | The type of the source repository system for this repo, eg 'Darcs' or
+ -- 'Git'. This field is required.
+ repoType :: Maybe RepoType,
+
+ -- | The location of the repository. For most 'RepoType's this is a URL.
+ -- This field is required.
+ repoLocation :: Maybe String,
+
+ -- | 'CVS' can put multiple \"modules\" on one server and requires a
+ -- module name in addition to the location to identify a particular repo.
+ -- Logically this is part of the location but unfortunately has to be
+ -- specified separately. This field is required for the 'CVS' 'RepoType' and
+ -- should not be given otherwise.
+ repoModule :: Maybe String,
+
+ -- | The name or identifier of the branch, if any. Many source control
+ -- systems have the notion of multiple branches in a repo that exist in the
+ -- same location. For example 'Git' and 'CVS' use this while systems like
+ -- 'Darcs' use different locations for different branches. This field is
+ -- optional but should be used if necessary to identify the sources,
+ -- especially for the 'RepoThis' repo kind.
+ repoBranch :: Maybe String,
+
+ -- | The tag identify a particular state of the repository. This should be
+ -- given for the 'RepoThis' repo kind and not for 'RepoHead' kind.
+ --
+ repoTag :: Maybe String,
+
+ -- | Some repositories contain multiple projects in different subdirectories
+ -- This field specifies the subdirectory where this packages sources can be
+ -- found, eg the subdirectory containing the @.cabal@ file. It is interpreted
+ -- relative to the root of the repository. This field is optional. If not
+ -- given the default is \".\" ie no subdirectory.
+ repoSubdir :: Maybe FilePath
+}
+ deriving (Eq, Read, Show)
+
+-- | What this repo info is for, what it represents.
+--
+data RepoKind =
+ -- | The repository for the \"head\" or development version of the project.
+ -- This repo is where we should track the latest development activity or
+ -- the usual repo people should get to contribute patches.
+ RepoHead
+
+ -- | The repository containing the sources for this exact package version
+ -- or release. For this kind of repo a tag should be given to give enough
+ -- information to re-create the exact sources.
+ | RepoThis
+
+ | RepoKindUnknown String
+ deriving (Eq, Ord, Read, Show)
+
+-- | An enumeration of common source control systems. The fields used in the
+-- 'SourceRepo' depend on the type of repo. The tools and methods used to
+-- obtain and track the repo depend on the repo type.
+--
+data RepoType = Darcs | Git | SVN | CVS
+ | Mercurial | GnuArch | Bazaar | Monotone
+ | OtherRepoType String
+ deriving (Eq, Ord, Read, Show)
+
+knownRepoTypes :: [RepoType]
+knownRepoTypes = [Darcs, Git, SVN, CVS
+ ,Mercurial, GnuArch, Bazaar, Monotone]
+
+repoTypeAliases :: RepoType -> [String]
+repoTypeAliases Bazaar = ["bzr"]
+repoTypeAliases Mercurial = ["hg"]
+repoTypeAliases GnuArch = ["arch"]
+repoTypeAliases _ = []
+
+instance Text RepoKind where
+ disp RepoHead = Disp.text "head"
+ disp RepoThis = Disp.text "this"
+ disp (RepoKindUnknown other) = Disp.text other
+
+ parse = do
+ name <- ident
+ return $ case lowercase name of
+ "head" -> RepoHead
+ "this" -> RepoThis
+ _ -> RepoKindUnknown name
+
+instance Text RepoType where
+ disp (OtherRepoType other) = Disp.text other
+ disp other = Disp.text (lowercase (show other))
+ parse = fmap classifyRepoType ident
+
+classifyRepoType :: String -> RepoType
+classifyRepoType s =
+ case lookup (lowercase s) repoTypeMap of
+ Just repoType' -> repoType'
+ Nothing -> OtherRepoType s
+ where
+ repoTypeMap = [ (name, repoType')
+ | repoType' <- knownRepoTypes
+ , name <- display repoType' : repoTypeAliases repoType' ]
+
+ident :: Parse.ReadP r String
+ident = Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-')
+
+lowercase :: String -> String
+lowercase = map Char.toLower
+
+-- ------------------------------------------------------------
+-- * Utils
+-- ------------------------------------------------------------
+
+updatePackageDescription :: HookedBuildInfo -> PackageDescription -> PackageDescription
+updatePackageDescription (mb_lib_bi, exe_bi) p
+ = p{ executables = updateExecutables exe_bi (executables p)
+ , library = updateLibrary mb_lib_bi (library p)
+ }
+ where
+ updateLibrary :: Maybe BuildInfo -> Maybe Library -> Maybe Library
+ updateLibrary (Just bi) (Just lib) = Just (lib{libBuildInfo = bi `mappend` libBuildInfo lib})
+ updateLibrary Nothing mb_lib = mb_lib
+ updateLibrary (Just _) Nothing = Nothing
+
+ updateExecutables :: [(String, BuildInfo)] -- ^[(exeName, new buildinfo)]
+ -> [Executable] -- ^list of executables to update
+ -> [Executable] -- ^list with exeNames updated
+ updateExecutables exe_bi' executables' = foldr updateExecutable executables' exe_bi'
+
+ updateExecutable :: (String, BuildInfo) -- ^(exeName, new buildinfo)
+ -> [Executable] -- ^list of executables to update
+ -> [Executable] -- ^libst with exeName updated
+ updateExecutable _ [] = []
+ updateExecutable exe_bi'@(name,bi) (exe:exes)
+ | exeName exe == name = exe{buildInfo = bi `mappend` buildInfo exe} : exes
+ | otherwise = exe : updateExecutable exe_bi' exes
+
+-- ---------------------------------------------------------------------------
+-- The GenericPackageDescription type
+
+data GenericPackageDescription =
+ GenericPackageDescription {
+ packageDescription :: PackageDescription,
+ genPackageFlags :: [Flag],
+ condLibrary :: Maybe (CondTree ConfVar [Dependency] Library),
+ condExecutables :: [(String, CondTree ConfVar [Dependency] Executable)],
+ condTestSuites :: [(String, CondTree ConfVar [Dependency] TestSuite)]
+ }
+ deriving (Show, Eq)
+
+instance Package GenericPackageDescription where
+ packageId = packageId . packageDescription
+
+--TODO: make PackageDescription an instance of Text.
+
+-- | A flag can represent a feature to be included, or a way of linking
+-- a target against its dependencies, or in fact whatever you can think of.
+data Flag = MkFlag
+ { flagName :: FlagName
+ , flagDescription :: String
+ , flagDefault :: Bool
+ , flagManual :: Bool
+ }
+ deriving (Show, Eq)
+
+-- | A 'FlagName' is the name of a user-defined configuration flag
+newtype FlagName = FlagName String
+ deriving (Eq, Ord, Show, Read)
+
+-- | A 'FlagAssignment' is a total or partial mapping of 'FlagName's to
+-- 'Bool' flag values. It represents the flags chosen by the user or
+-- discovered during configuration. For example @--flags=foo --flags=-bar@
+-- becomes @[("foo", True), ("bar", False)]@
+--
+type FlagAssignment = [(FlagName, Bool)]
+
+-- | A @ConfVar@ represents the variable type used.
+data ConfVar = OS OS
+ | Arch Arch
+ | Flag FlagName
+ | Impl CompilerFlavor VersionRange
+ deriving (Eq, Show)
+
+--instance Text ConfVar where
+-- disp (OS os) = "os(" ++ display os ++ ")"
+-- disp (Arch arch) = "arch(" ++ display arch ++ ")"
+-- disp (Flag (ConfFlag f)) = "flag(" ++ f ++ ")"
+-- disp (Impl c v) = "impl(" ++ display c
+-- ++ " " ++ display v ++ ")"
+
+-- | A boolean expression parameterized over the variable type used.
+data Condition c = Var c
+ | Lit Bool
+ | CNot (Condition c)
+ | COr (Condition c) (Condition c)
+ | CAnd (Condition c) (Condition c)
+ deriving (Show, Eq)
+
+--instance Text c => Text (Condition c) where
+-- disp (Var x) = text (show x)
+-- disp (Lit b) = text (show b)
+-- disp (CNot c) = char '!' <> parens (ppCond c)
+-- disp (COr c1 c2) = parens $ sep [ppCond c1, text "||" <+> ppCond c2]
+-- disp (CAnd c1 c2) = parens $ sep [ppCond c1, text "&&" <+> ppCond c2]
+
+data CondTree v c a = CondNode
+ { condTreeData :: a
+ , condTreeConstraints :: c
+ , condTreeComponents :: [( Condition v
+ , CondTree v c a
+ , Maybe (CondTree v c a))]
+ }
+ deriving (Show, Eq)
+
+--instance (Text v, Text c) => Text (CondTree v c a) where
+-- disp (CondNode _dat cs ifs) =
+-- (text "build-depends: " <+>
+-- disp cs)
+-- $+$
+-- (vcat $ map ppIf ifs)
+-- where
+-- ppIf (c,thenTree,mElseTree) =
+-- ((text "if" <+> ppCond c <> colon) $$
+-- nest 2 (ppCondTree thenTree disp))
+-- $+$ (maybe empty (\t -> text "else: " $$ nest 2 (ppCondTree t disp))
+-- mElseTree)
diff --git a/cabal/cabal/Distribution/PackageDescription/Check.hs b/cabal/cabal/Distribution/PackageDescription/Check.hs
new file mode 100644
index 0000000..a24346f
--- /dev/null
+++ b/cabal/cabal/Distribution/PackageDescription/Check.hs
@@ -0,0 +1,1441 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.PackageDescription.Check
+-- Copyright : Lennart Kolmodin 2008
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Portability : portable
+--
+-- This has code for checking for various problems in packages. There is one
+-- set of checks that just looks at a 'PackageDescription' in isolation and
+-- another set of checks that also looks at files in the package. Some of the
+-- checks are basic sanity checks, others are portability standards that we'd
+-- like to encourage. There is a 'PackageCheck' type that distinguishes the
+-- different kinds of check so we can see which ones are appropriate to report
+-- in different situations. This code gets uses when configuring a package when
+-- we consider only basic problems. The higher standard is uses when when
+-- preparing a source tarball and by hackage when uploading new packages. The
+-- reason for this is that we want to hold packages that are expected to be
+-- distributed to a higher standard than packages that are only ever expected
+-- to be used on the author's own environment.
+
+{- All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Isaac Jones nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
+
+module Distribution.PackageDescription.Check (
+ -- * Package Checking
+ PackageCheck(..),
+ checkPackage,
+ checkConfiguredPackage,
+
+ -- ** Checking package contents
+ checkPackageFiles,
+ checkPackageContent,
+ CheckPackageContentOps(..),
+ checkPackageFileNames,
+ ) where
+
+import Data.Maybe
+ ( isNothing, isJust, catMaybes, maybeToList, fromMaybe )
+import Data.List (sort, group, isPrefixOf, nub, find)
+import Control.Monad
+ ( filterM, liftM )
+import qualified System.Directory as System
+ ( doesFileExist, doesDirectoryExist )
+
+import Distribution.Package ( pkgName )
+import Distribution.PackageDescription
+import Distribution.PackageDescription.Configuration
+ ( flattenPackageDescription, finalizePackageDescription )
+import Distribution.Compiler
+ ( CompilerFlavor(..), buildCompilerFlavor, CompilerId(..) )
+import Distribution.System
+ ( OS(..), Arch(..), buildPlatform )
+import Distribution.License
+ ( License(..), knownLicenses )
+import Distribution.Simple.Utils
+ ( cabalVersion, intercalate, parseFileGlob, FileGlob(..), lowercase )
+
+import Distribution.Version
+ ( Version(..)
+ , VersionRange(..), foldVersionRange'
+ , anyVersion, noVersion, thisVersion, laterVersion, earlierVersion
+ , orLaterVersion, orEarlierVersion
+ , unionVersionRanges, intersectVersionRanges
+ , asVersionIntervals, UpperBound(..), isNoVersion )
+import Distribution.Package
+ ( PackageName(PackageName), packageName, packageVersion
+ , Dependency(..) )
+
+import Distribution.Text
+ ( display, disp )
+import qualified Text.PrettyPrint as Disp
+import Text.PrettyPrint ((<>), (<+>))
+
+import qualified Language.Haskell.Extension as Extension (deprecatedExtensions)
+import Language.Haskell.Extension
+ ( Language(UnknownLanguage), knownLanguages, Extension(..), KnownExtension(..) )
+import System.FilePath
+ ( (</>), takeExtension, isRelative, isAbsolute
+ , splitDirectories, splitPath )
+import System.FilePath.Windows as FilePath.Windows
+ ( isValid )
+
+-- | Results of some kind of failed package check.
+--
+-- There are a range of severities, from merely dubious to totally insane.
+-- All of them come with a human readable explanation. In future we may augment
+-- them with more machine readable explanations, for example to help an IDE
+-- suggest automatic corrections.
+--
+data PackageCheck =
+
+ -- | This package description is no good. There's no way it's going to
+ -- build sensibly. This should give an error at configure time.
+ PackageBuildImpossible { explanation :: String }
+
+ -- | A problem that is likely to affect building the package, or an
+ -- issue that we'd like every package author to be aware of, even if
+ -- the package is never distributed.
+ | PackageBuildWarning { explanation :: String }
+
+ -- | An issue that might not be a problem for the package author but
+ -- might be annoying or determental when the package is distributed to
+ -- users. We should encourage distributed packages to be free from these
+ -- issues, but occasionally there are justifiable reasons so we cannot
+ -- ban them entirely.
+ | PackageDistSuspicious { explanation :: String }
+
+ -- | An issue that is ok in the author's environment but is almost
+ -- certain to be a portability problem for other environments. We can
+ -- quite legitimately refuse to publicly distribute packages with these
+ -- problems.
+ | PackageDistInexcusable { explanation :: String }
+
+instance Show PackageCheck where
+ show notice = explanation notice
+
+check :: Bool -> PackageCheck -> Maybe PackageCheck
+check False _ = Nothing
+check True pc = Just pc
+
+-- ------------------------------------------------------------
+-- * Standard checks
+-- ------------------------------------------------------------
+
+-- | Check for common mistakes and problems in package descriptions.
+--
+-- This is the standard collection of checks covering all apsects except
+-- for checks that require looking at files within the package. For those
+-- see 'checkPackageFiles'.
+--
+-- It requires the 'GenericPackageDescription' and optionally a particular
+-- configuration of that package. If you pass 'Nothing' then we just check
+-- a version of the generic description using 'flattenPackageDescription'.
+--
+checkPackage :: GenericPackageDescription
+ -> Maybe PackageDescription
+ -> [PackageCheck]
+checkPackage gpkg mpkg =
+ checkConfiguredPackage pkg
+ ++ checkConditionals gpkg
+ ++ checkPackageVersions gpkg
+ where
+ pkg = fromMaybe (flattenPackageDescription gpkg) mpkg
+
+--TODO: make this variant go away
+-- we should alwaws know the GenericPackageDescription
+checkConfiguredPackage :: PackageDescription -> [PackageCheck]
+checkConfiguredPackage pkg =
+ checkSanity pkg
+ ++ checkFields pkg
+ ++ checkLicense pkg
+ ++ checkSourceRepos pkg
+ ++ checkGhcOptions pkg
+ ++ checkCCOptions pkg
+ ++ checkPaths pkg
+ ++ checkCabalVersion pkg
+
+
+-- ------------------------------------------------------------
+-- * Basic sanity checks
+-- ------------------------------------------------------------
+
+-- | Check that this package description is sane.
+--
+checkSanity :: PackageDescription -> [PackageCheck]
+checkSanity pkg =
+ catMaybes [
+
+ check (null . (\(PackageName n) -> n) . packageName $ pkg) $
+ PackageBuildImpossible "No 'name' field."
+
+ , check (null . versionBranch . packageVersion $ pkg) $
+ PackageBuildImpossible "No 'version' field."
+
+ , check (null (executables pkg) && isNothing (library pkg)) $
+ PackageBuildImpossible
+ "No executables and no library found. Nothing to do."
+
+ , check (not (null exeDuplicates)) $
+ PackageBuildImpossible $ "Duplicate executable sections "
+ ++ commaSep exeDuplicates
+ , check (not (null testDuplicates)) $
+ PackageBuildImpossible $ "Duplicate test sections "
+ ++ commaSep testDuplicates
+
+ --TODO: this seems to duplicate a check on the testsuites
+ , check (not (null testsThatAreExes)) $
+ PackageBuildImpossible $ "These test sections share names with executable sections: "
+ ++ commaSep testsThatAreExes
+ ]
+ --TODO: check for name clashes case insensitively: windows file systems cannot cope.
+
+ ++ maybe [] checkLibrary (library pkg)
+ ++ concatMap checkExecutable (executables pkg)
+ ++ concatMap (checkTestSuite pkg) (testSuites pkg)
+
+ ++ catMaybes [
+
+ check (specVersion pkg > cabalVersion) $
+ PackageBuildImpossible $
+ "This package description follows version "
+ ++ display (specVersion pkg) ++ " of the Cabal specification. This "
+ ++ "tool only supports up to version " ++ display cabalVersion ++ "."
+ ]
+ where
+ exeNames = map exeName $ executables pkg
+ testNames = map testName $ testSuites pkg
+ exeDuplicates = dups exeNames
+ testDuplicates = dups testNames
+ testsThatAreExes = filter (flip elem exeNames) testNames
+
+checkLibrary :: Library -> [PackageCheck]
+checkLibrary lib =
+ catMaybes [
+
+ check (not (null moduleDuplicates)) $
+ PackageBuildWarning $
+ "Duplicate modules in library: "
+ ++ commaSep (map display moduleDuplicates)
+ ]
+
+ where
+ moduleDuplicates = dups (libModules lib)
+
+checkExecutable :: Executable -> [PackageCheck]
+checkExecutable exe =
+ catMaybes [
+
+ check (null (modulePath exe)) $
+ PackageBuildImpossible $
+ "No 'Main-Is' field found for executable " ++ exeName exe
+
+ , check (not (null (modulePath exe))
+ && takeExtension (modulePath exe) `notElem` [".hs", ".lhs"]) $
+ PackageBuildImpossible $
+ "The 'Main-Is' field must specify a '.hs' or '.lhs' file "
+ ++ "(even if it is generated by a preprocessor)."
+
+ , check (not (null moduleDuplicates)) $
+ PackageBuildWarning $
+ "Duplicate modules in executable '" ++ exeName exe ++ "': "
+ ++ commaSep (map display moduleDuplicates)
+ ]
+ where
+ moduleDuplicates = dups (exeModules exe)
+
+checkTestSuite :: PackageDescription -> TestSuite -> [PackageCheck]
+checkTestSuite pkg test =
+ catMaybes [
+
+ case testInterface test of
+ TestSuiteUnsupported tt@(TestTypeUnknown _ _) -> Just $
+ PackageBuildWarning $
+ quote (display tt) ++ " is not a known type of test suite. "
+ ++ "The known test suite types are: "
+ ++ commaSep (map display knownTestTypes)
+
+ TestSuiteUnsupported tt -> Just $
+ PackageBuildWarning $
+ quote (display tt) ++ " is not a supported test suite version. "
+ ++ "The known test suite types are: "
+ ++ commaSep (map display knownTestTypes)
+ _ -> Nothing
+
+ , check (not $ null moduleDuplicates) $
+ PackageBuildWarning $
+ "Duplicate modules in test suite '" ++ testName test ++ "': "
+ ++ commaSep (map display moduleDuplicates)
+
+ , check mainIsWrongExt $
+ PackageBuildImpossible $
+ "The 'main-is' field must specify a '.hs' or '.lhs' file "
+ ++ "(even if it is generated by a preprocessor)."
+
+ , check exeNameClash $
+ PackageBuildImpossible $
+ "The test suite " ++ testName test
+ ++ " has the same name as an executable."
+
+ , check libNameClash $
+ PackageBuildImpossible $
+ "The test suite " ++ testName test
+ ++ " has the same name as the package."
+ ]
+ where
+ moduleDuplicates = dups $ testModules test
+
+ mainIsWrongExt = case testInterface test of
+ TestSuiteExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"]
+ _ -> False
+
+ exeNameClash = testName test `elem` [ exeName exe | exe <- executables pkg ]
+ libNameClash = testName test `elem` [ libName
+ | _lib <- maybeToList (library pkg)
+ , let PackageName libName =
+ pkgName (package pkg) ]
+
+-- ------------------------------------------------------------
+-- * Additional pure checks
+-- ------------------------------------------------------------
+
+checkFields :: PackageDescription -> [PackageCheck]
+checkFields pkg =
+ catMaybes [
+
+ check (not . FilePath.Windows.isValid . display . packageName $ pkg) $
+ PackageDistInexcusable $
+ "Unfortunately, the package name '" ++ display (packageName pkg)
+ ++ "' is one of the reserved system file names on Windows. Many tools "
+ ++ "need to convert package names to file names so using this name "
+ ++ "would cause problems."
+
+ , check (isNothing (buildType pkg)) $
+ PackageBuildWarning $
+ "No 'build-type' specified. If you do not need a custom Setup.hs or "
+ ++ "./configure script then use 'build-type: Simple'."
+
+ , case buildType pkg of
+ Just (UnknownBuildType unknown) -> Just $
+ PackageBuildWarning $
+ quote unknown ++ " is not a known 'build-type'. "
+ ++ "The known build types are: "
+ ++ commaSep (map display knownBuildTypes)
+ _ -> Nothing
+
+ , check (not (null unknownCompilers)) $
+ PackageBuildWarning $
+ "Unknown compiler " ++ commaSep (map quote unknownCompilers)
+ ++ " in 'tested-with' field."
+
+ , check (not (null unknownLanguages)) $
+ PackageBuildWarning $
+ "Unknown languages: " ++ commaSep unknownLanguages
+
+ , check (not (null unknownExtensions)) $
+ PackageBuildWarning $
+ "Unknown extensions: " ++ commaSep unknownExtensions
+
+ , check (not (null languagesUsedAsExtensions)) $
+ PackageBuildWarning $
+ "Languages listed as extensions: "
+ ++ commaSep languagesUsedAsExtensions
+ ++ ". Languages must be specified in either the 'default-language' "
+ ++ " or the 'other-languages' field."
+
+ , check (not (null deprecatedExtensions)) $
+ PackageDistSuspicious $
+ "Deprecated extensions: "
+ ++ commaSep (map (quote . display . fst) deprecatedExtensions)
+ ++ ". " ++ intercalate " "
+ [ "Instead of '" ++ display ext
+ ++ "' use '" ++ display replacement ++ "'."
+ | (ext, Just replacement) <- deprecatedExtensions ]
+
+ , check (null (category pkg)) $
+ PackageDistSuspicious "No 'category' field."
+
+ , check (null (maintainer pkg)) $
+ PackageDistSuspicious "No 'maintainer' field."
+
+ , check (null (synopsis pkg) && null (description pkg)) $
+ PackageDistInexcusable $ "No 'synopsis' or 'description' field."
+
+ , check (null (description pkg) && not (null (synopsis pkg))) $
+ PackageDistSuspicious "No 'description' field."
+
+ , check (null (synopsis pkg) && not (null (description pkg))) $
+ PackageDistSuspicious "No 'synopsis' field."
+
+ --TODO: recommend the bug reports url, author and homepage fields
+ --TODO: recommend not using the stability field
+ --TODO: recommend specifying a source repo
+
+ , check (length (synopsis pkg) >= 80) $
+ PackageDistSuspicious
+ "The 'synopsis' field is rather long (max 80 chars is recommended)."
+
+ -- check use of impossible constraints "tested-with: GHC== 6.10 && ==6.12"
+ , check (not (null testedWithImpossibleRanges)) $
+ PackageDistInexcusable $
+ "Invalid 'tested-with' version range: "
+ ++ commaSep (map display testedWithImpossibleRanges)
+ ++ ". To indicate that you have tested a package with multiple "
+ ++ "different versions of the same compiler use multiple entries, "
+ ++ "for example 'tested-with: GHC==6.10.4, GHC==6.12.3' and not "
+ ++ "'tested-with: GHC==6.10.4 && ==6.12.3'."
+ ]
+ where
+ unknownCompilers = [ name | (OtherCompiler name, _) <- testedWith pkg ]
+ unknownLanguages = [ name | bi <- allBuildInfo pkg
+ , UnknownLanguage name <- allLanguages bi ]
+ unknownExtensions = [ name | bi <- allBuildInfo pkg
+ , UnknownExtension name <- allExtensions bi
+ , name `notElem` map display knownLanguages ]
+ deprecatedExtensions = nub $ catMaybes
+ [ find ((==ext) . fst) Extension.deprecatedExtensions
+ | bi <- allBuildInfo pkg
+ , ext <- allExtensions bi ]
+ languagesUsedAsExtensions =
+ [ name | bi <- allBuildInfo pkg
+ , UnknownExtension name <- allExtensions bi
+ , name `elem` map display knownLanguages ]
+
+ testedWithImpossibleRanges =
+ [ Dependency (PackageName (display compiler)) vr
+ | (compiler, vr) <- testedWith pkg
+ , isNoVersion vr ]
+
+
+checkLicense :: PackageDescription -> [PackageCheck]
+checkLicense pkg =
+ catMaybes [
+
+ check (license pkg == AllRightsReserved) $
+ PackageDistInexcusable
+ "The 'license' field is missing or specified as AllRightsReserved."
+
+ , case license pkg of
+ UnknownLicense l -> Just $
+ PackageBuildWarning $
+ quote ("license: " ++ l) ++ " is not a recognised license. The "
+ ++ "known licenses are: "
+ ++ commaSep (map display knownLicenses)
+ _ -> Nothing
+
+ , check (license pkg == BSD4) $
+ PackageDistSuspicious $
+ "Using 'license: BSD4' is almost always a misunderstanding. 'BSD4' "
+ ++ "refers to the old 4-clause BSD license with the advertising "
+ ++ "clause. 'BSD3' refers the new 3-clause BSD license."
+
+ , case unknownLicenseVersion (license pkg) of
+ Just knownVersions -> Just $
+ PackageDistSuspicious $
+ "'license: " ++ display (license pkg) ++ "' is not a known "
+ ++ "version of that license. The known versions are "
+ ++ commaSep (map display knownVersions)
+ ++ ". If this is not a mistake and you think it should be a known "
+ ++ "version then please file a ticket."
+ _ -> Nothing
+
+ , check (license pkg `notElem` [AllRightsReserved, PublicDomain]
+ -- AllRightsReserved and PublicDomain are not strictly
+ -- licenses so don't need license files.
+ && null (licenseFile pkg)) $
+ PackageDistSuspicious "A 'license-file' is not specified."
+ ]
+ where
+ unknownLicenseVersion (GPL (Just v))
+ | v `notElem` knownVersions = Just knownVersions
+ where knownVersions = [ v' | GPL (Just v') <- knownLicenses ]
+ unknownLicenseVersion (LGPL (Just v))
+ | v `notElem` knownVersions = Just knownVersions
+ where knownVersions = [ v' | LGPL (Just v') <- knownLicenses ]
+ unknownLicenseVersion _ = Nothing
+
+checkSourceRepos :: PackageDescription -> [PackageCheck]
+checkSourceRepos pkg =
+ catMaybes $ concat [[
+
+ case repoKind repo of
+ RepoKindUnknown kind -> Just $ PackageDistInexcusable $
+ quote kind ++ " is not a recognised kind of source-repository. "
+ ++ "The repo kind is usually 'head' or 'this'"
+ _ -> Nothing
+
+ , check (repoType repo == Nothing) $
+ PackageDistInexcusable
+ "The source-repository 'type' is a required field."
+
+ , check (repoLocation repo == Nothing) $
+ PackageDistInexcusable
+ "The source-repository 'location' is a required field."
+
+ , check (repoType repo == Just CVS && repoModule repo == Nothing) $
+ PackageDistInexcusable
+ "For a CVS source-repository, the 'module' is a required field."
+
+ , check (repoKind repo == RepoThis && repoTag repo == Nothing) $
+ PackageDistInexcusable $
+ "For the 'this' kind of source-repository, the 'tag' is a required "
+ ++ "field. It should specify the tag corresponding to this version "
+ ++ "or release of the package."
+
+ , check (maybe False System.FilePath.isAbsolute (repoSubdir repo)) $
+ PackageDistInexcusable
+ "The 'subdir' field of a source-repository must be a relative path."
+ ]
+ | repo <- sourceRepos pkg ]
+
+--TODO: check location looks like a URL for some repo types.
+
+checkGhcOptions :: PackageDescription -> [PackageCheck]
+checkGhcOptions pkg =
+ catMaybes [
+
+ check has_WerrorWall $
+ PackageDistInexcusable $
+ "'ghc-options: -Wall -Werror' makes the package very easy to "
+ ++ "break with future GHC versions because new GHC versions often "
+ ++ "add new warnings. Use just 'ghc-options: -Wall' instead."
+
+ , check (not has_WerrorWall && has_Werror) $
+ PackageDistSuspicious $
+ "'ghc-options: -Werror' makes the package easy to "
+ ++ "break with future GHC versions because new GHC versions often "
+ ++ "add new warnings."
+
+ , checkFlags ["-fasm"] $
+ PackageDistInexcusable $
+ "'ghc-options: -fasm' is unnecessary and will not work on CPU "
+ ++ "architectures other than x86, x86-64, ppc or sparc."
+
+ , checkFlags ["-fvia-C"] $
+ PackageDistSuspicious $
+ "'ghc-options: -fvia-C' is usually unnecessary. If your package "
+ ++ "needs -via-C for correctness rather than performance then it "
+ ++ "is using the FFI incorrectly and will probably not work with GHC "
+ ++ "6.10 or later."
+
+ , checkFlags ["-fhpc"] $
+ PackageDistInexcusable $
+ "'ghc-options: -fhpc' is not appropriate for a distributed package."
+
+ , check (any ("-d" `isPrefixOf`) all_ghc_options) $
+ PackageDistInexcusable $
+ "'ghc-options: -d*' debug flags are not appropriate for a distributed package."
+
+ , checkFlags ["-prof"] $
+ PackageBuildWarning $
+ "'ghc-options: -prof' is not necessary and will lead to problems "
+ ++ "when used on a library. Use the configure flag "
+ ++ "--enable-library-profiling and/or --enable-executable-profiling."
+
+ , checkFlags ["-o"] $
+ PackageBuildWarning $
+ "'ghc-options: -o' is not needed. The output files are named automatically."
+
+ , checkFlags ["-hide-package"] $
+ PackageBuildWarning $
+ "'ghc-options: -hide-package' is never needed. Cabal hides all packages."
+
+ , checkFlags ["--make"] $
+ PackageBuildWarning $
+ "'ghc-options: --make' is never needed. Cabal uses this automatically."
+
+ , checkFlags ["-main-is"] $
+ PackageDistSuspicious $
+ "'ghc-options: -main-is' is not portable."
+
+ , checkFlags ["-O0", "-Onot"] $
+ PackageDistSuspicious $
+ "'ghc-options: -O0' is not needed. Use the --disable-optimization configure flag."
+
+ , checkFlags [ "-O", "-O1"] $
+ PackageDistInexcusable $
+ "'ghc-options: -O' is not needed. Cabal automatically adds the '-O' flag. "
+ ++ "Setting it yourself interferes with the --disable-optimization flag."
+
+ , checkFlags ["-O2"] $
+ PackageDistSuspicious $
+ "'ghc-options: -O2' is rarely needed. Check that it is giving a real benefit "
+ ++ "and not just imposing longer compile times on your users."
+
+ , checkFlags ["-split-objs"] $
+ PackageBuildWarning $
+ "'ghc-options: -split-objs' is not needed. Use the --enable-split-objs configure flag."
+
+ , checkFlags ["-optl-Wl,-s", "-optl-s"] $
+ PackageDistInexcusable $
+ "'ghc-options: -optl-Wl,-s' is not needed and is not portable to all"
+ ++ " operating systems. Cabal 1.4 and later automatically strip"
+ ++ " executables. Cabal also has a flag --disable-executable-stripping"
+ ++ " which is necessary when building packages for some Linux"
+ ++ " distributions and using '-optl-Wl,-s' prevents that from working."
+
+ , checkFlags ["-fglasgow-exts"] $
+ PackageDistSuspicious $
+ "Instead of 'ghc-options: -fglasgow-exts' it is preferable to use the 'extensions' field."
+
+ , check ("-threaded" `elem` lib_ghc_options) $
+ PackageDistSuspicious $
+ "'ghc-options: -threaded' has no effect for libraries. It should "
+ ++ "only be used for executables."
+
+ , checkAlternatives "ghc-options" "extensions"
+ [ (flag, display extension) | flag <- all_ghc_options
+ , Just extension <- [ghcExtension flag] ]
+
+ , checkAlternatives "ghc-options" "extensions"
+ [ (flag, extension) | flag@('-':'X':extension) <- all_ghc_options ]
+
+ , checkAlternatives "ghc-options" "cpp-options" $
+ [ (flag, flag) | flag@('-':'D':_) <- all_ghc_options ]
+ ++ [ (flag, flag) | flag@('-':'U':_) <- all_ghc_options ]
+
+ , checkAlternatives "ghc-options" "include-dirs"
+ [ (flag, dir) | flag@('-':'I':dir) <- all_ghc_options ]
+
+ , checkAlternatives "ghc-options" "extra-libraries"
+ [ (flag, lib) | flag@('-':'l':lib) <- all_ghc_options ]
+
+ , checkAlternatives "ghc-options" "extra-lib-dirs"
+ [ (flag, dir) | flag@('-':'L':dir) <- all_ghc_options ]
+ ]
+
+ where
+ has_WerrorWall = flip any ghc_options $ \opts ->
+ "-Werror" `elem` opts
+ && ("-Wall" `elem` opts || "-W" `elem` opts)
+ has_Werror = any (\opts -> "-Werror" `elem` opts) ghc_options
+
+ ghc_options = [ strs | bi <- allBuildInfo pkg
+ , (GHC, strs) <- options bi ]
+ all_ghc_options = concat ghc_options
+ lib_ghc_options = maybe [] (hcOptions GHC . libBuildInfo) (library pkg)
+
+ checkFlags :: [String] -> PackageCheck -> Maybe PackageCheck
+ checkFlags flags = check (any (`elem` flags) all_ghc_options)
+
+ ghcExtension ('-':'f':name) = case name of
+ "allow-overlapping-instances" -> Just (EnableExtension OverlappingInstances)
+ "no-allow-overlapping-instances" -> Just (DisableExtension OverlappingInstances)
+ "th" -> Just (EnableExtension TemplateHaskell)
+ "no-th" -> Just (DisableExtension TemplateHaskell)
+ "ffi" -> Just (EnableExtension ForeignFunctionInterface)
+ "no-ffi" -> Just (DisableExtension ForeignFunctionInterface)
+ "fi" -> Just (EnableExtension ForeignFunctionInterface)
+ "no-fi" -> Just (DisableExtension ForeignFunctionInterface)
+ "monomorphism-restriction" -> Just (EnableExtension MonomorphismRestriction)
+ "no-monomorphism-restriction" -> Just (DisableExtension MonomorphismRestriction)
+ "mono-pat-binds" -> Just (EnableExtension MonoPatBinds)
+ "no-mono-pat-binds" -> Just (DisableExtension MonoPatBinds)
+ "allow-undecidable-instances" -> Just (EnableExtension UndecidableInstances)
+ "no-allow-undecidable-instances" -> Just (DisableExtension UndecidableInstances)
+ "allow-incoherent-instances" -> Just (EnableExtension IncoherentInstances)
+ "no-allow-incoherent-instances" -> Just (DisableExtension IncoherentInstances)
+ "arrows" -> Just (EnableExtension Arrows)
+ "no-arrows" -> Just (DisableExtension Arrows)
+ "generics" -> Just (EnableExtension Generics)
+ "no-generics" -> Just (DisableExtension Generics)
+ "implicit-prelude" -> Just (EnableExtension ImplicitPrelude)
+ "no-implicit-prelude" -> Just (DisableExtension ImplicitPrelude)
+ "implicit-params" -> Just (EnableExtension ImplicitParams)
+ "no-implicit-params" -> Just (DisableExtension ImplicitParams)
+ "bang-patterns" -> Just (EnableExtension BangPatterns)
+ "no-bang-patterns" -> Just (DisableExtension BangPatterns)
+ "scoped-type-variables" -> Just (EnableExtension ScopedTypeVariables)
+ "no-scoped-type-variables" -> Just (DisableExtension ScopedTypeVariables)
+ "extended-default-rules" -> Just (EnableExtension ExtendedDefaultRules)
+ "no-extended-default-rules" -> Just (DisableExtension ExtendedDefaultRules)
+ _ -> Nothing
+ ghcExtension "-cpp" = Just (EnableExtension CPP)
+ ghcExtension _ = Nothing
+
+checkCCOptions :: PackageDescription -> [PackageCheck]
+checkCCOptions pkg =
+ catMaybes [
+
+ checkAlternatives "cc-options" "include-dirs"
+ [ (flag, dir) | flag@('-':'I':dir) <- all_ccOptions ]
+
+ , checkAlternatives "cc-options" "extra-libraries"
+ [ (flag, lib) | flag@('-':'l':lib) <- all_ccOptions ]
+
+ , checkAlternatives "cc-options" "extra-lib-dirs"
+ [ (flag, dir) | flag@('-':'L':dir) <- all_ccOptions ]
+
+ , checkAlternatives "ld-options" "extra-libraries"
+ [ (flag, lib) | flag@('-':'l':lib) <- all_ldOptions ]
+
+ , checkAlternatives "ld-options" "extra-lib-dirs"
+ [ (flag, dir) | flag@('-':'L':dir) <- all_ldOptions ]
+
+ , checkCCFlags [ "-O", "-Os", "-O0", "-O1", "-O2", "-O3" ] $
+ PackageDistSuspicious $
+ "'cc-options: -O[n]' is generally not needed. When building with "
+ ++ " optimisations Cabal automatically adds '-O2' for C code. "
+ ++ "Setting it yourself interferes with the --disable-optimization "
+ ++ "flag."
+ ]
+
+ where all_ccOptions = [ opts | bi <- allBuildInfo pkg
+ , opts <- ccOptions bi ]
+ all_ldOptions = [ opts | bi <- allBuildInfo pkg
+ , opts <- ldOptions bi ]
+
+ checkCCFlags :: [String] -> PackageCheck -> Maybe PackageCheck
+ checkCCFlags flags = check (any (`elem` flags) all_ccOptions)
+
+checkAlternatives :: String -> String -> [(String, String)] -> Maybe PackageCheck
+checkAlternatives badField goodField flags =
+ check (not (null badFlags)) $
+ PackageBuildWarning $
+ "Instead of " ++ quote (badField ++ ": " ++ unwords badFlags)
+ ++ " use " ++ quote (goodField ++ ": " ++ unwords goodFlags)
+
+ where (badFlags, goodFlags) = unzip flags
+
+checkPaths :: PackageDescription -> [PackageCheck]
+checkPaths pkg =
+ [ PackageBuildWarning $
+ quote (kind ++ ": " ++ path)
+ ++ " is a relative path outside of the source tree. "
+ ++ "This will not work when generating a tarball with 'sdist'."
+ | (path, kind) <- relPaths ++ absPaths
+ , isOutsideTree path ]
+ ++
+ [ PackageDistInexcusable $
+ quote (kind ++ ": " ++ path) ++ " is an absolute directory."
+ | (path, kind) <- relPaths
+ , isAbsolute path ]
+ ++
+ [ PackageDistInexcusable $
+ quote (kind ++ ": " ++ path) ++ " points inside the 'dist' "
+ ++ "directory. This is not reliable because the location of this "
+ ++ "directory is configurable by the user (or package manager). In "
+ ++ "addition the layout of the 'dist' directory is subject to change "
+ ++ "in future versions of Cabal."
+ | (path, kind) <- relPaths ++ absPaths
+ , isInsideDist path ]
+ ++
+ [ PackageDistInexcusable $
+ "The 'ghc-options' contains the path '" ++ path ++ "' which points "
+ ++ "inside the 'dist' directory. This is not reliable because the "
+ ++ "location of this directory is configurable by the user (or package "
+ ++ "manager). In addition the layout of the 'dist' directory is subject "
+ ++ "to change in future versions of Cabal."
+ | bi <- allBuildInfo pkg
+ , (GHC, flags) <- options bi
+ , path <- flags
+ , isInsideDist path ]
+ where
+ isOutsideTree path = case splitDirectories path of
+ "..":_ -> True
+ ".":"..":_ -> True
+ _ -> False
+ isInsideDist path = case map lowercase (splitDirectories path) of
+ "dist" :_ -> True
+ ".":"dist":_ -> True
+ _ -> False
+ -- paths that must be relative
+ relPaths =
+ [ (path, "extra-src-files") | path <- extraSrcFiles pkg ]
+ ++ [ (path, "extra-tmp-files") | path <- extraTmpFiles pkg ]
+ ++ [ (path, "data-files") | path <- dataFiles pkg ]
+ ++ [ (path, "data-dir") | path <- [dataDir pkg]]
+ ++ concat
+ [ [ (path, "c-sources") | path <- cSources bi ]
+ ++ [ (path, "install-includes") | path <- installIncludes bi ]
+ ++ [ (path, "hs-source-dirs") | path <- hsSourceDirs bi ]
+ | bi <- allBuildInfo pkg ]
+ -- paths that are allowed to be absolute
+ absPaths = concat
+ [ [ (path, "includes") | path <- includes bi ]
+ ++ [ (path, "include-dirs") | path <- includeDirs bi ]
+ ++ [ (path, "extra-lib-dirs") | path <- extraLibDirs bi ]
+ | bi <- allBuildInfo pkg ]
+
+--TODO: check sets of paths that would be interpreted differently between unix
+-- and windows, ie case-sensitive or insensitive. Things that might clash, or
+-- conversely be distinguished.
+
+--TODO: use the tar path checks on all the above paths
+
+-- | Check that the package declares the version in the @\"cabal-version\"@
+-- field correctly.
+--
+checkCabalVersion :: PackageDescription -> [PackageCheck]
+checkCabalVersion pkg =
+ catMaybes [
+
+ -- check syntax of cabal-version field
+ check (specVersion pkg >= Version [1,10] []
+ && not simpleSpecVersionRangeSyntax) $
+ PackageBuildWarning $
+ "Packages relying on Cabal 1.10 or later must only specify a "
+ ++ "version range of the form 'cabal-version: >= x.y'. Use "
+ ++ "'cabal-version: >= " ++ display (specVersion pkg) ++ "'."
+
+ -- check syntax of cabal-version field
+ , check (specVersion pkg < Version [1,9] []
+ && not simpleSpecVersionRangeSyntax) $
+ PackageDistSuspicious $
+ "It is recommended that the 'cabal-version' field only specify a "
+ ++ "version range of the form '>= x.y'. Use "
+ ++ "'cabal-version: >= " ++ display (specVersion pkg) ++ "'. "
+ ++ "Tools based on Cabal 1.10 and later will ignore upper bounds."
+
+ -- check syntax of cabal-version field
+ , checkVersion [1,12] simpleSpecVersionSyntax $
+ PackageBuildWarning $
+ "With Cabal 1.10 or earlier, the 'cabal-version' field must use "
+ ++ "range syntax rather than a simple version number. Use "
+ ++ "'cabal-version: >= " ++ display (specVersion pkg) ++ "'."
+
+ -- check use of test suite sections
+ , checkVersion [1,8] (not (null $ testSuites pkg)) $
+ PackageDistInexcusable $
+ "The 'test-suite' section is new in Cabal 1.10. "
+ ++ "Unfortunately it messes up the parser in older Cabal versions "
+ ++ "so you must specify at least 'cabal-version: >= 1.8', but note"
+ ++ "that only Cabal 1.10 and later can actually run such test suites."
+
+ -- check use of default-language field
+ -- note that we do not need to do an equivalent check for the
+ -- other-language field since that one does not change behaviour
+ , checkVersion [1,10] (any isJust (buildInfoField defaultLanguage)) $
+ PackageBuildWarning $
+ "To use the 'default-language' field the package needs to specify "
+ ++ "at least 'cabal-version: >= 1.10'."
+
+ , check (specVersion pkg >= Version [1,10] []
+ && (any isNothing (buildInfoField defaultLanguage))) $
+ PackageBuildWarning $
+ "Packages using 'cabal-version: >= 1.10' must specify the "
+ ++ "'default-language' field for each component (e.g. Haskell98 or "
+ ++ "Haskell2010). If a component uses different languages in "
+ ++ "different modules then list the other ones in the "
+ ++ "'other-languages' field."
+
+ -- check use of default-extensions field
+ -- don't need to do the equivalent check for other-extensions
+ , checkVersion [1,10] (any (not . null) (buildInfoField defaultExtensions)) $
+ PackageBuildWarning $
+ "To use the 'default-extensions' field the package needs to specify "
+ ++ "at least 'cabal-version: >= 1.10'."
+
+ -- check use of extensions field
+ , check (specVersion pkg >= Version [1,10] []
+ && (any (not . null) (buildInfoField oldExtensions))) $
+ PackageBuildWarning $
+ "For packages using 'cabal-version: >= 1.10' the 'extensions' "
+ ++ "field is deprecated. The new 'default-extensions' field lists "
+ ++ "extensions that are used in all modules in the component, while "
+ ++ "the 'other-extensions' field lists extensions that are used in "
+ ++ "some modules, e.g. via the {-# LANGUAGE #-} pragma."
+
+ -- check use of "foo (>= 1.0 && < 1.4) || >=1.8 " version-range syntax
+ , checkVersion [1,8] (not (null versionRangeExpressions)) $
+ PackageDistInexcusable $
+ "The package uses full version-range expressions "
+ ++ "in a 'build-depends' field: "
+ ++ commaSep (map displayRawDependency versionRangeExpressions)
+ ++ ". To use this new syntax the package needs to specify at least "
+ ++ "'cabal-version: >= 1.8'. Alternatively, if broader compatibility "
+ ++ "is important, then convert to conjunctive normal form, and use "
+ ++ "multiple 'build-depends:' lines, one conjunct per line."
+
+ -- check use of "build-depends: foo == 1.*" syntax
+ , checkVersion [1,6] (not (null depsUsingWildcardSyntax)) $
+ PackageDistInexcusable $
+ "The package uses wildcard syntax in the 'build-depends' field: "
+ ++ commaSep (map display depsUsingWildcardSyntax)
+ ++ ". To use this new syntax the package need to specify at least "
+ ++ "'cabal-version: >= 1.6'. Alternatively, if broader compatability "
+ ++ "is important then use: " ++ commaSep
+ [ display (Dependency name (eliminateWildcardSyntax versionRange))
+ | Dependency name versionRange <- depsUsingWildcardSyntax ]
+
+ -- check use of "tested-with: GHC (>= 1.0 && < 1.4) || >=1.8 " syntax
+ , checkVersion [1,8] (not (null testedWithVersionRangeExpressions)) $
+ PackageDistInexcusable $
+ "The package uses full version-range expressions "
+ ++ "in a 'tested-with' field: "
+ ++ commaSep (map displayRawDependency testedWithVersionRangeExpressions)
+ ++ ". To use this new syntax the package needs to specify at least "
+ ++ "'cabal-version: >= 1.8'."
+
+ -- check use of "tested-with: GHC == 6.12.*" syntax
+ , checkVersion [1,6] (not (null testedWithUsingWildcardSyntax)) $
+ PackageDistInexcusable $
+ "The package uses wildcard syntax in the 'tested-with' field: "
+ ++ commaSep (map display testedWithUsingWildcardSyntax)
+ ++ ". To use this new syntax the package need to specify at least "
+ ++ "'cabal-version: >= 1.6'. Alternatively, if broader compatability "
+ ++ "is important then use: " ++ commaSep
+ [ display (Dependency name (eliminateWildcardSyntax versionRange))
+ | Dependency name versionRange <- testedWithUsingWildcardSyntax ]
+
+ -- check use of "data-files: data/*.txt" syntax
+ , checkVersion [1,6] (not (null dataFilesUsingGlobSyntax)) $
+ PackageDistInexcusable $
+ "Using wildcards like "
+ ++ commaSep (map quote $ take 3 dataFilesUsingGlobSyntax)
+ ++ " in the 'data-files' field requires 'cabal-version: >= 1.6'. "
+ ++ "Alternatively if you require compatability with earlier Cabal "
+ ++ "versions then list all the files explicitly."
+
+ -- check use of "extra-source-files: mk/*.in" syntax
+ , checkVersion [1,6] (not (null extraSrcFilesUsingGlobSyntax)) $
+ PackageDistInexcusable $
+ "Using wildcards like "
+ ++ commaSep (map quote $ take 3 extraSrcFilesUsingGlobSyntax)
+ ++ " in the 'extra-source-files' field requires "
+ ++ "'cabal-version: >= 1.6'. Alternatively if you require "
+ ++ "compatability with earlier Cabal versions then list all the files "
+ ++ "explicitly."
+
+ -- check use of "source-repository" section
+ , checkVersion [1,6] (not (null (sourceRepos pkg))) $
+ PackageDistInexcusable $
+ "The 'source-repository' section is new in Cabal 1.6. "
+ ++ "Unfortunately it messes up the parser in earlier Cabal versions "
+ ++ "so you need to specify 'cabal-version: >= 1.6'."
+
+ -- check for new licenses
+ , checkVersion [1,4] (license pkg `notElem` compatLicenses) $
+ PackageDistInexcusable $
+ "Unfortunately the license " ++ quote (display (license pkg))
+ ++ " messes up the parser in earlier Cabal versions so you need to "
+ ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require "
+ ++ "compatability with earlier Cabal versions then use 'OtherLicense'."
+
+ -- check for new language extensions
+ , checkVersion [1,2,3] (not (null mentionedExtensionsThatNeedCabal12)) $
+ PackageDistInexcusable $
+ "Unfortunately the language extensions "
+ ++ commaSep (map (quote . display) mentionedExtensionsThatNeedCabal12)
+ ++ " break the parser in earlier Cabal versions so you need to "
+ ++ "specify 'cabal-version: >= 1.2.3'. Alternatively if you require "
+ ++ "compatability with earlier Cabal versions then you may be able to "
+ ++ "use an equivalent compiler-specific flag."
+
+ , checkVersion [1,4] (not (null mentionedExtensionsThatNeedCabal14)) $
+ PackageDistInexcusable $
+ "Unfortunately the language extensions "
+ ++ commaSep (map (quote . display) mentionedExtensionsThatNeedCabal14)
+ ++ " break the parser in earlier Cabal versions so you need to "
+ ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require "
+ ++ "compatability with earlier Cabal versions then you may be able to "
+ ++ "use an equivalent compiler-specific flag."
+ ]
+ where
+ -- Perform a check on packages that use a version of the spec less than
+ -- the version given. This is for cases where a new Cabal version adds
+ -- a new feature and we want to check that it is not used prior to that
+ -- version.
+ checkVersion :: [Int] -> Bool -> PackageCheck -> Maybe PackageCheck
+ checkVersion ver cond pc
+ | specVersion pkg >= Version ver [] = Nothing
+ | otherwise = check cond pc
+
+ buildInfoField field = map field (allBuildInfo pkg)
+ dataFilesUsingGlobSyntax = filter usesGlobSyntax (dataFiles pkg)
+ extraSrcFilesUsingGlobSyntax = filter usesGlobSyntax (extraSrcFiles pkg)
+ usesGlobSyntax str = case parseFileGlob str of
+ Just (FileGlob _ _) -> True
+ _ -> False
+
+ versionRangeExpressions =
+ [ dep | dep@(Dependency _ vr) <- buildDepends pkg
+ , usesNewVersionRangeSyntax vr ]
+
+ testedWithVersionRangeExpressions =
+ [ Dependency (PackageName (display compiler)) vr
+ | (compiler, vr) <- testedWith pkg
+ , usesNewVersionRangeSyntax vr ]
+
+ simpleSpecVersionRangeSyntax =
+ either (const True)
+ (foldVersionRange'
+ True
+ (\_ -> False)
+ (\_ -> False) (\_ -> False)
+ (\_ -> True) -- >=
+ (\_ -> False)
+ (\_ _ -> False)
+ (\_ _ -> False) (\_ _ -> False)
+ id)
+ (specVersionRaw pkg)
+
+ -- is the cabal-version field a simple version number, rather than a range
+ simpleSpecVersionSyntax =
+ either (const True) (const False) (specVersionRaw pkg)
+
+ usesNewVersionRangeSyntax :: VersionRange -> Bool
+ usesNewVersionRangeSyntax =
+ (> 2) -- uses the new syntax if depth is more than 2
+ . foldVersionRange'
+ (1 :: Int)
+ (const 1)
+ (const 1) (const 1)
+ (const 1) (const 1)
+ (const (const 1))
+ (+) (+)
+ (const 3) -- uses new ()'s syntax
+
+ depsUsingWildcardSyntax = [ dep | dep@(Dependency _ vr) <- buildDepends pkg
+ , usesWildcardSyntax vr ]
+
+ testedWithUsingWildcardSyntax = [ Dependency (PackageName (display compiler)) vr
+ | (compiler, vr) <- testedWith pkg
+ , usesWildcardSyntax vr ]
+
+ usesWildcardSyntax :: VersionRange -> Bool
+ usesWildcardSyntax =
+ foldVersionRange'
+ False (const False)
+ (const False) (const False)
+ (const False) (const False)
+ (\_ _ -> True) -- the wildcard case
+ (||) (||) id
+
+ eliminateWildcardSyntax =
+ foldVersionRange'
+ anyVersion thisVersion
+ laterVersion earlierVersion
+ orLaterVersion orEarlierVersion
+ (\v v' -> intersectVersionRanges (orLaterVersion v) (earlierVersion v'))
+ intersectVersionRanges unionVersionRanges id
+
+ compatLicenses = [ GPL Nothing, LGPL Nothing, BSD3, BSD4
+ , PublicDomain, AllRightsReserved, OtherLicense ]
+
+ mentionedExtensions = [ ext | bi <- allBuildInfo pkg
+ , ext <- allExtensions bi ]
+ mentionedExtensionsThatNeedCabal12 =
+ nub (filter (`elem` compatExtensionsExtra) mentionedExtensions)
+
+ -- As of Cabal-1.4 we can add new extensions without worrying about
+ -- breaking old versions of cabal.
+ mentionedExtensionsThatNeedCabal14 =
+ nub (filter (`notElem` compatExtensions) mentionedExtensions)
+
+ -- The known extensions in Cabal-1.2.3
+ compatExtensions =
+ map EnableExtension
+ [ OverlappingInstances, UndecidableInstances, IncoherentInstances
+ , RecursiveDo, ParallelListComp, MultiParamTypeClasses
+ , FunctionalDependencies, Rank2Types
+ , RankNTypes, PolymorphicComponents, ExistentialQuantification
+ , ScopedTypeVariables, ImplicitParams, FlexibleContexts
+ , FlexibleInstances, EmptyDataDecls, CPP, BangPatterns
+ , TypeSynonymInstances, TemplateHaskell, ForeignFunctionInterface
+ , Arrows, Generics, NamedFieldPuns, PatternGuards
+ , GeneralizedNewtypeDeriving, ExtensibleRecords, RestrictedTypeSynonyms
+ , HereDocuments] ++
+ map DisableExtension
+ [MonomorphismRestriction, ImplicitPrelude] ++
+ compatExtensionsExtra
+
+ -- The extra known extensions in Cabal-1.2.3 vs Cabal-1.1.6
+ -- (Cabal-1.1.6 came with ghc-6.6. Cabal-1.2 came with ghc-6.8)
+ compatExtensionsExtra =
+ map EnableExtension
+ [ KindSignatures, MagicHash, TypeFamilies, StandaloneDeriving
+ , UnicodeSyntax, PatternSignatures, UnliftedFFITypes, LiberalTypeSynonyms
+ , TypeOperators, RecordWildCards, RecordPuns, DisambiguateRecordFields
+ , OverloadedStrings, GADTs, RelaxedPolyRec
+ , ExtendedDefaultRules, UnboxedTuples, DeriveDataTypeable
+ , ConstrainedClassMethods
+ ] ++
+ map DisableExtension
+ [MonoPatBinds]
+
+-- | A variation on the normal 'Text' instance, shows any ()'s in the original
+-- textual syntax. We need to show these otherwise it's confusing to users when
+-- we complain of their presense but do not pretty print them!
+--
+displayRawVersionRange :: VersionRange -> String
+displayRawVersionRange =
+ Disp.render
+ . fst
+ . foldVersionRange' -- precedence:
+ -- All the same as the usual pretty printer, except for the parens
+ ( Disp.text "-any" , 0 :: Int)
+ (\v -> (Disp.text "==" <> disp v , 0))
+ (\v -> (Disp.char '>' <> disp v , 0))
+ (\v -> (Disp.char '<' <> disp v , 0))
+ (\v -> (Disp.text ">=" <> disp v , 0))
+ (\v -> (Disp.text "<=" <> disp v , 0))
+ (\v _ -> (Disp.text "==" <> dispWild v , 0))
+ (\(r1, p1) (r2, p2) -> (punct 2 p1 r1 <+> Disp.text "||" <+> punct 2 p2 r2 , 2))
+ (\(r1, p1) (r2, p2) -> (punct 1 p1 r1 <+> Disp.text "&&" <+> punct 1 p2 r2 , 1))
+ (\(r, _ ) -> (Disp.parens r, 0)) -- parens
+
+ where
+ dispWild (Version b _) =
+ Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int b))
+ <> Disp.text ".*"
+ punct p p' | p < p' = Disp.parens
+ | otherwise = id
+
+displayRawDependency :: Dependency -> String
+displayRawDependency (Dependency pkg vr) =
+ display pkg ++ " " ++ displayRawVersionRange vr
+
+
+-- ------------------------------------------------------------
+-- * Checks on the GenericPackageDescription
+-- ------------------------------------------------------------
+
+-- | Check the build-depends fields for any weirdness or bad practise.
+--
+checkPackageVersions :: GenericPackageDescription -> [PackageCheck]
+checkPackageVersions pkg =
+ catMaybes [
+
+ -- Check that the versi