summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSergeiTrofimovich <>2012-09-24 19:02:24 (GMT)
committerhdiff <hdiff@luite.com>2012-09-24 19:02:24 (GMT)
commita0db50cda0f7bcf3ec8f7934db111efe48f2c13b (patch)
tree677a237802217b601cc47e0d62fef90a41412db6
parent0278b85931c6389dea3b986c40f4db62ed82adc9 (diff)
version 0.2.190.2.19
-rw-r--r--Merge/Dependencies.hs24
-rw-r--r--Portage/EBuild.hs4
-rw-r--r--Portage/GHCCore.hs135
-rw-r--r--cabal/.darcs-boring6
-rw-r--r--cabal/Cabal/Cabal.cabal (renamed from cabal/cabal/Cabal.cabal)54
-rw-r--r--cabal/Cabal/DefaultSetup.hs (renamed from cabal/cabal/DefaultSetup.hs)0
-rw-r--r--cabal/Cabal/Distribution/Compat/CopyFile.hs (renamed from cabal/cabal/Distribution/Compat/CopyFile.hs)0
-rw-r--r--cabal/Cabal/Distribution/Compat/Exception.hs (renamed from cabal/cabal/Distribution/Compat/Exception.hs)0
-rw-r--r--cabal/Cabal/Distribution/Compat/ReadP.hs (renamed from cabal/cabal/Distribution/Compat/ReadP.hs)95
-rw-r--r--cabal/Cabal/Distribution/Compat/TempFile.hs (renamed from cabal/cabal/Distribution/Compat/TempFile.hs)0
-rw-r--r--cabal/Cabal/Distribution/Compiler.hs (renamed from cabal/cabal/Distribution/Compiler.hs)0
-rw-r--r--cabal/Cabal/Distribution/GetOpt.hs (renamed from cabal/cabal/Distribution/GetOpt.hs)0
-rw-r--r--cabal/Cabal/Distribution/InstalledPackageInfo.hs (renamed from cabal/cabal/Distribution/InstalledPackageInfo.hs)0
-rw-r--r--cabal/Cabal/Distribution/License.hs (renamed from cabal/cabal/Distribution/License.hs)8
-rw-r--r--cabal/Cabal/Distribution/Make.hs (renamed from cabal/cabal/Distribution/Make.hs)0
-rw-r--r--cabal/Cabal/Distribution/ModuleName.hs (renamed from cabal/cabal/Distribution/ModuleName.hs)0
-rw-r--r--cabal/Cabal/Distribution/Package.hs (renamed from cabal/cabal/Distribution/Package.hs)13
-rw-r--r--cabal/Cabal/Distribution/PackageDescription.hs (renamed from cabal/cabal/Distribution/PackageDescription.hs)161
-rw-r--r--cabal/Cabal/Distribution/PackageDescription/Check.hs (renamed from cabal/cabal/Distribution/PackageDescription/Check.hs)96
-rw-r--r--cabal/Cabal/Distribution/PackageDescription/Configuration.hs (renamed from cabal/cabal/Distribution/PackageDescription/Configuration.hs)78
-rw-r--r--cabal/Cabal/Distribution/PackageDescription/Parse.hs (renamed from cabal/cabal/Distribution/PackageDescription/Parse.hs)163
-rw-r--r--cabal/Cabal/Distribution/PackageDescription/PrettyPrint.hs (renamed from cabal/cabal/Distribution/PackageDescription/PrettyPrint.hs)0
-rw-r--r--cabal/Cabal/Distribution/ParseUtils.hs (renamed from cabal/cabal/Distribution/ParseUtils.hs)2
-rw-r--r--cabal/Cabal/Distribution/ReadE.hs (renamed from cabal/cabal/Distribution/ReadE.hs)0
-rw-r--r--cabal/Cabal/Distribution/Simple.hs (renamed from cabal/cabal/Distribution/Simple.hs)30
-rw-r--r--cabal/Cabal/Distribution/Simple/Bench.hs156
-rw-r--r--cabal/Cabal/Distribution/Simple/Build.hs (renamed from cabal/cabal/Distribution/Simple/Build.hs)249
-rw-r--r--cabal/Cabal/Distribution/Simple/Build/Macros.hs (renamed from cabal/cabal/Distribution/Simple/Build/Macros.hs)0
-rw-r--r--cabal/Cabal/Distribution/Simple/Build/PathsModule.hs (renamed from cabal/cabal/Distribution/Simple/Build/PathsModule.hs)16
-rw-r--r--cabal/Cabal/Distribution/Simple/BuildPaths.hs (renamed from cabal/cabal/Distribution/Simple/BuildPaths.hs)0
-rw-r--r--cabal/Cabal/Distribution/Simple/Command.hs (renamed from cabal/cabal/Distribution/Simple/Command.hs)46
-rw-r--r--cabal/Cabal/Distribution/Simple/Compiler.hs (renamed from cabal/cabal/Distribution/Simple/Compiler.hs)0
-rw-r--r--cabal/Cabal/Distribution/Simple/Configure.hs (renamed from cabal/cabal/Distribution/Simple/Configure.hs)141
-rw-r--r--cabal/Cabal/Distribution/Simple/GHC.hs (renamed from cabal/cabal/Distribution/Simple/GHC.hs)406
-rw-r--r--cabal/Cabal/Distribution/Simple/GHC/IPI641.hs (renamed from cabal/cabal/Distribution/Simple/GHC/IPI641.hs)2
-rw-r--r--cabal/Cabal/Distribution/Simple/GHC/IPI642.hs (renamed from cabal/cabal/Distribution/Simple/GHC/IPI642.hs)2
-rw-r--r--cabal/Cabal/Distribution/Simple/Haddock.hs (renamed from cabal/cabal/Distribution/Simple/Haddock.hs)160
-rw-r--r--cabal/Cabal/Distribution/Simple/Hpc.hs (renamed from cabal/cabal/Distribution/Simple/Hpc.hs)147
-rw-r--r--cabal/Cabal/Distribution/Simple/Hugs.hs (renamed from cabal/cabal/Distribution/Simple/Hugs.hs)4
-rw-r--r--cabal/Cabal/Distribution/Simple/Install.hs (renamed from cabal/cabal/Distribution/Simple/Install.hs)0
-rw-r--r--cabal/Cabal/Distribution/Simple/InstallDirs.hs (renamed from cabal/cabal/Distribution/Simple/InstallDirs.hs)12
-rw-r--r--cabal/Cabal/Distribution/Simple/JHC.hs (renamed from cabal/cabal/Distribution/Simple/JHC.hs)5
-rw-r--r--cabal/Cabal/Distribution/Simple/LHC.hs (renamed from cabal/cabal/Distribution/Simple/LHC.hs)37
-rw-r--r--cabal/Cabal/Distribution/Simple/LocalBuildInfo.hs (renamed from cabal/cabal/Distribution/Simple/LocalBuildInfo.hs)63
-rw-r--r--cabal/Cabal/Distribution/Simple/NHC.hs (renamed from cabal/cabal/Distribution/Simple/NHC.hs)0
-rw-r--r--cabal/Cabal/Distribution/Simple/PackageIndex.hs (renamed from cabal/cabal/Distribution/Simple/PackageIndex.hs)18
-rw-r--r--cabal/Cabal/Distribution/Simple/PreProcess.hs (renamed from cabal/cabal/Distribution/Simple/PreProcess.hs)24
-rw-r--r--cabal/Cabal/Distribution/Simple/PreProcess/Unlit.hs (renamed from cabal/cabal/Distribution/Simple/PreProcess/Unlit.hs)0
-rw-r--r--cabal/Cabal/Distribution/Simple/Program.hs (renamed from cabal/cabal/Distribution/Simple/Program.hs)1
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Ar.hs (renamed from cabal/cabal/Distribution/Simple/Program/Ar.hs)0
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Builtin.hs (renamed from cabal/cabal/Distribution/Simple/Program/Builtin.hs)10
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Db.hs (renamed from cabal/cabal/Distribution/Simple/Program/Db.hs)0
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/GHC.hs458
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/HcPkg.hs (renamed from cabal/cabal/Distribution/Simple/Program/HcPkg.hs)69
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Hpc.hs73
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Ld.hs (renamed from cabal/cabal/Distribution/Simple/Program/Ld.hs)0
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Run.hs (renamed from cabal/cabal/Distribution/Simple/Program/Run.hs)0
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Script.hs (renamed from cabal/cabal/Distribution/Simple/Program/Script.hs)0
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Types.hs (renamed from cabal/cabal/Distribution/Simple/Program/Types.hs)40
-rw-r--r--cabal/Cabal/Distribution/Simple/Register.hs (renamed from cabal/cabal/Distribution/Simple/Register.hs)32
-rw-r--r--cabal/Cabal/Distribution/Simple/Setup.hs (renamed from cabal/cabal/Distribution/Simple/Setup.hs)154
-rw-r--r--cabal/Cabal/Distribution/Simple/SrcDist.hs (renamed from cabal/cabal/Distribution/Simple/SrcDist.hs)31
-rw-r--r--cabal/Cabal/Distribution/Simple/Test.hs (renamed from cabal/cabal/Distribution/Simple/Test.hs)242
-rw-r--r--cabal/Cabal/Distribution/Simple/UHC.hs (renamed from cabal/cabal/Distribution/Simple/UHC.hs)0
-rw-r--r--cabal/Cabal/Distribution/Simple/UserHooks.hs (renamed from cabal/cabal/Distribution/Simple/UserHooks.hs)17
-rw-r--r--cabal/Cabal/Distribution/Simple/Utils.hs (renamed from cabal/cabal/Distribution/Simple/Utils.hs)53
-rw-r--r--cabal/Cabal/Distribution/System.hs (renamed from cabal/cabal/Distribution/System.hs)0
-rw-r--r--cabal/Cabal/Distribution/TestSuite.hs125
-rw-r--r--cabal/Cabal/Distribution/Text.hs (renamed from cabal/cabal/Distribution/Text.hs)0
-rw-r--r--cabal/Cabal/Distribution/Verbosity.hs (renamed from cabal/cabal/Distribution/Verbosity.hs)0
-rw-r--r--cabal/Cabal/Distribution/Version.hs (renamed from cabal/cabal/Distribution/Version.hs)4
-rw-r--r--cabal/Cabal/LICENSE (renamed from cabal/cabal/LICENSE)0
-rw-r--r--cabal/Cabal/Language/Haskell/Extension.hs (renamed from cabal/cabal/Language/Haskell/Extension.hs)24
-rw-r--r--cabal/Cabal/Makefile (renamed from cabal/cabal/Makefile)2
-rw-r--r--cabal/Cabal/README (renamed from cabal/cabal/README)11
-rw-r--r--cabal/Cabal/Setup.hs (renamed from cabal/cabal/Setup.hs)0
-rw-r--r--cabal/Cabal/changelog (renamed from cabal/cabal/changelog)0
-rw-r--r--cabal/Cabal/doc/Cabal.css (renamed from cabal/cabal/doc/Cabal.css)0
-rw-r--r--cabal/Cabal/doc/developing-packages.markdown (renamed from cabal/cabal/doc/developing-packages.markdown)136
-rw-r--r--cabal/Cabal/doc/index.markdown (renamed from cabal/cabal/doc/index.markdown)0
-rw-r--r--cabal/Cabal/doc/installing-packages.markdown (renamed from cabal/cabal/doc/installing-packages.markdown)0
-rw-r--r--cabal/Cabal/doc/misc.markdown (renamed from cabal/cabal/doc/misc.markdown)0
-rw-r--r--cabal/Cabal/prologue.txt (renamed from cabal/cabal/prologue.txt)0
-rw-r--r--cabal/Cabal/runTests.sh (renamed from cabal/cabal/runTests.sh)0
-rw-r--r--cabal/Cabal/tests/PackageTests.hs (renamed from cabal/cabal/tests/suite.hs)22
-rw-r--r--cabal/Cabal/tests/PackageTests/BenchmarkExeV10/Check.hs21
-rw-r--r--cabal/Cabal/tests/PackageTests/BenchmarkExeV10/Foo.hs (renamed from cabal/cabal/tests/PackageTests/TestSuiteExeV10/Foo.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BenchmarkExeV10/Setup.hs (renamed from cabal/cabal/tests/Setup.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BenchmarkExeV10/benchmarks/bench-Foo.hs (renamed from cabal/cabal/tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BenchmarkExeV10/my.cabal15
-rw-r--r--cabal/Cabal/tests/PackageTests/BenchmarkOptions/BenchmarkOptions.cabal20
-rw-r--r--cabal/Cabal/tests/PackageTests/BenchmarkOptions/Check.hs23
-rw-r--r--cabal/Cabal/tests/PackageTests/BenchmarkOptions/Setup.hs (renamed from cabal/cabal/tests/PackageTests/TestSuiteExeV10/Setup.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BenchmarkOptions/test-BenchmarkOptions.hs11
-rw-r--r--cabal/Cabal/tests/PackageTests/BenchmarkStanza/Check.hs57
-rw-r--r--cabal/Cabal/tests/PackageTests/BenchmarkStanza/Setup.hs (renamed from cabal/cabal/tests/PackageTests/TestStanza/Setup.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BenchmarkStanza/my.cabal19
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs22
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal (renamed from cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Setup.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Setup.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs22
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal (renamed from cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Setup.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Setup.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs26
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Setup.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Setup.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal (renamed from cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs)8
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Setup.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Setup.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal (renamed from cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs)14
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Setup.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/Setup.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal (renamed from cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/Setup.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Setup.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal (renamed from cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs)14
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Setup.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/Setup.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal (renamed from cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/Setup.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Setup.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal (renamed from cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs)14
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Setup.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/Setup.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal (renamed from cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/Setup.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Setup.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal (renamed from cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs)8
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal (renamed from cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Setup.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Setup.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs24
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Setup.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Setup.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal (renamed from cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs)8
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Setup.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Setup.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal (renamed from cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs23
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Setup.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Setup.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs (renamed from cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal (renamed from cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal)0
-rw-r--r--cabal/Cabal/tests/PackageTests/PackageTester.hs (renamed from cabal/cabal/tests/PackageTests/PackageTester.hs)63
-rw-r--r--cabal/Cabal/tests/PackageTests/TemplateHaskell/Check.hs44
-rw-r--r--cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/Exe.hs6
-rw-r--r--cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/Lib.hs6
-rw-r--r--cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/Setup.hs3
-rw-r--r--cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/TH.hs4
-rw-r--r--cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/my.cabal15
-rw-r--r--cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/Exe.hs6
-rw-r--r--cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/Lib.hs6
-rw-r--r--cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/Setup.hs3
-rw-r--r--cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/TH.hs4
-rw-r--r--cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/my.cabal15
-rw-r--r--cabal/Cabal/tests/PackageTests/TestOptions/Check.hs23
-rw-r--r--cabal/Cabal/tests/PackageTests/TestOptions/Setup.hs3
-rw-r--r--cabal/Cabal/tests/PackageTests/TestOptions/TestOptions.cabal20
-rw-r--r--cabal/Cabal/tests/PackageTests/TestOptions/test-TestOptions.hs11
-rw-r--r--cabal/Cabal/tests/PackageTests/TestStanza/Check.hs (renamed from cabal/cabal/tests/PackageTests/TestStanza/Check.hs)0
-rw-r--r--cabal/Cabal/tests/PackageTests/TestStanza/Setup.hs3
-rw-r--r--cabal/Cabal/tests/PackageTests/TestStanza/my.cabal (renamed from cabal/cabal/tests/PackageTests/TestStanza/my.cabal)0
-rw-r--r--cabal/Cabal/tests/PackageTests/TestSuiteExeV10/Check.hs (renamed from cabal/cabal/tests/PackageTests/TestSuiteExeV10/Check.hs)8
-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.cabal (renamed from cabal/cabal/tests/PackageTests/TestSuiteExeV10/my.cabal)0
-rw-r--r--cabal/Cabal/tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs8
-rw-r--r--cabal/Cabal/tests/UnitTests.hs17
-rw-r--r--cabal/Cabal/tests/UnitTests/Distribution/Compat/ReadP.hs140
-rw-r--r--cabal/Cabal/tests/hackage/check.sh (renamed from cabal/cabal/tests/hackage/check.sh)0
-rw-r--r--cabal/Cabal/tests/hackage/download.sh (renamed from cabal/cabal/tests/hackage/download.sh)0
-rw-r--r--cabal/Cabal/tests/hackage/unpack.sh (renamed from cabal/cabal/tests/hackage/unpack.sh)0
-rw-r--r--cabal/Cabal/tests/misc/ghc-supported-languages.hs (renamed from cabal/cabal/tests/misc/ghc-supported-languages.hs)0
-rw-r--r--cabal/IMPORTED-FROM7
-rw-r--r--cabal/Paths_Cabal.hs (renamed from cabal/cabal/Paths_Cabal.hs)2
-rw-r--r--cabal/Paths_cabal_install.hs (renamed from cabal/cabal-install/Paths_cabal_install.hs)2
-rw-r--r--cabal/README4
-rw-r--r--cabal/cabal-install/Distribution/Client/BuildReports/Anonymous.hs12
-rw-r--r--cabal/cabal-install/Distribution/Client/BuildReports/Storage.hs4
-rw-r--r--cabal/cabal-install/Distribution/Client/BuildReports/Types.hs2
-rw-r--r--cabal/cabal-install/Distribution/Client/BuildReports/Upload.hs6
-rw-r--r--cabal/cabal-install/Distribution/Client/Config.hs111
-rw-r--r--cabal/cabal-install/Distribution/Client/Configure.hs57
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency.hs195
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular.hs58
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Assignment.hs154
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs143
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Configured.hs10
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs40
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs194
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Explore.hs148
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Flag.hs71
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Index.hs33
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs184
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Log.hs108
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Message.hs98
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/PSQ.hs102
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Package.hs113
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs275
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs54
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs147
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs232
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Version.hs43
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/TopDown.hs44
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/TopDown/Constraints.hs17
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs8
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Types.hs99
-rw-r--r--cabal/cabal-install/Distribution/Client/Fetch.hs26
-rw-r--r--cabal/cabal-install/Distribution/Client/Haddock.hs32
-rw-r--r--cabal/cabal-install/Distribution/Client/HttpUtils.hs34
-rw-r--r--cabal/cabal-install/Distribution/Client/Index.hs218
-rw-r--r--cabal/cabal-install/Distribution/Client/IndexUtils.hs418
-rw-r--r--cabal/cabal-install/Distribution/Client/Init.hs270
-rw-r--r--cabal/cabal-install/Distribution/Client/Init/Heuristics.hs52
-rw-r--r--cabal/cabal-install/Distribution/Client/Init/Licenses.hs206
-rw-r--r--cabal/cabal-install/Distribution/Client/Init/Types.hs12
-rw-r--r--cabal/cabal-install/Distribution/Client/Install.hs673
-rw-r--r--cabal/cabal-install/Distribution/Client/InstallPlan.hs67
-rw-r--r--cabal/cabal-install/Distribution/Client/InstallSymlink.hs13
-rw-r--r--cabal/cabal-install/Distribution/Client/JobControl.hs89
-rw-r--r--cabal/cabal-install/Distribution/Client/List.hs67
-rw-r--r--cabal/cabal-install/Distribution/Client/PackageEnvironment.hs380
-rw-r--r--cabal/cabal-install/Distribution/Client/PackageIndex.hs2
-rw-r--r--cabal/cabal-install/Distribution/Client/ParseUtils.hs55
-rw-r--r--cabal/cabal-install/Distribution/Client/Sandbox.hs215
-rw-r--r--cabal/cabal-install/Distribution/Client/Setup.hs641
-rw-r--r--cabal/cabal-install/Distribution/Client/SetupWrapper.hs181
-rw-r--r--cabal/cabal-install/Distribution/Client/SrcDist.hs136
-rw-r--r--cabal/cabal-install/Distribution/Client/Tar.hs59
-rw-r--r--cabal/cabal-install/Distribution/Client/Targets.hs25
-rw-r--r--cabal/cabal-install/Distribution/Client/Types.hs36
-rw-r--r--cabal/cabal-install/Distribution/Client/Update.hs10
-rw-r--r--cabal/cabal-install/Distribution/Client/Upload.hs41
-rw-r--r--cabal/cabal-install/Distribution/Client/Utils.hs73
-rw-r--r--cabal/cabal-install/Distribution/Client/World.hs5
-rw-r--r--cabal/cabal-install/Distribution/Compat/Time.hs37
-rw-r--r--cabal/cabal-install/Main.hs371
-rw-r--r--cabal/cabal-install/README20
-rw-r--r--cabal/cabal-install/bootstrap.sh32
-rw-r--r--cabal/cabal-install/cabal-install.cabal64
-rw-r--r--cabal/cabal-install/cbits/getnumcores.c46
-rw-r--r--cabal/cabal-install/changelog14
-rw-r--r--cabal/cabal/Distribution/TestSuite.hs310
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs15
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs15
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs20
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs18
-rw-r--r--cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs17
-rw-r--r--cabal/cabal/tests/README14
-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/suite.cabal30
-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.cabal11
359 files changed, 10020 insertions, 6572 deletions
diff --git a/Merge/Dependencies.hs b/Merge/Dependencies.hs
index 44ebd58..55ded63 100644
--- a/Merge/Dependencies.hs
+++ b/Merge/Dependencies.hs
@@ -296,7 +296,9 @@ resolvePkgConfig overlay (Cabal.Dependency (Cabal.PackageName pn) _cabalVersion)
table :: [(String, (String, String))]
table =
- [("gconf-2.0", ("gnome-base", "gconf"))
+ [
+ ("alsa", ("media-libs", "alsa-lib"))
+ ,("gconf-2.0", ("gnome-base", "gconf"))
,("gio-2.0", ("dev-libs", "glib:2"))
,("gio-unix-2.0", ("dev-libs", "glib:2"))
@@ -307,13 +309,13 @@ table =
,("gobject-2.0", ("dev-libs", "glib:2"))
,("gthread-2.0", ("dev-libs", "glib:2"))
- ,("gtk+-2.0", ("x11-libs", "gtk+")) -- should be slot 2
- ,("gdk-2.0", ("x11-libs", "gtk+"))
- ,("gdk-pixbuf-2.0", ("x11-libs", "gtk+"))
- ,("gdk-pixbuf-xlib-2.0", ("x11-libs", "gtk+"))
- ,("gdk-x11-2.0", ("x11-libs", "gtk+"))
- ,("gtk+-unix-print-2.0", ("x11-libs", "gtk+"))
- ,("gtk+-x11-2.0", ("x11-libs", "gtk+"))
+ ,("gtk+-2.0", ("x11-libs", "gtk+:2"))
+ ,("gdk-2.0", ("x11-libs", "gtk+:2"))
+ ,("gdk-pixbuf-2.0", ("x11-libs", "gtk+:2"))
+ ,("gdk-pixbuf-xlib-2.0", ("x11-libs", "gtk+:2"))
+ ,("gdk-x11-2.0", ("x11-libs", "gtk+:2"))
+ ,("gtk+-unix-print-2.0", ("x11-libs", "gtk+:2"))
+ ,("gtk+-x11-2.0", ("x11-libs", "gtk+:2"))
,("cairo", ("x11-libs", "cairo")) -- need [svg] for dev-haskell/cairo
,("cairo-ft", ("x11-libs", "cairo"))
@@ -333,7 +335,7 @@ table =
,("libglade-2.0", ("gnome-base", "libglade"))
,("gnome-vfs-2.0", ("gnome-base", "gnome-vfs"))
,("gnome-vfs-module-2.0", ("gnome-base", "gnome-vfs"))
- ,("webkit-1.0", ("net-libs","webkit-gtk"))
+ ,("webkit-1.0", ("net-libs","webkit-gtk:2"))
,("gstreamer-0.10", ("media-libs", "gstreamer"))
,("gstreamer-base-0.10", ("media-libs", "gstreamer"))
@@ -347,9 +349,9 @@ table =
,("gstreamer-video-0.10", ("media-libs", "gst-plugins-base"))
,("gstreamer-plugins-base-0.10", ("media-libs", "gst-plugins-base"))
- ,("gtksourceview-2.0", ("x11-libs", "gtksourceview"))
+ ,("gtksourceview-2.0", ("x11-libs", "gtksourceview:2.0"))
,("librsvg-2.0", ("gnome-base","librsvg"))
- ,("vte", ("x11-libs","vte"))
+ ,("vte", ("x11-libs","vte:0"))
,("gtkglext-1.0", ("x11-libs","gtkglext"))
,("curl", ("net-misc", "curl"))
diff --git a/Portage/EBuild.hs b/Portage/EBuild.hs
index bb06bdf..4de0213 100644
--- a/Portage/EBuild.hs
+++ b/Portage/EBuild.hs
@@ -11,6 +11,7 @@ import Portage.Dependency
import Distribution.License as Cabal
+import Data.String.Utils
import Data.Version(Version(..))
import qualified Paths_hackport(version)
@@ -93,7 +94,7 @@ showEBuild ebuild =
ss "MY_P=". quote "${MY_PN}-${PV}". nl. nl).
ss "DESCRIPTION=". quote (description ebuild). nl.
ss "HOMEPAGE=". quote (expandVars (homepage ebuild)). nl.
- ss "SRC_URI=". quote (src_uri ebuild). nl.
+ ss "SRC_URI=". quote (toMirror $ src_uri ebuild). nl.
nl.
ss "LICENSE=". quote (convertLicense . license $ ebuild).
(if null (licenseComment . license $ ebuild) then id
@@ -111,6 +112,7 @@ showEBuild ebuild =
where expandVars = replaceMultiVars [ ( name ebuild, "${PN}")
, (hackage_name ebuild, "${HACKAGE_N}")
]
+ toMirror = replace "http://hackage.haskell.org/" "mirror://hackage/"
ss :: String -> String -> String
ss = showString
diff --git a/Portage/GHCCore.hs b/Portage/GHCCore.hs
index d49d607..31ced2c 100644
--- a/Portage/GHCCore.hs
+++ b/Portage/GHCCore.hs
@@ -25,7 +25,7 @@ defaultGHC :: (CompilerId, [PackageName])
defaultGHC = let (g,pix) = ghc6123 in (g, packageNamesFromPackageIndex pix)
ghcs :: [(CompilerId, PackageIndex)]
-ghcs = [ghc682, ghc6101, ghc6104, ghc6121, ghc6122, ghc6123, ghc701]
+ghcs = [ghc6104, ghc6121, ghc6122, ghc6123, ghc701, ghc742, ghc761]
cabalFromGHC :: [Int] -> Maybe Version
cabalFromGHC ver = lookup ver table
@@ -43,6 +43,8 @@ cabalFromGHC ver = lookup ver table
,([6,12,2], Version [1,8,0,4] [])
,([6,12,3], Version [1,8,0,6] [])
,([7,0,1], Version [1,10,0,0] [])
+ ,([7,4,2], Version [1,14,0] [])
+ ,([7,6,1], Version [1,16,0] [])
]
platform :: Platform
@@ -90,13 +92,17 @@ mkIndex pids = fromList
| pi@(PackageIdentifier name version) <- pids ]
packageNamesFromPackageIndex :: PackageIndex -> [PackageName]
-packageNamesFromPackageIndex pix = nub $
- [ (pkgName . sourcePackageId) p | (p:_) <- allPackagesByName pix ]
+packageNamesFromPackageIndex pix = nub $ map fst $ allPackagesByName pix
ghc :: [Int] -> CompilerId
ghc nrs = CompilerId GHC (Version nrs [])
--- | Core packages in GHC 7.0.1 as a 'PackageIndex'.
+ghc761 :: (CompilerId, PackageIndex)
+ghc761 = (ghc [7,6,1], mkIndex ghc761_pkgs)
+
+ghc742 :: (CompilerId, PackageIndex)
+ghc742 = (ghc [7,4,2], mkIndex ghc742_pkgs)
+
ghc701 :: (CompilerId, PackageIndex)
ghc701 = (ghc [7,0,1], mkIndex ghc701_pkgs)
@@ -112,23 +118,70 @@ ghc6121 = (ghc [6,12,1], mkIndex ghc6121_pkgs)
ghc6104 :: (CompilerId, PackageIndex)
ghc6104 = (ghc [6,10,4], mkIndex ghc6104_pkgs)
-ghc6101 :: (CompilerId, PackageIndex)
-ghc6101 = (ghc [6,10,1], mkIndex ghc6101_pkgs)
-
-ghc682 :: (CompilerId, PackageIndex)
-ghc682 = (ghc [6,8,2], mkIndex ghc682_pkgs)
-
-- | Non-upgradeable core packages
-- Source: http://haskell.org/haskellwiki/Libraries_released_with_GHC
+
+ghc761_pkgs :: [PackageIdentifier]
+ghc761_pkgs =
+ [ p "array" [0,4,0,1]
+ , p "base" [4,6,0,0]
+-- , p "binary" [0,5,1,1] package is upgradeable
+ , p "bytestring" [0,10,0,8]
+-- , p "Cabal" [1,16,0] package is upgradeable
+ , p "containers" [0,5,0,0]
+ , p "deepseq" [1,3,0,1]
+ , p "directory" [1,2,0,0]
+ , p "filepath" [1,3,0,1]
+ , p "ghc-prim" [0,3,0,0]
+ , p "haskell2010" [1,1,1,0]
+ , p "haskell98" [2,0,0,2]
+ , p "hoopl" [3,9,0,0] -- used by libghc
+ , p "hpc" [0,6,0,0] -- used by libghc
+ , p "integer-gmp" [0,5,0,0]
+ , p "old-locale" [1,0,0,5]
+ , p "old-time" [1,1,0,1]
+ , p "pretty" [1,1,1,0]
+ , p "process" [1,1,0,2]
+ , p "template-haskell" [2,8,0,0] -- used by libghc
+ , p "time" [1,4,0,1] -- used by haskell98
+ , p "unix" [2,6,0,0]
+ ]
+
+ghc742_pkgs :: [PackageIdentifier]
+ghc742_pkgs =
+ [ p "array" [0,4,0,0]
+ , p "base" [4,5,1,0]
+-- , p "binary" [0,5,1,0] package is upgradeable
+ , p "bytestring" [0,9,1,8]
+-- , p "Cabal" [1,14,0] package is upgradeable
+ , p "containers" [0,4,2,1]
+ , p "directory" [1,1,0,2]
+-- , p "extensible-exceptions" [0,1,1,4] -- package is upgradeable, stopped shipping in 7.6
+ , p "filepath" [1,3,0,0]
+ , p "ghc-prim" [0,2,0,0]
+ , p "haskell2010" [1,1,0,1]
+ , p "haskell98" [2,0,0,1]
+ , p "hoopl" [3,8,7,3] -- used by libghc
+ , p "hpc" [0,5,1,1] -- used by libghc
+ , p "integer-gmp" [0,4,0,0]
+ , p "old-locale" [1,0,0,4]
+ , p "old-time" [1,1,0,0]
+ , p "pretty" [1,1,1,0]
+ , p "process" [1,1,0,1]
+ , p "template-haskell" [2,7,0,0] -- used by libghc
+ , p "time" [1,4] -- used by haskell98
+ , p "unix" [2,5,1,1]
+ ]
+
ghc701_pkgs :: [PackageIdentifier]
-ghc701_pkgs =
+ghc701_pkgs =
[ p "array" [0,3,0,2]
, p "base" [4,3,0,0]
, p "bytestring" [0,9,1,8]
-- , p "Cabal" [1,10,0,0] package is upgradeable
, p "containers" [0,4,0,0]
, p "directory" [1,1,0,0]
- , p "extensible-exceptions" [0,1,1,2]
+-- , p "extensible-exceptions" [0,1,1,2] -- package is upgradeable, stopped shipping in 7.6
, p "filepath" [1,2,0,0]
, p "haskell2010" [1,0,0,0]
, p "haskell98" [1,1,0,0]
@@ -147,7 +200,7 @@ ghc701_pkgs =
]
ghc6123_pkgs :: [PackageIdentifier]
-ghc6123_pkgs =
+ghc6123_pkgs =
[ p "array" [0,3,0,1]
, p "base" [3,0,3,2]
, p "base" [4,2,0,2]
@@ -155,7 +208,7 @@ ghc6123_pkgs =
-- , p "Cabal" [1,8,0,6] package is upgradeable
, p "containers" [0,3,0,0]
, p "directory" [1,0,1,1]
- , p "extensible-exceptions" [0,1,1,1]
+-- , p "extensible-exceptions" [0,1,1,1] -- package is upgradeable, stopped shipping in 7.6
, p "filepath" [1,1,0,4]
, p "haskell98" [1,0,1,1]
, p "hpc" [0,5,0,5]
@@ -182,7 +235,7 @@ ghc6122_pkgs =
-- , p "Cabal" [1,8,0,4] package is upgradeable
, p "containers" [0,3,0,0]
, p "directory" [1,0,1,1]
- , p "extensible-exceptions" [0,1,1,1]
+-- , p "extensible-exceptions" [0,1,1,1] -- package is upgradeable, stopped shipping in 7.6
, p "filepath" [1,1,0,4]
, p "haskell98" [1,0,1,1]
, p "hpc" [0,5,0,5]
@@ -201,7 +254,7 @@ ghc6122_pkgs =
]
ghc6121_pkgs :: [PackageIdentifier]
-ghc6121_pkgs =
+ghc6121_pkgs =
[ p "array" [0,3,0,0]
, p "base" [3,0,3,2]
, p "base" [4,2,0,0]
@@ -209,7 +262,7 @@ ghc6121_pkgs =
-- , p "Cabal" [1,8,0,2] package is upgradeable
, p "containers" [0,3,0,0]
, p "directory" [1,0,1,0]
- , p "extensible-exceptions" [0,1,1,1]
+-- , p "extensible-exceptions" [0,1,1,1] -- package is upgradeable, stopped shipping in 7.6
, p "filepath" [1,1,0,3]
, p "haskell98" [1,0,1,1]
, p "hpc" [0,5,0,4]
@@ -236,7 +289,7 @@ ghc6104_pkgs =
-- , p "Cabal" [1,6,0,3] package is upgradeable
, p "containers" [0,2,0,1 ]
, p "directory" [1,0,0,3]
- , p "extensible-exceptions" [0,1,1,0]
+-- , p "extensible-exceptions" [0,1,1,0] -- package is upgradeable, stopped shipping in 7.6
, p "filepath" [1,1,0,2]
, p "haskell98" [1,0,1,0]
, p "hpc" [0,5,0,3]
@@ -252,51 +305,5 @@ ghc6104_pkgs =
, p "unix" [2,3,2,0]
]
-ghc6101_pkgs :: [PackageIdentifier]
-ghc6101_pkgs =
- [ p "array" [0,2,0,0]
- , p "base" [3,0,3,0]
- , p "base" [4,0,0,0]
- , p "bytestring" [0,9,1,4]
--- , p "Cabal" [1,6,0,1] package is upgradeable
- , p "containers" [0,2,0,0]
- , p "directory" [1,0,0,2]
- , p "extensible-exceptions" [0,1,0,0]
- , p "filepath" [1,1,0,1]
- , p "haskell98" [1,0,1,0]
- , p "hpc" [0,5,0,2]
- , p "old-locale" [1,0,0,1]
- , p "old-time" [1,0,0,1]
- , p "packedstring" [0,1,0,1]
- , p "pretty" [1,0,1,0]
- , p "process" [1,0,1,0]
--- , p "random" [1,0,0,1] -- will not be shipped starting from ghc-7.2
--- , p "syb" [0,1,0,0] -- not distributed with ghc-7
- , p "template-haskell" [2,3,0,0]
- , p "unix" [2,3,1,0]
- ]
-
-ghc682_pkgs :: [PackageIdentifier]
-ghc682_pkgs =
- [ p "array" [0,1,0,0]
- , p "base" [3,0,1,0]
- , p "bytestring" [0,9,0,1]
--- , p "Cabal" [1,2,3,0] package is upgradeable
- , p "containers" [0,1,0,1]
- , p "dictionary" [1,0,0,0]
- , p "filepath" [1,1,0,0]
- , p "haskell98" [1,0,1,0]
- , p "hpc" [0,5,0,0]
- , p "old-locale" [1,0,0,0]
- , p "old-time" [1,0,0,0]
- , p "packedstring" [0,1,0,0]
- , p "pretty" [1,0,0,0]
- , p "process" [1,0,0,0]
--- , p "random" [1,0,0,0] -- will not be shipped starting from ghc-7.2
--- , p "readline" [1,0,1,0]
- , p "template-haskell" [2,2,0,0]
- , p "unix" [2,3,0,0]
- ]
-
p :: String -> [Int] -> PackageIdentifier
p pn vs = PackageIdentifier (PackageName pn) (Version vs [])
diff --git a/cabal/.darcs-boring b/cabal/.darcs-boring
deleted file mode 100644
index 4eddbbc..0000000
--- a/cabal/.darcs-boring
+++ /dev/null
@@ -1,6 +0,0 @@
-^dist(/|$)
-^setup(/|$)
-^GNUmakefile$
-^Makefile.local$
-^.depend(.bak)?$
-^doc/.depend(.bak)?$
diff --git a/cabal/cabal/Cabal.cabal b/cabal/Cabal/Cabal.cabal
index 403b450..a80e13b 100644
--- a/cabal/cabal/Cabal.cabal
+++ b/cabal/Cabal/Cabal.cabal
@@ -1,5 +1,5 @@
Name: Cabal
-Version: 1.12.0
+Version: 1.17.0
Copyright: 2003-2006, Isaac Jones
2005-2011, Duncan Coutts
License: BSD3
@@ -8,7 +8,7 @@ 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/
+bug-reports: https://github.com/haskell/cabal/issues
Synopsis: A framework for packaging Haskell software
Description:
The Haskell Common Architecture for Building Applications and
@@ -27,8 +27,9 @@ Extra-Source-Files:
README changelog
source-repository head
- type: darcs
- location: http://darcs.haskell.org/cabal/
+ type: git
+ location: https://github.com/haskell/cabal/
+ subdir: Cabal
Flag base4
Description: Choose the even newer, even smaller, split-up base package.
@@ -36,21 +37,28 @@ Flag base4
Flag base3
Description: Choose the new smaller, split-up base package.
+Flag bytestring-in-base
+
Library
build-depends: base >= 2 && < 5,
- filepath >= 1 && < 1.3
+ deepseq >= 1.3 && < 1.4,
+ filepath >= 1 && < 1.4
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,
+ Build-Depends: directory >= 1 && < 1.3,
process >= 1 && < 1.2,
- old-time >= 1 && < 1.1,
- containers >= 0.1 && < 0.5,
- array >= 0.1 && < 0.4,
+ old-time >= 1 && < 1.2,
+ containers >= 0.1 && < 0.6,
+ array >= 0.1 && < 0.5,
pretty >= 1 && < 1.2
+ if flag(bytestring-in-base)
+ Build-Depends: base >= 2.0 && < 2.2
+ else
+ Build-Depends: base < 2.0 || >= 3.0, bytestring >= 0.9
if !os(windows)
- Build-Depends: unix >= 2.0 && < 2.6
+ Build-Depends: unix >= 2.0 && < 2.7
ghc-options: -Wall -fno-ignore-asserts
if impl(ghc >= 6.8)
@@ -76,6 +84,7 @@ Library
Distribution.Simple.Build.Macros,
Distribution.Simple.Build.PathsModule,
Distribution.Simple.BuildPaths,
+ Distribution.Simple.Bench,
Distribution.Simple.Command,
Distribution.Simple.Compiler,
Distribution.Simple.Configure,
@@ -96,7 +105,9 @@ Library
Distribution.Simple.Program.Ar,
Distribution.Simple.Program.Builtin,
Distribution.Simple.Program.Db,
+ Distribution.Simple.Program.GHC,
Distribution.Simple.Program.HcPkg,
+ Distribution.Simple.Program.Hpc,
Distribution.Simple.Program.Ld,
Distribution.Simple.Program.Run,
Distribution.Simple.Program.Script,
@@ -128,9 +139,25 @@ Library
Default-Language: Haskell98
Default-Extensions: CPP
+-- Small, fast running tests.
test-suite unit-tests
type: exitcode-stdio-1.0
- main-is: suite.hs
+ main-is: UnitTests.hs
+ hs-source-dirs: tests
+ build-depends:
+ base,
+ test-framework,
+ test-framework-hunit,
+ test-framework-quickcheck2,
+ HUnit,
+ QuickCheck,
+ Cabal
+ Default-Language: Haskell98
+
+-- Large, system tests that build packages.
+test-suite package-tests
+ type: exitcode-stdio-1.0
+ main-is: PackageTests.hs
other-modules: PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check,
PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check,
PackageTests.BuildDeps.InternalLibrary0.Check,
@@ -142,14 +169,17 @@ test-suite unit-tests
PackageTests.BuildDeps.TargetSpecificDeps2.Check,
PackageTests.BuildDeps.TargetSpecificDeps3.Check,
PackageTests.BuildDeps.SameDepsAllRound.Check,
+ PackageTests.TestOptions.Check,
PackageTests.TestStanza.Check,
PackageTests.TestSuiteExeV10.Check,
+ PackageTests.BenchmarkStanza.Check,
+ PackageTests.TemplateHaskell.Check,
PackageTests.PackageTester
hs-source-dirs: tests
build-depends:
base,
test-framework,
- test-framework-quickcheck2,
+ test-framework-quickcheck2 >= 0.2.12,
test-framework-hunit,
HUnit,
QuickCheck >= 2.1.0.1,
diff --git a/cabal/cabal/DefaultSetup.hs b/cabal/Cabal/DefaultSetup.hs
index 9a994af..9a994af 100644
--- a/cabal/cabal/DefaultSetup.hs
+++ b/cabal/Cabal/DefaultSetup.hs
diff --git a/cabal/cabal/Distribution/Compat/CopyFile.hs b/cabal/Cabal/Distribution/Compat/CopyFile.hs
index 3d96d72..3d96d72 100644
--- a/cabal/cabal/Distribution/Compat/CopyFile.hs
+++ b/cabal/Cabal/Distribution/Compat/CopyFile.hs
diff --git a/cabal/cabal/Distribution/Compat/Exception.hs b/cabal/Cabal/Distribution/Compat/Exception.hs
index ae8d9d5..ae8d9d5 100644
--- a/cabal/cabal/Distribution/Compat/Exception.hs
+++ b/cabal/Cabal/Distribution/Compat/Exception.hs
diff --git a/cabal/cabal/Distribution/Compat/ReadP.hs b/cabal/Cabal/Distribution/Compat/ReadP.hs
index 0c3d989..e087ed2 100644
--- a/cabal/cabal/Distribution/Compat/ReadP.hs
+++ b/cabal/Cabal/Distribution/Compat/ReadP.hs
@@ -19,6 +19,8 @@
-- This version of ReadP has been locally hacked to make it H98, by
-- Martin Sj&#xF6;gren <mailto:msjogren@gmail.com>
--
+-- The unit tests have been moved to UnitTest.Distribution.Compat.ReadP, by
+-- Mark Lentczner <mailto:mark@glyphic.com>
-----------------------------------------------------------------------------
module Distribution.Compat.ReadP
@@ -64,9 +66,6 @@ module Distribution.Compat.ReadP
ReadS, -- :: *; = String -> [(a,String)]
readP_to_S, -- :: ReadP a -> ReadS a
readS_to_P -- :: ReadS a -> ReadP a
-
- -- * Properties
- -- $properties
)
where
@@ -378,93 +377,5 @@ readS_to_P :: ReadS a -> ReadP r a
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
index 9feddeb..9feddeb 100644
--- a/cabal/cabal/Distribution/Compat/TempFile.hs
+++ b/cabal/Cabal/Distribution/Compat/TempFile.hs
diff --git a/cabal/cabal/Distribution/Compiler.hs b/cabal/Cabal/Distribution/Compiler.hs
index 82abd46..82abd46 100644
--- a/cabal/cabal/Distribution/Compiler.hs
+++ b/cabal/Cabal/Distribution/Compiler.hs
diff --git a/cabal/cabal/Distribution/GetOpt.hs b/cabal/Cabal/Distribution/GetOpt.hs
index 14725d3..14725d3 100644
--- a/cabal/cabal/Distribution/GetOpt.hs
+++ b/cabal/Cabal/Distribution/GetOpt.hs
diff --git a/cabal/cabal/Distribution/InstalledPackageInfo.hs b/cabal/Cabal/Distribution/InstalledPackageInfo.hs
index db3a3e6..db3a3e6 100644
--- a/cabal/cabal/Distribution/InstalledPackageInfo.hs
+++ b/cabal/Cabal/Distribution/InstalledPackageInfo.hs
diff --git a/cabal/cabal/Distribution/License.hs b/cabal/Cabal/Distribution/License.hs
index 27e5b30..19b54c3 100644
--- a/cabal/cabal/Distribution/License.hs
+++ b/cabal/Cabal/Distribution/License.hs
@@ -89,6 +89,11 @@ data License =
-- | The MIT license, similar to the BSD3. Very free license.
| MIT
+ -- | The Apache License. Version 2.0 is the current version,
+ -- previous versions are considered historical.
+
+ | Apache (Maybe Version)
+
-- | Holder makes no claim to ownership, least restrictive license.
| PublicDomain
@@ -107,6 +112,7 @@ knownLicenses :: [License]
knownLicenses = [ GPL unversioned, GPL (version [2]), GPL (version [3])
, LGPL unversioned, LGPL (version [2,1]), LGPL (version [3])
, BSD3, MIT
+ , Apache unversioned, Apache (version [2, 0])
, PublicDomain, AllRightsReserved, OtherLicense]
where
unversioned = Nothing
@@ -115,6 +121,7 @@ knownLicenses = [ GPL unversioned, GPL (version [2]), GPL (version [3])
instance Text License where
disp (GPL version) = Disp.text "GPL" <> dispOptVersion version
disp (LGPL version) = Disp.text "LGPL" <> dispOptVersion version
+ disp (Apache version) = Disp.text "Apache" <> dispOptVersion version
disp (UnknownLicense other) = Disp.text other
disp other = Disp.text (show other)
@@ -127,6 +134,7 @@ instance Text License where
("BSD3", Nothing) -> BSD3
("BSD4", Nothing) -> BSD4
("MIT", Nothing) -> MIT
+ ("Apache", _ ) -> Apache version
("PublicDomain", Nothing) -> PublicDomain
("AllRightsReserved", Nothing) -> AllRightsReserved
("OtherLicense", Nothing) -> OtherLicense
diff --git a/cabal/cabal/Distribution/Make.hs b/cabal/Cabal/Distribution/Make.hs
index d085ce3..d085ce3 100644
--- a/cabal/cabal/Distribution/Make.hs
+++ b/cabal/Cabal/Distribution/Make.hs
diff --git a/cabal/cabal/Distribution/ModuleName.hs b/cabal/Cabal/Distribution/ModuleName.hs
index 5fe0cc1..5fe0cc1 100644
--- a/cabal/cabal/Distribution/ModuleName.hs
+++ b/cabal/Cabal/Distribution/ModuleName.hs
diff --git a/cabal/cabal/Distribution/Package.hs b/cabal/Cabal/Distribution/Package.hs
index fb2f3e0..0017b8c 100644
--- a/cabal/cabal/Distribution/Package.hs
+++ b/cabal/Cabal/Distribution/Package.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveDataTypeable #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Package
@@ -70,11 +71,13 @@ import qualified Distribution.Compat.ReadP as Parse
import Distribution.Compat.ReadP ((<++))
import qualified Text.PrettyPrint as Disp
import Text.PrettyPrint ((<>), (<+>), text)
+import Control.DeepSeq (NFData(..))
import qualified Data.Char as Char ( isDigit, isAlphaNum )
import Data.List ( intersperse )
+import Data.Typeable ( Typeable )
newtype PackageName = PackageName String
- deriving (Read, Show, Eq, Ord)
+ deriving (Read, Show, Eq, Ord, Typeable)
instance Text PackageName where
disp (PackageName n) = Disp.text n
@@ -88,6 +91,9 @@ instance Text PackageName where
-- each component must contain an alphabetic character, to avoid
-- ambiguity in identifiers like foo-1 (the 1 is the version number).
+instance NFData PackageName where
+ rnf (PackageName pkg) = rnf pkg
+
-- | Type alias so we can use the shorter name PackageId.
type PackageId = PackageIdentifier
@@ -97,7 +103,7 @@ data 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)
+ deriving (Read, Show, Eq, Ord, Typeable)
instance Text PackageIdentifier where
disp (PackageIdentifier n v) = case v of
@@ -109,6 +115,9 @@ instance Text PackageIdentifier where
v <- (Parse.char '-' >> parse) <++ return (Version [] [])
return (PackageIdentifier n v)
+instance NFData PackageIdentifier where
+ rnf (PackageIdentifier name version) = rnf name `seq` rnf version
+
-- ------------------------------------------------------------
-- * Installed Package Ids
-- ------------------------------------------------------------
diff --git a/cabal/cabal/Distribution/PackageDescription.hs b/cabal/Cabal/Distribution/PackageDescription.hs
index f4e3622..034479b 100644
--- a/cabal/cabal/Distribution/PackageDescription.hs
+++ b/cabal/Cabal/Distribution/PackageDescription.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveDataTypeable #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.PackageDescription
@@ -8,10 +9,10 @@
--
-- 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
+-- 'Executable', 'TestSuite', and 'Benchmark' sections each of which have
+-- associated 'BuildInfo' data that's used to build the library, exe, test, or
+-- benchmark. 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
@@ -85,6 +86,18 @@ module Distribution.PackageDescription (
testModules,
enabledTests,
+ -- * Benchmarks
+ Benchmark(..),
+ BenchmarkInterface(..),
+ BenchmarkType(..),
+ benchmarkType,
+ knownBenchmarkTypes,
+ emptyBenchmark,
+ hasBenchmarks,
+ withBenchmark,
+ benchmarkModules,
+ enabledBenchmarks,
+
-- * Build information
BuildInfo(..),
emptyBuildInfo,
@@ -114,8 +127,9 @@ module Distribution.PackageDescription (
import Data.List (nub, intersperse)
import Data.Maybe (maybeToList)
import Data.Monoid (Monoid(mempty, mappend))
+import Data.Typeable ( Typeable )
import Control.Monad (MonadPlus(mplus))
-import Text.PrettyPrint.HughesPJ as Disp
+import Text.PrettyPrint as Disp
import qualified Distribution.Compat.ReadP as Parse
import qualified Data.Char as Char (isAlphaNum, isDigit, toLower)
@@ -175,6 +189,7 @@ data PackageDescription
library :: Maybe Library,
executables :: [Executable],
testSuites :: [TestSuite],
+ benchmarks :: [Benchmark],
dataFiles :: [FilePath],
dataDir :: FilePath,
extraSrcFiles :: [FilePath],
@@ -237,6 +252,7 @@ emptyPackageDescription
library = Nothing,
executables = [],
testSuites = [],
+ benchmarks = [],
dataFiles = [],
dataDir = "",
extraSrcFiles = [],
@@ -470,9 +486,7 @@ data TestType = TestTypeExe Version -- ^ \"type: exitcode-stdio-x.y\"
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] []) -} ]
+ , TestTypeLib (Version [0,9] []) ]
instance Text TestType where
disp (TestTypeExe ver) = text "exitcode-stdio-" <> disp ver
@@ -503,6 +517,125 @@ testType test = case testInterface test of
TestSuiteUnsupported testtype -> testtype
-- ---------------------------------------------------------------------------
+-- The Benchmark type
+
+-- | A \"benchmark\" stanza in a cabal file.
+--
+data Benchmark = Benchmark {
+ benchmarkName :: String,
+ benchmarkInterface :: BenchmarkInterface,
+ benchmarkBuildInfo :: BuildInfo,
+ benchmarkEnabled :: Bool
+ -- TODO: See TODO for 'testEnabled'.
+ }
+ deriving (Show, Read, Eq)
+
+-- | The benchmark interfaces that are currently defined. Each
+-- benchmark must specify which interface it supports.
+--
+-- More interfaces may be defined in future, either new revisions or
+-- totally new interfaces.
+--
+data BenchmarkInterface =
+
+ -- | Benchmark interface \"exitcode-stdio-1.0\". The benchmark
+ -- 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.
+ --
+ BenchmarkExeV10 Version FilePath
+
+ -- | A benchmark that does not conform to one of the above
+ -- interfaces for the given reason (e.g. unknown benchmark type).
+ --
+ | BenchmarkUnsupported BenchmarkType
+ deriving (Eq, Read, Show)
+
+instance Monoid Benchmark where
+ mempty = Benchmark {
+ benchmarkName = mempty,
+ benchmarkInterface = mempty,
+ benchmarkBuildInfo = mempty,
+ benchmarkEnabled = False
+ }
+
+ mappend a b = Benchmark {
+ benchmarkName = combine' benchmarkName,
+ benchmarkInterface = combine benchmarkInterface,
+ benchmarkBuildInfo = combine benchmarkBuildInfo,
+ benchmarkEnabled = if benchmarkEnabled a then True
+ else benchmarkEnabled 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 benchmark field: '"
+ ++ x ++ "' and '" ++ y ++ "'"
+
+instance Monoid BenchmarkInterface where
+ mempty = BenchmarkUnsupported (BenchmarkTypeUnknown mempty (Version [] []))
+ mappend a (BenchmarkUnsupported _) = a
+ mappend _ b = b
+
+emptyBenchmark :: Benchmark
+emptyBenchmark = mempty
+
+-- | Does this package have any benchmarks?
+hasBenchmarks :: PackageDescription -> Bool
+hasBenchmarks = any (buildable . benchmarkBuildInfo) . benchmarks
+
+-- | Get all the enabled benchmarks from a package.
+enabledBenchmarks :: PackageDescription -> [Benchmark]
+enabledBenchmarks = filter benchmarkEnabled . benchmarks
+
+-- | Perform an action on each buildable 'Benchmark' in a package.
+withBenchmark :: PackageDescription -> (Benchmark -> IO ()) -> IO ()
+withBenchmark pkg_descr f =
+ mapM_ f $ filter (buildable . benchmarkBuildInfo) $ enabledBenchmarks pkg_descr
+
+-- | Get all the module names from a benchmark.
+benchmarkModules :: Benchmark -> [ModuleName]
+benchmarkModules benchmark = otherModules (benchmarkBuildInfo benchmark)
+
+-- | The \"benchmark-type\" field in the benchmark stanza.
+--
+data BenchmarkType = BenchmarkTypeExe Version
+ -- ^ \"type: exitcode-stdio-x.y\"
+ | BenchmarkTypeUnknown String Version
+ -- ^ Some unknown benchmark type e.g. \"type: foo\"
+ deriving (Show, Read, Eq)
+
+knownBenchmarkTypes :: [BenchmarkType]
+knownBenchmarkTypes = [ BenchmarkTypeExe (Version [1,0] []) ]
+
+instance Text BenchmarkType where
+ disp (BenchmarkTypeExe ver) = text "exitcode-stdio-" <> disp ver
+ disp (BenchmarkTypeUnknown 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" -> BenchmarkTypeExe ver
+ _ -> BenchmarkTypeUnknown 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).
+
+benchmarkType :: Benchmark -> BenchmarkType
+benchmarkType benchmark = case benchmarkInterface benchmark of
+ BenchmarkExeV10 ver _ -> BenchmarkTypeExe ver
+ BenchmarkUnsupported benchmarktype -> benchmarktype
+
+-- ---------------------------------------------------------------------------
-- The BuildInfo type
-- Consider refactoring into executable and library versions.
@@ -603,7 +736,8 @@ 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.
+-- all buildable executables, test suites and benchmarks. Useful for gathering
+-- dependencies.
allBuildInfo :: PackageDescription -> [BuildInfo]
allBuildInfo pkg_descr = [ bi | Just lib <- [library pkg_descr]
, let bi = libBuildInfo lib
@@ -615,6 +749,10 @@ allBuildInfo pkg_descr = [ bi | Just lib <- [library pkg_descr]
, let bi = testBuildInfo tst
, buildable bi
, testEnabled tst ]
+ ++ [ bi | tst <- benchmarks pkg_descr
+ , let bi = benchmarkBuildInfo tst
+ , buildable bi
+ , benchmarkEnabled tst ]
--FIXME: many of the places where this is used, we actually want to look at
-- unbuildable bits too, probably need separate functions
@@ -813,9 +951,10 @@ data GenericPackageDescription =
genPackageFlags :: [Flag],
condLibrary :: Maybe (CondTree ConfVar [Dependency] Library),
condExecutables :: [(String, CondTree ConfVar [Dependency] Executable)],
- condTestSuites :: [(String, CondTree ConfVar [Dependency] TestSuite)]
+ condTestSuites :: [(String, CondTree ConfVar [Dependency] TestSuite)],
+ condBenchmarks :: [(String, CondTree ConfVar [Dependency] Benchmark)]
}
- deriving (Show, Eq)
+ deriving (Show, Eq, Typeable)
instance Package GenericPackageDescription where
packageId = packageId . packageDescription
diff --git a/cabal/cabal/Distribution/PackageDescription/Check.hs b/cabal/Cabal/Distribution/PackageDescription/Check.hs
index a24346f..56afa83 100644
--- a/cabal/cabal/Distribution/PackageDescription/Check.hs
+++ b/cabal/Cabal/Distribution/PackageDescription/Check.hs
@@ -180,6 +180,7 @@ checkConfiguredPackage pkg =
++ checkSourceRepos pkg
++ checkGhcOptions pkg
++ checkCCOptions pkg
+ ++ checkCPPOptions pkg
++ checkPaths pkg
++ checkCabalVersion pkg
@@ -204,23 +205,17 @@ checkSanity 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
+ , check (not (null duplicateNames)) $
+ PackageBuildImpossible $ "Duplicate sections: " ++ commaSep duplicateNames
+ ++ ". The name of every executable, test suite, and benchmark section in"
+ ++ " the package must be unique."
]
--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)
+ ++ concatMap (checkBenchmark pkg) (benchmarks pkg)
++ catMaybes [
@@ -233,9 +228,8 @@ checkSanity pkg =
where
exeNames = map exeName $ executables pkg
testNames = map testName $ testSuites pkg
- exeDuplicates = dups exeNames
- testDuplicates = dups testNames
- testsThatAreExes = filter (flip elem exeNames) testNames
+ bmNames = map benchmarkName $ benchmarks pkg
+ duplicateNames = dups $ exeNames ++ testNames ++ bmNames
checkLibrary :: Library -> [PackageCheck]
checkLibrary lib =
@@ -300,11 +294,9 @@ checkTestSuite pkg test =
"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."
-
+ -- Test suites might be built as (internal) libraries named after
+ -- the test suite and thus their names must not clash with the
+ -- name of the package.
, check libNameClash $
PackageBuildImpossible $
"The test suite " ++ testName test
@@ -317,12 +309,57 @@ checkTestSuite pkg test =
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) ]
+checkBenchmark :: PackageDescription -> Benchmark -> [PackageCheck]
+checkBenchmark pkg bm =
+ catMaybes [
+
+ case benchmarkInterface bm of
+ BenchmarkUnsupported tt@(BenchmarkTypeUnknown _ _) -> Just $
+ PackageBuildWarning $
+ quote (display tt) ++ " is not a known type of benchmark. "
+ ++ "The known benchmark types are: "
+ ++ commaSep (map display knownBenchmarkTypes)
+
+ BenchmarkUnsupported tt -> Just $
+ PackageBuildWarning $
+ quote (display tt) ++ " is not a supported benchmark version. "
+ ++ "The known benchmark types are: "
+ ++ commaSep (map display knownBenchmarkTypes)
+ _ -> Nothing
+
+ , check (not $ null moduleDuplicates) $
+ PackageBuildWarning $
+ "Duplicate modules in benchmark '" ++ benchmarkName bm ++ "': "
+ ++ 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)."
+
+ -- See comment for similar check on test suites.
+ , check libNameClash $
+ PackageBuildImpossible $
+ "The benchmark " ++ benchmarkName bm
+ ++ " has the same name as the package."
+ ]
+ where
+ moduleDuplicates = dups $ benchmarkModules bm
+
+ mainIsWrongExt = case benchmarkInterface bm of
+ BenchmarkExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"]
+ _ -> False
+
+ libNameClash = benchmarkName bm `elem` [ libName
+ | _lib <- maybeToList (library pkg)
+ , let PackageName libName =
+ pkgName (package pkg) ]
+
-- ------------------------------------------------------------
-- * Additional pure checks
-- ------------------------------------------------------------
@@ -480,6 +517,9 @@ checkLicense pkg =
unknownLicenseVersion (LGPL (Just v))
| v `notElem` knownVersions = Just knownVersions
where knownVersions = [ v' | LGPL (Just v') <- knownLicenses ]
+ unknownLicenseVersion (Apache (Just v))
+ | v `notElem` knownVersions = Just knownVersions
+ where knownVersions = [ v' | Apache (Just v') <- knownLicenses ]
unknownLicenseVersion _ = Nothing
checkSourceRepos :: PackageDescription -> [PackageCheck]
@@ -546,6 +586,11 @@ checkGhcOptions pkg =
++ "is using the FFI incorrectly and will probably not work with GHC "
++ "6.10 or later."
+ , checkFlags ["-fdefer-type-errors"] $
+ PackageDistInexcusable $
+ "'ghc-options: -fdefer-type-errors' is fine during development but "
+ ++ "is not appropriate for a distributed package."
+
, checkFlags ["-fhpc"] $
PackageDistInexcusable $
"'ghc-options: -fhpc' is not appropriate for a distributed package."
@@ -716,6 +761,15 @@ checkCCOptions pkg =
checkCCFlags :: [String] -> PackageCheck -> Maybe PackageCheck
checkCCFlags flags = check (any (`elem` flags) all_ccOptions)
+checkCPPOptions :: PackageDescription -> [PackageCheck]
+checkCPPOptions pkg =
+ catMaybes [
+ checkAlternatives "cpp-options" "include-dirs"
+ [ (flag, dir) | flag@('-':'I':dir) <- all_cppOptions]
+ ]
+ where all_cppOptions = [ opts | bi <- allBuildInfo pkg
+ , opts <- cppOptions bi ]
+
checkAlternatives :: String -> String -> [(String, String)] -> Maybe PackageCheck
checkAlternatives badField goodField flags =
check (not (null badFlags)) $
@@ -827,7 +881,7 @@ checkCabalVersion 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"
+ ++ "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
diff --git a/cabal/cabal/Distribution/PackageDescription/Configuration.hs b/cabal/Cabal/Distribution/PackageDescription/Configuration.hs
index f3a657e..19d5fda 100644
--- a/cabal/cabal/Distribution/PackageDescription/Configuration.hs
+++ b/cabal/Cabal/Distribution/PackageDescription/Configuration.hs
@@ -68,7 +68,8 @@ import Distribution.PackageDescription
( GenericPackageDescription(..), PackageDescription(..)
, Library(..), Executable(..), BuildInfo(..)
, Flag(..), FlagName(..), FlagAssignment
- , CondTree(..), ConfVar(..), Condition(..), TestSuite(..) )
+ , Benchmark(..), CondTree(..), ConfVar(..), Condition(..)
+ , TestSuite(..) )
import Distribution.Version
( VersionRange, anyVersion, intersectVersionRanges, withinRange )
import Distribution.Compiler
@@ -399,12 +400,13 @@ newtype TargetSet a = TargetSet [(DependencyMap, a)]
overallDependencies :: TargetSet PDTagged -> DependencyMap
overallDependencies (TargetSet targets) = mconcat depss
where
- (depss, _) = unzip $ filter (removeDisabledTests . snd) targets
- removeDisabledTests :: PDTagged -> Bool
- removeDisabledTests (Lib _) = True
- removeDisabledTests (Exe _ _) = True
- removeDisabledTests (Test _ t) = testEnabled t
- removeDisabledTests PDNull = True
+ (depss, _) = unzip $ filter (removeDisabledSections . snd) targets
+ removeDisabledSections :: PDTagged -> Bool
+ removeDisabledSections (Lib _) = True
+ removeDisabledSections (Exe _ _) = True
+ removeDisabledSections (Test _ t) = testEnabled t
+ removeDisabledSections (Bench _ b) = benchmarkEnabled b
+ removeDisabledSections PDNull = True
-- Apply extra constraints to a dependency map.
-- Combines dependencies where the result will only contain keys from the left
@@ -425,32 +427,46 @@ constrainBy left extra =
-- | Collect up the targets in a TargetSet of tagged targets, storing the
-- dependencies as we go.
flattenTaggedTargets :: TargetSet PDTagged ->
- (Maybe Library, [(String, Executable)], [(String, TestSuite)])
-flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, [], []) targets
+ (Maybe Library, [(String, Executable)], [(String, TestSuite)]
+ , [(String, Benchmark)])
+flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, [], [], []) targets
where
- untag (_, Lib _) (Just _, _, _) = bug "Only one library expected"
- untag (deps, Lib l) (Nothing, exes, tests) = (Just l', exes, tests)
+ untag (_, Lib _) (Just _, _, _, _) = bug "Only one library expected"
+ untag (deps, Lib l) (Nothing, exes, tests, bms) =
+ (Just l', exes, tests, bms)
where
l' = l {
libBuildInfo = (libBuildInfo l) { targetBuildDepends = fromDepMap deps }
}
- untag (deps, Exe n e) (mlib, exes, tests)
+ untag (deps, Exe n e) (mlib, exes, tests, bms)
| any ((== n) . fst) exes = bug "Exe with same name found"
| any ((== n) . fst) tests = bug "Test sharing name of exe found"
- | otherwise = (mlib, exes ++ [(n, e')], tests)
+ | any ((== n) . fst) bms = bug "Benchmark sharing name of exe found"
+ | otherwise = (mlib, exes ++ [(n, e')], tests, bms)
where
e' = e {
buildInfo = (buildInfo e) { targetBuildDepends = fromDepMap deps }
}
- untag (deps, Test n t) (mlib, exes, tests)
+ untag (deps, Test n t) (mlib, exes, tests, bms)
| any ((== n) . fst) tests = bug "Test with same name found"
| any ((== n) . fst) exes = bug "Test sharing name of exe found"
- | otherwise = (mlib, exes, tests ++ [(n, t')])
+ | any ((== n) . fst) bms = bug "Test sharing name of benchmark found"
+ | otherwise = (mlib, exes, tests ++ [(n, t')], bms)
where
t' = t {
testBuildInfo = (testBuildInfo t)
{ targetBuildDepends = fromDepMap deps }
}
+ untag (deps, Bench n b) (mlib, exes, tests, bms)
+ | any ((== n) . fst) bms = bug "Benchmark with same name found"
+ | any ((== n) . fst) exes = bug "Benchmark sharing name of exe found"
+ | any ((== n) . fst) tests = bug "Benchmark sharing name of test found"
+ | otherwise = (mlib, exes, tests, bms ++ [(n, b')])
+ where
+ b' = b {
+ benchmarkBuildInfo = (benchmarkBuildInfo b)
+ { targetBuildDepends = fromDepMap deps }
+ }
untag (_, PDNull) x = x -- actually this should not happen, but let's be liberal
@@ -458,7 +474,12 @@ flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, [], []) targets
-- Convert GenericPackageDescription to PackageDescription
--
-data PDTagged = Lib Library | Exe String Executable | Test String TestSuite | PDNull deriving Show
+data PDTagged = Lib Library
+ | Exe String Executable
+ | Test String TestSuite
+ | Bench String Benchmark
+ | PDNull
+ deriving Show
instance Monoid PDTagged where
mempty = PDNull
@@ -467,6 +488,7 @@ instance Monoid PDTagged where
Lib l `mappend` Lib l' = Lib (l `mappend` l')
Exe n e `mappend` Exe n' e' | n == n' = Exe n (e `mappend` e')
Test n t `mappend` Test n' t' | n == n' = Test n (t `mappend` t')
+ Bench n b `mappend` Bench n' b' | n == n' = Bench n (b `mappend` b')
_ `mappend` _ = bug "Cannot combine incompatible tags"
-- | Create a package description with all configurations resolved.
@@ -503,12 +525,13 @@ finalizePackageDescription ::
-- ^ Either missing dependencies or the resolved package
-- description along with the flag assignments chosen.
finalizePackageDescription userflags satisfyDep (Platform arch os) impl constraints
- (GenericPackageDescription pkg flags mlib0 exes0 tests0) =
+ (GenericPackageDescription pkg flags mlib0 exes0 tests0 bms0) =
case resolveFlags of
- Right ((mlib, exes', tests'), targetSet, flagVals) ->
+ Right ((mlib, exes', tests', bms'), targetSet, flagVals) ->
Right ( pkg { library = mlib
, executables = exes'
, testSuites = tests'
+ , benchmarks = bms'
, buildDepends = fromDepMap (overallDependencies targetSet)
--TODO: we need to find a way to avoid pulling in deps
-- for non-buildable components. However cannot simply
@@ -523,14 +546,16 @@ finalizePackageDescription userflags satisfyDep (Platform arch os) impl constrai
condTrees = maybeToList (fmap (mapTreeData Lib) mlib0 )
++ map (\(name,tree) -> mapTreeData (Exe name) tree) exes0
++ map (\(name,tree) -> mapTreeData (Test name) tree) tests0
+ ++ map (\(name,tree) -> mapTreeData (Bench name) tree) bms0
resolveFlags =
case resolveWithFlags flagChoices os arch impl constraints condTrees check of
Right (targetSet, fs) ->
- let (mlib, exes, tests) = flattenTaggedTargets targetSet in
+ let (mlib, exes, tests, bms) = flattenTaggedTargets targetSet in
Right ( (fmap libFillInDefaults mlib,
map (\(n,e) -> (exeFillInDefaults e) { exeName = n }) exes,
- map (\(n,t) -> (testFillInDefaults t) { testName = n }) tests),
+ map (\(n,t) -> (testFillInDefaults t) { testName = n }) tests,
+ map (\(n,b) -> (benchFillInDefaults b) { benchmarkName = n }) bms),
targetSet, fs)
Left missing -> Left missing
@@ -569,11 +594,12 @@ resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribu
-- default path will be missing from the package description returned by this
-- function.
flattenPackageDescription :: GenericPackageDescription -> PackageDescription
-flattenPackageDescription (GenericPackageDescription pkg _ mlib0 exes0 tests0) =
+flattenPackageDescription (GenericPackageDescription pkg _ mlib0 exes0 tests0 bms0) =
pkg { library = mlib
, executables = reverse exes
, testSuites = reverse tests
- , buildDepends = ldeps ++ reverse edeps ++ reverse tdeps
+ , benchmarks = reverse bms
+ , buildDepends = ldeps ++ reverse edeps ++ reverse tdeps ++ reverse bdeps
}
where
(mlib, ldeps) = case mlib0 of
@@ -582,12 +608,16 @@ flattenPackageDescription (GenericPackageDescription pkg _ mlib0 exes0 tests0) =
Nothing -> (Nothing, [])
(exes, edeps) = foldr flattenExe ([],[]) exes0
(tests, tdeps) = foldr flattenTst ([],[]) tests0
+ (bms, bdeps) = foldr flattenBm ([],[]) bms0
flattenExe (n, t) (es, ds) =
let (e, ds') = ignoreConditions t in
( (exeFillInDefaults $ e { exeName = n }) : es, ds' ++ ds )
flattenTst (n, t) (es, ds) =
let (e, ds') = ignoreConditions t in
( (testFillInDefaults $ e { testName = n }) : es, ds' ++ ds )
+ flattenBm (n, t) (es, ds) =
+ let (e, ds') = ignoreConditions t in
+ ( (benchFillInDefaults $ e { benchmarkName = n }) : es, ds' ++ ds )
-- This is in fact rather a hack. The original version just overrode the
-- default values, however, when adding conditions we had to switch to a
@@ -608,6 +638,10 @@ testFillInDefaults :: TestSuite -> TestSuite
testFillInDefaults tst@(TestSuite { testBuildInfo = bi }) =
tst { testBuildInfo = biFillInDefaults bi }
+benchFillInDefaults :: Benchmark -> Benchmark
+benchFillInDefaults bm@(Benchmark { benchmarkBuildInfo = bi }) =
+ bm { benchmarkBuildInfo = biFillInDefaults bi }
+
biFillInDefaults :: BuildInfo -> BuildInfo
biFillInDefaults bi =
if null (hsSourceDirs bi)
diff --git a/cabal/cabal/Distribution/PackageDescription/Parse.hs b/cabal/Cabal/Distribution/PackageDescription/Parse.hs
index 087c309..fe85990 100644
--- a/cabal/cabal/Distribution/PackageDescription/Parse.hs
+++ b/cabal/Cabal/Distribution/PackageDescription/Parse.hs
@@ -74,12 +74,13 @@ import Data.Monoid ( Monoid(..) )
import Data.List (nub, unfoldr, partition, (\\))
import Control.Monad (liftM, foldM, when, unless)
import System.Directory (doesFileExist)
+import qualified Data.ByteString.Lazy.Char8 as BS.Char8
import Distribution.Text
( Text(disp, parse), display, simpleParse )
import Distribution.Compat.ReadP
((+++), option)
-import Text.PrettyPrint.HughesPJ
+import Text.PrettyPrint
import Distribution.ParseUtils hiding (parseFields)
import Distribution.PackageDescription
@@ -305,6 +306,80 @@ validateTestSuite line stanza =
-- ---------------------------------------------------------------------------
+-- The Benchmark type
+
+-- | An intermediate type just used for parsing the benchmark stanza.
+-- After validation it is converted into the proper 'Benchmark' type.
+data BenchmarkStanza = BenchmarkStanza {
+ benchmarkStanzaBenchmarkType :: Maybe BenchmarkType,
+ benchmarkStanzaMainIs :: Maybe FilePath,
+ benchmarkStanzaBenchmarkModule :: Maybe ModuleName,
+ benchmarkStanzaBuildInfo :: BuildInfo
+ }
+
+emptyBenchmarkStanza :: BenchmarkStanza
+emptyBenchmarkStanza = BenchmarkStanza Nothing Nothing Nothing mempty
+
+benchmarkFieldDescrs :: [FieldDescr BenchmarkStanza]
+benchmarkFieldDescrs =
+ [ simpleField "type"
+ (maybe empty disp) (fmap Just parse)
+ benchmarkStanzaBenchmarkType
+ (\x suite -> suite { benchmarkStanzaBenchmarkType = x })
+ , simpleField "main-is"
+ (maybe empty showFilePath) (fmap Just parseFilePathQ)
+ benchmarkStanzaMainIs
+ (\x suite -> suite { benchmarkStanzaMainIs = x })
+ ]
+ ++ map biToBenchmark binfoFieldDescrs
+ where
+ biToBenchmark = liftField benchmarkStanzaBuildInfo
+ (\bi suite -> suite { benchmarkStanzaBuildInfo = bi })
+
+storeXFieldsBenchmark :: UnrecFieldParser BenchmarkStanza
+storeXFieldsBenchmark (f@('x':'-':_), val)
+ t@(BenchmarkStanza { benchmarkStanzaBuildInfo = bi }) =
+ Just $ t {benchmarkStanzaBuildInfo =
+ bi{ customFieldsBI = (f,val):(customFieldsBI bi)}}
+storeXFieldsBenchmark _ _ = Nothing
+
+validateBenchmark :: LineNo -> BenchmarkStanza -> ParseResult Benchmark
+validateBenchmark line stanza =
+ case benchmarkStanzaBenchmarkType stanza of
+ Nothing -> return $
+ emptyBenchmark { benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza }
+
+ Just tt@(BenchmarkTypeUnknown _ _) ->
+ return emptyBenchmark {
+ benchmarkInterface = BenchmarkUnsupported tt,
+ benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza
+ }
+
+ Just tt | tt `notElem` knownBenchmarkTypes ->
+ return emptyBenchmark {
+ benchmarkInterface = BenchmarkUnsupported tt,
+ benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza
+ }
+
+ Just tt@(BenchmarkTypeExe ver) ->
+ case benchmarkStanzaMainIs stanza of
+ Nothing -> syntaxError line (missingField "main-is" tt)
+ Just file -> do
+ when (isJust (benchmarkStanzaBenchmarkModule stanza)) $
+ warning (extraField "benchmark-module" tt)
+ return emptyBenchmark {
+ benchmarkInterface = BenchmarkExeV10 ver file,
+ benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza
+ }
+
+ where
+ missingField name tt = "The '" ++ name ++ "' field is required for the "
+ ++ display tt ++ " benchmark type."
+
+ extraField name tt = "The '" ++ name ++ "' field is not used for the '"
+ ++ display tt ++ "' benchmark type."
+
+-- ---------------------------------------------------------------------------
-- The BuildInfo type
@@ -626,14 +701,14 @@ parsePackageDescription file = do
-- 'getBody' assumes that the remaining fields only consist of
-- flags, lib and exe sections.
- (repos, flags, mlib, exes, tests) <- getBody
+ (repos, flags, mlib, exes, tests, bms) <- getBody
warnIfRest -- warn if getBody did not parse up to the last field.
-- warn about using old/new syntax with wrong cabal-version:
maybeWarnCabalVersion (not $ oldSyntax fields0) pkg
checkForUndefinedFlags flags mlib exes tests
return $ GenericPackageDescription
pkg { sourceRepos = repos }
- flags mlib exes tests
+ flags mlib exes tests bms
where
oldSyntax flds = all isSimpleField flds
@@ -740,7 +815,8 @@ parsePackageDescription file = do
getBody :: PM ([SourceRepo], [Flag]
,Maybe (CondTree ConfVar [Dependency] Library)
,[(String, CondTree ConfVar [Dependency] Executable)]
- ,[(String, CondTree ConfVar [Dependency] TestSuite)])
+ ,[(String, CondTree ConfVar [Dependency] TestSuite)]
+ ,[(String, CondTree ConfVar [Dependency] Benchmark)])
getBody = peekField >>= \mf -> case mf of
Just (Section line_no sec_type sec_label sec_fields)
| sec_type == "executable" -> do
@@ -749,8 +825,8 @@ parsePackageDescription file = do
exename <- lift $ runP line_no "executable" parseTokenQ sec_label
flds <- collectFields parseExeFields sec_fields
skipField
- (repos, flags, lib, exes, tests) <- getBody
- return (repos, flags, lib, (exename, flds): exes, tests)
+ (repos, flags, lib, exes, tests, bms) <- getBody
+ return (repos, flags, lib, (exename, flds): exes, tests, bms)
| sec_type == "test-suite" -> do
when (null sec_label) $ lift $ syntaxError line_no
@@ -791,8 +867,8 @@ parsePackageDescription file = do
if checkTestType emptyTestSuite flds
then do
skipField
- (repos, flags, lib, exes, tests) <- getBody
- return (repos, flags, lib, exes, (testname, flds) : tests)
+ (repos, flags, lib, exes, tests, bms) <- getBody
+ return (repos, flags, lib, exes, (testname, flds) : tests, bms)
else lift $ syntaxError line_no $
"Test suite \"" ++ testname
++ "\" is missing required field \"type\" or the field "
@@ -800,15 +876,63 @@ parsePackageDescription file = do
++ "available test types are: "
++ intercalate ", " (map display knownTestTypes)
+ | sec_type == "benchmark" -> do
+ when (null sec_label) $ lift $ syntaxError line_no
+ "'benchmark' needs one argument (the benchmark's name)"
+ benchname <- lift $ runP line_no "benchmark" parseTokenQ sec_label
+ flds <- collectFields (parseBenchmarkFields line_no) sec_fields
+
+ -- Check that a valid benchmark type has been chosen. A type
+ -- field may be given inside a conditional block, so we must
+ -- check for that before complaining that a type field has not
+ -- been given. The benchmark must always have a valid type, so
+ -- we need to check both the 'then' and 'else' blocks, though
+ -- the blocks need not have the same type.
+ let checkBenchmarkType ts ct =
+ let ts' = mappend ts $ condTreeData ct
+ -- If a conditional has only a 'then' block and no
+ -- 'else' block, then it cannot have a valid type
+ -- in every branch, unless the type is specified at
+ -- a higher level in the tree.
+ checkComponent (_, _, Nothing) = False
+ -- If a conditional has a 'then' block and an 'else'
+ -- block, both must specify a benchmark type, unless the
+ -- type is specified higher in the tree.
+ checkComponent (_, t, Just e) =
+ checkBenchmarkType ts' t && checkBenchmarkType ts' e
+ -- Does the current node specify a benchmark type?
+ hasBenchmarkType = benchmarkInterface ts'
+ /= benchmarkInterface emptyBenchmark
+ components = condTreeComponents ct
+ -- If the current level of the tree specifies a type,
+ -- then we are done. If not, then one of the conditional
+ -- branches below the current node must specify a type.
+ -- Each node may have multiple immediate children; we
+ -- only one need one to specify a type because the
+ -- configure step uses 'mappend' to join together the
+ -- results of flag resolution.
+ in hasBenchmarkType || (any checkComponent components)
+ if checkBenchmarkType emptyBenchmark flds
+ then do
+ skipField
+ (repos, flags, lib, exes, tests, bms) <- getBody
+ return (repos, flags, lib, exes, tests, (benchname, flds) : bms)
+ else lift $ syntaxError line_no $
+ "Benchmark \"" ++ benchname
+ ++ "\" is missing required field \"type\" or the field "
+ ++ "is not present in all conditional branches. The "
+ ++ "available benchmark types are: "
+ ++ intercalate ", " (map display knownBenchmarkTypes)
+
| sec_type == "library" -> do
when (not (null sec_label)) $ lift $
syntaxError line_no "'library' expects no argument"
flds <- collectFields parseLibFields sec_fields
skipField
- (repos, flags, lib, exes, tests) <- getBody
+ (repos, flags, lib, exes, tests, bms) <- getBody
when (isJust lib) $ lift $ syntaxError line_no
"There can only be one library section in a package description."
- return (repos, flags, Just flds, exes, tests)
+ return (repos, flags, Just flds, exes, tests, bms)
| sec_type == "flag" -> do
when (null sec_label) $ lift $
@@ -819,8 +943,8 @@ parsePackageDescription file = do
(MkFlag (FlagName (lowercase sec_label)) "" True False)
sec_fields
skipField
- (repos, flags, lib, exes, tests) <- getBody
- return (repos, flag:flags, lib, exes, tests)
+ (repos, flags, lib, exes, tests, bms) <- getBody
+ return (repos, flag:flags, lib, exes, tests, bms)
| sec_type == "source-repository" -> do
when (null sec_label) $ lift $ syntaxError line_no $
@@ -844,8 +968,8 @@ parsePackageDescription file = do
})
sec_fields
skipField
- (repos, flags, lib, exes, tests) <- getBody
- return (repo:repos, flags, lib, exes, tests)
+ (repos, flags, lib, exes, tests, bms) <- getBody
+ return (repo:repos, flags, lib, exes, tests, bms)
| otherwise -> do
lift $ warning $ "Ignoring unknown section type: " ++ sec_type
@@ -856,7 +980,7 @@ parsePackageDescription file = do
"Construct not supported at this position: " ++ show f
skipField
getBody
- Nothing -> return ([], [], Nothing, [], [])
+ Nothing -> return ([], [], Nothing, [], [], [])
-- Extracts all fields in a block and returns a 'CondTree'.
--
@@ -904,6 +1028,12 @@ parsePackageDescription file = do
emptyTestStanza fields
lift $ validateTestSuite line x
+ parseBenchmarkFields :: LineNo -> [Field] -> PM Benchmark
+ parseBenchmarkFields line fields = do
+ x <- lift $ parseFields benchmarkFieldDescrs storeXFieldsBenchmark
+ emptyBenchmarkStanza fields
+ lift $ validateBenchmark line x
+
checkForUndefinedFlags ::
[Flag] ->
Maybe (CondTree ConfVar [Dependency] Library) ->
@@ -1039,7 +1169,8 @@ ppCustomField :: (String,String) -> Doc
ppCustomField (name,val) = text name <> colon <+> showFreeText val
writeHookedBuildInfo :: FilePath -> HookedBuildInfo -> IO ()
-writeHookedBuildInfo fpath = writeFileAtomic fpath . showHookedBuildInfo
+writeHookedBuildInfo fpath = writeFileAtomic fpath . BS.Char8.pack
+ . showHookedBuildInfo
showHookedBuildInfo :: HookedBuildInfo -> String
showHookedBuildInfo (mb_lib_bi, ex_bis) = render $
diff --git a/cabal/cabal/Distribution/PackageDescription/PrettyPrint.hs b/cabal/Cabal/Distribution/PackageDescription/PrettyPrint.hs
index b4b8d1d..b4b8d1d 100644
--- a/cabal/cabal/Distribution/PackageDescription/PrettyPrint.hs
+++ b/cabal/Cabal/Distribution/PackageDescription/PrettyPrint.hs
diff --git a/cabal/cabal/Distribution/ParseUtils.hs b/cabal/Cabal/Distribution/ParseUtils.hs
index 5145321..d390458 100644
--- a/cabal/cabal/Distribution/ParseUtils.hs
+++ b/cabal/Cabal/Distribution/ParseUtils.hs
@@ -81,7 +81,7 @@ import Distribution.Simple.Utils
import Language.Haskell.Extension
( Language, Extension )
-import Text.PrettyPrint.HughesPJ hiding (braces)
+import Text.PrettyPrint hiding (braces)
import Data.Char (isSpace, toLower, isAlphaNum, isDigit)
import Data.Maybe (fromMaybe)
import Data.Tree as Tree (Tree(..), flatten)
diff --git a/cabal/cabal/Distribution/ReadE.hs b/cabal/Cabal/Distribution/ReadE.hs
index ce165e2..ce165e2 100644
--- a/cabal/cabal/Distribution/ReadE.hs
+++ b/cabal/Cabal/Distribution/ReadE.hs
diff --git a/cabal/cabal/Distribution/Simple.hs b/cabal/Cabal/Distribution/Simple.hs
index 83ca516..fef0523 100644
--- a/cabal/cabal/Distribution/Simple.hs
+++ b/cabal/Cabal/Distribution/Simple.hs
@@ -112,6 +112,7 @@ import Distribution.Simple.Configure
, configure, checkForeignDeps )
import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) )
+import Distribution.Simple.Bench (bench)
import Distribution.Simple.BuildPaths ( srcPref)
import Distribution.Simple.Test (test)
import Distribution.Simple.Install (install)
@@ -206,6 +207,7 @@ defaultMainHelper hooks args = topHandler $
,registerCommand `commandAddAction` registerAction hooks
,unregisterCommand `commandAddAction` unregisterAction hooks
,testCommand `commandAddAction` testAction hooks
+ ,benchmarkCommand `commandAddAction` benchAction hooks
]
-- | Combine the preprocessors in the given hooks with the
@@ -360,6 +362,14 @@ testAction hooks flags args = do
(getBuildConfig hooks verbosity distPref)
hooks flags' args
+benchAction :: UserHooks -> BenchmarkFlags -> Args -> IO ()
+benchAction hooks flags args = do
+ let distPref = fromFlag $ benchmarkDistPref flags
+ verbosity = fromFlag $ benchmarkVerbosity flags
+ hookedActionWithArgs preBench benchHook postBench
+ (getBuildConfig hooks verbosity distPref)
+ hooks flags args
+
registerAction :: UserHooks -> RegisterFlags -> Args -> IO ()
registerAction hooks flags args
= do let distPref = fromFlag $ regDistPref flags
@@ -383,7 +393,17 @@ hookedAction :: (UserHooks -> Args -> flags -> IO HookedBuildInfo)
-> LocalBuildInfo -> IO ())
-> IO LocalBuildInfo
-> UserHooks -> flags -> Args -> IO ()
-hookedAction pre_hook cmd_hook post_hook get_build_config hooks flags args = do
+hookedAction pre_hook cmd_hook =
+ hookedActionWithArgs pre_hook (\h _ pd lbi uh flags -> cmd_hook h pd lbi uh flags)
+
+hookedActionWithArgs :: (UserHooks -> Args -> flags -> IO HookedBuildInfo)
+ -> (UserHooks -> Args -> PackageDescription -> LocalBuildInfo
+ -> UserHooks -> flags -> IO ())
+ -> (UserHooks -> Args -> flags -> PackageDescription
+ -> LocalBuildInfo -> IO ())
+ -> IO LocalBuildInfo
+ -> UserHooks -> flags -> Args -> IO ()
+hookedActionWithArgs pre_hook cmd_hook post_hook get_build_config hooks flags args = do
pbi <- pre_hook hooks args flags
localbuildinfo <- get_build_config
let pkg_descr0 = localPkgDescr localbuildinfo
@@ -392,7 +412,7 @@ hookedAction pre_hook cmd_hook post_hook get_build_config hooks flags args = do
let pkg_descr = updatePackageDescription pbi pkg_descr0
-- TODO: should we write the modified package descr back to the
-- localbuildinfo?
- cmd_hook hooks pkg_descr localbuildinfo hooks flags
+ cmd_hook hooks args pkg_descr localbuildinfo hooks flags
post_hook hooks args flags pkg_descr localbuildinfo
sanityCheckHookedBuildInfo :: PackageDescription -> HookedBuildInfo -> IO ()
@@ -499,6 +519,7 @@ simpleUserHooks =
buildHook = defaultBuildHook,
copyHook = \desc lbi _ f -> install desc lbi f, -- has correct 'copy' behavior with params
testHook = defaultTestHook,
+ benchHook = defaultBenchHook,
instHook = defaultInstallHook,
sDistHook = \p l h f -> sdist p l f srcPref (allSuffixHandlers h),
cleanHook = \p _ _ f -> clean p f,
@@ -645,6 +666,11 @@ defaultTestHook :: PackageDescription -> LocalBuildInfo
defaultTestHook pkg_descr localbuildinfo _ flags =
test pkg_descr localbuildinfo flags
+defaultBenchHook :: Args -> PackageDescription -> LocalBuildInfo
+ -> UserHooks -> BenchmarkFlags -> IO ()
+defaultBenchHook args pkg_descr localbuildinfo _ flags =
+ bench args pkg_descr localbuildinfo flags
+
defaultInstallHook :: PackageDescription -> LocalBuildInfo
-> UserHooks -> InstallFlags -> IO ()
defaultInstallHook pkg_descr localbuildinfo _ flags = do
diff --git a/cabal/Cabal/Distribution/Simple/Bench.hs b/cabal/Cabal/Distribution/Simple/Bench.hs
new file mode 100644
index 0000000..f34c888
--- /dev/null
+++ b/cabal/Cabal/Distribution/Simple/Bench.hs
@@ -0,0 +1,156 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Simple.Bench
+-- Copyright : Johan Tibell 2011
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Portability : portable
+--
+-- This is the entry point into running the benchmarks in a built
+-- package. It performs the \"@.\/setup bench@\" action. It runs
+-- benchmarks designated in the package description.
+
+{- 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.Simple.Bench
+ ( bench
+ ) where
+
+import qualified Distribution.PackageDescription as PD
+ ( PackageDescription(..), BuildInfo(buildable)
+ , Benchmark(..), BenchmarkInterface(..), benchmarkType, hasBenchmarks )
+import Distribution.Simple.BuildPaths ( exeExtension )
+import Distribution.Simple.Compiler ( Compiler(..) )
+import Distribution.Simple.InstallDirs
+ ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..)
+ , substPathTemplate , toPathTemplate, PathTemplate )
+import qualified Distribution.Simple.LocalBuildInfo as LBI
+ ( LocalBuildInfo(..) )
+import Distribution.Simple.Setup ( BenchmarkFlags(..), fromFlag )
+import Distribution.Simple.UserHooks ( Args )
+import Distribution.Simple.Utils ( die, notice, rawSystemExitCode )
+import Distribution.Text
+
+import Control.Monad ( when, unless )
+import System.Exit ( ExitCode(..), exitFailure, exitWith )
+import System.Directory ( doesFileExist )
+import System.FilePath ( (</>), (<.>) )
+
+-- | Perform the \"@.\/setup bench@\" action.
+bench :: Args -- ^positional command-line arguments
+ -> PD.PackageDescription -- ^information from the .cabal file
+ -> LBI.LocalBuildInfo -- ^information from the configure step
+ -> BenchmarkFlags -- ^flags sent to benchmark
+ -> IO ()
+bench args pkg_descr lbi flags = do
+ let verbosity = fromFlag $ benchmarkVerbosity flags
+ benchmarkNames = args
+ pkgBenchmarks = PD.benchmarks pkg_descr
+ enabledBenchmarks = [ t | t <- pkgBenchmarks
+ , PD.benchmarkEnabled t
+ , PD.buildable (PD.benchmarkBuildInfo t) ]
+
+ -- Run the benchmark
+ doBench :: PD.Benchmark -> IO ExitCode
+ doBench bm =
+ case PD.benchmarkInterface bm of
+ PD.BenchmarkExeV10 _ _ -> do
+ let cmd = LBI.buildDir lbi </> PD.benchmarkName bm
+ </> PD.benchmarkName bm <.> exeExtension
+ options = map (benchOption pkg_descr lbi bm) $
+ benchmarkOptions flags
+ name = PD.benchmarkName bm
+ -- Check that the benchmark executable exists.
+ exists <- doesFileExist cmd
+ unless exists $ die $
+ "Error: Could not find benchmark program \""
+ ++ cmd ++ "\". Did you build the package first?"
+
+ notice verbosity $ startMessage name
+ -- This will redirect the child process
+ -- stdout/stderr to the parent process.
+ exitcode <- rawSystemExitCode verbosity cmd options
+ notice verbosity $ finishMessage name exitcode
+ return exitcode
+
+ _ -> do
+ notice verbosity $ "No support for running "
+ ++ "benchmark " ++ PD.benchmarkName bm ++ " of type: "
+ ++ show (disp $ PD.benchmarkType bm)
+ exitFailure
+
+ when (not $ PD.hasBenchmarks pkg_descr) $ do
+ notice verbosity "Package has no benchmarks."
+ exitWith ExitSuccess
+
+ when (PD.hasBenchmarks pkg_descr && null enabledBenchmarks) $
+ die $ "No benchmarks enabled. Did you remember to configure with "
+ ++ "\'--enable-benchmarks\'?"
+
+ bmsToRun <- case benchmarkNames of
+ [] -> return enabledBenchmarks
+ names -> flip mapM names $ \bmName ->
+ let benchmarkMap = zip enabledNames enabledBenchmarks
+ enabledNames = map PD.benchmarkName enabledBenchmarks
+ allNames = map PD.benchmarkName pkgBenchmarks
+ in case lookup bmName benchmarkMap of
+ Just t -> return t
+ _ | bmName `elem` allNames ->
+ die $ "Package configured with benchmark "
+ ++ bmName ++ " disabled."
+ | otherwise -> die $ "no such benchmark: " ++ bmName
+
+ let totalBenchmarks = length bmsToRun
+ notice verbosity $ "Running " ++ show totalBenchmarks ++ " benchmarks..."
+ exitcodes <- mapM doBench bmsToRun
+ let allOk = totalBenchmarks == length (filter (== ExitSuccess) exitcodes)
+ unless allOk exitFailure
+ where
+ startMessage name = "Benchmark " ++ name ++ ": RUNNING...\n"
+ finishMessage name exitcode = "Benchmark " ++ name ++ ": "
+ ++ (case exitcode of
+ ExitSuccess -> "FINISH"
+ ExitFailure _ -> "ERROR")
+
+
+-- TODO: This is abusing the notion of a 'PathTemplate'. The result
+-- isn't neccesarily a path.
+benchOption :: PD.PackageDescription
+ -> LBI.LocalBuildInfo
+ -> PD.Benchmark
+ -> PathTemplate
+ -> String
+benchOption pkg_descr lbi bm template =
+ fromPathTemplate $ substPathTemplate env template
+ where
+ env = initialPathTemplateEnv
+ (PD.package pkg_descr) (compilerId $ LBI.compiler lbi) ++
+ [(BenchmarkNameVar, toPathTemplate $ PD.benchmarkName bm)]
diff --git a/cabal/cabal/Distribution/Simple/Build.hs b/cabal/Cabal/Distribution/Simple/Build.hs
index 33215b4..6fbcfb1 100644
--- a/cabal/cabal/Distribution/Simple/Build.hs
+++ b/cabal/Cabal/Distribution/Simple/Build.hs
@@ -64,12 +64,13 @@ import qualified Distribution.Simple.Build.PathsModule as Build.PathsModule
import Distribution.Package
( Package(..), PackageName(..), PackageIdentifier(..)
- , thisPackageVersion )
+ , Dependency(..), thisPackageVersion )
import Distribution.Simple.Compiler
( CompilerFlavor(..), compilerFlavor, PackageDB(..) )
import Distribution.PackageDescription
( PackageDescription(..), BuildInfo(..), Library(..), Executable(..)
- , TestSuite(..), TestSuiteInterface(..) )
+ , TestSuite(..), TestSuiteInterface(..), Benchmark(..)
+ , BenchmarkInterface(..) )
import qualified Distribution.InstalledPackageInfo as IPI
import qualified Distribution.ModuleName as ModuleName
@@ -78,11 +79,13 @@ import Distribution.Simple.Setup
import Distribution.Simple.PreProcess
( preprocessComponent, PPSuffixHandler )
import Distribution.Simple.LocalBuildInfo
- ( LocalBuildInfo(compiler, buildDir, withPackageDB)
+ ( LocalBuildInfo(compiler, buildDir, withPackageDB, withPrograms)
, Component(..), ComponentLocalBuildInfo(..), withComponentsLBI
- , inplacePackageId )
+ , componentBuildInfo, inplacePackageId )
+import Distribution.Simple.Program.Types
+import Distribution.Simple.Program.Db
import Distribution.Simple.BuildPaths
- ( autogenModulesDir, autogenModuleName, cppHeaderName )
+ ( autogenModulesDir, autogenModuleName, cppHeaderName, exeExtension )
import Distribution.Simple.Register
( registerPackage, inplaceInstalledPackageInfo )
import Distribution.Simple.Test ( stubFilePath, stubName )
@@ -97,6 +100,8 @@ import Distribution.Text
import Data.Maybe
( maybeToList )
+import Data.List
+ ( intersect )
import Control.Monad
( unless )
import System.FilePath
@@ -120,89 +125,143 @@ build pkg_descr lbi flags suffixes = do
internalPackageDB <- createInternalPackageDB distPref
- let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes
- lbi' = lbi {withPackageDB = withPackageDB lbi ++ [internalPackageDB]}
- -- Use the internal package DB for the exes.
- withComponentsLBI pkg_descr lbi $ \comp clbi -> do
- pre comp
- case comp of
- CLib lib -> do
- info verbosity "Building library..."
- buildLib verbosity pkg_descr lbi lib clbi
-
- -- Register the library in-place, so exes can depend
- -- on internally defined libraries.
- pwd <- getCurrentDirectory
- let installedPkgInfo =
- (inplaceInstalledPackageInfo pwd distPref pkg_descr lib lbi clbi) {
- -- The inplace registration uses the "-inplace" suffix,
- -- not an ABI hash.
- IPI.installedPackageId = inplacePackageId (packageId installedPkgInfo)
+ withComponentsLBI pkg_descr lbi $ \comp clbi ->
+ let bi = componentBuildInfo comp
+ progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi)
+ lbi' = lbi {
+ withPrograms = progs',
+ withPackageDB = withPackageDB lbi ++ [internalPackageDB]
+ }
+ in buildComponent verbosity pkg_descr lbi' suffixes comp clbi distPref
+
+
+buildComponent :: Verbosity
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> [PPSuffixHandler]
+ -> Component
+ -> ComponentLocalBuildInfo
+ -> FilePath
+ -> IO ()
+buildComponent verbosity pkg_descr lbi suffixes
+ comp@(CLib lib) clbi distPref = do
+ preprocessComponent pkg_descr comp lbi False verbosity suffixes
+ info verbosity "Building library..."
+ buildLib verbosity pkg_descr lbi lib clbi
+
+ -- Register the library in-place, so exes can depend
+ -- on internally defined libraries.
+ pwd <- getCurrentDirectory
+ let installedPkgInfo =
+ (inplaceInstalledPackageInfo pwd distPref pkg_descr lib lbi clbi) {
+ -- The inplace registration uses the "-inplace" suffix,
+ -- not an ABI hash.
+ IPI.installedPackageId = inplacePackageId (packageId installedPkgInfo)
+ }
+ registerPackage verbosity
+ installedPkgInfo pkg_descr lbi True -- True meaning inplace
+ (withPackageDB lbi)
+
+
+buildComponent verbosity pkg_descr lbi suffixes
+ comp@(CExe exe) clbi _ = do
+ preprocessComponent pkg_descr comp lbi False verbosity suffixes
+ info verbosity $ "Building executable " ++ exeName exe ++ "..."
+ buildExe verbosity pkg_descr lbi exe clbi
+
+
+buildComponent verbosity pkg_descr lbi suffixes
+ comp@(CTest
+ test@TestSuite { testInterface = TestSuiteExeV10 _ f })
+ clbi _distPref = do
+ let bi = testBuildInfo test
+ exe = Executable {
+ exeName = testName test,
+ modulePath = f,
+ buildInfo = bi
+ }
+ preprocessComponent pkg_descr comp lbi False verbosity suffixes
+ info verbosity $ "Building test suite " ++ testName test ++ "..."
+ buildExe verbosity pkg_descr lbi exe clbi
+
+
+buildComponent verbosity pkg_descr lbi suffixes
+ comp@(CTest
+ test@TestSuite { testInterface = TestSuiteLibV09 _ m })
+ clbi distPref = do
+ pwd <- getCurrentDirectory
+ let bi = testBuildInfo test
+ lib = Library {
+ exposedModules = [ m ],
+ libExposed = True,
+ libBuildInfo = bi
+ }
+ pkg = pkg_descr {
+ package = (package pkg_descr) {
+ pkgName = PackageName (testName test)
+ }
+ , buildDepends = targetBuildDepends $ testBuildInfo test
+ , executables = []
+ , testSuites = []
+ , library = Just lib
}
- registerPackage verbosity
- installedPkgInfo pkg_descr lbi True -- True meaning inplace
- (withPackageDB lbi ++ [internalPackageDB])
-
- CExe exe -> do
- info verbosity $ "Building executable " ++ exeName exe ++ "..."
- buildExe verbosity pkg_descr lbi' exe clbi
-
- CTest test -> do
- case testInterface test of
- TestSuiteExeV10 _ f -> do
- let exe = Executable
- { exeName = testName test
- , modulePath = f
- , buildInfo = testBuildInfo test
- }
- info verbosity $ "Building test suite " ++ testName test ++ "..."
- buildExe verbosity pkg_descr lbi' exe clbi
- TestSuiteLibV09 _ m -> do
- pwd <- getCurrentDirectory
- let lib = Library
- { exposedModules = [ m ]
- , libExposed = True
- , libBuildInfo = testBuildInfo test
- }
- pkg = pkg_descr
- { package = (package pkg_descr)
- { pkgName = PackageName $ testName test
- }
- , buildDepends = targetBuildDepends $ testBuildInfo test
- , executables = []
- , testSuites = []
- , library = Just lib
- }
- ipi = (inplaceInstalledPackageInfo
- pwd distPref pkg lib lbi clbi)
- { IPI.installedPackageId = inplacePackageId $ packageId ipi
- }
- testDir = buildDir lbi' </> stubName test
- </> stubName test ++ "-tmp"
- testLibDep = thisPackageVersion $ package pkg
- exe = Executable
- { exeName = stubName test
- , modulePath = stubFilePath test
- , buildInfo = (testBuildInfo test)
- { hsSourceDirs = [ testDir ]
- , targetBuildDepends = testLibDep
- : (targetBuildDepends $ testBuildInfo test)
- }
- }
- -- | The stub executable needs a new 'ComponentLocalBuildInfo'
- -- that exposes the relevant test suite library.
- exeClbi = clbi
- { componentPackageDeps =
- (IPI.installedPackageId ipi, packageId ipi)
- : (filter (\(_, x) -> let PackageName name = pkgName x in name == "Cabal" || name == "base")
- $ componentPackageDeps clbi)
- }
- info verbosity $ "Building test suite " ++ testName test ++ "..."
- buildLib verbosity pkg lbi' lib clbi
- registerPackage verbosity ipi pkg lbi' True $ withPackageDB lbi'
- buildExe verbosity pkg_descr lbi' exe exeClbi
- TestSuiteUnsupported tt -> die $ "No support for building test suite "
- ++ "type " ++ display tt
+ ipi = (inplaceInstalledPackageInfo pwd distPref pkg lib lbi clbi) {
+ IPI.installedPackageId = inplacePackageId $ packageId ipi
+ }
+ testDir = buildDir lbi </> stubName test
+ </> stubName test ++ "-tmp"
+ testLibDep = thisPackageVersion $ package pkg
+ exe = Executable {
+ exeName = stubName test,
+ modulePath = stubFilePath test,
+ buildInfo = (testBuildInfo test) {
+ hsSourceDirs = [ testDir ],
+ targetBuildDepends = testLibDep
+ : (targetBuildDepends $ testBuildInfo test)
+ }
+ }
+ -- | The stub executable needs a new 'ComponentLocalBuildInfo'
+ -- that exposes the relevant test suite library.
+ exeClbi = clbi {
+ componentPackageDeps =
+ (IPI.installedPackageId ipi, packageId ipi)
+ : (filter (\(_, x) -> let PackageName name = pkgName x
+ in name == "Cabal" || name == "base")
+ (componentPackageDeps clbi))
+ }
+ preprocessComponent pkg_descr comp lbi False verbosity suffixes
+ info verbosity $ "Building test suite " ++ testName test ++ "..."
+ buildLib verbosity pkg lbi lib clbi
+ registerPackage verbosity ipi pkg lbi True $ withPackageDB lbi
+ buildExe verbosity pkg_descr lbi exe exeClbi
+
+
+buildComponent _ _ _ _
+ (CTest TestSuite { testInterface = TestSuiteUnsupported tt })
+ _ _ =
+ die $ "No support for building test suite type " ++ display tt
+
+
+buildComponent verbosity pkg_descr lbi suffixes
+ comp@(CBench
+ bm@Benchmark { benchmarkInterface = BenchmarkExeV10 _ f })
+ clbi _ = do
+ let bi = benchmarkBuildInfo bm
+ exe = Executable
+ { exeName = benchmarkName bm
+ , modulePath = f
+ , buildInfo = bi
+ }
+ preprocessComponent pkg_descr comp lbi False verbosity suffixes
+ info verbosity $ "Building benchmark " ++ benchmarkName bm ++ "..."
+ buildExe verbosity pkg_descr lbi exe clbi
+
+
+buildComponent _ _ _ _
+ (CBench Benchmark { benchmarkInterface = BenchmarkUnsupported tt })
+ _ _ =
+ die $ "No support for building benchmark type " ++ display tt
+
-- | Initialize a new package db file for libraries defined
-- internally to the package.
@@ -213,6 +272,22 @@ createInternalPackageDB distPref = do
writeFile dbFile "[]"
return packageDB
+addInternalBuildTools :: PackageDescription -> LocalBuildInfo -> BuildInfo
+ -> ProgramDb -> ProgramDb
+addInternalBuildTools pkg lbi bi progs =
+ foldr updateProgram progs internalBuildTools
+ where
+ internalBuildTools =
+ [ simpleConfiguredProgram toolName (FoundOnSystem toolLocation)
+ | toolName <- toolNames
+ , let toolLocation = buildDir lbi </> toolName </> toolName <.> exeExtension ]
+ toolNames = intersect buildToolNames internalExeNames
+ internalExeNames = map exeName (executables pkg)
+ buildToolNames = map buildToolName (buildTools bi)
+ where
+ buildToolName (Dependency (PackageName name) _ ) = name
+
+
-- TODO: build separate libs in separate dirs so that we can build
-- multiple libs, e.g. for 'LibTest' library-style testsuites
buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo
diff --git a/cabal/cabal/Distribution/Simple/Build/Macros.hs b/cabal/Cabal/Distribution/Simple/Build/Macros.hs
index 58e2ed4..58e2ed4 100644
--- a/cabal/cabal/Distribution/Simple/Build/Macros.hs
+++ b/cabal/Cabal/Distribution/Simple/Build/Macros.hs
diff --git a/cabal/cabal/Distribution/Simple/Build/PathsModule.hs b/cabal/Cabal/Distribution/Simple/Build/PathsModule.hs
index 4a569c2..5980ba0 100644
--- a/cabal/cabal/Distribution/Simple/Build/PathsModule.hs
+++ b/cabal/Cabal/Distribution/Simple/Build/PathsModule.hs
@@ -19,7 +19,7 @@ module Distribution.Simple.Build.PathsModule (
) where
import Distribution.System
- ( OS(Windows), buildOS )
+ ( OS(Windows), buildOS, Arch(..), buildArch )
import Distribution.Simple.Compiler
( CompilerFlavor(..), compilerFlavor, compilerVersion )
import Distribution.Package
@@ -74,7 +74,8 @@ generate pkg_descr lbi =
foreign_imports++
"import qualified Control.Exception as Exception\n"++
"import Data.Version (Version(..))\n"++
- "import System.Environment (getEnv)"++
+ "import System.Environment (getEnv)\n"++
+ "import Prelude\n"++
"\n"++
"catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"++
"catchIO = Exception.catch\n" ++
@@ -167,7 +168,7 @@ generate pkg_descr lbi =
| isHugs = "progdirrel :: String\n"++
"progdirrel = "++show (fromJust flat_progdirrel)++"\n\n"++
get_prefix_hugs
- | otherwise = get_prefix_win32
+ | otherwise = get_prefix_win32 buildArch
path_sep = show [pathSeparator]
@@ -189,8 +190,8 @@ pkgPathEnvVar pkg_descr var =
fixchar '-' = '_'
fixchar c = c
-get_prefix_win32 :: String
-get_prefix_win32 =
+get_prefix_win32 :: Arch -> String
+get_prefix_win32 arch =
"getPrefixDirRel :: FilePath -> IO FilePath\n"++
"getPrefixDirRel dirRel = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.\n"++
" where\n"++
@@ -204,8 +205,11 @@ get_prefix_win32 =
" return ((bindir `minusFileName` bindirrel) `joinFileName` dirRel)\n"++
" | otherwise -> try_size (size * 2)\n"++
"\n"++
- "foreign import stdcall unsafe \"windows.h GetModuleFileNameW\"\n"++
+ "foreign import " ++ cconv ++ " unsafe \"windows.h GetModuleFileNameW\"\n"++
" c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n"
+ where cconv = case arch of
+ I386 -> "stdcall"
+ X86_64 -> "ccall"
get_prefix_hugs :: String
diff --git a/cabal/cabal/Distribution/Simple/BuildPaths.hs b/cabal/Cabal/Distribution/Simple/BuildPaths.hs
index 575545f..575545f 100644
--- a/cabal/cabal/Distribution/Simple/BuildPaths.hs
+++ b/cabal/Cabal/Distribution/Simple/BuildPaths.hs
diff --git a/cabal/cabal/Distribution/Simple/Command.hs b/cabal/Cabal/Distribution/Simple/Command.hs
index 48615e4..5a57a02 100644
--- a/cabal/cabal/Distribution/Simple/Command.hs
+++ b/cabal/Cabal/Distribution/Simple/Command.hs
@@ -55,6 +55,7 @@ module Distribution.Simple.Command (
-- ** Constructing commands
ShowOrParseArgs(..),
makeCommand,
+ hiddenCommand,
-- ** Associating actions with commands
Command,
@@ -94,7 +95,7 @@ import Distribution.Text
import Distribution.ParseUtils
import Distribution.ReadE
import Distribution.Simple.Utils (die, intercalate)
-import Text.PrettyPrint.HughesPJ ( punctuate, cat, comma, text, empty)
+import Text.PrettyPrint ( punctuate, cat, comma, text, empty)
data CommandUI flags = CommandUI {
-- | The name of the command as it would be entered on the command line.
@@ -113,7 +114,6 @@ data CommandUI flags = CommandUI {
}
data ShowOrParseArgs = ShowArgs | ParseArgs
-
type Name = String
type Description = String
@@ -270,9 +270,9 @@ viewAsFieldDescr (OptionField n dd) = FieldDescr n get set
Just f -> return (f a)
_ -> syntaxError line val
BoolOpt _ _ _ setV _ -> (`setV` a) `liftM` runP line n parse val
- OptArg _ _ _ _readE _ _ -> -- The behaviour in this case is not clear, and it has no use so far,
- -- so we avoid future surprises by not implementing it.
- error "Command.optionToFieldDescr: feature not implemented"
+ OptArg _ _ _ readE _ _ -> ($ a) `liftM` runE line n readE val
+ -- Optional arguments are parsed just like required arguments here;
+ -- we don't provide a method to set an OptArg field to the default value.
getChoiceByLongFlag :: OptDescr b -> String -> Maybe (b->b)
getChoiceByLongFlag (ChoiceOpt alts) val = listToMaybe [ set | (_,(_sf,lf:_), set, _) <- alts
@@ -449,7 +449,15 @@ instance Functor CommandParse where
fmap f (CommandReadyToGo flags) = CommandReadyToGo (f flags)
-data Command action = Command String String ([String] -> CommandParse action)
+data CommandType = NormalCommand | HiddenCommand
+data Command action =
+ Command String String ([String] -> CommandParse action) CommandType
+
+-- | Mark command as hidden. Hidden commands don't show up in the 'progname
+-- help' or 'progname --help' output.
+hiddenCommand :: Command action -> Command action
+hiddenCommand (Command name synopsys f _cmdType) =
+ Command name synopsys f HiddenCommand
commandAddAction :: CommandUI flags
-> (flags -> [String] -> action)
@@ -457,8 +465,8 @@ commandAddAction :: CommandUI flags
commandAddAction command action =
Command (commandName command)
(commandSynopsis command)
- (fmap (uncurry applyDefaultArgs)
- . commandParseArgs command False)
+ (fmap (uncurry applyDefaultArgs) . commandParseArgs command False)
+ NormalCommand
where applyDefaultArgs mkflags args =
let flags = mkflags (commandDefaultFlags command)
@@ -475,20 +483,21 @@ commandsRun globalCommand commands args =
CommandErrors errs -> CommandErrors errs
CommandReadyToGo (mkflags, args') -> case args' of
("help":cmdArgs) -> handleHelpCommand cmdArgs
- (name:cmdArgs) -> case lookupCommand name of
- [Command _ _ action] -> CommandReadyToGo (flags, action cmdArgs)
- _ -> CommandReadyToGo (flags, badCommand name)
- [] -> CommandReadyToGo (flags, noCommand)
+ (name:cmdArgs) -> case lookupCommand name of
+ [Command _ _ action _]
+ -> CommandReadyToGo (flags, action cmdArgs)
+ _ -> CommandReadyToGo (flags, badCommand name)
+ [] -> CommandReadyToGo (flags, noCommand)
where flags = mkflags (commandDefaultFlags globalCommand)
where
- lookupCommand cname = [ cmd | cmd@(Command cname' _ _) <- commands'
- , cname'==cname ]
+ lookupCommand cname = [ cmd | cmd@(Command cname' _ _ _) <- commands'
+ , cname' == cname ]
noCommand = CommandErrors ["no command given (try --help)\n"]
badCommand cname = CommandErrors ["unrecognised command: " ++ cname
++ " (try --help)\n"]
commands' = commands ++ [commandAddAction helpCommandUI undefined]
- commandNames = [ name | Command name _ _ <- commands' ]
+ commandNames = [ name | (Command name _ _ _) <- commands' ]
globalCommand' = globalCommand {
commandUsage = \pname ->
(case commandUsage globalCommand pname of
@@ -500,12 +509,13 @@ commandsRun globalCommand commands args =
commandDescription = Just $ \pname ->
"Commands:\n"
++ unlines [ " " ++ align name ++ " " ++ description
- | Command name description _ <- commands' ]
+ | Command name description _ NormalCommand <- commands' ]
++ case commandDescription globalCommand of
Nothing -> ""
Just desc -> '\n': desc pname
}
- where maxlen = maximum [ length name | Command name _ _ <- commands' ]
+ where maxlen = maximum
+ [ length name | Command name _ _ NormalCommand <- commands' ]
align str = str ++ replicate (maxlen - length str) ' '
-- A bit of a hack: support "prog help" as a synonym of "prog --help"
@@ -518,7 +528,7 @@ commandsRun globalCommand commands args =
CommandReadyToGo (_,[]) -> CommandHelp globalHelp
CommandReadyToGo (_,(name:cmdArgs')) ->
case lookupCommand name of
- [Command _ _ action] ->
+ [Command _ _ action _] ->
case action ("--help":cmdArgs') of
CommandHelp help -> CommandHelp help
CommandList _ -> CommandList []
diff --git a/cabal/cabal/Distribution/Simple/Compiler.hs b/cabal/Cabal/Distribution/Simple/Compiler.hs
index 09a9cf9..09a9cf9 100644
--- a/cabal/cabal/Distribution/Simple/Compiler.hs
+++ b/cabal/Cabal/Distribution/Simple/Compiler.hs
diff --git a/cabal/cabal/Distribution/Simple/Configure.hs b/cabal/Cabal/Distribution/Simple/Configure.hs
index bf9e965..e92887b 100644
--- a/cabal/cabal/Distribution/Simple/Configure.hs
+++ b/cabal/Cabal/Distribution/Simple/Configure.hs
@@ -61,6 +61,7 @@ module Distribution.Simple.Configure (configure,
ccLdOptionsBuildInfo,
tryGetConfigStateFile,
checkForeignDeps,
+ interpretPackageDbFlags,
)
where
@@ -82,7 +83,7 @@ import Distribution.PackageDescription as PD
( PackageDescription(..), specVersion, GenericPackageDescription(..)
, Library(..), hasLibs, Executable(..), BuildInfo(..), allExtensions
, HookedBuildInfo, updatePackageDescription, allBuildInfo
- , FlagName(..), TestSuite(..) )
+ , FlagName(..), TestSuite(..), Benchmark(..) )
import Distribution.PackageDescription.Configuration
( finalizePackageDescription, mapTreeData )
import Distribution.PackageDescription.Check
@@ -91,7 +92,7 @@ import Distribution.Simple.Hpc ( enableCoverage )
import Distribution.Simple.Program
( Program(..), ProgramLocation(..), ConfiguredProgram(..)
, ProgramConfiguration, defaultProgramConfiguration
- , configureAllKnownPrograms, knownPrograms, lookupKnownProgram, addKnownProgram
+ , configureAllKnownPrograms, knownPrograms, lookupKnownProgram
, userSpecifyArgss, userSpecifyPaths
, requireProgram, requireProgramVersion
, pkgConfigProgram, gccProgram, rawSystemProgramStdoutConf )
@@ -111,7 +112,7 @@ import Distribution.Simple.Utils
, withFileContents, writeFileAtomic
, withTempFile )
import Distribution.System
- ( OS(..), buildOS, buildPlatform )
+ ( OS(..), buildOS, Arch(..), buildArch, buildPlatform )
import Distribution.Version
( Version(..), anyVersion, orLaterVersion, withinRange, isAnyVersion )
import Distribution.Verbosity
@@ -146,11 +147,11 @@ import System.IO
( hPutStrLn, stderr, hClose )
import Distribution.Text
( Text(disp), display, simpleParse )
-import Text.PrettyPrint.HughesPJ
+import Text.PrettyPrint
( comma, punctuate, render, nest, sep )
import Distribution.Compat.Exception ( catchExit, catchIO )
-import Prelude hiding (catch)
+import qualified Data.ByteString.Lazy.Char8 as BS.Char8
tryGetConfigStateFile :: (Read a) => FilePath -> IO (Either String a)
tryGetConfigStateFile filename = do
@@ -215,7 +216,7 @@ writePersistBuildConfig :: FilePath -> LocalBuildInfo -> IO ()
writePersistBuildConfig distPref lbi = do
createDirectoryIfMissing False distPref
writeFileAtomic (localBuildInfoFile distPref)
- (showHeader pkgid ++ '\n' : show lbi)
+ (BS.Char8.pack $ showHeader pkgid ++ '\n' : show lbi)
where
pkgid = packageId (localPkgDescr lbi)
@@ -279,8 +280,8 @@ configure (pkg_descr0, pbi) cfg
. userSpecifyPaths (configProgramPaths cfg)
$ configPrograms cfg
userInstall = fromFlag (configUserInstall cfg)
- packageDbs = implicitPackageDbStack userInstall
- (flagToMaybe $ configPackageDB cfg)
+ packageDbs = interpretPackageDbFlags userInstall
+ (configPackageDBs cfg)
-- detect compiler
(comp, programsConfig') <- configCompiler
@@ -326,7 +327,11 @@ configure (pkg_descr0, pbi) cfg
enableTest t = t { testEnabled = fromFlag (configTests cfg) }
flaggedTests = map (\(n, t) -> (n, mapTreeData enableTest t))
(condTestSuites pkg_descr0)
- pkg_descr0'' = pkg_descr0 { condTestSuites = flaggedTests }
+ enableBenchmark bm = bm { benchmarkEnabled = fromFlag (configBenchmarks cfg) }
+ flaggedBenchmarks = map (\(n, bm) -> (n, mapTreeData enableBenchmark bm))
+ (condBenchmarks pkg_descr0)
+ pkg_descr0'' = pkg_descr0 { condTestSuites = flaggedTests
+ , condBenchmarks = flaggedBenchmarks }
(pkg_descr0', flags) <-
case finalizePackageDescription
@@ -429,21 +434,26 @@ configure (pkg_descr0, pbi) cfg
++ "supported by " ++ display (compilerId comp) ++ ": "
++ intercalate ", " (map display exts)
- -- configured known/required programs & build tools
- let requiredBuildTools = concatMap buildTools (allBuildInfo pkg_descr)
-
- -- add all exes built by this package ("internal exes") to the program
- -- conf; this makes the namespace of build-tools include intrapackage
- -- references to executables
- let programsConfig'' = foldr (addInternalExe buildDir') programsConfig'
- (executables pkg_descr)
-
- programsConfig''' <-
- configureAllKnownPrograms (lessVerbose verbosity) programsConfig''
+ -- configured known/required programs & external build tools
+ -- exclude build-tool deps on "internal" exes in the same package
+ let requiredBuildTools =
+ [ buildTool
+ | let exeNames = map exeName (executables pkg_descr)
+ , bi <- allBuildInfo pkg_descr
+ , buildTool@(Dependency (PackageName toolName) reqVer) <- buildTools bi
+ , let isInternal =
+ toolName `elem` exeNames
+ -- we assume all internal build-tools are
+ -- versioned with the package:
+ && packageVersion pkg_descr `withinRange` reqVer
+ , not isInternal ]
+
+ programsConfig'' <-
+ configureAllKnownPrograms (lessVerbose verbosity) programsConfig'
>>= configureRequiredPrograms verbosity requiredBuildTools
- (pkg_descr', programsConfig'''') <-
- configurePkgconfigPackages verbosity pkg_descr programsConfig'''
+ (pkg_descr', programsConfig''') <-
+ configurePkgconfigPackages verbosity pkg_descr programsConfig''
split_objs <-
if not (fromFlag $ configSplitObjs cfg)
@@ -464,6 +474,8 @@ configure (pkg_descr0, pbi) cfg
configExe exe = (exeName exe, configComponent (buildInfo exe))
configTest test = (testName test,
configComponent(testBuildInfo test))
+ configBenchmark bm = (benchmarkName bm,
+ configComponent(benchmarkBuildInfo bm))
configComponent bi = ComponentLocalBuildInfo {
componentPackageDeps =
if newPackageDepsBehaviour pkg_descr'
@@ -485,7 +497,8 @@ configure (pkg_descr0, pbi) cfg
mapMaybe exeDepToComp (buildTools bi)
++ mapMaybe libDepToComp (targetBuildDepends bi)
where
- bi = foldComponent libBuildInfo buildInfo testBuildInfo component
+ bi = foldComponent libBuildInfo buildInfo testBuildInfo
+ benchmarkBuildInfo component
exeDepToComp (Dependency (PackageName name) _) =
CExe `fmap` find ((==) name . exeName)
(executables pkg_descr')
@@ -498,13 +511,15 @@ configure (pkg_descr0, pbi) cfg
where (g, lkup, _) = graphFromEdges
$ allComponentsBy pkg_descr'
$ \c -> (c, key c, map key (ipDeps c))
- key = foldComponent (const "library") exeName testName
+ key = foldComponent (const "library") exeName
+ testName benchmarkName
-- check for cycles in the dependency graph
buildOrder <- forM sccs $ \scc -> case scc of
AcyclicSCC (c,_,_) -> return (foldComponent (const CLibName)
(CExeName . exeName)
(CTestName . testName)
+ (CBenchName . benchmarkName)
c)
CyclicSCC vs ->
die $ "Found cycle in intrapackage dependency graph:\n "
@@ -525,11 +540,12 @@ configure (pkg_descr0, pbi) cfg
libraryConfig = configLib `fmap` library pkg_descr',
executableConfigs = configExe `fmap` executables pkg_descr',
testSuiteConfigs = configTest `fmap` testSuites pkg_descr',
+ benchmarkConfigs = configBenchmark `fmap` benchmarks pkg_descr',
compBuildOrder = buildOrder,
installedPkgs = packageDependsIndex,
pkgDescrFile = Nothing,
localPkgDescr = pkg_descr',
- withPrograms = programsConfig'''',
+ withPrograms = programsConfig''',
withVanillaLib = fromFlag $ configVanillaLib cfg,
withProfLib = fromFlag $ configProfLib cfg,
withSharedLib = fromFlag $ configSharedLib cfg,
@@ -570,20 +586,11 @@ configure (pkg_descr0, pbi) cfg
dirinfo "Documentation" (docdir dirs) (docdir relative)
sequence_ [ reportProgram verbosity prog configuredProg
- | (prog, configuredProg) <- knownPrograms programsConfig'''' ]
+ | (prog, configuredProg) <- knownPrograms programsConfig''' ]
return lbi
where
- addInternalExe bd exe =
- let nm = exeName exe in
- addKnownProgram Program {
- programName = nm,
- programFindLocation = \_ -> return $ Just $ bd </> nm </> nm,
- programFindVersion = \_ _ -> return Nothing,
- programPostConf = \_ _ -> return []
- }
-
addExtraIncludeLibDirs pkg_descr =
let extraBi = mempty { extraLibDirs = configExtraLibDirs cfg
, PD.includeDirs = configExtraIncludeDirs cfg}
@@ -677,6 +684,11 @@ getInstalledPackages :: Verbosity -> Compiler
-> PackageDBStack -> ProgramConfiguration
-> IO PackageIndex
getInstalledPackages verbosity comp packageDBs progconf = do
+ when (null packageDBs) $
+ die $ "No package databases have been specified. If you use "
+ ++ "--package-db=clear, you must follow it with --package-db= "
+ ++ "with 'global', 'user' or a specific file."
+
info verbosity "Reading installed packages..."
case compilerFlavor comp of
GHC -> GHC.getInstalledPackages verbosity packageDBs progconf
@@ -688,19 +700,21 @@ getInstalledPackages verbosity comp packageDBs progconf = do
flv -> die $ "don't know how to find the installed packages for "
++ display flv
--- | Currently the user interface specifies the package dbs to use with just a
--- single valued option, a 'PackageDB'. However internally we represent the
--- stack of 'PackageDB's explictly as a list. This function converts encodes
--- the package db stack implicit in a single packagedb.
+-- | The user interface specifies the package dbs to use with a combination of
+-- @--global@, @--user@ and @--package-db=global|user|clear|$file@.
+-- This function combines the global/user flag and interprets the package-db
+-- flag into a single package db stack.
--
-implicitPackageDbStack :: Bool -> Maybe PackageDB -> PackageDBStack
-implicitPackageDbStack userInstall maybePackageDB
- | userInstall = GlobalPackageDB : UserPackageDB : extra
- | otherwise = GlobalPackageDB : extra
+interpretPackageDbFlags :: Bool -> [Maybe PackageDB] -> PackageDBStack
+interpretPackageDbFlags userInstall specificDBs =
+ extra initialStack specificDBs
where
- extra = case maybePackageDB of
- Just (SpecificPackageDB db) -> [SpecificPackageDB db]
- _ -> []
+ initialStack | userInstall = [GlobalPackageDB, UserPackageDB]
+ | otherwise = [GlobalPackageDB]
+
+ extra dbs' [] = dbs'
+ extra _ (Nothing:dbs) = extra [] dbs
+ extra dbs' (Just db:dbs) = extra (dbs' ++ [db]) dbs
newPackageDepsBehaviourMinVersion :: Version
newPackageDepsBehaviourMinVersion = Version { versionBranch = [1,7,1], versionTags = [] }
@@ -997,7 +1011,40 @@ checkForeignDeps pkg lbi verbosity = do
hcDefines :: Compiler -> [String]
hcDefines comp =
case compilerFlavor comp of
- GHC -> ["-D__GLASGOW_HASKELL__=" ++ versionInt version]
+ GHC ->
+ let ghcOS = case buildOS of
+ Linux -> ["linux"]
+ Windows -> ["mingw32"]
+ OSX -> ["darwin"]
+ FreeBSD -> ["freebsd"]
+ OpenBSD -> ["openbsd"]
+ NetBSD -> ["netbsd"]
+ Solaris -> ["solaris2"]
+ AIX -> ["aix"]
+ HPUX -> ["hpux"]
+ IRIX -> ["irix"]
+ HaLVM -> []
+ OtherOS _ -> []
+ ghcArch = case buildArch of
+ I386 -> ["i386"]
+ X86_64 -> ["x86_64"]
+ PPC -> ["powerpc"]
+ PPC64 -> ["powerpc64"]
+ Sparc -> ["sparc"]
+ Arm -> ["arm"]
+ Mips -> ["mips"]
+ SH -> []
+ IA64 -> ["ia64"]
+ S390 -> ["s390"]
+ Alpha -> ["alpha"]
+ Hppa -> ["hppa"]
+ Rs6000 -> ["rs6000"]
+ M68k -> ["m68k"]
+ Vax -> ["vax"]
+ OtherArch _ -> []
+ in ["-D__GLASGOW_HASKELL__=" ++ versionInt version] ++
+ map (\os -> "-D" ++ os ++ "_HOST_OS=1") ghcOS ++
+ map (\arch -> "-D" ++ arch ++ "_HOST_ARCH=1") ghcArch
JHC -> ["-D__JHC__=" ++ versionInt version]
NHC -> ["-D__NHC__=" ++ versionInt version]
Hugs -> ["-D__HUGS__"]
diff --git a/cabal/cabal/Distribution/Simple/GHC.hs b/cabal/Cabal/Distribution/Simple/GHC.hs
index 5d8f46d..33fdfb6 100644
--- a/cabal/cabal/Distribution/Simple/GHC.hs
+++ b/cabal/Cabal/Distribution/Simple/GHC.hs
@@ -65,11 +65,14 @@ module Distribution.Simple.GHC (
buildLib, buildExe,
installLib, installExe,
libAbiHash,
+ initPackageDB,
registerPackage,
- ghcOptions,
+ componentGhcOptions,
+ ghcLibDir,
+
+ -- * Deprecated
ghcVerbosityOptions,
ghcPackageDbOptions,
- ghcLibDir,
) where
import qualified Distribution.Simple.GHC.IPI641 as IPI641
@@ -94,8 +97,9 @@ import Distribution.Package
import qualified Distribution.ModuleName as ModuleName
import Distribution.Simple.Program
( Program(..), ConfiguredProgram(..), ProgramConfiguration, ProgArg
- , ProgramLocation(..), rawSystemProgram, rawSystemProgramConf
+ , ProgramLocation(..), rawSystemProgram
, rawSystemProgramStdout, rawSystemProgramStdoutConf
+ , getProgramInvocationOutput
, requireProgramVersion, requireProgram, getProgramOutput
, userMaybeSpecifyPath, programPath, lookupProgram, addKnownProgram
, ghcProgram, ghcPkgProgram, hsc2hsProgram
@@ -104,10 +108,12 @@ import Distribution.Simple.Program
import qualified Distribution.Simple.Program.HcPkg as HcPkg
import qualified Distribution.Simple.Program.Ar as Ar
import qualified Distribution.Simple.Program.Ld as Ld
+import Distribution.Simple.Program.GHC
+import Distribution.Simple.Setup (toFlag, fromFlag)
import Distribution.Simple.Compiler
( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion
, OptimisationLevel(..), PackageDB(..), PackageDBStack
- , Flag, languageToFlags, extensionsToFlags )
+ , Flag )
import Distribution.Version
( Version(..), anyVersion, orLaterVersion )
import Distribution.System
@@ -120,7 +126,7 @@ import Language.Haskell.Extension (Language(..), Extension(..), KnownExtension(.
import Control.Monad ( unless, when, liftM )
import Data.Char ( isSpace )
import Data.List
-import Data.Maybe ( catMaybes )
+import Data.Maybe ( catMaybes, fromMaybe )
import Data.Monoid ( Monoid(..) )
import System.Directory
( removeFile, getDirectoryContents, doesFileExist
@@ -128,6 +134,7 @@ import System.Directory
import System.FilePath ( (</>), (<.>), takeExtension,
takeDirectory, replaceExtension, splitExtension )
import System.IO (hClose, hPutStrLn)
+import System.Environment (getEnv)
import Distribution.Compat.Exception (catchExit, catchIO)
-- -----------------------------------------------------------------------------
@@ -251,23 +258,29 @@ configureToolchain ghcProg ghcInfo =
addKnownProgram gccProgram {
programFindLocation = findProg gccProgram
[ if ghcVersion >= Version [6,12] []
- then mingwBinDir </> "gcc.exe"
+ then mingwBinDir </> binPrefix ++ "gcc.exe"
else baseDir </> "gcc.exe" ],
programPostConf = configureGcc
}
. addKnownProgram ldProgram {
programFindLocation = findProg ldProgram
[ if ghcVersion >= Version [6,12] []
- then mingwBinDir </> "ld.exe"
+ then mingwBinDir </> binPrefix ++ "ld.exe"
else libDir </> "ld.exe" ],
programPostConf = configureLd
}
. addKnownProgram arProgram {
programFindLocation = findProg arProgram
[ if ghcVersion >= Version [6,12] []
- then mingwBinDir </> "ar.exe"
+ then mingwBinDir </> binPrefix ++ "ar.exe"
else libDir </> "ar.exe" ]
}
+ . addKnownProgram stripProgram {
+ programFindLocation = findProg stripProgram
+ [ if ghcVersion >= Version [6,12] []
+ then mingwBinDir </> binPrefix ++ "strip.exe"
+ else libDir </> "strip.exe" ]
+ }
where
Just ghcVersion = programVersion ghcProg
compilerDir = takeDirectory (programPath ghcProg)
@@ -276,6 +289,7 @@ configureToolchain ghcProg ghcInfo =
libDir = baseDir </> "gcc-lib"
includeDir = baseDir </> "include" </> "mingw"
isWindows = case buildOS of Windows -> True; _ -> False
+ binPrefix = ""
-- on Windows finding and configuring ghc's gcc and ld is a bit special
findProg :: Program -> [FilePath] -> Verbosity -> IO (Maybe FilePath)
@@ -457,6 +471,7 @@ oldLanguageExtensions =
getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration
-> IO PackageIndex
getInstalledPackages verbosity packagedbs conf = do
+ checkPackageDbEnvVar
checkPackageDbStack packagedbs
pkgss <- getInstalledPackages' verbosity packagedbs conf
topDir <- ghcLibDir' verbosity ghcProg
@@ -487,11 +502,29 @@ ghcLibDir' verbosity ghcProg =
(reverse . dropWhile isSpace . reverse) `fmap`
rawSystemProgramStdout verbosity ghcProg ["--print-libdir"]
+-- Cabal does not use the environment variable GHC_PACKAGE_PATH; let users
+-- know that this is the case. See ticket #335. Simply ignoring it is not a
+-- good idea, since then ghc and cabal are looking at different sets of
+-- package dbs and chaos is likely to ensue.
+checkPackageDbEnvVar :: IO ()
+checkPackageDbEnvVar = do
+ hasGPP <- (getEnv "GHC_PACKAGE_PATH" >> return True)
+ `catchIO` (\_ -> return False)
+ when hasGPP $
+ die $ "Use of GHC's environment variable GHC_PACKAGE_PATH is "
+ ++ "incompatible with Cabal. Use the flag --package-db to specify a "
+ ++ "package database (it can be used multiple times)."
+
checkPackageDbStack :: PackageDBStack -> IO ()
checkPackageDbStack (GlobalPackageDB:rest)
| GlobalPackageDB `notElem` rest = return ()
+checkPackageDbStack rest
+ | GlobalPackageDB `notElem` rest =
+ die $ "With current ghc versions the global package db is always used "
+ ++ "and must be listed first. This ghc limitation may be lifted in "
+ ++ "future, see http://hackage.haskell.org/trac/ghc/ticket/5977"
checkPackageDbStack _ =
- die $ "GHC.getInstalledPackages: the global package db must be "
+ die $ "If the global package db is specified, it must be "
++ "specified first and cannot be specified multiple times"
-- GHC < 6.10 put "$topdir/include/mingw" in rts's installDirs. This
@@ -579,12 +612,15 @@ buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo
buildLib verbosity pkg_descr lbi lib clbi = do
let pref = buildDir lbi
pkgid = packageId pkg_descr
- runGhcProg = rawSystemProgramConf verbosity ghcProgram (withPrograms lbi)
ifVanillaLib forceVanilla = when (forceVanilla || withVanillaLib lbi)
ifProfLib = when (withProfLib lbi)
ifSharedLib = when (withSharedLib lbi)
ifGHCiLib = when (withGHCiLib lbi && withVanillaLib lbi)
comp = compiler lbi
+ ghcVersion = compilerVersion comp
+
+ (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi)
+ let runGhcProg = runGHC verbosity ghcProg
libBi <- hackThreadedFlag verbosity
comp (withProfLib lbi) (libBuildInfo lib)
@@ -595,39 +631,51 @@ buildLib verbosity pkg_descr lbi lib clbi = do
createDirectoryIfMissingVerbose verbosity True libTargetDir
-- TODO: do we need to put hs-boot files into place for mutually recurive modules?
- let ghcArgs =
- "--make"
- : ["-package-name", display pkgid ]
- ++ constructGHCCmdLine lbi libBi clbi libTargetDir verbosity
- ++ map display (libModules lib)
- ghcArgsProf = ghcArgs
- ++ ["-prof",
- "-hisuf", "p_hi",
- "-osuf", "p_o"
- ]
- ++ ghcProfOptions libBi
- ghcArgsShared = ghcArgs
- ++ ["-dynamic",
- "-hisuf", "dyn_hi",
- "-osuf", "dyn_o", "-fPIC"
- ]
- ++ ghcSharedOptions libBi
+ let baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir
+ vanillaOpts = baseOpts `mappend` mempty {
+ ghcOptMode = toFlag GhcModeMake,
+ ghcOptPackageName = toFlag pkgid,
+ ghcOptInputModules = libModules lib
+ }
+
+ profOpts = vanillaOpts `mappend` mempty {
+ ghcOptProfilingMode = toFlag True,
+ ghcOptHiSuffix = toFlag "p_hi",
+ ghcOptObjSuffix = toFlag "p_o",
+ ghcOptExtra = ghcProfOptions libBi
+ }
+
+ sharedOpts = vanillaOpts `mappend` mempty {
+ ghcOptDynamic = toFlag True,
+ ghcOptFPic = toFlag True,
+ ghcOptHiSuffix = toFlag "dyn_hi",
+ ghcOptObjSuffix = toFlag "dyn_o",
+ ghcOptExtra = ghcSharedOptions libBi
+ }
+
unless (null (libModules lib)) $
- do ifVanillaLib forceVanillaLib (runGhcProg ghcArgs)
- ifProfLib (runGhcProg ghcArgsProf)
- ifSharedLib (runGhcProg ghcArgsShared)
+ do ifVanillaLib forceVanillaLib (runGhcProg vanillaOpts)
+ ifProfLib (runGhcProg profOpts)
+ ifSharedLib (runGhcProg sharedOpts)
-- build any C sources
unless (null (cSources libBi)) $ do
info verbosity "Building C Sources..."
- sequence_ [do let (odir,args) = constructCcCmdLine lbi libBi clbi pref
- filename verbosity
- False
- (withProfLib lbi)
- createDirectoryIfMissingVerbose verbosity True odir
- runGhcProg args
- ifSharedLib (runGhcProg (args ++ ["-fPIC", "-osuf dyn_o"]))
- | filename <- cSources libBi]
+ sequence_
+ [ do let vanillaCcOpts = (componentCcGhcOptions verbosity lbi
+ libBi clbi pref filename) `mappend` mempty {
+ ghcOptProfilingMode = toFlag (withProfLib lbi)
+ }
+ sharedCcOpts = vanillaCcOpts `mappend` mempty {
+ ghcOptFPic = toFlag True,
+ ghcOptDynamic = toFlag True,
+ ghcOptObjSuffix = toFlag "dyn_o"
+ }
+ odir = fromFlag (ghcOptObjDir vanillaCcOpts)
+ createDirectoryIfMissingVerbose verbosity True odir
+ runGhcProg vanillaCcOpts
+ ifSharedLib (runGhcProg sharedCcOpts)
+ | filename <- cSources libBi]
-- link:
info verbosity "Linking..."
@@ -645,15 +693,18 @@ buildLib verbosity pkg_descr lbi lib clbi = do
stubObjs <- fmap catMaybes $ sequence
[ findFileWithExtension [objExtension] [libTargetDir]
(ModuleName.toFilePath x ++"_stub")
- | x <- libModules lib ]
+ | ghcVersion < Version [7,2] [] -- ghc-7.2+ does not make _stub.o files
+ , x <- libModules lib ]
stubProfObjs <- fmap catMaybes $ sequence
[ findFileWithExtension ["p_" ++ objExtension] [libTargetDir]
(ModuleName.toFilePath x ++"_stub")
- | x <- libModules lib ]
+ | ghcVersion < Version [7,2] [] -- ghc-7.2+ does not make _stub.o files
+ , x <- libModules lib ]
stubSharedObjs <- fmap catMaybes $ sequence
[ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir]
(ModuleName.toFilePath x ++"_stub")
- | x <- libModules lib ]
+ | ghcVersion < Version [7,2] [] -- ghc-7.2+ does not make _stub.o files
+ , x <- libModules lib ]
hObjs <- getHaskellObjects lib lbi
pref objExtension True
@@ -695,20 +746,23 @@ buildLib verbosity pkg_descr lbi lib clbi = do
-- with the dependencies spelled out as -package arguments
-- and ghc invokes the linker with the proper library paths
ghcSharedLinkArgs =
- [ "-no-auto-link-packages",
- "-shared",
- "-dynamic",
- "-o", sharedLibFilePath ]
- -- For dynamic libs, Mac OS/X needs to know the install location
- -- at build time.
- ++ (if buildOS == OSX
- then ["-dylib-install-name", sharedLibInstallPath]
- else [])
- ++ dynamicObjectFiles
- ++ ["-package-name", display pkgid ]
- ++ ghcPackageFlags lbi clbi
- ++ ["-l"++extraLib | extraLib <- extraLibs libBi]
- ++ ["-L"++extraLibDir | extraLibDir <- extraLibDirs libBi]
+ mempty {
+ ghcOptShared = toFlag True,
+ ghcOptDynamic = toFlag True,
+ ghcOptInputFiles = dynamicObjectFiles,
+ ghcOptOutputFile = toFlag sharedLibFilePath,
+ -- For dynamic libs, Mac OS/X needs to know the install location
+ -- at build time.
+ ghcOptDylibName = if buildOS == OSX
+ then toFlag sharedLibInstallPath
+ else mempty,
+ ghcOptPackageName = toFlag pkgid,
+ ghcOptNoAutoLinkPackages = toFlag True,
+ ghcOptPackageDBs = withPackageDB lbi,
+ ghcOptPackages = componentPackageDeps clbi,
+ ghcOptLinkLibs = extraLibs libBi,
+ ghcOptLinkLibPath = extraLibDirs libBi
+ }
ifVanillaLib False $ do
(arProg, _) <- requireProgram verbosity arProgram (withPrograms lbi)
@@ -736,7 +790,9 @@ buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo
buildExe verbosity _pkg_descr lbi
exe@Executable { exeName = exeName', modulePath = modPath } clbi = do
let pref = buildDir lbi
- runGhcProg = rawSystemProgramConf verbosity ghcProgram (withPrograms lbi)
+
+ (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi)
+ let runGhcProg = runGHC verbosity ghcProg
exeBi <- hackThreadedFlag verbosity
(compiler lbi) (withProfExe lbi) (buildInfo exe)
@@ -755,47 +811,56 @@ buildExe verbosity _pkg_descr lbi
-- build executables
unless (null (cSources exeBi)) $ do
info verbosity "Building C Sources."
- sequence_ [do let (odir,args) = constructCcCmdLine lbi exeBi clbi
- exeDir filename verbosity
- (withDynExe lbi) (withProfExe lbi)
- createDirectoryIfMissingVerbose verbosity True odir
- runGhcProg args
- | filename <- cSources exeBi]
+ sequence_
+ [ do let opts = (componentCcGhcOptions verbosity lbi exeBi clbi
+ exeDir filename) `mappend` mempty {
+ ghcOptDynamic = toFlag (withDynExe lbi),
+ ghcOptProfilingMode = toFlag (withProfExe lbi)
+ }
+ odir = fromFlag (ghcOptObjDir opts)
+ createDirectoryIfMissingVerbose verbosity True odir
+ runGhcProg opts
+ | filename <- cSources exeBi]
srcMainFile <- findFile (exeDir : hsSourceDirs exeBi) modPath
let cObjs = map (`replaceExtension` objExtension) (cSources exeBi)
- let binArgs linkExe dynExe profExe =
- "--make"
- : (if linkExe
- then ["-o", targetDir </> exeNameReal]
- else ["-c"])
- ++ constructGHCCmdLine lbi exeBi clbi exeDir verbosity
- ++ [exeDir </> x | x <- cObjs]
- ++ [srcMainFile]
- ++ ["-optl" ++ opt | opt <- PD.ldOptions exeBi]
- ++ ["-l"++lib | lib <- extraLibs exeBi]
- ++ ["-L"++libDir | libDir <- extraLibDirs exeBi]
- ++ concat [["-framework", f] | f <- PD.frameworks exeBi]
- ++ if dynExe
- then ["-dynamic"]
- else []
- ++ if profExe
- then ["-prof",
- "-hisuf", "p_hi",
- "-osuf", "p_o"
- ] ++ ghcProfOptions exeBi
- else []
+ let vanillaOpts = (componentGhcOptions verbosity lbi exeBi clbi exeDir)
+ `mappend` mempty {
+ ghcOptMode = toFlag GhcModeMake,
+ ghcOptInputFiles = [exeDir </> x | x <- cObjs]
+ ++ [srcMainFile],
+ ghcOptLinkOptions = PD.ldOptions exeBi,
+ ghcOptLinkLibs = extraLibs exeBi,
+ ghcOptLinkLibPath = extraLibDirs exeBi,
+ ghcOptLinkFrameworks = PD.frameworks exeBi
+ }
+
+ exeOpts | withProfExe lbi = vanillaOpts `mappend` mempty {
+ ghcOptProfilingMode = toFlag True,
+ ghcOptHiSuffix = toFlag "p_hi",
+ ghcOptObjSuffix = toFlag "p_o",
+ ghcOptExtra = ghcProfOptions exeBi
+ }
+ | withDynExe lbi = vanillaOpts `mappend` mempty {
+ ghcOptDynamic = toFlag True,
+ ghcOptHiSuffix = toFlag "dyn_hi",
+ ghcOptObjSuffix = toFlag "dyn_o",
+ ghcOptExtra = ghcSharedOptions exeBi
+ }
+ | otherwise = vanillaOpts
-- For building exe's for profiling that use TH we actually
-- have to build twice, once without profiling and the again
-- with profiling. This is because the code that TH needs to
-- run at compile time needs to be the vanilla ABI so it can
-- be loaded up and run by the compiler.
- when (withProfExe lbi && EnableExtension TemplateHaskell `elem` allExtensions exeBi)
- (runGhcProg (binArgs False (withDynExe lbi) False))
+ when ((withProfExe lbi || withDynExe lbi) &&
+ EnableExtension TemplateHaskell `elem` allExtensions exeBi) $
+ runGhcProg vanillaOpts { ghcOptNoLink = toFlag True }
+
+ runGhcProg exeOpts { ghcOptOutputFile = toFlag (targetDir </> exeNameReal) }
- runGhcProg (binArgs True (withDynExe lbi) (withProfExe lbi))
-- | Filter the "-threaded" flag when profiling as it does not
-- work with ghc-6.8 and older.
@@ -845,74 +910,84 @@ libAbiHash verbosity pkg_descr lbi lib clbi = do
(compiler lbi) (withProfLib lbi) (libBuildInfo lib)
let
ghcArgs =
- "--abi-hash"
- : ["-package-name", display (packageId pkg_descr) ]
- ++ constructGHCCmdLine lbi libBi clbi (buildDir lbi) verbosity
- ++ map display (exposedModules lib)
+ (componentGhcOptions verbosity lbi libBi clbi (buildDir lbi))
+ `mappend` mempty {
+ ghcOptMode = toFlag GhcModeAbiHash,
+ ghcOptPackageName = toFlag (packageId pkg_descr),
+ ghcOptInputModules = exposedModules lib
+ }
--
- rawSystemProgramStdoutConf verbosity ghcProgram (withPrograms lbi) ghcArgs
-
-
-constructGHCCmdLine
- :: LocalBuildInfo
- -> BuildInfo
- -> ComponentLocalBuildInfo
- -> FilePath
- -> Verbosity
- -> [String]
-constructGHCCmdLine lbi bi clbi odir verbosity =
- ghcVerbosityOptions verbosity
- -- Unsupported extensions have already been checked by configure
- ++ ghcOptions lbi bi clbi odir
+ (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi)
+ getProgramInvocationOutput verbosity (ghcInvocation ghcProg ghcArgs)
+
+
+componentGhcOptions :: Verbosity -> LocalBuildInfo
+ -> BuildInfo -> ComponentLocalBuildInfo -> FilePath
+ -> GhcOptions
+componentGhcOptions verbosity lbi bi clbi odir =
+ mempty {
+ ghcOptVerbosity = toFlag verbosity,
+ ghcOptHideAllPackages = toFlag True,
+ ghcOptCabal = toFlag True,
+ ghcOptPackageDBs = withPackageDB lbi,
+ ghcOptPackages = componentPackageDeps clbi,
+ ghcOptSplitObjs = toFlag (splitObjs lbi),
+ ghcOptSourcePathClear = toFlag True,
+ ghcOptSourcePath = [odir] ++ nub (hsSourceDirs bi)
+ ++ [autogenModulesDir lbi],
+ ghcOptCppIncludePath = [autogenModulesDir lbi, odir]
+ ++ PD.includeDirs bi,
+ ghcOptCppOptions = cppOptions bi,
+ ghcOptCppIncludes = [autogenModulesDir lbi </> cppHeaderName],
+ ghcOptFfiIncludes = PD.includes bi,
+ ghcOptObjDir = toFlag odir,
+ ghcOptHiDir = toFlag odir,
+ ghcOptStubDir = toFlag odir,
+ ghcOptOptimisation = toGhcOptimisation (withOptimization lbi),
+ ghcOptExtra = hcOptions GHC bi,
+ ghcOptLanguage = toFlag (fromMaybe Haskell98 (defaultLanguage bi)),
+ -- Unsupported extensions have already been checked by configure
+ ghcOptExtensions = usedExtensions bi,
+ ghcOptExtensionMap = compilerExtensions (compiler lbi)
+ }
+ where
+ toGhcOptimisation NoOptimisation = mempty --TODO perhaps override?
+ toGhcOptimisation NormalOptimisation = toFlag GhcNormalOptimisation
+ toGhcOptimisation MaximumOptimisation = toFlag GhcMaximumOptimisation
+
+
+componentCcGhcOptions :: Verbosity -> LocalBuildInfo
+ -> BuildInfo -> ComponentLocalBuildInfo
+ -> FilePath -> FilePath
+ -> GhcOptions
+componentCcGhcOptions verbosity lbi bi clbi pref filename =
+ mempty {
+ ghcOptVerbosity = toFlag verbosity,
+ ghcOptMode = toFlag GhcModeCompile,
+ ghcOptInputFiles = [filename],
+
+ ghcOptCppIncludePath = odir : PD.includeDirs bi,
+ ghcOptPackageDBs = withPackageDB lbi,
+ ghcOptPackages = componentPackageDeps clbi,
+ ghcOptCcOptions = PD.ccOptions bi
+ ++ case withOptimization lbi of
+ NoOptimisation -> []
+ _ -> ["-O2"],
+ ghcOptObjDir = toFlag odir
+ }
+ where
+ odir | compilerVersion (compiler lbi) >= Version [6,4,1] [] = pref
+ | otherwise = pref </> takeDirectory filename
+ -- ghc 6.4.0 had a bug in -odir handling for C compilations.
+{-# DEPRECATED ghcVerbosityOptions "Use the GhcOptions record instead" #-}
ghcVerbosityOptions :: Verbosity -> [String]
ghcVerbosityOptions verbosity
| verbosity >= deafening = ["-v"]
| verbosity >= normal = []
| otherwise = ["-w", "-v0"]
-ghcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo
- -> FilePath -> [String]
-ghcOptions lbi bi clbi odir
- = ["-hide-all-packages"]
- ++ ["-fbuilding-cabal-package" | ghcVer >= Version [6,11] [] ]
- ++ ghcPackageDbOptions (withPackageDB lbi)
- ++ ["-split-objs" | splitObjs lbi ]
- ++ ["-i"]
- ++ ["-i" ++ odir]
- ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)]
- ++ ["-i" ++ autogenModulesDir lbi]
- ++ ["-I" ++ autogenModulesDir lbi]
- ++ ["-I" ++ odir]
- ++ ["-I" ++ dir | dir <- PD.includeDirs bi]
- ++ ["-optP" ++ opt | opt <- cppOptions bi]
- ++ [ "-optP-include", "-optP"++ (autogenModulesDir lbi </> cppHeaderName) ]
- ++ [ "-#include \"" ++ inc ++ "\"" | ghcVer < Version [6,11] []
- , inc <- PD.includes bi ]
- ++ [ "-odir", odir, "-hidir", odir ]
- ++ concat [ ["-stubdir", odir] | ghcVer >= Version [6,8] [] ]
- ++ ghcPackageFlags lbi clbi
- ++ (case withOptimization lbi of
- NoOptimisation -> []
- NormalOptimisation -> ["-O"]
- MaximumOptimisation -> ["-O2"])
- ++ hcOptions GHC bi
- ++ languageToFlags (compiler lbi) (defaultLanguage bi)
- ++ extensionsToFlags (compiler lbi) (usedExtensions bi)
- where
- ghcVer = compilerVersion (compiler lbi)
-
-ghcPackageFlags :: LocalBuildInfo -> ComponentLocalBuildInfo -> [String]
-ghcPackageFlags lbi clbi
- | ghcVer >= Version [6,11] []
- = concat [ ["-package-id", display ipkgid]
- | (ipkgid, _) <- componentPackageDeps clbi ]
-
- | otherwise = concat [ ["-package", display pkgid]
- | (_, pkgid) <- componentPackageDeps clbi ]
- where
- ghcVer = compilerVersion (compiler lbi)
-
+{-# DEPRECATED ghcPackageDbOptions "Use the GhcOptions record instead" #-}
ghcPackageDbOptions :: PackageDBStack -> [String]
ghcPackageDbOptions dbstack = case dbstack of
(GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs
@@ -924,38 +999,6 @@ ghcPackageDbOptions dbstack = case dbstack of
specific _ = ierror
ierror = error ("internal error: unexpected package db stack: " ++ show dbstack)
-constructCcCmdLine :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo
- -> FilePath -> FilePath -> Verbosity -> Bool -> Bool
- ->(FilePath,[String])
-constructCcCmdLine lbi bi clbi pref filename verbosity dynamic profiling
- = let odir | compilerVersion (compiler lbi) >= Version [6,4,1] [] = pref
- | otherwise = pref </> takeDirectory filename
- -- ghc 6.4.1 fixed a bug in -odir handling
- -- for C compilations.
- in
- (odir,
- ghcCcOptions lbi bi clbi odir
- ++ (if verbosity >= deafening then ["-v"] else [])
- ++ ["-c",filename]
- -- Note: When building with profiling enabled, we pass the -prof
- -- option to ghc here when compiling C code, so that the PROFILING
- -- macro gets defined. The macro is used in ghc's Rts.h in the
- -- definitions of closure layouts (Closures.h).
- ++ ["-dynamic" | dynamic]
- ++ ["-prof" | profiling])
-
-ghcCcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo
- -> FilePath -> [String]
-ghcCcOptions lbi bi clbi odir
- = ["-I" ++ dir | dir <- odir : PD.includeDirs bi]
- ++ ghcPackageDbOptions (withPackageDB lbi)
- ++ ghcPackageFlags lbi clbi
- ++ ["-optc" ++ opt | opt <- PD.ccOptions bi]
- ++ (case withOptimization lbi of
- NoOptimisation -> []
- _ -> ["-optc-O2"])
- ++ ["-odir", odir]
-
mkGHCiLibName :: PackageIdentifier -> String
mkGHCiLibName lib = "HS" ++ display lib <.> "o"
@@ -1062,10 +1105,15 @@ updateLibArchive verbosity lbi path
rawSystemProgram verbosity ranlib [path]
| otherwise = return ()
-
-- -----------------------------------------------------------------------------
-- Registering
+-- | Create an empty package DB at the specified location.
+initPackageDB :: Verbosity -> ProgramConfiguration -> FilePath -> IO ()
+initPackageDB verbosity conf dbPath = HcPkg.init verbosity ghcPkgProg dbPath
+ where
+ Just ghcPkgProg = lookupProgram ghcPkgProgram conf
+
registerPackage
:: Verbosity
-> InstalledPackageInfo
diff --git a/cabal/cabal/Distribution/Simple/GHC/IPI641.hs b/cabal/Cabal/Distribution/Simple/GHC/IPI641.hs
index dbfadf4..222af1a 100644
--- a/cabal/cabal/Distribution/Simple/GHC/IPI641.hs
+++ b/cabal/Cabal/Distribution/Simple/GHC/IPI641.hs
@@ -110,7 +110,7 @@ toCurrent ipi@InstalledPackageInfo{} = Current.InstalledPackageInfo {
Current.exposed = exposed ipi,
Current.exposedModules = map convertModuleName (exposedModules ipi),
Current.hiddenModules = map convertModuleName (hiddenModules ipi),
- Current.trusted = False,
+ Current.trusted = Current.trusted Current.emptyInstalledPackageInfo,
Current.importDirs = importDirs ipi,
Current.libraryDirs = libraryDirs ipi,
Current.hsLibraries = hsLibraries ipi,
diff --git a/cabal/cabal/Distribution/Simple/GHC/IPI642.hs b/cabal/Cabal/Distribution/Simple/GHC/IPI642.hs
index e2ac1c0..b1b8bb7 100644
--- a/cabal/cabal/Distribution/Simple/GHC/IPI642.hs
+++ b/cabal/Cabal/Distribution/Simple/GHC/IPI642.hs
@@ -145,7 +145,7 @@ toCurrent ipi@InstalledPackageInfo{} = Current.InstalledPackageInfo {
Current.exposed = exposed ipi,
Current.exposedModules = map convertModuleName (exposedModules ipi),
Current.hiddenModules = map convertModuleName (hiddenModules ipi),
- Current.trusted = False,
+ Current.trusted = Current.trusted Current.emptyInstalledPackageInfo,
Current.importDirs = importDirs ipi,
Current.libraryDirs = libraryDirs ipi,
Current.hsLibraries = hsLibraries ipi,
diff --git a/cabal/cabal/Distribution/Simple/Haddock.hs b/cabal/Cabal/Distribution/Simple/Haddock.hs
index ffcf2d0..1434803 100644
--- a/cabal/cabal/Distribution/Simple/Haddock.hs
+++ b/cabal/Cabal/Distribution/Simple/Haddock.hs
@@ -59,7 +59,8 @@ import Distribution.PackageDescription as PD
, Library(..), hasLibs, Executable(..) )
import Distribution.Simple.Compiler
( Compiler(..), compilerVersion )
-import Distribution.Simple.GHC ( ghcLibDir )
+import Distribution.Simple.GHC ( componentGhcOptions, ghcLibDir )
+import Distribution.Simple.Program.GHC ( GhcOptions(..), renderGhcOptions )
import Distribution.Simple.Program
( ConfiguredProgram(..), requireProgramVersion
, rawSystemProgram, rawSystemProgramStdout
@@ -68,17 +69,17 @@ import Distribution.Simple.PreProcess (ppCpp', ppUnlit
, PPSuffixHandler, runSimplePreProcessor
, preprocessComponent)
import Distribution.Simple.Setup
- ( defaultHscolourFlags, Flag(..), flagToMaybe, fromFlag
+ ( defaultHscolourFlags, Flag(..), toFlag, flagToMaybe, flagToList, fromFlag
, HaddockFlags(..), HscolourFlags(..) )
import Distribution.Simple.Build (initialBuildSteps)
-import Distribution.Simple.InstallDirs (InstallDirs(..), PathTemplate,
+import Distribution.Simple.InstallDirs (InstallDirs(..), PathTemplateEnv, PathTemplate,
PathTemplateVariable(..),
toPathTemplate, fromPathTemplate,
substPathTemplate,
initialPathTemplateEnv)
import Distribution.Simple.LocalBuildInfo
- ( LocalBuildInfo(..), externalPackageDeps
- , Component(..), ComponentLocalBuildInfo(..), withComponentsLBI )
+ ( LocalBuildInfo(..), Component(..), ComponentLocalBuildInfo(..)
+ , withComponentsLBI )
import Distribution.Simple.BuildPaths ( haddockName,
hscolourPref, autogenModulesDir,
)
@@ -93,7 +94,6 @@ import Distribution.Simple.Utils
, createDirectoryIfMissingVerbose, withTempFile, copyFileVerbose
, withTempDirectory
, findFileWithExtension, findFile )
-import Distribution.Simple.GHC (ghcOptions)
import Distribution.Text
( display, simpleParse )
@@ -122,13 +122,14 @@ data HaddockArgs = HaddockArgs {
argIgnoreExports :: Any, -- ^ ingore export lists in modules?
argLinkSource :: Flag (Template,Template), -- ^ (template for modules, template for symbols)
argCssFile :: Flag FilePath, -- ^ optinal custom css file.
+ argContents :: Flag String, -- ^ optional url to contents page
argVerbose :: Any,
argOutput :: Flag [Output], -- ^ Html or Hoogle doc or both? required.
argInterfaces :: [(FilePath, Maybe FilePath)], -- ^ [(interface file, path to the html docs for links)]
argOutputDir :: Directory, -- ^ where to generate the documentation.
argTitle :: Flag String, -- ^ page's title, required.
argPrologue :: Flag String, -- ^ prologue text, required.
- argGhcFlags :: [String], -- ^ additional flags to pass to ghc for haddock-2
+ argGhcOptions :: Flag (GhcOptions, Version), -- ^ additional flags to pass to ghc for haddock-2
argGhcLibDir :: Flag FilePath, -- ^ to find the correct ghc, required by haddock-2.
argTargets :: [FilePath] -- ^ modules to process.
}
@@ -193,11 +194,10 @@ haddock pkg_descr lbi suffixes flags = do
when (flag haddockHscolour) $ hscolour' pkg_descr lbi suffixes $
defaultHscolourFlags `mappend` haddockToHscolour flags
- args <- fmap mconcat . sequence $
- [ getInterfaces verbosity lbi (flagToMaybe (haddockHtmlLocation flags))
- , getGhcLibDir verbosity lbi isVersion2 ]
- ++ map return
- [ fromFlags flags
+ libdirArgs <- getGhcLibDir verbosity lbi isVersion2
+ let commonArgs = mconcat
+ [ libdirArgs
+ , fromFlags (haddockTemplateEnv lbi (packageId pkg_descr)) flags
, fromPackageDescription pkg_descr ]
let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes
@@ -207,21 +207,22 @@ haddock pkg_descr lbi suffixes flags = do
CLib lib -> do
withTempDirectory verbosity (buildDir lbi) "tmp" $ \tmp -> do
let bi = libBuildInfo lib
- libArgs <- fromLibrary tmp lbi lib clbi
+ libArgs <- fromLibrary verbosity tmp lbi lib clbi htmlTemplate
libArgs' <- prepareSources verbosity tmp
- lbi isVersion2 bi (args `mappend` libArgs)
+ lbi isVersion2 bi (commonArgs `mappend` libArgs)
runHaddock verbosity confHaddock libArgs'
CExe exe -> when (flag haddockExecutables) $ do
withTempDirectory verbosity (buildDir lbi) "tmp" $ \tmp -> do
let bi = buildInfo exe
- exeArgs <- fromExecutable tmp lbi exe clbi
+ exeArgs <- fromExecutable verbosity tmp lbi exe clbi htmlTemplate
exeArgs' <- prepareSources verbosity tmp
- lbi isVersion2 bi (args `mappend` exeArgs)
+ lbi isVersion2 bi (commonArgs `mappend` exeArgs)
runHaddock verbosity confHaddock exeArgs'
_ -> return ()
where
verbosity = flag haddockVerbosity
flag f = fromFlag $ f flags
+ htmlTemplate = fmap toPathTemplate . flagToMaybe . haddockHtmlLocation $ flags
-- | performs cpp and unlit preprocessing where needed on the files in
-- | argTargets, which must have an .hs or .lhs extension.
@@ -265,8 +266,8 @@ prepareSources verbosity tmp lbi isVersion2 bi args@HaddockArgs{argTargets=files
--------------------------------------------------------------------------------------------------
-- constributions to HaddockArgs
-fromFlags :: HaddockFlags -> HaddockArgs
-fromFlags flags =
+fromFlags :: PathTemplateEnv -> HaddockFlags -> HaddockArgs
+fromFlags env flags =
mempty {
argHideModules = (maybe mempty (All . not) $ flagToMaybe (haddockInternal flags), mempty),
argLinkSource = if fromFlag (haddockHscolour flags)
@@ -274,6 +275,7 @@ fromFlags flags =
,"src/%{MODULE/./-}.html#%{NAME}")
else NoFlag,
argCssFile = haddockCss flags,
+ argContents = fmap (fromPathTemplate . substPathTemplate env) (haddockContents flags),
argVerbose = maybe mempty (Any . (>= deafening)) . flagToMaybe $ haddockVerbosity flags,
argOutput =
Flag $ case [ Html | Flag True <- [haddockHtml flags] ] ++
@@ -298,52 +300,64 @@ fromPackageDescription pkg_descr =
subtitle | null (synopsis pkg_descr) = ""
| otherwise = ": " ++ synopsis pkg_descr
-fromLibrary :: FilePath
+fromLibrary :: Verbosity
+ -> FilePath
-> LocalBuildInfo -> Library -> ComponentLocalBuildInfo
+ -> Maybe PathTemplate -- ^ template for html location
-> IO HaddockArgs
-fromLibrary tmp lbi lib clbi =
- do inFiles <- map snd `fmap` getLibSourceFiles lbi lib
- return $ mempty {
- argHideModules = (mempty,otherModules $ bi),
- argGhcFlags = ghcOptions lbi bi clbi (buildDir lbi)
- -- Noooooooooo!!!!!111
- -- haddock stomps on our precious .hi
- -- and .o files. Workaround by telling
- -- haddock to write them elsewhere.
- ++ [ "-odir", tmp, "-hidir", tmp
- , "-stubdir", tmp ],
- argTargets = inFiles
- }
- where
- bi = libBuildInfo lib
+fromLibrary verbosity tmp lbi lib clbi htmlTemplate = do
+ inFiles <- map snd `fmap` getLibSourceFiles lbi lib
+ ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate
+ return ifaceArgs {
+ argHideModules = (mempty,otherModules $ bi),
+ argGhcOptions = toFlag ((componentGhcOptions normal lbi bi clbi (buildDir lbi)) {
+ -- Noooooooooo!!!!!111
+ -- haddock stomps on our precious .hi
+ -- and .o files. Workaround by telling
+ -- haddock to write them elsewhere.
+ ghcOptObjDir = toFlag tmp,
+ ghcOptHiDir = toFlag tmp,
+ ghcOptStubDir = toFlag tmp
+ },ghcVersion),
+ argTargets = inFiles
+ }
+ where
+ bi = libBuildInfo lib
+ ghcVersion = compilerVersion (compiler lbi)
-fromExecutable :: FilePath
+fromExecutable :: Verbosity
+ -> FilePath
-> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo
+ -> Maybe PathTemplate -- ^ template for html location
-> IO HaddockArgs
-fromExecutable tmp lbi exe clbi =
- do inFiles <- map snd `fmap` getExeSourceFiles lbi exe
- return $ mempty {
- argGhcFlags = ghcOptions lbi bi clbi (buildDir lbi)
- -- Noooooooooo!!!!!111
- -- haddock stomps on our precious .hi
- -- and .o files. Workaround by telling
- -- haddock to write them elsewhere.
- ++ [ "-odir", tmp, "-hidir", tmp
- , "-stubdir", tmp ],
- argOutputDir = Dir (exeName exe),
- argTitle = Flag (exeName exe),
- argTargets = inFiles
- }
- where
- bi = buildInfo exe
+fromExecutable verbosity tmp lbi exe clbi htmlTemplate = do
+ inFiles <- map snd `fmap` getExeSourceFiles lbi exe
+ ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate
+ return ifaceArgs {
+ argGhcOptions = toFlag ((componentGhcOptions normal lbi bi clbi (buildDir lbi)) {
+ -- Noooooooooo!!!!!111
+ -- haddock stomps on our precious .hi
+ -- and .o files. Workaround by telling
+ -- haddock to write them elsewhere.
+ ghcOptObjDir = toFlag tmp,
+ ghcOptHiDir = toFlag tmp,
+ ghcOptStubDir = toFlag tmp
+ }, ghcVersion),
+ argOutputDir = Dir (exeName exe),
+ argTitle = Flag (exeName exe),
+ argTargets = inFiles
+ }
+ where
+ bi = buildInfo exe
+ ghcVersion = compilerVersion (compiler lbi)
getInterfaces :: Verbosity
- -> LocalBuildInfo
- -> Maybe String -- ^ template for html location
- -> IO HaddockArgs
-getInterfaces verbosity lbi location = do
- let htmlTemplate = fmap toPathTemplate $ location
- (packageFlags, warnings) <- haddockPackageFlags lbi htmlTemplate
+ -> LocalBuildInfo
+ -> ComponentLocalBuildInfo
+ -> Maybe PathTemplate -- ^ template for html location
+ -> IO HaddockArgs
+getInterfaces verbosity lbi clbi htmlTemplate = do
+ (packageFlags, warnings) <- haddockPackageFlags lbi clbi htmlTemplate
maybe (return ()) (warn verbosity) warnings
return $ mempty {
argInterfaces = packageFlags
@@ -376,7 +390,7 @@ runHaddock verbosity confHaddock args = do
renderArgs :: Verbosity
-> Version
-> HaddockArgs
- -> (([[Char]], FilePath) -> IO a)
+ -> (([String], FilePath) -> IO a)
-> IO a
renderArgs verbosity version args k = do
createDirectoryIfMissingVerbose verbosity True outputDir
@@ -401,7 +415,7 @@ renderArgs verbosity version args k = do
pkgid = arg argPackageName
arg f = fromFlag $ f args
-renderPureArgs :: Version -> HaddockArgs -> [[Char]]
+renderPureArgs :: Version -> HaddockArgs -> [String]
renderPureArgs version args = concat
[
(:[]) . (\f -> "--dump-interface="++ unDir (argOutputDir args) </> f)
@@ -414,13 +428,16 @@ renderPureArgs version args = concat
maybe [] (\(m,e) -> ["--source-module=" ++ m
,"--source-entity=" ++ e]) . flagToMaybe . argLinkSource $ args,
maybe [] ((:[]).("--css="++)) . flagToMaybe . argCssFile $ args,
+ maybe [] ((:[]).("--use-contents="++)) . flagToMaybe . argContents $ args,
bool [] [verbosityFlag] . getAny . argVerbose $ args,
map (\o -> case o of Hoogle -> "--hoogle"; Html -> "--html") . fromFlag . argOutput $ args,
renderInterfaces . argInterfaces $ args,
(:[]).("--odir="++) . unDir . argOutputDir $ args,
(:[]).("--title="++) . (bool (++" (internal documentation)") id (getAny $ argIgnoreExports args))
. fromFlag . argTitle $ args,
- bool id (const []) isVersion2 . map ("--optghc=" ++) . argGhcFlags $ args,
+ [ "--optghc=" ++ opt | isVersion2
+ , (opts, ghcVersion) <- flagToList (argGhcOptions args)
+ , opt <- renderGhcOptions ghcVersion opts ],
maybe [] (\l -> ["-B"++l]) $ guard isVersion2 >> flagToMaybe (argGhcLibDir args), -- error if isVersion2 and Nothing?
argTargets $ args
]
@@ -436,14 +453,16 @@ renderPureArgs version args = concat
-----------------------------------------------------------------------------------------------------------
haddockPackageFlags :: LocalBuildInfo
+ -> ComponentLocalBuildInfo
-> Maybe PathTemplate
-> IO ([(FilePath,Maybe FilePath)], Maybe String)
-haddockPackageFlags lbi htmlTemplate = do
+haddockPackageFlags lbi clbi htmlTemplate = do
let allPkgs = installedPkgs lbi
- directDeps = map fst (externalPackageDeps lbi)
+ directDeps = map fst (componentPackageDeps clbi)
transitiveDeps <- case dependencyClosure allPkgs directDeps of
- Left x -> return x
- Right _ -> die "Can't find transitive deps for haddock"
+ Left x -> return x
+ Right inf -> die $ "internal error when calculating transative "
+ ++ "package dependencies.\nDebug info: " ++ show inf
interfaces <- sequence
[ case interfaceAndHtmlPath ipkg of
Nothing -> return (Left (packageId ipkg))
@@ -473,8 +492,11 @@ haddockPackageFlags lbi htmlTemplate = do
return (interface, html)
where expandTemplateVars = fromPathTemplate . substPathTemplate env
- env = (PrefixVar, prefix (installDirTemplates lbi))
- : initialPathTemplateEnv (packageId pkg) (compilerId (compiler lbi))
+ env = haddockTemplateEnv lbi (packageId pkg)
+
+haddockTemplateEnv :: LocalBuildInfo -> PackageIdentifier -> PathTemplateEnv
+haddockTemplateEnv lbi pkg_id = (PrefixVar, prefix (installDirTemplates lbi))
+ : initialPathTemplateEnv pkg_id (compilerId (compiler lbi))
-- --------------------------------------------------------------------------
-- hscolour support
@@ -595,13 +617,14 @@ instance Monoid HaddockArgs where
argIgnoreExports = mempty,
argLinkSource = mempty,
argCssFile = mempty,
+ argContents = mempty,
argVerbose = mempty,
argOutput = mempty,
argInterfaces = mempty,
argOutputDir = mempty,
argTitle = mempty,
argPrologue = mempty,
- argGhcFlags = mempty,
+ argGhcOptions = mempty,
argGhcLibDir = mempty,
argTargets = mempty
}
@@ -612,13 +635,14 @@ instance Monoid HaddockArgs where
argIgnoreExports = mult argIgnoreExports,
argLinkSource = mult argLinkSource,
argCssFile = mult argCssFile,
+ argContents = mult argContents,
argVerbose = mult argVerbose,
argOutput = mult argOutput,
argInterfaces = mult argInterfaces,
argOutputDir = mult argOutputDir,
argTitle = mult argTitle,
argPrologue = mult argPrologue,
- argGhcFlags = mult argGhcFlags,
+ argGhcOptions = mult argGhcOptions,
argGhcLibDir = mult argGhcLibDir,
argTargets = mult argTargets
}
diff --git a/cabal/cabal/Distribution/Simple/Hpc.hs b/cabal/Cabal/Distribution/Simple/Hpc.hs
index d5798d1..b579d16 100644
--- a/cabal/cabal/Distribution/Simple/Hpc.hs
+++ b/cabal/Cabal/Distribution/Simple/Hpc.hs
@@ -41,16 +41,15 @@ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
module Distribution.Simple.Hpc
- ( hpcDir
- , enableCoverage
+ ( enableCoverage
+ , htmlDir
, tixDir
, tixFilePath
- , doHpcMarkup
- , findTixFiles
+ , markupPackage
+ , markupTest
) where
-import Control.Exception ( bracket )
-import Control.Monad ( unless, when )
+import Control.Monad ( when )
import Distribution.Compiler ( CompilerFlavor(..) )
import Distribution.ModuleName ( main )
import Distribution.PackageDescription
@@ -60,14 +59,14 @@ import Distribution.PackageDescription
, TestSuite(..)
, testModules
)
-import Distribution.Simple.Utils ( die, notice )
+import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) )
+import Distribution.Simple.Program ( hpcProgram, requireProgram )
+import Distribution.Simple.Program.Hpc ( markup, union )
+import Distribution.Simple.Utils ( notice )
import Distribution.Text
import Distribution.Verbosity ( Verbosity() )
-import System.Directory ( doesFileExist, getDirectoryContents, removeFile )
-import System.Exit ( ExitCode(..) )
+import System.Directory ( createDirectoryIfMissing, doesFileExist )
import System.FilePath
-import System.IO ( hClose, IOMode(..), openFile, openTempFile )
-import System.Process ( runProcess, waitForProcess )
-- -------------------------------------------------------------------------
-- Haskell Program Coverage
@@ -95,7 +94,7 @@ enableCoverage True distPref p =
Just xs -> (GHC, hpcOpts ++ xs)
_ -> (GHC, hpcOpts)
newOptions = (:) newGHCOpts $ filter ((== GHC) . fst) oldOptions
- hpcOpts = ["-fhpc", "-hpcdir", hpcDir distPref name]
+ hpcOpts = ["-fhpc", "-hpcdir", mixDir distPref name]
in oldBI { options = newOptions }
enableLibCoverage l =
l { libBuildInfo = enableBICoverage (display $ package p)
@@ -105,81 +104,67 @@ enableCoverage True distPref p =
t { testBuildInfo = enableBICoverage (testName t) (testBuildInfo t) }
hpcDir :: FilePath -- ^ \"dist/\" prefix
- -> FilePath -- ^ Component subdirectory name
-> FilePath -- ^ Directory containing component's HPC .mix files
-hpcDir distPref name = distPref </> "hpc" </> name
+hpcDir distPref = distPref </> "hpc"
+
+mixDir :: FilePath -- ^ \"dist/\" prefix
+ -> FilePath -- ^ Component name
+ -> FilePath -- ^ Directory containing test suite's .mix files
+mixDir distPref name = hpcDir distPref </> "mix" </> name
tixDir :: FilePath -- ^ \"dist/\" prefix
- -> TestSuite -- ^ Test suite
+ -> FilePath -- ^ Component name
-> FilePath -- ^ Directory containing test suite's .tix files
-tixDir distPref suite = distPref </> "test" </> testName suite
+tixDir distPref name = hpcDir distPref </> "tix" </> name
-- | Path to the .tix file containing a test suite's sum statistics.
tixFilePath :: FilePath -- ^ \"dist/\" prefix
- -> TestSuite -- ^ Test suite
- -> FilePath -- Path to test suite's .tix file
-tixFilePath distPref suite = tixDir distPref suite </> testName suite <.> "tix"
-
--- | Returns a list of all the .tix files in a test suite's .tix file
--- directory. Returned paths are the complete relative path to each file.
-findTixFiles :: FilePath -- ^ \"dist/\" prefix
- -> TestSuite -- ^ Test suite
- -> IO [FilePath] -- ^ All .tix files belonging to test suite
-findTixFiles distPref suite = do
- files <- getDirectoryContents $ tixDir distPref suite
- let tixFiles = flip filter files $ \x -> takeExtension x == ".tix"
- return $ map (tixDir distPref suite </>) tixFiles
+ -> FilePath -- ^ Component name
+ -> FilePath -- ^ Path to test suite's .tix file
+tixFilePath distPref name = tixDir distPref name </> name <.> "tix"
+
+htmlDir :: FilePath -- ^ \"dist/\" prefix
+ -> FilePath -- ^ Component name
+ -> FilePath -- ^ Path to test suite's HTML markup directory
+htmlDir distPref name = hpcDir distPref </> "html" </> name
-- | Generate the HTML markup for a test suite.
-doHpcMarkup :: Verbosity
- -> FilePath -- ^ \"dist/\" prefix
- -> String -- ^ Library name
- -> TestSuite
- -> IO ()
-doHpcMarkup verbosity distPref libName suite = do
- tixFiles <- findTixFiles distPref suite
- when (not $ null tixFiles) $ do
- let hpcOptions = map (\x -> "--exclude=" ++ display x) excluded
- unionOptions = [ "sum"
- , "--union"
- , "--output=" ++ tixFilePath distPref suite
- ]
- ++ hpcOptions ++ tixFiles
- markupOptions = [ "markup"
- , tixFilePath distPref suite
- , "--hpcdir=" ++ hpcDir distPref libName
- , "--destdir=" ++ tixDir distPref suite
- ]
- ++ hpcOptions
- excluded = testModules suite ++ [ main ]
- --TODO: use standard process utilities from D.S.Utils
- runHpc opts h = runProcess "hpc" opts Nothing Nothing Nothing
- (Just h) (Just h)
- bracket (openHpcTemp $ tixDir distPref suite) deleteIfExists
- $ \hpcOut -> do
- hUnion <- openFile hpcOut AppendMode
- procUnion <- runHpc unionOptions hUnion
- exitUnion <- waitForProcess procUnion
- success <- case exitUnion of
- ExitSuccess -> do
- hMarkup <- openFile hpcOut AppendMode
- procMarkup <- runHpc markupOptions hMarkup
- exitMarkup <- waitForProcess procMarkup
- case exitMarkup of
- ExitSuccess -> return True
- _ -> return False
- _ -> return False
- unless success $ do
- errs <- readFile hpcOut
- die $ "HPC failed:\n" ++ errs
- when success $ notice verbosity
- $ "Test coverage report written to "
- ++ tixDir distPref suite </> "hpc_index"
- <.> "html"
- return ()
- where openHpcTemp dir = do
- (f, h) <- openTempFile dir $ "cabal-test-hpc-" <.> "log"
- hClose h >> return f
- deleteIfExists path = do
- exists <- doesFileExist path
- when exists $ removeFile path
+markupTest :: Verbosity
+ -> LocalBuildInfo
+ -> FilePath -- ^ \"dist/\" prefix
+ -> String -- ^ Library name
+ -> TestSuite
+ -> IO ()
+markupTest verbosity lbi distPref libName suite = do
+ tixFileExists <- doesFileExist $ tixFilePath distPref $ testName suite
+ when tixFileExists $ do
+ (hpc, _) <- requireProgram verbosity hpcProgram $ withPrograms lbi
+ markup hpc verbosity (tixFilePath distPref $ testName suite)
+ (mixDir distPref libName)
+ (htmlDir distPref $ testName suite)
+ (testModules suite ++ [ main ])
+ notice verbosity $ "Test coverage report written to "
+ ++ htmlDir distPref (testName suite)
+ </> "hpc_index" <.> "html"
+
+-- | Generate the HTML markup for all of a package's test suites.
+markupPackage :: Verbosity
+ -> LocalBuildInfo
+ -> FilePath -- ^ \"dist/\" prefix
+ -> String -- ^ Library name
+ -> [TestSuite]
+ -> IO ()
+markupPackage verbosity lbi distPref libName suites = do
+ let tixFiles = map (tixFilePath distPref . testName) suites
+ tixFilesExist <- mapM doesFileExist tixFiles
+ when (and tixFilesExist) $ do
+ (hpc, _) <- requireProgram verbosity hpcProgram $ withPrograms lbi
+ let outFile = tixFilePath distPref libName
+ mixDir' = mixDir distPref libName
+ htmlDir' = htmlDir distPref libName
+ excluded = concatMap testModules suites ++ [ main ]
+ createDirectoryIfMissing True $ takeDirectory outFile
+ union hpc verbosity tixFiles outFile excluded
+ markup hpc verbosity outFile mixDir' htmlDir' excluded
+ notice verbosity $ "Package coverage report written to "
+ ++ htmlDir' </> "hpc_index.html"
diff --git a/cabal/cabal/Distribution/Simple/Hugs.hs b/cabal/Cabal/Distribution/Simple/Hugs.hs
index f6e5af6..ef3dd53 100644
--- a/cabal/cabal/Distribution/Simple/Hugs.hs
+++ b/cabal/Cabal/Distribution/Simple/Hugs.hs
@@ -119,6 +119,8 @@ import System.Exit
( ExitCode(ExitSuccess) )
import Distribution.Compat.Exception
+import qualified Data.ByteString.Lazy.Char8 as BS.Char8
+
-- -----------------------------------------------------------------------------
-- Configuring
@@ -597,7 +599,7 @@ install verbosity lbi libDir installProgDir binDir targetProgDir buildPref (prog
let args = hugsOptions ++ [targetName, "\"$@\""]
in unlines ["#! /bin/sh",
unwords ("runhugs" : args)]
- writeFileAtomic exeFile script
+ writeFileAtomic exeFile (BS.Char8.pack script)
setFileExecutable exeFile
hugsInstallSuffixes :: [String]
diff --git a/cabal/cabal/Distribution/Simple/Install.hs b/cabal/Cabal/Distribution/Simple/Install.hs
index d5d4242..d5d4242 100644
--- a/cabal/cabal/Distribution/Simple/Install.hs
+++ b/cabal/Cabal/Distribution/Simple/Install.hs
diff --git a/cabal/cabal/Distribution/Simple/InstallDirs.hs b/cabal/Cabal/Distribution/Simple/InstallDirs.hs
index a191711..8555b9b 100644
--- a/cabal/cabal/Distribution/Simple/InstallDirs.hs
+++ b/cabal/Cabal/Distribution/Simple/InstallDirs.hs
@@ -60,6 +60,7 @@ module Distribution.Simple.InstallDirs (
PathTemplate,
PathTemplateVariable(..),
+ PathTemplateEnv,
toPathTemplate,
fromPathTemplate,
substPathTemplate,
@@ -89,7 +90,7 @@ import Distribution.Compiler
import Distribution.Text
( display )
-#if mingw32_HOST_OS || mingw32_TARGET_OS
+#if mingw32_HOST_OS
import Foreign
import Foreign.C
#endif
@@ -390,6 +391,7 @@ data PathTemplateVariable =
| ExecutableNameVar -- ^ The executable name; used in shell wrappers
| TestSuiteNameVar -- ^ The name of the test suite being run
| TestSuiteResultVar -- ^ The result of the test suite being run, eg @pass@, @fail@, or @error@.
+ | BenchmarkNameVar -- ^ The name of the benchmark being run
deriving Eq
type PathTemplateEnv = [(PathTemplateVariable, PathTemplate)]
@@ -484,6 +486,7 @@ instance Show PathTemplateVariable where
show ExecutableNameVar = "executablename"
show TestSuiteNameVar = "test-suite"
show TestSuiteResultVar = "result"
+ show BenchmarkNameVar = "benchmark"
instance Read PathTemplateVariable where
readsPrec _ s =
@@ -507,7 +510,8 @@ instance Read PathTemplateVariable where
,("arch", ArchVar)
,("executablename", ExecutableNameVar)
,("test-suite", TestSuiteNameVar)
- ,("result", TestSuiteResultVar)]
+ ,("result", TestSuiteResultVar)
+ ,("benchmark", BenchmarkNameVar)]
instance Show PathComponent where
show (Ordinary path) = path
@@ -547,14 +551,14 @@ instance Read PathTemplate where
getWindowsProgramFilesDir :: IO FilePath
getWindowsProgramFilesDir = do
-#if mingw32_HOST_OS || mingw32_TARGET_OS
+#if mingw32_HOST_OS
m <- shGetFolderPath csidl_PROGRAM_FILES
#else
let m = Nothing
#endif
return (fromMaybe "C:\\Program Files" m)
-#if mingw32_HOST_OS || mingw32_TARGET_OS
+#if mingw32_HOST_OS
shGetFolderPath :: CInt -> IO (Maybe FilePath)
shGetFolderPath n =
# if __HUGS__
diff --git a/cabal/cabal/Distribution/Simple/JHC.hs b/cabal/Cabal/Distribution/Simple/JHC.hs
index 9287b9c..efaa09a 100644
--- a/cabal/cabal/Distribution/Simple/JHC.hs
+++ b/cabal/Cabal/Distribution/Simple/JHC.hs
@@ -89,6 +89,8 @@ import Data.List ( nub )
import Data.Char ( isSpace )
import Data.Maybe ( fromMaybe )
+import qualified Data.ByteString.Lazy.Char8 as BS.Char8
+
-- -----------------------------------------------------------------------------
-- Configuring
@@ -161,7 +163,7 @@ buildLib verbosity pkg_descr lbi lib clbi = do
let pkgid = display (packageId pkg_descr)
pfile = buildDir lbi </> "jhc-pkg.conf"
hlfile= buildDir lbi </> (pkgid ++ ".hl")
- writeFileAtomic pfile $ jhcPkgConf pkg_descr
+ writeFileAtomic pfile . BS.Char8.pack $ jhcPkgConf pkg_descr
rawSystemProgram verbosity jhcProg $
["--build-hl="++pfile, "-o", hlfile] ++
args ++ map display (libModules lib)
@@ -218,4 +220,3 @@ installExe verb dest build_dir (progprefix,progsuffix) _ exe = do
out = (progprefix ++ exe_name ++ progsuffix) </> exeExtension
createDirectoryIfMissingVerbose verb True dest
installExecutableFile verb (build_dir </> src) (dest </> out)
-
diff --git a/cabal/cabal/Distribution/Simple/LHC.hs b/cabal/Cabal/Distribution/Simple/LHC.hs
index ffeeea1..6b3fcbe 100644
--- a/cabal/cabal/Distribution/Simple/LHC.hs
+++ b/cabal/Cabal/Distribution/Simple/LHC.hs
@@ -241,7 +241,7 @@ getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration
-> IO PackageIndex
getInstalledPackages verbosity packagedbs conf = do
checkPackageDbStack packagedbs
- pkgss <- getInstalledPackages' verbosity packagedbs conf
+ pkgss <- getInstalledPackages' lhcPkg verbosity packagedbs conf
let indexes = [ PackageIndex.fromList (map (substTopDir topDir) pkgs)
| (_, pkgs) <- pkgss ]
return $! (mconcat indexes)
@@ -251,6 +251,7 @@ getInstalledPackages verbosity packagedbs conf = do
-- paths. We need to substitute the right value in so that when
-- we, for example, call gcc, we have proper paths to give it
Just ghcProg = lookupProgram lhcProgram conf
+ Just lhcPkg = lookupProgram lhcPkgProgram conf
compilerDir = takeDirectory (programPath ghcProg)
topDir = takeDirectory compilerDir
@@ -263,9 +264,10 @@ checkPackageDbStack _ =
-- | Get the packages from specific PackageDBs, not cumulative.
--
-getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramConfiguration
- -> IO [(PackageDB, [InstalledPackageInfo])]
-getInstalledPackages' verbosity packagedbs conf
+getInstalledPackages' :: ConfiguredProgram -> Verbosity
+ -> [PackageDB] -> ProgramConfiguration
+ -> IO [(PackageDB, [InstalledPackageInfo])]
+getInstalledPackages' lhcPkg verbosity packagedbs conf
=
sequence
[ do str <- rawSystemProgramStdoutConf verbosity lhcPkgProgram conf
@@ -294,7 +296,13 @@ getInstalledPackages' verbosity packagedbs conf
packageDbGhcPkgFlag GlobalPackageDB = "--global"
packageDbGhcPkgFlag UserPackageDB = "--user"
- packageDbGhcPkgFlag (SpecificPackageDB path) = "--package-conf=" ++ path
+ packageDbGhcPkgFlag (SpecificPackageDB path) = "--" ++ packageDbFlag ++ "=" ++ path
+
+ packageDbFlag
+ | programVersion lhcPkg < Just (Version [7,5] [])
+ = "package-conf"
+ | otherwise
+ = "package-db"
substTopDir :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo
@@ -607,7 +615,7 @@ ghcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo
-> FilePath -> [String]
ghcOptions lbi bi clbi odir
= ["-hide-all-packages"]
- ++ ghcPackageDbOptions (withPackageDB lbi)
+ ++ ghcPackageDbOptions lbi
++ (if splitObjs lbi then ["-split-objs"] else [])
++ ["-i"]
++ ["-i" ++ odir]
@@ -643,17 +651,24 @@ ghcPackageFlags lbi clbi
where
ghcVer = compilerVersion (compiler lbi)
-ghcPackageDbOptions :: PackageDBStack -> [String]
-ghcPackageDbOptions dbstack = case dbstack of
+ghcPackageDbOptions :: LocalBuildInfo -> [String]
+ghcPackageDbOptions lbi = case dbstack of
(GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs
- (GlobalPackageDB:dbs) -> "-no-user-package-conf"
+ (GlobalPackageDB:dbs) -> ("-no-user-" ++ packageDbFlag)
: concatMap specific dbs
_ -> ierror
where
- specific (SpecificPackageDB db) = [ "-package-conf", db ]
+ specific (SpecificPackageDB db) = [ '-':packageDbFlag, db ]
specific _ = ierror
ierror = error ("internal error: unexpected package db stack: " ++ show dbstack)
+ dbstack = withPackageDB lbi
+ packageDbFlag
+ | compilerVersion (compiler lbi) < Version [7,5] []
+ = "package-conf"
+ | otherwise
+ = "package-db"
+
constructCcCmdLine :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo
-> FilePath -> FilePath -> Verbosity -> (FilePath,[String])
constructCcCmdLine lbi bi clbi pref filename verbosity
@@ -672,7 +687,7 @@ ghcCcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo
-> FilePath -> [String]
ghcCcOptions lbi bi clbi odir
= ["-I" ++ dir | dir <- PD.includeDirs bi]
- ++ ghcPackageDbOptions (withPackageDB lbi)
+ ++ ghcPackageDbOptions lbi
++ ghcPackageFlags lbi clbi
++ ["-optc" ++ opt | opt <- PD.ccOptions bi]
++ (case withOptimization lbi of
diff --git a/cabal/cabal/Distribution/Simple/LocalBuildInfo.hs b/cabal/Cabal/Distribution/Simple/LocalBuildInfo.hs
index 8fa4f27..b757a89 100644
--- a/cabal/cabal/Distribution/Simple/LocalBuildInfo.hs
+++ b/cabal/Cabal/Distribution/Simple/LocalBuildInfo.hs
@@ -52,6 +52,7 @@ module Distribution.Simple.LocalBuildInfo (
-- * Buildable package components
Component(..),
foldComponent,
+ componentBuildInfo,
allComponentsBy,
ComponentName(..),
ComponentLocalBuildInfo(..),
@@ -75,7 +76,7 @@ import Distribution.Simple.Program (ProgramConfiguration)
import Distribution.PackageDescription
( PackageDescription(..), withLib, Library(libBuildInfo), withExe
, Executable(exeName, buildInfo), withTest, TestSuite(..)
- , BuildInfo(buildable) )
+ , BuildInfo(buildable), Benchmark(..) )
import Distribution.Package
( PackageId, Package(..), InstalledPackageId(..) )
import Distribution.Simple.Compiler
@@ -117,6 +118,7 @@ data LocalBuildInfo = LocalBuildInfo {
-- ^ All the components to build, ordered by topological sort
-- over the intrapackage dependency graph
testSuiteConfigs :: [(String, ComponentLocalBuildInfo)],
+ benchmarkConfigs :: [(String, ComponentLocalBuildInfo)],
installedPkgs :: PackageIndex,
-- ^ All the info about the installed packages that the
-- current package depends on (directly or indirectly).
@@ -140,13 +142,19 @@ data LocalBuildInfo = LocalBuildInfo {
progSuffix :: PathTemplate -- ^Suffix to be appended to installed executables
} deriving (Read, Show)
--- | External package dependencies for the package as a whole, the union of the
--- individual 'targetPackageDeps'.
+-- | External package dependencies for the package as a whole. This is the
+-- union of the individual 'componentPackageDeps', less any internal deps.
externalPackageDeps :: LocalBuildInfo -> [(InstalledPackageId, PackageId)]
-externalPackageDeps lbi = nub $
+externalPackageDeps lbi = filter (not . internal . snd) $ nub $
-- TODO: what about non-buildable components?
- maybe [] componentPackageDeps (libraryConfig lbi)
- ++ concatMap (componentPackageDeps . snd) (executableConfigs lbi)
+ maybe [] componentPackageDeps (libraryConfig lbi)
+ ++ concatMap (componentPackageDeps . snd) (executableConfigs lbi)
+ ++ concatMap (componentPackageDeps . snd) (testSuiteConfigs lbi)
+ ++ concatMap (componentPackageDeps . snd) (benchmarkConfigs lbi)
+ where
+ -- True if this dependency is an internal one (depends on the library
+ -- defined in the same package).
+ internal pkgid = pkgid == packageId (localPkgDescr lbi)
-- | The installed package Id we use for local packages registered in the local
-- package db. This is what is used for intra-package deps between components.
@@ -157,14 +165,16 @@ inplacePackageId pkgid = InstalledPackageId (display pkgid ++ "-inplace")
-- -----------------------------------------------------------------------------
-- Buildable components
-data Component = CLib Library
- | CExe Executable
- | CTest TestSuite
+data Component = CLib Library
+ | CExe Executable
+ | CTest TestSuite
+ | CBench Benchmark
deriving (Show, Eq, Read)
-data ComponentName = CLibName -- currently only a single lib
- | CExeName String
- | CTestName String
+data ComponentName = CLibName -- currently only a single lib
+ | CExeName String
+ | CTestName String
+ | CBenchName String
deriving (Show, Eq, Read)
data ComponentLocalBuildInfo = ComponentLocalBuildInfo {
@@ -179,11 +189,17 @@ data ComponentLocalBuildInfo = ComponentLocalBuildInfo {
foldComponent :: (Library -> a)
-> (Executable -> a)
-> (TestSuite -> a)
+ -> (Benchmark -> a)
-> Component
-> a
-foldComponent f _ _ (CLib lib) = f lib
-foldComponent _ f _ (CExe exe) = f exe
-foldComponent _ _ f (CTest tst) = f tst
+foldComponent f _ _ _ (CLib lib) = f lib
+foldComponent _ f _ _ (CExe exe) = f exe
+foldComponent _ _ f _ (CTest tst) = f tst
+foldComponent _ _ _ f (CBench bch) = f bch
+
+componentBuildInfo :: Component -> BuildInfo
+componentBuildInfo =
+ foldComponent libBuildInfo buildInfo testBuildInfo benchmarkBuildInfo
-- | Obtains all components (libs, exes, or test suites), transformed by the
-- given function. Useful for gathering dependencies with component context.
@@ -198,6 +214,9 @@ allComponentsBy pkg_descr f =
++ [ f (CTest tst) | tst <- testSuites pkg_descr
, buildable (testBuildInfo tst)
, testEnabled tst ]
+ ++ [ f (CBench bm) | bm <- benchmarks pkg_descr
+ , buildable (benchmarkBuildInfo bm)
+ , benchmarkEnabled bm ]
-- |If the package description has a library section, call the given
-- function with the library build info as argument. Extended version of
@@ -264,8 +283,18 @@ withComponentsLBI pkg_descr lbi f = mapM_ compF (compBuildOrder lbi)
missingtest = "internal error: component list includes a test suite "
++ name ++ " but the package contains no such test suite."
+ compF (CBenchName name) =
+ case find (\bch -> benchmarkName bch == name) (benchmarks pkg_descr) of
+ Nothing -> die missingbench
+ Just bch -> case lookup name (benchmarkConfigs lbi) of
+ Nothing -> die (missingBenchConf name)
+ Just clbi -> f (CBench bch) clbi
+ where
+ missingbench = "internal error: component list includes a benchmark "
+ ++ name ++ " but the package contains no such benchmark."
+
missingLibConf :: String
-missingExeConf, missingTestConf :: String -> String
+missingExeConf, missingTestConf, missingBenchConf :: String -> String
missingLibConf = "internal error: the package contains a library "
++ "but there is no corresponding configuration data"
@@ -273,6 +302,8 @@ missingExeConf name = "internal error: the package contains an executable "
++ name ++ " but there is no corresponding configuration data"
missingTestConf name = "internal error: the package contains a test suite "
++ name ++ " but there is no corresponding configuration data"
+missingBenchConf name = "internal error: the package contains a benchmark "
+ ++ name ++ " but there is no corresponding configuration data"
-- -----------------------------------------------------------------------------
diff --git a/cabal/cabal/Distribution/Simple/NHC.hs b/cabal/Cabal/Distribution/Simple/NHC.hs
index 83ff384..83ff384 100644
--- a/cabal/cabal/Distribution/Simple/NHC.hs
+++ b/cabal/Cabal/Distribution/Simple/NHC.hs
diff --git a/cabal/cabal/Distribution/Simple/PackageIndex.hs b/cabal/Cabal/Distribution/Simple/PackageIndex.hs
index 9ee28f5..edb671f 100644
--- a/cabal/cabal/Distribution/Simple/PackageIndex.hs
+++ b/cabal/Cabal/Distribution/Simple/PackageIndex.hs
@@ -43,6 +43,7 @@ module Distribution.Simple.PackageIndex (
-- ** Bulk queries
allPackages,
allPackagesByName,
+ allPackagesBySourcePackageId,
-- ** Special queries
brokenPackages,
@@ -293,11 +294,22 @@ allPackages (PackageIndex pids _) = Map.elems pids
-- | Get all the packages from the index.
--
--- They are grouped by package name, case-sensitively.
+-- They are grouped by package name (case-sensitively).
--
-allPackagesByName :: PackageIndex -> [[InstalledPackageInfo]]
+allPackagesByName :: PackageIndex -> [(PackageName, [InstalledPackageInfo])]
allPackagesByName (PackageIndex _ pnames) =
- concatMap Map.elems (Map.elems pnames)
+ [ (pkgname, concat (Map.elems pvers))
+ | (pkgname, pvers) <- Map.toList pnames ]
+
+-- | Get all the packages from the index.
+--
+-- They are grouped by source package id (package name and version).
+--
+allPackagesBySourcePackageId :: PackageIndex -> [(PackageId, [InstalledPackageInfo])]
+allPackagesBySourcePackageId (PackageIndex _ pnames) =
+ [ (packageId ipkg, ipkgs)
+ | pvers <- Map.elems pnames
+ , ipkgs@(ipkg:_) <- Map.elems pvers ]
--
-- * Lookups
diff --git a/cabal/cabal/Distribution/Simple/PreProcess.hs b/cabal/Cabal/Distribution/Simple/PreProcess.hs
index 1c16d09..0c6cb3e 100644
--- a/cabal/cabal/Distribution/Simple/PreProcess.hs
+++ b/cabal/Cabal/Distribution/Simple/PreProcess.hs
@@ -66,7 +66,8 @@ import Distribution.PackageDescription as PD
, Executable(..)
, Library(..), libModules
, TestSuite(..), testModules
- , TestSuiteInterface(..) )
+ , TestSuiteInterface(..)
+ , Benchmark(..), benchmarkModules, BenchmarkInterface(..) )
import qualified Distribution.InstalledPackageInfo as Installed
( InstalledPackageInfo_(..) )
import qualified Distribution.Simple.PackageIndex as PackageIndex
@@ -209,6 +210,14 @@ preprocessComponent pd comp lbi isSrcDist verbosity handlers = case comp of
preProcessTest test (stubFilePath test) testDir
TestSuiteUnsupported tt -> die $ "No support for preprocessing test "
++ "suite type " ++ display tt
+ CBench bm@Benchmark{ benchmarkName = nm } -> do
+ setupMessage verbosity ("Preprocessing benchmark '" ++ nm ++ "' for") (packageId pd)
+ case benchmarkInterface bm of
+ BenchmarkExeV10 _ f ->
+ preProcessBench bm f $ buildDir lbi </> benchmarkName bm
+ </> benchmarkName bm ++ "-tmp"
+ BenchmarkUnsupported tt -> die $ "No support for preprocessing benchmark "
+ ++ "type " ++ display tt
where
builtinSuffixes
| NHC == compilerFlavor (compiler lbi) = ["hs", "lhs", "gc"]
@@ -216,15 +225,18 @@ preprocessComponent pd comp lbi isSrcDist verbosity handlers = case comp of
localHandlers bi = [(ext, h bi lbi) | (ext, h) <- handlers]
pre dirs dir lhndlrs fp =
preprocessFile dirs dir isSrcDist fp verbosity builtinSuffixes lhndlrs
- preProcessTest test exePath testDir = do
- let bi = testBuildInfo test
- biHandlers = localHandlers bi
+ preProcessTest test = preProcessComponent (testBuildInfo test)
+ (testModules test)
+ preProcessBench bm = preProcessComponent (benchmarkBuildInfo bm)
+ (benchmarkModules bm)
+ preProcessComponent bi modules exePath dir = do
+ let biHandlers = localHandlers bi
sourceDirs = hsSourceDirs bi ++ [ autogenModulesDir lbi ]
sequence_ [ preprocessFile sourceDirs (buildDir lbi) isSrcDist
(ModuleName.toFilePath modu) verbosity builtinSuffixes
biHandlers
- | modu <- testModules test ]
- preprocessFile (testDir : (hsSourceDirs bi)) testDir isSrcDist
+ | modu <- modules ]
+ preprocessFile (dir : (hsSourceDirs bi)) dir isSrcDist
(dropExtensions $ exePath) verbosity
builtinSuffixes biHandlers
diff --git a/cabal/cabal/Distribution/Simple/PreProcess/Unlit.hs b/cabal/Cabal/Distribution/Simple/PreProcess/Unlit.hs
index d1b4123..d1b4123 100644
--- a/cabal/cabal/Distribution/Simple/PreProcess/Unlit.hs
+++ b/cabal/Cabal/Distribution/Simple/PreProcess/Unlit.hs
diff --git a/cabal/cabal/Distribution/Simple/Program.hs b/cabal/Cabal/Distribution/Simple/Program.hs
index 90f0002..c57d553 100644
--- a/cabal/cabal/Distribution/Simple/Program.hs
+++ b/cabal/Cabal/Distribution/Simple/Program.hs
@@ -110,6 +110,7 @@ module Distribution.Simple.Program (
, tarProgram
, cppProgram
, pkgConfigProgram
+ , hpcProgram
-- * deprecated
, rawSystemProgram
diff --git a/cabal/cabal/Distribution/Simple/Program/Ar.hs b/cabal/Cabal/Distribution/Simple/Program/Ar.hs
index ea68dba..ea68dba 100644
--- a/cabal/cabal/Distribution/Simple/Program/Ar.hs
+++ b/cabal/Cabal/Distribution/Simple/Program/Ar.hs
diff --git a/cabal/cabal/Distribution/Simple/Program/Builtin.hs b/cabal/Cabal/Distribution/Simple/Program/Builtin.hs
index 6f46167..48446fa 100644
--- a/cabal/cabal/Distribution/Simple/Program/Builtin.hs
+++ b/cabal/Cabal/Distribution/Simple/Program/Builtin.hs
@@ -42,6 +42,7 @@ module Distribution.Simple.Program.Builtin (
tarProgram,
cppProgram,
pkgConfigProgram,
+ hpcProgram,
) where
import Distribution.Simple.Program.Types
@@ -69,6 +70,7 @@ builtinPrograms =
, lhcProgram
, lhcPkgProgram
, uhcProgram
+ , hpcProgram
-- preprocessors
, hscolourProgram
, haddockProgram
@@ -155,6 +157,14 @@ uhcProgram = (simpleProgram "uhc") {
programFindVersion = findProgramVersion "--version-dotted" id
}
+hpcProgram :: Program
+hpcProgram = (simpleProgram "hpc")
+ {
+ programFindVersion = findProgramVersion "version" $ \str ->
+ case words str of
+ (_ : _ : _ : ver : _) -> ver
+ _ -> ""
+ }
-- AArgh! Finding the version of hugs or ffihugs is almost impossible.
hugsProgram :: Program
diff --git a/cabal/cabal/Distribution/Simple/Program/Db.hs b/cabal/Cabal/Distribution/Simple/Program/Db.hs
index c01cf74..c01cf74 100644
--- a/cabal/cabal/Distribution/Simple/Program/Db.hs
+++ b/cabal/Cabal/Distribution/Simple/Program/Db.hs
diff --git a/cabal/Cabal/Distribution/Simple/Program/GHC.hs b/cabal/Cabal/Distribution/Simple/Program/GHC.hs
new file mode 100644
index 0000000..340c04e
--- /dev/null
+++ b/cabal/Cabal/Distribution/Simple/Program/GHC.hs
@@ -0,0 +1,458 @@
+module Distribution.Simple.Program.GHC (
+ GhcOptions(..),
+ GhcMode(..),
+ GhcOptimisation(..),
+
+ ghcInvocation,
+ renderGhcOptions,
+
+ runGHC,
+
+ ) where
+
+import Distribution.Package
+import Distribution.ModuleName
+import Distribution.Simple.Compiler hiding (Flag)
+import Distribution.Simple.Setup (Flag(..), flagToMaybe, fromFlagOrDefault, flagToList)
+--import Distribution.Simple.LocalBuildInfo
+import Distribution.Simple.Program.Types
+import Distribution.Simple.Program.Run
+import Distribution.Text
+import Distribution.Verbosity
+import Distribution.Version
+import Language.Haskell.Extension ( Language(..), Extension(..) )
+
+import Data.Monoid
+
+
+-- | A structured set of GHC options/flags
+--
+data GhcOptions = GhcOptions {
+
+ -- | The major mode for the ghc invocation.
+ ghcOptMode :: Flag GhcMode,
+
+ -- | Any extra options to pass directly to ghc. These go at the end and hence
+ -- override other stuff.
+ ghcOptExtra :: [String],
+
+ -- | Extra default flags to pass directly to ghc. These go at the beginning
+ -- and so can be overridden by other stuff.
+ ghcOptExtraDefault :: [String],
+
+ -----------------------
+ -- Inputs and outputs
+
+ -- | The main input files; could be .hs, .hi, .c, .o, depending on mode.
+ ghcOptInputFiles :: [FilePath],
+
+ -- | The names of input Haskell modules, mainly for @--make@ mode.
+ ghcOptInputModules :: [ModuleName],
+
+ -- | Location for output file; the @ghc -o@ flag.
+ ghcOptOutputFile :: Flag FilePath,
+
+ -- | Start with an empty search path for Haskell source files;
+ -- the @ghc -i@ flag (@-i@ on it's own with no path argument).
+ ghcOptSourcePathClear :: Flag Bool,
+
+ -- | Search path for Haskell source files; the @ghc -i@ flag.
+ ghcOptSourcePath :: [FilePath],
+
+ -------------
+ -- Packages
+
+ -- | The package name the modules will belong to; the @ghc -package-name@ flag
+ ghcOptPackageName :: Flag PackageId,
+
+ -- | GHC package databases to use, the @ghc -package-conf@ flag
+ ghcOptPackageDBs :: PackageDBStack,
+
+ -- | The GHC packages to use. For compatability with old and new ghc, this
+ -- requires both the short and long form of the package id;
+ -- the @ghc -package@ or @ghc -package-id@ flags.
+ ghcOptPackages :: [(InstalledPackageId, PackageId)],
+
+ -- | Start with a clean package set; the @ghc -hide-all-packages@ flag
+ ghcOptHideAllPackages :: Flag Bool,
+
+ -- | Don't automatically link in Haskell98 etc; the @ghc -no-auto-link-packages@ flag.
+ ghcOptNoAutoLinkPackages :: Flag Bool,
+
+ -----------------
+ -- Linker stuff
+
+ -- | Names of libraries to link in; the @ghc -l@ flag.
+ ghcOptLinkLibs :: [FilePath],
+
+ -- | Search path for libraries to link in; the @ghc -L@ flag.
+ ghcOptLinkLibPath :: [FilePath],
+
+ -- | Options to pass through to the linker; the @ghc -optl@ flag.
+ ghcOptLinkOptions :: [String],
+
+ -- | OSX only: frameworks to link in; the @ghc -framework@ flag.
+ ghcOptLinkFrameworks :: [String],
+
+ -- | Don't do the link step, useful in make mode; the @ghc -no-link@ flag.
+ ghcOptNoLink :: Flag Bool,
+
+ --------------------
+ -- C and CPP stuff
+
+ -- | Options to pass through to the C compiler; the @ghc -optc@ flag.
+ ghcOptCcOptions :: [String],
+
+ -- | Options to pass through to CPP; the @ghc -optP@ flag.
+ ghcOptCppOptions :: [String],
+
+ -- | Search path for CPP includes like header files; the @ghc -I@ flag.
+ ghcOptCppIncludePath :: [FilePath],
+
+ -- | Extra header files to include at CPP stage; the @ghc -optP-include@ flag.
+ ghcOptCppIncludes :: [FilePath],
+
+ -- | Extra header files to include for old-style FFI; the @ghc -#include@ flag.
+ ghcOptFfiIncludes :: [FilePath],
+
+ ----------------------------
+ -- Language and extensions
+
+ -- | The base language; the @ghc -XHaskell98@ or @-XHaskell2010@ flag.
+ ghcOptLanguage :: Flag Language,
+
+ -- | The language extensions; the @ghc -X@ flag.
+ ghcOptExtensions :: [Extension],
+
+ -- | A GHC version-dependent mapping of extensions to flags. This must be
+ -- set to be able to make use of the 'ghcOptExtensions'.
+ ghcOptExtensionMap :: [(Extension, String)],
+
+ ----------------
+ -- Compilation
+
+ -- | What optimisation level to use; the @ghc -O@ flag.
+ ghcOptOptimisation :: Flag GhcOptimisation,
+
+ -- | Compile in profiling mode; the @ghc -prof@ flag.
+ ghcOptProfilingMode :: Flag Bool,
+
+ -- | Use the \"split object files\" feature; the @ghc -split-objs@ flag.
+ ghcOptSplitObjs :: Flag Bool,
+
+ ----------------
+ -- GHCi
+
+ -- | Extra GHCi startup scripts; the @-ghci-script@ flag
+ ghcOptGHCiScripts :: [FilePath],
+
+ ------------------------
+ -- Redirecting outputs
+
+ ghcOptHiSuffix :: Flag String,
+ ghcOptObjSuffix :: Flag String,
+ ghcOptHiDir :: Flag FilePath,
+ ghcOptObjDir :: Flag FilePath,
+ ghcOptStubDir :: Flag FilePath,
+
+ --------------------
+ -- Dynamic linking
+
+ ghcOptDynamic :: Flag Bool,
+ ghcOptShared :: Flag Bool,
+ ghcOptFPic :: Flag Bool,
+ ghcOptDylibName :: Flag String,
+
+ ---------------
+ -- Misc flags
+
+ -- | Get GHC to be quiet or verbose with what it's doing; the @ghc -v@ flag.
+ ghcOptVerbosity :: Flag Verbosity,
+
+ -- | Let GHC know that it is Cabal that's calling it.
+ -- Modifies some of the GHC error messages.
+ ghcOptCabal :: Flag Bool
+
+} deriving Show
+
+
+data GhcMode = GhcModeCompile -- ^ @ghc -c@
+ | GhcModeLink -- ^ @ghc@
+ | GhcModeMake -- ^ @ghc --make@
+ | GhcModeInteractive -- ^ @ghci@ \/ @ghc --interactive@
+ | GhcModeAbiHash -- ^ @ghc --abi-hash@
+-- | GhcModeDepAnalysis -- ^ @ghc -M@
+-- | GhcModeEvaluate -- ^ @ghc -e@
+ deriving (Show, Eq)
+
+data GhcOptimisation = GhcNoOptimisation -- ^ @-O0@
+ | GhcNormalOptimisation -- ^ @-O@
+ | GhcMaximumOptimisation -- ^ @-O2@
+ | GhcSpecialOptimisation String -- ^ e.g. @-Odph@
+ deriving (Show, Eq)
+
+
+runGHC :: Verbosity -> ConfiguredProgram -> GhcOptions -> IO ()
+runGHC verbosity ghcProg opts = do
+ runProgramInvocation verbosity (ghcInvocation ghcProg opts)
+
+
+ghcInvocation :: ConfiguredProgram -> GhcOptions -> ProgramInvocation
+ghcInvocation ConfiguredProgram { programVersion = Nothing } _ =
+ error "ghcInvocation: the programVersion must not be Nothing"
+ghcInvocation prog@ConfiguredProgram { programVersion = Just ver } opts =
+ programInvocation prog (renderGhcOptions ver opts)
+
+
+renderGhcOptions :: Version -> GhcOptions -> [String]
+renderGhcOptions version@(Version ver _) opts =
+ concat
+ [ case flagToMaybe (ghcOptMode opts) of
+ Nothing -> []
+ Just GhcModeCompile -> ["-c"]
+ Just GhcModeLink -> []
+ Just GhcModeMake -> ["--make"]
+ Just GhcModeInteractive -> ["--interactive"]
+ Just GhcModeAbiHash -> ["--abi-hash"]
+-- Just GhcModeDepAnalysis -> ["-M"]
+-- Just GhcModeEvaluate -> ["-e", expr]
+
+ , flags ghcOptExtraDefault
+
+ , [ "-no-link" | flagBool ghcOptNoLink ]
+
+ ---------------
+ -- Misc flags
+
+ , maybe [] verbosityOpts (flagToMaybe (ghcOptVerbosity opts))
+
+ , [ "-fbuilding-cabal-package" | flagBool ghcOptCabal, ver >= [6,11] ]
+
+ ----------------
+ -- Compilation
+
+ , case flagToMaybe (ghcOptOptimisation opts) of
+ Nothing -> []
+ Just GhcNoOptimisation -> ["-O0"]
+ Just GhcNormalOptimisation -> ["-O"]
+ Just GhcMaximumOptimisation -> ["-O2"]
+ Just (GhcSpecialOptimisation s) -> ["-O" ++ s] -- eg -Odph
+
+ , [ "-prof" | flagBool ghcOptProfilingMode ]
+
+ , [ "-split-objs" | flagBool ghcOptSplitObjs ]
+
+ --------------------
+ -- Dynamic linking
+
+ , [ "-shared" | flagBool ghcOptShared ]
+ , [ "-dynamic" | flagBool ghcOptDynamic ]
+ , [ "-fPIC" | flagBool ghcOptFPic ]
+
+ , concat [ ["-dylib-install-name", libname] | libname <- flag ghcOptDylibName ]
+
+ ------------------------
+ -- Redirecting outputs
+
+ , concat [ ["-osuf", suf] | suf <- flag ghcOptObjSuffix ]
+ , concat [ ["-hisuf", suf] | suf <- flag ghcOptHiSuffix ]
+ , concat [ ["-odir", dir] | dir <- flag ghcOptObjDir ]
+ , concat [ ["-hidir", dir] | dir <- flag ghcOptHiDir ]
+ , concat [ ["-stubdir", dir] | dir <- flag ghcOptStubDir, ver >= [6,8] ]
+
+ -----------------------
+ -- Source search path
+
+ , [ "-i" | flagBool ghcOptSourcePathClear ]
+ , [ "-i" ++ dir | dir <- flags ghcOptSourcePath ]
+
+ --------------------
+ -- C and CPP stuff
+
+ , [ "-I" ++ dir | dir <- flags ghcOptCppIncludePath ]
+ , [ "-optP" ++ opt | opt <- flags ghcOptCppOptions ]
+ , concat [ [ "-optP-include", "-optP" ++ inc] | inc <- flags ghcOptCppIncludes ]
+ , [ "-#include \"" ++ inc ++ "\"" | inc <- flags ghcOptFfiIncludes, ver < [6,11] ]
+ , [ "-optc" ++ opt | opt <- flags ghcOptCcOptions ]
+
+ -----------------
+ -- Linker stuff
+
+ , [ "-optl" ++ opt | opt <- flags ghcOptLinkOptions ]
+ , ["-l" ++ lib | lib <- flags ghcOptLinkLibs ]
+ , ["-L" ++ dir | dir <- flags ghcOptLinkLibPath ]
+ , concat [ ["-framework", fmwk] | fmwk <- flags ghcOptLinkFrameworks ]
+
+ -------------
+ -- Packages
+
+ , concat [ ["-package-name", display pkgid] | pkgid <- flag ghcOptPackageName ]
+
+ , [ "-hide-all-packages" | flagBool ghcOptHideAllPackages ]
+ , [ "-no-auto-link-packages" | flagBool ghcOptNoAutoLinkPackages ]
+
+ , packageDbArgs version (flags ghcOptPackageDBs)
+
+ , concat $ if ver >= [6,11]
+ then [ ["-package-id", display ipkgid] | (ipkgid,_) <- flags ghcOptPackages ]
+ else [ ["-package", display pkgid] | (_,pkgid) <- flags ghcOptPackages ]
+
+ ----------------------------
+ -- Language and extensions
+
+ , if ver >= [7]
+ then [ "-X" ++ display lang | lang <- flag ghcOptLanguage ]
+ else []
+
+ , [ case lookup ext (ghcOptExtensionMap opts) of
+ Just arg -> arg
+ Nothing -> error $ "renderGhcOptions: " ++ display ext
+ ++ " not present in ghcOptExtensionMap."
+ | ext <- ghcOptExtensions opts ]
+
+ ----------------
+ -- GHCi
+
+ , concat [ [ "-ghci-script", script ] | script <- flags ghcOptGHCiScripts
+ , ver >= [7,2] ]
+
+ ---------------
+ -- Inputs
+
+ , [ display modu | modu <- flags ghcOptInputModules ]
+ , ghcOptInputFiles opts
+
+ , concat [ [ "-o", out] | out <- flag ghcOptOutputFile ]
+
+ ---------------
+ -- Extra
+
+ , ghcOptExtra opts
+
+ ]
+
+
+ where
+ flag flg = flagToList (flg opts)
+ flags flg = flg opts
+ flagBool flg = fromFlagOrDefault False (flg opts)
+
+
+verbosityOpts :: Verbosity -> [String]
+verbosityOpts verbosity
+ | verbosity >= deafening = ["-v"]
+ | verbosity >= normal = []
+ | otherwise = ["-w", "-v0"]
+
+
+packageDbArgs :: Version -> PackageDBStack -> [String]
+packageDbArgs (Version ver _) dbstack = case dbstack of
+ (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs
+ (GlobalPackageDB:dbs) -> ("-no-user-" ++ packageDbFlag)
+ : concatMap specific dbs
+ _ -> ierror
+ where
+ specific (SpecificPackageDB db) = [ '-':packageDbFlag , db ]
+ specific _ = ierror
+ ierror = error $ "internal error: unexpected package db stack: "
+ ++ show dbstack
+
+ packageDbFlag
+ | ver < [7,5]
+ = "package-conf"
+ | otherwise
+ = "package-db"
+
+
+-- -----------------------------------------------------------------------------
+-- Boilerplate Monoid instance for GhcOptions
+
+instance Monoid GhcOptions where
+ mempty = GhcOptions {
+ ghcOptMode = mempty,
+ ghcOptExtra = mempty,
+ ghcOptExtraDefault = mempty,
+ ghcOptInputFiles = mempty,
+ ghcOptInputModules = mempty,
+ ghcOptOutputFile = mempty,
+ ghcOptSourcePathClear = mempty,
+ ghcOptSourcePath = mempty,
+ ghcOptPackageName = mempty,
+ ghcOptPackageDBs = mempty,
+ ghcOptPackages = mempty,
+ ghcOptHideAllPackages = mempty,
+ ghcOptNoAutoLinkPackages = mempty,
+ ghcOptLinkLibs = mempty,
+ ghcOptLinkLibPath = mempty,
+ ghcOptLinkOptions = mempty,
+ ghcOptLinkFrameworks = mempty,
+ ghcOptNoLink = mempty,
+ ghcOptCcOptions = mempty,
+ ghcOptCppOptions = mempty,
+ ghcOptCppIncludePath = mempty,
+ ghcOptCppIncludes = mempty,
+ ghcOptFfiIncludes = mempty,
+ ghcOptLanguage = mempty,
+ ghcOptExtensions = mempty,
+ ghcOptExtensionMap = mempty,
+ ghcOptOptimisation = mempty,
+ ghcOptProfilingMode = mempty,
+ ghcOptSplitObjs = mempty,
+ ghcOptGHCiScripts = mempty,
+ ghcOptHiSuffix = mempty,
+ ghcOptObjSuffix = mempty,
+ ghcOptHiDir = mempty,
+ ghcOptObjDir = mempty,
+ ghcOptStubDir = mempty,
+ ghcOptDynamic = mempty,
+ ghcOptShared = mempty,
+ ghcOptFPic = mempty,
+ ghcOptDylibName = mempty,
+ ghcOptVerbosity = mempty,
+ ghcOptCabal = mempty
+ }
+ mappend a b = GhcOptions {
+ ghcOptMode = combine ghcOptMode,
+ ghcOptExtra = combine ghcOptExtra,
+ ghcOptExtraDefault = combine ghcOptExtraDefault,
+ ghcOptInputFiles = combine ghcOptInputFiles,
+ ghcOptInputModules = combine ghcOptInputModules,
+ ghcOptOutputFile = combine ghcOptOutputFile,
+ ghcOptSourcePathClear = combine ghcOptSourcePathClear,
+ ghcOptSourcePath = combine ghcOptSourcePath,
+ ghcOptPackageName = combine ghcOptPackageName,
+ ghcOptPackageDBs = combine ghcOptPackageDBs,
+ ghcOptPackages = combine ghcOptPackages,
+ ghcOptHideAllPackages = combine ghcOptHideAllPackages,
+ ghcOptNoAutoLinkPackages = combine ghcOptNoAutoLinkPackages,
+ ghcOptLinkLibs = combine ghcOptLinkLibs,
+ ghcOptLinkLibPath = combine ghcOptLinkLibPath,
+ ghcOptLinkOptions = combine ghcOptLinkOptions,
+ ghcOptLinkFrameworks = combine ghcOptLinkFrameworks,
+ ghcOptNoLink = combine ghcOptNoLink,
+ ghcOptCcOptions = combine ghcOptCcOptions,
+ ghcOptCppOptions = combine ghcOptCppOptions,
+ ghcOptCppIncludePath = combine ghcOptCppIncludePath,
+ ghcOptCppIncludes = combine ghcOptCppIncludes,
+ ghcOptFfiIncludes = combine ghcOptFfiIncludes,
+ ghcOptLanguage = combine ghcOptLanguage,
+ ghcOptExtensions = combine ghcOptExtensions,
+ ghcOptExtensionMap = combine ghcOptExtensionMap,
+ ghcOptOptimisation = combine ghcOptOptimisation,
+ ghcOptProfilingMode = combine ghcOptProfilingMode,
+ ghcOptSplitObjs = combine ghcOptSplitObjs,
+ ghcOptGHCiScripts = combine ghcOptGHCiScripts,
+ ghcOptHiSuffix = combine ghcOptHiSuffix,
+ ghcOptObjSuffix = combine ghcOptObjSuffix,
+ ghcOptHiDir = combine ghcOptHiDir,
+ ghcOptObjDir = combine ghcOptObjDir,
+ ghcOptStubDir = combine ghcOptStubDir,
+ ghcOptDynamic = combine ghcOptDynamic,
+ ghcOptShared = combine ghcOptShared,
+ ghcOptFPic = combine ghcOptFPic,
+ ghcOptDylibName = combine ghcOptDylibName,
+ ghcOptVerbosity = combine ghcOptVerbosity,
+ ghcOptCabal = combine ghcOptCabal
+ }
+ where
+ combine field = field a `mappend` field b
diff --git a/cabal/cabal/Distribution/Simple/Program/HcPkg.hs b/cabal/Cabal/Distribution/Simple/Program/HcPkg.hs
index d5061d9..de01a47 100644
--- a/cabal/cabal/Distribution/Simple/Program/HcPkg.hs
+++ b/cabal/Cabal/Distribution/Simple/Program/HcPkg.hs
@@ -10,6 +10,7 @@
-- Currently only GHC and LHC have hc-pkg programs.
module Distribution.Simple.Program.HcPkg (
+ init,
register,
reregister,
unregister,
@@ -18,6 +19,7 @@ module Distribution.Simple.Program.HcPkg (
dump,
-- * Program invocations
+ initInvocation,
registerInvocation,
reregisterInvocation,
unregisterInvocation,
@@ -26,6 +28,7 @@ module Distribution.Simple.Program.HcPkg (
dumpInvocation,
) where
+import Prelude hiding (init)
import Distribution.Package
( PackageId, InstalledPackageId(..) )
import Distribution.InstalledPackageInfo
@@ -62,9 +65,18 @@ import System.FilePath as FilePath
import qualified System.FilePath.Posix as FilePath.Posix
+-- | Call @hc-pkg@ to initialise a package database at the location {path}.
+--
+-- > hc-pkg init {path}
+--
+init :: Verbosity -> ConfiguredProgram -> FilePath -> IO ()
+init verbosity hcPkg path =
+ runProgramInvocation verbosity
+ (initInvocation hcPkg verbosity path)
+
-- | Call @hc-pkg@ to register a package.
--
--- > hc-pkg register {filename | -} [--user | --global | --package-conf]
+-- > hc-pkg register {filename | -} [--user | --global | --package-db]
--
register :: Verbosity -> ConfiguredProgram -> PackageDBStack
-> Either FilePath
@@ -77,7 +89,7 @@ register verbosity hcPkg packagedb pkgFile =
-- | Call @hc-pkg@ to re-register a package.
--
--- > hc-pkg register {filename | -} [--user | --global | --package-conf]
+-- > hc-pkg register {filename | -} [--user | --global | --package-db]
--
reregister :: Verbosity -> ConfiguredProgram -> PackageDBStack
-> Either FilePath
@@ -90,7 +102,7 @@ reregister verbosity hcPkg packagedb pkgFile =
-- | Call @hc-pkg@ to unregister a package
--
--- > hc-pkg unregister [pkgid] [--user | --global | --package-conf]
+-- > hc-pkg unregister [pkgid] [--user | --global | --package-db]
--
unregister :: Verbosity -> ConfiguredProgram -> PackageDB -> PackageId -> IO ()
unregister verbosity hcPkg packagedb pkgid =
@@ -100,7 +112,7 @@ unregister verbosity hcPkg packagedb pkgid =
-- | Call @hc-pkg@ to expose a package.
--
--- > hc-pkg expose [pkgid] [--user | --global | --package-conf]
+-- > hc-pkg expose [pkgid] [--user | --global | --package-db]
--
expose :: Verbosity -> ConfiguredProgram -> PackageDB -> PackageId -> IO ()
expose verbosity hcPkg packagedb pkgid =
@@ -110,7 +122,7 @@ expose verbosity hcPkg packagedb pkgid =
-- | Call @hc-pkg@ to expose a package.
--
--- > hc-pkg expose [pkgid] [--user | --global | --package-conf]
+-- > hc-pkg expose [pkgid] [--user | --global | --package-db]
--
hide :: Verbosity -> ConfiguredProgram -> PackageDB -> PackageId -> IO ()
hide verbosity hcPkg packagedb pkgid =
@@ -228,6 +240,14 @@ setInstalledPackageId pkginfo = pkginfo
-- The program invocations
--
+initInvocation :: ConfiguredProgram
+ -> Verbosity -> FilePath -> ProgramInvocation
+initInvocation hcPkg verbosity path =
+ programInvocation hcPkg args
+ where
+ args = ["init", path]
+ ++ verbosityOpts hcPkg verbosity
+
registerInvocation, reregisterInvocation
:: ConfiguredProgram -> Verbosity -> PackageDBStack
-> Either FilePath InstalledPackageInfo
@@ -245,8 +265,8 @@ registerInvocation' cmdname hcPkg verbosity packagedbs (Left pkgFile) =
where
args = [cmdname, pkgFile]
++ (if legacyVersion hcPkg
- then [packageDbOpts (last packagedbs)]
- else packageDbStackOpts packagedbs)
+ then [packageDbOpts hcPkg (last packagedbs)]
+ else packageDbStackOpts hcPkg packagedbs)
++ verbosityOpts hcPkg verbosity
registerInvocation' cmdname hcPkg verbosity packagedbs (Right pkgInfo) =
@@ -257,8 +277,8 @@ registerInvocation' cmdname hcPkg verbosity packagedbs (Right pkgInfo) =
where
args = [cmdname, "-"]
++ (if legacyVersion hcPkg
- then [packageDbOpts (last packagedbs)]
- else packageDbStackOpts packagedbs)
+ then [packageDbOpts hcPkg (last packagedbs)]
+ else packageDbStackOpts hcPkg packagedbs)
++ verbosityOpts hcPkg verbosity
@@ -267,7 +287,7 @@ unregisterInvocation :: ConfiguredProgram
-> ProgramInvocation
unregisterInvocation hcPkg verbosity packagedb pkgid =
programInvocation hcPkg $
- ["unregister", packageDbOpts packagedb, display pkgid]
+ ["unregister", packageDbOpts hcPkg packagedb, display pkgid]
++ verbosityOpts hcPkg verbosity
@@ -275,7 +295,7 @@ exposeInvocation :: ConfiguredProgram
-> Verbosity -> PackageDB -> PackageId -> ProgramInvocation
exposeInvocation hcPkg verbosity packagedb pkgid =
programInvocation hcPkg $
- ["expose", packageDbOpts packagedb, display pkgid]
+ ["expose", packageDbOpts hcPkg packagedb, display pkgid]
++ verbosityOpts hcPkg verbosity
@@ -283,7 +303,7 @@ hideInvocation :: ConfiguredProgram
-> Verbosity -> PackageDB -> PackageId -> ProgramInvocation
hideInvocation hcPkg verbosity packagedb pkgid =
programInvocation hcPkg $
- ["hide", packageDbOpts packagedb, display pkgid]
+ ["hide", packageDbOpts hcPkg packagedb, display pkgid]
++ verbosityOpts hcPkg verbosity
@@ -294,31 +314,38 @@ dumpInvocation hcPkg _verbosity packagedb =
progInvokeOutputEncoding = IOEncodingUTF8
}
where
- args = ["dump", packageDbOpts packagedb]
+ args = ["dump", packageDbOpts hcPkg packagedb]
++ verbosityOpts hcPkg silent
-- We use verbosity level 'silent' because it is important that we
-- do not contaminate the output with info/debug messages.
-packageDbStackOpts :: PackageDBStack -> [String]
-packageDbStackOpts dbstack = case dbstack of
+packageDbStackOpts :: ConfiguredProgram -> PackageDBStack -> [String]
+packageDbStackOpts hcPkg dbstack = case dbstack of
(GlobalPackageDB:UserPackageDB:dbs) -> "--global"
: "--user"
: map specific dbs
(GlobalPackageDB:dbs) -> "--global"
- : "--no-user-package-conf"
+ : ("--no-user-" ++ packageDbFlag hcPkg)
: map specific dbs
_ -> ierror
where
- specific (SpecificPackageDB db) = "--package-conf=" ++ db
+ specific (SpecificPackageDB db) = "--" ++ packageDbFlag hcPkg ++ "=" ++ db
specific _ = ierror
ierror :: a
ierror = error ("internal error: unexpected package db stack: " ++ show dbstack)
-packageDbOpts :: PackageDB -> String
-packageDbOpts GlobalPackageDB = "--global"
-packageDbOpts UserPackageDB = "--user"
-packageDbOpts (SpecificPackageDB db) = "--package-conf=" ++ db
+packageDbFlag :: ConfiguredProgram -> String
+packageDbFlag hcPkg
+ | programVersion hcPkg < Just (Version [7,5] [])
+ = "package-conf"
+ | otherwise
+ = "package-db"
+
+packageDbOpts :: ConfiguredProgram -> PackageDB -> String
+packageDbOpts _ GlobalPackageDB = "--global"
+packageDbOpts _ UserPackageDB = "--user"
+packageDbOpts hcPkg (SpecificPackageDB db) = "--" ++ packageDbFlag hcPkg ++ "=" ++ db
verbosityOpts :: ConfiguredProgram -> Verbosity -> [String]
verbosityOpts hcPkg v
diff --git a/cabal/Cabal/Distribution/Simple/Program/Hpc.hs b/cabal/Cabal/Distribution/Simple/Program/Hpc.hs
new file mode 100644
index 0000000..9de5c64
--- /dev/null
+++ b/cabal/Cabal/Distribution/Simple/Program/Hpc.hs
@@ -0,0 +1,73 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Simple.Program.Hpc
+-- Copyright : Thomas Tuegel 2011
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Portability : portable
+--
+-- This module provides an library interface to the @hpc@ program.
+
+module Distribution.Simple.Program.Hpc
+ ( markup
+ , union
+ ) where
+
+import Distribution.ModuleName ( ModuleName )
+import Distribution.Simple.Program.Run
+ ( ProgramInvocation, programInvocation, runProgramInvocation )
+import Distribution.Simple.Program.Types ( ConfiguredProgram )
+import Distribution.Text ( display )
+import Distribution.Verbosity ( Verbosity )
+
+markup :: ConfiguredProgram
+ -> Verbosity
+ -> FilePath -- ^ Path to .tix file
+ -> FilePath -- ^ Path to directory with .mix files
+ -> FilePath -- ^ Path where html output should be located
+ -> [ModuleName] -- ^ List of modules to exclude from report
+ -> IO ()
+markup hpc verbosity tixFile hpcDir destDir excluded =
+ runProgramInvocation verbosity
+ (markupInvocation hpc tixFile hpcDir destDir excluded)
+
+markupInvocation :: ConfiguredProgram
+ -> FilePath -- ^ Path to .tix file
+ -> FilePath -- ^ Path to directory with .mix files
+ -> FilePath -- ^ Path where html output should be
+ -- located
+ -> [ModuleName] -- ^ List of modules to exclude from
+ -- report
+ -> ProgramInvocation
+markupInvocation hpc tixFile hpcDir destDir excluded =
+ let args = [ "markup", tixFile
+ , "--hpcdir=" ++ hpcDir
+ , "--destdir=" ++ destDir
+ ]
+ ++ ["--exclude=" ++ display moduleName
+ | moduleName <- excluded ]
+ in programInvocation hpc args
+
+union :: ConfiguredProgram
+ -> Verbosity
+ -> [FilePath] -- ^ Paths to .tix files
+ -> FilePath -- ^ Path to resultant .tix file
+ -> [ModuleName] -- ^ List of modules to exclude from union
+ -> IO ()
+union hpc verbosity tixFiles outFile excluded =
+ runProgramInvocation verbosity
+ (unionInvocation hpc tixFiles outFile excluded)
+
+unionInvocation :: ConfiguredProgram
+ -> [FilePath] -- ^ Paths to .tix files
+ -> FilePath -- ^ Path to resultant .tix file
+ -> [ModuleName] -- ^ List of modules to exclude from union
+ -> ProgramInvocation
+unionInvocation hpc tixFiles outFile excluded =
+ programInvocation hpc $ concat
+ [ ["sum", "--union"]
+ , tixFiles
+ , ["--output=" ++ outFile]
+ , ["--exclude=" ++ display moduleName
+ | moduleName <- excluded ]
+ ]
diff --git a/cabal/cabal/Distribution/Simple/Program/Ld.hs b/cabal/Cabal/Distribution/Simple/Program/Ld.hs
index 8d9737d..8d9737d 100644
--- a/cabal/cabal/Distribution/Simple/Program/Ld.hs
+++ b/cabal/Cabal/Distribution/Simple/Program/Ld.hs
diff --git a/cabal/cabal/Distribution/Simple/Program/Run.hs b/cabal/Cabal/Distribution/Simple/Program/Run.hs
index 5ab689e..5ab689e 100644
--- a/cabal/cabal/Distribution/Simple/Program/Run.hs
+++ b/cabal/Cabal/Distribution/Simple/Program/Run.hs
diff --git a/cabal/cabal/Distribution/Simple/Program/Script.hs b/cabal/Cabal/Distribution/Simple/Program/Script.hs
index 71b3cf1..71b3cf1 100644
--- a/cabal/cabal/Distribution/Simple/Program/Script.hs
+++ b/cabal/Cabal/Distribution/Simple/Program/Script.hs
diff --git a/cabal/cabal/Distribution/Simple/Program/Types.hs b/cabal/Cabal/Distribution/Simple/Program/Types.hs
index 0ad7b36..fc3f553 100644
--- a/cabal/cabal/Distribution/Simple/Program/Types.hs
+++ b/cabal/Cabal/Distribution/Simple/Program/Types.hs
@@ -17,7 +17,6 @@
module Distribution.Simple.Program.Types (
-- * Program and functions for constructing them
Program(..),
- internalProgram,
simpleProgram,
-- * Configured program and related functions
@@ -25,19 +24,21 @@ module Distribution.Simple.Program.Types (
programPath,
ProgArg,
ProgramLocation(..),
+ simpleConfiguredProgram,
) where
-import Data.List (nub)
-import System.FilePath ((</>))
-
import Distribution.Simple.Utils
- ( findProgramLocation, findFirstFile )
+ ( findProgramLocation )
import Distribution.Version
( Version )
import Distribution.Verbosity
( Verbosity )
-- | Represents a program which can be configured.
+--
+-- Note: rather than constructing this directly, start with 'simpleProgram' and
+-- override any extra fields.
+--
data Program = Program {
-- | The simple name of the program, eg. ghc
programName :: String,
@@ -59,6 +60,12 @@ data Program = Program {
type ProgArg = String
+-- | Represents a program which has been configured and is thus ready to be run.
+--
+-- These are usually made by configuring a 'Program', but if you have to
+-- construct one directly then start with 'simpleConfiguredProgram' and
+-- override any extra fields.
+--
data ConfiguredProgram = ConfiguredProgram {
-- | Just the name again
programId :: String,
@@ -87,7 +94,7 @@ data ProgramLocation
-- ^The user gave the path to this program,
-- eg. --ghc-path=\/usr\/bin\/ghc-6.6
| FoundOnSystem { locationPath :: FilePath }
- -- ^The location of the program, as located by searching PATH.
+ -- ^The program was found automatically.
deriving (Read, Show, Eq)
-- | The full path of a configured program.
@@ -109,14 +116,15 @@ simpleProgram name = Program {
programPostConf = \_ _ -> return []
}
--- | Make a simple 'internal' program; that is, one that was built as an
--- executable already and is expected to be found in the build directory
-internalProgram :: [FilePath] -> String -> Program
-internalProgram paths name = Program {
- programName = name,
- programFindLocation = \_v ->
- findFirstFile id [ path </> name | path <- nub paths ],
- programFindVersion = \_ _ -> return Nothing,
- programPostConf = \_ _ -> return []
+-- | Make a simple 'ConfiguredProgram'.
+--
+-- > simpleConfiguredProgram "foo" (FoundOnSystem path)
+--
+simpleConfiguredProgram :: String -> ProgramLocation -> ConfiguredProgram
+simpleConfiguredProgram name loc = ConfiguredProgram {
+ programId = name,
+ programVersion = Nothing,
+ programDefaultArgs = [],
+ programOverrideArgs = [],
+ programLocation = loc
}
-
diff --git a/cabal/cabal/Distribution/Simple/Register.hs b/cabal/Cabal/Distribution/Simple/Register.hs
index f8c9dca..496c99a 100644
--- a/cabal/cabal/Distribution/Simple/Register.hs
+++ b/cabal/Cabal/Distribution/Simple/Register.hs
@@ -57,6 +57,7 @@ module Distribution.Simple.Register (
register,
unregister,
+ initPackageDB,
registerPackage,
generateRegistrationInfo,
inplaceInstalledPackageInfo,
@@ -73,11 +74,12 @@ import qualified Distribution.Simple.LHC as LHC
import qualified Distribution.Simple.Hugs as Hugs
import qualified Distribution.Simple.UHC as UHC
import Distribution.Simple.Compiler
- ( compilerVersion, CompilerFlavor(..), compilerFlavor
+ ( compilerVersion, Compiler, CompilerFlavor(..), compilerFlavor
, PackageDBStack, registrationPackageDB )
import Distribution.Simple.Program
- ( ConfiguredProgram, runProgramInvocation
- , requireProgram, lookupProgram, ghcPkgProgram, lhcPkgProgram )
+ ( ProgramConfiguration, ConfiguredProgram
+ , runProgramInvocation, requireProgram, lookupProgram
+ , ghcPkgProgram, lhcPkgProgram )
import Distribution.Simple.Program.Script
( invocationAsSystemScript )
import qualified Distribution.Simple.Program.HcPkg as HcPkg
@@ -113,7 +115,7 @@ import Data.Maybe
( isJust, fromMaybe, maybeToList )
import Data.List
( partition, nub )
-
+import qualified Data.ByteString.Lazy.Char8 as BS.Char8
-- -----------------------------------------------------------------------------
-- Registration
@@ -204,6 +206,14 @@ generateRegistrationInfo verbosity pkg lib lbi clbi inplace distPref = do
return installedPkgInfo{ IPI.installedPackageId = ipid }
+-- | Create an empty package DB at the specified location.
+initPackageDB :: Verbosity -> Compiler -> ProgramConfiguration -> FilePath
+ -> IO ()
+initPackageDB verbosity comp conf dbPath =
+ case (compilerFlavor comp) of
+ GHC -> GHC.initPackageDB verbosity conf dbPath
+ _ -> die "initPackageDB is not implemented for this compiler"
+
registerPackage :: Verbosity
-> InstalledPackageInfo
-> PackageDescription
@@ -212,7 +222,10 @@ registerPackage :: Verbosity
-> PackageDBStack
-> IO ()
registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs = do
- setupMessage verbosity "Registering" (packageId pkg)
+ let msg = if inplace
+ then "In-place registering"
+ else "Registering"
+ setupMessage verbosity msg (packageId pkg)
case compilerFlavor (compiler lbi) of
GHC -> GHC.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs
LHC -> LHC.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs
@@ -275,7 +288,7 @@ generalInstalledPackageInfo adjustRelIncDirs pkg lib clbi installDirs =
IPI.exposed = libExposed lib,
IPI.exposedModules = exposedModules lib,
IPI.hiddenModules = otherModules bi,
- IPI.trusted = False,
+ IPI.trusted = IPI.trusted IPI.emptyInstalledPackageInfo,
IPI.importDirs = [ libdir installDirs | hasModules ],
IPI.libraryDirs = if hasLibrary
then libdir installDirs : extraLibDirs bi
@@ -317,9 +330,10 @@ inplaceInstalledPackageInfo :: FilePath -- ^ top of the build tree
-> ComponentLocalBuildInfo
-> InstalledPackageInfo
inplaceInstalledPackageInfo inplaceDir distPref pkg lib lbi clbi =
- generalInstalledPackageInfo adjustReativeIncludeDirs pkg lib clbi installDirs
+ generalInstalledPackageInfo adjustRelativeIncludeDirs pkg lib clbi
+ installDirs
where
- adjustReativeIncludeDirs = map (inplaceDir </>)
+ adjustRelativeIncludeDirs = map (inplaceDir </>)
installDirs =
(absoluteInstallDirs pkg lbi NoCopyDest) {
libdir = inplaceDir </> buildDir lbi,
@@ -373,7 +387,7 @@ unregister pkg lbi regFlags = do
packageDb pkgid
in if genScript
then writeFileAtomic unregScriptFileName
- (invocationAsSystemScript buildOS invocation)
+ (BS.Char8.pack $ invocationAsSystemScript buildOS invocation)
else runProgramInvocation verbosity invocation
Hugs -> do
_ <- tryIO $ removeDirectoryRecursive (libdir installDirs)
diff --git a/cabal/cabal/Distribution/Simple/Setup.hs b/cabal/Cabal/Distribution/Simple/Setup.hs
index b696bdc..89e242c 100644
--- a/cabal/cabal/Distribution/Simple/Setup.hs
+++ b/cabal/Cabal/Distribution/Simple/Setup.hs
@@ -72,9 +72,10 @@ module Distribution.Simple.Setup (
SDistFlags(..), emptySDistFlags, defaultSDistFlags, sdistCommand,
TestFlags(..), emptyTestFlags, defaultTestFlags, testCommand,
TestShowDetails(..),
+ BenchmarkFlags(..), emptyBenchmarkFlags, defaultBenchmarkFlags, benchmarkCommand,
CopyDest(..),
configureArgs, configureOptions, configureCCompiler, configureLinker,
- installDirsOptions,
+ buildOptions, installDirsOptions,
defaultDistPref,
@@ -284,7 +285,7 @@ data ConfigFlags = ConfigFlags {
configDistPref :: Flag FilePath, -- ^"dist" prefix
configVerbosity :: Flag Verbosity, -- ^verbosity level
configUserInstall :: Flag Bool, -- ^The --user\/--global flag
- configPackageDB :: Flag PackageDB, -- ^Which package DB to use
+ configPackageDBs :: [Maybe PackageDB], -- ^Which package DBs to use
configGHCiLib :: Flag Bool, -- ^Enable compiling library for GHCi
configSplitObjs :: Flag Bool, -- ^Enable -split-objs with GHC
configStripExes :: Flag Bool, -- ^Enable executable stripping
@@ -292,6 +293,7 @@ data ConfigFlags = ConfigFlags {
-- dependencies
configConfigurationsFlags :: FlagAssignment,
configTests :: Flag Bool, -- ^Enable test suite compilation
+ configBenchmarks :: Flag Bool, -- ^Enable benchmark compilation
configLibCoverage :: Flag Bool -- ^ Enable test suite program coverage
}
deriving (Read,Show)
@@ -311,10 +313,11 @@ defaultConfigFlags progConf = emptyConfigFlags {
configDistPref = Flag defaultDistPref,
configVerbosity = Flag normal,
configUserInstall = Flag False, --TODO: reverse this
- configGHCiLib = Flag True,
+ configGHCiLib = Flag False,
configSplitObjs = Flag False, -- takes longer, so turn off by default
configStripExes = Flag True,
configTests = Flag False,
+ configBenchmarks = Flag False,
configLibCoverage = Flag False
}
@@ -443,12 +446,9 @@ configureOptions showOrParseArgs =
(boolOpt' ([],["user"]) ([], ["global"]))
,option "" ["package-db"]
- "Use a specific package database (to satisfy dependencies and register in)"
- configPackageDB (\v flags -> flags { configPackageDB = v })
- (reqArg' "PATH" (Flag . SpecificPackageDB)
- (\f -> case f of
- Flag (SpecificPackageDB db) -> [db]
- _ -> []))
+ "Use a given package database (to satisfy dependencies and register in). May be a specific file, 'global', 'user' or 'clear'."
+ configPackageDBs (\v flags -> flags { configPackageDBs = v })
+ (reqArg' "DB" readPackageDbList showPackageDbList)
,option "f" ["flags"]
"Force values for the given flags in Cabal conditionals in the .cabal file. E.g., --flags=\"debug -usebytestrings\" forces the flag \"debug\" to true and \"usebytestrings\" to false."
@@ -478,6 +478,10 @@ configureOptions showOrParseArgs =
"build library and test suites with Haskell Program Coverage enabled. (GHC only)"
configLibCoverage (\v flags -> flags { configLibCoverage = v })
(boolOpt [] [])
+ ,option "" ["benchmarks"]
+ "dependency checking and compilation for benchmarks listed in the package description file."
+ configBenchmarks (\v flags -> flags { configBenchmarks = v })
+ (boolOpt [] [])
]
where
readFlagList :: String -> FlagAssignment
@@ -489,6 +493,20 @@ configureOptions showOrParseArgs =
showFlagList fs = [ if not set then '-':fname else fname
| (FlagName fname, set) <- fs]
+ readPackageDbList :: String -> [Maybe PackageDB]
+ readPackageDbList "clear" = [Nothing]
+ readPackageDbList "global" = [Just GlobalPackageDB]
+ readPackageDbList "user" = [Just UserPackageDB]
+ readPackageDbList other = [Just (SpecificPackageDB other)]
+
+ showPackageDbList :: [Maybe PackageDB] -> [String]
+ showPackageDbList = map showPackageDb
+ where
+ showPackageDb Nothing = "clear"
+ showPackageDb (Just GlobalPackageDB) = "global"
+ showPackageDb (Just UserPackageDB) = "user"
+ showPackageDb (Just (SpecificPackageDB db)) = db
+
liftInstallDirs =
liftOption configInstallDirs (\v flags -> flags { configInstallDirs = v })
@@ -578,7 +596,7 @@ instance Monoid ConfigFlags where
configDistPref = mempty,
configVerbosity = mempty,
configUserInstall = mempty,
- configPackageDB = mempty,
+ configPackageDBs = mempty,
configGHCiLib = mempty,
configSplitObjs = mempty,
configStripExes = mempty,
@@ -587,7 +605,8 @@ instance Monoid ConfigFlags where
configExtraIncludeDirs = mempty,
configConfigurationsFlags = mempty,
configTests = mempty,
- configLibCoverage = mempty
+ configLibCoverage = mempty,
+ configBenchmarks = mempty
}
mappend a b = ConfigFlags {
configPrograms = configPrograms b,
@@ -610,7 +629,7 @@ instance Monoid ConfigFlags where
configDistPref = combine configDistPref,
configVerbosity = combine configVerbosity,
configUserInstall = combine configUserInstall,
- configPackageDB = combine configPackageDB,
+ configPackageDBs = combine configPackageDBs,
configGHCiLib = combine configGHCiLib,
configSplitObjs = combine configSplitObjs,
configStripExes = combine configStripExes,
@@ -619,7 +638,8 @@ instance Monoid ConfigFlags where
configExtraIncludeDirs = combine configExtraIncludeDirs,
configConfigurationsFlags = combine configConfigurationsFlags,
configTests = combine configTests,
- configLibCoverage = combine configLibCoverage
+ configLibCoverage = combine configLibCoverage,
+ configBenchmarks = combine configBenchmarks
}
where combine field = field a `mappend` field b
@@ -1002,6 +1022,7 @@ data HaddockFlags = HaddockFlags {
haddockCss :: Flag FilePath,
haddockHscolour :: Flag Bool,
haddockHscolourCss :: Flag FilePath,
+ haddockContents :: Flag PathTemplate,
haddockDistPref :: Flag FilePath,
haddockVerbosity :: Flag Verbosity
}
@@ -1019,6 +1040,7 @@ defaultHaddockFlags = HaddockFlags {
haddockCss = NoFlag,
haddockHscolour = Flag False,
haddockHscolourCss = NoFlag,
+ haddockContents = NoFlag,
haddockDistPref = Flag defaultDistPref,
haddockVerbosity = Flag normal
}
@@ -1074,6 +1096,13 @@ haddockCommand = makeCommand name shortDesc longDesc defaultHaddockFlags options
"Use PATH as the HsColour stylesheet"
haddockHscolourCss (\v flags -> flags { haddockHscolourCss = v })
(reqArgFlag "PATH")
+
+ ,option "" ["contents-location"]
+ "Bake URL in as the location for the contents page"
+ haddockContents (\v flags -> flags { haddockContents = v })
+ (reqArg' "URL"
+ (toFlag . toPathTemplate)
+ (flagToList . fmap fromPathTemplate))
]
++ programConfigurationPaths progConf ParseArgs
haddockProgramPaths (\v flags -> flags { haddockProgramPaths = v})
@@ -1098,6 +1127,7 @@ instance Monoid HaddockFlags where
haddockCss = mempty,
haddockHscolour = mempty,
haddockHscolourCss = mempty,
+ haddockContents = mempty,
haddockDistPref = mempty,
haddockVerbosity = mempty
}
@@ -1112,6 +1142,7 @@ instance Monoid HaddockFlags where
haddockCss = combine haddockCss,
haddockHscolour = combine haddockHscolour,
haddockHscolourCss = combine haddockHscolourCss,
+ haddockContents = combine haddockContents,
haddockDistPref = combine haddockDistPref,
haddockVerbosity = combine haddockVerbosity
}
@@ -1194,22 +1225,26 @@ defaultBuildFlags = BuildFlags {
}
buildCommand :: ProgramConfiguration -> CommandUI BuildFlags
-buildCommand progConf = makeCommand name shortDesc longDesc defaultBuildFlags options
+buildCommand progConf = makeCommand name shortDesc longDesc
+ defaultBuildFlags (buildOptions progConf)
where
name = "build"
shortDesc = "Make this package ready for installation."
longDesc = Nothing
- options showOrParseArgs =
- optionVerbosity buildVerbosity (\v flags -> flags { buildVerbosity = v })
- : optionDistPref
- buildDistPref (\d flags -> flags { buildDistPref = d })
- showOrParseArgs
- : programConfigurationPaths progConf showOrParseArgs
- buildProgramPaths (\v flags -> flags { buildProgramPaths = v})
+buildOptions :: ProgramConfiguration -> ShowOrParseArgs
+ -> [OptionField BuildFlags]
+buildOptions progConf showOrParseArgs =
+ optionVerbosity buildVerbosity (\v flags -> flags { buildVerbosity = v })
+ : optionDistPref
+ buildDistPref (\d flags -> flags { buildDistPref = d })
+ showOrParseArgs
- ++ programConfigurationOptions progConf showOrParseArgs
- buildProgramArgs (\v flags -> flags { buildProgramArgs = v})
+ : programConfigurationPaths progConf showOrParseArgs
+ buildProgramPaths (\v flags -> flags { buildProgramPaths = v})
+
+ ++ programConfigurationOptions progConf showOrParseArgs
+ buildProgramArgs (\v flags -> flags { buildProgramArgs = v})
emptyBuildFlags :: BuildFlags
emptyBuildFlags = mempty
@@ -1265,7 +1300,7 @@ data TestFlags = TestFlags {
--TODO: eliminate the test list and pass it directly as positional args to the testHook
testList :: Flag [String],
-- TODO: think about if/how options are passed to test exes
- testOptions :: Flag [PathTemplate]
+ testOptions :: [PathTemplate]
}
defaultTestFlags :: TestFlags
@@ -1277,7 +1312,7 @@ defaultTestFlags = TestFlags {
testShowDetails = toFlag Failures,
testKeepTix = toFlag False,
testList = Flag [],
- testOptions = Flag []
+ testOptions = []
}
testCommand :: CommandUI TestFlags
@@ -1325,16 +1360,16 @@ testCommand = makeCommand name shortDesc longDesc defaultTestFlags options
++ "(name templates can use $pkgid, $compiler, "
++ "$os, $arch, $test-suite)")
testOptions (\v flags -> flags { testOptions = v })
- (reqArg' "TEMPLATES" (toFlag . map toPathTemplate . splitArgs)
- (map fromPathTemplate . fromFlagOrDefault []))
+ (reqArg' "TEMPLATES" (map toPathTemplate . splitArgs)
+ (const []))
, option [] ["test-option"]
("give extra option to test executables "
++ "(no need to quote options containing spaces, "
++ "name template can use $pkgid, $compiler, "
++ "$os, $arch, $test-suite)")
testOptions (\v flags -> flags { testOptions = v })
- (reqArg' "TEMPLATE" (\x -> toFlag [toPathTemplate x])
- (map fromPathTemplate . fromFlagOrDefault []))
+ (reqArg' "TEMPLATE" (\x -> [toPathTemplate x])
+ (map fromPathTemplate))
]
emptyTestFlags :: TestFlags
@@ -1364,6 +1399,67 @@ instance Monoid TestFlags where
where combine field = field a `mappend` field b
-- ------------------------------------------------------------
+-- * Benchmark flags
+-- ------------------------------------------------------------
+
+data BenchmarkFlags = BenchmarkFlags {
+ benchmarkDistPref :: Flag FilePath,
+ benchmarkVerbosity :: Flag Verbosity,
+ benchmarkOptions :: [PathTemplate]
+ }
+
+defaultBenchmarkFlags :: BenchmarkFlags
+defaultBenchmarkFlags = BenchmarkFlags {
+ benchmarkDistPref = Flag defaultDistPref,
+ benchmarkVerbosity = Flag normal,
+ benchmarkOptions = []
+ }
+
+benchmarkCommand :: CommandUI BenchmarkFlags
+benchmarkCommand = makeCommand name shortDesc longDesc defaultBenchmarkFlags options
+ where
+ name = "bench"
+ shortDesc = "Run the benchmark, if any (configure with UserHooks)."
+ longDesc = Nothing
+ options showOrParseArgs =
+ [ optionVerbosity benchmarkVerbosity (\v flags -> flags { benchmarkVerbosity = v })
+ , optionDistPref
+ benchmarkDistPref (\d flags -> flags { benchmarkDistPref = d })
+ showOrParseArgs
+ , option [] ["benchmark-options"]
+ ("give extra options to benchmark executables "
+ ++ "(name templates can use $pkgid, $compiler, "
+ ++ "$os, $arch, $benchmark)")
+ benchmarkOptions (\v flags -> flags { benchmarkOptions = v })
+ (reqArg' "TEMPLATES" (map toPathTemplate . splitArgs)
+ (const []))
+ , option [] ["benchmark-option"]
+ ("give extra option to benchmark executables "
+ ++ "(no need to quote options containing spaces, "
+ ++ "name template can use $pkgid, $compiler, "
+ ++ "$os, $arch, $benchmark)")
+ benchmarkOptions (\v flags -> flags { benchmarkOptions = v })
+ (reqArg' "TEMPLATE" (\x -> [toPathTemplate x])
+ (map fromPathTemplate))
+ ]
+
+emptyBenchmarkFlags :: BenchmarkFlags
+emptyBenchmarkFlags = mempty
+
+instance Monoid BenchmarkFlags where
+ mempty = BenchmarkFlags {
+ benchmarkDistPref = mempty,
+ benchmarkVerbosity = mempty,
+ benchmarkOptions = mempty
+ }
+ mappend a b = BenchmarkFlags {
+ benchmarkDistPref = combine benchmarkDistPref,
+ benchmarkVerbosity = combine benchmarkVerbosity,
+ benchmarkOptions = combine benchmarkOptions
+ }
+ where combine field = field a `mappend` field b
+
+-- ------------------------------------------------------------
-- * Shared options utils
-- ------------------------------------------------------------
diff --git a/cabal/cabal/Distribution/Simple/SrcDist.hs b/cabal/Cabal/Distribution/Simple/SrcDist.hs
index c6ef47a..beca46e 100644
--- a/cabal/cabal/Distribution/Simple/SrcDist.hs
+++ b/cabal/Cabal/Distribution/Simple/SrcDist.hs
@@ -68,7 +68,8 @@ module Distribution.Simple.SrcDist (
import Distribution.PackageDescription
( PackageDescription(..), BuildInfo(..), Executable(..), Library(..)
- , TestSuite(..), TestSuiteInterface(..) )
+ , TestSuite(..), TestSuiteInterface(..), Benchmark(..)
+ , BenchmarkInterface(..) )
import Distribution.PackageDescription.Check
( PackageCheck(..), checkConfiguredPackage, checkPackageFiles )
import Distribution.Package
@@ -195,6 +196,23 @@ prepareTree verbosity pkg_descr0 mb_lbi distPref targetDir pps = do
prep [m] bi
TestSuiteUnsupported tp -> die $ "Unsupported test suite type: " ++ show tp
+ -- move the benchmarks into place
+ withBenchmark $ \bm -> do
+ let bi = benchmarkBuildInfo bm
+ prep = prepareDir verbosity pkg_descr distPref targetDir pps
+ case benchmarkInterface bm of
+ BenchmarkExeV10 _ mainPath -> do
+ prep [] bi
+ srcMainFile <- do
+ ppFile <- findFileWithExtension (ppSuffixes pps)
+ (hsSourceDirs bi)
+ (dropExtension mainPath)
+ case ppFile of
+ Nothing -> findFile (hsSourceDirs bi) mainPath
+ Just pp -> return pp
+ copyFileTo verbosity targetDir srcMainFile
+ BenchmarkUnsupported tp -> die $ "Unsupported benchmark type: " ++ show tp
+
flip mapM_ (dataFiles pkg_descr) $ \ filename -> do
files <- matchFileGlob (dataDir pkg_descr </> filename)
let dir = takeDirectory (dataDir pkg_descr </> filename)
@@ -261,6 +279,7 @@ prepareTree verbosity pkg_descr0 mb_lbi distPref targetDir pps = do
withLib action = maybe (return ()) action (library pkg_descr)
withExe action = mapM_ action (executables pkg_descr)
withTest action = mapM_ action (testSuites pkg_descr)
+ withBenchmark action = mapM_ action (benchmarks pkg_descr)
-- | Prepare a directory tree of source files for a snapshot version.
-- It is expected that the appropriate snapshot version has already been set
@@ -411,8 +430,12 @@ mapAllBuildInfo :: (BuildInfo -> BuildInfo)
-> (PackageDescription -> PackageDescription)
mapAllBuildInfo f pkg = pkg {
library = fmap mapLibBi (library pkg),
- executables = fmap mapExeBi (executables pkg)
+ executables = fmap mapExeBi (executables pkg),
+ testSuites = fmap mapTestBi (testSuites pkg),
+ benchmarks = fmap mapBenchBi (benchmarks pkg)
}
where
- mapLibBi lib = lib { libBuildInfo = f (libBuildInfo lib) }
- mapExeBi exe = exe { buildInfo = f (buildInfo exe) }
+ mapLibBi lib = lib { libBuildInfo = f (libBuildInfo lib) }
+ mapExeBi exe = exe { buildInfo = f (buildInfo exe) }
+ mapTestBi t = t { testBuildInfo = f (testBuildInfo t) }
+ mapBenchBi bm = bm { benchmarkBuildInfo = f (benchmarkBuildInfo bm) }
diff --git a/cabal/cabal/Distribution/Simple/Test.hs b/cabal/Cabal/Distribution/Simple/Test.hs
index 9ee670b..ce8b38c 100644
--- a/cabal/cabal/Distribution/Simple/Test.hs
+++ b/cabal/Cabal/Distribution/Simple/Test.hs
@@ -42,13 +42,13 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
module Distribution.Simple.Test
( test
- , runTests
+ , stubMain
, writeSimpleTestStub
, stubFilePath
, stubName
, PackageLog(..)
, TestSuiteLog(..)
- , Case(..)
+ , TestLogs(..)
, suitePassed, suiteFailed, suiteError
) where
@@ -63,7 +63,8 @@ import qualified Distribution.PackageDescription as PD
import Distribution.Simple.Build.PathsModule ( pkgPathEnvVar )
import Distribution.Simple.BuildPaths ( exeExtension )
import Distribution.Simple.Compiler ( Compiler(..), CompilerId )
-import Distribution.Simple.Hpc ( doHpcMarkup, findTixFiles, tixDir )
+import Distribution.Simple.Hpc
+ ( markupPackage, markupTest, tixDir, tixFilePath )
import Distribution.Simple.InstallDirs
( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..)
, substPathTemplate , toPathTemplate, PathTemplate )
@@ -71,19 +72,21 @@ import qualified Distribution.Simple.LocalBuildInfo as LBI
( LocalBuildInfo(..) )
import Distribution.Simple.Setup ( TestFlags(..), TestShowDetails(..), fromFlag )
import Distribution.Simple.Utils ( die, notice )
-import qualified Distribution.TestSuite as TestSuite
- ( Test, Result(..), ImpureTestable(..), TestOptions(..), Options(..) )
+import Distribution.TestSuite
+ ( OptionDescr(..), Options, Progress(..), Result(..), TestInstance(..)
+ , Test(..) )
import Distribution.Text
import Distribution.Verbosity ( normal, Verbosity )
import Distribution.System ( buildPlatform, Platform )
import Control.Exception ( bracket )
-import Control.Monad ( when, liftM, unless, filterM )
+import Control.Monad ( when, unless, filterM )
import Data.Char ( toUpper )
-import Data.Monoid ( mempty )
+import Data.Maybe ( mapMaybe )
import System.Directory
- ( createDirectoryIfMissing, doesFileExist, getCurrentDirectory
- , removeFile, getDirectoryContents )
+ ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist
+ , getCurrentDirectory, getDirectoryContents, removeDirectoryRecursive
+ , removeFile )
import System.Environment ( getEnvironment )
import System.Exit ( ExitCode(..), exitFailure, exitWith )
import System.FilePath ( (</>), (<.>) )
@@ -111,40 +114,55 @@ localPackageLog pkg_descr lbi = PackageLog
-- | Logs test suite results, itemized by test case.
data TestSuiteLog = TestSuiteLog
- { name :: String
- , cases :: [Case]
+ { testSuiteName :: String
+ , testLogs :: TestLogs
, logFile :: FilePath -- path to human-readable log file
}
deriving (Read, Show, Eq)
-data Case = Case
- { caseName :: String
- , caseOptions :: TestSuite.Options
- , caseResult :: TestSuite.Result
- }
+data TestLogs
+ = TestLog
+ { testName :: String
+ , testOptionsReturned :: Options
+ , testResult :: Result
+ }
+ | GroupLogs String [TestLogs]
deriving (Read, Show, Eq)
-getTestOptions :: TestSuite.Test -> TestSuiteLog -> IO TestSuite.Options
-getTestOptions t l =
- case filter ((== TestSuite.name t) . caseName) (cases l) of
- (x:_) -> return $ caseOptions x
- _ -> TestSuite.defaultOptions t
+-- | Count the number of pass, fail, and error test results in a 'TestLogs'
+-- tree.
+countTestResults :: TestLogs
+ -> (Int, Int, Int) -- ^ Passes, fails, and errors,
+ -- respectively.
+countTestResults = go (0, 0, 0)
+ where
+ go (p, f, e) (TestLog { testResult = r }) =
+ case r of
+ Pass -> (p + 1, f, e)
+ Fail _ -> (p, f + 1, e)
+ Error _ -> (p, f, e + 1)
+ go (p, f, e) (GroupLogs _ ts) = foldl go (p, f, e) ts
-- | From a 'TestSuiteLog', determine if the test suite passed.
suitePassed :: TestSuiteLog -> Bool
-suitePassed = all (== TestSuite.Pass) . map caseResult . cases
+suitePassed l =
+ case countTestResults (testLogs l) of
+ (_, 0, 0) -> True
+ _ -> False
-- | From a 'TestSuiteLog', determine if the test suite failed.
suiteFailed :: TestSuiteLog -> Bool
-suiteFailed = any isFail . map caseResult . cases
- where isFail (TestSuite.Fail _) = True
- isFail _ = False
+suiteFailed l =
+ case countTestResults (testLogs l) of
+ (_, 0, _) -> False
+ _ -> True
-- | From a 'TestSuiteLog', determine if the test suite encountered errors.
suiteError :: TestSuiteLog -> Bool
-suiteError = any isError . map caseResult . cases
- where isError (TestSuite.Error _) = True
- isError _ = False
+suiteError l =
+ case countTestResults (testLogs l) of
+ (_, _, 0) -> False
+ _ -> True
-- | Run a test executable, logging the output and generating the appropriate
-- summary messages.
@@ -168,30 +186,35 @@ testController flags pkg_descr lbi suite preTest cmd postTest logNamer = do
let distPref = fromFlag $ testDistPref flags
verbosity = fromFlag $ testVerbosity flags
testLogDir = distPref </> "test"
- optionTemplates = fromFlag $ testOptions flags
- options = map (testOption pkg_descr lbi suite) optionTemplates
+ opts = map (testOption pkg_descr lbi suite) $ testOptions flags
pwd <- getCurrentDirectory
existingEnv <- getEnvironment
let dataDirPath = pwd </> PD.dataDir pkg_descr
shellEnv = Just $ (pkgPathEnvVar pkg_descr "datadir", dataDirPath)
- : ("HPCTIXDIR", pwd </> tixDir distPref suite)
+ : ("HPCTIXFILE", (</>) pwd
+ $ tixFilePath distPref $ PD.testName suite)
: existingEnv
bracket (openCabalTemp testLogDir) deleteIfExists $ \tempLog ->
bracket (openCabalTemp testLogDir) deleteIfExists $ \tempInput -> do
- -- Create directory for HPC files.
- createDirectoryIfMissing True $ tixDir distPref suite
+ -- Check that the test executable exists.
+ exists <- doesFileExist cmd
+ unless exists $ die $ "Error: Could not find test program \"" ++ cmd
+ ++ "\". Did you build the package first?"
-- Remove old .tix files if appropriate.
- tixFiles <- findTixFiles distPref suite
- unless (fromFlag $ testKeepTix flags)
- $ mapM_ deleteIfExists tixFiles
+ unless (fromFlag $ testKeepTix flags) $ do
+ let tDir = tixDir distPref $ PD.testName suite
+ exists' <- doesDirectoryExist tDir
+ when exists' $ removeDirectoryRecursive tDir
+
+ -- Create directory for HPC files.
+ createDirectoryIfMissing True $ tixDir distPref $ PD.testName suite
-- Write summary notices indicating start of test suite
notice verbosity $ summarizeSuiteStart $ PD.testName suite
- appendFile tempLog $ summarizeSuiteStart $ PD.testName suite
-- Prepare standard input for test executable
appendFile tempInput $ preTest tempInput
@@ -201,38 +224,42 @@ testController flags pkg_descr lbi suite preTest cmd postTest logNamer = do
hLog <- openFile tempLog AppendMode
hIn <- openFile tempInput ReadMode
-- these handles get closed by runProcess
- proc <- runProcess cmd options Nothing shellEnv
+ proc <- runProcess cmd opts Nothing shellEnv
(Just hIn) (Just hLog) (Just hLog)
waitForProcess proc
-- Generate TestSuiteLog from executable exit code and a machine-
-- readable test log
- suiteLog <- readFile tempInput >>= return . postTest exit
+ suiteLog <- fmap (postTest exit $!) $ readFile tempInput
-- Generate final log file name
let finalLogName = testLogDir </> logNamer suiteLog
suiteLog' = suiteLog { logFile = finalLogName }
- -- Write summary notice to log file indicating end of test suite
- appendFile tempLog $ summarizeSuiteFinish suiteLog'
+ -- Write summary notice to log file indicating start of test suite
+ appendFile (logFile suiteLog') $ summarizeSuiteStart $ PD.testName suite
-- Append contents of temporary log file to the final human-
-- readable log file
readFile tempLog >>= appendFile (logFile suiteLog')
+ -- Write end-of-suite summary notice to log file
+ appendFile (logFile suiteLog') $ summarizeSuiteFinish suiteLog'
+
-- Show the contents of the human-readable log file on the terminal
-- if there is a failure and/or detailed output is requested
let details = fromFlag $ testShowDetails flags
whenPrinting = when $ (details > Never)
&& (not (suitePassed suiteLog) || details == Always)
&& verbosity >= normal
- whenPrinting $ readFile (logFile suiteLog') >>=
- putStr . unlines . map (">>> " ++) . lines
+ whenPrinting $ readFile tempLog >>=
+ putStr . unlines . lines
-- Write summary notice to terminal indicating end of test suite
notice verbosity $ summarizeSuiteFinish suiteLog'
- doHpcMarkup verbosity distPref (display $ PD.package pkg_descr) suite
+ markupTest verbosity lbi distPref
+ (display $ PD.package pkg_descr) suite
return suiteLog'
where
@@ -263,7 +290,7 @@ test pkg_descr lbi flags = do
, PD.buildable (PD.testBuildInfo t) ]
doTest :: (PD.TestSuite, Maybe TestSuiteLog) -> IO TestSuiteLog
- doTest (suite, mLog) = do
+ doTest (suite, _) = do
let testLogPath = testSuiteLogPath humanTemplate pkg_descr lbi
go pre cmd post = testController flags pkg_descr lbi suite
pre cmd post testLogPath
@@ -274,12 +301,16 @@ test pkg_descr lbi flags = do
preTest _ = ""
postTest exit _ =
let r = case exit of
- ExitSuccess -> TestSuite.Pass
- ExitFailure c -> TestSuite.Fail
+ ExitSuccess -> Pass
+ ExitFailure c -> Fail
$ "exit code: " ++ show c
in TestSuiteLog
- { name = PD.testName suite
- , cases = [Case (PD.testName suite) mempty r]
+ { testSuiteName = PD.testName suite
+ , testLogs = TestLog
+ { testName = PD.testName suite
+ , testOptionsReturned = []
+ , testResult = r
+ }
, logFile = ""
}
go preTest cmd postTest
@@ -287,23 +318,21 @@ test pkg_descr lbi flags = do
PD.TestSuiteLibV09 _ _ -> do
let cmd = LBI.buildDir lbi </> stubName suite
</> stubName suite <.> exeExtension
- oldLog = case mLog of
- Nothing -> TestSuiteLog
- { name = PD.testName suite
- , cases = []
- , logFile = []
- }
- Just l -> l
- preTest f = show $ oldLog { logFile = f }
+ preTest f = show ( f
+ , PD.testName suite
+ )
postTest _ = read
go preTest cmd postTest
_ -> return TestSuiteLog
- { name = PD.testName suite
- , cases = [Case (PD.testName suite) mempty
- $ TestSuite.Error $ "No support for running "
- ++ "test suite type: "
- ++ show (disp $ PD.testType suite)]
+ { testSuiteName = PD.testName suite
+ , testLogs = TestLog
+ { testName = PD.testName suite
+ , testOptionsReturned = []
+ , testResult = Error $
+ "No support for running test suite type: "
+ ++ show (disp $ PD.testType suite)
+ }
, logFile = ""
}
@@ -343,6 +372,10 @@ test pkg_descr lbi flags = do
$ packageLogPath machineTemplate pkg_descr lbi
allOk <- summarizePackage verbosity packageLog
writeFile packageLogFile $ show packageLog
+
+ markupPackage verbosity lbi distPref (display $ PD.package pkg_descr)
+ $ map fst testsToRun
+
unless allOk exitFailure
-- | Print a summary to the console after all test suites have been run
@@ -350,30 +383,33 @@ test pkg_descr lbi flags = do
-- all test suites passed and 'False' otherwise.
summarizePackage :: Verbosity -> PackageLog -> IO Bool
summarizePackage verbosity packageLog = do
- let cases' = map caseResult $ concatMap cases $ testSuites packageLog
- passedCases = length $ filter (== TestSuite.Pass) cases'
- totalCases = length cases'
+ let counts = map (countTestResults . testLogs) $ testSuites packageLog
+ (passed, failed, errors) = foldl1 addTriple counts
+ totalCases = passed + failed + errors
passedSuites = length $ filter suitePassed $ testSuites packageLog
totalSuites = length $ testSuites packageLog
notice verbosity $ show passedSuites ++ " of " ++ show totalSuites
- ++ " test suites (" ++ show passedCases ++ " of "
+ ++ " test suites (" ++ show passed ++ " of "
++ show totalCases ++ " test cases) passed."
return $! passedSuites == totalSuites
+ where
+ addTriple (p1, f1, e1) (p2, f2, e2) = (p1 + p2, f1 + f2, e1 + e2)
-- | Print a summary of a single test case's result to the console, supressing
-- output for certain verbosity or test filter levels.
-summarizeCase :: Verbosity -> TestShowDetails -> Case -> IO ()
-summarizeCase verbosity details t =
- when shouldPrint $ notice verbosity $ "Test case " ++ caseName t
- ++ ": " ++ show (caseResult t)
+summarizeTest :: Verbosity -> TestShowDetails -> TestLogs -> IO ()
+summarizeTest _ _ (GroupLogs {}) = return ()
+summarizeTest verbosity details t =
+ when shouldPrint $ notice verbosity $ "Test case " ++ testName t
+ ++ ": " ++ show (testResult t)
where shouldPrint = (details > Never) && (notPassed || details == Always)
- notPassed = caseResult t /= TestSuite.Pass
+ notPassed = testResult t /= Pass
-- | Print a summary of the test suite's results on the console, suppressing
-- output for certain verbosity or test filter levels.
summarizeSuiteFinish :: TestSuiteLog -> String
summarizeSuiteFinish testLog = unlines
- [ "Test suite " ++ name testLog ++ ": " ++ resStr
+ [ "Test suite " ++ testSuiteName testLog ++ ": " ++ resStr
, "Test suite logged to: " ++ logFile testLog
]
where resStr = map toUpper (resultString testLog)
@@ -396,7 +432,7 @@ testSuiteLogPath template pkg_descr lbi testLog =
where
env = initialPathTemplateEnv
(PD.package pkg_descr) (compilerId $ LBI.compiler lbi)
- ++ [ (TestSuiteNameVar, toPathTemplate $ name testLog)
+ ++ [ (TestSuiteNameVar, toPathTemplate $ testSuiteName testLog)
, (TestSuiteResultVar, result)
]
result = toPathTemplate $ resultString testLog
@@ -450,13 +486,20 @@ writeSimpleTestStub t dir = do
simpleTestStub :: ModuleName -> String
simpleTestStub m = unlines
[ "module Main ( main ) where"
- , "import Control.Monad ( liftM )"
- , "import Distribution.Simple.Test ( runTests )"
+ , "import Distribution.Simple.Test ( stubMain )"
, "import " ++ show (disp m) ++ " ( tests )"
, "main :: IO ()"
- , "main = runTests tests"
+ , "main = stubMain tests"
]
+-- | Main function for test stubs. Once, it was written directly into the stub,
+-- but minimizing the amount of code actually in the stub maximizes the number
+-- of detectable errors when Cabal is compiled.
+stubMain :: IO [Test] -> IO ()
+stubMain tests = do
+ (f, n) <- fmap read getContents
+ tests >>= stubRunTests >>= stubWriteLog f n
+
-- | The test runner used in library "TestSuite" stub executables. Runs a list
-- of 'Test's. An executable calling this function is meant to be invoked as
-- the child of a Cabal process during @.\/setup test@. A 'TestSuiteLog',
@@ -464,23 +507,38 @@ simpleTestStub m = unlines
-- the test suite and the location of the machine-readable test suite log file.
-- Human-readable log information is written to the standard output for capture
-- by the calling Cabal process.
-runTests :: [TestSuite.Test] -> IO ()
-runTests tests = do
- testLogIn <- liftM read getContents
- let go :: TestSuite.Test -> IO Case
- go t = do
- o <- getTestOptions t testLogIn
- r <- TestSuite.runM t o
- let ret = Case
- { caseName = TestSuite.name t
- , caseOptions = o
- , caseResult = r
- }
- summarizeCase normal Always ret
- return ret
- cases' <- mapM go tests
- let testLog = testLogIn { cases = cases'}
+stubRunTests :: [Test] -> IO TestLogs
+stubRunTests tests = do
+ logs <- mapM stubRunTests' tests
+ return $ GroupLogs "Default" logs
+ where
+ stubRunTests' (Test t) = do
+ l <- run t >>= finish
+ summarizeTest normal Always l
+ return l
+ where
+ finish (Finished result) =
+ return TestLog
+ { testName = name t
+ , testOptionsReturned = defaultOptions t
+ , testResult = result
+ }
+ finish (Progress _ next) = next >>= finish
+ stubRunTests' g@(Group {}) = do
+ logs <- mapM stubRunTests' $ groupTests g
+ return $ GroupLogs (groupName g) logs
+ stubRunTests' (ExtraOptions _ t) = stubRunTests' t
+ maybeDefaultOption opt =
+ maybe Nothing (\d -> Just (optionName opt, d)) $ optionDefault opt
+ defaultOptions testInst = mapMaybe maybeDefaultOption $ options testInst
+
+-- | From a test stub, write the 'TestSuiteLog' to temporary file for the calling
+-- Cabal process to read.
+stubWriteLog :: FilePath -> String -> TestLogs -> IO ()
+stubWriteLog f n logs = do
+ let testLog = TestSuiteLog { testSuiteName = n, testLogs = logs, logFile = f }
writeFile (logFile testLog) $ show testLog
when (suiteError testLog) $ exitWith $ ExitFailure 2
when (suiteFailed testLog) $ exitWith $ ExitFailure 1
exitWith ExitSuccess
+
diff --git a/cabal/cabal/Distribution/Simple/UHC.hs b/cabal/Cabal/Distribution/Simple/UHC.hs
index 873b938..873b938 100644
--- a/cabal/cabal/Distribution/Simple/UHC.hs
+++ b/cabal/Cabal/Distribution/Simple/UHC.hs
diff --git a/cabal/cabal/Distribution/Simple/UserHooks.hs b/cabal/Cabal/Distribution/Simple/UserHooks.hs
index 5a5addf..07f0bf1 100644
--- a/cabal/cabal/Distribution/Simple/UserHooks.hs
+++ b/cabal/Cabal/Distribution/Simple/UserHooks.hs
@@ -66,7 +66,7 @@ import Distribution.Simple.PreProcess (PPSuffixHandler)
import Distribution.Simple.Setup
(ConfigFlags, BuildFlags, CleanFlags, CopyFlags,
InstallFlags, SDistFlags, RegisterFlags, HscolourFlags,
- HaddockFlags, TestFlags)
+ HaddockFlags, TestFlags, BenchmarkFlags)
import Distribution.Simple.LocalBuildInfo (LocalBuildInfo)
type Args = [String]
@@ -168,7 +168,14 @@ data UserHooks = UserHooks {
-- |Over-ride this hook to get different behavior during test.
testHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> TestFlags -> IO (),
-- |Hook to run after test command.
- postTest :: Args -> TestFlags -> PackageDescription -> LocalBuildInfo -> IO ()
+ postTest :: Args -> TestFlags -> PackageDescription -> LocalBuildInfo -> IO (),
+
+ -- |Hook to run before bench command.
+ preBench :: Args -> BenchmarkFlags -> IO HookedBuildInfo,
+ -- |Over-ride this hook to get different behavior during bench.
+ benchHook :: Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> BenchmarkFlags -> IO (),
+ -- |Hook to run after bench command.
+ postBench :: Args -> BenchmarkFlags -> PackageDescription -> LocalBuildInfo -> IO ()
}
{-# DEPRECATED runTests "Please use the new testing interface instead!" #-}
@@ -214,7 +221,11 @@ emptyUserHooks
preTest = \_ _ -> return emptyHookedBuildInfo, -- same as rn, but without
-- noExtraFlags
testHook = ru,
- postTest = ru
+ postTest = ru,
+ preBench = \_ _ -> return emptyHookedBuildInfo, -- same as rn, but without
+ -- noExtraFlags
+ benchHook = \_ -> ru,
+ postBench = ru
}
where rn args _ = noExtraFlags args >> return emptyHookedBuildInfo
ru _ _ _ _ = return ()
diff --git a/cabal/cabal/Distribution/Simple/Utils.hs b/cabal/Cabal/Distribution/Simple/Utils.hs
index 3605a66..d1f45a7 100644
--- a/cabal/cabal/Distribution/Simple/Utils.hs
+++ b/cabal/Cabal/Distribution/Simple/Utils.hs
@@ -58,6 +58,7 @@ module Distribution.Simple.Utils (
-- * running programs
rawSystemExit,
+ rawSystemExitCode,
rawSystemExitWithEnv,
rawSystemStdout,
rawSystemStdInOut,
@@ -146,6 +147,8 @@ import Data.Char as Char
( toLower, chr, ord )
import Data.Bits
( Bits((.|.), (.&.), shiftL, shiftR) )
+import qualified Data.ByteString.Lazy as BS
+import qualified Data.ByteString.Lazy.Char8 as BS.Char8
import System.Directory
( getDirectoryContents, doesDirectoryExist, doesFileExist, removeFile
@@ -162,7 +165,8 @@ import System.FilePath
import System.Directory
( createDirectory, renameFile, removeDirectoryRecursive )
import System.IO
- ( Handle, openFile, openBinaryFile, IOMode(ReadMode), hSetBinaryMode
+ ( Handle, openFile, openBinaryFile, openBinaryTempFile
+ , IOMode(ReadMode), hSetBinaryMode
, hGetContents, stderr, stdout, hPutStr, hFlush, hClose )
import System.IO.Error as IO.Error
( isDoesNotExistError, isAlreadyExistsError
@@ -199,9 +203,9 @@ import Distribution.Compat.CopyFile
( copyFile, copyOrdinaryFile, copyExecutableFile
, setFileOrdinary, setFileExecutable, setDirOrdinary )
import Distribution.Compat.TempFile
- ( openTempFile, openNewBinaryFile, createTempDirectory )
+ ( openTempFile, createTempDirectory )
import Distribution.Compat.Exception
- ( IOException, throwIOIO, tryIO, catchIO, catchExit, onException )
+ ( IOException, throwIOIO, tryIO, catchIO, catchExit )
import Distribution.Verbosity
#ifdef VERSION_base
@@ -374,6 +378,15 @@ rawSystemExit verbosity path args = do
debug verbosity $ path ++ " returned " ++ show exitcode
exitWith exitcode
+rawSystemExitCode :: Verbosity -> FilePath -> [String] -> IO ExitCode
+rawSystemExitCode verbosity path args = do
+ printRawCommandAndArgs verbosity path args
+ hFlush stdout
+ exitcode <- rawSystem path args
+ unless (exitcode == ExitSuccess) $ do
+ debug verbosity $ path ++ " returned " ++ show exitcode
+ return exitcode
+
rawSystemExitWithEnv :: Verbosity
-> FilePath
-> [String]
@@ -908,21 +921,16 @@ withFileContents name action =
-- On windows it is not possible to delete a file that is open by a process.
-- This case will give an IO exception but the atomic property is not affected.
--
-writeFileAtomic :: FilePath -> String -> IO ()
-writeFileAtomic targetFile content = do
- (tmpFile, tmpHandle) <- openNewBinaryFile targetDir template
- do hPutStr tmpHandle content
- hClose tmpHandle
- renameFile tmpFile targetFile
- `onException` do hClose tmpHandle
- removeFile tmpFile
- where
- template = targetName <.> "tmp"
- targetDir | null targetDir_ = currentDir
- | otherwise = targetDir_
- --TODO: remove this when takeDirectory/splitFileName is fixed
- -- to always return a valid dir
- (targetDir_,targetName) = splitFileName targetFile
+writeFileAtomic :: FilePath -> BS.ByteString -> IO ()
+writeFileAtomic targetPath content = do
+ let (targetDir, targetFile) = splitFileName targetPath
+ Exception.bracketOnError
+ (openBinaryTempFile targetDir $ targetFile <.> "tmp")
+ (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath)
+ (\(tmpPath, handle) -> do
+ BS.hPut handle content
+ hClose handle
+ renameFile tmpPath targetPath)
-- | Write a file but only if it would have new content. If we would be writing
-- the same as the existing content then leave the file as is so that we do not
@@ -934,9 +942,10 @@ rewriteFile path newContent =
existingContent <- readFile path
_ <- evaluate (length existingContent)
unless (existingContent == newContent) $
- writeFileAtomic path newContent
+ writeFileAtomic path (BS.Char8.pack newContent)
where
- mightNotExist e | isDoesNotExistError e = writeFileAtomic path newContent
+ mightNotExist e | isDoesNotExistError e = writeFileAtomic path
+ (BS.Char8.pack newContent)
| otherwise = ioError e
-- | The path name that represents the current directory.
@@ -979,7 +988,7 @@ findPackageDesc dir
multiDesc :: [String] -> IO a
multiDesc l = die $ "Multiple cabal files found.\n"
++ "Please use only one of: "
- ++ show l
+ ++ intercalate ", " l
-- |Optional auxiliary package information file (/pkgname/@.buildinfo@)
defaultHookedPackageDesc :: IO (Maybe FilePath)
@@ -1102,7 +1111,7 @@ withUTF8FileContents name action =
-- Uses 'writeFileAtomic', so provides the same guarantees.
--
writeUTF8File :: FilePath -> String -> IO ()
-writeUTF8File path = writeFileAtomic path . toUTF8
+writeUTF8File path = writeFileAtomic path . BS.Char8.pack . toUTF8
-- | Fix different systems silly line ending conventions
normaliseLineEndings :: String -> String
diff --git a/cabal/cabal/Distribution/System.hs b/cabal/Cabal/Distribution/System.hs
index 519d76a..519d76a 100644
--- a/cabal/cabal/Distribution/System.hs
+++ b/cabal/Cabal/Distribution/System.hs
diff --git a/cabal/Cabal/Distribution/TestSuite.hs b/cabal/Cabal/Distribution/TestSuite.hs
new file mode 100644
index 0000000..461f4e5
--- /dev/null
+++ b/cabal/Cabal/Distribution/TestSuite.hs
@@ -0,0 +1,125 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.TestSuite
+-- Copyright : Thomas Tuegel 2010
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Portability : portable
+--
+-- This module defines the detailed test suite interface which makes it
+-- possible to expose individual tests to Cabal or other test agents.
+
+{- 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.TestSuite
+ ( TestInstance(..)
+ , OptionDescr(..)
+ , OptionType(..)
+ , Test(..)
+ , Options
+ , Progress(..)
+ , Result(..)
+ , testGroup
+ ) where
+
+data TestInstance = TestInstance
+ { run :: IO Progress -- ^ Perform the test.
+ , name :: String -- ^ A name for the test, unique within a
+ -- test suite.
+ , tags :: [String] -- ^ Users can select groups of tests by
+ -- their tags.
+ , options :: [OptionDescr] -- ^ Descriptions of the options recognized
+ -- by this test.
+ , setOption :: String -> String -> Either String TestInstance
+ -- ^ Try to set the named option to the given value. Returns an error
+ -- message if the option is not supported or the value could not be
+ -- correctly parsed; otherwise, a 'TestInstance' with the option set to
+ -- the given value is returned.
+ }
+
+data OptionDescr = OptionDescr
+ { optionName :: String
+ , optionDescription :: String -- ^ A human-readable description of the
+ -- option to guide the user setting it.
+ , optionType :: OptionType
+ , optionDefault :: Maybe String
+ }
+ deriving (Eq, Read, Show)
+
+data OptionType
+ = OptionFile
+ { optionFileMustExist :: Bool
+ , optionFileIsDir :: Bool
+ , optionFileExtensions :: [String]
+ }
+ | OptionString
+ { optionStringMultiline :: Bool
+ }
+ | OptionNumber
+ { optionNumberIsInt :: Bool
+ , optionNumberBounds :: (Maybe String, Maybe String)
+ }
+ | OptionBool
+ | OptionEnum [String]
+ | OptionSet [String]
+ | OptionRngSeed
+ deriving (Eq, Read, Show)
+
+data Test
+ = Test TestInstance
+ | Group
+ { groupName :: String
+ , concurrently :: Bool
+ -- ^ If true, then children of this group may be run in parallel.
+ -- Note that this setting is not inherited by children. In
+ -- particular, consider a group F with "concurrently = False" that
+ -- has some children, including a group T with "concurrently =
+ -- True". The children of group T may be run concurrently with each
+ -- other, as long as none are run at the same time as any of the
+ -- direct children of group F.
+ , groupTests :: [Test]
+ }
+ | ExtraOptions [OptionDescr] Test
+
+type Options = [(String, String)]
+
+data Progress = Finished Result
+ | Progress String (IO Progress)
+
+data Result = Pass
+ | Fail String
+ | Error String
+ deriving (Eq, Read, Show)
+
+-- | Create a named group of tests, which are assumed to be safe to run in
+-- parallel.
+testGroup :: String -> [Test] -> Test
+testGroup n ts = Group { groupName = n, concurrently = True, groupTests = ts }
diff --git a/cabal/cabal/Distribution/Text.hs b/cabal/Cabal/Distribution/Text.hs
index b8a4cc6..b8a4cc6 100644
--- a/cabal/cabal/Distribution/Text.hs
+++ b/cabal/Cabal/Distribution/Text.hs
diff --git a/cabal/cabal/Distribution/Verbosity.hs b/cabal/Cabal/Distribution/Verbosity.hs
index 1e0d62e..1e0d62e 100644
--- a/cabal/cabal/Distribution/Verbosity.hs
+++ b/cabal/Cabal/Distribution/Verbosity.hs
diff --git a/cabal/cabal/Distribution/Version.hs b/cabal/Cabal/Distribution/Version.hs
index 446053d..5502a95 100644
--- a/cabal/cabal/Distribution/Version.hs
+++ b/cabal/Cabal/Distribution/Version.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveDataTypeable #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Version
@@ -91,6 +92,7 @@ module Distribution.Version (
) where
+import Data.Typeable ( Typeable )
import Data.Version ( Version(..) )
import Distribution.Text ( Text(..) )
@@ -116,7 +118,7 @@ data VersionRange
| UnionVersionRanges VersionRange VersionRange
| IntersectVersionRanges VersionRange VersionRange
| VersionRangeParens VersionRange -- just '(exp)' parentheses syntax
- deriving (Show,Read,Eq)
+ deriving (Show,Read,Eq,Typeable)
{-# DEPRECATED AnyVersion "Use 'anyVersion', 'foldVersionRange' or 'asVersionIntervals'" #-}
{-# DEPRECATED ThisVersion "use 'thisVersion', 'foldVersionRange' or 'asVersionIntervals'" #-}
diff --git a/cabal/cabal/LICENSE b/cabal/Cabal/LICENSE
index aa3f918..aa3f918 100644
--- a/cabal/cabal/LICENSE
+++ b/cabal/Cabal/LICENSE
diff --git a/cabal/cabal/Language/Haskell/Extension.hs b/cabal/Cabal/Language/Haskell/Extension.hs
index d864a12..2f12945 100644
--- a/cabal/cabal/Language/Haskell/Extension.hs
+++ b/cabal/Cabal/Language/Haskell/Extension.hs
@@ -436,6 +436,30 @@ data KnownExtension =
-- | Enable non-decreasing indentation for 'do' blocks.
| NondecreasingIndentation
+ -- | [GHC &#xa7; 7.20.3] Allow imports to be qualified with a safe
+ -- keyword that requires the imported module be trusted as according
+ -- to the Safe Haskell definition of trust.
+ --
+ -- > import safe Network.Socket
+ | SafeImports
+
+ -- | [GHC &#xa7; 7.20] Compile a module in the Safe, Safe Haskell
+ -- mode -- a restricted form of the Haskell language to ensure
+ -- type safety.
+ | Safe
+
+ -- | [GHC &#xa7; 7.20] Compile a module in the Trustworthy, Safe
+ -- Haskell mode -- no restrictions apply but the module is marked
+ -- as trusted as long as the package the module resides in is
+ -- trusted.
+ | Trustworthy
+
+ -- | [GHC &#xa7; 7.40] Allow type class/implicit parameter/equality
+ -- constraints to be used as types with the special kind Constraint.
+ -- Also generalise the (ctxt => ty) syntax so that any type of kind
+ -- Constraint can occur before the arrow.
+ | ConstraintKinds
+
deriving (Show, Read, Eq, Enum, Bounded)
{-# DEPRECATED knownExtensions
diff --git a/cabal/cabal/Makefile b/cabal/Cabal/Makefile
index 8619fc7..0d4f5b6 100644
--- a/cabal/cabal/Makefile
+++ b/cabal/Cabal/Makefile
@@ -1,5 +1,5 @@
-VERSION=1.11.2
+VERSION=1.14.0
#KIND=devel
KIND=rc
diff --git a/cabal/cabal/README b/cabal/Cabal/README
index 5713b62..457b365 100644
--- a/cabal/cabal/README
+++ b/cabal/Cabal/README
@@ -10,6 +10,17 @@ the `cabal-install` package in addition to this library.
Installation instructions for the Cabal library
===============================================
+If you have the `cabal` program already
+---------------------------------------
+
+In this case it's simple, just
+
+ cabal install
+
+Of course, if you don't have an existing version of the `cabal` program
+then to get one you'd first need to install the Cabal library! To avoid
+this bootstrapping problem, you can install the Cabal library directly:
+
Installing as a user (no root or administer access)
---------------------------------------------------
diff --git a/cabal/cabal/Setup.hs b/cabal/Cabal/Setup.hs
index 48c49ca..48c49ca 100644
--- a/cabal/cabal/Setup.hs
+++ b/cabal/Cabal/Setup.hs
diff --git a/cabal/cabal/changelog b/cabal/Cabal/changelog
index aabf8a2..aabf8a2 100644
--- a/cabal/cabal/changelog
+++ b/cabal/Cabal/changelog
diff --git a/cabal/cabal/doc/Cabal.css b/cabal/Cabal/doc/Cabal.css
index 97f276c..97f276c 100644
--- a/cabal/cabal/doc/Cabal.css
+++ b/cabal/Cabal/doc/Cabal.css
diff --git a/cabal/cabal/doc/developing-packages.markdown b/cabal/Cabal/doc/developing-packages.markdown
index 2993210..c28e60d 100644
--- a/cabal/cabal/doc/developing-packages.markdown
+++ b/cabal/Cabal/doc/developing-packages.markdown
@@ -521,7 +521,7 @@ interface. The `exitcode-stdio-1.0` type requires the `main-is` field.
`main-is` field of an executable section.
Test suites using the `detailed-1.0` interface are modules exporting the symbol
-`tests :: [Test]`. The `Test` type is exported by the module
+`tests :: IO [Test]`. The `Test` type is exported by the module
`Distribution.TestSuite` provided by Cabal. For more details, see the example below.
The `detailed-1.0` interface allows Cabal and other test agents to inspect a
@@ -587,42 +587,132 @@ Build-Type: Simple
Test-Suite test-bar
type: detailed-1.0
- test-module: Test.Bar
+ test-module: Bar
build-depends: base, Cabal >= 1.9.2
~~~~~~~~~~~~~~~~
-Test/Bar.hs:
+Bar.hs:
~~~~~~~~~~~~~~~~
-{-# LANGUAGE FlexibleInstances #-}
-module Test.Bar ( tests ) where
+module Bar ( tests ) where
import Distribution.TestSuite
-instance TestOptions (String, Bool) where
- name = fst
- options = const []
- defaultOptions _ = return (Options [])
- check _ _ = []
+tests :: IO [Test]
+tests = return [ Test succeeds, Test fails ]
+ where
+ succeeds = TestInstance
+ { run = return $ Finished Pass
+ , name = "succeeds"
+ , tags = []
+ , options = []
+ , setOption = \_ _ -> Right succeeds
+ }
+ fails = TestInstance
+ { run = return $ Finished $ Fail "Always fails!"
+ , name = "fails"
+ , tags = []
+ , options = []
+ , setOption = \_ _ -> Right fails
+ }
+~~~~~~~~~~~~~~~~
+
+#### Running test suites ####
+
+You can have Cabal run your test suites using its built-in test
+runner:
+
+~~~~~~~~~~~~~~~~
+$ cabal configure --enable-tests
+$ cabal build
+$ cabal test
+~~~~~~~~~~~~~~~~
+
+See the output of `cabal help test` for a list of options you can pass
+to `cabal test`.
+
+### Benchmarks ###
+
+Benchmark sections (if present) describe benchmarks contained in the package and
+must have an argument after the section label, which defines the name of the
+benchmark. This is a freeform argument, but may not contain spaces. It should
+be unique among the names of the package's other benchmarks, the package's test
+suites, the package's executables, and the package itself. Using benchmark
+sections requires at least Cabal version 1.9.2.
+
+The benchmark may be described using the following fields, as well as build
+information fields (see the section on [build information](#build-information)).
+
+`type:` _interface_ (required)
+: The interface type and version of the benchmark. At the moment Cabal only
+ support one benchmark interface, called `exitcode-stdio-1.0`.
+
+Benchmarks using the `exitcode-stdio-1.0` interface are executables that
+indicate failure to run the benchmark with a non-zero exit code when run; they
+may provide human-readable information through the standard output and error
+channels.
+
+`main-is:` _filename_ (required: `exitcode-stdio-1.0`)
+: The name of the `.hs` or `.lhs` file containing the `Main` module. Note that it is the
+ `.hs` filename that must be listed, even if that file is generated
+ using a preprocessor. The source file must be relative to one of the
+ directories listed in `hs-source-dirs`. This field is analogous to the
+ `main-is` field of an executable section.
+
+#### Example: Package using `exitcode-stdio-1.0` interface ####
+
+The example package description and executable source file below demonstrate
+the use of the `exitcode-stdio-1.0` interface. For brevity, the example package
+does not include a library or any normal executables, but a real package would
+be required to have at least one library or executable.
+
+foo.cabal:
+
+~~~~~~~~~~~~~~~~
+Name: foo
+Version: 1.0
+License: BSD3
+Cabal-Version: >= 1.9.2
+Build-Type: Simple
+
+Benchmark bench-foo
+ type: exitcode-stdio-1.0
+ main-is: bench-foo.hs
+ build-depends: base, time
+~~~~~~~~~~~~~~~~
+
+bench-foo.hs:
+
+~~~~~~~~~~~~~~~~
+{-# LANGUAGE BangPatterns #-}
+module Main where
-instance PureTestable (String, Bool) where
- run (name, result) _ | result == True = Pass
- | result == False = Fail (name ++ " failed!")
+import Data.Time.Clock
-test :: (String, Bool) -> Test
-test = pure
+fib 0 = 1
+fib 1 = 1
+fib n = fib (n-1) + fib (n-2)
--- In actual usage, the instances 'TestOptions (String, Bool)' and
--- 'PureTestable (String, Bool)', as well as the function 'test', would be
--- provided by the test framework.
+main = do
+ start <- getCurrentTime
+ let !r = fib 20
+ end <- getCurrentTime
+ putStrLn $ "fib 20 took " ++ show (diffUTCTime end start)
+~~~~~~~~~~~~~~~~
+
+#### Running benchmarks ####
-tests :: [Test]
-tests =
- [ test ("bar-1", True)
- , test ("bar-2", False)
- ]
+You can have Cabal run your benchmark using its built-in benchmark runner:
+
+~~~~~~~~~~~~~~~~
+$ cabal configure --enable-benchmarks
+$ cabal build
+$ cabal bench
~~~~~~~~~~~~~~~~
+See the output of `cabal help bench` for a list of options you can
+pass to `cabal bench`.
+
### Build information ###
The following fields may be optionally present in a library or
diff --git a/cabal/cabal/doc/index.markdown b/cabal/Cabal/doc/index.markdown
index ad3eba9..ad3eba9 100644
--- a/cabal/cabal/doc/index.markdown
+++ b/cabal/Cabal/doc/index.markdown
diff --git a/cabal/cabal/doc/installing-packages.markdown b/cabal/Cabal/doc/installing-packages.markdown
index 624d0ca..624d0ca 100644
--- a/cabal/cabal/doc/installing-packages.markdown
+++ b/cabal/Cabal/doc/installing-packages.markdown
diff --git a/cabal/cabal/doc/misc.markdown b/cabal/Cabal/doc/misc.markdown
index 7690861..7690861 100644
--- a/cabal/cabal/doc/misc.markdown
+++ b/cabal/Cabal/doc/misc.markdown
diff --git a/cabal/cabal/prologue.txt b/cabal/Cabal/prologue.txt
index f583baa..f583baa 100644
--- a/cabal/cabal/prologue.txt
+++ b/cabal/Cabal/prologue.txt
diff --git a/cabal/cabal/runTests.sh b/cabal/Cabal/runTests.sh
index 34f8589..34f8589 100644
--- a/cabal/cabal/runTests.sh
+++ b/cabal/Cabal/runTests.sh
diff --git a/cabal/cabal/tests/suite.hs b/cabal/Cabal/tests/PackageTests.hs
index c513ea3..bd8ef6b 100644
--- a/cabal/cabal/tests/suite.hs
+++ b/cabal/Cabal/tests/PackageTests.hs
@@ -10,6 +10,9 @@ import Test.Framework
import Test.Framework.Providers.HUnit
import Test.Framework.Providers.QuickCheck2
import qualified Test.HUnit as HUnit
+import PackageTests.BenchmarkExeV10.Check
+import PackageTests.BenchmarkOptions.Check
+import PackageTests.BenchmarkStanza.Check
import PackageTests.BuildDeps.SameDepsAllRound.Check
import PackageTests.BuildDeps.TargetSpecificDeps1.Check
import PackageTests.BuildDeps.TargetSpecificDeps1.Check
@@ -22,8 +25,10 @@ import PackageTests.BuildDeps.InternalLibrary1.Check
import PackageTests.BuildDeps.InternalLibrary2.Check
import PackageTests.BuildDeps.InternalLibrary3.Check
import PackageTests.BuildDeps.InternalLibrary4.Check
+import PackageTests.TestOptions.Check
import PackageTests.TestStanza.Check
import PackageTests.TestSuiteExeV10.Check
+import PackageTests.TemplateHaskell.Check
import Distribution.Text (display)
import Distribution.Simple.Utils (cabalVersion)
import Data.Version
@@ -35,8 +40,10 @@ hunit name test = testGroup name $ hUnitTestToTests test
tests :: Version -> [Test]
tests cabalVersion = [
hunit "PackageTests/BuildDeps/SameDepsAllRound/" PackageTests.BuildDeps.SameDepsAllRound.Check.suite,
- hunit "PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/" PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check.suite,
- hunit "PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/" PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check.suite,
+ -- The two following tests were disabled by Johan Tibell as
+ -- they have been failing for a long time:
+ -- hunit "PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/" PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check.suite,
+ -- hunit "PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/" PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check.suite,
hunit "PackageTests/BuildDeps/InternalLibrary0/" (PackageTests.BuildDeps.InternalLibrary0.Check.suite cabalVersion),
hunit "PackageTests/TestStanza/" (PackageTests.TestStanza.Check.suite cabalVersion),
-- ^ The Test stanza test will eventually be required
@@ -44,7 +51,16 @@ tests cabalVersion = [
hunit "PackageTests/TestSuiteExeV10/Test"
(PackageTests.TestSuiteExeV10.Check.checkTest cabalVersion),
hunit "PackageTests/TestSuiteExeV10/TestWithHpc"
- (PackageTests.TestSuiteExeV10.Check.checkTestWithHpc cabalVersion)
+ (PackageTests.TestSuiteExeV10.Check.checkTestWithHpc cabalVersion),
+ hunit "PackageTests/TestOptions" PackageTests.TestOptions.Check.suite,
+ hunit "PackageTests/BenchmarkStanza/" (PackageTests.BenchmarkStanza.Check.suite cabalVersion),
+ -- ^ The benchmark stanza test will eventually be required
+ -- only for higher versions.
+ hunit "PackageTests/BenchmarkExeV10/Test"
+ (PackageTests.BenchmarkExeV10.Check.checkBenchmark cabalVersion),
+ hunit "PackageTests/BenchmarkOptions" PackageTests.BenchmarkOptions.Check.suite,
+ hunit "PackageTests/TemplateHaskell/profiling" PackageTests.TemplateHaskell.Check.profiling,
+ hunit "PackageTests/TemplateHaskell/dynamic" PackageTests.TemplateHaskell.Check.dynamic
] ++
-- These tests are only required to pass on cabal version >= 1.7
(if cabalVersion >= Version [1, 7] []
diff --git a/cabal/Cabal/tests/PackageTests/BenchmarkExeV10/Check.hs b/cabal/Cabal/tests/PackageTests/BenchmarkExeV10/Check.hs
new file mode 100644
index 0000000..c99d5f9
--- /dev/null
+++ b/cabal/Cabal/tests/PackageTests/BenchmarkExeV10/Check.hs
@@ -0,0 +1,21 @@
+module PackageTests.BenchmarkExeV10.Check
+ ( checkBenchmark
+ ) where
+
+import Distribution.PackageDescription ( Benchmark(..), emptyBenchmark )
+import Distribution.Simple.Hpc
+import Distribution.Version
+import Test.HUnit
+import System.Directory
+import System.FilePath
+import PackageTests.PackageTester
+
+dir :: FilePath
+dir = "PackageTests" </> "BenchmarkExeV10"
+
+checkBenchmark :: Version -> Test
+checkBenchmark cabalVersion = TestCase $ do
+ let spec = PackageSpec dir ["--enable-benchmarks"]
+ buildResult <- cabal_build spec
+ let buildMessage = "\'setup build\' should succeed"
+ assertEqual buildMessage True $ successful buildResult
diff --git a/cabal/cabal/tests/PackageTests/TestSuiteExeV10/Foo.hs b/cabal/Cabal/tests/PackageTests/BenchmarkExeV10/Foo.hs
index 2d3e705..2d3e705 100644
--- a/cabal/cabal/tests/PackageTests/TestSuiteExeV10/Foo.hs
+++ b/cabal/Cabal/tests/PackageTests/BenchmarkExeV10/Foo.hs
diff --git a/cabal/cabal/tests/Setup.hs b/cabal/Cabal/tests/PackageTests/BenchmarkExeV10/Setup.hs
index 200a2e5..200a2e5 100644
--- a/cabal/cabal/tests/Setup.hs
+++ b/cabal/Cabal/tests/PackageTests/BenchmarkExeV10/Setup.hs
diff --git a/cabal/cabal/tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs b/cabal/Cabal/tests/PackageTests/BenchmarkExeV10/benchmarks/bench-Foo.hs
index 6951cac..6951cac 100644
--- a/cabal/cabal/tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs
+++ b/cabal/Cabal/tests/PackageTests/BenchmarkExeV10/benchmarks/bench-Foo.hs
diff --git a/cabal/Cabal/tests/PackageTests/BenchmarkExeV10/my.cabal b/cabal/Cabal/tests/PackageTests/BenchmarkExeV10/my.cabal
new file mode 100644
index 0000000..e4f2740
--- /dev/null
+++ b/cabal/Cabal/tests/PackageTests/BenchmarkExeV10/my.cabal
@@ -0,0 +1,15 @@
+name: my
+version: 0.1
+license: BSD3
+cabal-version: >= 1.9.2
+build-type: Simple
+
+library
+ exposed-modules: Foo
+ build-depends: base
+
+benchmark bench-Foo
+ type: exitcode-stdio-1.0
+ hs-source-dirs: benchmarks
+ main-is: bench-Foo.hs
+ build-depends: base, my
diff --git a/cabal/Cabal/tests/PackageTests/BenchmarkOptions/BenchmarkOptions.cabal b/cabal/Cabal/tests/PackageTests/BenchmarkOptions/BenchmarkOptions.cabal
new file mode 100644
index 0000000..e35702c
--- /dev/null
+++ b/cabal/Cabal/tests/PackageTests/BenchmarkOptions/BenchmarkOptions.cabal
@@ -0,0 +1,20 @@
+name: BenchmarkOptions
+version: 0.1
+license: BSD3
+author: Johan Tibell
+stability: stable
+category: PackageTests
+build-type: Simple
+cabal-version: >= 1.9.2
+
+description:
+ Check that Cabal passes the correct test options to test suites.
+
+executable dummy
+ main-is: test-BenchmarkOptions.hs
+ build-depends: base
+
+benchmark test-BenchmarkOptions
+ main-is: test-BenchmarkOptions.hs
+ type: exitcode-stdio-1.0
+ build-depends: base
diff --git a/cabal/Cabal/tests/PackageTests/BenchmarkOptions/Check.hs b/cabal/Cabal/tests/PackageTests/BenchmarkOptions/Check.hs
new file mode 100644
index 0000000..dbb7a74
--- /dev/null
+++ b/cabal/Cabal/tests/PackageTests/BenchmarkOptions/Check.hs
@@ -0,0 +1,23 @@
+module PackageTests.BenchmarkOptions.Check where
+
+import Test.HUnit
+import System.FilePath
+import PackageTests.PackageTester
+
+suite :: Test
+suite = TestCase $ do
+ let directory = "PackageTests" </> "BenchmarkOptions"
+ pdFile = directory </> "BenchmarkOptions" <.> "cabal"
+ spec = PackageSpec directory ["--enable-benchmarks"]
+ _ <- cabal_build spec
+ result <- cabal_bench spec ["--benchmark-options=1 2 3"]
+ let message = "\"cabal bench\" did not pass the correct options to the "
+ ++ "benchmark executable with \"--benchmark-options\""
+ assertEqual message True $ successful result
+ result' <- cabal_bench spec [ "--benchmark-option=1"
+ , "--benchmark-option=2"
+ , "--benchmark-option=3"
+ ]
+ let message = "\"cabal bench\" did not pass the correct options to the "
+ ++ "benchmark executable with \"--benchmark-option\""
+ assertEqual message True $ successful result'
diff --git a/cabal/cabal/tests/PackageTests/TestSuiteExeV10/Setup.hs b/cabal/Cabal/tests/PackageTests/BenchmarkOptions/Setup.hs
index 200a2e5..200a2e5 100644
--- a/cabal/cabal/tests/PackageTests/TestSuiteExeV10/Setup.hs
+++ b/cabal/Cabal/tests/PackageTests/BenchmarkOptions/Setup.hs
diff --git a/cabal/Cabal/tests/PackageTests/BenchmarkOptions/test-BenchmarkOptions.hs b/cabal/Cabal/tests/PackageTests/BenchmarkOptions/test-BenchmarkOptions.hs
new file mode 100644
index 0000000..7c21bff
--- /dev/null
+++ b/cabal/Cabal/tests/PackageTests/BenchmarkOptions/test-BenchmarkOptions.hs
@@ -0,0 +1,11 @@
+module Main where
+
+import System.Environment ( getArgs )
+import System.Exit ( exitFailure, exitSuccess )
+
+main :: IO ()
+main = do
+ args <- getArgs
+ if args == ["1", "2", "3"]
+ then exitSuccess
+ else putStrLn ("Got: " ++ show args) >> exitFailure
diff --git a/cabal/Cabal/tests/PackageTests/BenchmarkStanza/Check.hs b/cabal/Cabal/tests/PackageTests/BenchmarkStanza/Check.hs
new file mode 100644
index 0000000..3f83002
--- /dev/null
+++ b/cabal/Cabal/tests/PackageTests/BenchmarkStanza/Check.hs
@@ -0,0 +1,57 @@
+module PackageTests.BenchmarkStanza.Check where
+
+import Test.HUnit
+import System.FilePath
+import PackageTests.PackageTester
+import Data.List (isInfixOf, intercalate)
+import Distribution.Version
+import Distribution.PackageDescription.Parse
+ ( readPackageDescription )
+import Distribution.PackageDescription.Configuration
+ ( finalizePackageDescription )
+import Distribution.Package
+ ( PackageIdentifier(..), PackageName(..), Dependency(..) )
+import Distribution.PackageDescription
+ ( PackageDescription(..), BuildInfo(..), Benchmark(..), Library(..)
+ , BenchmarkInterface(..)
+ , TestType(..), emptyPackageDescription, emptyBuildInfo, emptyLibrary
+ , emptyBenchmark, BuildType(..) )
+import Distribution.Verbosity (silent)
+import Distribution.License (License(..))
+import Distribution.ModuleName (fromString)
+import Distribution.System (buildPlatform)
+import Distribution.Compiler
+ ( CompilerId(..), CompilerFlavor(..) )
+import Distribution.Text
+
+suite :: Version -> Test
+suite cabalVersion = TestCase $ do
+ let directory = "PackageTests" </> "BenchmarkStanza"
+ pdFile = directory </> "my" <.> "cabal"
+ spec = PackageSpec directory []
+ result <- cabal_configure spec
+ let message = "cabal configure should recognize benchmark section"
+ test = "unknown section type"
+ `isInfixOf`
+ (intercalate " " $ lines $ outputText result)
+ assertEqual message False test
+ genPD <- readPackageDescription silent pdFile
+ let compiler = CompilerId GHC $ Version [6, 12, 2] []
+ anyV = intersectVersionRanges anyVersion anyVersion
+ anticipatedBenchmark = emptyBenchmark
+ { benchmarkName = "dummy"
+ , benchmarkInterface = BenchmarkExeV10 (Version [1,0] []) "dummy.hs"
+ , benchmarkBuildInfo = emptyBuildInfo
+ { targetBuildDepends =
+ [ Dependency (PackageName "base") anyVersion ]
+ , hsSourceDirs = ["."]
+ }
+ , benchmarkEnabled = False
+ }
+ case finalizePackageDescription [] (const True) buildPlatform compiler [] genPD of
+ Left xs -> let depMessage = "should not have missing dependencies:\n" ++
+ (unlines $ map (show . disp) xs)
+ in assertEqual depMessage True False
+ Right (f, _) -> let gotBenchmark = head $ benchmarks f
+ in assertEqual "parsed benchmark stanza does not match anticipated"
+ gotBenchmark anticipatedBenchmark
diff --git a/cabal/cabal/tests/PackageTests/TestStanza/Setup.hs b/cabal/Cabal/tests/PackageTests/BenchmarkStanza/Setup.hs
index 200a2e5..200a2e5 100644
--- a/cabal/cabal/tests/PackageTests/TestStanza/Setup.hs
+++ b/cabal/Cabal/tests/PackageTests/BenchmarkStanza/Setup.hs
diff --git a/cabal/Cabal/tests/PackageTests/BenchmarkStanza/my.cabal b/cabal/Cabal/tests/PackageTests/BenchmarkStanza/my.cabal
new file mode 100644
index 0000000..e41f3ab
--- /dev/null
+++ b/cabal/Cabal/tests/PackageTests/BenchmarkStanza/my.cabal
@@ -0,0 +1,19 @@
+name: BenchmarkStanza
+version: 0.1
+license: BSD3
+author: Johan Tibell
+stability: stable
+category: PackageTests
+build-type: Simple
+
+description:
+ Check that Cabal recognizes the benchmark stanza defined below.
+
+Library
+ exposed-modules: MyLibrary
+ build-depends: base
+
+benchmark dummy
+ main-is: dummy.hs
+ type: exitcode-stdio-1.0
+ build-depends: base \ No newline at end of file
diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs
new file mode 100644
index 0000000..dabb9b4
--- /dev/null
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs
@@ -0,0 +1,22 @@
+module PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check where
+
+import Test.HUnit
+import PackageTests.PackageTester
+import System.FilePath
+import Data.List
+import Control.Exception
+import Prelude hiding (catch)
+
+
+suite :: Test
+suite = TestCase $ do
+ let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "GlobalBuildDepsNotAdditive1") []
+ result <- cabal_build spec
+ do
+ assertEqual "cabal build should fail - see test-log.txt" False (successful result)
+ let sb = "Could not find module `Prelude'"
+ assertBool ("cabal output should be "++show sb) $
+ sb `isInfixOf` outputText result
+ `catch` \exc -> do
+ putStrLn $ "Cabal result was "++show result
+ throwIO (exc :: SomeException)
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal b/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal
index 2bc350c..2bc350c 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs
index 666fdb7..666fdb7 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Setup.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Setup.hs
index 200a2e5..200a2e5 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Setup.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Setup.hs
diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs
new file mode 100644
index 0000000..cdebfc2
--- /dev/null
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs
@@ -0,0 +1,22 @@
+module PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check where
+
+import Test.HUnit
+import PackageTests.PackageTester
+import System.FilePath
+import Data.List
+import Control.Exception
+import Prelude hiding (catch)
+
+
+suite :: Test
+suite = TestCase $ do
+ let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "GlobalBuildDepsNotAdditive2") []
+ result <- cabal_build spec
+ do
+ assertEqual "cabal build should fail - see test-log.txt" False (successful result)
+ let sb = "Could not find module `Prelude'"
+ assertBool ("cabal output should be "++show sb) $
+ sb `isInfixOf` outputText result
+ `catch` \exc -> do
+ putStrLn $ "Cabal result was "++show result
+ throwIO (exc :: SomeException)
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal b/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal
index 4487049..4487049 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Setup.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Setup.hs
index 200a2e5..200a2e5 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Setup.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Setup.hs
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs
index 06328a5..06328a5 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs
diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs
new file mode 100644
index 0000000..eddc994
--- /dev/null
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs
@@ -0,0 +1,26 @@
+module PackageTests.BuildDeps.InternalLibrary0.Check where
+
+import Test.HUnit
+import PackageTests.PackageTester
+import Control.Monad
+import System.FilePath
+import Data.Version
+import Data.List (isInfixOf, intercalate)
+import Control.Exception
+import Prelude hiding (catch)
+
+
+suite :: Version -> Test
+suite cabalVersion = TestCase $ do
+ let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "InternalLibrary0") []
+ result <- cabal_build spec
+ do
+ assertEqual "cabal build should fail" False (successful result)
+ when (cabalVersion >= Version [1, 7] []) $ do
+ let sb = "library which is defined within the same package."
+ -- In 1.7 it should tell you how to enable the desired behaviour.
+ assertEqual ("cabal output should say "++show sb) True $
+ sb `isInfixOf` (intercalate " " $ lines $ outputText result)
+ `catch` \exc -> do
+ putStrLn $ "Cabal result was "++show result
+ throwIO (exc :: SomeException)
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs
index 666fdb7..666fdb7 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Setup.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Setup.hs
index 200a2e5..200a2e5 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Setup.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Setup.hs
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal
index 0929d9e..0929d9e 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs
index 32c2fa8..32c2fa8 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs
index 9695f09..86d378e 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs
@@ -3,10 +3,16 @@ module PackageTests.BuildDeps.InternalLibrary1.Check where
import Test.HUnit
import PackageTests.PackageTester
import System.FilePath
+import Control.Exception
+import Prelude hiding (catch)
suite :: Test
suite = TestCase $ do
let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "InternalLibrary1") []
result <- cabal_build spec
- assertEqual "cabal build should succeed - see test-log.txt" True (successful result)
+ do
+ assertEqual "cabal build should succeed - see test-log.txt" True (successful result)
+ `catch` \exc -> do
+ putStrLn $ "Cabal result was "++show result
+ throwIO (exc :: SomeException)
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs
index 666fdb7..666fdb7 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Setup.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Setup.hs
index 200a2e5..200a2e5 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Setup.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Setup.hs
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal
index fe0212c..fe0212c 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs
index 32c2fa8..32c2fa8 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs
index 16845bb..b10dfd9 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs
@@ -4,6 +4,8 @@ import Test.HUnit
import PackageTests.PackageTester
import System.FilePath
import qualified Data.ByteString.Char8 as C
+import Control.Exception
+import Prelude hiding (catch)
suite :: Test
@@ -13,9 +15,17 @@ suite = TestCase $ do
unregister "InternalLibrary2"
iResult <- cabal_install specTI
- assertEqual "cabal install should succeed - see to-install/test-log.txt" True (successful iResult)
+ do
+ assertEqual "cabal install should succeed" True (successful iResult)
+ `catch` \exc -> do
+ putStrLn $ "Cabal result was "++show iResult
+ throwIO (exc :: SomeException)
bResult <- cabal_build spec
- assertEqual "cabal build should succeed - see test-log.txt" True (successful bResult)
+ do
+ assertEqual "cabal build should succeed" True (successful bResult)
+ `catch` \exc -> do
+ putStrLn $ "Cabal result was "++show bResult
+ throwIO (exc :: SomeException)
unregister "InternalLibrary2"
(_, _, output) <- run (Just $ directory spec) "dist/build/lemon/lemon" []
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs
index a988f04..a988f04 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/Setup.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Setup.hs
index 200a2e5..200a2e5 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/Setup.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Setup.hs
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal
index 75e599d..75e599d 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs
index 32c2fa8..32c2fa8 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs
index 6aa4a9e..6aa4a9e 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Setup.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/Setup.hs
index 200a2e5..200a2e5 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Setup.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/Setup.hs
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal
index c48f3b8..c48f3b8 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs
index 4558e79..605b3f2 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs
@@ -4,6 +4,8 @@ import Test.HUnit
import PackageTests.PackageTester
import System.FilePath
import qualified Data.ByteString.Char8 as C
+import Control.Exception
+import Prelude hiding (catch)
suite :: Test
@@ -13,9 +15,17 @@ suite = TestCase $ do
unregister "InternalLibrary3"
iResult <- cabal_install specTI
- assertEqual "cabal install should succeed - see to-install/test-log.txt" True (successful iResult)
+ do
+ assertEqual "cabal install should succeed - see to-install/test-log.txt" True (successful iResult)
+ `catch` \exc -> do
+ putStrLn $ "Cabal result was "++show iResult
+ throwIO (exc :: SomeException)
bResult <- cabal_build spec
- assertEqual "cabal build should succeed - see test-log.txt" True (successful bResult)
+ do
+ assertEqual "cabal build should succeed - see test-log.txt" True (successful bResult)
+ `catch` \exc -> do
+ putStrLn $ "Cabal result was "++show bResult
+ throwIO (exc :: SomeException)
unregister "InternalLibrary3"
(_, _, output) <- run (Just $ directory spec) "dist/build/lemon/lemon" []
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs
index a988f04..a988f04 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/Setup.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Setup.hs
index 200a2e5..200a2e5 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/Setup.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Setup.hs
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal
index d0ba998..d0ba998 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs
index 32c2fa8..32c2fa8 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs
index 6aa4a9e..6aa4a9e 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Setup.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/Setup.hs
index 200a2e5..200a2e5 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Setup.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/Setup.hs
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal
index aa39872..aa39872 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs
index 07b6519..ef5a5c7 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs
@@ -4,6 +4,8 @@ import Test.HUnit
import PackageTests.PackageTester
import System.FilePath
import qualified Data.ByteString.Char8 as C
+import Control.Exception
+import Prelude hiding (catch)
suite :: Test
@@ -13,9 +15,17 @@ suite = TestCase $ do
unregister "InternalLibrary4"
iResult <- cabal_install specTI
- assertEqual "cabal install should succeed - see to-install/test-log.txt" True (successful iResult)
+ do
+ assertEqual "cabal install should succeed - see to-install/test-log.txt" True (successful iResult)
+ `catch` \exc -> do
+ putStrLn $ "Cabal result was "++show iResult
+ throwIO (exc :: SomeException)
bResult <- cabal_build spec
- assertEqual "cabal build should succeed - see test-log.txt" True (successful bResult)
+ do
+ assertEqual "cabal build should succeed - see test-log.txt" True (successful bResult)
+ `catch` \exc -> do
+ putStrLn $ "Cabal result was "++show bResult
+ throwIO (exc :: SomeException)
unregister "InternalLibrary4"
(_, _, output) <- run (Just $ directory spec) "dist/build/lemon/lemon" []
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs
index a988f04..a988f04 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/Setup.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Setup.hs
index 200a2e5..200a2e5 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/Setup.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Setup.hs
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal
index 3fbc132..3fbc132 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs
index 32c2fa8..32c2fa8 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs
index 6aa4a9e..6aa4a9e 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Setup.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/Setup.hs
index 200a2e5..200a2e5 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Setup.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/Setup.hs
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal
index 5e72e0b..5e72e0b 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs
index a2ff086..63bb2c8 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs
@@ -3,10 +3,16 @@ module PackageTests.BuildDeps.SameDepsAllRound.Check where
import Test.HUnit
import PackageTests.PackageTester
import System.FilePath
+import Control.Exception
+import Prelude hiding (catch)
suite :: Test
suite = TestCase $ do
let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "SameDepsAllRound") []
result <- cabal_build spec
- assertEqual "cabal build should succeed - see test-log.txt" True (successful result)
+ do
+ assertEqual "cabal build should succeed - see test-log.txt" True (successful result)
+ `catch` \exc -> do
+ putStrLn $ "Cabal result was "++show result
+ throwIO (exc :: SomeException)
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs
index 666fdb7..666fdb7 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal b/cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal
index 4c6abb9..4c6abb9 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Setup.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Setup.hs
index 200a2e5..200a2e5 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Setup.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Setup.hs
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs
index 06328a5..06328a5 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs
index 40f30bd..40f30bd 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs
diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs
new file mode 100644
index 0000000..189866d
--- /dev/null
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs
@@ -0,0 +1,24 @@
+module PackageTests.BuildDeps.TargetSpecificDeps1.Check where
+
+import Test.HUnit
+import PackageTests.PackageTester
+import System.FilePath
+import Data.List
+import Control.Exception
+import Prelude hiding (catch)
+
+
+suite :: Test
+suite = TestCase $ do
+ let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "TargetSpecificDeps1") []
+ result <- cabal_build spec
+ do
+ assertEqual "cabal build should fail - see test-log.txt" False (successful result)
+ assertBool "error should be in MyLibrary.hs" $
+ "MyLibrary.hs:" `isInfixOf` outputText result
+ assertBool "error should be \"Could not find module `System.Time\"" $
+ "Could not find module `System.Time'" `isInfixOf`
+ (intercalate " " $ lines $ outputText result)
+ `catch` \exc -> do
+ putStrLn $ "Cabal result was "++show result
+ throwIO (exc :: SomeException)
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs
index 666fdb7..666fdb7 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Setup.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Setup.hs
index 200a2e5..200a2e5 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Setup.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Setup.hs
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs
index 06328a5..06328a5 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal
index 1e8761f..1e8761f 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs
index 02732fc..76738d7 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs
@@ -4,10 +4,16 @@ import Test.HUnit
import PackageTests.PackageTester
import System.FilePath
import Data.List
+import Control.Exception
+import Prelude hiding (catch)
suite :: Test
suite = TestCase $ do
let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "TargetSpecificDeps2") []
result <- cabal_build spec
- assertEqual "cabal build should succeed - see test-log.txt" True (successful result)
+ do
+ assertEqual "cabal build should succeed - see test-log.txt" True (successful result)
+ `catch` \exc -> do
+ putStrLn $ "Cabal result was "++show result
+ throwIO (exc :: SomeException)
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs
index 666fdb7..666fdb7 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Setup.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Setup.hs
index 200a2e5..200a2e5 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Setup.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Setup.hs
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs
index ffdccbc..ffdccbc 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal
index 97a8c79..97a8c79 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal
diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs
new file mode 100644
index 0000000..5b15a3d
--- /dev/null
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs
@@ -0,0 +1,23 @@
+module PackageTests.BuildDeps.TargetSpecificDeps3.Check where
+
+import Test.HUnit
+import PackageTests.PackageTester
+import System.FilePath
+import Data.List
+import Control.Exception
+import Prelude hiding (catch)
+
+
+suite :: Test
+suite = TestCase $ do
+ let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "TargetSpecificDeps3") []
+ result <- cabal_build spec
+ do
+ assertEqual "cabal build should fail - see test-log.txt" False (successful result)
+ assertBool "error should be in lemon.hs" $
+ "lemon.hs:" `isInfixOf` outputText result
+ assertBool "error should be \"Could not find module `System.Time\"" $
+ "Could not find module `System.Time'" `isInfixOf` (intercalate " " $ lines $ outputText result)
+ `catch` \exc -> do
+ putStrLn $ "Cabal result was "++show result
+ throwIO (exc :: SomeException)
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs
index 666fdb7..666fdb7 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Setup.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Setup.hs
index 200a2e5..200a2e5 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Setup.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Setup.hs
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs
index 06328a5..06328a5 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs
diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal
index 41e44c1..41e44c1 100644
--- a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal
+++ b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal
diff --git a/cabal/cabal/tests/PackageTests/PackageTester.hs b/cabal/Cabal/tests/PackageTests/PackageTester.hs
index f9ec3c5..fbc8529 100644
--- a/cabal/cabal/tests/PackageTests/PackageTester.hs
+++ b/cabal/Cabal/tests/PackageTests/PackageTester.hs
@@ -5,6 +5,7 @@ module PackageTests.PackageTester (
cabal_configure,
cabal_build,
cabal_test,
+ cabal_bench,
cabal_install,
unregister,
run
@@ -32,7 +33,13 @@ data PackageSpec =
configOpts :: [String]
}
-data Success = Failure | ConfigureSuccess | BuildSuccess | InstallSuccess | TestSuccess deriving (Eq, Show)
+data Success = Failure
+ | ConfigureSuccess
+ | BuildSuccess
+ | InstallSuccess
+ | TestSuccess
+ | BenchSuccess
+ deriving (Eq, Show)
data Result = Result {
successful :: Bool,
@@ -104,20 +111,28 @@ cabal_install spec = do
record spec res
return res
-cabal_test :: PackageSpec -> IO Result
-cabal_test spec = do
- res <- cabal spec ["test"]
+cabal_test :: PackageSpec -> [String] -> IO Result
+cabal_test spec extraArgs = do
+ res <- cabal spec $ "test" : extraArgs
let r = recordRun res TestSuccess nullResult
record spec r
return r
+cabal_bench :: PackageSpec -> [String] -> IO Result
+cabal_bench spec extraArgs = do
+ res <- cabal spec $ "bench" : extraArgs
+ let r = recordRun res BenchSuccess nullResult
+ record spec r
+ return r
+
-- | Returns the command that was issued, the return code, and hte output text
cabal :: PackageSpec -> [String] -> IO (String, ExitCode, String)
cabal spec cabalArgs = do
wd <- getCurrentDirectory
r <- run (Just $ directory spec) "ghc"
[ "--make"
- , "-fhpc"
+-- HPC causes trouble -- see #1012
+-- , "-fhpc"
, "-package-conf " ++ wd </> "../dist/package.conf.inplace"
, "Setup.hs"
]
@@ -129,32 +144,13 @@ run :: Maybe FilePath -> String -> [String] -> IO (String, ExitCode, String)
run cwd cmd args = do
-- Posix-specific
(outf, outf0) <- createPipe
- (errf, errf0) <- createPipe
outh <- fdToHandle outf
outh0 <- fdToHandle outf0
- errh <- fdToHandle errf
- errh0 <- fdToHandle errf0
- pid <- runProcess cmd args cwd Nothing Nothing (Just outh0) (Just errh0)
-
- {-
- -- ghc-6.10.1 specific
- (Just inh, Just outh, Just errh, pid) <-
- createProcess (proc cmd args){ std_in = CreatePipe,
- std_out = CreatePipe,
- std_err = CreatePipe,
- cwd = cwd }
- hClose inh -- done with stdin
- -}
+ pid <- runProcess cmd args cwd Nothing Nothing (Just outh0) (Just outh0)
-- fork off a thread to start consuming the output
- outChan <- newChan
- forkIO $ suckH outChan outh
- forkIO $ suckH outChan errh
-
- output <- suckChan outChan
-
+ output <- suckH [] outh
hClose outh
- hClose errh
-- wait on the process
ex <- waitForProcess pid
@@ -162,22 +158,13 @@ run cwd cmd args = do
return ("\"" ++ fullCmd ++ "\" in " ++ fromMaybe "" cwd,
ex, output)
where
- suckH chan h = do
+ suckH output h = do
eof <- hIsEOF h
if eof
- then writeChan chan Nothing
+ then return (reverse output)
else do
c <- hGetChar h
- writeChan chan $ Just c
- suckH chan h
- suckChan chan = sc' chan 2 []
- where
- sc' _ 0 acc = return $ reverse acc
- sc' chan eofs acc = do
- mC <- readChan chan
- case mC of
- Just c -> sc' chan eofs (c:acc)
- Nothing -> sc' chan (eofs-1) acc
+ suckH (c:output) h
requireSuccess :: (String, ExitCode, String) -> IO ()
requireSuccess (cmd, exitCode, output) = do
diff --git a/cabal/Cabal/tests/PackageTests/TemplateHaskell/Check.hs b/cabal/Cabal/tests/PackageTests/TemplateHaskell/Check.hs
new file mode 100644
index 0000000..c57623e
--- /dev/null
+++ b/cabal/Cabal/tests/PackageTests/TemplateHaskell/Check.hs
@@ -0,0 +1,44 @@
+module PackageTests.TemplateHaskell.Check where
+
+import Test.HUnit
+import System.FilePath
+import PackageTests.PackageTester
+import Data.List (isInfixOf, intercalate)
+import Distribution.Version
+import Distribution.PackageDescription.Parse
+ ( readPackageDescription )
+import Distribution.PackageDescription.Configuration
+ ( finalizePackageDescription )
+import Distribution.Package
+ ( PackageIdentifier(..), PackageName(..), Dependency(..) )
+import Distribution.PackageDescription
+ ( PackageDescription(..), BuildInfo(..), TestSuite(..), Library(..)
+ , TestSuiteInterface(..)
+ , TestType(..), emptyPackageDescription, emptyBuildInfo, emptyLibrary
+ , emptyTestSuite, BuildType(..) )
+import Distribution.Verbosity (silent)
+import Distribution.License (License(..))
+import Distribution.ModuleName (fromString)
+import Distribution.System (buildPlatform)
+import Distribution.Compiler
+ ( CompilerId(..), CompilerFlavor(..) )
+import Distribution.Text
+
+profiling :: Test
+profiling = TestCase $ do
+ let flags = ["--enable-library-profiling"
+-- ,"--disable-library-vanilla"
+ ,"--enable-executable-profiling"]
+ spec = PackageSpec ("PackageTests" </> "TemplateHaskell" </> "profiling") flags
+ result <- cabal_build spec
+ assertEqual "cabal build should succeed - see test-log.txt" True (successful result)
+
+dynamic :: Test
+dynamic = TestCase $ do
+ let flags = ["--enable-shared"
+-- ,"--disable-library-vanilla"
+ ,"--enable-executable-dynamic"]
+ spec = PackageSpec ("PackageTests" </> "TemplateHaskell" </> "dynamic") flags
+ result <- cabal_build spec
+ assertEqual "cabal build should succeed - see test-log.txt" True (successful result)
+
diff --git a/cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/Exe.hs b/cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/Exe.hs
new file mode 100644
index 0000000..e33689f
--- /dev/null
+++ b/cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/Exe.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Main where
+
+import TH
+
+main = print $(splice) \ No newline at end of file
diff --git a/cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/Lib.hs b/cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/Lib.hs
new file mode 100644
index 0000000..738088d
--- /dev/null
+++ b/cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/Lib.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Lib where
+
+import TH
+
+val = $(splice)
diff --git a/cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/Setup.hs b/cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/Setup.hs
new file mode 100644
index 0000000..200a2e5
--- /dev/null
+++ b/cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/Setup.hs
@@ -0,0 +1,3 @@
+import Distribution.Simple
+main = defaultMain
+
diff --git a/cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/TH.hs b/cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/TH.hs
new file mode 100644
index 0000000..800088b
--- /dev/null
+++ b/cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/TH.hs
@@ -0,0 +1,4 @@
+{-# LANGUAGE TemplateHaskell #-}
+module TH where
+
+splice = [| () |]
diff --git a/cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/my.cabal b/cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/my.cabal
new file mode 100644
index 0000000..a69e56b
--- /dev/null
+++ b/cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/my.cabal
@@ -0,0 +1,15 @@
+Name: templateHaskell
+Version: 0.1
+Build-Type: Simple
+Cabal-Version: >= 1.2
+
+Library
+ Exposed-Modules: Lib
+ Other-Modules: TH
+ Build-Depends: base, template-haskell
+ Extensions: TemplateHaskell
+
+Executable main
+ Main-is: Exe.hs
+ Build-Depends: base, template-haskell
+ Extensions: TemplateHaskell
diff --git a/cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/Exe.hs b/cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/Exe.hs
new file mode 100644
index 0000000..e33689f
--- /dev/null
+++ b/cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/Exe.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Main where
+
+import TH
+
+main = print $(splice) \ No newline at end of file
diff --git a/cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/Lib.hs b/cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/Lib.hs
new file mode 100644
index 0000000..738088d
--- /dev/null
+++ b/cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/Lib.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Lib where
+
+import TH
+
+val = $(splice)
diff --git a/cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/Setup.hs b/cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/Setup.hs
new file mode 100644
index 0000000..200a2e5
--- /dev/null
+++ b/cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/Setup.hs
@@ -0,0 +1,3 @@
+import Distribution.Simple
+main = defaultMain
+
diff --git a/cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/TH.hs b/cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/TH.hs
new file mode 100644
index 0000000..800088b
--- /dev/null
+++ b/cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/TH.hs
@@ -0,0 +1,4 @@
+{-# LANGUAGE TemplateHaskell #-}
+module TH where
+
+splice = [| () |]
diff --git a/cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/my.cabal b/cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/my.cabal
new file mode 100644
index 0000000..a69e56b
--- /dev/null
+++ b/cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/my.cabal
@@ -0,0 +1,15 @@
+Name: templateHaskell
+Version: 0.1
+Build-Type: Simple
+Cabal-Version: >= 1.2
+
+Library
+ Exposed-Modules: Lib
+ Other-Modules: TH
+ Build-Depends: base, template-haskell
+ Extensions: TemplateHaskell
+
+Executable main
+ Main-is: Exe.hs
+ Build-Depends: base, template-haskell
+ Extensions: TemplateHaskell
diff --git a/cabal/Cabal/tests/PackageTests/TestOptions/Check.hs b/cabal/Cabal/tests/PackageTests/TestOptions/Check.hs
new file mode 100644
index 0000000..0943530
--- /dev/null
+++ b/cabal/Cabal/tests/PackageTests/TestOptions/Check.hs
@@ -0,0 +1,23 @@
+module PackageTests.TestOptions.Check where
+
+import Test.HUnit
+import System.FilePath
+import PackageTests.PackageTester
+
+suite :: Test
+suite = TestCase $ do
+ let directory = "PackageTests" </> "TestOptions"
+ pdFile = directory </> "TestOptions" <.> "cabal"
+ spec = PackageSpec directory ["--enable-tests"]
+ _ <- cabal_build spec
+ result <- cabal_test spec ["--test-options=1 2 3"]
+ let message = "\"cabal test\" did not pass the correct options to the "
+ ++ "test executable with \"--test-options\""
+ assertEqual message True $ successful result
+ result' <- cabal_test spec [ "--test-option=1"
+ , "--test-option=2"
+ , "--test-option=3"
+ ]
+ let message = "\"cabal test\" did not pass the correct options to the "
+ ++ "test executable with \"--test-option\""
+ assertEqual message True $ successful result'
diff --git a/cabal/Cabal/tests/PackageTests/TestOptions/Setup.hs b/cabal/Cabal/tests/PackageTests/TestOptions/Setup.hs
new file mode 100644
index 0000000..200a2e5
--- /dev/null
+++ b/cabal/Cabal/tests/PackageTests/TestOptions/Setup.hs
@@ -0,0 +1,3 @@
+import Distribution.Simple
+main = defaultMain
+
diff --git a/cabal/Cabal/tests/PackageTests/TestOptions/TestOptions.cabal b/cabal/Cabal/tests/PackageTests/TestOptions/TestOptions.cabal
new file mode 100644
index 0000000..a319a12
--- /dev/null
+++ b/cabal/Cabal/tests/PackageTests/TestOptions/TestOptions.cabal
@@ -0,0 +1,20 @@
+name: TestOptions
+version: 0.1
+license: BSD3
+author: Thomas Tuegel
+stability: stable
+category: PackageTests
+build-type: Simple
+cabal-version: >= 1.9.2
+
+description:
+ Check that Cabal passes the correct test options to test suites.
+
+executable dummy
+ main-is: test-TestOptions.hs
+ build-depends: base
+
+test-suite test-TestOptions
+ main-is: test-TestOptions.hs
+ type: exitcode-stdio-1.0
+ build-depends: base
diff --git a/cabal/Cabal/tests/PackageTests/TestOptions/test-TestOptions.hs b/cabal/Cabal/tests/PackageTests/TestOptions/test-TestOptions.hs
new file mode 100644
index 0000000..7c21bff
--- /dev/null
+++ b/cabal/Cabal/tests/PackageTests/TestOptions/test-TestOptions.hs
@@ -0,0 +1,11 @@
+module Main where
+
+import System.Environment ( getArgs )
+import System.Exit ( exitFailure, exitSuccess )
+
+main :: IO ()
+main = do
+ args <- getArgs
+ if args == ["1", "2", "3"]
+ then exitSuccess
+ else putStrLn ("Got: " ++ show args) >> exitFailure
diff --git a/cabal/cabal/tests/PackageTests/TestStanza/Check.hs b/cabal/Cabal/tests/PackageTests/TestStanza/Check.hs
index 2db93cd..2db93cd 100644
--- a/cabal/cabal/tests/PackageTests/TestStanza/Check.hs
+++ b/cabal/Cabal/tests/PackageTests/TestStanza/Check.hs
diff --git a/cabal/Cabal/tests/PackageTests/TestStanza/Setup.hs b/cabal/Cabal/tests/PackageTests/TestStanza/Setup.hs
new file mode 100644
index 0000000..200a2e5
--- /dev/null
+++ b/cabal/Cabal/tests/PackageTests/TestStanza/Setup.hs
@@ -0,0 +1,3 @@
+import Distribution.Simple
+main = defaultMain
+
diff --git a/cabal/cabal/tests/PackageTests/TestStanza/my.cabal b/cabal/Cabal/tests/PackageTests/TestStanza/my.cabal
index 3381abf..3381abf 100644
--- a/cabal/cabal/tests/PackageTests/TestStanza/my.cabal
+++ b/cabal/Cabal/tests/PackageTests/TestStanza/my.cabal
diff --git a/cabal/cabal/tests/PackageTests/TestSuiteExeV10/Check.hs b/cabal/Cabal/tests/PackageTests/TestSuiteExeV10/Check.hs
index 5c4c238..3028109 100644
--- a/cabal/cabal/tests/PackageTests/TestSuiteExeV10/Check.hs
+++ b/cabal/Cabal/tests/PackageTests/TestSuiteExeV10/Check.hs
@@ -20,7 +20,7 @@ checkTest cabalVersion = TestCase $ do
buildResult <- cabal_build spec
let buildMessage = "\'setup build\' should succeed"
assertEqual buildMessage True $ successful buildResult
- testResult <- cabal_test spec
+ testResult <- cabal_test spec []
let testMessage = "\'setup test\' should succeed"
assertEqual testMessage True $ successful testResult
@@ -32,13 +32,13 @@ checkTestWithHpc cabalVersion = TestCase $ do
buildResult <- cabal_build spec
let buildMessage = "\'setup build\' should succeed"
assertEqual buildMessage True $ successful buildResult
- testResult <- cabal_test spec
+ testResult <- cabal_test spec []
let testMessage = "\'setup test\' should succeed"
assertEqual testMessage True $ successful testResult
let dummy = emptyTestSuite { testName = "test-Foo" }
- tixFile = tixFilePath (dir </> "dist") dummy
+ tixFile = tixFilePath (dir </> "dist") $ testName dummy
tixFileMessage = ".tix file should exist"
- markupDir = tixDir (dir </> "dist") dummy
+ markupDir = htmlDir (dir </> "dist") $ testName dummy
markupFile = markupDir </> "hpc_index" <.> "html"
markupFileMessage = "HPC markup file should exist"
tixFileExists <- doesFileExist tixFile
diff --git a/cabal/Cabal/tests/PackageTests/TestSuiteExeV10/Foo.hs b/cabal/Cabal/tests/PackageTests/TestSuiteExeV10/Foo.hs
new file mode 100644
index 0000000..2d3e705
--- /dev/null
+++ b/cabal/Cabal/tests/PackageTests/TestSuiteExeV10/Foo.hs
@@ -0,0 +1,4 @@
+module Foo where
+
+fooTest :: [String] -> Bool
+fooTest _ = True
diff --git a/cabal/Cabal/tests/PackageTests/TestSuiteExeV10/Setup.hs b/cabal/Cabal/tests/PackageTests/TestSuiteExeV10/Setup.hs
new file mode 100644
index 0000000..200a2e5
--- /dev/null
+++ b/cabal/Cabal/tests/PackageTests/TestSuiteExeV10/Setup.hs
@@ -0,0 +1,3 @@
+import Distribution.Simple
+main = defaultMain
+
diff --git a/cabal/cabal/tests/PackageTests/TestSuiteExeV10/my.cabal b/cabal/Cabal/tests/PackageTests/TestSuiteExeV10/my.cabal
index c9d5ef1..c9d5ef1 100644
--- a/cabal/cabal/tests/PackageTests/TestSuiteExeV10/my.cabal
+++ b/cabal/Cabal/tests/PackageTests/TestSuiteExeV10/my.cabal
diff --git a/cabal/Cabal/tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs b/cabal/Cabal/tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs
new file mode 100644
index 0000000..6951cac
--- /dev/null
+++ b/cabal/Cabal/tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs
@@ -0,0 +1,8 @@
+module Main where
+
+import Foo
+import System.Exit
+
+main :: IO ()
+main | fooTest [] = exitSuccess
+ | otherwise = exitFailure
diff --git a/cabal/Cabal/tests/UnitTests.hs b/cabal/Cabal/tests/UnitTests.hs
new file mode 100644
index 0000000..87f0e28
--- /dev/null
+++ b/cabal/Cabal/tests/UnitTests.hs
@@ -0,0 +1,17 @@
+module Main
+ ( main
+ ) where
+
+import Test.Framework
+import Test.Framework.Providers.HUnit
+
+import qualified UnitTests.Distribution.Compat.ReadP
+
+tests :: [Test]
+tests = [
+ testGroup "Distribution.Compat.ReadP"
+ UnitTests.Distribution.Compat.ReadP.tests
+ ]
+
+main :: IO ()
+main = defaultMain tests
diff --git a/cabal/Cabal/tests/UnitTests/Distribution/Compat/ReadP.hs b/cabal/Cabal/tests/UnitTests/Distribution/Compat/ReadP.hs
new file mode 100644
index 0000000..c9c00aa
--- /dev/null
+++ b/cabal/Cabal/tests/UnitTests/Distribution/Compat/ReadP.hs
@@ -0,0 +1,140 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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 code was originally in Distribution.Compat.ReadP. Please see that file
+-- for provenace. The tests have been integrated into the test framework.
+-- Some properties cannot be tested, as they hold over arbitrary ReadP values,
+-- and we don't have a good Arbitrary instance (nor Show instance) for ReadP.
+--
+module UnitTests.Distribution.Compat.ReadP
+ ( tests
+ -- * Properties
+ -- $properties
+ ) where
+
+import Data.List
+import Distribution.Compat.ReadP
+
+import Test.Framework
+import Test.Framework.Providers.HUnit
+import Test.Framework.Providers.QuickCheck2
+
+tests =
+ [ testProperty "Get Nil" prop_Get_Nil
+ , testProperty "Get Cons" prop_Get_Cons
+ , testProperty "Look" prop_Look
+ , testProperty "Fail" prop_Fail
+ , testProperty "Return" prop_Return
+ --, testProperty "Bind" prop_Bind
+ --, testProperty "Plus" prop_Plus
+ --, testProperty "LeftPlus" prop_LeftPlus
+ --, testProperty "Gather" prop_Gather
+ , testProperty "String Yes" prop_String_Yes
+ , testProperty "String Maybe" prop_String_Maybe
+ , testProperty "Munch" (prop_Munch evenChar)
+ , testProperty "Munch1" (prop_Munch1 evenChar)
+ --, testProperty "Choice" prop_Choice
+ --, testProperty "ReadS" prop_ReadS
+ ]
+
+-- ---------------------------------------------------------------------------
+-- 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
+
+evenChar :: Char -> Bool
+evenChar = even . fromEnum
+
diff --git a/cabal/cabal/tests/hackage/check.sh b/cabal/Cabal/tests/hackage/check.sh
index cbd512d..cbd512d 100644
--- a/cabal/cabal/tests/hackage/check.sh
+++ b/cabal/Cabal/tests/hackage/check.sh
diff --git a/cabal/cabal/tests/hackage/download.sh b/cabal/Cabal/tests/hackage/download.sh
index 9a6a509..9a6a509 100644
--- a/cabal/cabal/tests/hackage/download.sh
+++ b/cabal/Cabal/tests/hackage/download.sh
diff --git a/cabal/cabal/tests/hackage/unpack.sh b/cabal/Cabal/tests/hackage/unpack.sh
index 8155f7e..8155f7e 100644
--- a/cabal/cabal/tests/hackage/unpack.sh
+++ b/cabal/Cabal/tests/hackage/unpack.sh
diff --git a/cabal/cabal/tests/misc/ghc-supported-languages.hs b/cabal/Cabal/tests/misc/ghc-supported-languages.hs
index 8c97158..8c97158 100644
--- a/cabal/cabal/tests/misc/ghc-supported-languages.hs
+++ b/cabal/Cabal/tests/misc/ghc-supported-languages.hs
diff --git a/cabal/IMPORTED-FROM b/cabal/IMPORTED-FROM
deleted file mode 100644
index ecef606..0000000
--- a/cabal/IMPORTED-FROM
+++ /dev/null
@@ -1,7 +0,0 @@
-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/cabal/Paths_Cabal.hs b/cabal/Paths_Cabal.hs
index 8a5ff0a..8a770f2 100644
--- a/cabal/cabal/Paths_Cabal.hs
+++ b/cabal/Paths_Cabal.hs
@@ -5,4 +5,4 @@ module Paths_Cabal (
import Data.Version (Version(..))
version :: Version
-version = Version {versionBranch = [1,12,0], versionTags = []}
+version = Version {versionBranch = [1,17,0], versionTags = []}
diff --git a/cabal/cabal-install/Paths_cabal_install.hs b/cabal/Paths_cabal_install.hs
index 25a44b7..b7a174a 100644
--- a/cabal/cabal-install/Paths_cabal_install.hs
+++ b/cabal/Paths_cabal_install.hs
@@ -5,4 +5,4 @@ module Paths_cabal_install (
import Data.Version (Version(..))
version :: Version
-version = Version {versionBranch = [0,12,0], versionTags = []}
+version = Version {versionBranch = [0,17,0], versionTags = []}
diff --git a/cabal/README b/cabal/README
index bab14a4..b4963b7 100644
--- a/cabal/README
+++ b/cabal/README
@@ -1,8 +1,8 @@
This Cabal darcs repository contains multiple packages:
- * cabal/ -- the Cabal library package
+ * 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/
+The canonical upstream repo lives at https://github.com/haskell/cabal
diff --git a/cabal/cabal-install/Distribution/Client/BuildReports/Anonymous.hs b/cabal/cabal-install/Distribution/Client/BuildReports/Anonymous.hs
index 53d1f45..3849fd4 100644
--- a/cabal/cabal-install/Distribution/Client/BuildReports/Anonymous.hs
+++ b/cabal/cabal-install/Distribution/Client/BuildReports/Anonymous.hs
@@ -56,9 +56,9 @@ import Distribution.Simple.Utils
import qualified Distribution.Compat.ReadP as Parse
( ReadP, pfail, munch1, skipSpaces )
-import qualified Text.PrettyPrint.HughesPJ as Disp
+import qualified Text.PrettyPrint as Disp
( Doc, render, char, text )
-import Text.PrettyPrint.HughesPJ
+import Text.PrettyPrint
( (<+>), (<>) )
import Data.List
@@ -112,6 +112,7 @@ data InstallOutcome
| SetupFailed
| ConfigureFailed
| BuildFailed
+ | TestsFailed
| InstallFailed
| InstallOk
deriving Eq
@@ -122,7 +123,7 @@ data Outcome = NotTried | Failed | Ok
new :: OS -> Arch -> CompilerId -- -> Version
-> ConfiguredPackage -> BR.BuildResult
-> BuildReport
-new os' arch' comp (ConfiguredPackage pkg flags deps) result =
+new os' arch' comp (ConfiguredPackage pkg flags _ deps) result =
BuildReport {
package = packageId pkg,
os = os',
@@ -143,6 +144,7 @@ new os' arch' comp (ConfiguredPackage pkg flags deps) result =
Left (BR.UnpackFailed _) -> UnpackFailed
Left (BR.ConfigureFailed _) -> ConfigureFailed
Left (BR.BuildFailed _) -> BuildFailed
+ Left (BR.TestsFailed _) -> TestsFailed
Left (BR.InstallFailed _) -> InstallFailed
Right (BR.BuildOk _ _) -> InstallOk
convertDocsOutcome = case result of
@@ -151,9 +153,9 @@ new os' arch' comp (ConfiguredPackage pkg flags deps) result =
Right (BR.BuildOk BR.DocsFailed _) -> Failed
Right (BR.BuildOk BR.DocsOk _) -> Ok
convertTestsOutcome = case result of
+ Left (BR.TestsFailed _) -> Failed
Left _ -> NotTried
Right (BR.BuildOk _ BR.TestsNotTried) -> NotTried
- Right (BR.BuildOk _ BR.TestsFailed) -> Failed
Right (BR.BuildOk _ BR.TestsOk) -> Ok
cabalInstallID :: PackageIdentifier
@@ -280,6 +282,7 @@ instance Text.Text InstallOutcome where
disp SetupFailed = Disp.text "SetupFailed"
disp ConfigureFailed = Disp.text "ConfigureFailed"
disp BuildFailed = Disp.text "BuildFailed"
+ disp TestsFailed = Disp.text "TestsFailed"
disp InstallFailed = Disp.text "InstallFailed"
disp InstallOk = Disp.text "InstallOk"
@@ -294,6 +297,7 @@ instance Text.Text InstallOutcome where
"SetupFailed" -> return SetupFailed
"ConfigureFailed" -> return ConfigureFailed
"BuildFailed" -> return BuildFailed
+ "TestsFailed" -> return TestsFailed
"InstallFailed" -> return InstallFailed
"InstallOk" -> return InstallOk
_ -> Parse.pfail
diff --git a/cabal/cabal-install/Distribution/Client/BuildReports/Storage.hs b/cabal/cabal-install/Distribution/Client/BuildReports/Storage.hs
index 7b2a4b5..555ebb9 100644
--- a/cabal/cabal-install/Distribution/Client/BuildReports/Storage.hs
+++ b/cabal/cabal-install/Distribution/Client/BuildReports/Storage.hs
@@ -117,11 +117,11 @@ fromPlanPackage :: Platform -> CompilerId
fromPlanPackage (Platform arch os) comp planPackage = case planPackage of
InstallPlan.Installed pkg@(ConfiguredPackage (SourcePackage {
- packageSource = RepoTarballPackage repo _ _ }) _ _) result
+ packageSource = RepoTarballPackage repo _ _ }) _ _ _) result
-> Just $ (BuildReport.new os arch comp pkg (Right result), repo)
InstallPlan.Failed pkg@(ConfiguredPackage (SourcePackage {
- packageSource = RepoTarballPackage repo _ _ }) _ _) result
+ packageSource = RepoTarballPackage repo _ _ }) _ _ _) result
-> Just $ (BuildReport.new os arch comp pkg (Left result), repo)
_ -> Nothing
diff --git a/cabal/cabal-install/Distribution/Client/BuildReports/Types.hs b/cabal/cabal-install/Distribution/Client/BuildReports/Types.hs
index ea28e71..8e7aaa7 100644
--- a/cabal/cabal-install/Distribution/Client/BuildReports/Types.hs
+++ b/cabal/cabal-install/Distribution/Client/BuildReports/Types.hs
@@ -19,7 +19,7 @@ import qualified Distribution.Text as Text
import qualified Distribution.Compat.ReadP as Parse
( pfail, munch1 )
-import qualified Text.PrettyPrint.HughesPJ as Disp
+import qualified Text.PrettyPrint as Disp
( text )
import Data.Char as Char
diff --git a/cabal/cabal-install/Distribution/Client/BuildReports/Upload.hs b/cabal/cabal-install/Distribution/Client/BuildReports/Upload.hs
index a1ae1f1..49378ad 100644
--- a/cabal/cabal-install/Distribution/Client/BuildReports/Upload.hs
+++ b/cabal/cabal-install/Distribution/Client/BuildReports/Upload.hs
@@ -29,10 +29,8 @@ type BuildReportId = URI
type BuildLog = String
uploadReports :: URI -> [(BuildReport, Maybe BuildLog)]
- -> BrowserAction (HandleStream String) ()
-> BrowserAction (HandleStream BuildLog) ()
-uploadReports uri reports auth = do
- auth
+uploadReports uri reports = do
forM_ reports $ \(report, mbBuildLog) -> do
buildId <- postBuildReport uri report
case mbBuildLog of
@@ -63,7 +61,7 @@ putBuildLog :: BuildReportId -> BuildLog
-> BrowserAction (HandleStream BuildLog) ()
putBuildLog reportId buildLog = do
--FIXME: do something if the request fails
- (_, response) <- request Request {
+ (_, _response) <- request Request {
rqURI = reportId{uriPath = uriPath reportId </> "log"},
rqMethod = PUT,
rqHeaders = [Header HdrContentType ("text/plain"),
diff --git a/cabal/cabal-install/Distribution/Client/Config.hs b/cabal/cabal-install/Distribution/Client/Config.hs
index c283222..b035472 100644
--- a/cabal/cabal-install/Distribution/Client/Config.hs
+++ b/cabal/cabal-install/Distribution/Client/Config.hs
@@ -8,7 +8,8 @@
-- Stability : provisional
-- Portability : portable
--
--- Utilities for handling saved state such as known packages, known servers and downloaded packages.
+-- Utilities for handling saved state such as known packages, known servers and
+-- downloaded packages.
-----------------------------------------------------------------------------
module Distribution.Client.Config (
SavedConfig(..),
@@ -21,7 +22,14 @@ module Distribution.Client.Config (
defaultCabalDir,
defaultConfigFile,
defaultCacheDir,
+ defaultCompiler,
defaultLogsDir,
+
+ baseSavedConfig,
+ commentSavedConfig,
+ initialSavedConfig,
+ configFieldDescriptions,
+ installDirsFields
) where
@@ -36,19 +44,26 @@ import Distribution.Client.Setup
, UploadFlags(..), uploadCommand
, ReportFlags(..), reportCommand
, showRepo, parseRepo )
+import Distribution.Client.Utils
+ ( numberOfProcessors )
+import Distribution.Simple.Compiler
+ ( OptimisationLevel(..) )
import Distribution.Simple.Setup
( ConfigFlags(..), configureOptions, defaultConfigFlags
, installDirsOptions
- , Flag, toFlag, flagToMaybe, fromFlagOrDefault )
+ , Flag(..), toFlag, flagToMaybe, fromFlagOrDefault )
import Distribution.Simple.InstallDirs
( InstallDirs(..), defaultInstallDirs
, PathTemplate, toPathTemplate )
import Distribution.ParseUtils
( FieldDescr(..), liftField
- , ParseResult(..), locatedErrorMsg, showPWarning
+ , ParseResult(..), PError(..), PWarning(..)
+ , locatedErrorMsg, showPWarning
, readFields, warning, lineNo
, simpleField, listField, parseFilePathQ, parseTokenQ )
+import Distribution.Client.ParseUtils
+ ( parseFields, ppFields, ppSection )
import qualified Distribution.ParseUtils as ParseUtils
( Field(..) )
import qualified Distribution.Text as Text
@@ -73,23 +88,24 @@ import Data.Monoid
( Monoid(..) )
import Control.Monad
( when, foldM, liftM )
-import qualified Data.Map as Map
import qualified Distribution.Compat.ReadP as Parse
( option )
-import qualified Text.PrettyPrint.HughesPJ as Disp
- ( Doc, render, text, colon, vcat, empty, isEmpty, nest )
-import Text.PrettyPrint.HughesPJ
- ( (<>), (<+>), ($$), ($+$) )
+import qualified Text.PrettyPrint as Disp
+ ( render, text, empty )
+import Text.PrettyPrint
+ ( ($+$) )
import System.Directory
- ( createDirectoryIfMissing, getAppUserDataDirectory )
+ ( createDirectoryIfMissing, getAppUserDataDirectory, renameFile )
import Network.URI
( URI(..), URIAuth(..) )
import System.FilePath
- ( (</>), takeDirectory )
+ ( (<.>), (</>), takeDirectory )
import System.Environment
( getEnvironment )
import System.IO.Error
( isDoesNotExistError )
+import Distribution.Compat.Exception
+ ( catchIO )
--
-- * Configuration saved in the config file
@@ -195,7 +211,8 @@ initialSavedConfig = do
},
savedInstallFlags = mempty {
installSummaryFile = [toPathTemplate (logsDir </> "build.log")],
- installBuildReports= toFlag AnonymousReports
+ installBuildReports= toFlag AnonymousReports,
+ installNumJobs = toFlag (Just numberOfProcessors)
}
}
@@ -288,15 +305,17 @@ readConfigFile initial file = handleNotExists $
fmap (Just . parseConfig initial) (readFile file)
where
- handleNotExists action = catch action $ \ioe ->
+ handleNotExists action = catchIO action $ \ioe ->
if isDoesNotExistError ioe
then return Nothing
else ioError ioe
writeConfigFile :: FilePath -> SavedConfig -> SavedConfig -> IO ()
writeConfigFile file comments vals = do
+ let tmpFile = file <.> "tmp"
createDirectoryIfMissing True (takeDirectory file)
- writeFile file $ explanation ++ showConfigWithComments comments vals ++ "\n"
+ writeFile tmpFile $ explanation ++ showConfigWithComments comments vals ++ "\n"
+ renameFile tmpFile file
where
explanation = unlines
["-- This is the configuration file for the 'cabal' command line tool."
@@ -343,7 +362,7 @@ configFieldDescriptions =
++ toSavedConfig liftConfigFlag
(configureOptions ParseArgs)
- (["builddir", "configure-option"] ++ map fieldName installDirsFields)
+ (["builddir", "configure-option", "constraint"] ++ map fieldName installDirsFields)
--FIXME: this is only here because viewAsFieldDescr gives us a parser
-- that only recognises 'ghc' etc, the case-sensitive flag names, not
@@ -351,6 +370,31 @@ configFieldDescriptions =
[simpleField "compiler"
(fromFlagOrDefault Disp.empty . fmap Text.disp) (optional Text.parse)
configHcFlavor (\v flags -> flags { configHcFlavor = v })
+ -- TODO: The following is a temporary fix. The "optimization" field is
+ -- OptArg, and viewAsFieldDescr fails on that. Instead of a hand-written
+ -- hackaged parser and printer, we should handle this case properly in
+ -- the library.
+ ,liftField configOptimization (\v flags -> flags { configOptimization = v }) $
+ let name = "optimization" in
+ FieldDescr name
+ (\f -> case f of
+ Flag NoOptimisation -> Disp.text "False"
+ Flag NormalOptimisation -> Disp.text "True"
+ Flag MaximumOptimisation -> Disp.text "2"
+ _ -> Disp.empty)
+ (\line str _ -> case () of
+ _ | str == "False" -> ParseOk [] (Flag NoOptimisation)
+ | str == "True" -> ParseOk [] (Flag NormalOptimisation)
+ | str == "0" -> ParseOk [] (Flag NoOptimisation)
+ | str == "1" -> ParseOk [] (Flag NormalOptimisation)
+ | str == "2" -> ParseOk [] (Flag MaximumOptimisation)
+ | lstr == "false" -> ParseOk [caseWarning] (Flag NoOptimisation)
+ | lstr == "true" -> ParseOk [caseWarning] (Flag NormalOptimisation)
+ | otherwise -> ParseFailed (NoParse name line)
+ where
+ lstr = lowercase str
+ caseWarning = PWarning $
+ "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'.")
]
++ toSavedConfig liftConfigExFlag
@@ -359,7 +403,7 @@ configFieldDescriptions =
++ toSavedConfig liftInstallFlag
(installOptions ParseArgs)
- ["dry-run", "reinstall", "only"] []
+ ["dry-run", "only"] []
++ toSavedConfig liftUploadFlag
(commandOptions uploadCommand ParseArgs)
@@ -495,42 +539,5 @@ showConfigWithComments comment vals = Disp.render $
ppSection "install-dirs" name installDirsFields
(field comment) (field vals)
-------------------------
--- * Parsing utils
---
-
---FIXME: replace this with something better in Cabal-1.5
-parseFields :: [FieldDescr a] -> a -> [ParseUtils.Field] -> ParseResult a
-parseFields fields initial = foldM setField initial
- where
- fieldMap = Map.fromList
- [ (name, f) | f@(FieldDescr name _ _) <- fields ]
- setField accum (ParseUtils.F line name value) = case Map.lookup name fieldMap of
- Just (FieldDescr _ _ set) -> set line value accum
- Nothing -> do
- warning $ "Unrecognized field " ++ name ++ " on line " ++ show line
- return accum
- setField accum f = do
- warning $ "Unrecognized stanza on line " ++ show (lineNo f)
- return accum
-
--- | This is a customised version of the function from Cabal that also prints
--- default values for empty fields as comments.
---
-ppFields :: [FieldDescr a] -> a -> a -> Disp.Doc
-ppFields fields def cur = Disp.vcat [ ppField name (getter def) (getter cur)
- | FieldDescr name getter _ <- fields]
-
-ppField :: String -> Disp.Doc -> Disp.Doc -> Disp.Doc
-ppField name def cur
- | Disp.isEmpty cur = Disp.text "--" <+> Disp.text name <> Disp.colon <+> def
- | otherwise = Disp.text name <> Disp.colon <+> cur
-
-ppSection :: String -> String -> [FieldDescr a] -> a -> a -> Disp.Doc
-ppSection name arg fields def cur =
- Disp.text name <+> Disp.text arg
- $$ Disp.nest 2 (ppFields fields def cur)
-
installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))]
installDirsFields = map viewAsFieldDescr installDirsOptions
-
diff --git a/cabal/cabal-install/Distribution/Client/Configure.hs b/cabal/cabal-install/Distribution/Client/Configure.hs
index 8da7506..b921de9 100644
--- a/cabal/cabal-install/Distribution/Client/Configure.hs
+++ b/cabal/cabal-install/Distribution/Client/Configure.hs
@@ -32,8 +32,8 @@ import Distribution.Simple.Compiler
, PackageDB(..), PackageDBStack )
import Distribution.Simple.Program (ProgramConfiguration )
import Distribution.Simple.Setup
- ( ConfigFlags(..), toFlag, flagToMaybe, fromFlagOrDefault )
-import Distribution.Client.PackageIndex (PackageIndex)
+ ( ConfigFlags(..), fromFlag, toFlag, flagToMaybe, fromFlagOrDefault )
+import Distribution.Simple.PackageIndex (PackageIndex)
import Distribution.Simple.Utils
( defaultPackageDesc )
import Distribution.Package
@@ -82,7 +82,7 @@ configure verbosity packageDBs repos comp conf
configureCommand (const configFlags) extraArgs
Right installPlan -> case InstallPlan.ready installPlan of
- [pkg@(ConfiguredPackage (SourcePackage _ _ (LocalUnpackedPackage _)) _ _)] ->
+ [pkg@(ConfiguredPackage (SourcePackage _ _ (LocalUnpackedPackage _)) _ _ _)] ->
configurePackage verbosity
(InstallPlan.planPlatform installPlan)
(InstallPlan.planCompiler installPlan)
@@ -97,22 +97,27 @@ configure verbosity packageDBs repos comp conf
useCabalVersion = maybe anyVersion thisVersion
(flagToMaybe (configCabalVersion configExFlags)),
useCompiler = Just comp,
- -- Hack: we typically want to allow the UserPackageDB for finding the
- -- Cabal lib when compiling any Setup.hs even if we're doing a global
- -- install. However we also allow looking in a specific package db.
- usePackageDB = if UserPackageDB `elem` packageDBs
- then packageDBs
- else packageDBs ++ [UserPackageDB],
- usePackageIndex = if UserPackageDB `elem` packageDBs
- then Just index
- else Nothing,
+ usePackageDB = packageDBs',
+ usePackageIndex = index',
useProgramConfig = conf,
useDistPref = fromFlagOrDefault
(useDistPref defaultSetupScriptOptions)
(configDistPref configFlags),
useLoggingHandle = Nothing,
- useWorkingDir = Nothing
+ useWorkingDir = Nothing,
+ forceExternalSetupMethod = False,
+ setupCacheLock = Nothing
}
+ where
+ -- Hack: we typically want to allow the UserPackageDB for finding the
+ -- Cabal lib when compiling any Setup.hs even if we're doing a global
+ -- install. However we also allow looking in a specific package db.
+ (packageDBs', index') =
+ case packageDBs of
+ (GlobalPackageDB:dbs) | UserPackageDB `notElem` dbs
+ -> (GlobalPackageDB:UserPackageDB:dbs, Nothing)
+ -- but if the user is using an odd db stack, don't touch it
+ dbs -> (dbs, Just index)
logMsg message rest = debug verbosity message >> rest
@@ -121,12 +126,13 @@ configure verbosity packageDBs repos comp conf
--
planLocalPackage :: Verbosity -> Compiler
-> ConfigFlags -> ConfigExFlags
- -> PackageIndex InstalledPackage
+ -> PackageIndex
-> SourcePackageDb
-> IO (Progress String String InstallPlan)
planLocalPackage verbosity comp configFlags configExFlags installedPkgIndex
(SourcePackageDb _ packagePrefs) = do
pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity
+ solver <- chooseSolver verbosity (fromFlag $ configSolver configExFlags) (compilerId comp)
let -- We create a local package and ask to resolve a dependency on it
localPkg = SourcePackage {
@@ -135,6 +141,10 @@ planLocalPackage verbosity comp configFlags configExFlags installedPkgIndex
packageSource = LocalUnpackedPackage "."
}
+ testsEnabled = fromFlagOrDefault False $ configTests configFlags
+ benchmarksEnabled =
+ fromFlagOrDefault False $ configBenchmarks configFlags
+
resolverParams =
addPreferences
@@ -153,12 +163,21 @@ planLocalPackage verbosity comp configFlags configExFlags installedPkgIndex
[ PackageConstraintFlags (packageName pkg)
(configConfigurationsFlags configFlags) ]
+ . addConstraints
+ -- '--enable-tests' and '--enable-benchmarks' constraints from
+ -- command line
+ [ PackageConstraintStanzas (packageName pkg) $ concat
+ [ if testsEnabled then [TestStanzas] else []
+ , if benchmarksEnabled then [BenchStanzas] else []
+ ]
+ ]
+
$ standardInstallPolicy
installedPkgIndex
(SourcePackageDb mempty packagePrefs)
[SpecificSourcePackage localPkg]
- return (resolveDependencies buildPlatform (compilerId comp) resolverParams)
+ return (resolveDependencies buildPlatform (compilerId comp) solver resolverParams)
-- | Call an installer for an 'SourcePackage' but override the configure
@@ -175,7 +194,7 @@ configurePackage :: Verbosity
-> [String]
-> IO ()
configurePackage verbosity platform comp scriptOptions configFlags
- (ConfiguredPackage (SourcePackage _ gpkg _) flags deps) extraArgs =
+ (ConfiguredPackage (SourcePackage _ gpkg _) flags stanzas deps) extraArgs =
setupWrapper verbosity
scriptOptions (Just pkg) configureCommand configureFlags extraArgs
@@ -184,11 +203,13 @@ configurePackage verbosity platform comp scriptOptions configFlags
configureFlags = filterConfigureFlags configFlags {
configConfigurationsFlags = flags,
configConstraints = map thisPackageVersion deps,
- configVerbosity = toFlag verbosity
+ configVerbosity = toFlag verbosity,
+ configBenchmarks = toFlag (BenchStanzas `elem` stanzas),
+ configTests = toFlag (TestStanzas `elem` stanzas)
}
pkg = case finalizePackageDescription flags
(const True)
- platform comp [] gpkg of
+ platform comp [] (enableStanzas stanzas gpkg) of
Left _ -> error "finalizePackageDescription ConfiguredPackage failed"
Right (desc, _) -> desc
diff --git a/cabal/cabal-install/Distribution/Client/Dependency.hs b/cabal/cabal-install/Distribution/Client/Dependency.hs
index 6946066..1c91799 100644
--- a/cabal/cabal-install/Distribution/Client/Dependency.hs
+++ b/cabal/cabal-install/Distribution/Client/Dependency.hs
@@ -14,6 +14,7 @@
-----------------------------------------------------------------------------
module Distribution.Client.Dependency (
-- * The main package dependency resolver
+ chooseSolver,
resolveDependencies,
Progress(..),
foldProgress,
@@ -42,44 +43,57 @@ module Distribution.Client.Dependency (
addConstraints,
addPreferences,
setPreferenceDefault,
+ setReorderGoals,
+ setIndependentGoals,
+ setAvoidReinstalls,
+ setShadowPkgs,
+ setMaxBackjumps,
addSourcePackages,
- hideInstalledPackagesSpecific,
+ hideInstalledPackagesSpecificByInstalledPackageId,
+ hideInstalledPackagesSpecificBySourcePackageId,
hideInstalledPackagesAllVersions,
) where
-import Distribution.Client.Dependency.TopDown (topDownResolver)
+import Distribution.Client.Dependency.TopDown
+ ( topDownResolver )
+import Distribution.Client.Dependency.Modular
+ ( modularResolver, SolverConfig(..) )
import qualified Distribution.Client.PackageIndex as PackageIndex
-import Distribution.Client.PackageIndex (PackageIndex)
+import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.InstallPlan (InstallPlan)
import Distribution.Client.Types
( SourcePackageDb(SourcePackageDb)
- , SourcePackage(..), InstalledPackage )
+ , SourcePackage(..) )
import Distribution.Client.Dependency.Types
- ( DependencyResolver, PackageConstraint(..)
+ ( PreSolver(..), Solver(..), DependencyResolver, PackageConstraint(..)
, PackagePreferences(..), InstalledPreference(..)
+ , PackagesPreferenceDefault(..)
, Progress(..), foldProgress )
import Distribution.Client.Targets
+import qualified Distribution.InstalledPackageInfo as Installed
import Distribution.Package
( PackageName(..), PackageId, Package(..), packageVersion
- , Dependency(Dependency))
+ , InstalledPackageId, Dependency(Dependency))
import Distribution.Version
- ( VersionRange, anyVersion, withinRange, simplifyVersionRange )
+ ( Version(..), VersionRange, anyVersion, withinRange, simplifyVersionRange )
import Distribution.Compiler
- ( CompilerId(..) )
+ ( CompilerId(..), CompilerFlavor(..) )
import Distribution.System
( Platform )
-import Distribution.Simple.Utils (comparing)
+import Distribution.Simple.Utils
+ ( comparing, warn, info )
import Distribution.Text
( display )
+import Distribution.Verbosity
+ ( Verbosity )
import Data.List (maximumBy, foldl')
-import Data.Maybe (fromMaybe, isJust)
+import Data.Maybe (fromMaybe)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Set (Set)
-
-- ------------------------------------------------------------
-- * High level planner policy
-- ------------------------------------------------------------
@@ -93,36 +107,16 @@ data DepResolverParams = DepResolverParams {
depResolverConstraints :: [PackageConstraint],
depResolverPreferences :: [PackagePreference],
depResolverPreferenceDefault :: PackagesPreferenceDefault,
- depResolverInstalledPkgIndex :: PackageIndex InstalledPackage,
- depResolverSourcePkgIndex :: PackageIndex SourcePackage
+ depResolverInstalledPkgIndex :: InstalledPackageIndex.PackageIndex,
+ depResolverSourcePkgIndex :: PackageIndex.PackageIndex SourcePackage,
+ depResolverReorderGoals :: Bool,
+ depResolverIndependentGoals :: Bool,
+ depResolverAvoidReinstalls :: Bool,
+ depResolverShadowPkgs :: Bool,
+ depResolverMaxBackjumps :: Maybe Int
}
--- | 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
@@ -137,8 +131,8 @@ data PackagePreference =
-- | If we prefer versions of packages that are already installed.
| PackageInstalledPreference PackageName InstalledPreference
-basicDepResolverParams :: PackageIndex InstalledPackage
- -> PackageIndex SourcePackage
+basicDepResolverParams :: InstalledPackageIndex.PackageIndex
+ -> PackageIndex.PackageIndex SourcePackage
-> DepResolverParams
basicDepResolverParams installedPkgIndex sourcePkgIndex =
DepResolverParams {
@@ -147,7 +141,12 @@ basicDepResolverParams installedPkgIndex sourcePkgIndex =
depResolverPreferences = [],
depResolverPreferenceDefault = PreferLatestForSelected,
depResolverInstalledPkgIndex = installedPkgIndex,
- depResolverSourcePkgIndex = sourcePkgIndex
+ depResolverSourcePkgIndex = sourcePkgIndex,
+ depResolverReorderGoals = False,
+ depResolverIndependentGoals = False,
+ depResolverAvoidReinstalls = False,
+ depResolverShadowPkgs = False,
+ depResolverMaxBackjumps = Nothing
}
addTargets :: [PackageName]
@@ -180,6 +179,36 @@ setPreferenceDefault preferenceDefault params =
depResolverPreferenceDefault = preferenceDefault
}
+setReorderGoals :: Bool -> DepResolverParams -> DepResolverParams
+setReorderGoals b params =
+ params {
+ depResolverReorderGoals = b
+ }
+
+setIndependentGoals :: Bool -> DepResolverParams -> DepResolverParams
+setIndependentGoals b params =
+ params {
+ depResolverIndependentGoals = b
+ }
+
+setAvoidReinstalls :: Bool -> DepResolverParams -> DepResolverParams
+setAvoidReinstalls b params =
+ params {
+ depResolverAvoidReinstalls = b
+ }
+
+setShadowPkgs :: Bool -> DepResolverParams -> DepResolverParams
+setShadowPkgs b params =
+ params {
+ depResolverShadowPkgs = b
+ }
+
+setMaxBackjumps :: Maybe Int -> DepResolverParams -> DepResolverParams
+setMaxBackjumps n params =
+ params {
+ depResolverMaxBackjumps = n
+ }
+
dontUpgradeBasePackage :: DepResolverParams -> DepResolverParams
dontUpgradeBasePackage params =
addConstraints extraConstraints params
@@ -193,7 +222,7 @@ dontUpgradeBasePackage params =
-- 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
+ . InstalledPackageIndex.lookupPackageName
(depResolverInstalledPkgIndex params)
addSourcePackages :: [SourcePackage]
@@ -205,13 +234,23 @@ addSourcePackages pkgs params =
(depResolverSourcePkgIndex params) pkgs
}
-hideInstalledPackagesSpecific :: [PackageId]
- -> DepResolverParams -> DepResolverParams
-hideInstalledPackagesSpecific pkgids params =
+hideInstalledPackagesSpecificByInstalledPackageId :: [InstalledPackageId]
+ -> DepResolverParams -> DepResolverParams
+hideInstalledPackagesSpecificByInstalledPackageId pkgids params =
+ --TODO: this should work using exclude constraints instead
+ params {
+ depResolverInstalledPkgIndex =
+ foldl' (flip InstalledPackageIndex.deleteInstalledPackageId)
+ (depResolverInstalledPkgIndex params) pkgids
+ }
+
+hideInstalledPackagesSpecificBySourcePackageId :: [PackageId]
+ -> DepResolverParams -> DepResolverParams
+hideInstalledPackagesSpecificBySourcePackageId pkgids params =
--TODO: this should work using exclude constraints instead
params {
depResolverInstalledPkgIndex =
- foldl' (flip PackageIndex.deletePackageId)
+ foldl' (flip InstalledPackageIndex.deleteSourcePackageId)
(depResolverInstalledPkgIndex params) pkgids
}
@@ -221,20 +260,20 @@ hideInstalledPackagesAllVersions pkgnames params =
--TODO: this should work using exclude constraints instead
params {
depResolverInstalledPkgIndex =
- foldl' (flip PackageIndex.deletePackageName)
+ foldl' (flip InstalledPackageIndex.deletePackageName)
(depResolverInstalledPkgIndex params) pkgnames
}
hideBrokenInstalledPackages :: DepResolverParams -> DepResolverParams
hideBrokenInstalledPackages params =
- hideInstalledPackagesSpecific pkgids params
+ hideInstalledPackagesSpecificByInstalledPackageId pkgids params
where
- pkgids = map packageId
- . PackageIndex.reverseDependencyClosure
+ pkgids = map Installed.installedPackageId
+ . InstalledPackageIndex.reverseDependencyClosure
(depResolverInstalledPkgIndex params)
- . map (packageId . fst)
- . PackageIndex.brokenPackages
+ . map (Installed.installedPackageId . fst)
+ . InstalledPackageIndex.brokenPackages
$ depResolverInstalledPkgIndex params
@@ -247,7 +286,7 @@ reinstallTargets params =
hideInstalledPackagesAllVersions (depResolverTargets params) params
-standardInstallPolicy :: PackageIndex InstalledPackage
+standardInstallPolicy :: InstalledPackageIndex.PackageIndex
-> SourcePackageDb
-> [PackageSpecifier SourcePackage]
-> DepResolverParams
@@ -265,7 +304,7 @@ standardInstallPolicy
. addTargets
(map pkgSpecifierTarget pkgSpecifiers)
- . hideInstalledPackagesSpecific
+ . hideInstalledPackagesSpecificBySourcePackageId
[ packageId pkg | SpecificSourcePackage pkg <- pkgSpecifiers ]
. addSourcePackages
@@ -279,8 +318,20 @@ standardInstallPolicy
-- * Interface to the standard resolver
-- ------------------------------------------------------------
-defaultResolver :: DependencyResolver
-defaultResolver = topDownResolver
+chooseSolver :: Verbosity -> PreSolver -> CompilerId -> IO Solver
+chooseSolver _ AlwaysTopDown _ = return TopDown
+chooseSolver _ AlwaysModular _ = return Modular
+chooseSolver verbosity Choose (CompilerId f v) = do
+ let chosenSolver | f == GHC && v <= Version [7] [] = TopDown
+ | otherwise = Modular
+ msg TopDown = warn verbosity "Falling back to topdown solver for GHC < 7."
+ msg Modular = info verbosity "Choosing modular solver."
+ msg chosenSolver
+ return chosenSolver
+
+runSolver :: Solver -> SolverConfig -> DependencyResolver
+runSolver TopDown = const topDownResolver -- TODO: warn about unsuported options
+runSolver Modular = modularResolver
-- | Run the dependency solver.
--
@@ -290,27 +341,40 @@ defaultResolver = topDownResolver
--
resolveDependencies :: Platform
-> CompilerId
+ -> Solver
-> DepResolverParams
-> Progress String String InstallPlan
--TODO: is this needed here? see dontUpgradeBasePackage
-resolveDependencies platform comp params
+resolveDependencies platform comp _solver params
| null (depResolverTargets params)
= return (mkInstallPlan platform comp [])
-resolveDependencies platform comp params =
+resolveDependencies platform comp solver params =
fmap (mkInstallPlan platform comp)
- $ defaultResolver platform comp installedPkgIndex sourcePkgIndex
- preferences constraints targets
+ $ runSolver solver (SolverConfig reorderGoals indGoals noReinstalls shadowing maxBkjumps)
+ platform comp installedPkgIndex sourcePkgIndex
+ preferences constraints targets
where
DepResolverParams
targets constraints
prefs defpref
installedPkgIndex
- sourcePkgIndex = dontUpgradeBasePackage
- . hideBrokenInstalledPackages
- $ params
+ sourcePkgIndex
+ reorderGoals
+ indGoals
+ noReinstalls
+ shadowing
+ maxBkjumps = dontUpgradeBasePackage
+ -- TODO:
+ -- The modular solver can properly deal with broken packages
+ -- and won't select them. So the 'hideBrokenInstalledPackages'
+ -- function should be moved into a module that is specific
+ -- to the Topdown solver.
+ . (if solver /= Modular then hideBrokenInstalledPackages
+ else id)
+ $ params
preferences = interpretPackagesPreference
(Set.fromList targets) defpref prefs
@@ -383,7 +447,8 @@ interpretPackagesPreference selected defaultPref prefs =
resolveWithoutDependencies :: DepResolverParams
-> Either [ResolveNoDepsError] [SourcePackage]
resolveWithoutDependencies (DepResolverParams targets constraints
- prefs defpref installedPkgIndex sourcePkgIndex) =
+ prefs defpref installedPkgIndex sourcePkgIndex
+ _reorderGoals _indGoals _avoidReinstalls _shadowing _maxBjumps) =
collectEithers (map selectPackage targets)
where
selectPackage :: PackageName -> Either ResolveNoDepsError SourcePackage
@@ -406,7 +471,7 @@ resolveWithoutDependencies (DepResolverParams targets constraints
(installPref pkg, versionPref pkg, packageVersion pkg)
installPref = case preferInstalled of
PreferLatest -> const False
- PreferInstalled -> isJust . PackageIndex.lookupPackageId
+ PreferInstalled -> not . null . InstalledPackageIndex.lookupSourcePackageId
installedPkgIndex
. packageId
versionPref pkg = packageVersion pkg `withinRange` preferredVersions
diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Modular.hs b/cabal/cabal-install/Distribution/Client/Dependency/Modular.hs
new file mode 100644
index 0000000..c88fa0b
--- /dev/null
+++ b/cabal/cabal-install/Distribution/Client/Dependency/Modular.hs
@@ -0,0 +1,58 @@
+module Distribution.Client.Dependency.Modular
+ ( modularResolver, SolverConfig(..)) where
+
+-- Here, we try to map between the external cabal-install solver
+-- interface and the internal interface that the solver actually
+-- expects. There are a number of type conversions to perform: we
+-- have to convert the package indices to the uniform index used
+-- by the solver; we also have to convert the initial constraints;
+-- and finally, we have to convert back the resulting install
+-- plan.
+
+import Data.Map as M
+ ( fromListWith )
+import Distribution.Client.Dependency.Modular.Assignment
+ ( Assignment, toCPs )
+import Distribution.Client.Dependency.Modular.Dependency
+ ( RevDepMap )
+import Distribution.Client.Dependency.Modular.ConfiguredConversion
+ ( convCP )
+import Distribution.Client.Dependency.Modular.IndexConversion
+ ( convPIs )
+import Distribution.Client.Dependency.Modular.Log
+ ( logToProgress )
+import Distribution.Client.Dependency.Modular.Package
+ ( PN )
+import Distribution.Client.Dependency.Modular.Solver
+ ( SolverConfig(..), solve )
+import Distribution.Client.Dependency.Types
+ ( DependencyResolver, PackageConstraint(..) )
+import Distribution.Client.InstallPlan
+ ( PlanPackage )
+import Distribution.System
+ ( Platform(..) )
+
+-- | Ties the two worlds together: classic cabal-install vs. the modular
+-- solver. Performs the necessary translations before and after.
+modularResolver :: SolverConfig -> DependencyResolver
+modularResolver sc (Platform arch os) cid iidx sidx pprefs pcs pns =
+ fmap (uncurry postprocess) $ -- convert install plan
+ logToProgress (maxBackjumps sc) $ -- convert log format into progress format
+ solve sc idx pprefs gcs pns
+ where
+ -- Indices have to be converted into solver-specific uniform index.
+ idx = convPIs os arch cid (shadowPkgs sc) iidx sidx
+ -- Constraints have to be converted into a finite map indexed by PN.
+ gcs = M.fromListWith (++) (map (\ pc -> (pcName pc, [pc])) pcs)
+
+ -- Results have to be converted into an install plan.
+ postprocess :: Assignment -> RevDepMap -> [PlanPackage]
+ postprocess a rdm = map (convCP iidx sidx) (toCPs a rdm)
+
+ -- Helper function to extract the PN from a constraint.
+ pcName :: PackageConstraint -> PN
+ pcName (PackageConstraintVersion pn _) = pn
+ pcName (PackageConstraintInstalled pn ) = pn
+ pcName (PackageConstraintSource pn ) = pn
+ pcName (PackageConstraintFlags pn _) = pn
+ pcName (PackageConstraintStanzas pn _) = pn
diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Modular/Assignment.hs b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Assignment.hs
new file mode 100644
index 0000000..91db3c1
--- /dev/null
+++ b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Assignment.hs
@@ -0,0 +1,154 @@
+module Distribution.Client.Dependency.Modular.Assignment where
+
+import Control.Applicative
+import Control.Monad
+import Data.Array as A
+import Data.List as L
+import Data.Map as M
+import Data.Maybe
+import Data.Graph
+import Prelude hiding (pi)
+
+import Distribution.PackageDescription (FlagAssignment) -- from Cabal
+import Distribution.Client.Types (OptionalStanza)
+
+import Distribution.Client.Dependency.Modular.Configured
+import Distribution.Client.Dependency.Modular.Dependency
+import Distribution.Client.Dependency.Modular.Flag
+import Distribution.Client.Dependency.Modular.Index
+import Distribution.Client.Dependency.Modular.Package
+import Distribution.Client.Dependency.Modular.Version
+
+-- | A (partial) package assignment. Qualified package names
+-- are associated with instances.
+type PAssignment = Map QPN I
+
+-- | A (partial) package preassignment. Qualified package names
+-- are associated with constrained instances. Constrained instances
+-- record constraints about the instances that can still be chosen,
+-- and in the extreme case fix a concrete instance.
+type PPreAssignment = Map QPN (CI QPN)
+type FAssignment = Map QFN Bool
+type SAssignment = Map QSN Bool
+
+-- | A (partial) assignment of variables.
+data Assignment = A PAssignment FAssignment SAssignment
+ deriving (Show, Eq)
+
+-- | A preassignment comprises knowledge about variables, but not
+-- necessarily fixed values.
+data PreAssignment = PA PPreAssignment FAssignment SAssignment
+
+-- | Extend a package preassignment.
+--
+-- Takes the variable that causes the new constraints, a current preassignment
+-- and a set of new dependency constraints.
+--
+-- We're trying to extend the preassignment with each dependency one by one.
+-- Each dependency is for a particular variable. We check if we already have
+-- constraints for that variable in the current preassignment. If so, we're
+-- trying to merge the constraints.
+--
+-- Either returns a witness of the conflict that would arise during the merge,
+-- or the successfully extended assignment.
+extend :: Var QPN -> PPreAssignment -> [Dep QPN] -> Either (ConflictSet QPN, [Dep QPN]) PPreAssignment
+extend var pa qa = foldM (\ a (Dep qpn ci) ->
+ let ci' = M.findWithDefault (Constrained []) qpn a
+ in case (\ x -> M.insert qpn x a) <$> merge ci' ci of
+ Left (c, (d, d')) -> Left (c, L.map (Dep qpn) (simplify (P qpn) d d'))
+ Right x -> Right x)
+ pa qa
+ where
+ -- We're trying to remove trivial elements of the conflict. If we're just
+ -- making a choice pkg == instance, and pkg => pkg == instance is a part
+ -- of the conflict, then this info is clear from the context and does not
+ -- have to be repeated.
+ simplify v (Fixed _ (Goal var' _)) c | v == var && var' == var = [c]
+ simplify v c (Fixed _ (Goal var' _)) | v == var && var' == var = [c]
+ simplify _ c d = [c, d]
+
+-- | Delivers an ordered list of fully configured packages.
+--
+-- TODO: This function is (sort of) ok. However, there's an open bug
+-- w.r.t. unqualification. There might be several different instances
+-- of one package version chosen by the solver, which will lead to
+-- clashes.
+toCPs :: Assignment -> RevDepMap -> [CP QPN]
+toCPs (A pa fa sa) rdm =
+ let
+ -- get hold of the graph
+ g :: Graph
+ vm :: Vertex -> ((), QPN, [QPN])
+ cvm :: QPN -> Maybe Vertex
+ -- Note that the RevDepMap contains duplicate dependencies. Therefore the nub.
+ (g, vm, cvm) = graphFromEdges (L.map (\ (x, xs) -> ((), x, nub xs))
+ (M.toList rdm))
+ tg :: Graph
+ tg = transposeG g
+ -- Topsort the dependency graph, yielding a list of pkgs in the right order.
+ -- The graph will still contain all the installed packages, and it might
+ -- contain duplicates, because several variables might actually resolve to
+ -- the same package in the presence of qualified package names.
+ ps :: [PI QPN]
+ ps = L.map ((\ (_, x, _) -> PI x (pa M.! x)) . vm) $
+ topSort g
+ -- Determine the flags per package, by walking over and regrouping the
+ -- complete flag assignment by package.
+ fapp :: Map QPN FlagAssignment
+ fapp = M.fromListWith (++) $
+ L.map (\ ((FN (PI qpn _) fn), b) -> (qpn, [(fn, b)])) $
+ M.toList $
+ fa
+ -- Stanzas per package.
+ sapp :: Map QPN [OptionalStanza]
+ sapp = M.fromListWith (++) $
+ L.map (\ ((SN (PI qpn _) sn), b) -> (qpn, if b then [sn] else [])) $
+ M.toList $
+ sa
+ -- Dependencies per package.
+ depp :: QPN -> [PI QPN]
+ depp qpn = let v :: Vertex
+ v = fromJust (cvm qpn)
+ dvs :: [Vertex]
+ dvs = tg A.! v
+ in L.map (\ dv -> case vm dv of (_, x, _) -> PI x (pa M.! x)) dvs
+ in
+ L.map (\ pi@(PI qpn _) -> CP pi
+ (M.findWithDefault [] qpn fapp)
+ (M.findWithDefault [] qpn sapp)
+ (depp qpn))
+ ps
+
+-- | Finalize an assignment and a reverse dependency map.
+--
+-- This is preliminary, and geared towards output right now.
+finalize :: Index -> Assignment -> RevDepMap -> IO ()
+finalize idx (A pa fa _) rdm =
+ let
+ -- get hold of the graph
+ g :: Graph
+ vm :: Vertex -> ((), QPN, [QPN])
+ (g, vm) = graphFromEdges' (L.map (\ (x, xs) -> ((), x, xs)) (M.toList rdm))
+ -- topsort the dependency graph, yielding a list of pkgs in the right order
+ f :: [PI QPN]
+ f = L.filter (not . instPI) (L.map ((\ (_, x, _) -> PI x (pa M.! x)) . vm) (topSort g))
+ fapp :: Map QPN [(QFN, Bool)] -- flags per package
+ fapp = M.fromListWith (++) $
+ L.map (\ (qfn@(FN (PI qpn _) _), b) -> (qpn, [(qfn, b)])) $ M.toList $ fa
+ -- print one instance
+ ppi pi@(PI qpn _) = showPI pi ++ status pi ++ " " ++ pflags (M.findWithDefault [] qpn fapp)
+ -- print install status
+ status :: PI QPN -> String
+ status (PI (Q _ pn) _) =
+ case insts of
+ [] -> " (new)"
+ vs -> " (" ++ intercalate ", " (L.map showVer vs) ++ ")"
+ where insts = L.map (\ (I v _) -> v) $ L.filter isInstalled $
+ M.keys (M.findWithDefault M.empty pn idx)
+ isInstalled (I _ (Inst _ )) = True
+ isInstalled _ = False
+ -- print flag assignment
+ pflags = unwords . L.map (uncurry showFBool)
+ in
+ -- show packages with associated flag assignments
+ putStr (unlines (L.map ppi f))
diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs
new file mode 100644
index 0000000..24d60b4
--- /dev/null
+++ b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs
@@ -0,0 +1,143 @@
+module Distribution.Client.Dependency.Modular.Builder where
+
+-- Building the search tree.
+--
+-- In this phase, we build a search tree that is too large, i.e, it contains
+-- invalid solutions. We keep track of the open goals at each point. We
+-- nondeterministically pick an open goal (via a goal choice node), create
+-- subtrees according to the index and the available solutions, and extend the
+-- set of open goals by superficially looking at the dependencies recorded in
+-- the index.
+--
+-- For each goal, we keep track of all the *reasons* why it is being
+-- introduced. These are for debugging and error messages, mainly. A little bit
+-- of care has to be taken due to the way we treat flags. If a package has
+-- flag-guarded dependencies, we cannot introduce them immediately. Instead, we
+-- store the entire dependency.
+
+import Control.Monad.Reader hiding (sequence, mapM)
+import Data.List as L
+import Data.Map as M
+import Prelude hiding (sequence, mapM)
+
+import Distribution.Client.Dependency.Modular.Dependency
+import Distribution.Client.Dependency.Modular.Flag
+import Distribution.Client.Dependency.Modular.Index
+import Distribution.Client.Dependency.Modular.Package
+import Distribution.Client.Dependency.Modular.PSQ as P
+import Distribution.Client.Dependency.Modular.Tree
+
+-- | The state needed during the build phase of the search tree.
+data BuildState = BS {
+ index :: Index, -- ^ information about packages and their dependencies
+ scope :: Scope, -- ^ information about encapsulations
+ rdeps :: RevDepMap, -- ^ set of all package goals, completed and open, with reverse dependencies
+ open :: PSQ OpenGoal (), -- ^ set of still open goals (flag and package goals)
+ next :: BuildType -- ^ kind of node to generate next
+}
+
+-- | Extend the set of open goals with the new goals listed.
+--
+-- We also adjust the map of overall goals, and keep track of the
+-- reverse dependencies of each of the goals.
+extendOpen :: QPN -> [OpenGoal] -> BuildState -> BuildState
+extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs
+ where
+ go g o [] = s { rdeps = g, open = o }
+ go g o (ng@(OpenGoal (Flagged _ _ _ _) _gr) : ngs) = go g (cons ng () o) ngs
+ go g o (ng@(OpenGoal (Stanza _ _ ) _gr) : ngs) = go g (cons ng () o) ngs
+ go g o (ng@(OpenGoal (Simple (Dep qpn _)) _gr) : ngs)
+ | qpn == qpn' = go g o ngs
+ -- we ignore self-dependencies at this point; TODO: more care may be needed
+ | qpn `M.member` g = go (M.adjust (qpn':) qpn g) o ngs
+ | otherwise = go (M.insert qpn [qpn'] g) (cons ng () o) ngs
+ -- code above is correct; insert/adjust have different arg order
+
+-- | Update the current scope by taking into account the encapsulations that
+-- are defined for the current package.
+establishScope :: QPN -> Encaps -> BuildState -> BuildState
+establishScope (Q pp pn) ecs s =
+ s { scope = L.foldl (\ m e -> M.insert e pp' m) (scope s) ecs }
+ where
+ pp' = pn : pp -- new path
+
+-- | Given the current scope, qualify all the package names in the given set of
+-- dependencies and then extend the set of open goals accordingly.
+scopedExtendOpen :: QPN -> I -> QGoalReasons -> FlaggedDeps PN -> FlagInfo ->
+ BuildState -> BuildState
+scopedExtendOpen qpn i gr fdeps fdefs s = extendOpen qpn gs s
+ where
+ sc = scope s
+ qfdeps = L.map (fmap (qualify sc)) fdeps -- qualify all the package names
+ qfdefs = L.map (\ (fn, b) -> Flagged (FN (PI qpn i) fn) b [] []) $ M.toList fdefs
+ gs = L.map (flip OpenGoal gr) (qfdeps ++ qfdefs)
+
+data BuildType = Goals | OneGoal OpenGoal | Instance QPN I PInfo QGoalReasons
+
+build :: BuildState -> Tree (QGoalReasons, Scope)
+build = ana go
+ where
+ go :: BuildState -> TreeF (QGoalReasons, Scope) BuildState
+
+ -- If we have a choice between many goals, we just record the choice in
+ -- the tree. We select each open goal in turn, and before we descend, remove
+ -- it from the queue of open goals.
+ go bs@(BS { rdeps = rds, open = gs, next = Goals })
+ | P.null gs = DoneF rds
+ | otherwise = GoalChoiceF (P.mapWithKey (\ g (_sc, gs') -> bs { next = OneGoal g, open = gs' })
+ (P.splits gs))
+
+ -- If we have already picked a goal, then the choice depends on the kind
+ -- of goal.
+ --
+ -- For a package, we look up the instances available in the global info,
+ -- and then handle each instance in turn.
+ go bs@(BS { index = idx, scope = sc, next = OneGoal (OpenGoal (Simple (Dep qpn@(Q _ pn) _)) gr) }) =
+ case M.lookup pn idx of
+ Nothing -> FailF (toConflictSet (Goal (P qpn) gr)) (BuildFailureNotInIndex pn)
+ Just pis -> PChoiceF qpn (gr, sc) (P.fromList (L.map (\ (i, info) ->
+ (i, bs { next = Instance qpn i info gr }))
+ (M.toList pis)))
+ -- TODO: data structure conversion is rather ugly here
+
+ -- For a flag, we create only two subtrees, and we create them in the order
+ -- that is indicated by the flag default.
+ --
+ -- TODO: Should we include the flag default in the tree?
+ go bs@(BS { scope = sc, next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) (FInfo b m) t f) gr) }) =
+ FChoiceF qfn (gr, sc) trivial m (P.fromList (reorder b
+ [(True, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn True : gr)) t) bs) { next = Goals }),
+ (False, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn False : gr)) f) bs) { next = Goals })]))
+ where
+ reorder True = id
+ reorder False = reverse
+ trivial = L.null t && L.null f
+
+ go bs@(BS { scope = sc, next = OneGoal (OpenGoal (Stanza qsn@(SN (PI qpn _) _) t) gr) }) =
+ SChoiceF qsn (gr, sc) trivial (P.fromList
+ [(False, bs { next = Goals }),
+ (True, (extendOpen qpn (L.map (flip OpenGoal (SDependency qsn : gr)) t) bs) { next = Goals })])
+ where
+ trivial = L.null t
+
+ -- For a particular instance, we change the state: we update the scope,
+ -- and furthermore we update the set of goals.
+ --
+ -- TODO: We could inline this above.
+ go bs@(BS { next = Instance qpn i (PInfo fdeps fdefs ecs _) gr }) =
+ go ((establishScope qpn ecs
+ (scopedExtendOpen qpn i (PDependency (PI qpn i) : gr) fdeps fdefs bs))
+ { next = Goals })
+
+-- | Interface to the tree builder. Just takes an index and a list of package names,
+-- and computes the initial state and then the tree from there.
+buildTree :: Index -> Bool -> [PN] -> Tree (QGoalReasons, Scope)
+buildTree idx ind igs =
+ build (BS idx sc
+ (M.fromList (L.map (\ qpn -> (qpn, [])) qpns))
+ (P.fromList (L.map (\ qpn -> (OpenGoal (Simple (Dep qpn (Constrained []))) [UserGoal], ())) qpns))
+ Goals)
+ where
+ sc | ind = makeIndependent igs
+ | otherwise = emptyScope
+ qpns = L.map (qualify sc) igs
diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Modular/Configured.hs b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Configured.hs
new file mode 100644
index 0000000..d6f2bc2
--- /dev/null
+++ b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Configured.hs
@@ -0,0 +1,10 @@
+module Distribution.Client.Dependency.Modular.Configured where
+
+import Distribution.PackageDescription (FlagAssignment) -- from Cabal
+import Distribution.Client.Types (OptionalStanza)
+
+import Distribution.Client.Dependency.Modular.Package
+
+-- | A configured package is a package instance together with
+-- a flag assignment and complete dependencies.
+data CP qpn = CP (PI qpn) FlagAssignment [OptionalStanza] [PI qpn]
diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs b/cabal/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs
new file mode 100644
index 0000000..58e08a3
--- /dev/null
+++ b/cabal/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs
@@ -0,0 +1,40 @@
+module Distribution.Client.Dependency.Modular.ConfiguredConversion where
+
+import Data.Maybe
+import Prelude hiding (pi)
+
+import Distribution.Client.InstallPlan
+import Distribution.Client.Types
+import Distribution.Compiler
+import qualified Distribution.Client.PackageIndex as CI
+import qualified Distribution.Simple.PackageIndex as SI
+import Distribution.System
+
+import Distribution.Client.Dependency.Modular.Configured
+import Distribution.Client.Dependency.Modular.Package
+
+mkPlan :: Platform -> CompilerId ->
+ SI.PackageIndex -> CI.PackageIndex SourcePackage ->
+ [CP QPN] -> Either [PlanProblem] InstallPlan
+mkPlan plat comp iidx sidx cps =
+ new plat comp (CI.fromList (map (convCP iidx sidx) cps))
+
+convCP :: SI.PackageIndex -> CI.PackageIndex SourcePackage ->
+ CP QPN -> PlanPackage
+convCP iidx sidx (CP qpi fa es ds) =
+ case convPI qpi of
+ Left pi -> PreExisting $ InstalledPackage
+ (fromJust $ SI.lookupInstalledPackageId iidx pi)
+ (map convPI' ds)
+ Right pi -> Configured $ ConfiguredPackage
+ (fromJust $ CI.lookupPackageId sidx pi)
+ fa
+ es
+ (map convPI' ds)
+
+convPI :: PI QPN -> Either InstalledPackageId PackageId
+convPI (PI _ (I _ (Inst pi))) = Left pi
+convPI qpi = Right $ convPI' qpi
+
+convPI' :: PI QPN -> PackageId
+convPI' (PI (Q _ pn) (I v _)) = PackageIdentifier pn v
diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs
new file mode 100644
index 0000000..5642b01
--- /dev/null
+++ b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs
@@ -0,0 +1,194 @@
+module Distribution.Client.Dependency.Modular.Dependency where
+
+import Prelude hiding (pi)
+
+import Data.List as L
+import Data.Map as M
+import Data.Set as S
+
+import Distribution.Client.Dependency.Modular.Flag
+import Distribution.Client.Dependency.Modular.Package
+import Distribution.Client.Dependency.Modular.Version
+
+-- | The type of variables that play a role in the solver.
+-- Note that the tree currently does not use this type directly,
+-- and rather has separate tree nodes for the different types of
+-- variables. This fits better with the fact that in most cases,
+-- these have to be treated differently.
+--
+-- TODO: This isn't the ideal location to declare the type,
+-- but we need them for constrained instances.
+data Var qpn = P qpn | F (FN qpn) | S (SN qpn)
+ deriving (Eq, Ord, Show)
+
+showVar :: Var QPN -> String
+showVar (P qpn) = showQPN qpn
+showVar (F qfn) = showQFN qfn
+showVar (S qsn) = showQSN qsn
+
+instance Functor Var where
+ fmap f (P n) = P (f n)
+ fmap f (F fn) = F (fmap f fn)
+ fmap f (S sn) = S (fmap f sn)
+
+type ConflictSet qpn = Set (Var qpn)
+
+showCS :: ConflictSet QPN -> String
+showCS = intercalate ", " . L.map showVar . S.toList
+
+-- | Constrained instance. If the choice has already been made, this is
+-- a fixed instance, and we record the package name for which the choice
+-- is for convenience. Otherwise, it is a list of version ranges paired with
+-- the goals / variables that introduced them.
+data CI qpn = Fixed I (Goal qpn) | Constrained [VROrigin qpn]
+ deriving (Eq, Show)
+
+instance Functor CI where
+ fmap f (Fixed i g) = Fixed i (fmap f g)
+ fmap f (Constrained vrs) = Constrained (L.map (\ (x, y) -> (x, fmap f y)) vrs)
+
+instance ResetGoal CI where
+ resetGoal g (Fixed i _) = Fixed i g
+ resetGoal g (Constrained vrs) = Constrained (L.map (\ (x, y) -> (x, resetGoal g y)) vrs)
+
+type VROrigin qpn = (VR, Goal qpn)
+
+-- | Helper function to collapse a list of version ranges with origins into
+-- a single, simplified, version range.
+collapse :: [VROrigin qpn] -> VR
+collapse = simplifyVR . L.foldr (.&&.) anyVR . L.map fst
+
+showCI :: CI QPN -> String
+showCI (Fixed i _) = "==" ++ showI i
+showCI (Constrained vr) = showVR (collapse vr)
+
+-- | Merge constrained instances. We currently adopt a lazy strategy for
+-- merging, i.e., we only perform actual checking if one of the two choices
+-- is fixed. If the merge fails, we return a conflict set indicating the
+-- variables responsible for the failure, as well as the two conflicting
+-- fragments.
+--
+-- Note that while there may be more than one conflicting pair of version
+-- ranges, we only return the first we find.
+--
+-- TODO: Different pairs might have different conflict sets. We're
+-- obviously interested to return a conflict that has a "better" conflict
+-- set in the sense the it contains variables that allow us to backjump
+-- further. We might apply some heuristics here, such as to change the
+-- order in which we check the constraints.
+merge :: Ord qpn => CI qpn -> CI qpn -> Either (ConflictSet qpn, (CI qpn, CI qpn)) (CI qpn)
+merge c@(Fixed i g1) d@(Fixed j g2)
+ | i == j = Right c
+ | otherwise = Left (S.union (toConflictSet g1) (toConflictSet g2), (c, d))
+merge c@(Fixed (I v _) g1) (Constrained rs) = go rs -- I tried "reverse rs" here, but it seems to slow things down ...
+ where
+ go [] = Right c
+ go (d@(vr, g2) : vrs)
+ | checkVR vr v = go vrs
+ | otherwise = Left (S.union (toConflictSet g1) (toConflictSet g2), (c, Constrained [d]))
+merge c@(Constrained _) d@(Fixed _ _) = merge d c
+merge (Constrained rs) (Constrained ss) = Right (Constrained (rs ++ ss))
+
+
+type FlaggedDeps qpn = [FlaggedDep qpn]
+
+-- | Flagged dependencies can either be plain dependency constraints,
+-- or flag-dependent dependency trees.
+data FlaggedDep qpn =
+ Flagged (FN qpn) FInfo (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn)
+ | Stanza (SN qpn) (TrueFlaggedDeps qpn)
+ | Simple (Dep qpn)
+ deriving (Eq, Show)
+
+instance Functor FlaggedDep where
+ fmap f (Flagged x y tt ff) = Flagged (fmap f x) y
+ (fmap (fmap f) tt) (fmap (fmap f) ff)
+ fmap f (Stanza x tt) = Stanza (fmap f x) (fmap (fmap f) tt)
+ fmap f (Simple d) = Simple (fmap f d)
+
+type TrueFlaggedDeps qpn = FlaggedDeps qpn
+type FalseFlaggedDeps qpn = FlaggedDeps qpn
+
+-- | A dependency (constraint) associates a package name with a
+-- constrained instance.
+data Dep qpn = Dep qpn (CI qpn)
+ deriving (Eq, Show)
+
+showDep :: Dep QPN -> String
+showDep (Dep qpn (Fixed i (Goal v _)) ) =
+ (if P qpn /= v then showVar v ++ " => " else "") ++
+ showQPN qpn ++ "==" ++ showI i
+showDep (Dep qpn (Constrained [(vr, Goal v _)])) =
+ showVar v ++ " => " ++ showQPN qpn ++ showVR vr
+showDep (Dep qpn ci ) =
+ showQPN qpn ++ showCI ci
+
+instance Functor Dep where
+ fmap f (Dep x y) = Dep (f x) (fmap f y)
+
+instance ResetGoal Dep where
+ resetGoal g (Dep qpn ci) = Dep qpn (resetGoal g ci)
+
+-- | A map containing reverse dependencies between qualified
+-- package names.
+type RevDepMap = Map QPN [QPN]
+
+-- | Goals are solver variables paired with information about
+-- why they have been introduced.
+data Goal qpn = Goal (Var qpn) (GoalReasons qpn)
+ deriving (Eq, Show)
+
+instance Functor Goal where
+ fmap f (Goal v gr) = Goal (fmap f v) (fmap (fmap f) gr)
+
+class ResetGoal f where
+ resetGoal :: Goal qpn -> f qpn -> f qpn
+
+instance ResetGoal Goal where
+ resetGoal = const
+
+-- | For open goals as they occur during the build phase, we need to store
+-- additional information about flags.
+data OpenGoal = OpenGoal (FlaggedDep QPN) QGoalReasons
+ deriving (Eq, Show)
+
+-- | Reasons why a goal can be added to a goal set.
+data GoalReason qpn =
+ UserGoal
+ | PDependency (PI qpn)
+ | FDependency (FN qpn) Bool
+ | SDependency (SN qpn)
+ deriving (Eq, Show)
+
+instance Functor GoalReason where
+ fmap _ UserGoal = UserGoal
+ fmap f (PDependency pi) = PDependency (fmap f pi)
+ fmap f (FDependency fn b) = FDependency (fmap f fn) b
+ fmap f (SDependency sn) = SDependency (fmap f sn)
+
+-- | The first element is the immediate reason. The rest are the reasons
+-- for the reasons ...
+type GoalReasons qpn = [GoalReason qpn]
+
+type QGoalReasons = GoalReasons QPN
+
+goalReasonToVars :: GoalReason qpn -> ConflictSet qpn
+goalReasonToVars UserGoal = S.empty
+goalReasonToVars (PDependency (PI qpn _)) = S.singleton (P qpn)
+goalReasonToVars (FDependency qfn _) = S.singleton (F qfn)
+goalReasonToVars (SDependency qsn) = S.singleton (S qsn)
+
+goalReasonsToVars :: Ord qpn => GoalReasons qpn -> ConflictSet qpn
+goalReasonsToVars = S.unions . L.map goalReasonToVars
+
+-- | Closes a goal, i.e., removes all the extraneous information that we
+-- need only during the build phase.
+close :: OpenGoal -> Goal QPN
+close (OpenGoal (Simple (Dep qpn _)) gr) = Goal (P qpn) gr
+close (OpenGoal (Flagged qfn _ _ _ ) gr) = Goal (F qfn) gr
+close (OpenGoal (Stanza qsn _) gr) = Goal (S qsn) gr
+
+-- | Compute a conflic set from a goal. The conflict set contains the
+-- closure of goal reasons as well as the variable of the goal itself.
+toConflictSet :: Ord qpn => Goal qpn -> ConflictSet qpn
+toConflictSet (Goal g gr) = S.insert g (goalReasonsToVars gr)
diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Modular/Explore.hs b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Explore.hs
new file mode 100644
index 0000000..9f6690b
--- /dev/null
+++ b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Explore.hs
@@ -0,0 +1,148 @@
+module Distribution.Client.Dependency.Modular.Explore where
+
+import Control.Applicative as A
+import Data.Foldable
+import Data.List as L
+import Data.Map as M
+import Data.Set as S
+
+import Distribution.Client.Dependency.Modular.Assignment
+import Distribution.Client.Dependency.Modular.Dependency
+import Distribution.Client.Dependency.Modular.Log
+import Distribution.Client.Dependency.Modular.Message
+import Distribution.Client.Dependency.Modular.Package
+import Distribution.Client.Dependency.Modular.PSQ as P
+import Distribution.Client.Dependency.Modular.Tree
+
+-- | Backjumping.
+--
+-- A tree traversal that tries to propagate conflict sets
+-- up the tree from the leaves, and thereby cut branches.
+-- All the tricky things are done in the function 'combine'.
+backjump :: Tree a -> Tree (Maybe (ConflictSet QPN))
+backjump = snd . cata go
+ where
+ go (FailF c fr) = (Just c, Fail c fr)
+ go (DoneF rdm ) = (Nothing, Done rdm)
+ go (PChoiceF qpn _ ts) = (c, PChoice qpn c (P.fromList ts'))
+ where
+ ~(c, ts') = combine (P qpn) (P.toList ts) S.empty
+ go (FChoiceF qfn _ b m ts) = (c, FChoice qfn c b m (P.fromList ts'))
+ where
+ ~(c, ts') = combine (F qfn) (P.toList ts) S.empty
+ go (SChoiceF qsn _ b ts) = (c, SChoice qsn c b (P.fromList ts'))
+ where
+ ~(c, ts') = combine (S qsn) (P.toList ts) S.empty
+ go (GoalChoiceF ts) = (c, GoalChoice (P.fromList ts'))
+ where
+ ~(cs, ts') = unzip $ L.map (\ (k, (x, v)) -> (x, (k, v))) $ P.toList ts
+ c = case cs of [] -> Nothing
+ d : _ -> d
+
+-- | The 'combine' function is at the heart of backjumping. It takes
+-- the variable we're currently considering, and a list of children
+-- annotated with their respective conflict sets, and an accumulator
+-- for the result conflict set. It returns a combined conflict set
+-- for the parent node, and a (potentially shortened) list of children
+-- with the annotations removed.
+--
+-- It is *essential* that we produce the results as early as possible.
+-- In particular, we have to produce the list of children prior to
+-- traversing the entire list -- otherwise we lose the desired behaviour
+-- of being able to traverse the tree from left to right incrementally.
+--
+-- We can shorten the list of children if we find an individual conflict
+-- set that does not contain the current variable. In this case, we can
+-- just lift the conflict set to the current level, because the current
+-- level cannot possibly have contributed to this conflict, so no other
+-- choice at the current level would avoid the conflict.
+--
+-- If any of the children might contain a successful solution
+-- (indicated by Nothing), then Nothing will be the combined
+-- conflict set. If all children contain conflict sets, we can
+-- take the union as the combined conflict set.
+combine :: Var QPN -> [(a, (Maybe (ConflictSet QPN), b))] ->
+ ConflictSet QPN -> (Maybe (ConflictSet QPN), [(a, b)])
+combine _ [] c = (Just c, [])
+combine var ((k, ( d, v)) : xs) c = (\ ~(e, ys) -> (e, (k, v) : ys)) $
+ case d of
+ Just e | not (var `S.member` e) -> (Just e, [])
+ | otherwise -> combine var xs (e `S.union` c)
+ Nothing -> (Nothing, snd $ combine var xs S.empty)
+
+-- | Naive backtracking exploration of the search tree. This will yield correct
+-- assignments only once the tree itself is validated.
+explore :: Alternative m => Tree a -> (Assignment -> m (Assignment, RevDepMap))
+explore = cata go
+ where
+ go (FailF _ _) _ = A.empty
+ go (DoneF rdm) a = pure (a, rdm)
+ go (PChoiceF qpn _ ts) (A pa fa sa) =
+ asum $ -- try children in order,
+ P.mapWithKey -- when descending ...
+ (\ k r -> r (A (M.insert qpn k pa) fa sa)) $ -- record the pkg choice
+ ts
+ go (FChoiceF qfn _ _ _ ts) (A pa fa sa) =
+ asum $ -- try children in order,
+ P.mapWithKey -- when descending ...
+ (\ k r -> r (A pa (M.insert qfn k fa) sa)) $ -- record the flag choice
+ ts
+ go (SChoiceF qsn _ _ ts) (A pa fa sa) =
+ asum $ -- try children in order,
+ P.mapWithKey -- when descending ...
+ (\ k r -> r (A pa fa (M.insert qsn k sa))) $ -- record the flag choice
+ ts
+ go (GoalChoiceF ts) a =
+ casePSQ ts A.empty -- empty goal choice is an internal error
+ (\ _k v _xs -> v a) -- commit to the first goal choice
+
+-- | Version of 'explore' that returns a 'Log'.
+exploreLog :: Tree (Maybe (ConflictSet QPN)) -> (Assignment -> Log Message (Assignment, RevDepMap))
+exploreLog = cata go
+ where
+ go (FailF c fr) _ = failWith (Failure c fr)
+ go (DoneF rdm) a = succeedWith Success (a, rdm)
+ go (PChoiceF qpn c ts) (A pa fa sa) =
+ backjumpInfo c $
+ asum $ -- try children in order,
+ P.mapWithKey -- when descending ...
+ (\ k r -> tryWith (TryP (PI qpn k)) $ -- log and ...
+ r (A (M.insert qpn k pa) fa sa)) -- record the pkg choice
+ ts
+ go (FChoiceF qfn c _ _ ts) (A pa fa sa) =
+ backjumpInfo c $
+ asum $ -- try children in order,
+ P.mapWithKey -- when descending ...
+ (\ k r -> tryWith (TryF qfn k) $ -- log and ...
+ r (A pa (M.insert qfn k fa) sa)) -- record the pkg choice
+ ts
+ go (SChoiceF qsn c _ ts) (A pa fa sa) =
+ backjumpInfo c $
+ asum $ -- try children in order,
+ P.mapWithKey -- when descending ...
+ (\ k r -> tryWith (TryS qsn k) $ -- log and ...
+ r (A pa fa (M.insert qsn k sa))) -- record the pkg choice
+ ts
+ go (GoalChoiceF ts) a =
+ casePSQ ts
+ (failWith (Failure S.empty EmptyGoalChoice)) -- empty goal choice is an internal error
+ (\ k v _xs -> continueWith (Next (close k)) (v a)) -- commit to the first goal choice
+
+-- | Add in information about pruned trees.
+--
+-- TODO: This isn't quite optimal, because we do not merely report the shape of the
+-- tree, but rather make assumptions about where that shape originated from. It'd be
+-- better if the pruning itself would leave information that we could pick up at this
+-- point.
+backjumpInfo :: Maybe (ConflictSet QPN) -> Log Message a -> Log Message a
+backjumpInfo c m = m <|> case c of -- important to produce 'm' before matching on 'c'!
+ Nothing -> A.empty
+ Just cs -> failWith (Failure cs Backjump)
+
+-- | Interface.
+exploreTree :: Alternative m => Tree a -> m (Assignment, RevDepMap)
+exploreTree t = explore t (A M.empty M.empty M.empty)
+
+-- | Interface.
+exploreTreeLog :: Tree (Maybe (ConflictSet QPN)) -> Log Message (Assignment, RevDepMap)
+exploreTreeLog t = exploreLog t (A M.empty M.empty M.empty)
diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Modular/Flag.hs b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Flag.hs
new file mode 100644
index 0000000..72340bf
--- /dev/null
+++ b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Flag.hs
@@ -0,0 +1,71 @@
+module Distribution.Client.Dependency.Modular.Flag where
+
+import Data.Map as M
+import Prelude hiding (pi)
+
+import Distribution.PackageDescription hiding (Flag) -- from Cabal
+
+import Distribution.Client.Dependency.Modular.Package
+import Distribution.Client.Types (OptionalStanza(..))
+
+-- | Flag name. Consists of a package instance and the flag identifier itself.
+data FN qpn = FN (PI qpn) Flag
+ deriving (Eq, Ord, Show)
+
+-- | Extract the package name from a flag name.
+getPN :: FN qpn -> qpn
+getPN (FN (PI qpn _) _) = qpn
+
+instance Functor FN where
+ fmap f (FN x y) = FN (fmap f x) y
+
+-- | Flag identifier. Just a string.
+type Flag = FlagName
+
+unFlag :: Flag -> String
+unFlag (FlagName fn) = fn
+
+-- | Flag info. Default value, and whether the flag is manual.
+-- Manual flags can only be set explicitly.
+data FInfo = FInfo { fdefault :: Bool, fmanual :: Bool }
+ deriving (Eq, Ord, Show)
+
+-- | Flag defaults.
+type FlagInfo = Map Flag FInfo
+
+-- | Qualified flag name.
+type QFN = FN QPN
+
+-- | Stanza name. Paired with a package name, much like a flag.
+data SN qpn = SN (PI qpn) OptionalStanza
+ deriving (Eq, Ord, Show)
+
+instance Functor SN where
+ fmap f (SN x y) = SN (fmap f x) y
+
+-- | Qualified stanza name.
+type QSN = SN QPN
+
+unStanza :: OptionalStanza -> String
+unStanza TestStanzas = "test"
+unStanza BenchStanzas = "bench"
+
+showQFNBool :: QFN -> Bool -> String
+showQFNBool qfn@(FN pi _f) b = showPI pi ++ ":" ++ showFBool qfn b
+
+showQSNBool :: QSN -> Bool -> String
+showQSNBool qsn@(SN pi _f) b = showPI pi ++ ":" ++ showSBool qsn b
+
+showFBool :: FN qpn -> Bool -> String
+showFBool (FN _ f) True = "+" ++ unFlag f
+showFBool (FN _ f) False = "-" ++ unFlag f
+
+showSBool :: SN qpn -> Bool -> String
+showSBool (SN _ s) True = "*" ++ unStanza s
+showSBool (SN _ s) False = "!" ++ unStanza s
+
+showQFN :: QFN -> String
+showQFN (FN pi f) = showPI pi ++ ":" ++ unFlag f
+
+showQSN :: QSN -> String
+showQSN (SN pi f) = showPI pi ++ ":" ++ unStanza f
diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Modular/Index.hs b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Index.hs
new file mode 100644
index 0000000..d01cdb6
--- /dev/null
+++ b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Index.hs
@@ -0,0 +1,33 @@
+module Distribution.Client.Dependency.Modular.Index where
+
+import Data.List as L
+import Data.Map as M
+import Prelude hiding (pi)
+
+import Distribution.Client.Dependency.Modular.Dependency
+import Distribution.Client.Dependency.Modular.Flag
+import Distribution.Client.Dependency.Modular.Package
+import Distribution.Client.Dependency.Modular.Tree
+
+-- | An index contains information about package instances. This is a nested
+-- dictionary. Package names are mapped to instances, which in turn is mapped
+-- to info.
+type Index = Map PN (Map I PInfo)
+
+-- | Info associated with a package instance.
+-- Currently, dependencies, flags, encapsulations and failure reasons.
+-- Packages that have a failure reason recorded for them are disabled
+-- globally, for reasons external to the solver. We currently use this
+-- for shadowing which essentially is a GHC limitation, and for
+-- installed packages that are broken.
+data PInfo = PInfo (FlaggedDeps PN) FlagInfo Encaps (Maybe FailReason)
+ deriving (Show)
+
+-- | Encapsulations. A list of package names.
+type Encaps = [PN]
+
+mkIndex :: [(PN, I, PInfo)] -> Index
+mkIndex xs = M.map M.fromList (groupMap (L.map (\ (pn, i, pi) -> (pn, (i, pi))) xs))
+
+groupMap :: Ord a => [(a, b)] -> Map a [b]
+groupMap xs = M.fromListWith (flip (++)) (L.map (\ (x, y) -> (x, [y])) xs)
diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs b/cabal/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs
new file mode 100644
index 0000000..d22eeb9
--- /dev/null
+++ b/cabal/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs
@@ -0,0 +1,184 @@
+module Distribution.Client.Dependency.Modular.IndexConversion where
+
+import Data.List as L
+import Data.Map as M
+import Data.Maybe
+import Prelude hiding (pi)
+
+import qualified Distribution.Client.PackageIndex as CI
+import Distribution.Client.Types
+import Distribution.Compiler
+import Distribution.InstalledPackageInfo as IPI
+import Distribution.Package -- from Cabal
+import Distribution.PackageDescription as PD -- from Cabal
+import qualified Distribution.Simple.PackageIndex as SI
+import Distribution.System
+
+import Distribution.Client.Dependency.Modular.Dependency as D
+import Distribution.Client.Dependency.Modular.Flag as F
+import Distribution.Client.Dependency.Modular.Index
+import Distribution.Client.Dependency.Modular.Package
+import Distribution.Client.Dependency.Modular.Tree
+import Distribution.Client.Dependency.Modular.Version
+
+-- | Convert both the installed package index and the source package
+-- index into one uniform solver index.
+--
+-- We use 'allPackagesBySourcePackageId' for the installed package index
+-- because that returns us several instances of the same package and version
+-- in order of preference. This allows us in principle to \"shadow\"
+-- packages if there are several installed packages of the same version.
+-- There are currently some shortcomings in both GHC and Cabal in
+-- resolving these situations. However, the right thing to do is to
+-- fix the problem there, so for now, shadowing is only activated if
+-- explicitly requested.
+convPIs :: OS -> Arch -> CompilerId -> Bool ->
+ SI.PackageIndex -> CI.PackageIndex SourcePackage -> Index
+convPIs os arch cid sip iidx sidx =
+ mkIndex (convIPI' sip iidx ++ convSPI' os arch cid sidx)
+
+-- | Convert a Cabal installed package index to the simpler,
+-- more uniform index format of the solver.
+convIPI' :: Bool -> SI.PackageIndex -> [(PN, I, PInfo)]
+convIPI' sip idx =
+ -- apply shadowing whenever there are multple installed packages with
+ -- the same version
+ [ maybeShadow (convIP idx pkg)
+ | (_pkgid, pkgs) <- SI.allPackagesBySourcePackageId idx
+ , (maybeShadow, pkg) <- zip (id : repeat shadow) pkgs ]
+ where
+
+ -- shadowing is recorded in the package info
+ shadow (pn, i, PInfo fdeps fds encs _) | sip = (pn, i, PInfo fdeps fds encs (Just Shadowed))
+ shadow x = x
+
+convIPI :: Bool -> SI.PackageIndex -> Index
+convIPI sip = mkIndex . convIPI' sip
+
+-- | Convert a single installed package into the solver-specific format.
+convIP :: SI.PackageIndex -> InstalledPackageInfo -> (PN, I, PInfo)
+convIP idx ipi =
+ let ipid = installedPackageId ipi
+ i = I (pkgVersion (sourcePackageId ipi)) (Inst ipid)
+ pn = pkgName (sourcePackageId ipi)
+ in case mapM (convIPId pn idx) (IPI.depends ipi) of
+ Nothing -> (pn, i, PInfo [] M.empty [] (Just Broken))
+ Just fds -> (pn, i, PInfo fds M.empty [] Nothing)
+-- TODO: Installed packages should also store their encapsulations!
+
+-- | Convert dependencies specified by an installed package id into
+-- flagged dependencies of the solver.
+--
+-- May return Nothing if the package can't be found in the index. That
+-- indicates that the original package having this dependency is broken
+-- and should be ignored.
+convIPId :: PN -> SI.PackageIndex -> InstalledPackageId -> Maybe (FlaggedDep PN)
+convIPId pn' idx ipid =
+ case SI.lookupInstalledPackageId idx ipid of
+ Nothing -> Nothing
+ Just ipi -> let i = I (pkgVersion (sourcePackageId ipi)) (Inst ipid)
+ pn = pkgName (sourcePackageId ipi)
+ in Just (D.Simple (Dep pn (Fixed i (Goal (P pn') []))))
+
+-- | Convert a cabal-install source package index to the simpler,
+-- more uniform index format of the solver.
+convSPI' :: OS -> Arch -> CompilerId ->
+ CI.PackageIndex SourcePackage -> [(PN, I, PInfo)]
+convSPI' os arch cid = L.map (convSP os arch cid) . CI.allPackages
+
+convSPI :: OS -> Arch -> CompilerId ->
+ CI.PackageIndex SourcePackage -> Index
+convSPI os arch cid = mkIndex . convSPI' os arch cid
+
+-- | Convert a single source package into the solver-specific format.
+convSP :: OS -> Arch -> CompilerId -> SourcePackage -> (PN, I, PInfo)
+convSP os arch cid (SourcePackage (PackageIdentifier pn pv) gpd _pl) =
+ let i = I pv InRepo
+ in (pn, i, convGPD os arch cid (PI pn i) gpd)
+
+-- We do not use 'flattenPackageDescription' or 'finalizePackageDescription'
+-- from 'Distribution.PackageDescription.Configuration' here, because we
+-- want to keep the condition tree, but simplify much of the test.
+
+-- | Convert a generic package description to a solver-specific 'PInfo'.
+--
+-- TODO: We currently just take all dependencies from all specified library,
+-- executable and test components. This does not quite seem fair.
+convGPD :: OS -> Arch -> CompilerId ->
+ PI PN -> GenericPackageDescription -> PInfo
+convGPD os arch cid pi
+ (GenericPackageDescription _ flags libs exes tests benchs) =
+ let
+ fds = flagInfo flags
+ in
+ PInfo
+ (maybe [] (convCondTree os arch cid pi fds (const True) ) libs ++
+ concatMap (convCondTree os arch cid pi fds (const True) . snd) exes ++
+ (prefix (Stanza (SN pi TestStanzas))
+ (L.map (convCondTree os arch cid pi fds (const True) . snd) tests)) ++
+ (prefix (Stanza (SN pi BenchStanzas))
+ (L.map (convCondTree os arch cid pi fds (const True) . snd) benchs)))
+ fds
+ [] -- TODO: add encaps
+ Nothing
+
+prefix :: (FlaggedDeps qpn -> FlaggedDep qpn) -> [FlaggedDeps qpn] -> FlaggedDeps qpn
+prefix _ [] = []
+prefix f fds = [f (concat fds)]
+
+-- | Convert flag information.
+flagInfo :: [PD.Flag] -> FlagInfo
+flagInfo = M.fromList . L.map (\ (MkFlag fn _ b m) -> (fn, FInfo b m))
+
+-- | Convert condition trees to flagged dependencies.
+convCondTree :: OS -> Arch -> CompilerId -> PI PN -> FlagInfo ->
+ (a -> Bool) -> -- how to detect if a branch is active
+ CondTree ConfVar [Dependency] a -> FlaggedDeps PN
+convCondTree os arch cid pi@(PI pn _) fds p (CondNode info ds branches)
+ | p info = L.map (D.Simple . convDep pn) ds -- unconditional dependencies
+ ++ concatMap (convBranch os arch cid pi fds p) branches
+ | otherwise = []
+
+-- | Branch interpreter.
+--
+-- Here, we try to simplify one of Cabal's condition tree branches into the
+-- solver's flagged dependency format, which is weaker. Condition trees can
+-- contain complex logical expression composed from flag choices and special
+-- flags (such as architecture, or compiler flavour). We try to evaluate the
+-- special flags and subsequently simplify to a tree that only depends on
+-- simple flag choices.
+convBranch :: OS -> Arch -> CompilerId ->
+ PI PN -> FlagInfo ->
+ (a -> Bool) -> -- how to detect if a branch is active
+ (Condition ConfVar,
+ CondTree ConfVar [Dependency] a,
+ Maybe (CondTree ConfVar [Dependency] a)) -> FlaggedDeps PN
+convBranch os arch cid@(CompilerId cf cv) pi fds p (c', t', mf') =
+ go c' ( convCondTree os arch cid pi fds p t')
+ (maybe [] (convCondTree os arch cid pi fds p) mf')
+ where
+ go :: Condition ConfVar ->
+ FlaggedDeps PN -> FlaggedDeps PN -> FlaggedDeps PN
+ go (Lit True) t _ = t
+ go (Lit False) _ f = f
+ go (CNot c) t f = go c f t
+ go (CAnd c d) t f = go c (go d t f) f
+ go (COr c d) t f = go c t (go d t f)
+ go (Var (Flag fn)) t f = [Flagged (FN pi fn) (fds ! fn) t f]
+ go (Var (OS os')) t f
+ | os == os' = t
+ | otherwise = f
+ go (Var (Arch arch')) t f
+ | arch == arch' = t
+ | otherwise = f
+ go (Var (Impl cf' cvr')) t f
+ | cf == cf' && checkVR cvr' cv = t
+ | otherwise = f
+
+-- | Convert a Cabal dependency to a solver-specific dependency.
+convDep :: PN -> Dependency -> Dep PN
+convDep pn' (Dependency pn vr) = Dep pn (Constrained [(vr, Goal (P pn') [])])
+
+-- | Convert a Cabal package identifier to a solver-specific dependency.
+convPI :: PN -> PackageIdentifier -> Dep PN
+convPI pn' (PackageIdentifier pn v) = Dep pn (Constrained [(eqVR v, Goal (P pn') [])])
diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Modular/Log.hs b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Log.hs
new file mode 100644
index 0000000..9e5b857
--- /dev/null
+++ b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Log.hs
@@ -0,0 +1,108 @@
+module Distribution.Client.Dependency.Modular.Log where
+
+import Control.Applicative
+import Data.List as L
+import Data.Set as S
+
+import Distribution.Client.Dependency.Types -- from Cabal
+
+import Distribution.Client.Dependency.Modular.Dependency
+import Distribution.Client.Dependency.Modular.Message
+import Distribution.Client.Dependency.Modular.Package
+import Distribution.Client.Dependency.Modular.Tree (FailReason(..))
+
+-- | The 'Log' datatype.
+--
+-- Represents the progress of a computation lazily.
+--
+-- Parameterized over the type of actual messages and the final result.
+type Log m a = Progress m () a
+
+runLog :: Log m a -> ([m], Maybe a)
+runLog (Done x) = ([], Just x)
+runLog (Fail _) = ([], Nothing)
+runLog (Step m p) = let
+ (ms, r) = runLog p
+ in
+ (m : ms, r)
+
+-- | Postprocesses a log file. Takes as an argument a limit on allowed backjumps.
+-- If the limit is 'Nothing', then infinitely many backjumps are allowed. If the
+-- limit is 'Just 0', backtracking is completely disabled.
+logToProgress :: Maybe Int -> Log Message a -> Progress String String a
+logToProgress mbj l = let
+ (ms, s) = runLog l
+ (es, e) = proc 0 ms -- catch first error (always)
+ (ns, t) = case mbj of
+ Nothing -> (ms, Nothing)
+ Just n -> proc n ms
+ -- prefer first error over later error
+ r = case t of
+ Nothing -> case s of
+ Nothing -> e
+ Just _ -> Nothing
+ Just _ -> e
+ in go es es -- trace for first error
+ (showMessages (const True) True ns) -- shortened run
+ r s
+ where
+ -- Proc takes the allowed number of backjumps and a list of messages and explores the
+ -- message list until the maximum number of backjumps has been reached. The log until
+ -- that point as well as whether we have encountered an error or not are returned.
+ proc :: Int -> [Message] -> ([Message], Maybe (ConflictSet QPN))
+ proc _ [] = ([], Nothing)
+ proc n ( Failure cs Backjump : xs@(Leave : Failure cs' Backjump : _))
+ | cs == cs' = proc n xs -- repeated backjumps count as one
+ proc 0 ( Failure cs Backjump : _ ) = ([], Just cs)
+ proc n (x@(Failure _ Backjump) : xs) = (\ ~(ys, r) -> (x : ys, r)) (proc (n - 1) xs)
+ proc n (x : xs) = (\ ~(ys, r) -> (x : ys, r)) (proc n xs)
+
+ -- This function takes a lot of arguments. The first two are both supposed to be
+ -- the log up to the first error. That's the error that will always be printed in
+ -- case we do not find a solution. We pass this log twice, because we evaluate it
+ -- in parallel with the full log, but we also want to retain the reference to its
+ -- beginning for when we print it. This trick prevents a space leak!
+ --
+ -- The thirs argument is the full log, the fifth and six error conditions.
+ --
+ -- The order of arguments is important! In particular 's' must not be evaluated
+ -- unless absolutely necessary. It contains the final result, and if we shortcut
+ -- with an error due to backjumping, evaluating 's' would still require traversing
+ -- the entire tree.
+ go ms (_ : ns) (x : xs) r s = Step x (go ms ns xs r s)
+ go ms [] (x : xs) r s = Step x (go ms [] xs r s)
+ go ms _ [] (Just cs) _ = Fail ("Could not resolve dependencies:\n" ++
+ unlines (showMessages (L.foldr (\ v _ -> v `S.member` cs) True) False ms))
+ go _ _ [] _ (Just s) = Done s
+ go _ _ [] _ _ = Fail ("Could not resolve dependencies.") -- should not happen
+
+logToProgress' :: Log Message a -> Progress String String a
+logToProgress' l = let
+ (ms, r) = runLog l
+ xs = showMessages (const True) True ms
+ in go xs r
+ where
+ go [x] Nothing = Fail x
+ go [] Nothing = Fail ""
+ go [] (Just r) = Done r
+ go (x:xs) r = Step x (go xs r)
+
+
+runLogIO :: Log Message a -> IO (Maybe a)
+runLogIO x =
+ do
+ let (ms, r) = runLog x
+ putStr (unlines $ showMessages (const True) True ms)
+ return r
+
+failWith :: m -> Log m a
+failWith m = Step m (Fail ())
+
+succeedWith :: m -> a -> Log m a
+succeedWith m x = Step m (Done x)
+
+continueWith :: m -> Log m a -> Log m a
+continueWith = Step
+
+tryWith :: Message -> Log Message a -> Log Message a
+tryWith m x = Step m (Step Enter x) <|> failWith Leave
diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Modular/Message.hs b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Message.hs
new file mode 100644
index 0000000..1331803
--- /dev/null
+++ b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Message.hs
@@ -0,0 +1,98 @@
+module Distribution.Client.Dependency.Modular.Message where
+
+import qualified Data.List as L
+import Prelude hiding (pi)
+
+import Distribution.Text -- from Cabal
+
+import Distribution.Client.Dependency.Modular.Dependency
+import Distribution.Client.Dependency.Modular.Flag
+import Distribution.Client.Dependency.Modular.Package
+import Distribution.Client.Dependency.Modular.Tree
+
+data Message =
+ Enter -- ^ increase indentation level
+ | Leave -- ^ decrease indentation level
+ | TryP (PI QPN)
+ | TryF QFN Bool
+ | TryS QSN Bool
+ | Next (Goal QPN)
+ | Success
+ | Failure (ConflictSet QPN) FailReason
+
+-- | Transforms the structured message type to actual messages (strings).
+--
+-- Takes an additional relevance predicate. The predicate gets a stack of goal
+-- variables and can decide whether messages regarding these goals are relevant.
+-- You can plug in 'const True' if you're interested in a full trace. If you
+-- want a slice of the trace concerning a particular conflict set, then plug in
+-- a predicate returning 'True' on the empty stack and if the head is in the
+-- conflict set.
+--
+-- The second argument indicates if the level numbers should be shown. This is
+-- recommended for any trace that involves backtracking, because only the level
+-- numbers will allow to keep track of backjumps.
+showMessages :: ([Var QPN] -> Bool) -> Bool -> [Message] -> [String]
+showMessages p sl = go [] 0
+ where
+ go :: [Var QPN] -> Int -> [Message] -> [String]
+ go _ _ [] = []
+ -- complex patterns
+ go v l (TryP (PI qpn i) : Enter : Failure c fr : Leave : ms) = goPReject v l qpn [i] c fr ms
+ go v l (TryF qfn b : Enter : Failure c fr : Leave : ms) = (atLevel (F qfn : v) l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go v l ms)
+ go v l (TryS qsn b : Enter : Failure c fr : Leave : ms) = (atLevel (S qsn : v) l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go v l ms)
+ go v l (Next (Goal (P qpn) gr) : TryP pi : ms@(Enter : Next _ : _)) = (atLevel (P qpn : v) l $ "trying: " ++ showPI pi ++ showGRs gr) (go (P qpn : v) l ms)
+ go v l (Failure c Backjump : ms@(Leave : Failure c' Backjump : _)) | c == c' = go v l ms
+ -- standard display
+ go v l (Enter : ms) = go v (l+1) ms
+ go v l (Leave : ms) = go (drop 1 v) (l-1) ms
+ go v l (TryP pi@(PI qpn _) : ms) = (atLevel (P qpn : v) l $ "trying: " ++ showPI pi) (go (P qpn : v) l ms)
+ go v l (TryF qfn b : ms) = (atLevel (F qfn : v) l $ "trying: " ++ showQFNBool qfn b) (go (F qfn : v) l ms)
+ go v l (TryS qsn b : ms) = (atLevel (S qsn : v) l $ "trying: " ++ showQSNBool qsn b) (go (S qsn : v) l ms)
+ go v l (Next (Goal (P qpn) gr) : ms) = (atLevel (P qpn : v) l $ "next goal: " ++ showQPN qpn ++ showGRs gr) (go v l ms)
+ go v l (Next _ : ms) = go v l ms -- ignore flag goals in the log
+ go v l (Success : ms) = (atLevel v l $ "done") (go v l ms)
+ go v l (Failure c fr : ms) = (atLevel v l $ "fail" ++ showFR c fr) (go v l ms)
+
+ -- special handler for many subsequent package rejections
+ goPReject :: [Var QPN] -> Int -> QPN -> [I] -> ConflictSet QPN -> FailReason -> [Message] -> [String]
+ goPReject v l qpn is c fr (TryP (PI qpn' i) : Enter : Failure _ fr' : Leave : ms) | qpn == qpn' && fr == fr' = goPReject v l qpn (i : is) c fr ms
+ goPReject v l qpn is c fr ms = (atLevel (P qpn : v) l $ "rejecting: " ++ showQPN qpn ++ "-" ++ L.intercalate ", " (map showI (reverse is)) ++ showFR c fr) (go v l ms)
+
+ -- write a message, but only if it's relevant; we can also enable or disable the display of the current level
+ atLevel v l x xs
+ | sl && p v = let s = show l
+ in ("[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ x) : xs
+ | p v = x : xs
+ | otherwise = xs
+
+showGRs :: QGoalReasons -> String
+showGRs (gr : _) = showGR gr
+showGRs [] = ""
+
+showGR :: GoalReason QPN -> String
+showGR UserGoal = " (user goal)"
+showGR (PDependency pi) = " (dependency of " ++ showPI pi ++ ")"
+showGR (FDependency qfn b) = " (dependency of " ++ showQFNBool qfn b ++ ")"
+showGR (SDependency qsn) = " (dependency of " ++ showQSNBool qsn True ++ ")"
+
+showFR :: ConflictSet QPN -> FailReason -> String
+showFR _ InconsistentInitialConstraints = " (inconsistent initial constraints)"
+showFR _ (Conflicting ds) = " (conflict: " ++ L.intercalate ", " (map showDep ds) ++ ")"
+showFR _ CannotInstall = " (only already installed instances can be used)"
+showFR _ CannotReinstall = " (avoiding to reinstall a package with same version but new dependencies)"
+showFR _ Shadowed = " (shadowed by another installed package with same version)"
+showFR _ Broken = " (package is broken)"
+showFR _ (GlobalConstraintVersion vr) = " (global constraint requires " ++ display vr ++ ")"
+showFR _ GlobalConstraintInstalled = " (global constraint requires installed instance)"
+showFR _ GlobalConstraintSource = " (global constraint requires source instance)"
+showFR _ GlobalConstraintFlag = " (global constraint requires opposite flag selection)"
+showFR _ ManualFlag = " (manual flag can only be changed explicitly)"
+showFR _ (BuildFailureNotInIndex pn) = " (unknown package: " ++ display pn ++ ")"
+showFR c Backjump = " (backjumping, conflict set: " ++ showCS c ++ ")"
+-- The following are internal failures. They should not occur. In the
+-- interest of not crashing unnecessarily, we still just print an error
+-- message though.
+showFR _ (MalformedFlagChoice qfn) = " (INTERNAL ERROR: MALFORMED FLAG CHOICE: " ++ showQFN qfn ++ ")"
+showFR _ (MalformedStanzaChoice qsn) = " (INTERNAL ERROR: MALFORMED STANZA CHOICE: " ++ showQSN qsn ++ ")"
+showFR _ EmptyGoalChoice = " (INTERNAL ERROR: EMPTY GOAL CHOICE)"
diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Modular/PSQ.hs b/cabal/cabal-install/Distribution/Client/Dependency/Modular/PSQ.hs
new file mode 100644
index 0000000..1b05377
--- /dev/null
+++ b/cabal/cabal-install/Distribution/Client/Dependency/Modular/PSQ.hs
@@ -0,0 +1,102 @@
+module Distribution.Client.Dependency.Modular.PSQ where
+
+-- Priority search queues.
+--
+-- I am not yet sure what exactly is needed. But we need a datastructure with
+-- key-based lookup that can be sorted. We're using a sequence right now with
+-- (inefficiently implemented) lookup, because I think that queue-based
+-- operations and sorting turn out to be more efficiency-critical in practice.
+
+import Control.Applicative
+import Data.Foldable
+import Data.Function
+import Data.List as S hiding (foldr)
+import Data.Traversable
+import Prelude hiding (foldr)
+
+newtype PSQ k v = PSQ [(k, v)]
+ deriving (Eq, Show)
+
+instance Functor (PSQ k) where
+ fmap f (PSQ xs) = PSQ (fmap (\ (k, v) -> (k, f v)) xs)
+
+instance Foldable (PSQ k) where
+ foldr op e (PSQ xs) = foldr op e (fmap snd xs)
+
+instance Traversable (PSQ k) where
+ traverse f (PSQ xs) = PSQ <$> traverse (\ (k, v) -> (\ x -> (k, x)) <$> f v) xs
+
+keys :: PSQ k v -> [k]
+keys (PSQ xs) = fmap fst xs
+
+lookup :: Eq k => k -> PSQ k v -> Maybe v
+lookup k (PSQ xs) = S.lookup k xs
+
+map :: (v1 -> v2) -> PSQ k v1 -> PSQ k v2
+map f (PSQ xs) = PSQ (fmap (\ (k, v) -> (k, f v)) xs)
+
+mapKeys :: (k1 -> k2) -> PSQ k1 v -> PSQ k2 v
+mapKeys f (PSQ xs) = PSQ (fmap (\ (k, v) -> (f k, v)) xs)
+
+mapWithKey :: (k -> a -> b) -> PSQ k a -> PSQ k b
+mapWithKey f (PSQ xs) = PSQ (fmap (\ (k, v) -> (k, f k v)) xs)
+
+mapWithKeyState :: (s -> k -> a -> (b, s)) -> PSQ k a -> s -> PSQ k b
+mapWithKeyState p (PSQ xs) s0 =
+ PSQ (foldr (\ (k, v) r s -> case p s k v of
+ (w, n) -> (k, w) : (r n))
+ (const []) xs s0)
+
+delete :: Eq k => k -> PSQ k a -> PSQ k a
+delete k (PSQ xs) = PSQ (snd (partition ((== k) . fst) xs))
+
+fromList :: [(k, a)] -> PSQ k a
+fromList = PSQ
+
+cons :: k -> a -> PSQ k a -> PSQ k a
+cons k x (PSQ xs) = PSQ ((k, x) : xs)
+
+snoc :: PSQ k a -> k -> a -> PSQ k a
+snoc (PSQ xs) k x = PSQ (xs ++ [(k, x)])
+
+casePSQ :: PSQ k a -> r -> (k -> a -> PSQ k a -> r) -> r
+casePSQ (PSQ xs) n c =
+ case xs of
+ [] -> n
+ (k, v) : ys -> c k v (PSQ ys)
+
+splits :: PSQ k a -> PSQ k (a, PSQ k a)
+splits xs =
+ casePSQ xs
+ (PSQ [])
+ (\ k v ys -> cons k (v, ys) (fmap (\ (w, zs) -> (w, cons k v zs)) (splits ys)))
+
+sortBy :: (a -> a -> Ordering) -> PSQ k a -> PSQ k a
+sortBy cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` snd) xs)
+
+sortByKeys :: (k -> k -> Ordering) -> PSQ k a -> PSQ k a
+sortByKeys cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` fst) xs)
+
+filterKeys :: (k -> Bool) -> PSQ k a -> PSQ k a
+filterKeys p (PSQ xs) = PSQ (S.filter (p . fst) xs)
+
+filter :: (a -> Bool) -> PSQ k a -> PSQ k a
+filter p (PSQ xs) = PSQ (S.filter (p . snd) xs)
+
+length :: PSQ k a -> Int
+length (PSQ xs) = S.length xs
+
+-- | "Lazy length".
+--
+-- Only approximates the length, but doesn't force the list.
+llength :: PSQ k a -> Int
+llength (PSQ []) = 0
+llength (PSQ (_:[])) = 1
+llength (PSQ (_:_:[])) = 2
+llength (PSQ _) = 3
+
+null :: PSQ k a -> Bool
+null (PSQ xs) = S.null xs
+
+toList :: PSQ k a -> [(k, a)]
+toList (PSQ xs) = xs
diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Modular/Package.hs b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Package.hs
new file mode 100644
index 0000000..caa58db
--- /dev/null
+++ b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Package.hs
@@ -0,0 +1,113 @@
+module Distribution.Client.Dependency.Modular.Package
+ (module Distribution.Client.Dependency.Modular.Package,
+ module Distribution.Package) where
+
+import Data.List as L
+import Data.Map as M
+
+import Distribution.Package -- from Cabal
+import Distribution.Text -- from Cabal
+
+import Distribution.Client.Dependency.Modular.Version
+
+-- | A package name.
+type PN = PackageName
+
+-- | Unpacking a package name.
+unPN :: PN -> String
+unPN (PackageName pn) = pn
+
+-- | Package version. A package name plus a version number.
+type PV = PackageId
+
+-- | Qualified package version.
+type QPV = Q PV
+
+-- | Package id. Currently just a black-box string.
+type PId = InstalledPackageId
+
+-- | Location. Info about whether a package is installed or not, and where
+-- exactly it is located. For installed packages, uniquely identifies the
+-- package instance via its 'PId'.
+--
+-- TODO: More information is needed about the repo.
+data Loc = Inst PId | InRepo
+ deriving (Eq, Ord, Show)
+
+-- | Instance. A version number and a location.
+data I = I Ver Loc
+ deriving (Eq, Ord, Show)
+
+-- | String representation of an instance.
+showI :: I -> String
+showI (I v InRepo) = showVer v
+showI (I v (Inst (InstalledPackageId i))) = showVer v ++ "/installed" ++ shortId i
+ where
+ -- A hack to extract the beginning of the package ABI hash
+ shortId = snip (splitAt 4) (++ "...") .
+ snip ((\ (x, y) -> (reverse x, y)) . break (=='-') . reverse) ('-':)
+ snip p f xs = case p xs of
+ (ys, zs) -> (if L.null zs then id else f) ys
+
+-- | Package instance. A package name and an instance.
+data PI qpn = PI qpn I
+ deriving (Eq, Ord, Show)
+
+-- | String representation of a package instance.
+showPI :: PI QPN -> String
+showPI (PI qpn i) = showQPN qpn ++ "-" ++ showI i
+
+-- | Checks if a package instance corresponds to an installed package.
+instPI :: PI qpn -> Bool
+instPI (PI _ (I _ (Inst _))) = True
+instPI _ = False
+
+instI :: I -> Bool
+instI (I _ (Inst _)) = True
+instI _ = False
+
+instance Functor PI where
+ fmap f (PI x y) = PI (f x) y
+
+-- | Package path. (Stored in "reverse" order.)
+type PP = [PN]
+
+-- | String representation of a package path.
+showPP :: PP -> String
+showPP = intercalate "." . L.map display . reverse
+
+
+-- | A qualified entity. Pairs a package path with the entity.
+data Q a = Q PP a
+ deriving (Eq, Ord, Show)
+
+-- | Standard string representation of a qualified entity.
+showQ :: (a -> String) -> (Q a -> String)
+showQ showa (Q [] x) = showa x
+showQ showa (Q pp x) = showPP pp ++ "." ++ showa x
+
+-- | Qualified package name.
+type QPN = Q PN
+
+-- | String representation of a qualified package path.
+showQPN :: QPN -> String
+showQPN = showQ display
+
+-- | The scope associates every package with a path. The convention is that packages
+-- not in the data structure have an empty path associated with them.
+type Scope = Map PN PP
+
+-- | An empty scope structure, for initialization.
+emptyScope :: Scope
+emptyScope = M.empty
+
+-- | Create artificial parents for each of the package names, making
+-- them all independent.
+makeIndependent :: [PN] -> Scope
+makeIndependent ps = L.foldl (\ sc (n, p) -> M.insert p [PackageName (show n)] sc) emptyScope (zip ([0..] :: [Int]) ps)
+
+qualify :: Scope -> PN -> QPN
+qualify sc pn = Q (findWithDefault [] pn sc) pn
+
+unQualify :: Q a -> a
+unQualify (Q _ x) = x
diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
new file mode 100644
index 0000000..8802098
--- /dev/null
+++ b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
@@ -0,0 +1,275 @@
+module Distribution.Client.Dependency.Modular.Preference where
+
+-- Reordering or pruning the tree in order to prefer or make certain choices.
+
+import qualified Data.List as L
+import qualified Data.Map as M
+import Data.Monoid
+import Data.Ord
+
+import Distribution.Client.Dependency.Types
+ ( PackageConstraint(..), PackagePreferences(..), InstalledPreference(..) )
+import Distribution.Client.Types
+ ( OptionalStanza(..) )
+
+import Distribution.Client.Dependency.Modular.Dependency
+import Distribution.Client.Dependency.Modular.Flag
+import Distribution.Client.Dependency.Modular.Package
+import Distribution.Client.Dependency.Modular.PSQ as P
+import Distribution.Client.Dependency.Modular.Tree
+import Distribution.Client.Dependency.Modular.Version
+
+-- | Generic abstraction for strategies that just rearrange the package order.
+-- Only packages that match the given predicate are reordered.
+packageOrderFor :: (PN -> Bool) -> (PN -> I -> I -> Ordering) -> Tree a -> Tree a
+packageOrderFor p cmp = trav go
+ where
+ go (PChoiceF v@(Q _ pn) r cs)
+ | p pn = PChoiceF v r (P.sortByKeys (flip (cmp pn)) cs)
+ | otherwise = PChoiceF v r cs
+ go x = x
+
+-- | Ordering that treats preferred versions as greater than non-preferred
+-- versions.
+preferredVersionsOrdering :: VR -> Ver -> Ver -> Ordering
+preferredVersionsOrdering vr v1 v2 =
+ compare (checkVR vr v1) (checkVR vr v2)
+
+-- | Traversal that tries to establish package preferences (not constraints).
+-- Works by reordering choice nodes.
+preferPackagePreferences :: (PN -> PackagePreferences) -> Tree a -> Tree a
+preferPackagePreferences pcs = packageOrderFor (const True) preference
+ where
+ preference pn i1@(I v1 _) i2@(I v2 _) =
+ let PackagePreferences vr ipref = pcs pn
+ in preferredVersionsOrdering vr v1 v2 `mappend` -- combines lexically
+ locationsOrdering ipref i1 i2
+
+ -- Note that we always rank installed before uninstalled, and later
+ -- versions before earlier, but we can change the priority of the
+ -- two orderings.
+ locationsOrdering PreferInstalled v1 v2 =
+ preferInstalledOrdering v1 v2 `mappend` preferLatestOrdering v1 v2
+ locationsOrdering PreferLatest v1 v2 =
+ preferLatestOrdering v1 v2 `mappend` preferInstalledOrdering v1 v2
+
+-- | Ordering that treats installed instances as greater than uninstalled ones.
+preferInstalledOrdering :: I -> I -> Ordering
+preferInstalledOrdering (I _ (Inst _)) (I _ (Inst _)) = EQ
+preferInstalledOrdering (I _ (Inst _)) _ = GT
+preferInstalledOrdering _ (I _ (Inst _)) = LT
+preferInstalledOrdering _ _ = EQ
+
+-- | Compare instances by their version numbers.
+preferLatestOrdering :: I -> I -> Ordering
+preferLatestOrdering (I v1 _) (I v2 _) = compare v1 v2
+
+-- | Helper function that tries to enforce a single package constraint on a
+-- given instance for a P-node. Translates the constraint into a
+-- tree-transformer that either leaves the subtree untouched, or replaces it
+-- with an appropriate failure node.
+processPackageConstraintP :: ConflictSet QPN -> I -> PackageConstraint -> Tree a -> Tree a
+processPackageConstraintP c (I v _) (PackageConstraintVersion _ vr) r
+ | checkVR vr v = r
+ | otherwise = Fail c (GlobalConstraintVersion vr)
+processPackageConstraintP c i (PackageConstraintInstalled _) r
+ | instI i = r
+ | otherwise = Fail c GlobalConstraintInstalled
+processPackageConstraintP c i (PackageConstraintSource _) r
+ | not (instI i) = r
+ | otherwise = Fail c GlobalConstraintSource
+processPackageConstraintP _ _ _ r = r
+
+-- | Helper function that tries to enforce a single package constraint on a
+-- given flag setting for an F-node. Translates the constraint into a
+-- tree-transformer that either leaves the subtree untouched, or replaces it
+-- with an appropriate failure node.
+processPackageConstraintF :: Flag -> ConflictSet QPN -> Bool -> PackageConstraint -> Tree a -> Tree a
+processPackageConstraintF f c b' (PackageConstraintFlags _ fa) r =
+ case L.lookup f fa of
+ Nothing -> r
+ Just b | b == b' -> r
+ | otherwise -> Fail c GlobalConstraintFlag
+processPackageConstraintF _ _ _ _ r = r
+
+-- | Helper function that tries to enforce a single package constraint on a
+-- given flag setting for an F-node. Translates the constraint into a
+-- tree-transformer that either leaves the subtree untouched, or replaces it
+-- with an appropriate failure node.
+processPackageConstraintS :: OptionalStanza -> ConflictSet QPN -> Bool -> PackageConstraint -> Tree a -> Tree a
+processPackageConstraintS s c b' (PackageConstraintStanzas _ ss) r =
+ if not b' && s `elem` ss then Fail c GlobalConstraintFlag
+ else r
+processPackageConstraintS _ _ _ _ r = r
+
+-- | Traversal that tries to establish various kinds of user constraints. Works
+-- by selectively disabling choices that have been ruled out by global user
+-- constraints.
+enforcePackageConstraints :: M.Map PN [PackageConstraint] -> Tree QGoalReasons -> Tree QGoalReasons
+enforcePackageConstraints pcs = trav go
+ where
+ go (PChoiceF qpn@(Q _ pn) gr ts) =
+ let c = toConflictSet (Goal (P qpn) gr)
+ -- compose the transformation functions for each of the relevant constraint
+ g = \ i -> foldl (\ h pc -> h . processPackageConstraintP c i pc) id
+ (M.findWithDefault [] pn pcs)
+ in PChoiceF qpn gr (P.mapWithKey g ts)
+ go (FChoiceF qfn@(FN (PI (Q _ pn) _) f) gr tr m ts) =
+ let c = toConflictSet (Goal (F qfn) gr)
+ -- compose the transformation functions for each of the relevant constraint
+ g = \ b -> foldl (\ h pc -> h . processPackageConstraintF f c b pc) id
+ (M.findWithDefault [] pn pcs)
+ in FChoiceF qfn gr tr m (P.mapWithKey g ts)
+ go (SChoiceF qsn@(SN (PI (Q _ pn) _) f) gr tr ts) =
+ let c = toConflictSet (Goal (S qsn) gr)
+ -- compose the transformation functions for each of the relevant constraint
+ g = \ b -> foldl (\ h pc -> h . processPackageConstraintS f c b pc) id
+ (M.findWithDefault [] pn pcs)
+ in SChoiceF qsn gr tr (P.mapWithKey g ts)
+ go x = x
+
+-- | Transformation that tries to enforce manual flags. Manual flags
+-- can only be re-set explicitly by the user. This transformation should
+-- be run after user preferences have been enforced. For manual flags,
+-- it disables all but the first non-disabled choice.
+enforceManualFlags :: Tree QGoalReasons -> Tree QGoalReasons
+enforceManualFlags = trav go
+ where
+ go (FChoiceF qfn gr tr True ts) = FChoiceF qfn gr tr True $
+ let c = toConflictSet (Goal (F qfn) gr)
+ in case span isDisabled (P.toList ts) of
+ (_ , []) -> P.fromList []
+ (xs, y : ys) -> P.fromList (xs ++ y : L.map (\ (b, _) -> (b, Fail c ManualFlag)) ys)
+ where
+ isDisabled (_, Fail _ _) = True
+ isDisabled _ = False
+ go x = x
+
+-- | Prefer installed packages over non-installed packages, generally.
+-- All installed packages or non-installed packages are treated as
+-- equivalent.
+preferInstalled :: Tree a -> Tree a
+preferInstalled = packageOrderFor (const True) (const preferInstalledOrdering)
+
+-- | Prefer packages with higher version numbers over packages with
+-- lower version numbers, for certain packages.
+preferLatestFor :: (PN -> Bool) -> Tree a -> Tree a
+preferLatestFor p = packageOrderFor p (const preferLatestOrdering)
+
+-- | Prefer packages with higher version numbers over packages with
+-- lower version numbers, for all packages.
+preferLatest :: Tree a -> Tree a
+preferLatest = preferLatestFor (const True)
+
+-- | Require installed packages.
+requireInstalled :: (PN -> Bool) -> Tree (QGoalReasons, a) -> Tree (QGoalReasons, a)
+requireInstalled p = trav go
+ where
+ go (PChoiceF v@(Q _ pn) i@(gr, _) cs)
+ | p pn = PChoiceF v i (P.mapWithKey installed cs)
+ | otherwise = PChoiceF v i cs
+ where
+ installed (I _ (Inst _)) x = x
+ installed _ _ = Fail (toConflictSet (Goal (P v) gr)) CannotInstall
+ go x = x
+
+-- | Avoid reinstalls.
+--
+-- This is a tricky strategy. If a package version is installed already and the
+-- same version is available from a repo, the repo version will never be chosen.
+-- This would result in a reinstall (either destructively, or potentially,
+-- shadowing). The old instance won't be visible or even present anymore, but
+-- other packages might have depended on it.
+--
+-- TODO: It would be better to actually check the reverse dependencies of installed
+-- packages. If they're not depended on, then reinstalling should be fine. Even if
+-- they are, perhaps this should just result in trying to reinstall those other
+-- packages as well. However, doing this all neatly in one pass would require to
+-- change the builder, or at least to change the goal set after building.
+avoidReinstalls :: (PN -> Bool) -> Tree (QGoalReasons, a) -> Tree (QGoalReasons, a)
+avoidReinstalls p = trav go
+ where
+ go (PChoiceF qpn@(Q _ pn) i@(gr, _) cs)
+ | p pn = PChoiceF qpn i disableReinstalls
+ | otherwise = PChoiceF qpn i cs
+ where
+ disableReinstalls =
+ let installed = [ v | (I v (Inst _), _) <- toList cs ]
+ in P.mapWithKey (notReinstall installed) cs
+
+ notReinstall vs (I v InRepo) _
+ | v `elem` vs = Fail (toConflictSet (Goal (P qpn) gr)) CannotReinstall
+ notReinstall _ _ x = x
+ go x = x
+
+-- | Always choose the first goal in the list next, abandoning all
+-- other choices.
+--
+-- This is unnecessary for the default search strategy, because
+-- it descends only into the first goal choice anyway,
+-- but may still make sense to just reduce the tree size a bit.
+firstGoal :: Tree a -> Tree a
+firstGoal = trav go
+ where
+ go (GoalChoiceF xs) = casePSQ xs (GoalChoiceF xs) (\ _ t _ -> out t)
+ go x = x
+ -- Note that we keep empty choice nodes, because they mean success.
+
+-- | Transformation that tries to make a decision on base as early as
+-- possible. In nearly all cases, there's a single choice for the base
+-- package. Also, fixing base early should lead to better error messages.
+preferBaseGoalChoice :: Tree a -> Tree a
+preferBaseGoalChoice = trav go
+ where
+ go (GoalChoiceF xs) = GoalChoiceF (P.sortByKeys preferBase xs)
+ go x = x
+
+ preferBase :: OpenGoal -> OpenGoal -> Ordering
+ preferBase (OpenGoal (Simple (Dep (Q [] pn) _)) _) _ | unPN pn == "base" = LT
+ preferBase _ (OpenGoal (Simple (Dep (Q [] pn) _)) _) | unPN pn == "base" = GT
+ preferBase _ _ = EQ
+
+-- | Transformation that sorts choice nodes so that
+-- child nodes with a small branching degree are preferred. As a
+-- special case, choices with 0 branches will be preferred (as they
+-- are immediately considered inconsistent), and choices with 1
+-- branch will also be preferred (as they don't involve choice).
+preferEasyGoalChoices :: Tree a -> Tree a
+preferEasyGoalChoices = trav go
+ where
+ go (GoalChoiceF xs) = GoalChoiceF (P.sortBy (comparing choices) xs)
+ go x = x
+
+-- | Transformation that tries to avoid making inconsequential
+-- flag choices early.
+deferDefaultFlagChoices :: Tree a -> Tree a
+deferDefaultFlagChoices = trav go
+ where
+ go (GoalChoiceF xs) = GoalChoiceF (P.sortBy defer xs)
+ go x = x
+
+ defer :: Tree a -> Tree a -> Ordering
+ defer (FChoice _ _ True _ _) _ = GT
+ defer _ (FChoice _ _ True _ _) = LT
+ defer _ _ = EQ
+
+-- | Variant of 'preferEasyGoalChoices'.
+--
+-- Only approximates the number of choices in the branches. Less accurate,
+-- more efficient.
+lpreferEasyGoalChoices :: Tree a -> Tree a
+lpreferEasyGoalChoices = trav go
+ where
+ go (GoalChoiceF xs) = GoalChoiceF (P.sortBy (comparing lchoices) xs)
+ go x = x
+
+-- | Variant of 'preferEasyGoalChoices'.
+--
+-- I first thought that using a paramorphism might be faster here,
+-- but it doesn't seem to make any difference.
+preferEasyGoalChoices' :: Tree a -> Tree a
+preferEasyGoalChoices' = para (inn . go)
+ where
+ go (GoalChoiceF xs) = GoalChoiceF (P.map fst (P.sortBy (comparing (choices . snd)) xs))
+ go x = fmap fst x
+
diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs
new file mode 100644
index 0000000..b1cb0e9
--- /dev/null
+++ b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs
@@ -0,0 +1,54 @@
+module Distribution.Client.Dependency.Modular.Solver where
+
+import Data.Map as M
+
+import Distribution.Client.Dependency.Types
+
+import Distribution.Client.Dependency.Modular.Assignment
+import Distribution.Client.Dependency.Modular.Builder
+import Distribution.Client.Dependency.Modular.Dependency
+import Distribution.Client.Dependency.Modular.Explore
+import Distribution.Client.Dependency.Modular.Index
+import Distribution.Client.Dependency.Modular.Log
+import Distribution.Client.Dependency.Modular.Message
+import Distribution.Client.Dependency.Modular.Package
+import qualified Distribution.Client.Dependency.Modular.Preference as P
+import Distribution.Client.Dependency.Modular.Validate
+
+-- | Various options for the modular solver.
+data SolverConfig = SolverConfig {
+ preferEasyGoalChoices :: Bool,
+ independentGoals :: Bool,
+ avoidReinstalls :: Bool,
+ shadowPkgs :: Bool,
+ maxBackjumps :: Maybe Int
+}
+
+solve :: SolverConfig -> -- solver parameters
+ Index -> -- all available packages as an index
+ (PN -> PackagePreferences) -> -- preferences
+ Map PN [PackageConstraint] -> -- global constraints
+ [PN] -> -- global goals
+ Log Message (Assignment, RevDepMap)
+solve sc idx userPrefs userConstraints userGoals =
+ explorePhase $
+ heuristicsPhase $
+ preferencesPhase $
+ validationPhase $
+ prunePhase $
+ buildPhase
+ where
+ explorePhase = exploreTreeLog . backjump
+ heuristicsPhase = P.firstGoal . -- after doing goal-choice heuristics, commit to the first choice (saves space)
+ if preferEasyGoalChoices sc
+ then P.preferBaseGoalChoice . P.deferDefaultFlagChoices . P.lpreferEasyGoalChoices
+ else P.preferBaseGoalChoice
+ preferencesPhase = P.preferPackagePreferences userPrefs
+ validationPhase = P.enforceManualFlags . -- can only be done after user constraints
+ P.enforcePackageConstraints userConstraints .
+ validateTree idx
+ prunePhase = (if avoidReinstalls sc then P.avoidReinstalls (const True) else id) .
+ -- packages that can never be "upgraded":
+ P.requireInstalled (`elem` [PackageName "base",
+ PackageName "ghc-prim"])
+ buildPhase = buildTree idx (independentGoals sc) userGoals
diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs
new file mode 100644
index 0000000..dd250fc
--- /dev/null
+++ b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs
@@ -0,0 +1,147 @@
+module Distribution.Client.Dependency.Modular.Tree where
+
+import Control.Applicative
+import Control.Monad hiding (mapM)
+import Data.Foldable
+import Data.Traversable
+import Prelude hiding (foldr, mapM)
+
+import Distribution.Client.Dependency.Modular.Dependency
+import Distribution.Client.Dependency.Modular.Flag
+import Distribution.Client.Dependency.Modular.Package
+import Distribution.Client.Dependency.Modular.PSQ as P
+import Distribution.Client.Dependency.Modular.Version
+
+-- | Type of the search tree. Inlining the choice nodes for now.
+data Tree a =
+ PChoice QPN a (PSQ I (Tree a))
+ | FChoice QFN a Bool Bool (PSQ Bool (Tree a)) -- Bool indicates whether it's trivial, second Bool whether it's manual
+ | SChoice QSN a Bool (PSQ Bool (Tree a)) -- Bool indicates whether it's trivial
+ | GoalChoice (PSQ OpenGoal (Tree a)) -- PSQ should never be empty
+ | Done RevDepMap
+ | Fail (ConflictSet QPN) FailReason
+ deriving (Eq, Show)
+ -- Above, a choice is called trivial if it clearly does not matter. The
+ -- special case of triviality we actually consider is if there are no new
+ -- dependencies introduced by this node.
+
+instance Functor Tree where
+ fmap f (PChoice qpn i xs) = PChoice qpn (f i) (fmap (fmap f) xs)
+ fmap f (FChoice qfn i b m xs) = FChoice qfn (f i) b m (fmap (fmap f) xs)
+ fmap f (SChoice qsn i b xs) = SChoice qsn (f i) b (fmap (fmap f) xs)
+ fmap f (GoalChoice xs) = GoalChoice (fmap (fmap f) xs)
+ fmap _f (Done rdm ) = Done rdm
+ fmap _f (Fail cs fr ) = Fail cs fr
+
+data FailReason = InconsistentInitialConstraints
+ | Conflicting [Dep QPN]
+ | CannotInstall
+ | CannotReinstall
+ | Shadowed
+ | Broken
+ | GlobalConstraintVersion VR
+ | GlobalConstraintInstalled
+ | GlobalConstraintSource
+ | GlobalConstraintFlag
+ | ManualFlag
+ | BuildFailureNotInIndex PN
+ | MalformedFlagChoice QFN
+ | MalformedStanzaChoice QSN
+ | EmptyGoalChoice
+ | Backjump
+ deriving (Eq, Show)
+
+-- | Functor for the tree type.
+data TreeF a b =
+ PChoiceF QPN a (PSQ I b)
+ | FChoiceF QFN a Bool Bool (PSQ Bool b)
+ | SChoiceF QSN a Bool (PSQ Bool b)
+ | GoalChoiceF (PSQ OpenGoal b)
+ | DoneF RevDepMap
+ | FailF (ConflictSet QPN) FailReason
+
+out :: Tree a -> TreeF a (Tree a)
+out (PChoice p i ts) = PChoiceF p i ts
+out (FChoice p i b m ts) = FChoiceF p i b m ts
+out (SChoice p i b ts) = SChoiceF p i b ts
+out (GoalChoice ts) = GoalChoiceF ts
+out (Done x ) = DoneF x
+out (Fail c x ) = FailF c x
+
+inn :: TreeF a (Tree a) -> Tree a
+inn (PChoiceF p i ts) = PChoice p i ts
+inn (FChoiceF p i b m ts) = FChoice p i b m ts
+inn (SChoiceF p i b ts) = SChoice p i b ts
+inn (GoalChoiceF ts) = GoalChoice ts
+inn (DoneF x ) = Done x
+inn (FailF c x ) = Fail c x
+
+instance Functor (TreeF a) where
+ fmap f (PChoiceF p i ts) = PChoiceF p i (fmap f ts)
+ fmap f (FChoiceF p i b m ts) = FChoiceF p i b m (fmap f ts)
+ fmap f (SChoiceF p i b ts) = SChoiceF p i b (fmap f ts)
+ fmap f (GoalChoiceF ts) = GoalChoiceF (fmap f ts)
+ fmap _ (DoneF x ) = DoneF x
+ fmap _ (FailF c x ) = FailF c x
+
+instance Foldable (TreeF a) where
+ foldr op e (PChoiceF _ _ ts) = foldr op e ts
+ foldr op e (FChoiceF _ _ _ _ ts) = foldr op e ts
+ foldr op e (SChoiceF _ _ _ ts) = foldr op e ts
+ foldr op e (GoalChoiceF ts) = foldr op e ts
+ foldr _ e (DoneF _ ) = e
+ foldr _ e (FailF _ _ ) = e
+
+instance Traversable (TreeF a) where
+ traverse f (PChoiceF p i ts) = PChoiceF <$> pure p <*> pure i <*> traverse f ts
+ traverse f (FChoiceF p i b m ts) = FChoiceF <$> pure p <*> pure i <*> pure b <*> pure m <*> traverse f ts
+ traverse f (SChoiceF p i b ts) = SChoiceF <$> pure p <*> pure i <*> pure b <*> traverse f ts
+ traverse f (GoalChoiceF ts) = GoalChoiceF <$> traverse f ts
+ traverse _ (DoneF x ) = DoneF <$> pure x
+ traverse _ (FailF c x ) = FailF <$> pure c <*> pure x
+
+-- | Determines whether a tree is active, i.e., isn't a failure node.
+active :: Tree a -> Bool
+active (Fail _ _) = False
+active _ = True
+
+-- | Determines how many active choices are available in a node. Note that we
+-- count goal choices as having one choice, always.
+choices :: Tree a -> Int
+choices (PChoice _ _ ts) = P.length (P.filter active ts)
+choices (FChoice _ _ _ _ ts) = P.length (P.filter active ts)
+choices (SChoice _ _ _ ts) = P.length (P.filter active ts)
+choices (GoalChoice _ ) = 1
+choices (Done _ ) = 1
+choices (Fail _ _ ) = 0
+
+-- | Variant of 'choices' that only approximates the number of choices,
+-- using 'llength'.
+lchoices :: Tree a -> Int
+lchoices (PChoice _ _ ts) = P.llength (P.filter active ts)
+lchoices (FChoice _ _ _ _ ts) = P.llength (P.filter active ts)
+lchoices (SChoice _ _ _ ts) = P.llength (P.filter active ts)
+lchoices (GoalChoice _ ) = 1
+lchoices (Done _ ) = 1
+lchoices (Fail _ _ ) = 0
+
+-- | Catamorphism on trees.
+cata :: (TreeF a b -> b) -> Tree a -> b
+cata phi x = (phi . fmap (cata phi) . out) x
+
+trav :: (TreeF a (Tree b) -> TreeF b (Tree b)) -> Tree a -> Tree b
+trav psi x = cata (inn . psi) x
+
+-- | Paramorphism on trees.
+para :: (TreeF a (b, Tree a) -> b) -> Tree a -> b
+para phi = phi . fmap (\ x -> (para phi x, x)) . out
+
+cataM :: Monad m => (TreeF a b -> m b) -> Tree a -> m b
+cataM phi = phi <=< mapM (cataM phi) <=< return . out
+
+-- | Anamorphism on trees.
+ana :: (b -> TreeF a b) -> b -> Tree a
+ana psi = inn . fmap (ana psi) . psi
+
+anaM :: Monad m => (b -> m (TreeF a b)) -> b -> m (Tree a)
+anaM psi = return . inn <=< mapM (anaM psi) <=< psi
diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs
new file mode 100644
index 0000000..4cb6c0c
--- /dev/null
+++ b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs
@@ -0,0 +1,232 @@
+module Distribution.Client.Dependency.Modular.Validate where
+
+-- Validation of the tree.
+--
+-- The task here is to make sure all constraints hold. After validation, any
+-- assignment returned by exploration of the tree should be a complete valid
+-- assignment, i.e., actually constitute a solution.
+
+import Control.Applicative
+import Control.Monad.Reader hiding (sequence)
+import Data.List as L
+import Data.Map as M
+import Data.Traversable
+import Prelude hiding (sequence)
+
+import Distribution.Client.Dependency.Modular.Assignment
+import Distribution.Client.Dependency.Modular.Dependency
+import Distribution.Client.Dependency.Modular.Flag
+import Distribution.Client.Dependency.Modular.Index
+import Distribution.Client.Dependency.Modular.Package
+import Distribution.Client.Dependency.Modular.PSQ as P
+import Distribution.Client.Dependency.Modular.Tree
+
+-- In practice, most constraints are implication constraints (IF we have made
+-- a number of choices, THEN we also have to ensure that). We call constraints
+-- that for which the precondiditions are fulfilled ACTIVE. We maintain a set
+-- of currently active constraints that we pass down the node.
+--
+-- We aim at detecting inconsistent states as early as possible.
+--
+-- Whenever we make a choice, there are two things that need to happen:
+--
+-- (1) We must check that the choice is consistent with the currently
+-- active constraints.
+--
+-- (2) The choice increases the set of active constraints. For the new
+-- active constraints, we must check that they are consistent with
+-- the current state.
+--
+-- We can actually merge (1) and (2) by saying the the current choice is
+-- a new active constraint, fixing the choice.
+--
+-- If a test fails, we have detected an inconsistent state. We can
+-- disable the current subtree and do not have to traverse it any further.
+--
+-- We need a good way to represent the current state, i.e., the current
+-- set of active constraints. Since the main situation where we have to
+-- search in it is (1), it seems best to store the state by package: for
+-- every package, we store which versions are still allowed. If for any
+-- package, we have inconsistent active constraints, we can also stop.
+-- This is a particular way to read task (2):
+--
+-- (2, weak) We only check if the new constraints are consistent with
+-- the choices we've already made, and add them to the active set.
+--
+-- (2, strong) We check if the new constraints are consistent with the
+-- choices we've already made, and the constraints we already have.
+--
+-- It currently seems as if we're implementing the weak variant. However,
+-- when used together with 'preferEasyGoalChoices', we will find an
+-- inconsistent state in the very next step.
+--
+-- What do we do about flags?
+--
+-- Like for packages, we store the flag choices we have already made.
+-- Now, regarding (1), we only have to test whether we've decided the
+-- current flag before. Regarding (2), the interesting bit is in discovering
+-- the new active constraints. To this end, we look up the constraints for
+-- the package the flag belongs to, and traverse its flagged dependencies.
+-- Wherever we find the flag in question, we start recording dependencies
+-- underneath as new active dependencies. If we encounter other flags, we
+-- check if we've chosen them already and either proceed or stop.
+
+-- | The state needed during validation.
+data ValidateState = VS {
+ index :: Index,
+ saved :: Map QPN (FlaggedDeps QPN), -- saved, scoped, dependencies
+ pa :: PreAssignment
+}
+
+type Validate = Reader ValidateState
+
+validate :: Tree (QGoalReasons, Scope) -> Validate (Tree QGoalReasons)
+validate = cata go
+ where
+ go :: TreeF (QGoalReasons, Scope) (Validate (Tree QGoalReasons)) -> Validate (Tree QGoalReasons)
+
+ go (PChoiceF qpn (gr, sc) ts) = PChoice qpn gr <$> sequence (P.mapWithKey (goP qpn gr sc) ts)
+ go (FChoiceF qfn (gr, _sc) b m ts) =
+ do
+ -- Flag choices may occur repeatedly (because they can introduce new constraints
+ -- in various places). However, subsequent choices must be consistent. We thereby
+ -- collapse repeated flag choice nodes.
+ PA _ pfa _ <- asks pa -- obtain current flag-preassignment
+ case M.lookup qfn pfa of
+ Just rb -> -- flag has already been assigned; collapse choice to the correct branch
+ case P.lookup rb ts of
+ Just t -> goF qfn gr rb t
+ Nothing -> return $ Fail (toConflictSet (Goal (F qfn) gr)) (MalformedFlagChoice qfn)
+ Nothing -> -- flag choice is new, follow both branches
+ FChoice qfn gr b m <$> sequence (P.mapWithKey (goF qfn gr) ts)
+ go (SChoiceF qsn (gr, _sc) b ts) =
+ do
+ -- Optional stanza choices are very similar to flag choices.
+ PA _ _ psa <- asks pa -- obtain current stanza-preassignment
+ case M.lookup qsn psa of
+ Just rb -> -- stanza choice has already been made; collapse choice to the correct branch
+ case P.lookup rb ts of
+ Just t -> goS qsn gr rb t
+ Nothing -> return $ Fail (toConflictSet (Goal (S qsn) gr)) (MalformedStanzaChoice qsn)
+ Nothing -> -- stanza choice is new, follow both branches
+ SChoice qsn gr b <$> sequence (P.mapWithKey (goS qsn gr) ts)
+
+ -- We don't need to do anything for goal choices or failure nodes.
+ go (GoalChoiceF ts) = GoalChoice <$> sequence ts
+ go (DoneF rdm ) = pure (Done rdm)
+ go (FailF c fr ) = pure (Fail c fr)
+
+ -- What to do for package nodes ...
+ goP :: QPN -> QGoalReasons -> Scope -> I -> Validate (Tree QGoalReasons) -> Validate (Tree QGoalReasons)
+ goP qpn@(Q _pp pn) gr sc i r = do
+ PA ppa pfa psa <- asks pa -- obtain current preassignment
+ idx <- asks index -- obtain the index
+ svd <- asks saved -- obtain saved dependencies
+ let (PInfo deps _ _ mfr) = idx ! pn ! i -- obtain dependencies and index-dictated exclusions introduced by the choice
+ let qdeps = L.map (fmap (qualify sc)) deps -- qualify the deps in the current scope
+ -- the new active constraints are given by the instance we have chosen,
+ -- plus the dependency information we have for that instance
+ let goal = Goal (P qpn) gr
+ let newactives = Dep qpn (Fixed i goal) : L.map (resetGoal goal) (extractDeps pfa psa qdeps)
+ -- We now try to extend the partial assignment with the new active constraints.
+ let mnppa = extend (P qpn) ppa newactives
+ -- In case we continue, we save the scoped dependencies
+ let nsvd = M.insert qpn qdeps svd
+ case mfr of
+ Just fr -> -- The index marks this as an invalid choice. We can stop.
+ return (Fail (toConflictSet goal) fr)
+ _ -> case mnppa of
+ Left (c, d) -> -- We have an inconsistency. We can stop.
+ return (Fail c (Conflicting d))
+ Right nppa -> -- We have an updated partial assignment for the recursive validation.
+ local (\ s -> s { pa = PA nppa pfa psa, saved = nsvd }) r
+
+ -- What to do for flag nodes ...
+ goF :: QFN -> QGoalReasons -> Bool -> Validate (Tree QGoalReasons) -> Validate (Tree QGoalReasons)
+ goF qfn@(FN (PI qpn _i) _f) gr b r = do
+ PA ppa pfa psa <- asks pa -- obtain current preassignment
+ svd <- asks saved -- obtain saved dependencies
+ -- Note that there should be saved dependencies for the package in question,
+ -- because while building, we do not choose flags before we see the packages
+ -- that define them.
+ let qdeps = svd ! qpn
+ -- We take the *saved* dependencies, because these have been qualified in the
+ -- correct scope.
+ --
+ -- Extend the flag assignment
+ let npfa = M.insert qfn b pfa
+ -- We now try to get the new active dependencies we might learn about because
+ -- we have chosen a new flag.
+ let newactives = extractNewDeps (F qfn) gr b npfa psa qdeps
+ -- As in the package case, we try to extend the partial assignment.
+ case extend (F qfn) ppa newactives of
+ Left (c, d) -> return (Fail c (Conflicting d)) -- inconsistency found
+ Right nppa -> local (\ s -> s { pa = PA nppa npfa psa }) r
+
+ -- What to do for stanza nodes (similar to flag nodes) ...
+ goS :: QSN -> QGoalReasons -> Bool -> Validate (Tree QGoalReasons) -> Validate (Tree QGoalReasons)
+ goS qsn@(SN (PI qpn _i) _f) gr b r = do
+ PA ppa pfa psa <- asks pa -- obtain current preassignment
+ svd <- asks saved -- obtain saved dependencies
+ -- Note that there should be saved dependencies for the package in question,
+ -- because while building, we do not choose flags before we see the packages
+ -- that define them.
+ let qdeps = svd ! qpn
+ -- We take the *saved* dependencies, because these have been qualified in the
+ -- correct scope.
+ --
+ -- Extend the flag assignment
+ let npsa = M.insert qsn b psa
+ -- We now try to get the new active dependencies we might learn about because
+ -- we have chosen a new flag.
+ let newactives = extractNewDeps (S qsn) gr b pfa npsa qdeps
+ -- As in the package case, we try to extend the partial assignment.
+ case extend (S qsn) ppa newactives of
+ Left (c, d) -> return (Fail c (Conflicting d)) -- inconsistency found
+ Right nppa -> local (\ s -> s { pa = PA nppa pfa npsa }) r
+
+-- | We try to extract as many concrete dependencies from the given flagged
+-- dependencies as possible. We make use of all the flag knowledge we have
+-- already acquired.
+extractDeps :: FAssignment -> SAssignment -> FlaggedDeps QPN -> [Dep QPN]
+extractDeps fa sa deps = do
+ d <- deps
+ case d of
+ Simple sd -> return sd
+ Flagged qfn _ td fd -> case M.lookup qfn fa of
+ Nothing -> mzero
+ Just True -> extractDeps fa sa td
+ Just False -> extractDeps fa sa fd
+ Stanza qsn td -> case M.lookup qsn sa of
+ Nothing -> mzero
+ Just True -> extractDeps fa sa td
+ Just False -> []
+
+-- | We try to find new dependencies that become available due to the given
+-- flag or stanza choice. We therefore look for the choice in question, and then call
+-- 'extractDeps' for everything underneath.
+extractNewDeps :: Var QPN -> QGoalReasons -> Bool -> FAssignment -> SAssignment -> FlaggedDeps QPN -> [Dep QPN]
+extractNewDeps v gr b fa sa = go
+ where
+ go deps = do
+ d <- deps
+ case d of
+ Simple _ -> mzero
+ Flagged qfn' _ td fd
+ | v == F qfn' -> L.map (resetGoal (Goal v gr)) $
+ if b then extractDeps fa sa td else extractDeps fa sa fd
+ | otherwise -> case M.lookup qfn' fa of
+ Nothing -> mzero
+ Just True -> go td
+ Just False -> go fd
+ Stanza qsn' td
+ | v == S qsn' -> L.map (resetGoal (Goal v gr)) $
+ if b then extractDeps fa sa td else []
+ | otherwise -> case M.lookup qsn' sa of
+ Nothing -> mzero
+ Just True -> go td
+ Just False -> []
+
+-- | Interface.
+validateTree :: Index -> Tree (QGoalReasons, Scope) -> Tree QGoalReasons
+validateTree idx t = runReader (validate t) (VS idx M.empty (PA M.empty M.empty M.empty))
diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Modular/Version.hs b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Version.hs
new file mode 100644
index 0000000..231c34c
--- /dev/null
+++ b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Version.hs
@@ -0,0 +1,43 @@
+module Distribution.Client.Dependency.Modular.Version where
+
+import qualified Distribution.Version as CV -- from Cabal
+import Distribution.Text -- from Cabal
+
+-- | Preliminary type for versions.
+type Ver = CV.Version
+
+-- | String representation of a version.
+showVer :: Ver -> String
+showVer = display
+
+-- | Version range. Consists of a lower and upper bound.
+type VR = CV.VersionRange
+
+-- | String representation of a version range.
+showVR :: VR -> String
+showVR = display
+
+-- | Unconstrained version range.
+anyVR :: VR
+anyVR = CV.anyVersion
+
+-- | Version range fixing a single version.
+eqVR :: Ver -> VR
+eqVR = CV.thisVersion
+
+-- | Intersect two version ranges.
+(.&&.) :: VR -> VR -> VR
+(.&&.) = CV.intersectVersionRanges
+
+-- | Simplify a version range.
+simplifyVR :: VR -> VR
+simplifyVR = CV.simplifyVersionRange
+
+-- | Checking a version against a version range.
+checkVR :: VR -> Ver -> Bool
+checkVR = flip CV.withinRange
+
+-- | Make a version number.
+mkV :: [Int] -> Ver
+mkV xs = CV.Version xs []
+
diff --git a/cabal/cabal-install/Distribution/Client/Dependency/TopDown.hs b/cabal/cabal-install/Distribution/Client/Dependency/TopDown.hs
index e51d6e8..fea86fb 100644
--- a/cabal/cabal-install/Distribution/Client/Dependency/TopDown.hs
+++ b/cabal/cabal-install/Distribution/Client/Dependency/TopDown.hs
@@ -18,11 +18,14 @@ import Distribution.Client.Dependency.TopDown.Types
import qualified Distribution.Client.Dependency.TopDown.Constraints as Constraints
import Distribution.Client.Dependency.TopDown.Constraints
( Satisfiable(..) )
+import Distribution.Client.IndexUtils
+ ( convert )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.InstallPlan
( PlanPackage(..) )
import Distribution.Client.Types
- ( SourcePackage(..), ConfiguredPackage(..), InstalledPackage(..) )
+ ( SourcePackage(..), ConfiguredPackage(..), InstalledPackage(..)
+ , enableStanzas )
import Distribution.Client.Dependency.Types
( DependencyResolver, PackageConstraint(..)
, PackagePreferences(..), InstalledPreference(..)
@@ -106,8 +109,8 @@ explore pref (ChoiceNode _ choices) =
where
topSortNumber choice = case fst (head choice) of
InstalledOnly (InstalledPackageEx _ i _) -> i
- SourceOnly (UnconfiguredPackage _ i _) -> i
- InstalledAndSource _ (UnconfiguredPackage _ i _) -> i
+ SourceOnly (UnconfiguredPackage _ i _ _) -> i
+ InstalledAndSource _ (UnconfiguredPackage _ i _ _) -> i
bestByPref pkgname = case packageInstalledPreference of
PreferLatest ->
@@ -195,7 +198,7 @@ packageConstraints = either installedConstraints availableConstraints
installedConstraints (InstalledPackageEx _ _ deps) =
[ (thisPackageVersion dep, True)
| dep <- deps ]
- availableConstraints (SemiConfiguredPackage _ _ deps) =
+ availableConstraints (SemiConfiguredPackage _ _ _ deps) =
[ (dep, False) | dep <- deps ]
addDeps :: Constraints -> [PackageName] -> Constraints
@@ -239,7 +242,11 @@ search configure pref constraints =
-- the standard 'DependencyResolver' interface.
--
topDownResolver :: DependencyResolver
-topDownResolver = ((((((mapMessages .).).).).).) . topDownResolver'
+topDownResolver platform comp installedPkgIndex sourcePkgIndex
+ preferences constraints targets =
+ mapMessages (topDownResolver' platform comp
+ (convert installedPkgIndex) sourcePkgIndex
+ preferences constraints targets)
where
mapMessages :: Progress Log Failure a -> Progress String String a
mapMessages = foldProgress (Step . showLog) (Fail . showFailure) Done
@@ -333,6 +340,9 @@ addTopLevelConstraints (PackageConstraintSource pkg:deps) cs =
ConflictsWith conflicts ->
Fail (TopLevelInstallConstraintConflict pkg SourceConstraint conflicts)
+addTopLevelConstraints (PackageConstraintStanzas _ _ : deps) cs =
+ addTopLevelConstraints deps cs
+
-- | Add exclusion on available packages that cannot be configured.
--
pruneBottomUp :: Platform -> CompilerId
@@ -358,9 +368,9 @@ pruneBottomUp platform comp constraints =
[ (dep, Constraints.conflicting cs dep)
| dep <- missing ]
- configure cs (UnconfiguredPackage (SourcePackage _ pkg _) _ flags) =
+ configure cs (UnconfiguredPackage (SourcePackage _ pkg _) _ flags stanzas) =
finalizePackageDescription flags (dependencySatisfiable cs)
- platform comp [] pkg
+ platform comp [] (enableStanzas stanzas pkg)
dependencySatisfiable cs =
not . null . PackageIndex.lookupDependency (Constraints.choices cs)
@@ -372,8 +382,8 @@ pruneBottomUp platform comp constraints =
. Constraints.choices
topSortNumber (InstalledOnly (InstalledPackageEx _ i _)) = i
- topSortNumber (SourceOnly (UnconfiguredPackage _ i _)) = i
- topSortNumber (InstalledAndSource _ (UnconfiguredPackage _ i _)) = i
+ topSortNumber (SourceOnly (UnconfiguredPackage _ i _ _)) = i
+ topSortNumber (InstalledAndSource _ (UnconfiguredPackage _ i _ _)) = i
getSourcePkg (InstalledOnly _ ) = Nothing
getSourcePkg (SourceOnly spkg) = Just spkg
@@ -387,12 +397,12 @@ configurePackage platform comp available spkg = case spkg of
InstalledAndSource ipkg apkg -> fmap (InstalledAndSource ipkg)
(configure apkg)
where
- configure (UnconfiguredPackage apkg@(SourcePackage _ p _) _ flags) =
+ configure (UnconfiguredPackage apkg@(SourcePackage _ p _) _ flags stanzas) =
case finalizePackageDescription flags dependencySatisfiable
- platform comp [] p of
+ platform comp [] (enableStanzas stanzas p) of
Left missing -> Left missing
Right (pkg, flags') -> Right $
- SemiConfiguredPackage apkg flags' (externalBuildDepends pkg)
+ SemiConfiguredPackage apkg flags' stanzas (externalBuildDepends pkg)
dependencySatisfiable = not . null . PackageIndex.lookupDependency available
@@ -421,7 +431,7 @@ annotateSourcePackages :: [PackageConstraint]
-> PackageIndex UnconfiguredPackage
annotateSourcePackages constraints dfsNumber sourcePkgIndex =
PackageIndex.fromList
- [ UnconfiguredPackage pkg (dfsNumber name) (flagsFor name)
+ [ UnconfiguredPackage pkg (dfsNumber name) (flagsFor name) (stanzasFor name)
| pkg <- PackageIndex.allPackages sourcePkgIndex
, let name = packageName pkg ]
where
@@ -429,6 +439,10 @@ annotateSourcePackages constraints dfsNumber sourcePkgIndex =
flagsMap = Map.fromList
[ (name, flags)
| PackageConstraintFlags name flags <- constraints ]
+ stanzasFor = fromMaybe [] . flip Map.lookup stanzasMap
+ stanzasMap = Map.fromListWith (++)
+ [ (name, stanzas)
+ | PackageConstraintStanzas name stanzas <- 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
@@ -540,8 +554,8 @@ finaliseSelectedPackages pref selected constraints =
Just (InstalledAndSource _ _) -> finaliseSource (Just ipkg) apkg
finaliseInstalled (InstalledPackageEx pkg _ _) = InstallPlan.PreExisting pkg
- finaliseSource mipkg (SemiConfiguredPackage pkg flags deps) =
- InstallPlan.Configured (ConfiguredPackage pkg flags deps')
+ finaliseSource mipkg (SemiConfiguredPackage pkg flags stanzas deps) =
+ InstallPlan.Configured (ConfiguredPackage pkg flags stanzas deps')
where
deps' = map (packageId . pickRemaining mipkg) deps
diff --git a/cabal/cabal-install/Distribution/Client/Dependency/TopDown/Constraints.hs b/cabal/cabal-install/Distribution/Client/Dependency/TopDown/Constraints.hs
index 216cf71..b6a03b0 100644
--- a/cabal/cabal-install/Distribution/Client/Dependency/TopDown/Constraints.hs
+++ b/cabal/cabal-install/Distribution/Client/Dependency/TopDown/Constraints.hs
@@ -38,7 +38,7 @@ import Distribution.Client.Utils
import Data.Monoid
( Monoid(mempty) )
import Data.Either
- ( partitionEithers )
+ ( partitionEithers )
import qualified Data.Map as Map
import Data.Map (Map)
import qualified Data.Set as Set
@@ -71,8 +71,7 @@ import Control.Exception
-- Adding a new target package can fail if that package already has conflicting
-- constraints.
--
-data (Package installed, Package source)
- => Constraints installed source reason
+data Constraints installed source reason
= Constraints
-- | Targets that we know we need. This is the set for which we
@@ -118,7 +117,7 @@ instance Package pkg => Package (ExcludedPkg pkg reason) where
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
@@ -203,7 +202,7 @@ transitionsTo constraints @(Constraints _ available excluded _ _)
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 _)
@@ -314,7 +313,7 @@ addTarget pkgname
-- package is simply completely unknown.
| otherwise
= Unsatisfiable
-
+
where
conflicts =
[ (packageId pkg, reasons)
@@ -403,7 +402,7 @@ constrain pkgname constraint reason
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.
@@ -425,14 +424,14 @@ constrain pkgname constraint reason
Nothing
AllAvailable (InstalledAndSource (aiPkg, False) (asPkg, False)) ->
- removeAvailable False
+ removeAvailable False
(InstalledAndSource aiPkg asPkg)
(PackageIndex.deletePackageId pkgid)
(ExcludedPkg (InstalledAndSource aiPkg asPkg) [reason] [] [])
Nothing
AllAvailable (InstalledAndSource (aiPkg, True) (asPkg, False)) ->
- removeAvailable True
+ removeAvailable True
(SourceOnly asPkg)
(PackageIndex.insert (InstalledOnly aiPkg))
(ExcludedPkg (SourceOnly asPkg) [] [] [reason])
diff --git a/cabal/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs b/cabal/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs
index 5c83775..2e95083 100644
--- a/cabal/cabal-install/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
- ( SourcePackage(..), InstalledPackage )
+ ( SourcePackage(..), InstalledPackage, OptionalStanza )
import Distribution.Package
( PackageIdentifier, Dependency
@@ -50,11 +50,13 @@ data UnconfiguredPackage
SourcePackage
!TopologicalSortNumber
FlagAssignment
+ [OptionalStanza]
data SemiConfiguredPackage
= SemiConfiguredPackage
SourcePackage -- package info
FlagAssignment -- total flag assignment for the package
+ [OptionalStanza] -- enabled optional stanzas
[Dependency] -- dependencies we end up with when we apply
-- the flag assignment
@@ -65,10 +67,10 @@ instance PackageFixedDeps InstalledPackageEx where
depends (InstalledPackageEx _ _ deps) = deps
instance Package UnconfiguredPackage where
- packageId (UnconfiguredPackage p _ _) = packageId p
+ packageId (UnconfiguredPackage p _ _ _) = packageId p
instance Package SemiConfiguredPackage where
- packageId (SemiConfiguredPackage p _ _) = packageId p
+ packageId (SemiConfiguredPackage p _ _ _) = packageId p
instance (Package installed, Package source)
=> Package (InstalledOrSource installed source) where
diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Types.hs b/cabal/cabal-install/Distribution/Client/Dependency/Types.hs
index 5b245a1..61e36cb 100644
--- a/cabal/cabal-install/Distribution/Client/Dependency/Types.hs
+++ b/cabal/cabal-install/Distribution/Client/Dependency/Types.hs
@@ -11,35 +11,91 @@
-- Common types for dependency resolution.
-----------------------------------------------------------------------------
module Distribution.Client.Dependency.Types (
+ ExtDependency(..),
+
+ PreSolver(..),
+ Solver(..),
DependencyResolver,
PackageConstraint(..),
PackagePreferences(..),
InstalledPreference(..),
+ PackagesPreferenceDefault(..),
Progress(..),
foldProgress,
) where
+import Control.Applicative
+ ( Applicative(..), Alternative(..) )
+
+import Data.Char
+ ( isAlpha, toLower )
+import Data.Monoid
+ ( Monoid(..) )
+
import Distribution.Client.Types
- ( SourcePackage(..), InstalledPackage )
+ ( OptionalStanza, SourcePackage(..) )
import qualified Distribution.Client.InstallPlan as InstallPlan
+import Distribution.Compat.ReadP
+ ( (<++) )
+
+import qualified Distribution.Compat.ReadP as Parse
+ ( pfail, munch1 )
import Distribution.PackageDescription
( FlagAssignment )
-import Distribution.Client.PackageIndex
+import qualified Distribution.Client.PackageIndex as PackageIndex
+ ( PackageIndex )
+import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex
( PackageIndex )
import Distribution.Package
- ( PackageName )
+ ( Dependency, PackageName, InstalledPackageId )
import Distribution.Version
( VersionRange )
import Distribution.Compiler
( CompilerId )
import Distribution.System
( Platform )
+import Distribution.Text
+ ( Text(..) )
+
+import Text.PrettyPrint
+ ( text )
import Prelude hiding (fail)
+-- | Covers source dependencies and installed dependencies in
+-- one type.
+data ExtDependency = SourceDependency Dependency
+ | InstalledDependency InstalledPackageId
+
+instance Text ExtDependency where
+ disp (SourceDependency dep) = disp dep
+ disp (InstalledDependency dep) = disp dep
+
+ parse = (SourceDependency `fmap` parse) <++ (InstalledDependency `fmap` parse)
+
+-- | All the solvers that can be selected.
+data PreSolver = AlwaysTopDown | AlwaysModular | Choose
+ deriving (Eq, Ord, Show, Bounded, Enum)
+
+-- | All the solvers that can be used.
+data Solver = TopDown | Modular
+ deriving (Eq, Ord, Show, Bounded, Enum)
+
+instance Text PreSolver where
+ disp AlwaysTopDown = text "topdown"
+ disp AlwaysModular = text "modular"
+ disp Choose = text "choose"
+ parse = do
+ name <- Parse.munch1 isAlpha
+ case map toLower name of
+ "topdown" -> return AlwaysTopDown
+ "modular" -> return AlwaysModular
+ "choose" -> return Choose
+ _ -> Parse.pfail
+
-- | A dependency resolver is a function that works out an installation plan
-- given the set of installed and available packages and a set of deps to
-- solve for.
@@ -50,8 +106,8 @@ import Prelude hiding (fail)
--
type DependencyResolver = Platform
-> CompilerId
- -> PackageIndex InstalledPackage
- -> PackageIndex SourcePackage
+ -> InstalledPackageIndex.PackageIndex
+ -> PackageIndex.PackageIndex SourcePackage
-> (PackageName -> PackagePreferences)
-> [PackageConstraint]
-> [PackageName]
@@ -67,6 +123,7 @@ data PackageConstraint
| PackageConstraintInstalled PackageName
| PackageConstraintSource PackageName
| PackageConstraintFlags PackageName FlagAssignment
+ | PackageConstraintStanzas PackageName [OptionalStanza]
deriving (Show,Eq)
-- | A per-package preference on the version. It is a soft constraint that the
@@ -86,6 +143,30 @@ data PackagePreferences = PackagePreferences VersionRange InstalledPreference
--
data InstalledPreference = PreferInstalled | PreferLatest
+-- | 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 type to represent the unfolding of an expensive long running
-- calculation that may fail. We may get intermediate steps before the final
-- retult which may be used to indicate progress and\/or logging messages.
@@ -114,3 +195,11 @@ instance Functor (Progress step fail) where
instance Monad (Progress step fail) where
return a = Done a
p >>= f = foldProgress Step Fail f p
+
+instance Applicative (Progress step fail) where
+ pure a = Done a
+ p <*> x = foldProgress Step Fail (flip fmap x) p
+
+instance Monoid fail => Alternative (Progress step fail) where
+ empty = Fail mempty
+ p <|> q = foldProgress Step (const q) Done p
diff --git a/cabal/cabal-install/Distribution/Client/Fetch.hs b/cabal/cabal-install/Distribution/Client/Fetch.hs
index f69bf85..9d01e87 100644
--- a/cabal/cabal-install/Distribution/Client/Fetch.hs
+++ b/cabal/cabal-install/Distribution/Client/Fetch.hs
@@ -19,7 +19,6 @@ 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
@@ -30,6 +29,7 @@ import Distribution.Package
( packageId )
import Distribution.Simple.Compiler
( Compiler(compilerId), PackageDBStack )
+import Distribution.Simple.PackageIndex (PackageIndex)
import Distribution.Simple.Program
( ProgramConfiguration )
import Distribution.Simple.Setup
@@ -112,7 +112,7 @@ fetch verbosity packageDBs repos comp conf
planPackages :: Verbosity
-> Compiler
-> FetchFlags
- -> PackageIndex InstalledPackage
+ -> PackageIndex
-> SourcePackageDb
-> [PackageSpecifier SourcePackage]
-> IO [SourcePackage]
@@ -120,17 +120,19 @@ planPackages verbosity comp fetchFlags
installedPkgIndex sourcePkgDb pkgSpecifiers
| includeDependencies = do
+ solver <- chooseSolver verbosity (fromFlag (fetchSolver fetchFlags)) (compilerId comp)
notice verbosity "Resolving dependencies..."
installPlan <- foldProgress logMsg die return $
resolveDependencies
buildPlatform (compilerId comp)
+ solver
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.Configured (InstallPlan.ConfiguredPackage pkg _ _ _))
<- InstallPlan.toList installPlan ]
| otherwise =
@@ -140,17 +142,31 @@ planPackages verbosity comp fetchFlags
where
resolverParams =
+ setMaxBackjumps (if maxBackjumps < 0 then Nothing
+ else Just maxBackjumps)
+
+ . setIndependentGoals independentGoals
+
+ . setReorderGoals reorderGoals
+
+ . setShadowPkgs shadowPkgs
+
-- 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
+ -- already installed. Since we want to get the source packages of
-- things we might have installed (but not have the sources for).
- reinstallTargets
+ . reinstallTargets
$ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers
includeDependencies = fromFlag (fetchDeps fetchFlags)
logMsg message rest = debug verbosity message >> rest
+ reorderGoals = fromFlag (fetchReorderGoals fetchFlags)
+ independentGoals = fromFlag (fetchIndependentGoals fetchFlags)
+ shadowPkgs = fromFlag (fetchShadowPkgs fetchFlags)
+ maxBackjumps = fromFlag (fetchMaxBackjumps fetchFlags)
+
checkTarget :: UserTarget -> IO ()
checkTarget target = case target of
diff --git a/cabal/cabal-install/Distribution/Client/Haddock.hs b/cabal/cabal-install/Distribution/Client/Haddock.hs
index 72cebc5..97c3a72 100644
--- a/cabal/cabal-install/Distribution/Client/Haddock.hs
+++ b/cabal/cabal-install/Distribution/Client/Haddock.hs
@@ -10,7 +10,7 @@
-- Interfacing with Haddock
--
-----------------------------------------------------------------------------
-module Distribution.Client.Haddock
+module Distribution.Client.Haddock
(
regenerateHaddockIndex
)
@@ -22,30 +22,29 @@ import Control.Monad (guard)
import System.Directory (createDirectoryIfMissing, doesFileExist,
renameFile)
import System.FilePath ((</>), splitFileName)
-import Distribution.Package (Package(..))
+import Distribution.Package
+ ( Package(..), packageVersion )
import Distribution.Simple.Program (haddockProgram, ProgramConfiguration
, rawSystemProgram, requireProgramVersion)
import Distribution.Version (Version(Version), orLaterVersion)
import Distribution.Verbosity (Verbosity)
import Distribution.Text (display)
-import Distribution.Client.PackageIndex(PackageIndex, allPackages,
- allPackagesByName, fromList)
+import Distribution.Simple.PackageIndex
+ ( PackageIndex, allPackagesByName )
import Distribution.Simple.Utils
( comparing, intercalate, debug
, installDirectoryContents, withTempDirectory )
-import Distribution.InstalledPackageInfo as InstalledPackageInfo
+import Distribution.InstalledPackageInfo as InstalledPackageInfo
( InstalledPackageInfo
, InstalledPackageInfo_(haddockHTMLs, haddockInterfaces, exposed) )
-import Distribution.Client.Types
- ( InstalledPackage(..) )
-regenerateHaddockIndex :: Verbosity -> PackageIndex InstalledPackage -> ProgramConfiguration -> FilePath -> IO ()
+regenerateHaddockIndex :: Verbosity -> PackageIndex -> ProgramConfiguration -> FilePath -> IO ()
regenerateHaddockIndex verbosity pkgs conf index = do
(paths,warns) <- haddockPackagePaths pkgs'
case warns of
Nothing -> return ()
Just m -> debug verbosity m
-
+
(confHaddock, _, _) <-
requireProgramVersion verbosity haddockProgram
(orLaterVersion (Version [0,6] [])) conf
@@ -63,16 +62,13 @@ regenerateHaddockIndex verbosity pkgs conf index = do
rawSystemProgram verbosity confHaddock flags
renameFile (tempDir </> "index.html") (tempDir </> destFile)
installDirectoryContents verbosity tempDir destDir
-
- where
+
+ where
(destDir,destFile) = splitFileName index
- pkgs' = map (maximumBy $ comparing packageId)
- . allPackagesByName
- . fromList
- . filter exposed
- . map (\(InstalledPackage pkg _) -> pkg)
- . allPackages
- $ pkgs
+ pkgs' = [ maximumBy (comparing packageVersion) pkgvers'
+ | (_pname, pkgvers) <- allPackagesByName pkgs
+ , let pkgvers' = filter exposed pkgvers
+ , not (null pkgvers') ]
haddockPackagePaths :: [InstalledPackageInfo]
-> IO ([(FilePath, FilePath)], Maybe String)
diff --git a/cabal/cabal-install/Distribution/Client/HttpUtils.hs b/cabal/cabal-install/Distribution/Client/HttpUtils.hs
index 16a9a4c..d6e5270 100644
--- a/cabal/cabal-install/Distribution/Client/HttpUtils.hs
+++ b/cabal/cabal-install/Distribution/Client/HttpUtils.hs
@@ -5,6 +5,7 @@
module Distribution.Client.HttpUtils (
downloadURI,
getHTTP,
+ cabalBrowse,
proxy,
isOldHackageURI
) where
@@ -17,10 +18,10 @@ import Network.URI
import Network.Stream
( Result, ConnError(..) )
import Network.Browser
- ( Proxy (..), Authority (..), browse
- , setOutHandler, setErrHandler, setProxy, request)
+ ( Proxy (..), Authority (..), BrowserAction, browse
+ , setOutHandler, setErrHandler, setProxy, setAuthorityGen, request)
import Control.Monad
- ( mplus, join, liftM2 )
+ ( mplus, join, liftM, liftM2 )
import qualified Data.ByteString.Lazy.Char8 as ByteString
import Data.ByteString.Lazy (ByteString)
#ifdef WIN32
@@ -151,15 +152,22 @@ mkRequest uri = Request{ rqURI = uri
-- |Carry out a GET request, using the local proxy settings
getHTTP :: Verbosity -> URI -> IO (Result (Response ByteString))
-getHTTP verbosity uri = do
- p <- proxy verbosity
- let req = mkRequest uri
- (_, resp) <- browse $ do
- setErrHandler (warn verbosity . ("http error: "++))
- setOutHandler (debug verbosity)
- setProxy p
- request req
- return (Right resp)
+getHTTP verbosity uri = liftM (\(_, resp) -> Right resp) $
+ cabalBrowse verbosity (return ()) (request (mkRequest uri))
+
+cabalBrowse :: Verbosity
+ -> BrowserAction s ()
+ -> BrowserAction s a
+ -> IO a
+cabalBrowse verbosity auth act = do
+ p <- proxy verbosity
+ browse $ do
+ setProxy p
+ setErrHandler (warn verbosity . ("http error: "++))
+ setOutHandler (debug verbosity)
+ auth
+ setAuthorityGen (\_ _ -> return Nothing)
+ act
downloadURI :: Verbosity
-> URI -- ^ What to download
@@ -182,7 +190,7 @@ downloadURI verbosity uri path = do
Left err -> die $ "Failed to download " ++ show uri ++ " : " ++ show err
Right body -> do
info verbosity ("Downloaded to " ++ path)
- writeFileAtomic path (ByteString.unpack body)
+ writeFileAtomic path body
--FIXME: check the content-length header matches the body length.
--TODO: stream the download into the file rather than buffering the whole
-- thing in memory.
diff --git a/cabal/cabal-install/Distribution/Client/Index.hs b/cabal/cabal-install/Distribution/Client/Index.hs
new file mode 100644
index 0000000..347d9a7
--- /dev/null
+++ b/cabal/cabal-install/Distribution/Client/Index.hs
@@ -0,0 +1,218 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Client.Index
+-- Maintainer : cabal-devel@haskell.org
+-- Portability : portable
+--
+-- Querying and modifying local build tree references in the package index.
+-----------------------------------------------------------------------------
+
+module Distribution.Client.Index (
+ index,
+
+ createEmpty,
+ addBuildTreeRefs,
+ removeBuildTreeRefs,
+ listBuildTreeRefs,
+
+ defaultIndexFileName
+ ) where
+
+import qualified Distribution.Client.Tar as Tar
+import Distribution.Client.IndexUtils ( getSourcePackages )
+import Distribution.Client.PackageIndex ( allPackages )
+import Distribution.Client.Setup ( IndexFlags(..) )
+import Distribution.Client.Types ( Repo(..), LocalRepo(..)
+ , SourcePackageDb(..)
+ , SourcePackage(..), PackageLocation(..) )
+import Distribution.Client.Utils ( byteStringToFilePath, filePathToByteString
+ , makeAbsoluteToCwd )
+
+import Distribution.Simple.Setup ( fromFlagOrDefault )
+import Distribution.Simple.Utils ( die, debug, notice, findPackageDesc )
+import Distribution.Verbosity ( Verbosity )
+
+import qualified Data.ByteString.Lazy as BS
+import Control.Exception ( evaluate )
+import Control.Monad ( liftM, when, unless )
+import Data.List ( (\\), nub )
+import Data.Maybe ( catMaybes )
+import System.Directory ( canonicalizePath, createDirectoryIfMissing,
+ doesDirectoryExist, doesFileExist,
+ renameFile )
+import System.FilePath ( (</>), (<.>), takeDirectory, takeExtension )
+import System.IO ( IOMode(..), SeekMode(..)
+ , hSeek, withBinaryFile )
+
+-- | A reference to a local build tree.
+newtype BuildTreeRef = BuildTreeRef {
+ buildTreePath :: FilePath
+ }
+
+defaultIndexFileName :: FilePath
+defaultIndexFileName = "00-index.tar"
+
+-- | Entry point for the 'cabal index' command.
+index :: Verbosity -> IndexFlags -> FilePath -> IO ()
+index verbosity indexFlags path' = do
+ let runInit = fromFlagOrDefault False (indexInit indexFlags)
+ let refsToAdd = indexLinkSource indexFlags
+ let runLinkSource = not . null $ refsToAdd
+ let refsToRemove = indexRemoveSource indexFlags
+ let runRemoveSource = not . null $ refsToRemove
+ let runList = fromFlagOrDefault False (indexList indexFlags)
+
+ unless (or [runInit, runLinkSource, runRemoveSource, runList]) $ do
+ die "no arguments passed to the 'index' command"
+
+ path <- validateIndexPath path'
+
+ when runInit $ do
+ createEmpty verbosity path
+
+ when runLinkSource $ do
+ addBuildTreeRefs verbosity path refsToAdd
+
+ when runRemoveSource $ do
+ removeBuildTreeRefs verbosity path refsToRemove
+
+ when runList $ do
+ refs <- listBuildTreeRefs verbosity path
+ mapM_ putStrLn refs
+
+-- | Given a path, ensure that it refers to a local build tree.
+buildTreeRefFromPath :: FilePath -> IO (Maybe BuildTreeRef)
+buildTreeRefFromPath dir = do
+ dirExists <- doesDirectoryExist dir
+ when (not dirExists) $ do
+ die $ "directory '" ++ dir ++ "' does not exist"
+ _ <- findPackageDesc dir
+ return . Just $ BuildTreeRef { buildTreePath = dir }
+
+-- | Given a tar archive entry, try to parse it as a local build tree reference.
+readBuildTreePath :: Tar.Entry -> Maybe FilePath
+readBuildTreePath entry = case Tar.entryContent entry of
+ (Tar.OtherEntryType typeCode bs size)
+ | (typeCode == Tar.buildTreeRefTypeCode)
+ && (size == BS.length bs) -> Just $ byteStringToFilePath bs
+ | otherwise -> Nothing
+ _ -> Nothing
+
+-- | Given a sequence of tar archive entries, extract all references to local
+-- build trees.
+readBuildTreePaths :: Tar.Entries -> [FilePath]
+readBuildTreePaths =
+ catMaybes
+ . Tar.foldrEntries (\e r -> (readBuildTreePath e):r)
+ [] error
+
+-- | Given a path to a tar archive, extract all references to local build trees.
+readBuildTreePathsFromFile :: FilePath -> IO [FilePath]
+readBuildTreePathsFromFile = liftM (readBuildTreePaths . Tar.read)
+ . BS.readFile
+
+-- | Given a local build tree, serialise it to a tar archive entry.
+writeBuildTreeRef :: BuildTreeRef -> Tar.Entry
+writeBuildTreeRef lbt = Tar.simpleEntry tarPath content
+ where
+ bs = filePathToByteString path
+ path = buildTreePath lbt
+ -- fromRight can't fail because the path is shorter than 255 characters.
+ tarPath = fromRight $ Tar.toTarPath True tarPath'
+ -- Provide a filename for tools that treat custom entries as ordinary files.
+ tarPath' = "local-build-tree-reference"
+ content = Tar.OtherEntryType Tar.buildTreeRefTypeCode bs (BS.length bs)
+
+ -- TODO: Move this to D.C.Utils?
+ fromRight (Left err) = error err
+ fromRight (Right a) = a
+
+-- | Check that the provided path is either an existing directory, or a tar
+-- archive in an existing directory.
+validateIndexPath :: FilePath -> IO FilePath
+validateIndexPath path' = do
+ path <- makeAbsoluteToCwd path'
+ if (== ".tar") . takeExtension $ path
+ then return path
+ else do dirExists <- doesDirectoryExist path
+ unless dirExists $ do
+ die $ "directory does not exist: '" ++ path ++ "'"
+ return $ path </> defaultIndexFileName
+
+-- | Create an empty index file.
+createEmpty :: Verbosity -> FilePath -> IO ()
+createEmpty verbosity path = do
+ indexExists <- doesFileExist path
+ if indexExists
+ then debug verbosity $ "Package index already exists: " ++ path
+ else do
+ debug verbosity $ "Creating the index file '" ++ path ++ "'"
+ createDirectoryIfMissing True (takeDirectory path)
+ -- Equivalent to 'tar cvf empty.tar --files-from /dev/null'.
+ let zeros = BS.replicate (512*20) 0
+ BS.writeFile path zeros
+
+-- | Add given local build tree references to the index.
+addBuildTreeRefs :: Verbosity -> FilePath -> [FilePath] -> IO ()
+addBuildTreeRefs _ _ [] =
+ error "Distribution.Client.Index.addBuildTreeRefs: unexpected"
+addBuildTreeRefs verbosity path l' = do
+ checkIndexExists path
+ l <- liftM nub . mapM canonicalizePath $ l'
+ treesInIndex <- readBuildTreePathsFromFile path
+ -- Add only those paths that aren't already in the index.
+ treesToAdd <- mapM buildTreeRefFromPath (l \\ treesInIndex)
+ let entries = map writeBuildTreeRef (catMaybes treesToAdd)
+ when (not . null $ entries) $ do
+ offset <-
+ fmap (Tar.foldrEntries (\e acc -> Tar.entrySizeInBytes e + acc) 0 error
+ . Tar.read) $ BS.readFile path
+ _ <- evaluate offset
+ debug verbosity $ "Writing at offset: " ++ show offset
+ withBinaryFile path ReadWriteMode $ \h -> do
+ hSeek h AbsoluteSeek (fromIntegral offset)
+ BS.hPut h (Tar.write entries)
+ debug verbosity $ "Successfully appended to '" ++ path ++ "'"
+
+-- | Remove given local build tree references from the index.
+removeBuildTreeRefs :: Verbosity -> FilePath -> [FilePath] -> IO ()
+removeBuildTreeRefs _ _ [] =
+ error "Distribution.Client.Index.removeBuildTreeRefs: unexpected"
+removeBuildTreeRefs verbosity path l' = do
+ checkIndexExists path
+ l <- mapM canonicalizePath l'
+ let tmpFile = path <.> "tmp"
+ -- Performance note: on my system, it takes 'index --remove-source'
+ -- approx. 3,5s to filter a 65M file. Real-life indices are expected to be
+ -- much smaller.
+ BS.writeFile tmpFile . Tar.writeEntries . Tar.filterEntries (p l) . Tar.read
+ =<< BS.readFile path
+ -- This invalidates the cache, so we don't have to update it explicitly.
+ renameFile tmpFile path
+ debug verbosity $ "Successfully renamed '" ++ tmpFile
+ ++ "' to '" ++ path ++ "'"
+ where
+ p l entry = case readBuildTreePath entry of
+ Nothing -> True
+ (Just pth) -> not $ any (== pth) l
+
+-- | List the local build trees that are referred to from the index.
+listBuildTreeRefs :: Verbosity -> FilePath -> IO [FilePath]
+listBuildTreeRefs verbosity path = do
+ checkIndexExists path
+ let repo = Repo { repoKind = Right LocalRepo
+ , repoLocalDir = takeDirectory path }
+ pkgIndex <- fmap packageIndex . getSourcePackages verbosity $ [repo]
+ let buildTreeRefs = [ pkgPath | (LocalUnpackedPackage pkgPath) <-
+ map packageSource . allPackages $ pkgIndex ]
+ when (null buildTreeRefs) $ do
+ notice verbosity $ "Index file '" ++ path
+ ++ "' has no references to local build trees."
+ return buildTreeRefs
+
+-- | Check that the package index file exists and exit with error if it does not.
+checkIndexExists :: FilePath -> IO ()
+checkIndexExists path = do
+ indexExists <- doesFileExist path
+ when (not indexExists) $ do
+ die $ "index does not exist: '" ++ path ++ "'"
diff --git a/cabal/cabal-install/Distribution/Client/IndexUtils.hs b/cabal/cabal-install/Distribution/Client/IndexUtils.hs
index 0522a96..d5bfcf8 100644
--- a/cabal/cabal-install/Distribution/Client/IndexUtils.hs
+++ b/cabal/cabal-install/Distribution/Client/IndexUtils.hs
@@ -13,9 +13,12 @@
module Distribution.Client.IndexUtils (
getInstalledPackages,
getSourcePackages,
+ convert,
readPackageIndexFile,
- parseRepoIndex,
+ parsePackageIndex,
+ readRepoIndex,
+ updateRepoIndexCache,
) where
import qualified Distribution.Client.Tar as Tar
@@ -23,12 +26,13 @@ import Distribution.Client.Types
import Distribution.Package
( PackageId, PackageIdentifier(..), PackageName(..)
- , Package(..), packageVersion
+ , Package(..), packageVersion, packageName
, Dependency(Dependency), InstalledPackageId(..) )
import Distribution.Client.PackageIndex (PackageIndex)
import qualified Distribution.Client.PackageIndex as PackageIndex
import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex
import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
+import qualified Distribution.PackageDescription.Parse as PackageDesc.Parse
import Distribution.PackageDescription
( GenericPackageDescription )
import Distribution.PackageDescription.Parse
@@ -44,53 +48,57 @@ import Distribution.ParseUtils
import Distribution.Version
( Version(Version), intersectVersionRanges )
import Distribution.Text
- ( simpleParse )
+ ( display, simpleParse )
import Distribution.Verbosity
- ( Verbosity, lessVerbose )
+ ( Verbosity, normal, lessVerbose )
import Distribution.Simple.Utils
- ( warn, info, fromUTF8, equating )
+ ( die, warn, info, fromUTF8, findPackageDesc )
+import Data.Char (isAlphaNum)
import Data.Maybe (catMaybes, fromMaybe)
-import Data.List (isPrefixOf, groupBy)
+import Data.List (isPrefixOf)
import Data.Monoid (Monoid(..))
import qualified Data.Map as Map
-import Control.Monad (MonadPlus(mplus), when)
+import Control.Monad (MonadPlus(mplus), when, unless, liftM)
import Control.Exception (evaluate)
import qualified Data.ByteString.Lazy as BS
import qualified Data.ByteString.Lazy.Char8 as BS.Char8
+import qualified Data.ByteString.Char8 as BSS
import Data.ByteString.Lazy (ByteString)
import Distribution.Client.GZipUtils (maybeDecompress)
+import Distribution.Client.Utils (byteStringToFilePath)
import System.FilePath ((</>), takeExtension, splitDirectories, normalise)
import System.FilePath.Posix as FilePath.Posix
( takeFileName )
+import System.IO
+import System.IO.Unsafe (unsafeInterleaveIO)
import System.IO.Error (isDoesNotExistError)
+import Distribution.Compat.Exception (catchIO)
import System.Directory
- ( getModificationTime )
-import System.Time
- ( getClockTime, diffClockTimes, normalizeTimeDiff, TimeDiff(tdDay) )
+ ( getModificationTime, doesFileExist )
+import Distribution.Compat.Time
+
getInstalledPackages :: Verbosity -> Compiler
-> PackageDBStack -> ProgramConfiguration
- -> IO (PackageIndex InstalledPackage)
+ -> IO InstalledPackageIndex.PackageIndex
getInstalledPackages verbosity comp packageDbs conf =
- fmap convert (Configure.getInstalledPackages verbosity'
- comp packageDbs conf)
+ 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
- -- 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)
- | ipkgs <- InstalledPackageIndex.allPackagesByName index
- , (ipkg:_) <- groupBy (equating packageVersion) ipkgs ]
-
+convert :: InstalledPackageIndex.PackageIndex -> PackageIndex InstalledPackage
+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.allPackagesBySourcePackageId 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.allPackagesBySourcePackageId index' ]
+ where
-- The InstalledPackageInfo only lists dependencies by the
-- InstalledPackageId, which means we do not directly know the corresponding
-- source dependency. The only way to find out is to lookup the
@@ -109,6 +117,10 @@ getInstalledPackages verbosity comp packageDbs conf =
brokenPackageId (InstalledPackageId str) =
PackageIdentifier (PackageName (str ++ "-broken")) (Version [] [])
+------------------------------------------------------------------------
+-- Reading the source package index
+--
+
-- | Read a repository index from disk, from the local files specified by
-- a list of 'Repo's.
--
@@ -147,42 +159,29 @@ getSourcePackages verbosity repos = do
--
readRepoIndex :: Verbosity -> Repo
-> IO (PackageIndex SourcePackage, [Dependency])
-readRepoIndex verbosity repo = handleNotFound $ do
+readRepoIndex verbosity repo =
let indexFile = repoLocalDir repo </> "00-index.tar"
- (pkgs, prefs) <- either fail return
- . foldlTarball extract ([], [])
- =<< BS.readFile indexFile
+ cacheFile = repoLocalDir repo </> "00-index.cache"
+ in handleNotFound $ do
+ warnIfIndexIsOld indexFile
+ whenCacheOutOfDate indexFile cacheFile $ do
+ info verbosity $ "Updating the index cache file..."
+ updatePackageIndexCacheFile indexFile cacheFile
+ readPackageIndexCacheFile mkAvailablePackage indexFile cacheFile
- pkgIndex <- evaluate $ PackageIndex.fromList
- [ SourcePackage {
+ where
+ mkAvailablePackage pkgEntry =
+ SourcePackage {
packageInfoId = pkgid,
- packageDescription = pkg,
- packageSource = RepoTarballPackage repo pkgid Nothing
+ packageDescription = packageDesc pkgEntry,
+ packageSource = case pkgEntry of
+ NormalPackage _ _ _ -> RepoTarballPackage repo pkgid Nothing
+ BuildTreeRef _ path _ _ -> LocalUnpackedPackage path
}
- | (pkgid, pkg) <- pkgs]
-
- warnIfIndexIsOld indexFile
- return (pkgIndex, prefs)
+ where
+ pkgid = packageId pkgEntry
- where
- extract (pkgs, prefs) entry = fromMaybe (pkgs, prefs) $
- (do pkg <- extractPkg entry; return (pkg:pkgs, prefs))
- `mplus` (do prefs' <- extractPrefs entry; return (pkgs, prefs'++prefs))
-
- 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
+ handleNotFound action = catchIO action $ \e -> if isDoesNotExistError e
then do
case repoKind repo of
Left remoteRepo -> warn verbosity $
@@ -196,21 +195,55 @@ readRepoIndex verbosity repo = handleNotFound $ do
isOldThreshold = 15 --days
warnIfIndexIsOld indexFile = do
- indexTime <- getModificationTime indexFile
- currentTime <- getClockTime
- let diff = normalizeTimeDiff (diffClockTimes currentTime indexTime)
- when (tdDay diff >= isOldThreshold) $ case repoKind repo of
+ dt <- getFileAge indexFile
+ when (dt >= isOld