summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSergeiTrofimovich <>2012-10-16 21:28:07 (GMT)
committerhdiff <hdiff@luite.com>2012-10-16 21:28:07 (GMT)
commite0e48a6868e174487c70907bbb905aec2c8ce687 (patch)
tree7f4856509418277c6d53dff7e6acb92e035576d4
parenta0db50cda0f7bcf3ec8f7934db111efe48f2c13b (diff)
-rw-r--r--AnsiColor.hs63
-rw-r--r--BlingBling.hs52
-rw-r--r--Cabal2Ebuild.hs125
-rw-r--r--CacheFile.hs12
-rw-r--r--Diff.hs188
-rw-r--r--DistroMap.hs158
-rw-r--r--Error.hs63
-rw-r--r--Hackage.hs32
-rw-r--r--LICENSE674
-rw-r--r--Main-GuessGHC.hs27
-rw-r--r--Main.hs558
-rw-r--r--Merge.hs233
-rw-r--r--Merge/Dependencies.hs361
-rw-r--r--Overlays.hs71
-rw-r--r--Portage/Cabal.hs15
-rw-r--r--Portage/Dependency.hs219
-rw-r--r--Portage/EBuild.hs188
-rw-r--r--Portage/GHCCore.hs309
-rw-r--r--Portage/Host.hs92
-rw-r--r--Portage/Metadata.hs55
-rw-r--r--Portage/Overlay.hs181
-rw-r--r--Portage/PackageId.hs126
-rw-r--r--Portage/Resolve.hs75
-rw-r--r--Portage/Use.hs50
-rw-r--r--Portage/Version.hs95
-rw-r--r--Progress.hs62
-rw-r--r--README.rst133
-rw-r--r--Setup.hs7
-rw-r--r--Status.hs240
-rw-r--r--TODO39
-rw-r--r--Util.hs31
-rw-r--r--cabal/Cabal/Cabal.cabal193
-rw-r--r--cabal/Cabal/DefaultSetup.hs2
-rw-r--r--cabal/Cabal/Distribution/Compat/CopyFile.hs115
-rw-r--r--cabal/Cabal/Distribution/Compat/Exception.hs61
-rw-r--r--cabal/Cabal/Distribution/Compat/ReadP.hs381
-rw-r--r--cabal/Cabal/Distribution/Compat/TempFile.hs204
-rw-r--r--cabal/Cabal/Distribution/Compiler.hs158
-rw-r--r--cabal/Cabal/Distribution/GetOpt.hs335
-rw-r--r--cabal/Cabal/Distribution/InstalledPackageInfo.hs294
-rw-r--r--cabal/Cabal/Distribution/License.hs146
-rw-r--r--cabal/Cabal/Distribution/Make.hs213
-rw-r--r--cabal/Cabal/Distribution/ModuleName.hs130
-rw-r--r--cabal/Cabal/Distribution/Package.hs202
-rw-r--r--cabal/Cabal/Distribution/PackageDescription.hs1034
-rw-r--r--cabal/Cabal/Distribution/PackageDescription/Check.hs1495
-rw-r--r--cabal/Cabal/Distribution/PackageDescription/Configuration.hs652
-rw-r--r--cabal/Cabal/Distribution/PackageDescription/Parse.hs1205
-rw-r--r--cabal/Cabal/Distribution/PackageDescription/PrettyPrint.hs238
-rw-r--r--cabal/Cabal/Distribution/ParseUtils.hs715
-rw-r--r--cabal/Cabal/Distribution/ReadE.hs81
-rw-r--r--cabal/Cabal/Distribution/Simple.hs703
-rw-r--r--cabal/Cabal/Distribution/Simple/Bench.hs156
-rw-r--r--cabal/Cabal/Distribution/Simple/Build.hs349
-rw-r--r--cabal/Cabal/Distribution/Simple/Build/Macros.hs57
-rw-r--r--cabal/Cabal/Distribution/Simple/Build/PathsModule.hs262
-rw-r--r--cabal/Cabal/Distribution/Simple/BuildPaths.hs150
-rw-r--r--cabal/Cabal/Distribution/Simple/Command.hs555
-rw-r--r--cabal/Cabal/Distribution/Simple/Compiler.hs194
-rw-r--r--cabal/Cabal/Distribution/Simple/Configure.hs1083
-rw-r--r--cabal/Cabal/Distribution/Simple/GHC.hs1127
-rw-r--r--cabal/Cabal/Distribution/Simple/GHC/IPI641.hs129
-rw-r--r--cabal/Cabal/Distribution/Simple/GHC/IPI642.hs164
-rw-r--r--cabal/Cabal/Distribution/Simple/Haddock.hs653
-rw-r--r--cabal/Cabal/Distribution/Simple/Hpc.hs170
-rw-r--r--cabal/Cabal/Distribution/Simple/Hugs.hs634
-rw-r--r--cabal/Cabal/Distribution/Simple/Install.hs214
-rw-r--r--cabal/Cabal/Distribution/Simple/InstallDirs.hs604
-rw-r--r--cabal/Cabal/Distribution/Simple/JHC.hs222
-rw-r--r--cabal/Cabal/Distribution/Simple/LHC.hs820
-rw-r--r--cabal/Cabal/Distribution/Simple/LocalBuildInfo.hs337
-rw-r--r--cabal/Cabal/Distribution/Simple/NHC.hs424
-rw-r--r--cabal/Cabal/Distribution/Simple/PackageIndex.hs574
-rw-r--r--cabal/Cabal/Distribution/Simple/PreProcess.hs608
-rw-r--r--cabal/Cabal/Distribution/Simple/PreProcess/Unlit.hs165
-rw-r--r--cabal/Cabal/Distribution/Simple/Program.hs218
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Ar.hs70
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Builtin.hs269
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Db.hs409
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/GHC.hs458
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/HcPkg.hs365
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Hpc.hs73
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Ld.hs62
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Run.hs218
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Script.hs105
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Types.hs130
-rw-r--r--cabal/Cabal/Distribution/Simple/Register.hs404
-rw-r--r--cabal/Cabal/Distribution/Simple/Setup.hs1680
-rw-r--r--cabal/Cabal/Distribution/Simple/SrcDist.hs441
-rw-r--r--cabal/Cabal/Distribution/Simple/Test.hs544
-rw-r--r--cabal/Cabal/Distribution/Simple/UHC.hs300
-rw-r--r--cabal/Cabal/Distribution/Simple/UserHooks.hs231
-rw-r--r--cabal/Cabal/Distribution/Simple/Utils.hs1140
-rw-r--r--cabal/Cabal/Distribution/System.hs179
-rw-r--r--cabal/Cabal/Distribution/TestSuite.hs125
-rw-r--r--cabal/Cabal/Distribution/Text.hs68
-rw-r--r--cabal/Cabal/Distribution/Verbosity.hs113
-rw-r--r--cabal/Cabal/Distribution/Version.hs744
-rw-r--r--cabal/Cabal/LICENSE33
-rw-r--r--cabal/Cabal/Language/Haskell/Extension.hs540
-rw-r--r--cabal/Cabal/Makefile130
-rw-r--r--cabal/Cabal/README179
-rw-r--r--cabal/Cabal/Setup.hs10
-rw-r--r--cabal/Cabal/changelog385
-rw-r--r--cabal/Cabal/doc/Cabal.css39
-rw-r--r--cabal/Cabal/doc/developing-packages.markdown1537
-rw-r--r--cabal/Cabal/doc/index.markdown169
-rw-r--r--cabal/Cabal/doc/installing-packages.markdown809
-rw-r--r--cabal/Cabal/doc/misc.markdown109
-rw-r--r--cabal/Cabal/prologue.txt7
-rw-r--r--cabal/Cabal/runTests.sh21
-rw-r--r--cabal/Cabal/tests/PackageTests.hs82
-rw-r--r--cabal/Cabal/tests/PackageTests/BenchmarkExeV10/Check.hs21
-rw-r--r--cabal/Cabal/tests/PackageTests/BenchmarkExeV10/Foo.hs4
-rw-r--r--cabal/Cabal/tests/PackageTests/BenchmarkExeV10/Setup.hs3
-rw-r--r--cabal/Cabal/tests/PackageTests/BenchmarkExeV10/benchmarks/bench-Foo.hs8
-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.hs3
-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.hs3
-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.cabal20
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs10
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Setup.hs3
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs22
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal20
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Setup.hs3
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs7
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs26
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs10
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Setup.hs3
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal24
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs6
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs18
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs10
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Setup.hs3
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal23
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs6
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs34
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs10
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Setup.hs3
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal23
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs6
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs10
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/Setup.hs3
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal18
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs34
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs10
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Setup.hs3
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal23
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs6
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs10
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/Setup.hs3
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal18
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs34
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs10
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Setup.hs3
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal23
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs6
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs10
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/Setup.hs3
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal18
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs18
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs10
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal31
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Setup.hs3
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs7
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs7
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs24
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs10
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Setup.hs3
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs7
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal22
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs19
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs10
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Setup.hs3
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs5
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal24
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs23
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs10
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Setup.hs3
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs7
-rw-r--r--cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal22
-rw-r--r--cabal/Cabal/tests/PackageTests/PackageTester.hs179
-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.hs57
-rw-r--r--cabal/Cabal/tests/PackageTests/TestStanza/Setup.hs3
-rw-r--r--cabal/Cabal/tests/PackageTests/TestStanza/my.cabal19
-rw-r--r--cabal/Cabal/tests/PackageTests/TestSuiteExeV10/Check.hs47
-rw-r--r--cabal/Cabal/tests/PackageTests/TestSuiteExeV10/Foo.hs4
-rw-r--r--cabal/Cabal/tests/PackageTests/TestSuiteExeV10/Setup.hs3
-rw-r--r--cabal/Cabal/tests/PackageTests/TestSuiteExeV10/my.cabal15
-rw-r--r--cabal/Cabal/tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs8
-rw-r--r--cabal/Cabal/tests/UnitTests.hs17
-rw-r--r--cabal/Cabal/tests/UnitTests/Distribution/Compat/ReadP.hs140
-rw-r--r--cabal/Cabal/tests/hackage/check.sh25
-rw-r--r--cabal/Cabal/tests/hackage/download.sh19
-rw-r--r--cabal/Cabal/tests/hackage/unpack.sh16
-rw-r--r--cabal/Cabal/tests/misc/ghc-supported-languages.hs99
-rw-r--r--cabal/HACKING10
-rw-r--r--cabal/LICENSE33
-rw-r--r--cabal/Paths_Cabal.hs8
-rw-r--r--cabal/Paths_cabal_install.hs8
-rw-r--r--cabal/README8
-rw-r--r--cabal/cabal-install/Distribution/Client/BuildReports/Anonymous.hs315
-rw-r--r--cabal/cabal-install/Distribution/Client/BuildReports/Storage.hs127
-rw-r--r--cabal/cabal-install/Distribution/Client/BuildReports/Types.hs44
-rw-r--r--cabal/cabal-install/Distribution/Client/BuildReports/Upload.hs72
-rw-r--r--cabal/cabal-install/Distribution/Client/Check.hs85
-rw-r--r--cabal/cabal-install/Distribution/Client/Config.hs543
-rw-r--r--cabal/cabal-install/Distribution/Client/Configure.hs215
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency.hs514
-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.hs942
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/TopDown/Constraints.hs600
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs91
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Types.hs205
-rw-r--r--cabal/cabal-install/Distribution/Client/Fetch.hs189
-rw-r--r--cabal/cabal-install/Distribution/Client/FetchUtils.hs193
-rw-r--r--cabal/cabal-install/Distribution/Client/GZipUtils.hs44
-rw-r--r--cabal/cabal-install/Distribution/Client/Haddock.hs101
-rw-r--r--cabal/cabal-install/Distribution/Client/HttpUtils.hs205
-rw-r--r--cabal/cabal-install/Distribution/Client/Index.hs218
-rw-r--r--cabal/cabal-install/Distribution/Client/IndexUtils.hs514
-rw-r--r--cabal/cabal-install/Distribution/Client/Init.hs779
-rw-r--r--cabal/cabal-install/Distribution/Client/Init/Heuristics.hs229
-rw-r--r--cabal/cabal-install/Distribution/Client/Init/Licenses.hs1928
-rw-r--r--cabal/cabal-install/Distribution/Client/Init/Types.hs164
-rw-r--r--cabal/cabal-install/Distribution/Client/Install.hs1212
-rw-r--r--cabal/cabal-install/Distribution/Client/InstallPlan.hs536
-rw-r--r--cabal/cabal-install/Distribution/Client/InstallSymlink.hs239
-rw-r--r--cabal/cabal-install/Distribution/Client/JobControl.hs89
-rw-r--r--cabal/cabal-install/Distribution/Client/List.hs533
-rw-r--r--cabal/cabal-install/Distribution/Client/PackageEnvironment.hs380
-rw-r--r--cabal/cabal-install/Distribution/Client/PackageIndex.hs487
-rw-r--r--cabal/cabal-install/Distribution/Client/PackageUtils.hs34
-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.hs1492
-rw-r--r--cabal/cabal-install/Distribution/Client/SetupWrapper.hs389
-rw-r--r--cabal/cabal-install/Distribution/Client/SrcDist.hs160
-rw-r--r--cabal/cabal-install/Distribution/Client/Tar.hs926
-rw-r--r--cabal/cabal-install/Distribution/Client/Targets.hs760
-rw-r--r--cabal/cabal-install/Distribution/Client/Types.hs187
-rw-r--r--cabal/cabal-install/Distribution/Client/Unpack.hs123
-rw-r--r--cabal/cabal-install/Distribution/Client/Update.hs80
-rw-r--r--cabal/cabal-install/Distribution/Client/Upload.hs185
-rw-r--r--cabal/cabal-install/Distribution/Client/Utils.hs127
-rw-r--r--cabal/cabal-install/Distribution/Client/Win32SelfUpgrade.hs222
-rw-r--r--cabal/cabal-install/Distribution/Client/World.hs174
-rw-r--r--cabal/cabal-install/Distribution/Compat/ExceptionCI.hs56
-rw-r--r--cabal/cabal-install/Distribution/Compat/FilePerms.hs40
-rw-r--r--cabal/cabal-install/Distribution/Compat/Time.hs37
-rw-r--r--cabal/cabal-install/LICENSE34
-rw-r--r--cabal/cabal-install/Main.hs644
-rw-r--r--cabal/cabal-install/README143
-rw-r--r--cabal/cabal-install/Setup.hs2
-rw-r--r--cabal/cabal-install/bash-completion/cabal24
-rw-r--r--cabal/cabal-install/bootstrap.sh241
-rw-r--r--cabal/cabal-install/cabal-install.cabal146
-rw-r--r--cabal/cabal-install/cbits/getnumcores.c46
-rw-r--r--cabal/cabal-install/changelog135
-rw-r--r--cabal/cabal-install/tests/test-cabal-install9
-rw-r--r--cabal/cabal-install/tests/test-cabal-install-user8
-rw-r--r--cabal/ghc-packages2
-rw-r--r--hackport.cabal147
-rw-r--r--tests/resolveCat.hs31
303 files changed, 0 insertions, 57911 deletions
diff --git a/AnsiColor.hs b/AnsiColor.hs
deleted file mode 100644
index 7a6edf7..0000000
--- a/AnsiColor.hs
+++ /dev/null
@@ -1,63 +0,0 @@
-{-|
- Maintainer : Andres Loeh <kosmikus@gentoo.org>
- Stability : provisional
- Portability : haskell98
-
- Simplistic ANSI color support.
--}
-
-module AnsiColor
- where
-
-import Data.List
-
-data Color = Black
- | Red
- | Green
- | Yellow
- | Blue
- | Magenta
- | Cyan
- | White
- | Default
- deriving Enum
-
-esc :: [String] -> String
-esc [] = ""
-esc xs = "\ESC[" ++ (concat . intersperse ";" $ xs) ++ "m"
-
-col :: Color -> Bool -> Color -> [String]
-col fg bf bg = show (fromEnum fg + 30) : bf' [show (fromEnum bg + 40)]
- where bf' | bf = ("01" :)
- | otherwise = id
-
-inColor :: Color -> Bool -> Color -> String -> String
-inColor c bf bg txt = esc (col c bf bg) ++ txt ++ esc ["00"]
-
-bold, italic, underline, inverse :: String -> String
-bold = ansi "1" "22"
-italic = ansi "3" "23"
-underline = ansi "4" "24"
-inverse = ansi "7" "27"
-
-ansi :: String -> String -> String -> String
-ansi on off txt = esc [on] ++ txt ++ esc [off]
-
-{-
-data Doc = Doc (Bool -> String -> String)
-
-char chr = Doc (\_ c -> chr:c)
-
-text str = Doc (\_ c -> str ++ c)
-
-(Doc t) <> (Doc u) = Doc (\b c -> t b (u b c))
-
-t <+> u = t <> char ' ' <> u
-
-showDoc (Doc d) b = d b ""
-
-color (Doc d) color = Doc (\ b c ->
- if not b
- then d b c
- else inColor color False Default (d b ""))
--}
diff --git a/BlingBling.hs b/BlingBling.hs
deleted file mode 100644
index 23ad2ff..0000000
--- a/BlingBling.hs
+++ /dev/null
@@ -1,52 +0,0 @@
-module BlingBling where
-
-import qualified Progress
-
-import System.IO
-import Control.Exception as Exception (bracket)
-
--- what nobody needs but everyone wants...
-
--- FIXME: do something more fun here
-forMbling :: [a] -> (a -> IO b) -> IO [b]
-forMbling lst f =
- withBuffering stdout NoBuffering $ do
- xs <- mapM (\x -> putStr "." >> f x) lst
- putStrLn ""
- return xs
-
-blingProgress :: Progress.Progress s String a -> IO a
-blingProgress progress = do
- isTerm <- hIsTerminalDevice stdout
- if isTerm
- then canIHasTehBling
- else boring
-
- where
- boring = Progress.fold (flip const) fail return progress
-
- canIHasTehBling =
- withBuffering stdout NoBuffering $ do
- putChar (fst (char 0))
- result <- spin 0 progress
- putStr "\b \b"
- return result
-
- spin _ (Progress.Fail e) = fail e
- spin _ (Progress.Done r) = return r
- spin n (Progress.Step _ p) = do
- putStr ['\b', c]
- spin n' p
- where (c, n') = char n
-
- char :: Int -> (Char, Int)
- char 0 = ('/', 1)
- char 1 = ('-', 2)
- char 2 = ('\\', 3)
- char _ = ('|', 0)
-
-withBuffering :: Handle -> BufferMode -> IO a -> IO a
-withBuffering hnd mode action =
- Exception.bracket
- (hGetBuffering hnd) (hSetBuffering hnd)
- (\_ -> hSetBuffering hnd mode >> action)
diff --git a/Cabal2Ebuild.hs b/Cabal2Ebuild.hs
deleted file mode 100644
index 421dc97..0000000
--- a/Cabal2Ebuild.hs
+++ /dev/null
@@ -1,125 +0,0 @@
--- A program for generating a Gentoo ebuild from a .cabal file
---
--- Author : Duncan Coutts <dcoutts@gentoo.org>
---
--- Created: 21 July 2005
---
--- Copyright (C) 2005 Duncan Coutts
---
--- This library is free software; you can redistribute it and/or
--- modify it under the terms of the GNU General Public License
--- as published by the Free Software Foundation; either version 2
--- of the License, or (at your option) any later version.
---
--- This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of
--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
--- General Public License for more details.
---
--- |
--- Maintainer : haskell@gentoo.org
---
--- cabal2ebuild - a program for generating a Gentoo ebuild from a .cabal file
---
-module Cabal2Ebuild
- (cabal2ebuild
- ,convertDependencies
- ,convertDependency) where
-
-import qualified Distribution.PackageDescription as Cabal
- (PackageDescription(..))
-import qualified Distribution.Package as Cabal (PackageIdentifier(..)
- , Dependency(..)
- , PackageName(..))
-import qualified Distribution.Version as Cabal (VersionRange, foldVersionRange')
-import Distribution.Text (display)
-
-import Data.Char (toLower,isUpper)
-
-import Portage.Dependency
-import qualified Portage.PackageId as Portage
-import qualified Portage.EBuild as Portage
-import qualified Portage.Resolve as Portage
-import qualified Portage.EBuild as E
-import qualified Portage.Overlay as O
-import Portage.Version
-
-cabal2ebuild :: Cabal.PackageDescription -> Portage.EBuild
-cabal2ebuild pkg = Portage.ebuildTemplate {
- E.name = map toLower cabalPkgName,
- E.hackage_name= cabalPkgName,
- E.version = display (Cabal.pkgVersion (Cabal.package pkg)),
- E.description = if null (Cabal.synopsis pkg) then Cabal.description pkg
- else Cabal.synopsis pkg,
- E.long_desc = if null (Cabal.description pkg) then Cabal.synopsis pkg
- else Cabal.description pkg,
- E.homepage = thisHomepage,
- E.license = Cabal.license pkg,
- E.my_pn = if any isUpper cabalPkgName then Just cabalPkgName else Nothing,
- E.features = E.features E.ebuildTemplate
- ++ (if hasExe then ["bin"] else [])
- ++ maybe [] (const (["lib","profile","haddock","hoogle"]
- ++ if cabalPkgName == "hscolour" then [] else ["hscolour"])
- ) (Cabal.library pkg) -- hscolour can't colour its own sources
- ++ (if hasTests then ["test-suite"] else [])
- } where
- cabalPkgName = display $ Cabal.pkgName (Cabal.package pkg)
- hasExe = (not . null) (Cabal.executables pkg)
- hasTests = (not . null) (Cabal.testSuites pkg)
- thisHomepage = if (null $ Cabal.homepage pkg)
- then E.homepage E.ebuildTemplate
- else Cabal.homepage pkg
-
-convertDependencies :: O.Overlay -> Portage.Category -> [Cabal.Dependency] -> [Dependency]
-convertDependencies overlay category = concatMap (convertDependency overlay category)
-
-convertDependency :: O.Overlay -> Portage.Category -> Cabal.Dependency -> [Dependency]
-convertDependency _overlay _category (Cabal.Dependency pname@(Cabal.PackageName _name) _)
- | pname `elem` coreLibs = [] -- no explicit dep on core libs
-convertDependency overlay category (Cabal.Dependency pname versionRange)
- = convert versionRange
- where
- pn = case Portage.resolveFullPortageName overlay pname of
- Just r -> r
- Nothing -> Portage.PackageName category (Portage.normalizeCabalPackageName pname)
- convert :: Cabal.VersionRange -> [Dependency]
- convert = Cabal.foldVersionRange'
- ( [AnyVersionOf pn []] -- ^ @\"-any\"@ version
- )(\v -> [ThisVersionOf (fromCabalVersion v) pn []] -- ^ @\"== v\"@
- )(\v -> [LaterVersionOf (fromCabalVersion v) pn []] -- ^ @\"> v\"@
- )(\v -> [EarlierVersionOf (fromCabalVersion v) pn []] -- ^ @\"< v\"@
- )(\v -> [OrLaterVersionOf (fromCabalVersion v) pn []] -- ^ @\">= v\"@
- )(\v -> [OrEarlierVersionOf (fromCabalVersion v) pn []] -- ^ @\"<= v\"@
- )(\v _ -> [ThisMajorOf (fromCabalVersion v) pn []] -- ^ @\"== v.*\"@ wildcard. (incl lower, excl upper)
- )(\g1 g2 -> [DependEither (g1 ++ g2)] -- ^ @\"_ || _\"@ union
- )(\r1 r2 -> r1 ++ r2 -- ^ @\"_ && _\"@ intersection
- )(\dp -> [AllOf dp ] -- ^ @\"(_)\"@ parentheses
- )
-
-coreLibs :: [Cabal.PackageName]
-coreLibs = map Cabal.PackageName
- ["array"
- ,"base"
- ,"bytestring" -- intentionally no ebuild. use ghc's version
- -- to avoid dreaded 'diamond dependency' problem
- ,"containers"
- ,"directory"
- --,"editline"
- ,"filepath" -- intentionally no ebuild. use ghc's version
- ,"ghc"
- ,"ghc-prim"
- ,"haskell98"
- ,"hpc" --has ebuild, but only in the overlay
- ,"integer" -- up to ghc-6.10
- ,"integer-gmp" -- ghc-6.12+
- ,"old-locale"
- ,"old-time"
- ,"packedstring"
- ,"pretty"
- ,"process"
- -- ,"random" -- not a core package since ghc-7.2
- ,"rts"
- -- ,"syb" -- was splitted off from ghc again
- ,"template-haskell"
- ,"unix" -- unsafe to upgrade
- ]
diff --git a/CacheFile.hs b/CacheFile.hs
deleted file mode 100644
index 4569ca3..0000000
--- a/CacheFile.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-module CacheFile where
-
-import System.FilePath
-
-indexFile :: String
-indexFile = "00-index.tar.gz"
-
-hackportDir :: String
-hackportDir = ".hackport"
-
-cacheFile :: FilePath -> FilePath
-cacheFile tree = tree </> hackportDir </> indexFile
diff --git a/Diff.hs b/Diff.hs
deleted file mode 100644
index 9f1559e..0000000
--- a/Diff.hs
+++ /dev/null
@@ -1,188 +0,0 @@
-module Diff
- ( runDiff
- , DiffMode(..)
- ) where
-
-import Control.Monad ( mplus )
-import Control.Exception ( assert )
-import Data.Maybe ( fromJust, listToMaybe )
-import Data.List ( sortBy, groupBy )
-import Data.Ord ( comparing )
-
-import qualified Portage.Overlay as Portage
-import qualified Portage.Cabal as Portage
-import qualified Portage.PackageId as Portage
-
-import qualified Data.Version as Cabal
-
--- cabal
-import Distribution.Verbosity
-import Distribution.Text(display)
-import qualified Distribution.Package as Cabal
-import qualified Distribution.Client.PackageIndex as Index
-import Distribution.Simple.Utils (equating)
-
--- cabal-install
-import qualified Distribution.Client.IndexUtils as Index (getSourcePackages)
-import qualified Distribution.Client.Types as Cabal
-import Distribution.Client.Utils (mergeBy, MergeResult(..))
-
-data DiffMode
- = ShowAll
- | ShowMissing
- | ShowAdditions
- | ShowNewer
- | ShowCommon
- | ShowPackages [String]
- deriving Eq
-
-
-{-
-type DiffState a = MergeResult a a
-tabs :: String -> String
-tabs str = let len = length str in str++(if len < 3*8
- then replicate (3*8-len) ' '
- else "")
-
-
--- TODO: is the new showPackageCompareInfo showing the packages in the same
--- way as showDiffState did?
-
-showDiffState :: Cabal.PackageName -> DiffState Portage.Version -> String
-showDiffState pkg st = (tabs (display pkg)) ++ " [" ++ (case st of
- InBoth x y -> display x ++ (case compare x y of
- EQ -> "="
- GT -> ">"
- LT -> "<") ++ display y
- OnlyInLeft x -> display x ++ ">none"
- OnlyInRight y -> "none<" ++ display y) ++ "]"
--}
-
-runDiff :: Verbosity -> FilePath -> DiffMode -> Cabal.Repo -> IO ()
-runDiff verbosity overlayPath dm repo = do
- -- get package list from hackage
- pkgDB <- Index.getSourcePackages verbosity [ repo ]
- let (Cabal.SourcePackageDb hackageIndex _) = pkgDB
-
- -- get package list from the overlay
- overlay0 <- (Portage.loadLazy overlayPath)
- let overlayIndex = Portage.fromOverlay (Portage.reduceOverlay overlay0)
-
- let (subHackage, subOverlay)
- = case dm of
- ShowPackages pkgs ->
- (concatMap (concatMap snd . Index.searchByNameSubstring hackageIndex) pkgs
- ,concatMap (concatMap snd . Index.searchByNameSubstring overlayIndex) pkgs)
- _ ->
- (Index.allPackages hackageIndex
- ,Index.allPackages overlayIndex)
- diff subHackage subOverlay dm
-
-data PackageCompareInfo = PackageCompareInfo {
- name :: Cabal.PackageName,
--- hackageVersions :: [ Cabal.Version ],
--- overlayVersions :: [ Cabal.Version ]
- hackageVersion :: Maybe Cabal.Version,
- overlayVersion :: Maybe Cabal.Version
- } deriving Show
-
-showPackageCompareInfo :: PackageCompareInfo -> String
-showPackageCompareInfo pkgCmpInfo =
- display (name pkgCmpInfo) ++ " ["
- ++ hackageS ++ sign ++ overlayS ++ "]"
- where
- overlay = overlayVersion pkgCmpInfo
- hackage = hackageVersion pkgCmpInfo
- hackageS = maybe "none" display hackage
- overlayS = maybe "none" display overlay
- sign = case compare hackage overlay of
- EQ -> "="
- GT -> ">"
- LT -> "<"
-
-diff :: [Cabal.SourcePackage]
- -> [Portage.ExistingEbuild]
- -> DiffMode
- -> IO ()
-diff hackage overlay dm = do
- mapM_ (putStrLn . showPackageCompareInfo) pkgCmpInfos
- where
- merged = mergePackages (map (Portage.normalizeCabalPackageId . Cabal.packageId) hackage)
- (map Portage.ebuildCabalId overlay)
- pkgCmpInfos = filter pkgFilter (map (uncurry mergePackageInfo) merged)
- pkgFilter :: PackageCompareInfo -> Bool
- pkgFilter pkgCmpInfo =
- let om = overlayVersion pkgCmpInfo
- hm = hackageVersion pkgCmpInfo
- st = case (om,hm) of
- (Just ov, Just hv) -> InBoth ov hv
- (Nothing, Just hv) -> OnlyInRight hv
- (Just ov, Nothing) -> OnlyInLeft ov
- _ -> error "impossible"
- in
- case dm of
- ShowAll -> True
- ShowPackages _ -> True -- already filtered
- ShowNewer -> case st of
- InBoth o h -> h>o
- _ -> False
- ShowMissing -> case st of
- OnlyInLeft _ -> False
- InBoth x y -> x < y
- OnlyInRight _ -> True
- ShowAdditions -> case st of
- OnlyInLeft _ -> True
- InBoth x y -> x > y
- OnlyInRight _ -> False
- ShowCommon -> case st of
- OnlyInLeft _ -> False
- InBoth x y -> x == y
- OnlyInRight _ -> False
-
--- | We get the 'PackageCompareInfo' by combining the info for the overlay
--- and hackage versions of a package.
---
--- * We're building info about a various versions of a single named package so
--- the input package info records are all supposed to refer to the same
--- package name.
---
-mergePackageInfo :: [Cabal.PackageIdentifier]
- -> [Cabal.PackageIdentifier]
- -> PackageCompareInfo
-mergePackageInfo hackage overlay =
- assert (length overlay + length hackage > 0) $
- PackageCompareInfo {
- name = combine Cabal.pkgName latestHackage
- Cabal.pkgName latestOverlay,
--- hackageVersions = map Cabal.pkgVersion hackage,
--- overlayVersions = map Cabal.pkgVersion overlay
- hackageVersion = fmap Cabal.pkgVersion latestHackage,
- overlayVersion = fmap Cabal.pkgVersion latestOverlay
- }
- where
- combine f x g y = fromJust (fmap f x `mplus` fmap g y)
- latestHackage = latestOf hackage
- latestOverlay = latestOf overlay
- latestOf :: [Cabal.PackageIdentifier] -> Maybe Cabal.PackageIdentifier
- latestOf = listToMaybe . reverse . sortBy (comparing Cabal.pkgVersion)
-
--- | Rearrange installed and available packages into groups referring to the
--- same package by name. In the result pairs, the lists are guaranteed to not
--- both be empty.
---
-mergePackages :: [Cabal.PackageIdentifier] -> [Cabal.PackageIdentifier]
- -> [([Cabal.PackageIdentifier], [Cabal.PackageIdentifier])]
-mergePackages hackage overlay =
- map collect
- $ mergeBy (\i a -> fst i `compare` fst a)
- (groupOn Cabal.pkgName hackage)
- (groupOn Cabal.pkgName overlay)
- where
- collect (OnlyInLeft (_,is) ) = (is, [])
- collect ( InBoth (_,is) (_,as)) = (is, as)
- collect (OnlyInRight (_,as)) = ([], as)
-
-groupOn :: Ord key => (a -> key) -> [a] -> [(key,[a])]
-groupOn key = map (\xs -> (key (head xs), xs))
- . groupBy (equating key)
- . sortBy (comparing key)
diff --git a/DistroMap.hs b/DistroMap.hs
deleted file mode 100644
index 0e34294..0000000
--- a/DistroMap.hs
+++ /dev/null
@@ -1,158 +0,0 @@
-{-# OPTIONS -XPatternGuards #-}
-{-
-Generate a distromap, like these:
-http://hackage.haskell.org/packages/archive/00-distromap/
-Format:
-
-("xmobar","0.8",Just "http://packages.gentoo.org/package/x11-misc/xmobar")
-("xmobar","0.9",Just "http://packages.gentoo.org/package/x11-misc/xmobar")
-("xmobar","0.9.2",Just "http://packages.gentoo.org/package/x11-misc/xmobar")
-("xmonad","0.5",Just "http://packages.gentoo.org/package/x11-wm/xmonad")
-("xmonad","0.6",Just "http://packages.gentoo.org/package/x11-wm/xmonad")
-("xmonad","0.7",Just "http://packages.gentoo.org/package/x11-wm/xmonad")
-("xmonad","0.8",Just "http://packages.gentoo.org/package/x11-wm/xmonad")
-("xmonad","0.8.1",Just "http://packages.gentoo.org/package/x11-wm/xmonad")
-("xmonad","0.9",Just "http://packages.gentoo.org/package/x11-wm/xmonad")
-("xmonad","0.9.1",Just "http://en.gentoo-wiki.com/wiki/Haskell/overlay")
-
-Multiple entries for each package is allowed, given that there are different versions.
-
-
-Setup:
- Join all packages from portage and the overlay into a big map;
- From Portage.PackageId: PackageName = category/package
- PVULine = (packagename, versionstring, url)
- Create such a map: Map PackageName DistroLine
- Only one PVULine per version, and prefer portage over the overlay.
-
-Algorithm;
- 1. Take a package from hackage
- 2. Look for it in the map
- a. For each version:
- find a match in the list of versions:
- yield the PVULine
--}
-
-module DistroMap
- ( distroMap ) where
-
-import Control.Applicative
-import qualified Data.List as List ( nub )
-import qualified Data.Map as Map
-import Data.Map ( Map )
-import System.FilePath ( (</>) )
-import Debug.Trace ( trace )
-import Data.Maybe ( fromJust )
-
-import Distribution.Verbosity
-import Distribution.Text ( display )
-import Distribution.Client.Types ( Repo, SourcePackageDb(..), SourcePackage(..) )
-import Distribution.Simple.Utils ( info )
-
-import qualified Data.Version as Cabal
-import qualified Distribution.Package as Cabal
-import qualified Distribution.Client.PackageIndex as CabalInstall
-import qualified Distribution.Client.IndexUtils as CabalInstall
-
-import Portage.Overlay ( readOverlayByPackage, getDirectoryTree )
-import qualified Portage.PackageId as Portage
-import qualified Portage.Version as Portage
-
-type PVU = (Cabal.PackageName, Cabal.Version, Maybe String)
-type PVU_Map = Map Portage.PackageName [(Cabal.Version, Maybe String)]
-
-distroMap :: Verbosity -> Repo -> FilePath -> FilePath -> [String] -> IO ()
-distroMap verbosity repo portagePath overlayPath args = do
- info verbosity "distro map called"
- info verbosity ("verbosity: " ++ show verbosity)
- info verbosity ("portage: " ++ portagePath)
- info verbosity ("overlay: " ++ overlayPath)
- info verbosity ("args: " ++ show args)
-
- portage <- readOverlayByPackage <$> getDirectoryTree portagePath
- overlay <- readOverlayByPackage <$> getDirectoryTree overlayPath
-
- info verbosity ("portage packages: " ++ show (length portage))
- info verbosity ("overlay packages: " ++ show (length overlay))
-
- let portageMap = buildPortageMap portage
- overlayMap = buildOverlayMap overlay
- completeMap = unionMap portageMap overlayMap
-
- info verbosity ("portage map: " ++ show (Map.size portageMap))
- info verbosity ("overlay map: " ++ show (Map.size overlayMap))
- info verbosity ("complete map: " ++ show (Map.size completeMap))
-
- SourcePackageDb { packageIndex = packageIndex } <-
- CabalInstall.getSourcePackages verbosity [repo]
-
- let pkgs0 = map (map packageInfoId) (CabalInstall.allPackagesByName packageIndex)
- hackagePkgs = [ (Cabal.pkgName (head p), map Cabal.pkgVersion p) | p <- pkgs0 ]
-
- info verbosity ("cabal packages: " ++ show (length hackagePkgs))
-
- let pvus = concat $ map (\(p,vs) -> lookupPVU completeMap p vs) hackagePkgs
- info verbosity ("found pvus: " ++ show (length pvus))
-
- mapM_ (putStrLn . showPVU) pvus
- return ()
-
-
-showPVU :: PVU -> String
-showPVU (p,v,u) = show $ (display p, display v, u)
-
--- building the PVU_Map
-
-reduceVersion :: Portage.Version -> Portage.Version
-reduceVersion (Portage.Version ns _ _ _) = Portage.Version ns Nothing [] 0
-
-reduceVersions :: [Portage.Version] -> [Portage.Version]
-reduceVersions = List.nub . map reduceVersion
-
-buildMap :: [(Portage.PackageName, [Portage.Version])]
- -> (Portage.PackageName -> Portage.Version -> Maybe String)
- -> PVU_Map
-buildMap pvs f = Map.mapWithKey (\p vs -> [ (fromJust $ Portage.toCabalVersion v, f p v)
- | v <- reduceVersions vs ])
- (Map.fromList pvs)
-
-buildPortageMap :: [(Portage.PackageName, [Portage.Version])] -> PVU_Map
-buildPortageMap lst = buildMap lst $ \ (Portage.PackageName c p) _v ->
- Just $ "http://packages.gentoo.org/package" </> display c </> display p
-
-buildOverlayMap :: [(Portage.PackageName, [Portage.Version])] -> PVU_Map
-buildOverlayMap lst = buildMap lst $ \_ _ -> Just "http://en.gentoo-wiki.com/wiki/Haskell/overlay"
-
-unionMap :: PVU_Map -> PVU_Map -> PVU_Map
-unionMap = Map.unionWith f
- where
- f :: [(Cabal.Version, Maybe String)]
- -> [(Cabal.Version, Maybe String)]
- -> [(Cabal.Version, Maybe String)]
- f vas vbs = Map.toList (Map.union (Map.fromList vas) (Map.fromList vbs))
-
-
--- resolving Cabal.PackageName to Portage.PackageName
-
-lookupPVU :: PVU_Map -> Cabal.PackageName -> [Cabal.Version] -> [PVU]
-lookupPVU pvu_map pn cvs =
- case findItems pvu_map (Portage.normalizeCabalPackageName pn) of
- [] -> []
- [item] -> ret item
- items | [item] <- preferableItem items -> ret item
- | otherwise -> trace (noDefaultText items) []
- where
- noDefaultText is = unlines $ ("no default for package: " ++ display pn)
- : [ " * " ++ (display cat)
- | (Portage.PackageName cat _, _) <- is]
-
- ret (_, vs) = [ (pn, v, u) | (v, u) <- vs, v `elem` cvs ]
- preferableItem items =
- [ item
- | item@(Portage.PackageName cat _pn, _vs) <- items
- , cat == Portage.Category "dev-haskell"]
- findItems pvu_map cpn = Map.toList $ Map.filterWithKey f pvu_map
- where
- f (Portage.PackageName _cat pn) _vs = cpn == pn
-
-
diff --git a/Error.hs b/Error.hs
deleted file mode 100644
index c0ff2d1..0000000
--- a/Error.hs
+++ /dev/null
@@ -1,63 +0,0 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-
-module Error (HackPortError(..), throwEx, catchEx, hackPortShowError) where
-
-import Data.Typeable
-import Control.Exception.Extensible as EE
-import Control.Monad.Error
-
-data HackPortError
- = ArgumentError String
- | ConnectionFailed String String
- | PackageNotFound String
- | InvalidTarballURL String String
- | InvalidSignatureURL String String
- | VerificationFailed String String
- | DownloadFailed String String
- | UnknownCompression String
- | UnpackingFailed String Int
- | NoCabalFound String
- | ExtractionFailed String String Int
- | CabalParseFailed String String
- | BashNotFound
- | BashError String
- | NoOverlay
- | MultipleOverlays [String]
- | UnknownVerbosityLevel String
- -- | WrongCacheVersion
- -- | InvalidCache
- | InvalidServer String
- deriving (Typeable, Show)
-
-instance Error HackPortError where
-
-instance Exception HackPortError where
-
-throwEx :: HackPortError -> IO a
-throwEx = EE.throw
-
-catchEx :: IO a -> (HackPortError -> IO a) -> IO a
-catchEx = EE.catch
-
-hackPortShowError :: HackPortError -> String
-hackPortShowError err = case err of
- ArgumentError str -> "Argument error: "++str
- ConnectionFailed server reason -> "Connection to hackage server '"++server++"' failed: "++reason
- PackageNotFound pkg -> "Package '"++ pkg ++"' not found on server. Try 'hackport update'?"
- InvalidTarballURL url reason -> "Error while downloading tarball '"++url++"': "++reason
- InvalidSignatureURL url reason -> "Error while downloading signature '"++url++"': "++reason
- VerificationFailed file signature -> "Error while checking signature('"++signature++"') of '"++file++"'"
- DownloadFailed url reason -> "Error while downloading '"++url++"': "++reason
- UnknownCompression tarball -> "Couldn't guess compression type of '"++tarball++"'"
- UnpackingFailed tarball code -> "Unpacking '"++tarball++"' failed with exit code '"++show code++"'"
- NoCabalFound tarball -> "Tarball '"++tarball++"' doesn't contain a cabal file"
- ExtractionFailed tarball file code -> "Extracting '"++file++"' from '"++tarball++"' failed with '"++show code++"'"
- CabalParseFailed file reason -> "Error while parsing cabal file '"++file++"': "++reason
- BashNotFound -> "The 'bash' executable was not found. It is required to figure out your portage-overlay. If you don't want to install bash, use '-p path-to-overlay'"
- BashError str -> "Error while guessing your portage-overlay. Either set PORTDIR_OVERLAY in /etc/make.conf or use '-p path-to-overlay'.\nThe error was: \""++str++"\""
- MultipleOverlays overlays -> "You have the following overlays available: '"++unwords overlays++"'. Please choose one by using 'hackport -p path-to-overlay' <command>"
- NoOverlay -> "You don't have PORTDIR_OVERLAY set in '/etc/make.conf'. Please set it or use '-p path-to-overlay'"
- UnknownVerbosityLevel str -> "The verbosity level '"++str++"' is invalid. Please use debug,normal or silent"
- InvalidServer srv -> "Invalid server address, could not parse: " ++ srv
- --WrongCacheVersion -> "The version of the cache is too old. Please update the cache using 'hackport update'"
- --InvalidCache -> "Could not read the cache. Please ensure that it's up to date using 'hackport update'"
diff --git a/Hackage.hs b/Hackage.hs
deleted file mode 100644
index 57a5db2..0000000
--- a/Hackage.hs
+++ /dev/null
@@ -1,32 +0,0 @@
-{-|
- Author : Sergei Trofimovich <slyfox@gentoo.org>
- Stability : experimental
- Portability : haskell98
-
- Utilities to work with hackage-alike repositories
--}
-module Hackage
- ( defaultRepo
- , defaultRepoURI
- ) where
-
-import Distribution.Client.Types (Repo(..), RemoteRepo(..))
-import Network.URI (URI(..), URIAuth(..))
-import System.FilePath
-
-defaultRepo :: FilePath -> Repo
-defaultRepo overlayPath =
- Repo {
- repoKind = Left hackage,
- repoLocalDir = overlayPath </> ".hackport"
- }
- where
- hackage = RemoteRepo server_name uri
- server_name = "hackage.haskell.org"
- uri = URI "http:" (Just (URIAuth "" server_name "")) "/packages/archive" "" ""
-
-defaultRepoURI :: FilePath -> URI
-defaultRepoURI overlayPath =
- case repoKind (defaultRepo overlayPath) of
- Left (RemoteRepo { remoteRepoURI = uri }) -> uri
- Right _ -> error $ "defaultRepoURI: unable to get URI for " ++ overlayPath
diff --git a/LICENSE b/LICENSE
deleted file mode 100644
index 94a9ed0..0000000
--- a/LICENSE
+++ /dev/null
@@ -1,674 +0,0 @@
- GNU GENERAL PUBLIC LICENSE
- Version 3, 29 June 2007
-
- Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
- Everyone is permitted to copy and distribute verbatim copies
- of this license document, but changing it is not allowed.
-
- Preamble
-
- The GNU General Public License is a free, copyleft license for
-software and other kinds of works.
-
- The licenses for most software and other practical works are designed
-to take away your freedom to share and change the works. By contrast,
-the GNU General Public License is intended to guarantee your freedom to
-share and change all versions of a program--to make sure it remains free
-software for all its users. We, the Free Software Foundation, use the
-GNU General Public License for most of our software; it applies also to
-any other work released this way by its authors. You can apply it to
-your programs, too.
-
- When we speak of free software, we are referring to freedom, not
-price. Our General Public Licenses are designed to make sure that you
-have the freedom to distribute copies of free software (and charge for
-them if you wish), that you receive source code or can get it if you
-want it, that you can change the software or use pieces of it in new
-free programs, and that you know you can do these things.
-
- To protect your rights, we need to prevent others from denying you
-these rights or asking you to surrender the rights. Therefore, you have
-certain responsibilities if you distribute copies of the software, or if
-you modify it: responsibilities to respect the freedom of others.
-
- For example, if you distribute copies of such a program, whether
-gratis or for a fee, you must pass on to the recipients the same
-freedoms that you received. You must make sure that they, too, receive
-or can get the source code. And you must show them these terms so they
-know their rights.
-
- Developers that use the GNU GPL protect your rights with two steps:
-(1) assert copyright on the software, and (2) offer you this License
-giving you legal permission to copy, distribute and/or modify it.
-
- For the developers' and authors' protection, the GPL clearly explains
-that there is no warranty for this free software. For both users' and
-authors' sake, the GPL requires that modified versions be marked as
-changed, so that their problems will not be attributed erroneously to
-authors of previous versions.
-
- Some devices are designed to deny users access to install or run
-modified versions of the software inside them, although the manufacturer
-can do so. This is fundamentally incompatible with the aim of
-protecting users' freedom to change the software. The systematic
-pattern of such abuse occurs in the area of products for individuals to
-use, which is precisely where it is most unacceptable. Therefore, we
-have designed this version of the GPL to prohibit the practice for those
-products. If such problems arise substantially in other domains, we
-stand ready to extend this provision to those domains in future versions
-of the GPL, as needed to protect the freedom of users.
-
- Finally, every program is threatened constantly by software patents.
-States should not allow patents to restrict development and use of
-software on general-purpose computers, but in those that do, we wish to
-avoid the special danger that patents applied to a free program could
-make it effectively proprietary. To prevent this, the GPL assures that
-patents cannot be used to render the program non-free.
-
- The precise terms and conditions for copying, distribution and
-modification follow.
-
- TERMS AND CONDITIONS
-
- 0. Definitions.
-
- "This License" refers to version 3 of the GNU General Public License.
-
- "Copyright" also means copyright-like laws that apply to other kinds of
-works, such as semiconductor masks.
-
- "The Program" refers to any copyrightable work licensed under this
-License. Each licensee is addressed as "you". "Licensees" and
-"recipients" may be individuals or organizations.
-
- To "modify" a work means to copy from or adapt all or part of the work
-in a fashion requiring copyright permission, other than the making of an
-exact copy. The resulting work is called a "modified version" of the
-earlier work or a work "based on" the earlier work.
-
- A "covered work" means either the unmodified Program or a work based
-on the Program.
-
- To "propagate" a work means to do anything with it that, without
-permission, would make you directly or secondarily liable for
-infringement under applicable copyright law, except executing it on a
-computer or modifying a private copy. Propagation includes copying,
-distribution (with or without modification), making available to the
-public, and in some countries other activities as well.
-
- To "convey" a work means any kind of propagation that enables other
-parties to make or receive copies. Mere interaction with a user through
-a computer network, with no transfer of a copy, is not conveying.
-
- An interactive user interface displays "Appropriate Legal Notices"
-to the extent that it includes a convenient and prominently visible
-feature that (1) displays an appropriate copyright notice, and (2)
-tells the user that there is no warranty for the work (except to the
-extent that warranties are provided), that licensees may convey the
-work under this License, and how to view a copy of this License. If
-the interface presents a list of user commands or options, such as a
-menu, a prominent item in the list meets this criterion.
-
- 1. Source Code.
-
- The "source code" for a work means the preferred form of the work
-for making modifications to it. "Object code" means any non-source
-form of a work.
-
- A "Standard Interface" means an interface that either is an official
-standard defined by a recognized standards body, or, in the case of
-interfaces specified for a particular programming language, one that
-is widely used among developers working in that language.
-
- The "System Libraries" of an executable work include anything, other
-than the work as a whole, that (a) is included in the normal form of
-packaging a Major Component, but which is not part of that Major
-Component, and (b) serves only to enable use of the work with that
-Major Component, or to implement a Standard Interface for which an
-implementation is available to the public in source code form. A
-"Major Component", in this context, means a major essential component
-(kernel, window system, and so on) of the specific operating system
-(if any) on which the executable work runs, or a compiler used to
-produce the work, or an object code interpreter used to run it.
-
- The "Corresponding Source" for a work in object code form means all
-the source code needed to generate, install, and (for an executable
-work) run the object code and to modify the work, including scripts to
-control those activities. However, it does not include the work's
-System Libraries, or general-purpose tools or generally available free
-programs which are used unmodified in performing those activities but
-which are not part of the work. For example, Corresponding Source
-includes interface definition files associated with source files for
-the work, and the source code for shared libraries and dynamically
-linked subprograms that the work is specifically designed to require,
-such as by intimate data communication or control flow between those
-subprograms and other parts of the work.
-
- The Corresponding Source need not include anything that users
-can regenerate automatically from other parts of the Corresponding
-Source.
-
- The Corresponding Source for a work in source code form is that
-same work.
-
- 2. Basic Permissions.
-
- All rights granted under this License are granted for the term of
-copyright on the Program, and are irrevocable provided the stated
-conditions are met. This License explicitly affirms your unlimited
-permission to run the unmodified Program. The output from running a
-covered work is covered by this License only if the output, given its
-content, constitutes a covered work. This License acknowledges your
-rights of fair use or other equivalent, as provided by copyright law.
-
- You may make, run and propagate covered works that you do not
-convey, without conditions so long as your license otherwise remains
-in force. You may convey covered works to others for the sole purpose
-of having them make modifications exclusively for you, or provide you
-with facilities for running those works, provided that you comply with
-the terms of this License in conveying all material for which you do
-not control copyright. Those thus making or running the covered works
-for you must do so exclusively on your behalf, under your direction
-and control, on terms that prohibit them from making any copies of
-your copyrighted material outside their relationship with you.
-
- Conveying under any other circumstances is permitted solely under
-the conditions stated below. Sublicensing is not allowed; section 10
-makes it unnecessary.
-
- 3. Protecting Users' Legal Rights From Anti-Circumvention Law.
-
- No covered work shall be deemed part of an effective technological
-measure under any applicable law fulfilling obligations under article
-11 of the WIPO copyright treaty adopted on 20 December 1996, or
-similar laws prohibiting or restricting circumvention of such
-measures.
-
- When you convey a covered work, you waive any legal power to forbid
-circumvention of technological measures to the extent such circumvention
-is effected by exercising rights under this License with respect to
-the covered work, and you disclaim any intention to limit operation or
-modification of the work as a means of enforcing, against the work's
-users, your or third parties' legal rights to forbid circumvention of
-technological measures.
-
- 4. Conveying Verbatim Copies.
-
- You may convey verbatim copies of the Program's source code as you
-receive it, in any medium, provided that you conspicuously and
-appropriately publish on each copy an appropriate copyright notice;
-keep intact all notices stating that this License and any
-non-permissive terms added in accord with section 7 apply to the code;
-keep intact all notices of the absence of any warranty; and give all
-recipients a copy of this License along with the Program.
-
- You may charge any price or no price for each copy that you convey,
-and you may offer support or warranty protection for a fee.
-
- 5. Conveying Modified Source Versions.
-
- You may convey a work based on the Program, or the modifications to
-produce it from the Program, in the form of source code under the
-terms of section 4, provided that you also meet all of these conditions:
-
- a) The work must carry prominent notices stating that you modified
- it, and giving a relevant date.
-
- b) The work must carry prominent notices stating that it is
- released under this License and any conditions added under section
- 7. This requirement modifies the requirement in section 4 to
- "keep intact all notices".
-
- c) You must license the entire work, as a whole, under this
- License to anyone who comes into possession of a copy. This
- License will therefore apply, along with any applicable section 7
- additional terms, to the whole of the work, and all its parts,
- regardless of how they are packaged. This License gives no
- permission to license the work in any other way, but it does not
- invalidate such permission if you have separately received it.
-
- d) If the work has interactive user interfaces, each must display
- Appropriate Legal Notices; however, if the Program has interactive
- interfaces that do not display Appropriate Legal Notices, your
- work need not make them do so.
-
- A compilation of a covered work with other separate and independent
-works, which are not by their nature extensions of the covered work,
-and which are not combined with it such as to form a larger program,
-in or on a volume of a storage or distribution medium, is called an
-"aggregate" if the compilation and its resulting copyright are not
-used to limit the access or legal rights of the compilation's users
-beyond what the individual works permit. Inclusion of a covered work
-in an aggregate does not cause this License to apply to the other
-parts of the aggregate.
-
- 6. Conveying Non-Source Forms.
-
- You may convey a covered work in object code form under the terms
-of sections 4 and 5, provided that you also convey the
-machine-readable Corresponding Source under the terms of this License,
-in one of these ways:
-
- a) Convey the object code in, or embodied in, a physical product
- (including a physical distribution medium), accompanied by the
- Corresponding Source fixed on a durable physical medium
- customarily used for software interchange.
-
- b) Convey the object code in, or embodied in, a physical product
- (including a physical distribution medium), accompanied by a
- written offer, valid for at least three years and valid for as
- long as you offer spare parts or customer support for that product
- model, to give anyone who possesses the object code either (1) a
- copy of the Corresponding Source for all the software in the
- product that is covered by this License, on a durable physical
- medium customarily used for software interchange, for a price no
- more than your reasonable cost of physically performing this
- conveying of source, or (2) access to copy the
- Corresponding Source from a network server at no charge.
-
- c) Convey individual copies of the object code with a copy of the
- written offer to provide the Corresponding Source. This
- alternative is allowed only occasionally and noncommercially, and
- only if you received the object code with such an offer, in accord
- with subsection 6b.
-
- d) Convey the object code by offering access from a designated
- place (gratis or for a charge), and offer equivalent access to the
- Corresponding Source in the same way through the same place at no
- further charge. You need not require recipients to copy the
- Corresponding Source along with the object code. If the place to
- copy the object code is a network server, the Corresponding Source
- may be on a different server (operated by you or a third party)
- that supports equivalent copying facilities, provided you maintain
- clear directions next to the object code saying where to find the
- Corresponding Source. Regardless of what server hosts the
- Corresponding Source, you remain obligated to ensure that it is
- available for as long as needed to satisfy these requirements.
-
- e) Convey the object code using peer-to-peer transmission, provided
- you inform other peers where the object code and Corresponding
- Source of the work are being offered to the general public at no
- charge under subsection 6d.
-
- A separable portion of the object code, whose source code is excluded
-from the Corresponding Source as a System Library, need not be
-included in conveying the object code work.
-
- A "User Product" is either (1) a "consumer product", which means any
-tangible personal property which is normally used for personal, family,
-or household purposes, or (2) anything designed or sold for incorporation
-into a dwelling. In determining whether a product is a consumer product,
-doubtful cases shall be resolved in favor of coverage. For a particular
-product received by a particular user, "normally used" refers to a
-typical or common use of that class of product, regardless of the status
-of the particular user or of the way in which the particular user
-actually uses, or expects or is expected to use, the product. A product
-is a consumer product regardless of whether the product has substantial
-commercial, industrial or non-consumer uses, unless such uses represent
-the only significant mode of use of the product.
-
- "Installation Information" for a User Product means any methods,
-procedures, authorization keys, or other information required to install
-and execute modified versions of a covered work in that User Product from
-a modified version of its Corresponding Source. The information must
-suffice to ensure that the continued functioning of the modified object
-code is in no case prevented or interfered with solely because
-modification has been made.
-
- If you convey an object code work under this section in, or with, or
-specifically for use in, a User Product, and the conveying occurs as
-part of a transaction in which the right of possession and use of the
-User Product is transferred to the recipient in perpetuity or for a
-fixed term (regardless of how the transaction is characterized), the
-Corresponding Source conveyed under this section must be accompanied
-by the Installation Information. But this requirement does not apply
-if neither you nor any third party retains the ability to install
-modified object code on the User Product (for example, the work has
-been installed in ROM).
-
- The requirement to provide Installation Information does not include a
-requirement to continue to provide support service, warranty, or updates
-for a work that has been modified or installed by the recipient, or for
-the User Product in which it has been modified or installed. Access to a
-network may be denied when the modification itself materially and
-adversely affects the operation of the network or violates the rules and
-protocols for communication across the network.
-
- Corresponding Source conveyed, and Installation Information provided,
-in accord with this section must be in a format that is publicly
-documented (and with an implementation available to the public in
-source code form), and must require no special password or key for
-unpacking, reading or copying.
-
- 7. Additional Terms.
-
- "Additional permissions" are terms that supplement the terms of this
-License by making exceptions from one or more of its conditions.
-Additional permissions that are applicable to the entire Program shall
-be treated as though they were included in this License, to the extent
-that they are valid under applicable law. If additional permissions
-apply only to part of the Program, that part may be used separately
-under those permissions, but the entire Program remains governed by
-this License without regard to the additional permissions.
-
- When you convey a copy of a covered work, you may at your option
-remove any additional permissions from that copy, or from any part of
-it. (Additional permissions may be written to require their own
-removal in certain cases when you modify the work.) You may place
-additional permissions on material, added by you to a covered work,
-for which you have or can give appropriate copyright permission.
-
- Notwithstanding any other provision of this License, for material you
-add to a covered work, you may (if authorized by the copyright holders of
-that material) supplement the terms of this License with terms:
-
- a) Disclaiming warranty or limiting liability differently from the
- terms of sections 15 and 16 of this License; or
-
- b) Requiring preservation of specified reasonable legal notices or
- author attributions in that material or in the Appropriate Legal
- Notices displayed by works containing it; or
-
- c) Prohibiting misrepresentation of the origin of that material, or
- requiring that modified versions of such material be marked in
- reasonable ways as different from the original version; or
-
- d) Limiting the use for publicity purposes of names of licensors or
- authors of the material; or
-
- e) Declining to grant rights under trademark law for use of some
- trade names, trademarks, or service marks; or
-
- f) Requiring indemnification of licensors and authors of that
- material by anyone who conveys the material (or modified versions of
- it) with contractual assumptions of liability to the recipient, for
- any liability that these contractual assumptions directly impose on
- those licensors and authors.
-
- All other non-permissive additional terms are considered "further
-restrictions" within the meaning of section 10. If the Program as you
-received it, or any part of it, contains a notice stating that it is
-governed by this License along with a term that is a further
-restriction, you may remove that term. If a license document contains
-a further restriction but permits relicensing or conveying under this
-License, you may add to a covered work material governed by the terms
-of that license document, provided that the further restriction does
-not survive such relicensing or conveying.
-
- If you add terms to a covered work in accord with this section, you
-must place, in the relevant source files, a statement of the
-additional terms that apply to those files, or a notice indicating
-where to find the applicable terms.
-
- Additional terms, permissive or non-permissive, may be stated in the
-form of a separately written license, or stated as exceptions;
-the above requirements apply either way.
-
- 8. Termination.
-
- You may not propagate or modify a covered work except as expressly
-provided under this License. Any attempt otherwise to propagate or
-modify it is void, and will automatically terminate your rights under
-this License (including any patent licenses granted under the third
-paragraph of section 11).
-
- However, if you cease all violation of this License, then your
-license from a particular copyright holder is reinstated (a)
-provisionally, unless and until the copyright holder explicitly and
-finally terminates your license, and (b) permanently, if the copyright
-holder fails to notify you of the violation by some reasonable means
-prior to 60 days after the cessation.
-
- Moreover, your license from a particular copyright holder is
-reinstated permanently if the copyright holder notifies you of the
-violation by some reasonable means, this is the first time you have
-received notice of violation of this License (for any work) from that
-copyright holder, and you cure the violation prior to 30 days after
-your receipt of the notice.
-
- Termination of your rights under this section does not terminate the
-licenses of parties who have received copies or rights from you under
-this License. If your rights have been terminated and not permanently
-reinstated, you do not qualify to receive new licenses for the same
-material under section 10.
-
- 9. Acceptance Not Required for Having Copies.
-
- You are not required to accept this License in order to receive or
-run a copy of the Program. Ancillary propagation of a covered work
-occurring solely as a consequence of using peer-to-peer transmission
-to receive a copy likewise does not require acceptance. However,
-nothing other than this License grants you permission to propagate or
-modify any covered work. These actions infringe copyright if you do
-not accept this License. Therefore, by modifying or propagating a
-covered work, you indicate your acceptance of this License to do so.
-
- 10. Automatic Licensing of Downstream Recipients.
-
- Each time you convey a covered work, the recipient automatically
-receives a license from the original licensors, to run, modify and
-propagate that work, subject to this License. You are not responsible
-for enforcing compliance by third parties with this License.
-
- An "entity transaction" is a transaction transferring control of an
-organization, or substantially all assets of one, or subdividing an
-organization, or merging organizations. If propagation of a covered
-work results from an entity transaction, each party to that
-transaction who receives a copy of the work also receives whatever
-licenses to the work the party's predecessor in interest had or could
-give under the previous paragraph, plus a right to possession of the
-Corresponding Source of the work from the predecessor in interest, if
-the predecessor has it or can get it with reasonable efforts.
-
- You may not impose any further restrictions on the exercise of the
-rights granted or affirmed under this License. For example, you may
-not impose a license fee, royalty, or other charge for exercise of
-rights granted under this License, and you may not initiate litigation
-(including a cross-claim or counterclaim in a lawsuit) alleging that
-any patent claim is infringed by making, using, selling, offering for
-sale, or importing the Program or any portion of it.
-
- 11. Patents.
-
- A "contributor" is a copyright holder who authorizes use under this
-License of the Program or a work on which the Program is based. The
-work thus licensed is called the contributor's "contributor version".
-
- A contributor's "essential patent claims" are all patent claims
-owned or controlled by the contributor, whether already acquired or
-hereafter acquired, that would be infringed by some manner, permitted
-by this License, of making, using, or selling its contributor version,
-but do not include claims that would be infringed only as a
-consequence of further modification of the contributor version. For
-purposes of this definition, "control" includes the right to grant
-patent sublicenses in a manner consistent with the requirements of
-this License.
-
- Each contributor grants you a non-exclusive, worldwide, royalty-free
-patent license under the contributor's essential patent claims, to
-make, use, sell, offer for sale, import and otherwise run, modify and
-propagate the contents of its contributor version.
-
- In the following three paragraphs, a "patent license" is any express
-agreement or commitment, however denominated, not to enforce a patent
-(such as an express permission to practice a patent or covenant not to
-sue for patent infringement). To "grant" such a patent license to a
-party means to make such an agreement or commitment not to enforce a
-patent against the party.
-
- If you convey a covered work, knowingly relying on a patent license,
-and the Corresponding Source of the work is not available for anyone
-to copy, free of charge and under the terms of this License, through a
-publicly available network server or other readily accessible means,
-then you must either (1) cause the Corresponding Source to be so
-available, or (2) arrange to deprive yourself of the benefit of the
-patent license for this particular work, or (3) arrange, in a manner
-consistent with the requirements of this License, to extend the patent
-license to downstream recipients. "Knowingly relying" means you have
-actual knowledge that, but for the patent license, your conveying the
-covered work in a country, or your recipient's use of the covered work
-in a country, would infringe one or more identifiable patents in that
-country that you have reason to believe are valid.
-
- If, pursuant to or in connection with a single transaction or
-arrangement, you convey, or propagate by procuring conveyance of, a
-covered work, and grant a patent license to some of the parties
-receiving the covered work authorizing them to use, propagate, modify
-or convey a specific copy of the covered work, then the patent license
-you grant is automatically extended to all recipients of the covered
-work and works based on it.
-
- A patent license is "discriminatory" if it does not include within
-the scope of its coverage, prohibits the exercise of, or is
-conditioned on the non-exercise of one or more of the rights that are
-specifically granted under this License. You may not convey a covered
-work if you are a party to an arrangement with a third party that is
-in the business of distributing software, under which you make payment
-to the third party based on the extent of your activity of conveying
-the work, and under which the third party grants, to any of the
-parties who would receive the covered work from you, a discriminatory
-patent license (a) in connection with copies of the covered work
-conveyed by you (or copies made from those copies), or (b) primarily
-for and in connection with specific products or compilations that
-contain the covered work, unless you entered into that arrangement,
-or that patent license was granted, prior to 28 March 2007.
-
- Nothing in this License shall be construed as excluding or limiting
-any implied license or other defenses to infringement that may
-otherwise be available to you under applicable patent law.
-
- 12. No Surrender of Others' Freedom.
-
- If conditions are imposed on you (whether by court order, agreement or
-otherwise) that contradict the conditions of this License, they do not
-excuse you from the conditions of this License. If you cannot convey a
-covered work so as to satisfy simultaneously your obligations under this
-License and any other pertinent obligations, then as a consequence you may
-not convey it at all. For example, if you agree to terms that obligate you
-to collect a royalty for further conveying from those to whom you convey
-the Program, the only way you could satisfy both those terms and this
-License would be to refrain entirely from conveying the Program.
-
- 13. Use with the GNU Affero General Public License.
-
- Notwithstanding any other provision of this License, you have
-permission to link or combine any covered work with a work licensed
-under version 3 of the GNU Affero General Public License into a single
-combined work, and to convey the resulting work. The terms of this
-License will continue to apply to the part which is the covered work,
-but the special requirements of the GNU Affero General Public License,
-section 13, concerning interaction through a network will apply to the
-combination as such.
-
- 14. Revised Versions of this License.
-
- The Free Software Foundation may publish revised and/or new versions of
-the GNU General Public License from time to time. Such new versions will
-be similar in spirit to the present version, but may differ in detail to
-address new problems or concerns.
-
- Each version is given a distinguishing version number. If the
-Program specifies that a certain numbered version of the GNU General
-Public License "or any later version" applies to it, you have the
-option of following the terms and conditions either of that numbered
-version or of any later version published by the Free Software
-Foundation. If the Program does not specify a version number of the
-GNU General Public License, you may choose any version ever published
-by the Free Software Foundation.
-
- If the Program specifies that a proxy can decide which future
-versions of the GNU General Public License can be used, that proxy's
-public statement of acceptance of a version permanently authorizes you
-to choose that version for the Program.
-
- Later license versions may give you additional or different
-permissions. However, no additional obligations are imposed on any
-author or copyright holder as a result of your choosing to follow a
-later version.
-
- 15. Disclaimer of Warranty.
-
- THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
-APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
-HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
-OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
-THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
-PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
-IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
-ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
-
- 16. Limitation of Liability.
-
- IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
-WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
-THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
-GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
-USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
-DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
-PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
-EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
-SUCH DAMAGES.
-
- 17. Interpretation of Sections 15 and 16.
-
- If the disclaimer of warranty and limitation of liability provided
-above cannot be given local legal effect according to their terms,
-reviewing courts shall apply local law that most closely approximates
-an absolute waiver of all civil liability in connection with the
-Program, unless a warranty or assumption of liability accompanies a
-copy of the Program in return for a fee.
-
- END OF TERMS AND CONDITIONS
-
- How to Apply These Terms to Your New Programs
-
- If you develop a new program, and you want it to be of the greatest
-possible use to the public, the best way to achieve this is to make it
-free software which everyone can redistribute and change under these terms.
-
- To do so, attach the following notices to the program. It is safest
-to attach them to the start of each source file to most effectively
-state the exclusion of warranty; and each file should have at least
-the "copyright" line and a pointer to where the full notice is found.
-
- <one line to give the program's name and a brief idea of what it does.>
- Copyright (C) <year> <name of author>
-
- This program is free software: you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation, either version 3 of the License, or
- (at your option) any later version.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-Also add information on how to contact you by electronic and paper mail.
-
- If the program does terminal interaction, make it output a short
-notice like this when it starts in an interactive mode:
-
- <program> Copyright (C) <year> <name of author>
- This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
- This is free software, and you are welcome to redistribute it
- under certain conditions; type `show c' for details.
-
-The hypothetical commands `show w' and `show c' should show the appropriate
-parts of the General Public License. Of course, your program's commands
-might be different; for a GUI interface, you would use an "about box".
-
- You should also get your employer (if you work as a programmer) or school,
-if any, to sign a "copyright disclaimer" for the program, if necessary.
-For more information on this, and how to apply and follow the GNU GPL, see
-<http://www.gnu.org/licenses/>.
-
- The GNU General Public License does not permit incorporating your program
-into proprietary programs. If your program is a subroutine library, you
-may consider it more useful to permit linking proprietary applications with
-the library. If this is what you want to do, use the GNU Lesser General
-Public License instead of this License. But first, please read
-<http://www.gnu.org/philosophy/why-not-lgpl.html>.
diff --git a/Main-GuessGHC.hs b/Main-GuessGHC.hs
deleted file mode 100644
index 3eaf317..0000000
--- a/Main-GuessGHC.hs
+++ /dev/null
@@ -1,27 +0,0 @@
-module Main where
-
-import System.Environment
-
-import Distribution.PackageDescription
-import Distribution.PackageDescription.Parse
-
-import Distribution.Text
-import Distribution.Verbosity
-
-import Portage.GHCCore
-
-main :: IO ()
-main = do
- args <- getArgs
- gpds <- mapM (readPackageDescription silent) args
- mapM_ guess gpds
-
-guess :: GenericPackageDescription -> IO ()
-guess gpd = do
- let pkg = package . packageDescription $ gpd
- let mghc = minimumGHCVersionToBuildPackage gpd
- putStr (display pkg)
- putStr "\t\t"
- putStrLn $ case mghc of
- Nothing -> "Unknown"
- Just (compiler, _pkgs) -> display compiler
diff --git a/Main.hs b/Main.hs
deleted file mode 100644
index e6160a6..0000000
--- a/Main.hs
+++ /dev/null
@@ -1,558 +0,0 @@
-module Main where
-
-import Control.Applicative
-import Control.Monad
-import Data.Maybe
-import Data.List
-import Data.Monoid
- ( Monoid(..) )
-
--- cabal
-import Distribution.Simple.Setup
- ( Flag(..), fromFlag
- , trueArg
- , flagToList
- , optionVerbosity
- )
-import Distribution.ReadE ( succeedReadE )
-import Distribution.Simple.Command -- commandsRun
-import Distribution.Simple.Utils ( die, cabalVersion, warn )
-import qualified Distribution.PackageDescription.Parse as Cabal
-import qualified Distribution.Package as Cabal
-import Distribution.Verbosity (Verbosity, normal)
-import Distribution.Text (display, simpleParse)
-
-import Distribution.Client.Types
-import Distribution.Client.Update
-
-import qualified Distribution.Client.PackageIndex as Index
-import qualified Distribution.Client.IndexUtils as Index
-
-import Hackage (defaultRepo, defaultRepoURI)
-
-import Portage.Overlay as Overlay ( loadLazy, inOverlay )
-import Portage.Host as Host ( getInfo, portage_dir )
-import Portage.PackageId ( normalizeCabalPackageId )
-
-import Network.URI ( URI(..), parseURI )
-import System.Environment ( getArgs, getProgName )
-import System.Directory ( doesDirectoryExist )
-import System.Exit ( exitFailure )
-import System.FilePath ( (</>) )
-
-import Diff
-import Error
-import Status
-import Overlays
-import Merge
-import DistroMap ( distroMap )
-
-import qualified Paths_cabal_install
-import qualified Paths_hackport
-
------------------------------------------------------------------------
--- List
------------------------------------------------------------------------
-
-data ListFlags = ListFlags {
- listVerbosity :: Flag Verbosity
- -- , listOverlayPath :: Flag FilePath
- -- , listServerURI :: Flag String
- }
-
-instance Monoid ListFlags where
- mempty = ListFlags {
- listVerbosity = mempty
- -- , listOverlayPath = mempty
- -- , listServerURI = mempty
- }
- mappend a b = ListFlags {
- listVerbosity = combine listVerbosity
- -- , listOverlayPath = combine listOverlayPath
- -- , listServerURI = combine listServerURI
- }
- where combine field = field a `mappend` field b
-
-defaultListFlags :: ListFlags
-defaultListFlags = ListFlags {
- listVerbosity = Flag normal
- -- , listOverlayPath = NoFlag
- -- , listServerURI = Flag defaultHackageServerURI
- }
-
-listCommand :: CommandUI ListFlags
-listCommand = CommandUI {
- commandName = "list",
- commandSynopsis = "List packages",
- commandDescription = Just $ \_pname ->
- "TODO: this is the commandDescription for listCommand\n",
- commandUsage = usagePackages "list",
- commandDefaultFlags = defaultListFlags,
- commandOptions = \_showOrParseArgs ->
- [ optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v })
- {-
- , option [] ["overlay"]
- "Use cached packages list from specified overlay"
- listOverlayPath (\v flags -> flags { listOverlayPath = v })
- (reqArgFlag "PATH")
- -}
- ]
- }
-
-listAction :: ListFlags -> [String] -> GlobalFlags -> IO ()
-listAction flags extraArgs globalFlags = do
- let verbosity = fromFlag (listVerbosity flags)
- overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags)
- let repo = defaultRepo overlayPath
- index <- fmap packageIndex (Index.getSourcePackages verbosity [ repo ])
- overlay <- Overlay.loadLazy overlayPath
- let pkgs | null extraArgs = Index.allPackages index
- | otherwise = concatMap (concatMap snd . Index.searchByNameSubstring index) extraArgs
- normalized = map (normalizeCabalPackageId . packageInfoId) pkgs
- let decorated = map (\p -> (Overlay.inOverlay overlay p, p)) normalized
- mapM_ (putStrLn . pretty) decorated
- where
- pretty :: (Bool, Cabal.PackageIdentifier) -> String
- pretty (isInOverlay, pkgId) =
- let dec | isInOverlay = " * "
- | otherwise = " "
- in dec ++ display pkgId
-
-
------------------------------------------------------------------------
--- Make Ebuild
------------------------------------------------------------------------
-
-data MakeEbuildFlags = MakeEbuildFlags {
- makeEbuildVerbosity :: Flag Verbosity
- }
-
-instance Monoid MakeEbuildFlags where
- mempty = MakeEbuildFlags {
- makeEbuildVerbosity = mempty
- }
- mappend a b = MakeEbuildFlags {
- makeEbuildVerbosity = combine makeEbuildVerbosity
- }
- where combine field = field a `mappend` field b
-
-defaultMakeEbuildFlags :: MakeEbuildFlags
-defaultMakeEbuildFlags = MakeEbuildFlags {
- makeEbuildVerbosity = Flag normal
- }
-
-makeEbuildAction :: MakeEbuildFlags -> [String] -> GlobalFlags -> IO ()
-makeEbuildAction flags args globalFlags = do
- (catstr,cabals) <- case args of
- (category:cabal1:cabaln) -> return (category, cabal1:cabaln)
- _ -> throwEx (ArgumentError "make-ebuild needs at least two arguments. <category> <cabal-1> <cabal-n>")
- cat <- case simpleParse catstr of
- Just c -> return c
- Nothing -> throwEx (ArgumentError ("could not parse category: " ++ catstr))
- let verbosity = fromFlag (makeEbuildVerbosity flags)
- overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags)
- forM_ cabals $ \cabalFileName -> do
- pkg <- Cabal.readPackageDescription normal cabalFileName
- mergeGenericPackageDescription verbosity overlayPath cat pkg False
-
-makeEbuildCommand :: CommandUI MakeEbuildFlags
-makeEbuildCommand = CommandUI {
- commandName = "make-ebuild",
- commandSynopsis = "Make an ebuild from a .cabal file",
- commandDescription = Just $ \_pname ->
- "TODO: this is the commandDescription for makeEbuildCommand\n",
- commandUsage = \_ -> [],
- commandDefaultFlags = defaultMakeEbuildFlags,
- commandOptions = \_showOrParseArgs ->
- [ optionVerbosity makeEbuildVerbosity (\v flags -> flags { makeEbuildVerbosity = v })
- ]
- }
-
------------------------------------------------------------------------
--- Diff
------------------------------------------------------------------------
-
-data DiffFlags = DiffFlags {
- -- diffMode :: Flag String, -- DiffMode,
- diffVerbosity :: Flag Verbosity
- -- , diffServerURI :: Flag String
- }
-
-instance Monoid DiffFlags where
- mempty = DiffFlags {
- -- diffMode = mempty,
- diffVerbosity = mempty
- -- , diffServerURI = mempty
- }
- mappend a b = DiffFlags {
- -- diffMode = combine diffMode,
- diffVerbosity = combine diffVerbosity
- -- , diffServerURI = combine diffServerURI
- }
- where combine field = field a `mappend` field b
-
-defaultDiffFlags :: DiffFlags
-defaultDiffFlags = DiffFlags {
- -- diffMode = Flag "all",
- diffVerbosity = Flag normal
- -- , diffServerURI = Flag defaultHackageServerURI
- }
-
-diffCommand :: CommandUI DiffFlags
-diffCommand = CommandUI {
- commandName = "diff",
- commandSynopsis = "Run diff",
- commandDescription = Just $ \_pname ->
- "TODO: this is the commandDescription for diffCommand\n",
- commandUsage = usagePackages "diff",
- commandDefaultFlags = defaultDiffFlags,
- commandOptions = \_showOrParseArgs ->
- [ optionVerbosity diffVerbosity (\v flags -> flags { diffVerbosity = v })
- {-
- , option [] ["mode"]
- "Diff mode, one of: all, newer, missing, additions, common"
- diffMode (\v flags -> flags { diffMode = v })
- (reqArgFlag "MODE") -- I don't know how to map it strictly to DiffMode
- -}
- ]
- }
-
-diffAction :: DiffFlags -> [String] -> GlobalFlags -> IO ()
-diffAction flags args globalFlags = do
- let verbosity = fromFlag (diffVerbosity flags)
- -- dm0 = fromFlag (diffMode flags)
- dm <- case args of
- [] -> return ShowAll
- ["all"] -> return ShowAll
- ["missing"] -> return ShowMissing
- ["additions"] -> return ShowAdditions
- ["newer"] -> return ShowNewer
- ["common"] -> return ShowCommon
- ("package": pkgs) -> return (ShowPackages pkgs)
- -- TODO: ["package",packagePattern] ->
- -- return ShowPackagePattern packagePattern
- _ -> die $ "Unknown mode: " ++ unwords args
- overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags)
- let repo = defaultRepo overlayPath
- runDiff verbosity overlayPath dm repo
-
------------------------------------------------------------------------
--- Update
------------------------------------------------------------------------
-
-data UpdateFlags = UpdateFlags {
- updateVerbosity :: Flag Verbosity
- -- , updateServerURI :: Flag String
- }
-
-instance Monoid UpdateFlags where
- mempty = UpdateFlags {
- updateVerbosity = mempty
- -- , updateServerURI = mempty
- }
- mappend a b = UpdateFlags {
- updateVerbosity = combine updateVerbosity
- -- , updateServerURI = combine updateServerURI
- }
- where combine field = field a `mappend` field b
-
-defaultUpdateFlags :: UpdateFlags
-defaultUpdateFlags = UpdateFlags {
- updateVerbosity = Flag normal
- -- , updateServerURI = Flag defaultHackageServerURI
- }
-
-updateCommand :: CommandUI UpdateFlags
-updateCommand = CommandUI {
- commandName = "update",
- commandSynopsis = "Update the local cache",
- commandDescription = Just $ \_pname ->
- "TODO: this is the commandDescription for updateCommand\n",
- commandUsage = usageFlags "update",
- commandDefaultFlags = defaultUpdateFlags,
- commandOptions = \_ ->
- [ optionVerbosity updateVerbosity (\v flags -> flags { updateVerbosity = v })
-
- {-
- , option [] ["server"]
- "Set the server you'd like to update the cache from"
- updateServerURI (\v flags -> flags { updateServerURI = v} )
- (reqArgFlag "SERVER")
- -}
- ]
- }
-
-updateAction :: UpdateFlags -> [String] -> GlobalFlags -> IO ()
-updateAction flags extraArgs globalFlags = do
- unless (null extraArgs) $
- die $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs
- let verbosity = fromFlag (updateVerbosity flags)
- overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags)
- update verbosity [ defaultRepo overlayPath ]
-
-
------------------------------------------------------------------------
--- Status
------------------------------------------------------------------------
-
-data StatusFlags = StatusFlags {
- statusVerbosity :: Flag Verbosity,
- statusDirection :: Flag StatusDirection
- }
-
-defaultStatusFlags :: StatusFlags
-defaultStatusFlags = StatusFlags {
- statusVerbosity = Flag normal,
- statusDirection = Flag PortagePlusOverlay
- }
-
-statusCommand :: CommandUI StatusFlags
-statusCommand = CommandUI {
- commandName = "status",
- commandSynopsis = "Show status(??)",
- commandDescription = Just $ \_pname ->
- "TODO: this is the commandDescription for statusCommand\n",
- commandUsage = usagePackages "status",
- commandDefaultFlags = defaultStatusFlags,
- commandOptions = \_ ->
- [ optionVerbosity statusVerbosity (\v flags -> flags { statusVerbosity = v })
- , option [] ["to-portage"]
- "Print only packages likely to be interesting to move to the portage tree."
- statusDirection (\v flags -> flags { statusDirection = v })
- (noArg (Flag OverlayToPortage))
- , option [] ["from-hackage"]
- "Print only packages likely to be interesting to move from hackage tree."
- statusDirection (\v flags -> flags { statusDirection = v })
- (noArg (Flag HackageToOverlay))
- ]
- }
-
-statusAction :: StatusFlags -> [String] -> GlobalFlags -> IO ()
-statusAction flags args globalFlags = do
- let verbosity = fromFlag (statusVerbosity flags)
- direction = fromFlag (statusDirection flags)
- portagePath <- getPortageDir verbosity globalFlags
- overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags)
- runStatus verbosity portagePath overlayPath direction args
-
------------------------------------------------------------------------
--- Merge
------------------------------------------------------------------------
-
-data MergeFlags = MergeFlags {
- mergeVerbosity :: Flag Verbosity
- -- , mergeServerURI :: Flag String
- }
-
-instance Monoid MergeFlags where
- mempty = MergeFlags {
- mergeVerbosity = mempty
- -- , mergeServerURI = mempty
- }
- mappend a b = MergeFlags {
- mergeVerbosity = combine mergeVerbosity
- -- , mergeServerURI = combine mergeServerURI
- }
- where combine field = field a `mappend` field b
-
-defaultMergeFlags :: MergeFlags
-defaultMergeFlags = MergeFlags {
- mergeVerbosity = Flag normal
- -- , mergeServerURI = Flag defaultHackageServerURI
- }
-
-mergeCommand :: CommandUI MergeFlags
-mergeCommand = CommandUI {
- commandName = "merge",
- commandSynopsis = "Make an ebuild out of hackage package",
- commandDescription = Just $ \_pname ->
- "TODO: this is the commandDescription for mergeCommand\n",
- commandUsage = usagePackages "merge",
- commandDefaultFlags = defaultMergeFlags,
- commandOptions = \_showOrParseArgs ->
- [ optionVerbosity mergeVerbosity (\v flags -> flags { mergeVerbosity = v })
-
- {-
- , option [] ["server"]
- "Set the server you'd like to update the cache from"
- mergeServerURI (\v flags -> flags { mergeServerURI = v} )
- (reqArgFlag "SERVER")
- -}
- ]
- }
-
-mergeAction :: MergeFlags -> [String] -> GlobalFlags -> IO ()
-mergeAction flags extraArgs globalFlags = do
- let verbosity = fromFlag (mergeVerbosity flags)
- overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags)
- let repo = defaultRepo overlayPath
- merge verbosity repo (defaultRepoURI overlayPath) extraArgs overlayPath
-
------------------------------------------------------------------------
--- DistroMap
------------------------------------------------------------------------
-
-data DistroMapFlags = DistroMapFlags {
- distroMapVerbosity :: Flag Verbosity
- }
-
-instance Monoid DistroMapFlags where
- mempty = DistroMapFlags {
- distroMapVerbosity = mempty
- -- , mergeServerURI = mempty
- }
- mappend a b = DistroMapFlags {
- distroMapVerbosity = combine distroMapVerbosity
- }
- where combine field = field a `mappend` field b
-
-defaultDistroMapFlags :: DistroMapFlags
-defaultDistroMapFlags = DistroMapFlags {
- distroMapVerbosity = Flag normal
- }
-
-distroMapCommand :: CommandUI DistroMapFlags
-distroMapCommand = CommandUI {
- commandName = "distromap",
- commandSynopsis = "Build a distromap file",
- commandDescription = Just $ \_pname ->
- "TODO: this is the commandDescription for distroMapCommand\n",
- commandUsage = usagePackages "distromap",
- commandDefaultFlags = defaultDistroMapFlags,
- commandOptions = \_showOrParseArgs ->
- [ optionVerbosity distroMapVerbosity (\v flags -> flags { distroMapVerbosity = v })
- ]
- }
-
-distroMapAction :: DistroMapFlags-> [String] -> GlobalFlags -> IO ()
-distroMapAction flags extraArgs globalFlags = do
- let verbosity = fromFlag (distroMapVerbosity flags)
- overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags)
- let repo = defaultRepo overlayPath
- portagePath <- getPortageDir verbosity globalFlags
- distroMap verbosity repo portagePath overlayPath extraArgs
-
------------------------------------------------------------------------
--- Utils
------------------------------------------------------------------------
-
-getServerURI :: String -> IO URI
-getServerURI str =
- case parseURI str of
- Just uri -> return uri
- Nothing -> throwEx (InvalidServer str)
-
-reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description ->
- (b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b
-reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList
-
-usagePackages :: String -> String -> String
-usagePackages op_name pname =
- "Usage: " ++ pname ++ " " ++ op_name ++ " [FLAGS] [PACKAGE]\n\n"
- ++ "Flags for " ++ op_name ++ ":"
-
-usageFlags :: String -> String -> String
-usageFlags flag_name pname =
- "Usage: " ++ pname ++ " " ++ flag_name ++ " [FLAGS]\n\n"
- ++ "Flags for " ++ flag_name ++ ":"
-
-getPortageDir :: Verbosity -> GlobalFlags -> IO FilePath
-getPortageDir verbosity globalFlags = do
- let portagePathM = fromFlag (globalPathToPortage globalFlags)
- portagePath <- case portagePathM of
- Nothing -> Host.portage_dir <$> Host.getInfo
- Just path -> return path
- exists <- doesDirectoryExist $ portagePath </> "dev-haskell"
- when (not exists) $
- warn verbosity $ "Looks like an invalid portage directory: " ++ portagePath
- return portagePath
-
------------------------------------------------------------------------
--- Main
------------------------------------------------------------------------
-
-data GlobalFlags =
- GlobalFlags { globalVersion :: Flag Bool
- , globalNumericVersion :: Flag Bool
- , globalPathToOverlay :: Flag (Maybe FilePath)
- , globalPathToPortage :: Flag (Maybe FilePath)
- }
-
-defaultGlobalFlags :: GlobalFlags
-defaultGlobalFlags =
- GlobalFlags { globalVersion = Flag False
- , globalNumericVersion = Flag False
- , globalPathToOverlay = Flag Nothing
- , globalPathToPortage = Flag Nothing
- }
-
-globalCommand :: CommandUI GlobalFlags
-globalCommand = CommandUI {
- commandName = "",
- commandSynopsis = "",
- commandDescription = Just $ \_pname ->
- "TODO: this is the commandDescription for globalCommand\n",
- commandUsage = \_ -> [],
- commandDefaultFlags = defaultGlobalFlags,
- commandOptions = \_showOrParseArgs ->
- [ option ['V'] ["version"]
- "Print version information"
- globalVersion (\v flags -> flags { globalVersion = v })
- trueArg
- , option [] ["numeric-version"]
- "Print just the version number"
- globalNumericVersion (\v flags -> flags { globalNumericVersion = v })
- trueArg
- , option ['p'] ["overlay-path"]
- "Override search path list where .hackport/ lives (default list: ['.', paludis-ovls or emerge-ovls])"
- globalPathToOverlay (\ovrl_path flags -> flags { globalPathToOverlay = ovrl_path })
- (reqArg' "PATH" (Flag . Just) (\(Flag ms) -> catMaybes [ms]))
- , option [] ["portage-path"]
- "Override path to your portage tree"
- globalPathToPortage (\port_path flags -> flags { globalPathToPortage = port_path })
- (reqArg' "PATH" (Flag . Just) (\(Flag ms) -> catMaybes [ms]))
- ]
- }
-
-mainWorker :: [String] -> IO ()
-mainWorker args =
- case commandsRun globalCommand commands args of
- CommandHelp help -> printHelp help
- CommandList opts -> printOptionsList opts
- CommandErrors errs -> printErrors errs
- CommandReadyToGo (globalflags, commandParse) -> do
- case commandParse of
- _ | fromFlag (globalVersion globalflags) -> printVersion
- | fromFlag (globalNumericVersion globalflags) -> printNumericVersion
- CommandHelp help -> printHelp help
- CommandList opts -> printOptionsList opts
- CommandErrors errs -> printErrors errs
- CommandReadyToGo action -> catchEx (action globalflags) errorHandler
- where
- printHelp help = getProgName >>= putStr . help
- printOptionsList = putStr . unlines
- printErrors errs = do
- putStr (concat (intersperse "\n" errs))
- exitFailure
- printNumericVersion = putStrLn $ display Paths_hackport.version
- printVersion = putStrLn $ "hackport version "
- ++ display Paths_hackport.version
- ++ "\nusing cabal-install "
- ++ display Paths_cabal_install.version
- ++ " and the Cabal library version "
- ++ display cabalVersion
- errorHandler :: HackPortError -> IO ()
- errorHandler e = do
- putStrLn (hackPortShowError e)
- commands =
- [ listCommand `commandAddAction` listAction
- , makeEbuildCommand `commandAddAction` makeEbuildAction
- , statusCommand `commandAddAction` statusAction
- , diffCommand `commandAddAction` diffAction
- , updateCommand `commandAddAction` updateAction
- , mergeCommand `commandAddAction` mergeAction
- , distroMapCommand `commandAddAction` distroMapAction
- ]
-
-main :: IO ()
-main = getArgs >>= mainWorker
diff --git a/Merge.hs b/Merge.hs
deleted file mode 100644
index bcf3e24..0000000
--- a/Merge.hs
+++ /dev/null
@@ -1,233 +0,0 @@
-{-# OPTIONS -XPatternGuards #-}
-module Merge
- ( merge
- , mergeGenericPackageDescription
- ) where
-
-import Control.Monad.Error
-import Control.Exception
-import Data.Maybe
-import Data.List as L
-import Distribution.Package
-import Distribution.PackageDescription ( PackageDescription(..)
- , FlagName(..)
- , GenericPackageDescription
- )
-import Distribution.PackageDescription.Configuration
- ( finalizePackageDescription )
-import Distribution.Text (display)
-
-import System.Directory ( getCurrentDirectory
- , setCurrentDirectory
- , createDirectoryIfMissing
- , doesFileExist
- )
-import System.Cmd (system)
-import System.FilePath ((</>))
-import System.Exit
-
-import qualified Cabal2Ebuild as C2E
-import qualified Portage.EBuild as E
-import Error as E
-
-import qualified Distribution.Package as Cabal
-import qualified Distribution.Version as Cabal
-
-import Distribution.System (buildPlatform)
-import Distribution.Verbosity
-import Distribution.Simple.Utils
-
-import Network.URI
-
-import Distribution.Client.IndexUtils ( getSourcePackages )
-import qualified Distribution.Client.PackageIndex as Index
-import Distribution.Client.Types
-
-import qualified Portage.PackageId as Portage
-import qualified Portage.Version as Portage
-import qualified Portage.Metadata as Portage
-import qualified Portage.Overlay as Overlay
-import qualified Portage.Resolve as Portage
-
-import qualified Portage.GHCCore as GHCCore
-
-import qualified Merge.Dependencies as Merge
-
-import Debug.Trace ( trace )
-
-(<.>) :: String -> String -> String
-a <.> b = a ++ '.':b
-
-{-
-Requested features:
- * Copy the old keywords and ~arch them
- * Add files to darcs?
- * Print diff with the next latest version?
-BUGS:
- * Dependencies are always expected to be in dev-haskell
--}
-
-readPackageString :: [String]
- -> Either HackPortError ( Maybe Portage.Category
- , Cabal.PackageName
- , Maybe Portage.Version
- )
-readPackageString args = do
- packageString <-
- case args of
- [] -> Left (ArgumentError "Need an argument, [category/]package[-version]")
- [pkg] -> return pkg
- _ -> Left (ArgumentError ("Too many arguments: " ++ unwords args))
- case Portage.parseFriendlyPackage packageString of
- Just v@(_,_,Nothing) -> return v
- -- we only allow versions we can convert into cabal versions
- Just v@(_,_,Just (Portage.Version _ Nothing [] 0)) -> return v
- _ -> Left (ArgumentError ("Could not parse [category/]package[-version]: " ++ packageString))
-
-
-
--- | Given a list of available packages, and maybe a preferred version,
--- return the available package with that version. Latest version is chosen
--- if no preference.
-resolveVersion :: [SourcePackage] -> Maybe Cabal.Version -> Maybe SourcePackage
-resolveVersion avails Nothing = Just $ maximumBy (comparing packageInfoId) avails
-resolveVersion avails (Just ver) = listToMaybe (filter match avails)
- where
- match avail = ver == pkgVersion (packageInfoId avail)
-
-merge :: Verbosity -> Repo -> URI -> [String] -> FilePath -> IO ()
-merge verbosity repo _serverURI args overlayPath = do
- (m_category, user_pName, m_version) <-
- case readPackageString args of
- Left err -> throwEx err
- Right (c,p,m_v) ->
- case m_v of
- Nothing -> return (c,p,Nothing)
- Just v -> case Portage.toCabalVersion v of
- Nothing -> throwEx (ArgumentError "illegal version")
- Just ver -> return (c,p,Just ver)
-
- debug verbosity $ "Category: " ++ show m_category
- debug verbosity $ "Package: " ++ show user_pName
- debug verbosity $ "Version: " ++ show m_version
-
- let (Cabal.PackageName user_pname_str) = user_pName
-
- overlay <- Overlay.loadLazy overlayPath
- -- portage_path <- Host.portage_dir `fmap` Host.getInfo
- -- portage <- Overlay.loadLazy portage_path
- index <- fmap packageIndex $ getSourcePackages verbosity [ repo ]
-
- -- find all packages that maches the user specified package name
- availablePkgs <-
- case map snd (Index.searchByName index user_pname_str) of
- [] -> throwEx (PackageNotFound user_pname_str)
- [pkg] -> return pkg
- pkgs -> let names = map (pkgName . packageInfoId . L.head) pkgs
- whole_list = map (L.intercalate "\n" . map (show . packageInfoId)) pkgs
- in throwEx $ ArgumentError $ L.intercalate "\n---\n" $ ["Ambiguous names: " ++ show names] ++ whole_list
-
- -- select a single package taking into account the user specified version
- selectedPkg <-
- case resolveVersion availablePkgs m_version of
- Nothing -> do
- putStrLn "No such version for that package, available versions:"
- forM_ availablePkgs $ \ avail ->
- putStrLn (display . packageInfoId $ avail)
- throwEx (ArgumentError "no such version for that package")
- Just avail -> return avail
-
- -- print some info
- info verbosity "Selecting package:"
- forM_ availablePkgs $ \ avail -> do
- let match_text | packageInfoId avail == packageInfoId selectedPkg = "* "
- | otherwise = "- "
- info verbosity $ match_text ++ (display . packageInfoId $ avail)
-
- let cabal_pkgId = packageInfoId selectedPkg
- norm_pkgName = packageName (Portage.normalizeCabalPackageId cabal_pkgId)
- cat <- maybe (Portage.resolveCategory verbosity overlay norm_pkgName) return m_category
- mergeGenericPackageDescription verbosity overlayPath cat (packageDescription selectedPkg) True
-
-mergeGenericPackageDescription :: Verbosity -> FilePath -> Portage.Category -> GenericPackageDescription -> Bool -> IO ()
-mergeGenericPackageDescription verbosity overlayPath cat pkgGenericDesc fetch = do
- overlay <- Overlay.loadLazy overlayPath
- let Right (pkgDesc0, flags) =
- finalizePackageDescription
- [ -- XXX: common things we should enable/disable?
- -- (FlagName "small_base", True) -- try to use small base
- (FlagName "cocoa", False)
- ]
- (\dep -> trace ("accepting dep(?): " ++ display dep) True)
- -- (Nothing :: Maybe (Index.PackageIndex PackageIdentifier))
- buildPlatform
- (fst GHCCore.defaultGHC)
- [] pkgGenericDesc
-
- mminimumGHC = GHCCore.minimumGHCVersionToBuildPackage pkgGenericDesc
- (compilerId, excludePkgs) = maybe GHCCore.defaultGHC id mminimumGHC
-
- pkgDesc = let deps = [ Dependency pn (Cabal.simplifyVersionRange vr)
- | Dependency pn vr <- buildDepends pkgDesc0
- , pn `notElem` excludePkgs
- ]
- in pkgDesc0 { buildDepends = deps }
- edeps = Merge.resolveDependencies overlay pkgDesc (Just compilerId)
-
- debug verbosity ("Selected flags: " ++ show flags)
- info verbosity ("Guessing GHC version: " ++ maybe "could not guess" (display.fst) mminimumGHC)
- forM_ excludePkgs $
- \(PackageName name) -> info verbosity $ "Excluded packages (come with ghc): " ++ name
-
- let ebuild = (\e -> e { E.depend = Merge.dep edeps } )
- . (\e -> e { E.depend_extra = Merge.dep_e edeps } )
- . (\e -> e { E.rdepend = Merge.rdep edeps } )
- . (\e -> e { E.rdepend_extra = Merge.rdep_e edeps } )
- $ C2E.cabal2ebuild pkgDesc
-
- mergeEbuild verbosity overlayPath (Portage.unCategory cat) ebuild
- when fetch $ do
- let cabal_pkgId = packageId pkgDesc
- norm_pkgName = packageName (Portage.normalizeCabalPackageId cabal_pkgId)
- fetchAndDigest
- verbosity
- (overlayPath </> display cat </> display norm_pkgName)
-
-fetchAndDigest :: Verbosity
- -> FilePath -- ^ directory of ebuild
- -> IO ()
-fetchAndDigest verbosity ebuildDir =
- withWorkingDirectory ebuildDir $ do
- notice verbosity "Recalculating digests (repoman manifest)..."
- r <- system "repoman manifest"
- when (r /= ExitSuccess) $
- notice verbosity "repoman manifest failed horribly. Do something about it!"
- return ()
-
-withWorkingDirectory :: FilePath -> IO a -> IO a
-withWorkingDirectory newDir action = do
- oldDir <- getCurrentDirectory
- bracket
- (setCurrentDirectory newDir)
- (\_ -> setCurrentDirectory oldDir)
- (\_ -> action)
-
-mergeEbuild :: Verbosity -> FilePath -> String -> E.EBuild -> IO ()
-mergeEbuild verbosity target cat ebuild = do
- let edir = target </> cat </> E.name ebuild
- elocal = E.name ebuild ++"-"++ E.version ebuild <.> "ebuild"
- epath = edir </> elocal
- emeta = "metadata.xml"
- mpath = edir </> emeta
- default_meta = Portage.makeDefaultMetadata (E.long_desc ebuild)
- createDirectoryIfMissing True edir
- notice verbosity $ "Writing " ++ elocal
- writeFile epath (display ebuild)
-
- yet_meta <- doesFileExist mpath
- if (not yet_meta) -- TODO: add --force-meta-rewrite to opts
- then do notice verbosity $ "Writing " ++ emeta
- writeFile mpath default_meta
- else do current_meta <- readFile mpath
- when (current_meta /= default_meta) $
- notice verbosity $ "Default and current " ++ emeta ++ " differ."
diff --git a/Merge/Dependencies.hs b/Merge/Dependencies.hs
deleted file mode 100644
index 55ded63..0000000
--- a/Merge/Dependencies.hs
+++ /dev/null
@@ -1,361 +0,0 @@
-{- | Merge a package from hackage to an ebuild.
-
-Merging a library
-=================
-
-Compile time:
- ghc
- cabal
- build tools
- deps (haskell dependencies)
- extra-libs (c-libs)
- pkg-config (c-libs)
-
-Run time:
- ghc
- deps (haskell dependencies)
- extra-libs (c-libs)
- pkg-config (c-libs)
-
-RDEPEND="ghc ${DEPS} ${EXTRALIBS}"
-DEPEND="${RDEPEND} cabal ${BUILDTOOLS}"
-
-Merging an executable
-=====================
-Packages with both executable and library must be treated as libraries, as it will impose a stricter DEPEND.
-
-Compile time:
- ghc
- cabal
- build tools
- deps (haskell dependencies)
- extra-libs (c-libs)
- pkg-config (c-libs)
-
-Run time:
- extra-libs (c-libs)
- pkg-config (c-libs)
-
-RDEPEND="${EXTRALIBS}"
-DEPEND="${RDEPEND} ghc cabal ${DEPS} ${BUILDTOOLS}"
-
--}
-
-module Merge.Dependencies
- ( EDep(..)
- , resolveDependencies
- ) where
-
-import Distribution.PackageDescription ( PackageDescription(..)
- , libBuildInfo
- , buildInfo
- , buildable
- , extraLibs
- , buildTools
- , pkgconfigDepends
- , hasLibs
- , specVersion
- , TestSuite(..)
- , targetBuildDepends
- )
-import Data.Maybe ( isNothing )
-import Data.List ( nub )
-
-import qualified Distribution.Package as Cabal
-import qualified Distribution.Version as Cabal
-import Distribution.Compiler
-
-import qualified Portage.Dependency as Portage
-import qualified Portage.Overlay as Portage
-import qualified Portage.PackageId as Portage
-import qualified Portage.Use as Portage
-import qualified Portage.Version as Portage
-import qualified Cabal2Ebuild as C2E
-
-import qualified Portage.GHCCore as GHCCore
-
-import Debug.Trace ( trace )
-
--- | Dependencies of an ebuild
-data EDep = EDep
- {
- rdep :: [Portage.Dependency],
- rdep_e :: [String],
- dep :: [Portage.Dependency],
- dep_e :: [String]
- }
-
-emptyEDep :: EDep
-emptyEDep = EDep
- {
- rdep = [],
- rdep_e = [],
- dep = [],
- dep_e = []
- }
-
-resolveDependencies :: Portage.Overlay -> PackageDescription -> Maybe CompilerId -> EDep
-resolveDependencies overlay pkg mcompiler =
- edeps
- {
- dep = dep2,
- rdep = rdep2
- -- todo: if rdep includes cabal or ghc, make sure it's the same
- -- version as in dep
- }
- where
- dep1 = Portage.simplify_deps ( dep edeps)
- dep2 = Portage.simplifyUseDeps dep1 (dep1++rdep2)
- rdep1 = Portage.simplify_deps (rdep edeps)
- rdep2 = Portage.simplifyUseDeps rdep1 rdep1
- compiler = maybe (fst GHCCore.defaultGHC) id mcompiler
-
- hasBuildableExes p = any (buildable . buildInfo) . executables $ p
- treatAsLibrary = (not . hasBuildableExes) pkg || hasLibs pkg
- haskell_deps
- | treatAsLibrary = add_profile $ haskellDependencies overlay pkg
- | otherwise = haskellDependencies overlay pkg
- test_deps
- | (not . null) (testSuites pkg) = testDependencies overlay pkg
- | otherwise = [] -- tests not enabled
- cabal_dep = cabalDependency overlay pkg compiler
- ghc_dep = compilerIdToDependency compiler
- extra_libs = findCLibs pkg
- build_tools = buildToolsDependencies pkg
- pkg_config = pkgConfigDependencies overlay pkg
- edeps
- | treatAsLibrary = emptyEDep
- {
- dep = cabal_dep
- : build_tools
- ++ test_deps,
- dep_e = [ "${RDEPEND}" ],
- rdep = ghc_dep
- : haskell_deps
- ++ extra_libs
- ++ pkg_config
- }
- | otherwise = emptyEDep
- {
- dep = ghc_dep
- : cabal_dep
- : build_tools
- ++ haskell_deps
- ++ test_deps,
- dep_e = [ "${RDEPEND}" ],
- rdep = extra_libs ++ pkg_config
- }
- add_profile = map (flip Portage.addDepUseFlag (Portage.mkQUse "profile"))
-
----------------------------------------------------------------
--- Test-suite dependencies
----------------------------------------------------------------
-
-testDependencies :: Portage.Overlay -> PackageDescription -> [Portage.Dependency]
-testDependencies overlay pkg@(PackageDescription { package = Cabal.PackageIdentifier { Cabal.pkgName = Cabal.PackageName name}}) =
- [Portage.DependIfUse (Portage.UseFlag "test") (Portage.AllOf $ Portage.simplify_deps deps)]
- where cabalDeps = concat $ map targetBuildDepends $ map testBuildInfo (testSuites pkg)
- cabalDeps' = filter (\(Cabal.Dependency (Cabal.PackageName pname) _) -> pname /= name) cabalDeps
- deps = C2E.convertDependencies overlay (Portage.Category "dev-haskell") cabalDeps'
-
----------------------------------------------------------------
--- Haskell packages
----------------------------------------------------------------
-
-haskellDependencies :: Portage.Overlay -> PackageDescription -> [Portage.Dependency]
-haskellDependencies overlay pkg =
- Portage.simplify_deps
- $ C2E.convertDependencies overlay (Portage.Category "dev-haskell") (buildDepends pkg)
-
----------------------------------------------------------------
--- Cabal Dependency
----------------------------------------------------------------
-
--- | Select the most restrictive dependency on Cabal, either the .cabal
--- file's descCabalVersion, or the Cabal GHC shipped with.
-cabalDependency :: Portage.Overlay -> PackageDescription -> CompilerId -> Portage.Dependency
-cabalDependency overlay pkg (CompilerId GHC ghcVersion@(Cabal.Version versionNumbers _)) =
- head $ C2E.convertDependency overlay
- (Portage.Category "dev-haskell")
- (Cabal.Dependency (Cabal.PackageName "Cabal")
- finalCabalDep)
- where
- userCabalVersion = Cabal.orLaterVersion (specVersion pkg)
- shippedCabalVersion = GHCCore.cabalFromGHC versionNumbers
- shippedCabalDep = maybe Cabal.anyVersion
- (\shipped -> Cabal.intersectVersionRanges
- (Cabal.thisVersion shipped)
- (Cabal.laterVersion shipped))
- shippedCabalVersion
- finalCabalDep = Cabal.simplifyVersionRange
- (Cabal.intersectVersionRanges
- userCabalVersion
- shippedCabalDep)
-
----------------------------------------------------------------
--- GHC Dependency
----------------------------------------------------------------
-
-compilerIdToDependency :: CompilerId -> Portage.Dependency
-compilerIdToDependency (CompilerId GHC versionNumbers) =
- Portage.OrLaterVersionOf (Portage.fromCabalVersion versionNumbers) (Portage.mkPackageName "dev-lang" "ghc") []
-
----------------------------------------------------------------
--- C Libraries
----------------------------------------------------------------
-
-findCLibs :: PackageDescription -> [Portage.Dependency]
-findCLibs (PackageDescription { library = lib, executables = exes }) =
- [ trace ("WARNING: This package depends on a C library we don't know the portage name for: " ++ p ++ ". Check the generated ebuild.")
- (Portage.AnyVersionOf (Portage.mkPackageName "unknown-c-lib" p) [])
- | p <- notFound
- ] ++
- found
- where
- libE = maybe [] (extraLibs.libBuildInfo) lib
- exeE = concatMap extraLibs (filter buildable (map buildInfo exes))
- allE = libE ++ exeE
-
- notFound = [ p | p <- allE, isNothing (staticTranslateExtraLib p) ]
- found = [ p | Just p <- map staticTranslateExtraLib allE ]
-
-staticTranslateExtraLib :: String -> Maybe Portage.Dependency
-staticTranslateExtraLib lib = lookup lib m
- where
- m = [ ("z", Portage.AnyVersionOf (Portage.mkPackageName "sys-libs" "zlib") [])
- , ("bz2", Portage.AnyVersionOf (Portage.mkPackageName "sys-libs" "bzlib") [])
- , ("mysqlclient", Portage.LaterVersionOf (Portage.Version [4,0] Nothing [] 0) (Portage.mkPackageName "virtual" "mysql") [])
- , ("pq", Portage.LaterVersionOf (Portage.Version [7] Nothing [] 0) (Portage.mkPackageName "dev-db" "postgresql-base") [])
- , ("ev", Portage.AnyVersionOf (Portage.mkPackageName "dev-libs" "libev") [])
- , ("expat", Portage.AnyVersionOf (Portage.mkPackageName "dev-libs" "expat") [])
- , ("curl", Portage.AnyVersionOf (Portage.mkPackageName "net-misc" "curl") [])
- , ("xml2", Portage.AnyVersionOf (Portage.mkPackageName "dev-libs" "libxml2") [])
- , ("mecab", Portage.AnyVersionOf (Portage.mkPackageName "app-text" "mecab") [])
- , ("zmq", Portage.AnyVersionOf (Portage.mkPackageName "net-libs" "zeromq") [])
- ]
-
----------------------------------------------------------------
--- Build Tools
----------------------------------------------------------------
-
-buildToolsDependencies :: PackageDescription -> [Portage.Dependency]
-buildToolsDependencies (PackageDescription { library = lib, executables = exes }) = nub $
- [ case pkg of
- Just p -> p
- Nothing -> trace ("WARNING: Unknown build tool '" ++ pn ++ "'. Check the generated ebuild.")
- (Portage.AnyVersionOf (Portage.mkPackageName "unknown-build-tool" pn) [])
- | Cabal.Dependency (Cabal.PackageName pn) _range <- cabalDeps
- , pkg <- return (lookup pn buildToolsTable)
- ]
- where
- cabalDeps = filter notProvided $ depL ++ depE
- depL = maybe [] (buildTools.libBuildInfo) lib
- depE = concatMap buildTools (filter buildable (map buildInfo exes))
- notProvided (Cabal.Dependency (Cabal.PackageName pn) _range) = pn `notElem` buildToolsProvided
-
-buildToolsTable :: [(String, Portage.Dependency)]
-buildToolsTable =
- [ ("happy", Portage.AnyVersionOf (Portage.mkPackageName "dev-haskell" "happy") [])
- , ("alex", Portage.AnyVersionOf (Portage.mkPackageName "dev-haskell" "alex") [])
- , ("c2hs", Portage.AnyVersionOf (Portage.mkPackageName "dev-haskell" "c2hs") [])
- , ("cabal-install", Portage.AnyVersionOf (Portage.mkPackageName "dev-haskell" "cabal-install") [])
- , ("gtk2hsTypeGen", Portage.AnyVersionOf (Portage.mkPackageName "dev-haskell" "gtk2hs-buildtools") [])
- , ("gtk2hsHookGenerator", Portage.AnyVersionOf (Portage.mkPackageName "dev-haskell" "gtk2hs-buildtools") [])
- , ("gtk2hsC2hs", Portage.AnyVersionOf (Portage.mkPackageName "dev-haskell" "gtk2hs-buildtools") [])
- ]
-
--- tools that are provided by ghc or some other existing program
--- so we do not need dependencies on them
-buildToolsProvided :: [String]
-buildToolsProvided = ["hsc2hs"]
-
-
----------------------------------------------------------------
--- pkg-config
----------------------------------------------------------------
-
-pkgConfigDependencies :: Portage.Overlay -> PackageDescription -> [Portage.Dependency]
-pkgConfigDependencies overlay (PackageDescription { library = lib, executables = exes }) = nub $ resolvePkgConfigs overlay cabalDeps
- where
- cabalDeps = depL ++ depE
- depL = maybe [] (pkgconfigDepends.libBuildInfo) lib
- depE = concatMap pkgconfigDepends (filter buildable (map buildInfo exes))
-
-resolvePkgConfigs :: Portage.Overlay -> [Cabal.Dependency] -> [Portage.Dependency]
-resolvePkgConfigs overlay cdeps =
- [ case resolvePkgConfig overlay pkg of
- Just d -> d
- Nothing -> trace ("WARNING: Could not resolve pkg-config: " ++ pn ++ ". Check generated ebuild.")
- (Portage.AnyVersionOf (Portage.mkPackageName "unknown-pkg-config" pn) [])
- | pkg@(Cabal.Dependency (Cabal.PackageName pn) _range) <- cdeps ]
-
-resolvePkgConfig :: Portage.Overlay -> Cabal.Dependency -> Maybe Portage.Dependency
-resolvePkgConfig overlay (Cabal.Dependency (Cabal.PackageName pn) _cabalVersion) = do
- (cat,portname) <- lookup pn table
- return $ Portage.AnyVersionOf (Portage.mkPackageName cat portname) []
-
-table :: [(String, (String, String))]
-table =
- [
- ("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"))
- ,("glib-2.0", ("dev-libs", "glib:2"))
- ,("gmodule-2.0", ("dev-libs", "glib:2"))
- ,("gmodule-export-2.0", ("dev-libs", "glib:2"))
- ,("gmodule-no-export-2.0", ("dev-libs", "glib:2"))
- ,("gobject-2.0", ("dev-libs", "glib:2"))
- ,("gthread-2.0", ("dev-libs", "glib:2"))
-
- ,("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"))
- ,("cairo-ps", ("x11-libs", "cairo"))
- ,("cairo-png", ("x11-libs", "cairo"))
- ,("cairo-pdf", ("x11-libs", "cairo"))
- ,("cairo-svg", ("x11-libs", "cairo"))
- ,("cairo-xlib", ("x11-libs", "cairo"))
- ,("cairo-xlib-xrender", ("x11-libs", "cairo"))
-
- ,("pangocairo", ("x11-libs", "pango"))
- ,("pangoft2", ("x11-libs", "pango"))
- ,("pango", ("x11-libs", "pango"))
- ,("pangoxft", ("x11-libs", "pango"))
- ,("pangox", ("x11-libs", "pango"))
-
- ,("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:2"))
-
- ,("gstreamer-0.10", ("media-libs", "gstreamer"))
- ,("gstreamer-base-0.10", ("media-libs", "gstreamer"))
- ,("gstreamer-check-0.10", ("media-libs", "gstreamer"))
- ,("gstreamer-controller-0.10", ("media-libs", "gstreamer"))
- ,("gstreamer-dataprotocol-0.10", ("media-libs", "gstreamer"))
- ,("gstreamer-net-0.10", ("media-libs", "gstreamer"))
-
- ,("gstreamer-app-0.10", ("media-libs", "gst-plugins-base"))
- ,("gstreamer-audio-0.10", ("media-libs", "gst-plugins-base"))
- ,("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:2.0"))
- ,("librsvg-2.0", ("gnome-base","librsvg"))
- ,("vte", ("x11-libs","vte:0"))
- ,("gtkglext-1.0", ("x11-libs","gtkglext"))
-
- ,("curl", ("net-misc", "curl"))
- ,("libxml2", ("dev-libs", "libxml2"))
- ,("libgsasl", ("virtual", "gsasl"))
-
- ]
diff --git a/Overlays.hs b/Overlays.hs
deleted file mode 100644
index 6a4614a..0000000
--- a/Overlays.hs
+++ /dev/null
@@ -1,71 +0,0 @@
-module Overlays
- ( getOverlayPath
- ) where
-
-import Control.Monad
-import Data.List (nub, inits)
-import Data.Maybe (maybeToList, listToMaybe, isJust, fromJust)
-import System.Directory
-import System.FilePath ((</>), splitPath, joinPath)
-
-import Error
-import CacheFile
-import Portage.Host
-
--- cabal
-import Distribution.Verbosity
-import Distribution.Simple.Utils ( info )
-
-getOverlayPath :: Verbosity -> Maybe FilePath -> IO String
-getOverlayPath verbosity override_overlay = do
- overlays <- if isJust override_overlay
- then do info verbosity $ "Forced " ++ fromJust override_overlay
- return [fromJust override_overlay]
- else getOverlays
- case overlays of
- [] -> throwEx NoOverlay
- [x] -> return x
- mul -> search mul
- where
- search :: [String] -> IO String
- search mul = do
- let loop [] = throwEx (MultipleOverlays mul)
- loop (x:xs) = do
- info verbosity $ "Checking '" ++ x ++ "'..."
- found <- doesFileExist (cacheFile x)
- if found
- then do
- info verbosity "OK!"
- return x
- else do
- info verbosity "Not ok."
- loop xs
- info verbosity "There are several overlays in your configuration."
- mapM_ (info verbosity . (" * " ++)) mul
- info verbosity "Looking for one with a HackPort cache..."
- overlay <- loop mul
- info verbosity $ "I choose " ++ overlay
- info verbosity "Override my decision with hackport --overlay /my/overlay"
- return overlay
-
-getOverlays :: IO [String]
-getOverlays = do
- local <- getLocalOverlay
- overlays <- overlay_list `fmap` getInfo
- return $ nub $ map clean $
- maybeToList local
- ++ overlays
- where
- clean path = case reverse path of
- '/':p -> reverse p
- _ -> path
-
-getLocalOverlay :: IO (Maybe FilePath)
-getLocalOverlay = do
- curDir <- getCurrentDirectory
- let lookIn = map joinPath . reverse . inits . splitPath $ curDir
- fmap listToMaybe (filterM probe lookIn)
-
- where
- probe dir = doesDirectoryExist (dir </> "dev-haskell")
-
diff --git a/Portage/Cabal.hs b/Portage/Cabal.hs
deleted file mode 100644
index a8a3c33..0000000
--- a/Portage/Cabal.hs
+++ /dev/null
@@ -1,15 +0,0 @@
-module Portage.Cabal
- (fromOverlay) where
-
-import qualified Data.Map as Map
-
-import qualified Distribution.Client.PackageIndex as Cabal
-
-import qualified Portage.Overlay as Portage
-
-fromOverlay :: Portage.Overlay -> Cabal.PackageIndex Portage.ExistingEbuild
-fromOverlay overlay = Cabal.fromList $
- [ ebuild
- | (_pn, ebuilds) <- Map.toAscList (Portage.overlayMap overlay)
- , ebuild <- ebuilds
- ]
diff --git a/Portage/Dependency.hs b/Portage/Dependency.hs
deleted file mode 100644
index 11cfea8..0000000
--- a/Portage/Dependency.hs
+++ /dev/null
@@ -1,219 +0,0 @@
-module Portage.Dependency (
- Dependency(..),
- simplify_deps,
- simplifyUseDeps,
- addDepUseFlag
- ) where
-
-import Portage.Version
-import Portage.Use
-import Distribution.Text ( display, Text(..) )
-
-import Portage.PackageId
-
-import qualified Text.PrettyPrint as Disp
-import Text.PrettyPrint ( (<>), hsep )
-
-import Data.Maybe ( fromJust, catMaybes, mapMaybe )
-import Data.List ( nub, groupBy, partition, sortBy )
-import Data.Ord (comparing)
-
-data Dependency = AnyVersionOf PackageName [UseFlag]
- | ThisVersionOf Version PackageName [UseFlag] -- ~package-version
- | LaterVersionOf Version PackageName [UseFlag] -- >package-version
- | EarlierVersionOf Version PackageName [UseFlag] -- <package-version
- | OrLaterVersionOf Version PackageName [UseFlag] -- >=package-version
- | OrEarlierVersionOf Version PackageName [UseFlag] -- <=package-version
- | DependEither [Dependency] -- || ( depend1 depend2 ... )
- | DependIfUse UseFlag Dependency -- use? ( depend )
- | ThisMajorOf Version PackageName [UseFlag] -- =package-version*
- | AllOf [Dependency] -- ( depend1 depend2 ... )
- deriving (Eq,Show)
-
-instance Text Dependency where
- disp = showDepend
-
-(<->) :: Disp.Doc -> Disp.Doc -> Disp.Doc
-a <-> b = a <> Disp.char '-' <> b
-
-showDepend :: Dependency -> Disp.Doc
-showDepend (AnyVersionOf p u) = disp p <> dispUses u
-showDepend (ThisVersionOf v p u) = Disp.char '~' <> disp p <-> disp v { versionRevision = 0 } <> dispUses u
-showDepend (LaterVersionOf v p u) = Disp.char '>' <> disp p <-> disp v <> dispUses u
-showDepend (EarlierVersionOf v p u) = Disp.char '<' <> disp p <-> disp v <> dispUses u
-showDepend (OrLaterVersionOf v p u) = Disp.text ">=" <> disp p <-> disp v <> dispUses u
-showDepend (OrEarlierVersionOf v p u) = Disp.text "<=" <> disp p <-> disp v <> dispUses u
-showDepend (DependEither dp ) = Disp.text "|| ( " <> hsep (map showDepend dp) <> Disp.text " )"
-showDepend (DependIfUse useflag dep) = disp useflag <> Disp.text "? " <> pp_deps dep
- where -- special case to avoid double braces: test? ( ( ) )
- pp_deps (AllOf _) = disp dep
- pp_deps _ = Disp.parens (Disp.text " " <> disp dep <> Disp.text " ")
-showDepend (ThisMajorOf v p u) = Disp.char '=' <> disp p <-> disp v <> Disp.char '*' <> dispUses u
-showDepend (AllOf []) = Disp.empty
-showDepend (AllOf (d:dp) ) =
- Disp.text "( " <> showDepend d <> line
- <> Disp.hcat (map (\x -> Disp.text "\t\t\t" <> (showDepend x) <> line) dp)
- <> Disp.text "\t\t)"
- where line = Disp.char '\n'
-
-{- Here goes code for dependencies simplification -}
-
-simplify_group_table :: PackageName ->
- [UseFlag] ->
- Maybe Version ->
- Maybe Version ->
- Maybe Version ->
- Maybe Version ->
- Maybe Version -> [Dependency]
-
--- simplify_group_table p ol l e oe exact
--- 1) trivial cases:
-simplify_group_table p u Nothing Nothing Nothing Nothing Nothing = error $ display p ++ ": unsolvable constraints"
-simplify_group_table p u (Just v) Nothing Nothing Nothing Nothing = [OrLaterVersionOf v p u]
-simplify_group_table p u Nothing (Just v) Nothing Nothing Nothing = [LaterVersionOf v p u]
-simplify_group_table p u Nothing Nothing (Just v) Nothing Nothing = [EarlierVersionOf v p u]
-simplify_group_table p u Nothing Nothing Nothing (Just v) Nothing = [OrEarlierVersionOf v p u]
-simplify_group_table p u Nothing Nothing Nothing Nothing (Just v) = [ThisVersionOf v p u]
-
--- 2) simplification passes
-simplify_group_table p u (Just (Version v1 _ _ _)) Nothing (Just (Version v2 _ _ _)) Nothing Nothing
- -- special case: >=a-v.N a<v.(N+1) => =a-v.N*
- | (init v1 == init v2) && (last v2 == last v1 + 1) = [ThisMajorOf (Version v1 Nothing [] 0) p u]
- | otherwise = [OrLaterVersionOf (Version v1 Nothing [] 0) p u, EarlierVersionOf (Version v2 Nothing [] 0) p u]
-
--- TODO: simplify constraints of type: >=a-v1; > a-v2 and such
-
--- 3) otherwise sink:
-simplify_group_table p u (Just v) l@(_) e@(_) oe@(_) exact@(_) = OrLaterVersionOf v p u: simplify_group_table p u Nothing l e oe exact
-simplify_group_table p u ol@(Nothing) (Just v) e@(_) oe@(_) exact@(_) = LaterVersionOf v p u: simplify_group_table p u ol Nothing e oe exact
-simplify_group_table p u ol@(Nothing) l@(Nothing) (Just v) oe@(_) exact@(_) = EarlierVersionOf v p u: simplify_group_table p u ol l Nothing oe exact
-simplify_group_table p u ol@(Nothing) l@(Nothing) e@(Nothing) (Just v) exact@(_) = OrEarlierVersionOf v p u: simplify_group_table p u ol l e Nothing exact
--- already defined earlier
--- simplify_group_table p ol@(Nothing) l@(Nothing) e@(Nothing) oe@(Nothing) (Just v) = OrEarlierVersionOf v p : simplify_group_table p ol l e oe Nothing
-
--- >a-v1 >a-v2 => >a-(max v1 v2)
--- key idea: all constraints are enforcing constraints, so we can't get
--- more, than one interval.
-simplify_group :: [Dependency] -> [Dependency]
-simplify_group [dep@(AnyVersionOf _package _u)] = [dep]
-simplify_group [dep@(ThisMajorOf _v _p _u)] = [dep]
-simplify_group deps = simplify_group_table package
- uses
- min_or_later_v -- >=
- min_later_v -- >
- max_earlier_v -- <
- max_or_earlier_v -- <=
- exact_this_v -- ==
- where
- package = fromJust.getPackage $ head deps
- uses = fromJust.getUses $ head deps
- max_earlier_v = safe_minimum $ map earlier_v deps
- max_or_earlier_v = safe_minimum $ map or_earlier_v deps
- min_later_v = safe_maximum $ map later_v deps
- min_or_later_v = safe_maximum $ map or_later_v deps
- exact_this_v = case catMaybes (map this_v deps) of
- [] -> Nothing
- [v] -> Just v
- xs -> error $ "too many exact versions:" ++ show xs
- --
- earlier_v (EarlierVersionOf v _p _u) = Just v
- earlier_v _ = Nothing
-
- or_earlier_v (OrEarlierVersionOf v _p _u) = Just v
- or_earlier_v _ = Nothing
-
- later_v (LaterVersionOf v _p _u) = Just v
- later_v _ = Nothing
-
- or_later_v (OrLaterVersionOf v _p _u) = Just v
- or_later_v _ = Nothing
-
- this_v (ThisVersionOf v _p _u) = Just v
- this_v _ = Nothing
- --
- safe_minimum xs = case catMaybes xs of
- [] -> Nothing
- xs' -> Just $ minimum xs'
- safe_maximum xs = case catMaybes xs of
- [] -> Nothing
- xs' -> Just $ maximum xs'
-
--- divide packages to groups (by package name), simplify groups, merge again
-simplify_deps :: [Dependency] -> [Dependency]
-simplify_deps deps = (concatMap (simplify_group.nub) $
- groupBy cmpPkgName $
- sortBy (comparing getPackagePart) groupable)
- ++ ungroupable
- where (ungroupable, groupable) = partition ((==Nothing).getPackage) deps
- --
- cmpPkgName p1 p2 = cmpMaybe (getPackage p1) (getPackage p2)
- cmpMaybe (Just p1) (Just p2) = p1 == p2
- cmpMaybe _ _ = False
- --
-getPackage :: Dependency -> Maybe PackageName
-getPackage (AllOf _dependency) = Nothing
-getPackage (AnyVersionOf package _uses) = Just package
-getPackage (ThisVersionOf _version package _uses) = Just package
-getPackage (LaterVersionOf _version package _uses) = Just package
-getPackage (EarlierVersionOf _version package _uses) = Just package
-getPackage (OrLaterVersionOf _version package _uses) = Just package
-getPackage (OrEarlierVersionOf _version package _uses) = Just package
-getPackage (DependEither _dependency ) = Nothing
-getPackage (DependIfUse _useFlag _Dependency) = Nothing
-getPackage (ThisMajorOf _version package _uses) = Just package
-
-getUses :: Dependency -> Maybe [UseFlag]
-getUses (AllOf _d) = Nothing
-getUses (AnyVersionOf _p u) = Just u
-getUses (ThisVersionOf _v _p u) = Just u
-getUses (LaterVersionOf _v _p u) = Just u
-getUses (EarlierVersionOf _v _p u) = Just u
-getUses (OrLaterVersionOf _v _p u) = Just u
-getUses (OrEarlierVersionOf _v _p u) = Just u
-getUses (DependEither _d) = Nothing
-getUses (DependIfUse _u _d) = Nothing
-getUses (ThisMajorOf _v _p u) = Just u
-
---
-getPackagePart :: Dependency -> PackageName
-getPackagePart dep = fromJust (getPackage dep)
-
---
-addDepUseFlag :: Dependency -> UseFlag -> Dependency
-addDepUseFlag (AllOf d) n = AllOf $ map (flip addDepUseFlag n) d
-addDepUseFlag (AnyVersionOf p u) n = AnyVersionOf p (n:u)
-addDepUseFlag (ThisVersionOf v p u) n = ThisVersionOf v p (n:u)
-addDepUseFlag (LaterVersionOf v p u) n = LaterVersionOf v p (n:u)
-addDepUseFlag (EarlierVersionOf v p u) n = EarlierVersionOf v p (n:u)
-addDepUseFlag (OrLaterVersionOf v p u) n = OrLaterVersionOf v p (n:u)
-addDepUseFlag (OrEarlierVersionOf v p u) n = OrEarlierVersionOf v p (n:u)
-addDepUseFlag (ThisMajorOf v p u) n = ThisMajorOf v p (n:u)
-addDepUseFlag (DependEither d) n = DependEither $ map (flip addDepUseFlag n) d
-addDepUseFlag (DependIfUse u d) n = DependIfUse u (addDepUseFlag d n)
-
---
--- | remove all Use dependencies that overlap with normal dependencies
-simplifyUseDeps :: [Dependency] -- list where use deps is taken
- -> [Dependency] -- list where common deps is taken
- -> [Dependency] -- result deps
-simplifyUseDeps ds cs =
- let (u,o) = partition isUseDep ds
- c = mapMaybe getPackage cs
- in (mapMaybe (intersectD c) u)++o
-
-intersectD :: [PackageName] -> Dependency -> Maybe Dependency
-intersectD fs (DependIfUse u d) = intersectD fs d >>= Just . DependIfUse u
-intersectD fs (DependEither ds) =
- let ds' = mapMaybe (intersectD fs) ds
- in if null ds' then Nothing else Just (DependEither ds')
-intersectD fs (AllOf ds) =
- let ds' = mapMaybe (intersectD fs) ds
- in if null ds' then Nothing else Just (AllOf ds')
-intersectD fs x =
- let pkg = fromJust $ getPackage x -- this is unsafe but will save from error later
- in if any (==pkg) fs then Nothing else Just x
-
-isUseDep :: Dependency -> Bool
-isUseDep (DependIfUse _ _) = True
-isUseDep _ = False
---
diff --git a/Portage/EBuild.hs b/Portage/EBuild.hs
deleted file mode 100644
index 4de0213..0000000
--- a/Portage/EBuild.hs
+++ /dev/null
@@ -1,188 +0,0 @@
-module Portage.EBuild
- ( EBuild(..)
- , ebuildTemplate
- , src_uri
- ) where
-
-import Distribution.Text ( Text(..), display )
-import qualified Text.PrettyPrint as Disp
-
-import Portage.Dependency
-
-import Distribution.License as Cabal
-
-import Data.String.Utils
-import Data.Version(Version(..))
-import qualified Paths_hackport(version)
-
-data EBuild = EBuild {
- name :: String,
- hackage_name :: String, -- might differ a bit (we mangle case)
- version :: String,
- hackportVersion :: String,
- description :: String,
- long_desc :: String,
- homepage :: String,
- license :: Cabal.License,
- slot :: String,
- keywords :: [String],
- iuse :: [String],
- depend :: [Dependency],
- depend_extra :: [String],
- rdepend :: [Dependency],
- rdepend_extra :: [String],
- features :: [String],
- my_pn :: Maybe String -- ^ Just 'myOldName' if the package name contains upper characters
- }
-
-getHackportVersion :: Version -> String
-getHackportVersion Version {versionBranch=(x:s)} = foldl (\y z -> y ++ "." ++ (show z)) (show x) s
-getHackportVersion Version {versionBranch=[]} = ""
-
-ebuildTemplate :: EBuild
-ebuildTemplate = EBuild {
- name = "foobar",
- hackage_name = "FooBar",
- version = "0.1",
- hackportVersion = getHackportVersion Paths_hackport.version,
- description = "",
- long_desc = "",
- homepage = "http://hackage.haskell.org/package/${HACKAGE_N}",
- license = Cabal.UnknownLicense "xxx UNKNOWN xxx",
- slot = "0",
- keywords = ["~amd64","~x86"],
- iuse = [],
- depend = [],
- depend_extra = [],
- rdepend = [],
- rdepend_extra = [],
- features = [],
- my_pn = Nothing
- }
-
-instance Text EBuild where
- disp = Disp.text . showEBuild
-
--- | Given an EBuild, give the URI to the tarball of the source code.
--- Assumes that the server is always hackage.haskell.org.
-src_uri :: EBuild -> String
-src_uri e =
- case my_pn e of
- -- use standard address given that the package name has no upper
- -- characters
- Nothing -> "http://hackage.haskell.org/packages/archive/${PN}/${PV}/${P}.tar.gz"
- -- use MY_X variables (defined in showEBuild) as we've renamed the
- -- package
- Just _ -> "http://hackage.haskell.org/packages/archive/${MY_PN}/${PV}/${MY_P}.tar.gz"
-
-showEBuild :: EBuild -> String
-showEBuild ebuild =
- ss "# Copyright 1999-2012 Gentoo Foundation". nl.
- ss "# Distributed under the terms of the GNU General Public License v2". nl.
- ss "# $Header: $". nl.
- nl.
- ss "EAPI=4". nl.
- nl.
- ss ("# ebuild generated by hackport " ++ hackportVersion ebuild). nl.
- nl.
- ss "CABAL_FEATURES=". quote' (sepBy " " $ features ebuild). nl.
- ss "inherit haskell-cabal". nl.
- nl.
- (case my_pn ebuild of
- Nothing -> id
- Just pn -> ss "MY_PN=". quote pn. nl.
- 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 (toMirror $ src_uri ebuild). nl.
- nl.
- ss "LICENSE=". quote (convertLicense . license $ ebuild).
- (if null (licenseComment . license $ ebuild) then id
- else ss "\t#". ss (licenseComment . license $ ebuild)). nl.
- ss "SLOT=". quote (slot ebuild). nl.
- ss "KEYWORDS=". quote' (sepBy " " $ keywords ebuild).nl.
- ss "IUSE=". quote' (sepBy ", " $ iuse ebuild). nl.
- nl.
- dep_str "RDEPEND" (rdepend_extra ebuild) (rdepend ebuild).
- dep_str "DEPEND" ( depend_extra ebuild) ( depend ebuild).
- (case my_pn ebuild of
- Nothing -> id
- Just _ -> nl. ss "S=". quote ("${WORKDIR}/${MY_P}"). nl)
- $ []
- 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
-
-sc :: Char -> String -> String
-sc = showChar
-
-nl :: String -> String
-nl = sc '\n'
-
-dep_str :: String -> [String] -> [Dependency] -> (String -> String)
-dep_str var extra deps = ss var. sc '='. quote' (sepBy "\n\t\t" $ extra ++ map display deps). nl
-
-quote :: String -> String -> String
-quote str = sc '"'. ss (esc str). sc '"'
- where
- esc = concatMap esc'
- esc' '"' = "\""
- esc' c = [c]
-
-quote' :: (String -> String) -> String -> String
-quote' str = sc '"'. str. sc '"'
-
-sepBy :: String -> [String] -> ShowS
-sepBy _ [] = id
-sepBy _ [x] = ss x
-sepBy s (x:xs) = ss x. ss s. sepBy s xs
-
-getRestIfPrefix ::
- String -> -- ^ the prefix
- String -> -- ^ the string
- Maybe String
-getRestIfPrefix (p:ps) (x:xs) = if p==x then getRestIfPrefix ps xs else Nothing
-getRestIfPrefix [] rest = Just rest
-getRestIfPrefix _ [] = Nothing
-
-subStr ::
- String -> -- ^ the search string
- String -> -- ^ the string to be searched
- Maybe (String,String) -- ^ Just (pre,post) if string is found
-subStr sstr str = case getRestIfPrefix sstr str of
- Nothing -> if null str then Nothing else case subStr sstr (tail str) of
- Nothing -> Nothing
- Just (pre,post) -> Just (head str:pre,post)
- Just rest -> Just ([],rest)
-
-replaceMultiVars ::
- [(String,String)] -> -- ^ pairs of variable name and content
- String -> -- ^ string to be searched
- String -- ^ the result
-replaceMultiVars [] str = str
-replaceMultiVars whole@((pname,cont):rest) str = case subStr cont str of
- Nothing -> replaceMultiVars rest str
- Just (pre,post) -> (replaceMultiVars rest pre)++pname++(replaceMultiVars whole post)
-
--- map the cabal license type to the gentoo license string format
-convertLicense :: Cabal.License -> String
-convertLicense (Cabal.GPL mv) = "GPL-" ++ (maybe "2" display mv) -- almost certainly version 2
-convertLicense (Cabal.LGPL mv) = "LGPL-" ++ (maybe "2.1" display mv) -- probably version 2.1
-convertLicense Cabal.BSD3 = "BSD"
-convertLicense Cabal.BSD4 = "BSD-4"
-convertLicense Cabal.PublicDomain = "public-domain"
-convertLicense Cabal.AllRightsReserved = ""
-convertLicense Cabal.MIT = "MIT"
-convertLicense _ = ""
-
-licenseComment :: Cabal.License -> String
-licenseComment Cabal.AllRightsReserved =
- "Note: packages without a license cannot be included in portage"
-licenseComment Cabal.OtherLicense =
- "Fixme: \"OtherLicense\", please fill in manually"
-licenseComment (Cabal.UnknownLicense _) = "Fixme: license unknown to cabal"
-licenseComment _ = ""
diff --git a/Portage/GHCCore.hs b/Portage/GHCCore.hs
deleted file mode 100644
index 31ced2c..0000000
--- a/Portage/GHCCore.hs
+++ /dev/null
@@ -1,309 +0,0 @@
-
--- Guess GHC version from packages depended upon.
-module Portage.GHCCore
- ( minimumGHCVersionToBuildPackage
- , cabalFromGHC
- , defaultGHC
- ) where
-
-import Distribution.Package
-import Distribution.Version
-import Distribution.Simple.PackageIndex
-import Distribution.InstalledPackageInfo
-
-import Distribution.PackageDescription
-import Distribution.PackageDescription.Configuration
-import Distribution.Compiler (CompilerId(..), CompilerFlavor(GHC))
-import Distribution.System
-
-import Distribution.Text
-
-import Data.Maybe
-import Data.List ( nub )
-
-defaultGHC :: (CompilerId, [PackageName])
-defaultGHC = let (g,pix) = ghc6123 in (g, packageNamesFromPackageIndex pix)
-
-ghcs :: [(CompilerId, PackageIndex)]
-ghcs = [ghc6104, ghc6121, ghc6122, ghc6123, ghc701, ghc742, ghc761]
-
-cabalFromGHC :: [Int] -> Maybe Version
-cabalFromGHC ver = lookup ver table
- where
- table = [([6,6,0], Version [1,1,6] [])
- ,([6,6,1], Version [1,1,6,2] [])
- ,([6,8,1], Version [1,2,2,0] [])
- ,([6,8,2], Version [1,2,3,0] [])
- ,([6,8,3], Version [1,2,4,0] [])
- ,([6,10,1], Version [1,6,0,1] [])
- ,([6,10,2], Version [1,6,0,3] [])
- ,([6,10,3], Version [1,6,0,3] [])
- ,([6,10,4], Version [1,6,0,3] [])
- ,([6,12,1], Version [1,8,0,2] [])
- ,([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
-platform = Platform X86_64 Linux
-
-packageIsCore :: PackageIndex -> PackageName -> Bool
-packageIsCore index pn = not . null $ lookupPackageName index pn
-
-packageIsCoreInAnyGHC :: PackageName -> Bool
-packageIsCoreInAnyGHC pn = any (flip packageIsCore pn) (map snd ghcs)
-
--- | Check if a dependency is satisfiable given a 'PackageIndex'
--- representing the core packages in a GHC version.
--- Packages that are not core will always be accepted, packages that are
--- core in any ghc must be satisfied by the 'PackageIndex'.
-dependencySatisfiable :: PackageIndex -> Dependency -> Bool
-dependencySatisfiable pi dep@(Dependency pn rang)
- | pn == PackageName "Win32" = False -- only exists on windows, not in linux
- | not . null $ lookupDependency pi dep = True -- the package index satisfies the dep
- | packageIsCoreInAnyGHC pn = False -- some other ghcs support the dependency
- | otherwise = True -- the dep is not related with core packages, accept the dep
-
-packageBuildableWithGHCVersion
- :: GenericPackageDescription
- -> (CompilerId, PackageIndex)
- -> Either [Dependency] (PackageDescription, FlagAssignment)
-packageBuildableWithGHCVersion pkg (compiler, pkgIndex) =
- finalizePackageDescription [] (dependencySatisfiable pkgIndex) platform compiler [] pkg
-
--- | Given a 'GenericPackageDescription' it returns the miminum GHC version
--- to build a package, and a list of core packages to that GHC version.
-minimumGHCVersionToBuildPackage :: GenericPackageDescription -> Maybe (CompilerId, [PackageName])
-minimumGHCVersionToBuildPackage gpd =
- listToMaybe [ (cid, packageNamesFromPackageIndex pix)
- | g@(cid, pix) <- ghcs
- , Right _ <- return (packageBuildableWithGHCVersion gpd g)]
-
-mkIndex :: [PackageIdentifier] -> PackageIndex
-mkIndex pids = fromList
- [ emptyInstalledPackageInfo
- { installedPackageId = InstalledPackageId $ display name ++ "-" ++ display version
- , sourcePackageId = pi
- , exposed = True
- }
- | pi@(PackageIdentifier name version) <- pids ]
-
-packageNamesFromPackageIndex :: PackageIndex -> [PackageName]
-packageNamesFromPackageIndex pix = nub $ map fst $ allPackagesByName pix
-
-ghc :: [Int] -> CompilerId
-ghc nrs = CompilerId GHC (Version nrs [])
-
-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)
-
-ghc6123 :: (CompilerId, PackageIndex)
-ghc6123 = (ghc [6,12,3], mkIndex ghc6123_pkgs)
-
-ghc6122 :: (CompilerId, PackageIndex)
-ghc6122 = (ghc [6,12,2], mkIndex ghc6122_pkgs)
-
-ghc6121 :: (CompilerId, PackageIndex)
-ghc6121 = (ghc [6,12,1], mkIndex ghc6121_pkgs)
-
-ghc6104 :: (CompilerId, PackageIndex)
-ghc6104 = (ghc [6,10,4], mkIndex ghc6104_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 =
- [ 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] -- 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]
- , p "hpc" [0,5,0,6]
- , p "integer-gmp" [0,2,0,2]
- , p "integer-simple" [0,1,0,0]
- , p "old-locale" [1,0,0,2]
- , p "old-time" [1,0,0,6]
- , p "pretty" [1,0,1,2]
- , p "process" [1,0,1,4]
--- , p "random" [1,0,0,3] -- will not be shipped starting from ghc-7.2
- , p "template-haskell" [2,5,0,0]
--- , p "time" [1,2,0,3] package is upgradeable
- , p "unix" [2,4,1,0]
--- , p "utf8-string" [0,3,4] package is upgradeable
- ]
-
-ghc6123_pkgs :: [PackageIdentifier]
-ghc6123_pkgs =
- [ p "array" [0,3,0,1]
- , p "base" [3,0,3,2]
- , p "base" [4,2,0,2]
- , p "bytestring" [0,9,1,7]
--- , 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] -- 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]
- , p "integer-gmp" [0,2,0,1]
- , p "integer-simple" [0,1,0,0]
- , p "old-locale" [1,0,0,2]
- , p "old-time" [1,0,0,5]
- , p "pretty" [1,0,1,1]
- , p "process" [1,0,1,3]
--- , p "random" [1,0,0,2] -- will not be shipped starting from ghc-7.2
--- , p "syb" [0,1,0,2] -- not distributed with ghc-7
- , p "template-haskell" [2,4,0,1]
--- , p "time" [1,1,4] package is upgradeable
- , p "unix" [2,4,0,2]
--- , p "utf8-string" [0,3,4] package is upgradeable
- ]
-
-ghc6122_pkgs :: [PackageIdentifier]
-ghc6122_pkgs =
- [ p "array" [0,3,0,0]
- , p "base" [3,0,3,2]
- , p "base" [4,2,0,1]
- , p "bytestring" [0,9,1,6]
--- , 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] -- 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]
- , p "integer-gmp" [0,2,0,1]
- , p "integer-simple" [0,1,0,0]
- , p "old-locale" [1,0,0,2]
- , p "old-time" [1,0,0,4]
- , p "pretty" [1,0,1,1]
- , p "process" [1,0,1,2]
--- , p "random" [1,0,0,2] -- will not be shipped starting from ghc-7.2
--- , p "syb" [0,1,0,2] -- not distributed with ghc-7
- , p "template-haskell" [2,4,0,1]
--- , p "time" [1,1,4] package is upgradeable
- , p "unix" [2,4,0,1]
--- , p "utf8-string" [0,3,4] package is upgradeable
- ]
-
-ghc6121_pkgs :: [PackageIdentifier]
-ghc6121_pkgs =
- [ p "array" [0,3,0,0]
- , p "base" [3,0,3,2]
- , p "base" [4,2,0,0]
- , p "bytestring" [0,9,1,5]
--- , 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] -- 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]
- , p "integer-gmp" [0,2,0,0]
- , p "integer-simple" [0,1,0,0]
- , p "old-locale" [1,0,0,2]
- , p "old-time" [1,0,0,3]
- , p "pretty" [1,0,1,1]
- , p "process" [1,0,1,2]
--- , p "random" [1,0,0,2] -- will not be shipped starting from ghc-7.2
--- , p "syb" [0,1,0,2] -- not distributed with ghc-7
- , p "template-haskell" [2,4,0,0]
--- , p "time" [1,1,4] package is upgradeable
- , p "unix" [2,4,0,0]
--- , p "utf8-string" [0,3,4] package is upgradeable
- ]
-
-ghc6104_pkgs :: [PackageIdentifier]
-ghc6104_pkgs =
- [ p "array" [0,2,0,0]
- , p "base" [3,0,3,1]
- , p "base" [4,1,0,0]
- , p "bytestring" [0,9,1,4]
--- , 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] -- 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]
- , p "old-locale" [1,0,0,1]
- , p "old-time" [1,0,0,2]
- , p "packedstring" [0,1,0,1]
- , p "pretty" [1,0,1,0]
- , p "process" [1,0,1,1]
--- , p "random" [1,0,0,1] -- will not be shipped starting from ghc-7.2
--- , p "syb" [0,1,0,1] -- not distributed with ghc-7
- , p "template-haskell" [2,3,0,1]
--- , p "time" [1,1,4] package is upgradeable
- , p "unix" [2,3,2,0]
- ]
-
-p :: String -> [Int] -> PackageIdentifier
-p pn vs = PackageIdentifier (PackageName pn) (Version vs [])
diff --git a/Portage/Host.hs b/Portage/Host.hs
deleted file mode 100644
index d71390c..0000000
--- a/Portage/Host.hs
+++ /dev/null
@@ -1,92 +0,0 @@
-module Portage.Host
- ( getInfo -- :: IO [(String, String)]
- , LocalInfo(..)
- ) where
-
-import Util (run_cmd)
-import Data.Maybe (fromJust, isJust, catMaybes)
-import Control.Applicative ( (<$>) )
-
-data LocalInfo =
- LocalInfo { distfiles_dir :: String
- , overlay_list :: [FilePath]
- , portage_dir :: FilePath
- } deriving Show
-
-defaultInfo :: LocalInfo
-defaultInfo = LocalInfo { distfiles_dir = "/usr/portage/distfiles"
- , overlay_list = []
- , portage_dir = "/usr/portage"
- }
-
--- query paludis and then emerge
-getInfo :: IO LocalInfo
-getInfo = fromJust `fmap`
- performMaybes [ getPaludisInfo
- , fmap parse_emerge_output <$> (run_cmd "emerge --info")
- , return (Just defaultInfo)
- ]
- where performMaybes [] = return Nothing
- performMaybes (act:acts) =
- do r <- act
- if isJust r
- then return r
- else performMaybes acts
-
-----------
--- Paludis
-----------
-
-getPaludisInfo :: IO (Maybe LocalInfo)
-getPaludisInfo = fmap parsePaludisInfo <$> run_cmd "cave info"
-
-parsePaludisInfo :: String -> LocalInfo
-parsePaludisInfo text =
- let chunks = splitBy (=="") . lines $ text
- repositories = catMaybes (map parseRepository chunks)
- in fromJust (mkLocalInfo repositories)
- where
- parseRepository :: [String] -> Maybe (String, (String, String))
- parseRepository (firstLine:lns) = do
- name <- case words firstLine of
- ["Repository", nm] -> return (init nm)
- _ -> fail "not a repository chunk"
- let dict = [ (head ln, unwords (tail ln)) | ln <- map words lns ]
- location <- lookup "location" dict
- distfiles <- lookup "distdir" dict
- return (name, (location, distfiles))
-
- mkLocalInfo :: [(String, (String, String))] -> Maybe LocalInfo
- mkLocalInfo repos = do
- (gentooLocation, gentooDistfiles) <- lookup "gentoo" repos
- let overlays = [ loc | (name, (loc, _dist)) <- repos ]
- return (LocalInfo
- { distfiles_dir = gentooDistfiles
- , portage_dir = gentooLocation
- , overlay_list = overlays
- })
-
-splitBy :: (a -> Bool) -> [a] -> [[a]]
-splitBy c [] = []
-splitBy c lst =
- let (x,xs) = break c lst
- (_,xs') = span c xs
- in x : splitBy c xs'
-
----------
--- Emerge
----------
-
-parse_emerge_output :: String -> LocalInfo
-parse_emerge_output raw_data =
- foldl updateInfo defaultInfo $ lines raw_data
- where updateInfo info str =
- case (break (== '=') str) of
- ("DISTDIR", '=':value)
- -> info{distfiles_dir = unquote value}
- ("PORTDIR", '=':value)
- -> info{portage_dir = unquote value}
- ("PORTDIR_OVERLAY", '=':value)
- -> info{overlay_list = words $ unquote value}
- _ -> info
- unquote = init . tail
diff --git a/Portage/Metadata.hs b/Portage/Metadata.hs
deleted file mode 100644
index 1190209..0000000
--- a/Portage/Metadata.hs
+++ /dev/null
@@ -1,55 +0,0 @@
-module Portage.Metadata
- ( Metadata(..)
- , metadataFromFile
- , makeDefaultMetadata
- ) where
-
-import qualified Data.ByteString as B
-
-import Control.Applicative
-
-import Text.XML.Light
-
-data Metadata = Metadata
- { metadataHerds :: [String]
- -- , metadataMaintainers :: [String],
- -- , metadataUseFlags :: [(String,String)]
- } deriving (Show)
-
-metadataFromFile :: FilePath -> IO (Maybe Metadata)
-metadataFromFile fp = do
- doc <- parseXMLDoc <$> B.readFile fp
- return (doc >>= parseMetadata)
-
-parseMetadata :: Element -> Maybe Metadata
-parseMetadata xml = do
- let herds = map strContent (findChildren (unqual "herd") xml)
- return Metadata
- {
- metadataHerds = herds
- }
-
--- don't use Text.XML.Light as we like our own pretty printer
-makeDefaultMetadata :: String -> String
-makeDefaultMetadata long_description =
- unlines [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
- , "<!DOCTYPE pkgmetadata SYSTEM \"http://www.gentoo.org/dtd/metadata.dtd\">"
- , "<pkgmetadata>"
- , "\t<herd>haskell</herd>"
- , "\t<maintainer>"
- , "\t\t<email>haskell@gentoo.org</email>"
- , "\t</maintainer>"
- , (init {- strip trailing newline-}
- . unlines
- . map (\l -> if l `elem` ["<longdescription>", "</longdescription>"]
- then "\t" ++ l -- leading/trailing lines
- else "\t\t" ++ l -- description itself
- )
- . lines
- . showElement
- . unode "longdescription"
- . ("\n" ++) -- prepend newline to separate form <longdescription>
- . (++ "\n") -- append newline
- ) long_description
- , "</pkgmetadata>"
- ]
diff --git a/Portage/Overlay.hs b/Portage/Overlay.hs
deleted file mode 100644
index 4184355..0000000
--- a/Portage/Overlay.hs
+++ /dev/null
@@ -1,181 +0,0 @@
-module Portage.Overlay
- ( ExistingEbuild(..)
- , Overlay(..)
- , loadLazy
- , readOverlay, readOverlayByPackage
- , getDirectoryTree, DirectoryTree
-
- , reduceOverlay
- , filterByHerd
- , inOverlay
- )
- where
-
-import qualified Portage.PackageId as Portage
-import qualified Portage.Metadata as Portage
-
-import qualified Distribution.Package as Cabal
-
-import Distribution.Text (simpleParse)
-import Distribution.Simple.Utils ( comparing, equating )
-
-import Data.List as List
-import qualified Data.Map as Map
-import Data.Map (Map)
-import System.Directory (getDirectoryContents, doesDirectoryExist)
-import System.IO.Unsafe (unsafeInterleaveIO)
-import System.FilePath ((</>), splitExtension)
-
-import Data.Traversable ( traverse )
-
-data ExistingEbuild = ExistingEbuild {
- ebuildId :: Portage.PackageId,
- ebuildCabalId :: Cabal.PackageIdentifier,
- ebuildPath :: FilePath
- } deriving (Show,Ord,Eq)
-
-instance Cabal.Package ExistingEbuild where packageId = ebuildCabalId
-
-data Overlay = Overlay {
- overlayPath :: FilePath,
- overlayMap :: Map Portage.PackageName [ExistingEbuild],
- overlayMetadata :: Map Portage.PackageName Portage.Metadata
- } deriving Show
-
-inOverlay :: Overlay -> Cabal.PackageId -> Bool
-inOverlay overlay pkgId = not (Map.null packages)
- where
- packages = Map.filterWithKey
- (\(Portage.PackageName _cat overlay_pn) ebuilds ->
- let cabal_pn = Cabal.pkgName pkgId
- ebs = [ ()
- | e <- ebuilds
- , let ebuild_cabal_id = ebuildCabalId e
- , ebuild_cabal_id == pkgId
- ]
- in cabal_pn == overlay_pn && (not (null ebs))) om
- om = overlayMap overlay
-
-loadLazy :: FilePath -> IO Overlay
-loadLazy path = do
- dir <- getDirectoryTree path
- metadata <- unsafeInterleaveIO $ mkMetadataMap path dir
- return $ mkOverlay metadata $ readOverlayByPackage dir
- where
- allowed v = case v of
- (Portage.Version _ Nothing [] _) -> True
- _ -> False
-
- mkOverlay :: Map Portage.PackageName Portage.Metadata
- -> [(Portage.PackageName, [Portage.Version])]
- -> Overlay
- mkOverlay meta packages = Overlay {
- overlayPath = path,
- overlayMetadata = meta,
- overlayMap =
- Map.fromList
- [ (pkgName, [ ExistingEbuild portageId cabalId filepath
- | version <- allowedVersions
- , let portageId = Portage.PackageId pkgName version
- , Just cabalId <- [ Portage.toCabalPackageId portageId ]
- , let filepath = path </> Portage.packageIdToFilePath portageId
- ])
- | (pkgName, allVersions) <- packages
- , let allowedVersions = filter allowed allVersions
- ]
- }
-
-mkMetadataMap :: FilePath -> DirectoryTree -> IO (Map Portage.PackageName Portage.Metadata)
-mkMetadataMap root dir =
- fmap (Map.mapMaybe id) $
- traverse Portage.metadataFromFile $
- Map.fromList
- [ (Portage.mkPackageName category package, root </> category </> package </> "metadata.xml")
- | Directory category packages <- dir
- , Directory package files <- packages
- , File "metadata.xml" <- files
- ]
-
-filterByHerd :: ([String] -> Bool) -> Overlay -> Overlay
-filterByHerd p overlay = overlay
- { overlayMetadata = metadataMap'
- , overlayMap = pkgMap'
- }
- where
- metadataMap' = Map.filter (p . Portage.metadataHerds) (overlayMetadata overlay)
- pkgMap' = Map.intersection (overlayMap overlay) metadataMap'
-
-
--- make sure there is only one ebuild for each version number (by selecting
--- the highest ebuild version revision)
-reduceOverlay :: Overlay -> Overlay
-reduceOverlay overlay = overlay { overlayMap = Map.map reduceVersions (overlayMap overlay) }
- where
- versionNumbers (Portage.Version nums _ _ _) = nums
- reduceVersions :: [ExistingEbuild] -> [ExistingEbuild]
- reduceVersions ebuilds = -- gah!
- map (maximumBy (comparing (Portage.pkgVersion . ebuildId)))
- . groupBy (equating (versionNumbers . Portage.pkgVersion . ebuildId))
- . sortBy (comparing (Portage.pkgVersion . ebuildId))
- $ ebuilds
-
-readOverlayByPackage :: DirectoryTree -> [(Portage.PackageName, [Portage.Version])]
-readOverlayByPackage tree =
- [ (name, versions name pkgTree)
- | (category, catTree) <- categories tree
- , (name, pkgTree) <- packages category catTree
- ]
-
- where
- categories :: DirectoryTree -> [(Portage.Category, DirectoryTree)]
- categories entries =
- [ (category, entries')
- | Directory dir entries' <- entries
- , Just category <- [simpleParse dir] ]
-
- packages :: Portage.Category -> DirectoryTree
- -> [(Portage.PackageName, DirectoryTree)]
- packages category entries =
- [ (Portage.PackageName category name, entries')
- | Directory dir entries' <- entries
- , Just name <- [simpleParse dir] ]
-
- versions :: Portage.PackageName -> DirectoryTree -> [Portage.Version]
- versions name@(Portage.PackageName (Portage.Category category) _) entries =
- [ version
- | File fileName <- entries
- , let (baseName, ext) = splitExtension fileName
- , ext == ".ebuild"
- , let fullName = category ++ '/' : baseName
- , Just (Portage.PackageId name' version) <- [simpleParse fullName]
- , name == name' ]
-
-readOverlay :: DirectoryTree -> [Portage.PackageId]
-readOverlay tree = [ Portage.PackageId pkgId version
- | (pkgId, versions) <- readOverlayByPackage tree
- , version <- versions
- ]
-
-type DirectoryTree = [DirectoryEntry]
-data DirectoryEntry = File FilePath | Directory FilePath [DirectoryEntry]
-
-getDirectoryTree :: FilePath -> IO DirectoryTree
-getDirectoryTree = dirEntries
-
- where
- dirEntries :: FilePath -> IO [DirectoryEntry]
- dirEntries dir = do
- names <- getDirectoryContents dir
- sequence
- [ do isDirectory <- doesDirectoryExist path
- if isDirectory
- then do entries <- unsafeInterleaveIO (dirEntries path)
- return (Directory name entries)
- else return (File name)
- | name <- names
- , not (ignore name)
- , let path = dir </> name ]
-
- ignore ['.'] = True
- ignore ['.', '.'] = True
- ignore _ = False
diff --git a/Portage/PackageId.hs b/Portage/PackageId.hs
deleted file mode 100644
index ec81733..0000000
--- a/Portage/PackageId.hs
+++ /dev/null
@@ -1,126 +0,0 @@
--- | Portage package identifiers, which unlike Cabal ones include a category.
---
-module Portage.PackageId (
- Category(..),
- PackageName(..),
- PackageId(..),
- Portage.Version(..),
- mkPackageName,
- fromCabalPackageId,
- toCabalPackageId,
- parseFriendlyPackage,
- normalizeCabalPackageName,
- normalizeCabalPackageId,
- packageIdToFilePath
- ) where
-
-import qualified Distribution.Package as Cabal
-import Distribution.Text (Text(..))
-
-import qualified Distribution.Compat.ReadP as Parse
-
-import qualified Portage.Version as Portage
-
-import qualified Text.PrettyPrint as Disp
-import Text.PrettyPrint ((<>))
-import qualified Data.Char as Char (isAlphaNum, isSpace, toLower)
-
-import Distribution.Text(display)
-import System.FilePath ( (</>) )
-
-newtype Category = Category { unCategory :: String }
- deriving (Eq, Ord, Show, Read)
-
-data PackageName = PackageName Category Cabal.PackageName
- deriving (Eq, Ord, Show, Read)
-
-data PackageId = PackageId { packageId :: PackageName, pkgVersion :: Portage.Version }
- deriving (Eq, Ord, Show, Read)
-
-{-
-instance Text PN where
- disp (PN n) = Disp.text n
- parse = do
- ns <- Parse.sepBy1 component (Parse.char '-')
- return (PN (concat (intersperse "-" ns)))
- where
- component = do
- cs <- Parse.munch1 Char.isAlphaNum
- if all Char.isDigit cs then Parse.pfail else return cs
- -- each component must contain an alphabetic character, to avoid
- -- ambiguity in identifiers like foo-1 (the 1 is the version number).
--}
-
-packageIdToFilePath :: PackageId -> FilePath
-packageIdToFilePath (PackageId (PackageName cat pn) version) =
- display cat </> display pn </> display pn <-> display version <.> "ebuild"
- where
- a <-> b = a ++ '-':b
- a <.> b = a ++ '.':b
-
-mkPackageName :: String -> String -> PackageName
-mkPackageName cat package = PackageName (Category cat) (Cabal.PackageName package)
-
-fromCabalPackageId :: Category -> Cabal.PackageIdentifier -> PackageId
-fromCabalPackageId category (Cabal.PackageIdentifier name version) =
- PackageId (PackageName category (normalizeCabalPackageName name))
- (Portage.fromCabalVersion version)
-
-normalizeCabalPackageName :: Cabal.PackageName -> Cabal.PackageName
-normalizeCabalPackageName (Cabal.PackageName name) =
- Cabal.PackageName (map Char.toLower name)
-
-normalizeCabalPackageId :: Cabal.PackageIdentifier -> Cabal.PackageIdentifier
-normalizeCabalPackageId (Cabal.PackageIdentifier name version) =
- Cabal.PackageIdentifier (normalizeCabalPackageName name) version
-
-toCabalPackageId :: PackageId -> Maybe Cabal.PackageIdentifier
-toCabalPackageId (PackageId (PackageName _cat name) version) =
- fmap (Cabal.PackageIdentifier name)
- (Portage.toCabalVersion version)
-
-instance Text Category where
- disp (Category c) = Disp.text c
- parse = fmap Category (Parse.munch1 categoryChar)
- where
- categoryChar c = Char.isAlphaNum c || c == '-'
-
-instance Text PackageName where
- disp (PackageName category name) =
- disp category <> Disp.char '/' <> disp name
-
- parse = do
- category <- parse
- _ <- Parse.char '/'
- name <- parse
- return (PackageName category name)
-
-instance Text PackageId where
- disp (PackageId name version) =
- disp name <> Disp.char '-' <> disp version
-
- parse = do
- name <- parse
- _ <- Parse.char '-'
- version <- parse
- return (PackageId name version)
-
-parseFriendlyPackage :: String -> Maybe (Maybe Category, Cabal.PackageName, Maybe Portage.Version)
-parseFriendlyPackage str =
- case [ p | (p,s) <- Parse.readP_to_S parser str
- , all Char.isSpace s ] of
- [] -> Nothing
- (x:_) -> Just x
- where
- parser = do
- mc <- Parse.option Nothing $ do
- c <- parse
- _ <- Parse.char '/'
- return (Just c)
- p <- parse
- mv <- Parse.option Nothing $ do
- _ <- Parse.char '-'
- v <- parse
- return (Just v)
- return (mc, p, mv)
-
diff --git a/Portage/Resolve.hs b/Portage/Resolve.hs
deleted file mode 100644
index 1f66b72..0000000
--- a/Portage/Resolve.hs
+++ /dev/null
@@ -1,75 +0,0 @@
-{-# LANGUAGE PatternGuards #-}
-
-module Portage.Resolve
- ( resolveCategory
- , resolveCategories
- , resolveFullPortageName
- ) where
-
-import qualified Portage.Overlay as Overlay
-import qualified Portage.PackageId as Portage
-
-import Distribution.Verbosity
-import Distribution.Text (display)
-import qualified Distribution.Package as Cabal
-import Distribution.Simple.Utils
-
-import qualified Data.Map as Map
-
-import Error
-
-import Debug.Trace (trace)
-
--- | If a package already exist in the overlay, find which category it has.
--- If it does not exist, we default to \'dev-haskell\'.
-resolveCategory :: Verbosity -> Overlay.Overlay -> Cabal.PackageName -> IO Portage.Category
-resolveCategory verbosity overlay pn = do
- info verbosity "Searching for which category to use..."
- case resolveCategories overlay pn of
- [] -> do
- info verbosity "No previous version of this package, defaulting category to dev-haskell."
- return devhaskell
- [cat] -> do
- info verbosity $ "Exact match of already existing package, using category: "
- ++ display cat
- return cat
- cats -> do
- warn verbosity $ "Multiple matches of categories: " ++ unwords (map display cats)
- if devhaskell `elem` cats
- then do notice verbosity "Defaulting to dev-haskell"
- return devhaskell
- else do warn verbosity "Multiple matches and no known default. Override by specifying "
- warn verbosity "package category like so 'hackport merge categoryname/package[-version]."
- throwEx (ArgumentError "Specify package category and try again.")
- where
- devhaskell = Portage.Category "dev-haskell"
-
-resolveCategories :: Overlay.Overlay -> Cabal.PackageName -> [Portage.Category]
-resolveCategories overlay pn =
- [ cat
- | (Portage.PackageName cat pn') <- Map.keys om
- , pn == Portage.normalizeCabalPackageName pn'
- ]
- where
- om = Overlay.overlayMap overlay
-
-resolveFullPortageName :: Overlay.Overlay -> Cabal.PackageName -> Maybe Portage.PackageName
-resolveFullPortageName overlay pn =
- case resolveCategories overlay pn of
- [] -> Nothing
- [cat] -> ret cat
- cats | (cat:_) <- (filter (`elem` cats) priority) -> ret cat
- | otherwise -> trace ("Ambiguous package name: " ++ show pn ++ ", hits: " ++ show cats) Nothing
- where
- ret c = return (Portage.PackageName c pn)
- mkC = Portage.Category
- -- if any of these categories show up in the result list, the match isn't
- -- ambiguous, pick the first match in the list
- priority = [ mkC "dev-haskell"
- , mkC "sys-libs"
- , mkC "dev-libs"
- , mkC "x11-libs"
- , mkC "media-libs"
- , mkC "net-libs"
- , mkC "sci-libs"
- ]
diff --git a/Portage/Use.hs b/Portage/Use.hs
deleted file mode 100644
index b12ce03..0000000
--- a/Portage/Use.hs
+++ /dev/null
@@ -1,50 +0,0 @@
-module Portage.Use (
- -- * main structures
- UseFlag(..),
- Use,
- dispUses,
- -- * helpers
- mkUse,
- mkNotUse,
- mkQUse
- ) where
-
-import qualified Text.PrettyPrint as Disp
-import Text.PrettyPrint ((<>))
-import Distribution.Text ( Text(..) )
-
--- | Use variable modificator
-data UseFlag = UseFlag Use -- ^ no modificator
- | E UseFlag -- ^ = modificator (Equiv mark)
- | Q UseFlag -- ^ ? modificator (Question mark)
- | X UseFlag -- ^ ! modificator (eXclamation mark)
- | N UseFlag -- ^ - modificator
- deriving (Eq,Show,Ord,Read)
-
--- |
-mkUse :: Use -> UseFlag
-mkUse = UseFlag
-
-mkNotUse :: Use -> UseFlag
-mkNotUse = UseFlag
-
-mkQUse :: Use -> UseFlag
-mkQUse = Q . UseFlag
-
-
-instance Text UseFlag where
- disp = showModificator
-
-showModificator :: UseFlag -> Disp.Doc
-showModificator (UseFlag u) = Disp.text u
-showModificator (X u) = Disp.char '!' <> disp u
-showModificator (Q u) = disp u <> Disp.char '?'
-showModificator (E u) = disp u <> Disp.char '='
-showModificator (N u) = Disp.char '-' <> disp u
-
-dispUses :: [UseFlag] -> Disp.Doc
-dispUses [] = Disp.empty
-dispUses us = Disp.brackets $ Disp.hcat $ (Disp.punctuate (Disp.text ", ")) $ map disp us
-
-type Use = String
-
diff --git a/Portage/Version.hs b/Portage/Version.hs
deleted file mode 100644
index 1f26d86..0000000
--- a/Portage/Version.hs
+++ /dev/null
@@ -1,95 +0,0 @@
-{-|
- Author : Andres Loeh <kosmikus@gentoo.org>
- Stability : provisional
- Portability : haskell98
-
- Version parser, according to Portage spec.
-
- Shamelessly borrowed from exi, ported from Parsec to ReadP
-
--}
-
-module Portage.Version (
- Version(..),
- Suffix(..),
- fromCabalVersion,
- toCabalVersion,
- is_live
- ) where
-
-import qualified Distribution.Version as Cabal
-
-import Distribution.Text (Text(..))
-
-import qualified Distribution.Compat.ReadP as Parse
-import qualified Text.PrettyPrint as Disp
-import Text.PrettyPrint ((<>))
-import qualified Data.Char as Char (isAlpha, isDigit)
-
-data Version = Version { versionNumber :: [Int] -- [1,42,3] ~= 1.42.3
- , versionChar :: (Maybe Char) -- optional letter
- , versionSuffix :: [Suffix]
- , versionRevision :: Int -- revision, 0 means none
- }
- deriving (Eq, Ord, Show, Read)
-
--- foo-9999* is treated as live ebuild
-is_live :: Version -> Bool
-is_live v =
- case versionNumber v of
- [n] | n >= 9999 && (all (== '9') . show) n -> True
- _ -> False
-
-data Suffix = Alpha Int | Beta Int | Pre Int | RC Int | P Int
- deriving (Eq, Ord, Show, Read)
-
-fromCabalVersion :: Cabal.Version -> Version
-fromCabalVersion (Cabal.Version nums _tags) = Version nums Nothing [] 0
-
-toCabalVersion :: Version -> Maybe Cabal.Version
-toCabalVersion (Version nums Nothing [] _) = Just (Cabal.Version nums [])
-toCabalVersion _ = Nothing
-
-instance Text Version where
- disp (Version ver c suf rev) =
- dispVer ver <> dispC c <> dispSuf suf <> dispRev rev
- where
- dispVer = Disp.hcat . Disp.punctuate (Disp.char '.') . map Disp.int
- dispC = maybe Disp.empty Disp.char
- dispSuf = Disp.hcat . map disp
- dispRev 0 = Disp.empty
- dispRev n = Disp.text "-r" <> Disp.int n
-
- parse = do
- ver <- Parse.sepBy1 digits (Parse.char '.')
- c <- Parse.option Nothing (fmap Just (Parse.satisfy Char.isAlpha))
- suf <- Parse.many parse
- rev <- Parse.option 0 (Parse.string "-r" >> digits)
- return (Version ver c suf rev)
-
-instance Text Suffix where
- disp suf = case suf of
- Alpha n -> Disp.text "_alpha" <> dispPos n
- Beta n -> Disp.text "_beta" <> dispPos n
- Pre n -> Disp.text "_pre" <> dispPos n
- RC n -> Disp.text "_rc" <> dispPos n
- P n -> Disp.text "_p" <> dispPos n
-
- where
- dispPos :: Int -> Disp.Doc
- dispPos 0 = Disp.empty
- dispPos n = Disp.int n
-
- parse = Parse.char '_'
- >> Parse.choice
- [ Parse.string "alpha" >> fmap Alpha maybeDigits
- , Parse.string "beta" >> fmap Beta maybeDigits
- , Parse.string "pre" >> fmap Pre maybeDigits
- , Parse.string "rc" >> fmap RC maybeDigits
- , Parse.string "p" >> fmap P maybeDigits
- ]
- where
- maybeDigits = Parse.option 0 digits
-
-digits :: Parse.ReadP r Int
-digits = fmap read (Parse.munch1 Char.isDigit)
diff --git a/Progress.hs b/Progress.hs
deleted file mode 100644
index f318f57..0000000
--- a/Progress.hs
+++ /dev/null
@@ -1,62 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Progress
--- Copyright : (c) Duncan Coutts 2008
--- License : BSD-like
---
--- Maintainer : duncan@haskell.org
--- Portability : portable
---
--- Common types for dependency resolution.
------------------------------------------------------------------------------
-module Progress (
- Progress(..),
- fold, unfold, fromList,
- ) where
-
-import Prelude hiding (fail)
-
--- | 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.
---
-data Progress step fail done = Step step (Progress step fail done)
- | Fail fail
- | Done done
-
--- | Consume a 'Progress' calculation. Much like 'foldr' for lists but with
--- two base cases, one for a final result and one for failure.
---
--- Eg to convert into a simple 'Either' result use:
---
--- > foldProgress (flip const) Left Right
---
-fold :: (step -> a -> a) -> (fail -> a) -> (done -> a)
- -> Progress step fail done -> a
-fold step fail done = go
- where
- go (Step s p) = step s (go p)
- go (Fail f) = fail f
- go (Done r) = done r
-
-unfold :: (s -> Either (Either fail done) (step, s))
- -> s -> Progress step fail done
-unfold f = go
- where
- go s = case f s of
- Left (Left fail) -> Fail fail
- Left (Right done) -> Done done
- Right (step, s') -> Step step (go s')
-
-fromList :: [a] -> Progress () b [a]
-fromList xs0 = unfold next xs0
- where
- next [] = Left (Right xs0)
- next (_:xs) = Right ((), xs)
-
-instance Functor (Progress step fail) where
- fmap f = fold Step Fail (Done . f)
-
-instance Monad (Progress step fail) where
- return a = Done a
- p >>= f = fold Step Fail f p
diff --git a/README.rst b/README.rst
deleted file mode 100644
index 28898aa..0000000
--- a/README.rst
+++ /dev/null
@@ -1,133 +0,0 @@
-Hackport
-========
-
-About
------
-
-Hackport is a utility application for Gentoo Linux to ease the tasks for the
-Haskell Project.
-
-The main purpose for Hackport is to interact with Hackage and create
-Ebuilds from Cabal packages. It also does handy functions to compare
-hackage, the overlay and the portage tree.
-
-Quick start
------------
-
-1. Build hackport binary by hand (or install it from haskell overlay).
-2. Setup hackport database into overlay you plan to merge new ebuilds:
-
-::
-
- $ mkdir ~/overlays
- $ cd ~/overlays
- $ git clone git://github.com/gentoo-haskell/gentoo-haskell.git
- $ cd gentoo-haskell
- $ hackport update
- $ ls -1 .hackport/
- 00-index.tar
- 00-index.tar.gz
-
-3. Add your ~/overlays/gentoo-haskell to PORTDIR_OVERLAY in /etc/make.conf.
-
-Done! Now you can `hackport merge <package-name>` to get an ebuild merged to
-your overlay!
-
-Features
---------
-
- 'hackport update'
- Update the local copy of hackage's package list. You should run this
- every once in a while to get a more recent copy.
-
- 'hackport list [FILTER]'
- Print packages from hackage, with an optional substring matching.
-
- 'hackport merge <package>'
- Create a Gentoo Linux Ebuild for hackage package named <package>.
- The category defaults to dev-haskell, but is overridden if an older
- version has been merged previously to another category. The category
- can also be overridden with the syntax category/package. Example:
-
- $ hackport merge x11-wm/xmonad
-
- Hackport will make an ebuild that uses the haskell-cabal eclass, and
- set the following properties:
-
- PN (package name)
- Package name converted into lower case
- PV (package version)
- Package version with tags dropped.
- KEYWORDS
- Defaults to ~amd64 ~x86
- CABAL_FEATURES
- Set to "bin" for executables, and "lib haddock profile" for
- libraries. Packages that contains both a binary and library will
- get the union.
- DEPEND
- GHC dependency defaults to >=dev-lang/ghc-6.6.1.
- Cabal dependency is fetched from Cabal field 'Cabal-Version'.
- All other package dependencies are converted into gentoo syntax.
- Range dependencies are flattened and usually needs manual
- tweaking.
- DESCRIPTION
- From Synopsis if it is non-empty, otherwise Description.
- HOMEPAGE
- From Homepage
- SRC_URI
- From package url
- LICENSE
- From cabal license converted into gentoo licenses
- SLOT
- Defaults to "0"
-
- 'hackport diff [missing|additions|newer|common]'
- Prints a list showing a diff between hackage and the overlay.
- For each package it shows the latest version in both hackage and the
- overlay.
-
-
- Optional parameters:
- 'all', the default action
- List all packages.
- 'missing'
- List packages that exist in hackage but not in the overlay,
- or where the hackage version is more recent.
- 'additions'
- List packages only in the overlay, or where the overlay has
- a more recent version.
- 'newer'
- List packages where hackage has a more recent version.
- 'common'
- List packages where hackage and the overlay has the same
- version.
-
- 'hackport status [toportage]'
- Provides an overview comparing the overlay to the portage tree.
- It will teel you, for each package and version, if the package exist
-
- - only in the portage tree
- - only in the overlay
- - both in the portage tree and the overlay
- - both in the portage tree and the overlay,
- but the ebuilds are not identical
-
- Optional parameters:
- '--to-portage'
- Only print packages that are likely to be interesting to
- move to the portage tree.
- It will print packages when they exist in both portage and
- the overlay, and:
- - the ebuilds differ, or
- - the overlay has a more recent version
-
- 'hackport make-ebuild <category> <path/to/package.cabal>'
- Generates standalone .ebuild file from .cabal spec and stores result
- to the overlay into <category>/<package>
- Option is useful for not-on-hackage packages and for debug purposes.
-
--------
-
- Henning Günther
- Duncan Coutts
- Lennart Kolmodin
diff --git a/Setup.hs b/Setup.hs
deleted file mode 100644
index 36c3aa9..0000000
--- a/Setup.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-#!/usr/bin/runhaskell
-module Main where
-
-import Distribution.Simple
-
-main :: IO ()
-main = defaultMain
diff --git a/Status.hs b/Status.hs
deleted file mode 100644
index 9803bac..0000000
--- a/Status.hs
+++ /dev/null
@@ -1,240 +0,0 @@
-module Status
- ( FileStatus(..)
- , StatusDirection(..)
- , fromStatus
- , status
- , runStatus
- ) where
-
-import AnsiColor
-
-import qualified Portage.Version as V (is_live)
-
-import Portage.Overlay
-import Portage.PackageId
-import Portage.Resolve
-
-import Control.Monad.State
-
-import qualified Data.List as List
-
-import qualified Data.ByteString.Lazy.Char8 as L
-
-import Data.Char
-import Data.Function (on)
-import qualified Data.Map as Map
-import Data.Map as Map (Map)
-
-import qualified Data.Traversable as T
-import Control.Applicative
-
--- cabal
-import Distribution.Client.Types ( Repo, SourcePackageDb(..), SourcePackage(..) )
-import Distribution.Verbosity
-import Distribution.Package (pkgName)
-import Distribution.Simple.Utils (comparing, die, equating)
-import Distribution.Text ( display, simpleParse )
-
-import qualified Distribution.Client.PackageIndex as CabalInstall
-import qualified Distribution.Client.IndexUtils as CabalInstall
-
-import Hackage (defaultRepo)
-
-data StatusDirection
- = PortagePlusOverlay
- | OverlayToPortage
- | HackageToOverlay
- deriving Eq
-
-data FileStatus a
- = Same a
- | Differs a a
- | OverlayOnly a
- | PortageOnly a
- | HackageOnly a
- deriving (Show,Eq)
-
-instance Ord a => Ord (FileStatus a) where
- compare = comparing fromStatus
-
-instance Functor FileStatus where
- fmap f st =
- case st of
- Same a -> Same (f a)
- Differs a b -> Differs (f a) (f b)
- OverlayOnly a -> OverlayOnly (f a)
- PortageOnly a -> PortageOnly (f a)
- HackageOnly a -> HackageOnly (f a)
-
-fromStatus :: FileStatus a -> a
-fromStatus fs =
- case fs of
- Same a -> a
- Differs a _ -> a -- second status is lost
- OverlayOnly a -> a
- PortageOnly a -> a
- HackageOnly a -> a
-
-
-
-loadHackage :: Verbosity -> Distribution.Client.Types.Repo -> Overlay -> IO [[PackageId]]
-loadHackage verbosity repo overlay = do
- SourcePackageDb { packageIndex = pindex } <- CabalInstall.getSourcePackages verbosity [repo]
- let get_cat cabal_pkg = case resolveCategories overlay (pkgName cabal_pkg) of
- [cat] -> cat
- _ -> {- ambig -} Category "dev-haskell"
- pkg_infos = map ( reverse . take 3 . reverse -- hackage usually has a ton of older versions
- . map ((\p -> fromCabalPackageId (get_cat p) p)
- . packageInfoId))
- (CabalInstall.allPackagesByName pindex)
- return pkg_infos
-
-status :: Verbosity -> FilePath -> FilePath -> IO (Map PackageName [FileStatus ExistingEbuild])
-status verbosity portdir overlaydir = do
- let repo = defaultRepo overlaydir
- overlay <- loadLazy overlaydir
- hackage <- loadHackage verbosity repo overlay
- portage <- filterByHerd ("haskell" `elem`) <$> loadLazy portdir
- let (over, both, port) = portageDiff (overlayMap overlay) (overlayMap portage)
-
- both' <- T.forM both $ mapM $ \e -> liftIO $ do
- -- can't fail, we know the ebuild exists in both portagedirs
- -- also, one of them is already bound to 'e'
- let (Just e1) = lookupEbuildWith (overlayMap portage) (ebuildId e)
- (Just e2) = lookupEbuildWith (overlayMap overlay) (ebuildId e)
- eq <- equals (ebuildPath e1) (ebuildPath e2)
- return $ if eq
- then Same e1
- else Differs e1 e2
-
- let p_to_ee :: PackageId -> ExistingEbuild
- p_to_ee p = ExistingEbuild p cabal_p ebuild_path
- where Just cabal_p = toCabalPackageId p -- lame doubleconv
- ebuild_path = packageIdToFilePath p
- mk_fake_ee :: [PackageId] -> (PackageName, [ExistingEbuild])
- mk_fake_ee ~pkgs@(p:_) = (packageId p, map p_to_ee pkgs)
-
- map_diff = Map.differenceWith (\le re -> Just $ foldr (List.deleteBy (equating ebuildId)) le re)
- hack = ((Map.fromList $ map mk_fake_ee hackage) `map_diff` overlayMap overlay) `map_diff` overlayMap portage
-
- meld = Map.unionsWith (\a b -> List.sort (a++b))
- [ Map.map (map PortageOnly) port
- , both'
- , Map.map (map OverlayOnly) over
- , Map.map (map HackageOnly) hack
- ]
- return meld
-
-type EMap = Map PackageName [ExistingEbuild]
-
-lookupEbuildWith :: EMap -> PackageId -> Maybe ExistingEbuild
-lookupEbuildWith overlay pkgid = do
- ebuilds <- Map.lookup (packageId pkgid) overlay
- List.find (\e -> ebuildId e == pkgid) ebuilds
-
-runStatus :: Verbosity -> FilePath -> FilePath -> StatusDirection -> [String] -> IO ()
-runStatus verbosity portdir overlaydir direction pkgs = do
- let pkgFilter = case direction of
- OverlayToPortage -> toPortageFilter
- PortagePlusOverlay -> id
- HackageToOverlay -> fromHackageFilter
- pkgs' <- forM pkgs $ \p ->
- case simpleParse p of
- Nothing -> die ("Could not parse package name: " ++ p ++ ". Format cat/pkg")
- Just pn -> return pn
- tree0 <- status verbosity portdir overlaydir
- let tree = pkgFilter tree0
- if (null pkgs')
- then statusPrinter tree
- else forM_ pkgs' $ \pkg -> statusPrinter (Map.filterWithKey (\k _ -> k == pkg) tree)
-
--- |Only return packages that seems interesting to sync to portage;
---
--- * Ebuild differs, or
--- * Newer version in overlay than in portage
-toPortageFilter :: Map PackageName [FileStatus ExistingEbuild] -> Map PackageName [FileStatus ExistingEbuild]
-toPortageFilter = Map.mapMaybe $ \ sts ->
- let inPortage = flip filter sts $ \st ->
- case st of
- OverlayOnly _ -> False
- HackageOnly _ -> False
- _ -> True
- latestPortageVersion = List.maximum $ map (pkgVersion . ebuildId . fromStatus) inPortage
- interestingPackages = flip filter sts $ \st ->
- case st of
- Differs _ _ -> True
- _ | pkgVersion (ebuildId (fromStatus st)) > latestPortageVersion -> True
- | otherwise -> False
- in if not (null inPortage) && not (null interestingPackages)
- then Just sts
- else Nothing
-
--- |Only return packages that exist in overlay or portage but look outdated
-fromHackageFilter :: Map PackageName [FileStatus ExistingEbuild] -> Map PackageName [FileStatus ExistingEbuild]
-fromHackageFilter = Map.mapMaybe $ \ sts ->
- let inEbuilds = flip filter sts $ \st ->
- case st of
- HackageOnly _ -> False
- _ -> True
- -- treat live as oldest version not avoid masking hackage releases
- mangle_live_versions v
- | V.is_live v = v {versionNumber=[-1]}
- | otherwise = v
- latestVersion = List.maximumBy (compare `on` mangle_live_versions . pkgVersion . ebuildId . fromStatus) sts
- in case latestVersion of
- HackageOnly _ | not (null inEbuilds) -> Just sts
- _ -> Nothing
-
-statusPrinter :: Map PackageName [FileStatus ExistingEbuild] -> IO ()
-statusPrinter packages = do
- putStrLn $ toColor (Same "Green") ++ ": package in portage and overlay are the same"
- putStrLn $ toColor (Differs "Yellow" "") ++ ": package in portage and overlay differs"
- putStrLn $ toColor (OverlayOnly "Red") ++ ": package only exist in the overlay"
- putStrLn $ toColor (PortageOnly "Magenta") ++ ": package only exist in the portage tree"
- putStrLn $ toColor (HackageOnly "Cyan") ++ ": package only exist on hackage"
- forM_ (Map.toAscList packages) $ \(pkg, ebuilds) -> do
- let (PackageName c p) = pkg
- putStr $ display c ++ '/' : bold (display p)
- putStr " "
- forM_ ebuilds $ \e -> do
- putStr $ toColor (fmap (display . pkgVersion . ebuildId) e)
- putChar ' '
- putStrLn ""
-
-toColor :: FileStatus String -> String
-toColor st = inColor c False Default (fromStatus st)
- where
- c = case st of
- (Same _) -> Green
- (Differs _ _) -> Yellow
- (OverlayOnly _) -> Red
- (PortageOnly _) -> Magenta
- (HackageOnly _) -> Cyan
-
-portageDiff :: EMap -> EMap -> (EMap, EMap, EMap)
-portageDiff p1 p2 = (in1, ins, in2)
- where ins = Map.filter (not . null) $ Map.intersectionWith (List.intersectBy $ equating ebuildId) p1 p2
- in1 = difference p1 p2
- in2 = difference p2 p1
- difference x y = Map.filter (not . null) $
- Map.differenceWith (\xs ys ->
- let lst = foldr (List.deleteBy (equating ebuildId)) xs ys in
- if null lst
- then Nothing
- else Just lst
- ) x y
-
--- | Compares two ebuilds, returns True if they are equal.
--- Disregards comments.
-equals :: FilePath -> FilePath -> IO Bool
-equals fp1 fp2 = do
- f1 <- L.readFile fp1
- f2 <- L.readFile fp2
- return (equal' f1 f2)
-
-equal' :: L.ByteString -> L.ByteString -> Bool
-equal' = equating essence
- where
- essence = filter (not . isEmpty) . filter (not . isComment) . L.lines
- isComment = L.isPrefixOf (L.pack "#") . L.dropWhile isSpace
- isEmpty = L.null . L.dropWhile isSpace
diff --git a/TODO b/TODO
deleted file mode 100644
index f4ed04a..0000000
--- a/TODO
+++ /dev/null
@@ -1,39 +0,0 @@
-
-Easier
-====
-
-* Document the commands in Main.hs with text from README.
- commandDescription and commandSynopsis fields in the CommandUI records
-
-* continue on the CLI. see what additional flags the commands need, if there
- still are any missing. set good default values, and make sure we don't
- get any 'fromFlag' errors due to missing defaults for all commands
-
-* catch base constraints and upgrade ghc requirement
- (like in vty-4.0.0.1: base >= 4 leads to ghc >= 6.10)
-
-Harder
-======
-
-* translate the dev-db/libpq dependency into dev-db/postgresql-base
- the cabal field to describe c libs should be translated if we know the
- proper gentoo package name.
-
-* see if PackageIndex and IndexUtils from cabal install can be used instead of Index
- see Distribution.Simple.PackageIndex
- PackageIndex Ebuild?
-
-* make clear destinction of Hackage.Package and Portage.Package (notice the namespaces)
- Look into Portage, P2 and whatever other hacks there might be and
- properly separate them into the two categories.
- See the already existing Portage.PackageId
-
-* look into Ebuild's field ePkgDesc and its uses
-
-* Merge the separate tool keyword-stat into hackport, and make it use the
- hackport API.
- See http://code.haskell.org/gentoo/keyword-stat/
-
-* Pick keywords from latest available ebuild
-
-* hacport status --to-portage should warn about different 'ChangeLog' and 'metadata.xml' files
diff --git a/Util.hs b/Util.hs
deleted file mode 100644
index 95f5d88..0000000
--- a/Util.hs
+++ /dev/null
@@ -1,31 +0,0 @@
-{-|
- Author : Sergei Trofimovich <slyfox@inbox.ru>
- Stability : experimental
- Portability : haskell98
-
- Ungrouped utilitary stuff lays here until someone finds better place for it :]
--}
-
-module Util
- ( run_cmd -- :: String -> IO (Maybe String)
- ) where
-
-import System.IO
-import System.Process
-import System.Exit (ExitCode(..))
-
--- 'run_cmd' executes command and returns it's standard output
--- as 'String'.
-
-run_cmd :: String -> IO (Maybe String)
-run_cmd cmd = do (hI, hO, hE, hProcess) <- runInteractiveCommand cmd
- hClose hI
- output <- hGetContents hO
- errors <- hGetContents hE -- TODO: propagate error to caller
- length output `seq` hClose hO
- length errors `seq` hClose hE
-
- exitCode <- waitForProcess hProcess
- return $ if (output == "" || exitCode /= ExitSuccess)
- then Nothing
- else Just output
diff --git a/cabal/Cabal/Cabal.cabal b/cabal/Cabal/Cabal.cabal
deleted file mode 100644
index a80e13b..0000000
--- a/cabal/Cabal/Cabal.cabal
+++ /dev/null
@@ -1,193 +0,0 @@
-Name: Cabal
-Version: 1.17.0
-Copyright: 2003-2006, Isaac Jones
- 2005-2011, Duncan Coutts
-License: BSD3
-License-File: LICENSE
-Author: Isaac Jones <ijones@syntaxpolice.org>
- Duncan Coutts <duncan@community.haskell.org>
-Maintainer: cabal-devel@haskell.org
-Homepage: http://www.haskell.org/cabal/
-bug-reports: https://github.com/haskell/cabal/issues
-Synopsis: A framework for packaging Haskell software
-Description:
- The Haskell Common Architecture for Building Applications and
- Libraries: a framework defining a common interface for authors to more
- easily build their Haskell applications in a portable way.
- .
- The Haskell Cabal is part of a larger infrastructure for distributing,
- organizing, and cataloging Haskell libraries and tools.
-Category: Distribution
-cabal-version: >=1.10
-Build-Type: Custom
--- Even though we do use the default Setup.lhs it's vital to bootstrapping
--- that we build Setup.lhs using our own local Cabal source code.
-
-Extra-Source-Files:
- README changelog
-
-source-repository head
- type: git
- location: https://github.com/haskell/cabal/
- subdir: Cabal
-
-Flag base4
- Description: Choose the even newer, even smaller, split-up base package.
-
-Flag base3
- Description: Choose the new smaller, split-up base package.
-
-Flag bytestring-in-base
-
-Library
- build-depends: base >= 2 && < 5,
- 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.3,
- process >= 1 && < 1.2,
- 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.7
-
- ghc-options: -Wall -fno-ignore-asserts
- if impl(ghc >= 6.8)
- ghc-options: -fwarn-tabs
- nhc98-Options: -K4M
-
- Exposed-Modules:
- Distribution.Compiler,
- Distribution.InstalledPackageInfo,
- Distribution.License,
- Distribution.Make,
- Distribution.ModuleName,
- Distribution.Package,
- Distribution.PackageDescription,
- Distribution.PackageDescription.Configuration,
- Distribution.PackageDescription.Parse,
- Distribution.PackageDescription.Check,
- Distribution.PackageDescription.PrettyPrint,
- Distribution.ParseUtils,
- Distribution.ReadE,
- Distribution.Simple,
- Distribution.Simple.Build,
- Distribution.Simple.Build.Macros,
- Distribution.Simple.Build.PathsModule,
- Distribution.Simple.BuildPaths,
- Distribution.Simple.Bench,
- Distribution.Simple.Command,
- Distribution.Simple.Compiler,
- Distribution.Simple.Configure,
- Distribution.Simple.GHC,
- Distribution.Simple.LHC,
- Distribution.Simple.Haddock,
- Distribution.Simple.Hpc,
- Distribution.Simple.Hugs,
- Distribution.Simple.Install,
- Distribution.Simple.InstallDirs,
- Distribution.Simple.JHC,
- Distribution.Simple.LocalBuildInfo,
- Distribution.Simple.NHC,
- Distribution.Simple.PackageIndex,
- Distribution.Simple.PreProcess,
- Distribution.Simple.PreProcess.Unlit,
- Distribution.Simple.Program,
- Distribution.Simple.Program.Ar,
- Distribution.Simple.Program.Builtin,
- Distribution.Simple.Program.Db,
- Distribution.Simple.Program.GHC,
- Distribution.Simple.Program.HcPkg,
- Distribution.Simple.Program.Hpc,
- Distribution.Simple.Program.Ld,
- Distribution.Simple.Program.Run,
- Distribution.Simple.Program.Script,
- Distribution.Simple.Program.Types,
- Distribution.Simple.Register,
- Distribution.Simple.Setup,
- Distribution.Simple.SrcDist,
- Distribution.Simple.Test,
- Distribution.Simple.UHC,
- Distribution.Simple.UserHooks,
- Distribution.Simple.Utils,
- Distribution.System,
- Distribution.TestSuite,
- Distribution.Text,
- Distribution.Verbosity,
- Distribution.Version,
- Distribution.Compat.ReadP,
- Language.Haskell.Extension
-
- Other-Modules:
- Distribution.GetOpt,
- Distribution.Compat.Exception,
- Distribution.Compat.CopyFile,
- Distribution.Compat.TempFile,
- Distribution.Simple.GHC.IPI641,
- Distribution.Simple.GHC.IPI642,
- Paths_Cabal
-
- Default-Language: Haskell98
- Default-Extensions: CPP
-
--- Small, fast running tests.
-test-suite unit-tests
- type: exitcode-stdio-1.0
- 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,
- PackageTests.BuildDeps.InternalLibrary1.Check,
- PackageTests.BuildDeps.InternalLibrary2.Check,
- PackageTests.BuildDeps.InternalLibrary3.Check,
- PackageTests.BuildDeps.InternalLibrary4.Check,
- PackageTests.BuildDeps.TargetSpecificDeps1.Check,
- PackageTests.BuildDeps.TargetSpecificDeps2.Check,
- PackageTests.BuildDeps.TargetSpecificDeps3.Check,
- PackageTests.BuildDeps.SameDepsAllRound.Check,
- PackageTests.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 >= 0.2.12,
- test-framework-hunit,
- HUnit,
- QuickCheck >= 2.1.0.1,
- Cabal,
- process,
- directory,
- filepath,
- extensible-exceptions,
- bytestring,
- unix
- Default-Language: Haskell98
diff --git a/cabal/Cabal/DefaultSetup.hs b/cabal/Cabal/DefaultSetup.hs
deleted file mode 100644
index 9a994af..0000000
--- a/cabal/Cabal/DefaultSetup.hs
+++ /dev/null
@@ -1,2 +0,0 @@
-import Distribution.Simple
-main = defaultMain
diff --git a/cabal/Cabal/Distribution/Compat/CopyFile.hs b/cabal/Cabal/Distribution/Compat/CopyFile.hs
deleted file mode 100644
index 3d96d72..0000000
--- a/cabal/Cabal/Distribution/Compat/CopyFile.hs
+++ /dev/null
@@ -1,115 +0,0 @@
-{-# OPTIONS -cpp #-}
--- OPTIONS required for ghc-6.4.x compat, and must appear first
-{-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -cpp #-}
-{-# OPTIONS_NHC98 -cpp #-}
-{-# OPTIONS_JHC -fcpp #-}
--- #hide
-module Distribution.Compat.CopyFile (
- copyFile,
- copyOrdinaryFile,
- copyExecutableFile,
- setFileOrdinary,
- setFileExecutable,
- setDirOrdinary,
- ) where
-
-#ifdef __GLASGOW_HASKELL__
-
-import Control.Monad
- ( when )
-import Control.Exception
- ( bracket, bracketOnError )
-import Distribution.Compat.Exception
- ( catchIO )
-#if __GLASGOW_HASKELL__ >= 608
-import Distribution.Compat.Exception
- ( throwIOIO )
-import System.IO.Error
- ( ioeSetLocation )
-#endif
-import System.Directory
- ( renameFile, removeFile )
-import Distribution.Compat.TempFile
- ( openBinaryTempFile )
-import System.FilePath
- ( takeDirectory )
-import System.IO
- ( openBinaryFile, IOMode(ReadMode), hClose, hGetBuf, hPutBuf )
-import Foreign
- ( allocaBytes )
-#endif /* __GLASGOW_HASKELL__ */
-
-#ifndef mingw32_HOST_OS
-#if __GLASGOW_HASKELL__ >= 611
-import System.Posix.Internals (withFilePath)
-#else
-import Foreign.C (withCString)
-#endif
-import System.Posix.Types
- ( FileMode )
-import System.Posix.Internals
- ( c_chmod )
-#if __GLASGOW_HASKELL__ >= 608
-import Foreign.C
- ( throwErrnoPathIfMinus1_ )
-#else
-import Foreign.C
- ( throwErrnoIfMinus1_ )
-#endif
-#endif /* mingw32_HOST_OS */
-
-copyOrdinaryFile, copyExecutableFile :: FilePath -> FilePath -> IO ()
-copyOrdinaryFile src dest = copyFile src dest >> setFileOrdinary dest
-copyExecutableFile src dest = copyFile src dest >> setFileExecutable dest
-
-setFileOrdinary, setFileExecutable, setDirOrdinary :: FilePath -> IO ()
-#ifndef mingw32_HOST_OS
-setFileOrdinary path = setFileMode path 0o644 -- file perms -rw-r--r--
-setFileExecutable path = setFileMode path 0o755 -- file perms -rwxr-xr-x
-
-setFileMode :: FilePath -> FileMode -> IO ()
-setFileMode name m =
-#if __GLASGOW_HASKELL__ >= 611
- withFilePath name $ \s -> do
-#else
- withCString name $ \s -> do
-#endif
-#if __GLASGOW_HASKELL__ >= 608
- throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m)
-#else
- throwErrnoIfMinus1_ name (c_chmod s m)
-#endif
-#else
-setFileOrdinary _ = return ()
-setFileExecutable _ = return ()
-#endif
--- This happens to be true on Unix and currently on Windows too:
-setDirOrdinary = setFileExecutable
-
-copyFile :: FilePath -> FilePath -> IO ()
-#ifdef __GLASGOW_HASKELL__
-copyFile fromFPath toFPath =
- copy
-#if __GLASGOW_HASKELL__ >= 608
- `catchIO` (\ioe -> throwIOIO (ioeSetLocation ioe "copyFile"))
-#endif
- where copy = bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom ->
- bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) ->
- do allocaBytes bufferSize $ copyContents hFrom hTmp
- hClose hTmp
- renameFile tmpFPath toFPath
- openTmp = openBinaryTempFile (takeDirectory toFPath) ".copyFile.tmp"
- cleanTmp (tmpFPath, hTmp) = do
- hClose hTmp `catchIO` \_ -> return ()
- removeFile tmpFPath `catchIO` \_ -> return ()
- bufferSize = 4096
-
- copyContents hFrom hTo buffer = do
- count <- hGetBuf hFrom buffer bufferSize
- when (count > 0) $ do
- hPutBuf hTo buffer count
- copyContents hFrom hTo buffer
-#else
-copyFile fromFPath toFPath = readFile fromFPath >>= writeFile toFPath
-#endif
diff --git a/cabal/Cabal/Distribution/Compat/Exception.hs b/cabal/Cabal/Distribution/Compat/Exception.hs
deleted file mode 100644
index ae8d9d5..0000000
--- a/cabal/Cabal/Distribution/Compat/Exception.hs
+++ /dev/null
@@ -1,61 +0,0 @@
-{-# OPTIONS -cpp #-}
--- OPTIONS required for ghc-6.4.x compat, and must appear first
-{-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -cpp #-}
-{-# OPTIONS_NHC98 -cpp #-}
-{-# OPTIONS_JHC -fcpp #-}
-
-#if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 610))
-#define NEW_EXCEPTION
-#endif
-
-module Distribution.Compat.Exception (
- Exception.IOException,
- onException,
- catchIO,
- catchExit,
- throwIOIO,
- tryIO,
- ) where
-
-import System.Exit
-import qualified Control.Exception as Exception
-
-onException :: IO a -> IO b -> IO a
-#ifdef NEW_EXCEPTION
-onException = Exception.onException
-#else
-onException io what = io `Exception.catch` \e -> do what
- Exception.throw e
-#endif
-
-throwIOIO :: Exception.IOException -> IO a
-#ifdef NEW_EXCEPTION
-throwIOIO = Exception.throwIO
-#else
-throwIOIO = Exception.throwIO . Exception.IOException
-#endif
-
-tryIO :: IO a -> IO (Either Exception.IOException a)
-#ifdef NEW_EXCEPTION
-tryIO = Exception.try
-#else
-tryIO = Exception.tryJust Exception.ioErrors
-#endif
-
-catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
-#ifdef NEW_EXCEPTION
-catchIO = Exception.catch
-#else
-catchIO = Exception.catchJust Exception.ioErrors
-#endif
-
-catchExit :: IO a -> (ExitCode -> IO a) -> IO a
-#ifdef NEW_EXCEPTION
-catchExit = Exception.catch
-#else
-catchExit = Exception.catchJust exitExceptions
- where exitExceptions (Exception.ExitException ee) = Just ee
- exitExceptions _ = Nothing
-#endif
-
diff --git a/cabal/Cabal/Distribution/Compat/ReadP.hs b/cabal/Cabal/Distribution/Compat/ReadP.hs
deleted file mode 100644
index e087ed2..0000000
--- a/cabal/Cabal/Distribution/Compat/ReadP.hs
+++ /dev/null
@@ -1,381 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Distribution.Compat.ReadP
--- Copyright : (c) The University of Glasgow 2002
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Portability : portable
---
--- This is a library of parser combinators, originally written by Koen Claessen.
--- It parses all alternatives in parallel, so it never keeps hold of
--- the beginning of the input string, a common source of space leaks with
--- other parsers. The '(+++)' choice combinator is genuinely commutative;
--- it makes no difference which branch is \"shorter\".
---
--- See also Koen's paper /Parallel Parsing Processes/
--- (<http://www.cs.chalmers.se/~koen/publications.html>).
---
--- This version of ReadP has been locally hacked to make it H98, by
--- Martin Sj&#xF6;gren <mailto:msjogren@gmail.com>
---
--- The unit tests have been moved to UnitTest.Distribution.Compat.ReadP, by
--- Mark Lentczner <mailto:mark@glyphic.com>
------------------------------------------------------------------------------
-
-module Distribution.Compat.ReadP
- (
- -- * The 'ReadP' type
- ReadP, -- :: * -> *; instance Functor, Monad, MonadPlus
-
- -- * Primitive operations
- get, -- :: ReadP Char
- look, -- :: ReadP String
- (+++), -- :: ReadP a -> ReadP a -> ReadP a
- (<++), -- :: ReadP a -> ReadP a -> ReadP a
- gather, -- :: ReadP a -> ReadP (String, a)
-
- -- * Other operations
- pfail, -- :: ReadP a
- satisfy, -- :: (Char -> Bool) -> ReadP Char
- char, -- :: Char -> ReadP Char
- string, -- :: String -> ReadP String
- munch, -- :: (Char -> Bool) -> ReadP String
- munch1, -- :: (Char -> Bool) -> ReadP String
- skipSpaces, -- :: ReadP ()
- choice, -- :: [ReadP a] -> ReadP a
- count, -- :: Int -> ReadP a -> ReadP [a]
- between, -- :: ReadP open -> ReadP close -> ReadP a -> ReadP a
- option, -- :: a -> ReadP a -> ReadP a
- optional, -- :: ReadP a -> ReadP ()
- many, -- :: ReadP a -> ReadP [a]
- many1, -- :: ReadP a -> ReadP [a]
- skipMany, -- :: ReadP a -> ReadP ()
- skipMany1, -- :: ReadP a -> ReadP ()
- sepBy, -- :: ReadP a -> ReadP sep -> ReadP [a]
- sepBy1, -- :: ReadP a -> ReadP sep -> ReadP [a]
- endBy, -- :: ReadP a -> ReadP sep -> ReadP [a]
- endBy1, -- :: ReadP a -> ReadP sep -> ReadP [a]
- chainr, -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a
- chainl, -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a
- chainl1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a
- chainr1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a
- manyTill, -- :: ReadP a -> ReadP end -> ReadP [a]
-
- -- * Running a parser
- ReadS, -- :: *; = String -> [(a,String)]
- readP_to_S, -- :: ReadP a -> ReadS a
- readS_to_P -- :: ReadS a -> ReadP a
- )
- where
-
-import Control.Monad( MonadPlus(..), liftM2 )
-import Data.Char (isSpace)
-
-infixr 5 +++, <++
-
--- ---------------------------------------------------------------------------
--- The P type
--- is representation type -- should be kept abstract
-
-data P s a
- = Get (s -> P s a)
- | Look ([s] -> P s a)
- | Fail
- | Result a (P s a)
- | Final [(a,[s])] -- invariant: list is non-empty!
-
--- Monad, MonadPlus
-
-instance Monad (P s) where
- return x = Result x Fail
-
- (Get f) >>= k = Get (\c -> f c >>= k)
- (Look f) >>= k = Look (\s -> f s >>= k)
- Fail >>= _ = Fail
- (Result x p) >>= k = k x `mplus` (p >>= k)
- (Final r) >>= k = final [ys' | (x,s) <- r, ys' <- run (k x) s]
-
- fail _ = Fail
-
-instance MonadPlus (P s) where
- mzero = Fail
-
- -- most common case: two gets are combined
- Get f1 `mplus` Get f2 = Get (\c -> f1 c `mplus` f2 c)
-
- -- results are delivered as soon as possible
- Result x p `mplus` q = Result x (p `mplus` q)
- p `mplus` Result x q = Result x (p `mplus` q)
-
- -- fail disappears
- Fail `mplus` p = p
- p `mplus` Fail = p
-
- -- two finals are combined
- -- final + look becomes one look and one final (=optimization)
- -- final + sthg else becomes one look and one final
- Final r `mplus` Final t = Final (r ++ t)
- Final r `mplus` Look f = Look (\s -> Final (r ++ run (f s) s))
- Final r `mplus` p = Look (\s -> Final (r ++ run p s))
- Look f `mplus` Final r = Look (\s -> Final (run (f s) s ++ r))
- p `mplus` Final r = Look (\s -> Final (run p s ++ r))
-
- -- two looks are combined (=optimization)
- -- look + sthg else floats upwards
- Look f `mplus` Look g = Look (\s -> f s `mplus` g s)
- Look f `mplus` p = Look (\s -> f s `mplus` p)
- p `mplus` Look f = Look (\s -> p `mplus` f s)
-
--- ---------------------------------------------------------------------------
--- The ReadP type
-
-newtype Parser r s a = R ((a -> P s r) -> P s r)
-type ReadP r a = Parser r Char a
-
--- Functor, Monad, MonadPlus
-
-instance Functor (Parser r s) where
- fmap h (R f) = R (\k -> f (k . h))
-
-instance Monad (Parser r s) where
- return x = R (\k -> k x)
- fail _ = R (\_ -> Fail)
- R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k))
-
---instance MonadPlus (Parser r s) where
--- mzero = pfail
--- mplus = (+++)
-
--- ---------------------------------------------------------------------------
--- Operations over P
-
-final :: [(a,[s])] -> P s a
--- Maintains invariant for Final constructor
-final [] = Fail
-final r = Final r
-
-run :: P c a -> ([c] -> [(a, [c])])
-run (Get f) (c:s) = run (f c) s
-run (Look f) s = run (f s) s
-run (Result x p) s = (x,s) : run p s
-run (Final r) _ = r
-run _ _ = []
-
--- ---------------------------------------------------------------------------
--- Operations over ReadP
-
-get :: ReadP r Char
--- ^ Consumes and returns the next character.
--- Fails if there is no input left.
-get = R Get
-
-look :: ReadP r String
--- ^ Look-ahead: returns the part of the input that is left, without
--- consuming it.
-look = R Look
-
-pfail :: ReadP r a
--- ^ Always fails.
-pfail = R (\_ -> Fail)
-
-(+++) :: ReadP r a -> ReadP r a -> ReadP r a
--- ^ Symmetric choice.
-R f1 +++ R f2 = R (\k -> f1 k `mplus` f2 k)
-
-(<++) :: ReadP a a -> ReadP r a -> ReadP r a
--- ^ Local, exclusive, left-biased choice: If left parser
--- locally produces any result at all, then right parser is
--- not used.
-R f <++ q =
- do s <- look
- probe (f return) s 0
- where
- probe (Get f') (c:s) n = probe (f' c) s (n+1 :: Int)
- probe (Look f') s n = probe (f' s) s n
- probe p@(Result _ _) _ n = discard n >> R (p >>=)
- probe (Final r) _ _ = R (Final r >>=)
- probe _ _ _ = q
-
- discard 0 = return ()
- discard n = get >> discard (n-1 :: Int)
-
-gather :: ReadP (String -> P Char r) a -> ReadP r (String, a)
--- ^ Transforms a parser into one that does the same, but
--- in addition returns the exact characters read.
--- IMPORTANT NOTE: 'gather' gives a runtime error if its first argument
--- is built using any occurrences of readS_to_P.
-gather (R m) =
- R (\k -> gath id (m (\a -> return (\s -> k (s,a)))))
- where
- gath l (Get f) = Get (\c -> gath (l.(c:)) (f c))
- gath _ Fail = Fail
- gath l (Look f) = Look (\s -> gath l (f s))
- gath l (Result k p) = k (l []) `mplus` gath l p
- gath _ (Final _) = error "do not use readS_to_P in gather!"
-
--- ---------------------------------------------------------------------------
--- Derived operations
-
-satisfy :: (Char -> Bool) -> ReadP r Char
--- ^ Consumes and returns the next character, if it satisfies the
--- specified predicate.
-satisfy p = do c <- get; if p c then return c else pfail
-
-char :: Char -> ReadP r Char
--- ^ Parses and returns the specified character.
-char c = satisfy (c ==)
-
-string :: String -> ReadP r String
--- ^ Parses and returns the specified string.
-string this = do s <- look; scan this s
- where
- scan [] _ = do return this
- scan (x:xs) (y:ys) | x == y = do get >> scan xs ys
- scan _ _ = do pfail
-
-munch :: (Char -> Bool) -> ReadP r String
--- ^ Parses the first zero or more characters satisfying the predicate.
-munch p =
- do s <- look
- scan s
- where
- scan (c:cs) | p c = do _ <- get; s <- scan cs; return (c:s)
- scan _ = do return ""
-
-munch1 :: (Char -> Bool) -> ReadP r String
--- ^ Parses the first one or more characters satisfying the predicate.
-munch1 p =
- do c <- get
- if p c then do s <- munch p; return (c:s)
- else pfail
-
-choice :: [ReadP r a] -> ReadP r a
--- ^ Combines all parsers in the specified list.
-choice [] = pfail
-choice [p] = p
-choice (p:ps) = p +++ choice ps
-
-skipSpaces :: ReadP r ()
--- ^ Skips all whitespace.
-skipSpaces =
- do s <- look
- skip s
- where
- skip (c:s) | isSpace c = do _ <- get; skip s
- skip _ = do return ()
-
-count :: Int -> ReadP r a -> ReadP r [a]
--- ^ @ count n p @ parses @n@ occurrences of @p@ in sequence. A list of
--- results is returned.
-count n p = sequence (replicate n p)
-
-between :: ReadP r open -> ReadP r close -> ReadP r a -> ReadP r a
--- ^ @ between open close p @ parses @open@, followed by @p@ and finally
--- @close@. Only the value of @p@ is returned.
-between open close p = do _ <- open
- x <- p
- _ <- close
- return x
-
-option :: a -> ReadP r a -> ReadP r a
--- ^ @option x p@ will either parse @p@ or return @x@ without consuming
--- any input.
-option x p = p +++ return x
-
-optional :: ReadP r a -> ReadP r ()
--- ^ @optional p@ optionally parses @p@ and always returns @()@.
-optional p = (p >> return ()) +++ return ()
-
-many :: ReadP r a -> ReadP r [a]
--- ^ Parses zero or more occurrences of the given parser.
-many p = return [] +++ many1 p
-
-many1 :: ReadP r a -> ReadP r [a]
--- ^ Parses one or more occurrences of the given parser.
-many1 p = liftM2 (:) p (many p)
-
-skipMany :: ReadP r a -> ReadP r ()
--- ^ Like 'many', but discards the result.
-skipMany p = many p >> return ()
-
-skipMany1 :: ReadP r a -> ReadP r ()
--- ^ Like 'many1', but discards the result.
-skipMany1 p = p >> skipMany p
-
-sepBy :: ReadP r a -> ReadP r sep -> ReadP r [a]
--- ^ @sepBy p sep@ parses zero or more occurrences of @p@, separated by @sep@.
--- Returns a list of values returned by @p@.
-sepBy p sep = sepBy1 p sep +++ return []
-
-sepBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a]
--- ^ @sepBy1 p sep@ parses one or more occurrences of @p@, separated by @sep@.
--- Returns a list of values returned by @p@.
-sepBy1 p sep = liftM2 (:) p (many (sep >> p))
-
-endBy :: ReadP r a -> ReadP r sep -> ReadP r [a]
--- ^ @endBy p sep@ parses zero or more occurrences of @p@, separated and ended
--- by @sep@.
-endBy p sep = many (do x <- p ; _ <- sep ; return x)
-
-endBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a]
--- ^ @endBy p sep@ parses one or more occurrences of @p@, separated and ended
--- by @sep@.
-endBy1 p sep = many1 (do x <- p ; _ <- sep ; return x)
-
-chainr :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a
--- ^ @chainr p op x@ parses zero or more occurrences of @p@, separated by @op@.
--- Returns a value produced by a /right/ associative application of all
--- functions returned by @op@. If there are no occurrences of @p@, @x@ is
--- returned.
-chainr p op x = chainr1 p op +++ return x
-
-chainl :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a
--- ^ @chainl p op x@ parses zero or more occurrences of @p@, separated by @op@.
--- Returns a value produced by a /left/ associative application of all
--- functions returned by @op@. If there are no occurrences of @p@, @x@ is
--- returned.
-chainl p op x = chainl1 p op +++ return x
-
-chainr1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a
--- ^ Like 'chainr', but parses one or more occurrences of @p@.
-chainr1 p op = scan
- where scan = p >>= rest
- rest x = do f <- op
- y <- scan
- return (f x y)
- +++ return x
-
-chainl1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a
--- ^ Like 'chainl', but parses one or more occurrences of @p@.
-chainl1 p op = p >>= rest
- where rest x = do f <- op
- y <- p
- rest (f x y)
- +++ return x
-
-manyTill :: ReadP r a -> ReadP [a] end -> ReadP r [a]
--- ^ @manyTill p end@ parses zero or more occurrences of @p@, until @end@
--- succeeds. Returns a list of values returned by @p@.
-manyTill p end = scan
- where scan = (end >> return []) <++ (liftM2 (:) p scan)
-
--- ---------------------------------------------------------------------------
--- Converting between ReadP and Read
-
-readP_to_S :: ReadP a a -> ReadS a
--- ^ Converts a parser into a Haskell ReadS-style function.
--- This is the main way in which you can \"run\" a 'ReadP' parser:
--- the expanded type is
--- @ readP_to_S :: ReadP a -> String -> [(a,String)] @
-readP_to_S (R f) = run (f return)
-
-readS_to_P :: ReadS a -> ReadP r a
--- ^ Converts a Haskell ReadS-style function into a parser.
--- Warning: This introduces local backtracking in the resulting
--- parser, and therefore a possible inefficiency.
-readS_to_P r =
- R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s']))
-
-
-
diff --git a/cabal/Cabal/Distribution/Compat/TempFile.hs b/cabal/Cabal/Distribution/Compat/TempFile.hs
deleted file mode 100644
index 9feddeb..0000000
--- a/cabal/Cabal/Distribution/Compat/TempFile.hs
+++ /dev/null
@@ -1,204 +0,0 @@
-{-# OPTIONS -cpp #-}
--- OPTIONS required for ghc-6.4.x compat, and must appear first
-{-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -cpp #-}
-{-# OPTIONS_NHC98 -cpp #-}
-{-# OPTIONS_JHC -fcpp #-}
--- #hide
-module Distribution.Compat.TempFile (
- openTempFile,
- openBinaryTempFile,
- openNewBinaryFile,
- createTempDirectory,
- ) where
-
-
-import System.FilePath ((</>))
-import Foreign.C (eEXIST)
-
-#if __NHC__ || __HUGS__
-import System.IO (openFile, openBinaryFile,
- Handle, IOMode(ReadWriteMode))
-import System.Directory (doesFileExist)
-import System.FilePath ((<.>), splitExtension)
-import System.IO.Error (try, isAlreadyExistsError)
-#else
-import System.IO (Handle, openTempFile, openBinaryTempFile)
-import Data.Bits ((.|.))
-import System.Posix.Internals (c_open, c_close, o_CREAT, o_EXCL, o_RDWR,
- o_BINARY, o_NONBLOCK, o_NOCTTY)
-import System.IO.Error (isAlreadyExistsError)
-#if __GLASGOW_HASKELL__ >= 611
-import System.Posix.Internals (withFilePath)
-#else
-import Foreign.C (withCString)
-#endif
-import Foreign.C (CInt)
-#if __GLASGOW_HASKELL__ >= 611
-import GHC.IO.Handle.FD (fdToHandle)
-#else
-import GHC.Handle (fdToHandle)
-#endif
-import Distribution.Compat.Exception (onException, tryIO)
-#endif
-import Foreign.C (getErrno, errnoToIOError)
-
-#if __NHC__
-import System.Posix.Types (CPid(..))
-foreign import ccall unsafe "getpid" c_getpid :: IO CPid
-#else
-import System.Posix.Internals (c_getpid)
-#endif
-
-#ifdef mingw32_HOST_OS
-import System.Directory ( createDirectory )
-#else
-import qualified System.Posix
-#endif
-
--- ------------------------------------------------------------
--- * temporary files
--- ------------------------------------------------------------
-
--- This is here for Haskell implementations that do not come with
--- System.IO.openTempFile. This includes nhc-1.20, hugs-2006.9.
--- TODO: Not sure about jhc
-
-#if __NHC__ || __HUGS__
--- use a temporary filename that doesn't already exist.
--- NB. *not* secure (we don't atomically lock the tmp file we get)
-openTempFile :: FilePath -> String -> IO (FilePath, Handle)
-openTempFile tmp_dir template
- = do x <- getProcessID
- findTempName x
- where
- (templateBase, templateExt) = splitExtension template
- findTempName :: Int -> IO (FilePath, Handle)
- findTempName x
- = do let path = tmp_dir </> (templateBase ++ "-" ++ show x) <.> templateExt
- b <- doesFileExist path
- if b then findTempName (x+1)
- else do hnd <- openFile path ReadWriteMode
- return (path, hnd)
-
-openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle)
-openBinaryTempFile tmp_dir template
- = do x <- getProcessID
- findTempName x
- where
- (templateBase, templateExt) = splitExtension template
- findTempName :: Int -> IO (FilePath, Handle)
- findTempName x
- = do let path = tmp_dir </> (templateBase ++ "-" ++ show x) <.> templateExt
- b <- doesFileExist path
- if b then findTempName (x+1)
- else do hnd <- openBinaryFile path ReadWriteMode
- return (path, hnd)
-
-openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle)
-openNewBinaryFile = openBinaryTempFile
-
-getProcessID :: IO Int
-getProcessID = fmap fromIntegral c_getpid
-#else
--- This is a copy/paste of the openBinaryTempFile definition, but
--- if uses 666 rather than 600 for the permissions. The base library
--- needs to be changed to make this better.
-openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle)
-openNewBinaryFile dir template = do
- pid <- c_getpid
- findTempName pid
- where
- -- We split off the last extension, so we can use .foo.ext files
- -- for temporary files (hidden on Unix OSes). Unfortunately we're
- -- below filepath in the hierarchy here.
- (prefix,suffix) =
- case break (== '.') $ reverse template of
- -- First case: template contains no '.'s. Just re-reverse it.
- (rev_suffix, "") -> (reverse rev_suffix, "")
- -- Second case: template contains at least one '.'. Strip the
- -- dot from the prefix and prepend it to the suffix (if we don't
- -- do this, the unique number will get added after the '.' and
- -- thus be part of the extension, which is wrong.)
- (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix)
- -- Otherwise, something is wrong, because (break (== '.')) should
- -- always return a pair with either the empty string or a string
- -- beginning with '.' as the second component.
- _ -> error "bug in System.IO.openTempFile"
-
- oflags = rw_flags .|. o_EXCL .|. o_BINARY
-
-#if __GLASGOW_HASKELL__ < 611
- withFilePath = withCString
-#endif
-
- findTempName x = do
- fd <- withFilePath filepath $ \ f ->
- c_open f oflags 0o666
- if fd < 0
- then do
- errno <- getErrno
- if errno == eEXIST
- then findTempName (x+1)
- else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir))
- else do
- -- TODO: We want to tell fdToHandle what the filepath is,
- -- as any exceptions etc will only be able to report the
- -- fd currently
- h <-
-#if __GLASGOW_HASKELL__ >= 609
- fdToHandle fd
-#elif __GLASGOW_HASKELL__ <= 606 && defined(mingw32_HOST_OS)
- -- fdToHandle is borked on Windows with ghc-6.6.x
- openFd (fromIntegral fd) Nothing False filepath
- ReadWriteMode True
-#else
- fdToHandle (fromIntegral fd)
-#endif
- `onException` c_close fd
- return (filepath, h)
- where
- filename = prefix ++ show x ++ suffix
- filepath = dir `combine` filename
-
- -- FIXME: bits copied from System.FilePath
- combine a b
- | null b = a
- | null a = b
- | last a == pathSeparator = a ++ b
- | otherwise = a ++ [pathSeparator] ++ b
-
--- FIXME: Should use filepath library
-pathSeparator :: Char
-#ifdef mingw32_HOST_OS
-pathSeparator = '\\'
-#else
-pathSeparator = '/'
-#endif
-
--- FIXME: Copied from GHC.Handle
-std_flags, output_flags, rw_flags :: CInt
-std_flags = o_NONBLOCK .|. o_NOCTTY
-output_flags = std_flags .|. o_CREAT
-rw_flags = output_flags .|. o_RDWR
-#endif
-
-createTempDirectory :: FilePath -> String -> IO FilePath
-createTempDirectory dir template = do
- pid <- c_getpid
- findTempName pid
- where
- findTempName x = do
- let dirpath = dir </> template ++ "-" ++ show x
- r <- tryIO $ mkPrivateDir dirpath
- case r of
- Right _ -> return dirpath
- Left e | isAlreadyExistsError e -> findTempName (x+1)
- | otherwise -> ioError e
-
-mkPrivateDir :: String -> IO ()
-#ifdef mingw32_HOST_OS
-mkPrivateDir s = createDirectory s
-#else
-mkPrivateDir s = System.Posix.createDirectory s 0o700
-#endif
diff --git a/cabal/Cabal/Distribution/Compiler.hs b/cabal/Cabal/Distribution/Compiler.hs
deleted file mode 100644
index 82abd46..0000000
--- a/cabal/Cabal/Distribution/Compiler.hs
+++ /dev/null
@@ -1,158 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Distribution.Compiler
--- Copyright : Isaac Jones 2003-2004
---
--- Maintainer : cabal-devel@haskell.org
--- Portability : portable
---
--- This has an enumeration of the various compilers that Cabal knows about. It
--- also specifies the default compiler. Sadly you'll often see code that does
--- case analysis on this compiler flavour enumeration like:
---
--- > case compilerFlavor comp of
--- > GHC -> GHC.getInstalledPackages verbosity packageDb progconf
--- > JHC -> JHC.getInstalledPackages verbosity packageDb progconf
---
--- Obviously it would be better to use the proper 'Compiler' abstraction
--- because that would keep all the compiler-specific code together.
--- Unfortunately we cannot make this change yet without breaking the
--- 'UserHooks' api, which would break all custom @Setup.hs@ files, so for the
--- moment we just have to live with this deficiency. If you're interested, see
--- ticket #50.
-
-{- All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
- * Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
- * Redistributions in binary form must reproduce the above
- copyright notice, this list of conditions and the following
- disclaimer in the documentation and/or other materials provided
- with the distribution.
-
- * Neither the name of Isaac Jones nor the names of other
- contributors may be used to endorse or promote products derived
- from this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
-
-module Distribution.Compiler (
- -- * Compiler flavor
- CompilerFlavor(..),
- buildCompilerFlavor,
- defaultCompilerFlavor,
- parseCompilerFlavorCompat,
-
- -- * Compiler id
- CompilerId(..),
- ) where
-
-import Distribution.Version (Version(..))
-
-import qualified System.Info (compilerName)
-import Distribution.Text (Text(..), display)
-import qualified Distribution.Compat.ReadP as Parse
-import qualified Text.PrettyPrint as Disp
-import Text.PrettyPrint ((<>))
-
-import qualified Data.Char as Char (toLower, isDigit, isAlphaNum)
-import Control.Monad (when)
-
-data CompilerFlavor = GHC | NHC | YHC | Hugs | HBC | Helium | JHC | LHC | UHC
- | OtherCompiler String
- deriving (Show, Read, Eq, Ord)
-
-knownCompilerFlavors :: [CompilerFlavor]
-knownCompilerFlavors = [GHC, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC]
-
-instance Text CompilerFlavor where
- disp (OtherCompiler name) = Disp.text name
- disp NHC = Disp.text "nhc98"
- disp other = Disp.text (lowercase (show other))
-
- parse = do
- comp <- Parse.munch1 Char.isAlphaNum
- when (all Char.isDigit comp) Parse.pfail
- return (classifyCompilerFlavor comp)
-
-classifyCompilerFlavor :: String -> CompilerFlavor
-classifyCompilerFlavor s =
- case lookup (lowercase s) compilerMap of
- Just compiler -> compiler
- Nothing -> OtherCompiler s
- where
- compilerMap = [ (display compiler, compiler)
- | compiler <- knownCompilerFlavors ]
-
-
---TODO: In some future release, remove 'parseCompilerFlavorCompat' and use
--- ordinary 'parse'. Also add ("nhc", NHC) to the above 'compilerMap'.
-
--- | Like 'classifyCompilerFlavor' but compatible with the old ReadS parser.
---
--- It is compatible in the sense that it accepts only the same strings,
--- eg "GHC" but not "ghc". However other strings get mapped to 'OtherCompiler'.
--- The point of this is that we do not allow extra valid values that would
--- upset older Cabal versions that had a stricter parser however we cope with
--- new values more gracefully so that we'll be able to introduce new value in
--- future without breaking things so much.
---
-parseCompilerFlavorCompat :: Parse.ReadP r CompilerFlavor
-parseCompilerFlavorCompat = do
- comp <- Parse.munch1 Char.isAlphaNum
- when (all Char.isDigit comp) Parse.pfail
- case lookup comp compilerMap of
- Just compiler -> return compiler
- Nothing -> return (OtherCompiler comp)
- where
- compilerMap = [ (show compiler, compiler)
- | compiler <- knownCompilerFlavors
- , compiler /= YHC ]
-
-buildCompilerFlavor :: CompilerFlavor
-buildCompilerFlavor = classifyCompilerFlavor System.Info.compilerName
-
--- | The default compiler flavour to pick when compiling stuff. This defaults
--- to the compiler used to build the Cabal lib.
---
--- However if it's not a recognised compiler then it's 'Nothing' and the user
--- will have to specify which compiler they want.
---
-defaultCompilerFlavor :: Maybe CompilerFlavor
-defaultCompilerFlavor = case buildCompilerFlavor of
- OtherCompiler _ -> Nothing
- _ -> Just buildCompilerFlavor
-
--- ------------------------------------------------------------
--- * Compiler Id
--- ------------------------------------------------------------
-
-data CompilerId = CompilerId CompilerFlavor Version
- deriving (Eq, Ord, Read, Show)
-
-instance Text CompilerId where
- disp (CompilerId f (Version [] _)) = disp f
- disp (CompilerId f v) = disp f <> Disp.char '-' <> disp v
-
- parse = do
- flavour <- parse
- version <- (Parse.char '-' >> parse) Parse.<++ return (Version [] [])
- return (CompilerId flavour version)
-
-lowercase :: String -> String
-lowercase = map Char.toLower
diff --git a/cabal/Cabal/Distribution/GetOpt.hs b/cabal/Cabal/Distribution/GetOpt.hs
deleted file mode 100644
index 14725d3..0000000
--- a/cabal/Cabal/Distribution/GetOpt.hs
+++ /dev/null
@@ -1,335 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Distribution.GetOpt
--- Copyright : (c) Sven Panne 2002-2005
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Portability : portable
---
--- This library provides facilities for parsing the command-line options
--- in a standalone program. It is essentially a Haskell port of the GNU
--- @getopt@ library.
---
------------------------------------------------------------------------------
-
-{-
-Sven Panne <Sven.Panne@informatik.uni-muenchen.de> Oct. 1996 (small
-changes Dec. 1997)
-
-Two rather obscure features are missing: The Bash 2.0 non-option hack
-(if you don't already know it, you probably don't want to hear about
-it...) and the recognition of long options with a single dash
-(e.g. '-help' is recognised as '--help', as long as there is no short
-option 'h').
-
-Other differences between GNU's getopt and this implementation:
-
-* To enforce a coherent description of options and arguments, there
- are explanation fields in the option/argument descriptor.
-
-* Error messages are now more informative, but no longer POSIX
- compliant... :-(
-
-And a final Haskell advertisement: The GNU C implementation uses well
-over 1100 lines, we need only 195 here, including a 46 line example!
-:-)
--}
-
--- #hide
-module Distribution.GetOpt (
- -- * GetOpt
- getOpt, getOpt',
- usageInfo,
- ArgOrder(..),
- OptDescr(..),
- ArgDescr(..),
-
- -- * Example
-
- -- $example
-) where
-
-import Data.List ( isPrefixOf, intersperse, find )
-
--- |What to do with options following non-options
-data ArgOrder a
- = RequireOrder -- ^ no option processing after first non-option
- | Permute -- ^ freely intersperse options and non-options
- | ReturnInOrder (String -> a) -- ^ wrap non-options into options
-
-{-|
-Each 'OptDescr' describes a single option.
-
-The arguments to 'Option' are:
-
-* list of short option characters
-
-* list of long option strings (without \"--\")
-
-* argument descriptor
-
-* explanation of option for user
--}
-data OptDescr a = -- description of a single options:
- Option [Char] -- list of short option characters
- [String] -- list of long option strings (without "--")
- (ArgDescr a) -- argument descriptor
- String -- explanation of option for user
-
--- |Describes whether an option takes an argument or not, and if so
--- how the argument is injected into a value of type @a@.
-data ArgDescr a
- = NoArg a -- ^ no argument expected
- | ReqArg (String -> a) String -- ^ option requires argument
- | OptArg (Maybe String -> a) String -- ^ optional argument
-
-data OptKind a -- kind of cmd line arg (internal use only):
- = Opt a -- an option
- | UnreqOpt String -- an un-recognized option
- | NonOpt String -- a non-option
- | EndOfOpts -- end-of-options marker (i.e. "--")
- | OptErr String -- something went wrong...
-
--- | Return a string describing the usage of a command, derived from
--- the header (first argument) and the options described by the
--- second argument.
-usageInfo :: String -- header
- -> [OptDescr a] -- option descriptors
- -> String -- nicely formatted decription of options
-usageInfo header optDescr = unlines (header:table)
- where (ss,ls,ds) = unzip3 [ (sepBy ", " (map (fmtShort ad) sos)
- ,concatMap (fmtLong ad) (take 1 los)
- ,d)
- | Option sos los ad d <- optDescr ]
- ssWidth = (maximum . map length) ss
- lsWidth = (maximum . map length) ls
- dsWidth = 30 `max` (80 - (ssWidth + lsWidth + 3))
- table = [ " " ++ padTo ssWidth so' ++
- " " ++ padTo lsWidth lo' ++
- " " ++ d'
- | (so,lo,d) <- zip3 ss ls ds
- , (so',lo',d') <- fmtOpt dsWidth so lo d ]
- padTo n x = take n (x ++ repeat ' ')
- sepBy s = concat . intersperse s
-
-fmtOpt :: Int -> String -> String -> String -> [(String, String, String)]
-fmtOpt descrWidth so lo descr =
- case wrapText descrWidth descr of
- [] -> [(so,lo,"")]
- (d:ds) -> (so,lo,d) : [ ("","",d') | d' <- ds ]
-
-fmtShort :: ArgDescr a -> Char -> String
-fmtShort (NoArg _ ) so = "-" ++ [so]
-fmtShort (ReqArg _ _) so = "-" ++ [so]
-fmtShort (OptArg _ _) so = "-" ++ [so]
-
-fmtLong :: ArgDescr a -> String -> String
-fmtLong (NoArg _ ) lo = "--" ++ lo
-fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad
-fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]"
-
-wrapText :: Int -> String -> [String]
-wrapText width = map unwords . wrap 0 [] . words
- where wrap :: Int -> [String] -> [String] -> [[String]]
- wrap 0 [] (w:ws)
- | length w + 1 > width
- = wrap (length w) [w] ws
- wrap col line (w:ws)
- | col + length w + 1 > width
- = reverse line : wrap 0 [] (w:ws)
- wrap col line (w:ws)
- = let col' = col + length w + 1
- in wrap col' (w:line) ws
- wrap _ [] [] = []
- wrap _ line [] = [reverse line]
-
-{-|
-Process the command-line, and return the list of values that matched
-(and those that didn\'t). The arguments are:
-
-* The order requirements (see 'ArgOrder')
-
-* The option descriptions (see 'OptDescr')
-
-* The actual command line arguments (presumably got from
- 'System.Environment.getArgs').
-
-'getOpt' returns a triple consisting of the option arguments, a list
-of non-options, and a list of error messages.
--}
-getOpt :: ArgOrder a -- non-option handling
- -> [OptDescr a] -- option descriptors
- -> [String] -- the command-line arguments
- -> ([a],[String],[String]) -- (options,non-options,error messages)
-getOpt ordering optDescr args = (os,xs,es ++ map errUnrec us)
- where (os,xs,us,es) = getOpt' ordering optDescr args
-
-{-|
-This is almost the same as 'getOpt', but returns a quadruple
-consisting of the option arguments, a list of non-options, a list of
-unrecognized options, and a list of error messages.
--}
-getOpt' :: ArgOrder a -- non-option handling
- -> [OptDescr a] -- option descriptors
- -> [String] -- the command-line arguments
- -> ([a],[String], [String] ,[String]) -- (options,non-options,unrecognized,error messages)
-getOpt' _ _ [] = ([],[],[],[])
-getOpt' ordering optDescr (arg:args) = procNextOpt opt ordering
- where procNextOpt (Opt o) _ = (o:os,xs,us,es)
- procNextOpt (UnreqOpt u) _ = (os,xs,u:us,es)
- procNextOpt (NonOpt x) RequireOrder = ([],x:rest,[],[])
- procNextOpt (NonOpt x) Permute = (os,x:xs,us,es)
- procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,us,es)
- procNextOpt EndOfOpts RequireOrder = ([],rest,[],[])
- procNextOpt EndOfOpts Permute = ([],rest,[],[])
- procNextOpt EndOfOpts (ReturnInOrder f) = (map f rest,[],[],[])
- procNextOpt (OptErr e) _ = (os,xs,us,e:es)
-
- (opt,rest) = getNext arg args optDescr
- (os,xs,us,es) = getOpt' ordering optDescr rest
-
--- take a look at the next cmd line arg and decide what to do with it
-getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])
-getNext ('-':'-':[]) rest _ = (EndOfOpts,rest)
-getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr
-getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr
-getNext a rest _ = (NonOpt a,rest)
-
--- handle long option
-longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])
-longOpt ls rs optDescr = long ads arg rs
- where (opt,arg) = break (=='=') ls
- getWith p = [ o | o@(Option _ xs _ _) <- optDescr
- , find (p opt) xs /= Nothing]
- exact = getWith (==)
- options = if null exact then getWith isPrefixOf else exact
- ads = [ ad | Option _ _ ad _ <- options ]
- optStr = ("--"++opt)
-
- long (_:_:_) _ rest = (errAmbig options optStr,rest)
- long [NoArg a ] [] rest = (Opt a,rest)
- long [NoArg _ ] ('=':_) rest = (errNoArg optStr,rest)
- long [ReqArg _ d] [] [] = (errReq d optStr,[])
- long [ReqArg f _] [] (r:rest) = (Opt (f r),rest)
- long [ReqArg f _] ('=':xs) rest = (Opt (f xs),rest)
- long [OptArg f _] [] rest = (Opt (f Nothing),rest)
- long [OptArg f _] ('=':xs) rest = (Opt (f (Just xs)),rest)
- long _ _ rest = (UnreqOpt ("--"++ls),rest)
-
--- handle short option
-shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String])
-shortOpt y ys rs optDescr = short ads ys rs
- where options = [ o | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s ]
- ads = [ ad | Option _ _ ad _ <- options ]
- optStr = '-':[y]
-
- short (_:_:_) _ rest = (errAmbig options optStr,rest)
- short (NoArg a :_) [] rest = (Opt a,rest)
- short (NoArg a :_) xs rest = (Opt a,('-':xs):rest)
- short (ReqArg _ d:_) [] [] = (errReq d optStr,[])
- short (ReqArg f _:_) [] (r:rest) = (Opt (f r),rest)
- short (ReqArg f _:_) xs rest = (Opt (f xs),rest)
- short (OptArg f _:_) [] rest = (Opt (f Nothing),rest)
- short (OptArg f _:_) xs rest = (Opt (f (Just xs)),rest)
- short [] [] rest = (UnreqOpt optStr,rest)
- short [] xs rest = (UnreqOpt (optStr++xs),rest)
-
--- miscellaneous error formatting
-
-errAmbig :: [OptDescr a] -> String -> OptKind a
-errAmbig ods optStr = OptErr (usageInfo header ods)
- where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:"
-
-errReq :: String -> String -> OptKind a
-errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n")
-
-errUnrec :: String -> String
-errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n"
-
-errNoArg :: String -> OptKind a
-errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n")
-
-{-
------------------------------------------------------------------------------------------
--- and here a small and hopefully enlightening example:
-
-data Flag = Verbose | Version | Name String | Output String | Arg String deriving Show
-
-options :: [OptDescr Flag]
-options =
- [Option ['v'] ["verbose"] (NoArg Verbose) "verbosely list files",
- Option ['V','?'] ["version","release"] (NoArg Version) "show version info",
- Option ['o'] ["output"] (OptArg out "FILE") "use FILE for dump",
- Option ['n'] ["name"] (ReqArg Name "USER") "only dump USER's files"]
-
-out :: Maybe String -> Flag
-out Nothing = Output "stdout"
-out (Just o) = Output o
-
-test :: ArgOrder Flag -> [String] -> String
-test order cmdline = case getOpt order options cmdline of
- (o,n,[] ) -> "options=" ++ show o ++ " args=" ++ show n ++ "\n"
- (_,_,errs) -> concat errs ++ usageInfo header options
- where header = "Usage: foobar [OPTION...] files..."
-
--- example runs:
--- putStr (test RequireOrder ["foo","-v"])
--- ==> options=[] args=["foo", "-v"]
--- putStr (test Permute ["foo","-v"])
--- ==> options=[Verbose] args=["foo"]
--- putStr (test (ReturnInOrder Arg) ["foo","-v"])
--- ==> options=[Arg "foo", Verbose] args=[]
--- putStr (test Permute ["foo","--","-v"])
--- ==> options=[] args=["foo", "-v"]
--- putStr (test Permute ["-?o","--name","bar","--na=baz"])
--- ==> options=[Version, Output "stdout", Name "bar", Name "baz"] args=[]
--- putStr (test Permute ["--ver","foo"])
--- ==> option `--ver' is ambiguous; could be one of:
--- -v --verbose verbosely list files
--- -V, -? --version, --release show version info
--- Usage: foobar [OPTION...] files...
--- -v --verbose verbosely list files
--- -V, -? --version, --release show version info
--- -o[FILE] --output[=FILE] use FILE for dump
--- -n USER --name=USER only dump USER's files
------------------------------------------------------------------------------------------
--}
-
-{- $example
-
-To hopefully illuminate the role of the different data
-structures, here\'s the command-line options for a (very simple)
-compiler:
-
-> module Opts where
->
-> import Distribution.GetOpt
-> import Data.Maybe ( fromMaybe )
->
-> data Flag
-> = Verbose | Version
-> | Input String | Output String | LibDir String
-> deriving Show
->
-> options :: [OptDescr Flag]
-> options =
-> [ Option ['v'] ["verbose"] (NoArg Verbose) "chatty output on stderr"
-> , Option ['V','?'] ["version"] (NoArg Version) "show version number"
-> , Option ['o'] ["output"] (OptArg outp "FILE") "output FILE"
-> , Option ['c'] [] (OptArg inp "FILE") "input FILE"
-> , Option ['L'] ["libdir"] (ReqArg LibDir "DIR") "library directory"
-> ]
->
-> inp,outp :: Maybe String -> Flag
-> outp = Output . fromMaybe "stdout"
-> inp = Input . fromMaybe "stdin"
->
-> compilerOpts :: [String] -> IO ([Flag], [String])
-> compilerOpts argv =
-> case getOpt Permute options argv of
-> (o,n,[] ) -> return (o,n)
-> (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))
-> where header = "Usage: ic [OPTION...] files..."
-
--}
diff --git a/cabal/Cabal/Distribution/InstalledPackageInfo.hs b/cabal/Cabal/Distribution/InstalledPackageInfo.hs
deleted file mode 100644
index db3a3e6..0000000
--- a/cabal/Cabal/Distribution/InstalledPackageInfo.hs
+++ /dev/null
@@ -1,294 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Distribution.InstalledPackageInfo
--- Copyright : (c) The University of Glasgow 2004
---
--- Maintainer : libraries@haskell.org
--- Portability : portable
---
--- This is the information about an /installed/ package that
--- is communicated to the @ghc-pkg@ program in order to register
--- a package. @ghc-pkg@ now consumes this package format (as of version
--- 6.4). This is specific to GHC at the moment.
---
--- The @.cabal@ file format is for describing a package that is not yet
--- installed. It has a lot of flexibility, like conditionals and dependency
--- ranges. As such, that format is not at all suitable for describing a package
--- that has already been built and installed. By the time we get to that stage,
--- we have resolved all conditionals and resolved dependency version
--- constraints to exact versions of dependent packages. So, this module defines
--- the 'InstalledPackageInfo' data structure that contains all the info we keep
--- about an installed package. There is a parser and pretty printer. The
--- textual format is rather simpler than the @.cabal@ format: there are no
--- sections, for example.
-
-{- All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
- * Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
- * Redistributions in binary form must reproduce the above
- copyright notice, this list of conditions and the following
- disclaimer in the documentation and/or other materials provided
- with the distribution.
-
- * Neither the name of the University nor the names of other
- contributors may be used to endorse or promote products derived
- from this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
-
--- This module is meant to be local-only to Distribution...
-
-module Distribution.InstalledPackageInfo (
- InstalledPackageInfo_(..), InstalledPackageInfo,
- ParseResult(..), PError(..), PWarning,
- emptyInstalledPackageInfo,
- parseInstalledPackageInfo,
- showInstalledPackageInfo,
- showInstalledPackageInfoField,
- fieldsInstalledPackageInfo,
- ) where
-
-import Distribution.ParseUtils
- ( FieldDescr(..), ParseResult(..), PError(..), PWarning
- , simpleField, listField, parseLicenseQ
- , showFields, showSingleNamedField, parseFieldsFlat
- , parseFilePathQ, parseTokenQ, parseModuleNameQ, parsePackageNameQ
- , showFilePath, showToken, boolField, parseOptVersion
- , parseFreeText, showFreeText )
-import Distribution.License ( License(..) )
-import Distribution.Package
- ( PackageName(..), PackageIdentifier(..), PackageId, InstalledPackageId(..)
- , packageName, packageVersion )
-import qualified Distribution.Package as Package
- ( Package(..) )
-import Distribution.ModuleName
- ( ModuleName )
-import Distribution.Version
- ( Version(..) )
-import Distribution.Text
- ( Text(disp, parse) )
-
--- -----------------------------------------------------------------------------
--- The InstalledPackageInfo type
-
-data InstalledPackageInfo_ m
- = InstalledPackageInfo {
- -- these parts are exactly the same as PackageDescription
- installedPackageId :: InstalledPackageId,
- sourcePackageId :: PackageId,
- license :: License,
- copyright :: String,
- maintainer :: String,
- author :: String,
- stability :: String,
- homepage :: String,
- pkgUrl :: String,
- synopsis :: String,
- description :: String,
- category :: String,
- -- these parts are required by an installed package only:
- exposed :: Bool,
- exposedModules :: [m],
- hiddenModules :: [m],
- trusted :: Bool,
- importDirs :: [FilePath], -- contain sources in case of Hugs
- libraryDirs :: [FilePath],
- hsLibraries :: [String],
- extraLibraries :: [String],
- extraGHCiLibraries:: [String], -- overrides extraLibraries for GHCi
- includeDirs :: [FilePath],
- includes :: [String],
- depends :: [InstalledPackageId],
- hugsOptions :: [String],
- ccOptions :: [String],
- ldOptions :: [String],
- frameworkDirs :: [FilePath],
- frameworks :: [String],
- haddockInterfaces :: [FilePath],
- haddockHTMLs :: [FilePath]
- }
- deriving (Read, Show)
-
-instance Package.Package (InstalledPackageInfo_ str) where
- packageId = sourcePackageId
-
-type InstalledPackageInfo = InstalledPackageInfo_ ModuleName
-
-emptyInstalledPackageInfo :: InstalledPackageInfo_ m
-emptyInstalledPackageInfo
- = InstalledPackageInfo {
- installedPackageId = InstalledPackageId "",
- sourcePackageId = PackageIdentifier (PackageName "") noVersion,
- license = AllRightsReserved,
- copyright = "",
- maintainer = "",
- author = "",
- stability = "",
- homepage = "",
- pkgUrl = "",
- synopsis = "",
- description = "",
- category = "",
- exposed = False,
- exposedModules = [],
- hiddenModules = [],
- trusted = False,
- importDirs = [],
- libraryDirs = [],
- hsLibraries = [],
- extraLibraries = [],
- extraGHCiLibraries= [],
- includeDirs = [],
- includes = [],
- depends = [],
- hugsOptions = [],
- ccOptions = [],
- ldOptions = [],
- frameworkDirs = [],
- frameworks = [],
- haddockInterfaces = [],
- haddockHTMLs = []
- }
-
-noVersion :: Version
-noVersion = Version{ versionBranch=[], versionTags=[] }
-
--- -----------------------------------------------------------------------------
--- Parsing
-
-parseInstalledPackageInfo :: String -> ParseResult InstalledPackageInfo
-parseInstalledPackageInfo =
- parseFieldsFlat fieldsInstalledPackageInfo emptyInstalledPackageInfo
-
--- -----------------------------------------------------------------------------
--- Pretty-printing
-
-showInstalledPackageInfo :: InstalledPackageInfo -> String
-showInstalledPackageInfo = showFields fieldsInstalledPackageInfo
-
-showInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String)
-showInstalledPackageInfoField = showSingleNamedField fieldsInstalledPackageInfo
-
--- -----------------------------------------------------------------------------
--- Description of the fields, for parsing/printing
-
-fieldsInstalledPackageInfo :: [FieldDescr InstalledPackageInfo]
-fieldsInstalledPackageInfo = basicFieldDescrs ++ installedFieldDescrs
-
-basicFieldDescrs :: [FieldDescr InstalledPackageInfo]
-basicFieldDescrs =
- [ simpleField "name"
- disp parsePackageNameQ
- packageName (\name pkg -> pkg{sourcePackageId=(sourcePackageId pkg){pkgName=name}})
- , simpleField "version"
- disp parseOptVersion
- packageVersion (\ver pkg -> pkg{sourcePackageId=(sourcePackageId pkg){pkgVersion=ver}})
- , simpleField "id"
- disp parse
- installedPackageId (\ipid pkg -> pkg{installedPackageId=ipid})
- , simpleField "license"
- disp parseLicenseQ
- license (\l pkg -> pkg{license=l})
- , simpleField "copyright"
- showFreeText parseFreeText
- copyright (\val pkg -> pkg{copyright=val})
- , simpleField "maintainer"
- showFreeText parseFreeText
- maintainer (\val pkg -> pkg{maintainer=val})
- , simpleField "stability"
- showFreeText parseFreeText
- stability (\val pkg -> pkg{stability=val})
- , simpleField "homepage"
- showFreeText parseFreeText
- homepage (\val pkg -> pkg{homepage=val})
- , simpleField "package-url"
- showFreeText parseFreeText
- pkgUrl (\val pkg -> pkg{pkgUrl=val})
- , simpleField "synopsis"
- showFreeText parseFreeText
- synopsis (\val pkg -> pkg{synopsis=val})
- , simpleField "description"
- showFreeText parseFreeText
- description (\val pkg -> pkg{description=val})
- , simpleField "category"
- showFreeText parseFreeText
- category (\val pkg -> pkg{category=val})
- , simpleField "author"
- showFreeText parseFreeText
- author (\val pkg -> pkg{author=val})
- ]
-
-installedFieldDescrs :: [FieldDescr InstalledPackageInfo]
-installedFieldDescrs = [
- boolField "exposed"
- exposed (\val pkg -> pkg{exposed=val})
- , listField "exposed-modules"
- disp parseModuleNameQ
- exposedModules (\xs pkg -> pkg{exposedModules=xs})
- , listField "hidden-modules"
- disp parseModuleNameQ
- hiddenModules (\xs pkg -> pkg{hiddenModules=xs})
- , boolField "trusted"
- trusted (\val pkg -> pkg{trusted=val})
- , listField "import-dirs"
- showFilePath parseFilePathQ
- importDirs (\xs pkg -> pkg{importDirs=xs})
- , listField "library-dirs"
- showFilePath parseFilePathQ
- libraryDirs (\xs pkg -> pkg{libraryDirs=xs})
- , listField "hs-libraries"
- showFilePath parseTokenQ
- hsLibraries (\xs pkg -> pkg{hsLibraries=xs})
- , listField "extra-libraries"
- showToken parseTokenQ
- extraLibraries (\xs pkg -> pkg{extraLibraries=xs})
- , listField "extra-ghci-libraries"
- showToken parseTokenQ
- extraGHCiLibraries (\xs pkg -> pkg{extraGHCiLibraries=xs})
- , listField "include-dirs"
- showFilePath parseFilePathQ
- includeDirs (\xs pkg -> pkg{includeDirs=xs})
- , listField "includes"
- showFilePath parseFilePathQ
- includes (\xs pkg -> pkg{includes=xs})
- , listField "depends"
- disp parse
- depends (\xs pkg -> pkg{depends=xs})
- , listField "hugs-options"
- showToken parseTokenQ
- hugsOptions (\path pkg -> pkg{hugsOptions=path})
- , listField "cc-options"
- showToken parseTokenQ
- ccOptions (\path pkg -> pkg{ccOptions=path})
- , listField "ld-options"
- showToken parseTokenQ
- ldOptions (\path pkg -> pkg{ldOptions=path})
- , listField "framework-dirs"
- showFilePath parseFilePathQ
- frameworkDirs (\xs pkg -> pkg{frameworkDirs=xs})
- , listField "frameworks"
- showToken parseTokenQ
- frameworks (\xs pkg -> pkg{frameworks=xs})
- , listField "haddock-interfaces"
- showFilePath parseFilePathQ
- haddockInterfaces (\xs pkg -> pkg{haddockInterfaces=xs})
- , listField "haddock-html"
- showFilePath parseFilePathQ
- haddockHTMLs (\xs pkg -> pkg{haddockHTMLs=xs})
- ]
diff --git a/cabal/Cabal/Distribution/License.hs b/cabal/Cabal/Distribution/License.hs
deleted file mode 100644
index 19b54c3..0000000
--- a/cabal/Cabal/Distribution/License.hs
+++ /dev/null
@@ -1,146 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Distribution.License
--- Copyright : Isaac Jones 2003-2005
--- Duncan Coutts 2008
---
--- Maintainer : cabal-devel@haskell.org
--- Portability : portable
---
--- The License datatype. For more information about these and other
--- open-source licenses, you may visit <http://www.opensource.org/>.
---
--- The @.cabal@ file allows you to specify a license file. Of course you can
--- use any license you like but people often pick common open source licenses
--- and it's useful if we can automatically recognise that (eg so we can display
--- it on the hackage web pages). So you can also specify the license itself in
--- the @.cabal@ file from a short enumeration defined in this module. It
--- includes 'GPL', 'LGPL' and 'BSD3' licenses.
-
-{- All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
- * Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
- * Redistributions in binary form must reproduce the above
- copyright notice, this list of conditions and the following
- disclaimer in the documentation and/or other materials provided
- with the distribution.
-
- * Neither the name of Isaac Jones nor the names of other
- contributors may be used to endorse or promote products derived
- from this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
-
-module Distribution.License (
- License(..),
- knownLicenses,
- ) where
-
-import Distribution.Version (Version(Version))
-
-import Distribution.Text (Text(..), display)
-import qualified Distribution.Compat.ReadP as Parse
-import qualified Text.PrettyPrint as Disp
-import Text.PrettyPrint ((<>))
-import qualified Data.Char as Char (isAlphaNum)
-
--- |This datatype indicates the license under which your package is
--- released. It is also wise to add your license to each source file
--- using the license-file field. The 'AllRightsReserved' constructor
--- is not actually a license, but states that you are not giving
--- anyone else a license to use or distribute your work. The comments
--- below are general guidelines. Please read the licenses themselves
--- and consult a lawyer if you are unsure of your rights to release
--- the software.
---
-data License =
-
---TODO: * remove BSD4
-
- -- | GNU Public License. Source code must accompany alterations.
- GPL (Maybe Version)
-
- -- | Lesser GPL, Less restrictive than GPL, useful for libraries.
- | LGPL (Maybe Version)
-
- -- | 3-clause BSD license, newer, no advertising clause. Very free license.
- | BSD3
-
- -- | 4-clause BSD license, older, with advertising clause. You almost
- -- certainly want to use the BSD3 license instead.
- | BSD4
-
- -- | The MIT license, similar to the BSD3. Very free license.
- | MIT
-
- -- | 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
-
- -- | No rights are granted to others. Undistributable. Most restrictive.
- | AllRightsReserved
-
- -- | Some other license.
- | OtherLicense
-
- -- | Not a recognised license.
- -- Allows us to deal with future extensions more gracefully.
- | UnknownLicense String
- deriving (Read, Show, Eq)
-
-knownLicenses :: [License]
-knownLicenses = [ GPL unversioned, GPL (version [2]), GPL (version [3])
- , LGPL unversioned, LGPL (version [2,1]), LGPL (version [3])
- , BSD3, MIT
- , Apache unversioned, Apache (version [2, 0])
- , PublicDomain, AllRightsReserved, OtherLicense]
- where
- unversioned = Nothing
- version v = Just (Version v [])
-
-instance Text License where
- disp (GPL version) = Disp.text "GPL" <> dispOptVersion version
- disp (LGPL version) = Disp.text "LGPL" <> dispOptVersion version
- disp (Apache version) = Disp.text "Apache" <> dispOptVersion version
- disp (UnknownLicense other) = Disp.text other
- disp other = Disp.text (show other)
-
- parse = do
- name <- Parse.munch1 (\c -> Char.isAlphaNum c && c /= '-')
- version <- Parse.option Nothing (Parse.char '-' >> fmap Just parse)
- return $! case (name, version :: Maybe Version) of
- ("GPL", _ ) -> GPL version
- ("LGPL", _ ) -> LGPL version
- ("BSD3", Nothing) -> BSD3
- ("BSD4", Nothing) -> BSD4
- ("MIT", Nothing) -> MIT
- ("Apache", _ ) -> Apache version
- ("PublicDomain", Nothing) -> PublicDomain
- ("AllRightsReserved", Nothing) -> AllRightsReserved
- ("OtherLicense", Nothing) -> OtherLicense
- _ -> UnknownLicense $ name
- ++ maybe "" (('-':) . display) version
-
-dispOptVersion :: Maybe Version -> Disp.Doc
-dispOptVersion Nothing = Disp.empty
-dispOptVersion (Just v) = Disp.char '-' <> disp v
diff --git a/cabal/Cabal/Distribution/Make.hs b/cabal/Cabal/Distribution/Make.hs
deleted file mode 100644
index d085ce3..0000000
--- a/cabal/Cabal/Distribution/Make.hs
+++ /dev/null
@@ -1,213 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Distribution.Make
--- Copyright : Martin Sj&#xF6;gren 2004
---
--- Maintainer : cabal-devel@haskell.org
--- Portability : portable
---
--- This is an alternative build system that delegates everything to the @make@
--- program. All the commands just end up calling @make@ with appropriate
--- arguments. The intention was to allow preexisting packages that used
--- makefiles to be wrapped into Cabal packages. In practice essentially all
--- such packages were converted over to the \"Simple\" build system instead.
--- Consequently this module is not used much and it certainly only sees cursory
--- maintenance and no testing. Perhaps at some point we should stop pretending
--- that it works.
---
--- Uses the parsed command-line from "Distribution.Simple.Setup" in order to build
--- Haskell tools using a backend build system based on make. Obviously we
--- assume that there is a configure script, and that after the ConfigCmd has
--- been run, there is a Makefile. Further assumptions:
---
--- [ConfigCmd] We assume the configure script accepts
--- @--with-hc@,
--- @--with-hc-pkg@,
--- @--prefix@,
--- @--bindir@,
--- @--libdir@,
--- @--libexecdir@,
--- @--datadir@.
---
--- [BuildCmd] We assume that the default Makefile target will build everything.
---
--- [InstallCmd] We assume there is an @install@ target. Note that we assume that
--- this does *not* register the package!
---
--- [CopyCmd] We assume there is a @copy@ target, and a variable @$(destdir)@.
--- The @copy@ target should probably just invoke @make install@
--- recursively (e.g. @$(MAKE) install prefix=$(destdir)\/$(prefix)
--- bindir=$(destdir)\/$(bindir)@. The reason we can\'t invoke @make
--- install@ directly here is that we don\'t know the value of @$(prefix)@.
---
--- [SDistCmd] We assume there is a @dist@ target.
---
--- [RegisterCmd] We assume there is a @register@ target and a variable @$(user)@.
---
--- [UnregisterCmd] We assume there is an @unregister@ target.
---
--- [HaddockCmd] We assume there is a @docs@ or @doc@ target.
-
-
--- copy :
--- $(MAKE) install prefix=$(destdir)/$(prefix) \
--- bindir=$(destdir)/$(bindir) \
-
-{- All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
- * Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
- * Redistributions in binary form must reproduce the above
- copyright notice, this list of conditions and the following
- disclaimer in the documentation and/or other materials provided
- with the distribution.
-
- * Neither the name of Isaac Jones nor the names of other
- contributors may be used to endorse or promote products derived
- from this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
-
-module Distribution.Make (
- module Distribution.Package,
- License(..), Version(..),
- defaultMain, defaultMainArgs, defaultMainNoRead
- ) where
-
--- local
-import Distribution.Compat.Exception
-import Distribution.Package --must not specify imports, since we're exporting moule.
-import Distribution.Simple.Program(defaultProgramConfiguration)
-import Distribution.PackageDescription
-import Distribution.Simple.Setup
-import Distribution.Simple.Command
-
-import Distribution.Simple.Utils (rawSystemExit, cabalVersion)
-
-import Distribution.License (License(..))
-import Distribution.Version
- ( Version(..) )
-import Distribution.Text
- ( display )
-
-import System.Environment (getArgs, getProgName)
-import Data.List (intersperse)
-import System.Exit
-
-defaultMain :: IO ()
-defaultMain = getArgs >>= defaultMainArgs
-
-defaultMainArgs :: [String] -> IO ()
-defaultMainArgs = defaultMainHelper
-
-{-# DEPRECATED defaultMainNoRead "it ignores its PackageDescription arg" #-}
-defaultMainNoRead :: PackageDescription -> IO ()
-defaultMainNoRead = const defaultMain
-
-defaultMainHelper :: [String] -> IO ()
-defaultMainHelper args =
- case commandsRun globalCommand commands args of
- CommandHelp help -> printHelp help
- CommandList opts -> printOptionsList opts
- CommandErrors errs -> printErrors errs
- CommandReadyToGo (flags, commandParse) ->
- case commandParse of
- _ | fromFlag (globalVersion flags) -> printVersion
- | fromFlag (globalNumericVersion flags) -> printNumericVersion
- CommandHelp help -> printHelp help
- CommandList opts -> printOptionsList opts
- CommandErrors errs -> printErrors errs
- CommandReadyToGo action -> action
-
- where
- printHelp help = getProgName >>= putStr . help
- printOptionsList = putStr . unlines
- printErrors errs = do
- putStr (concat (intersperse "\n" errs))
- exitWith (ExitFailure 1)
- printNumericVersion = putStrLn $ display cabalVersion
- printVersion = putStrLn $ "Cabal library version "
- ++ display cabalVersion
-
- progs = defaultProgramConfiguration
- commands =
- [configureCommand progs `commandAddAction` configureAction
- ,buildCommand progs `commandAddAction` buildAction
- ,installCommand `commandAddAction` installAction
- ,copyCommand `commandAddAction` copyAction
- ,haddockCommand `commandAddAction` haddockAction
- ,cleanCommand `commandAddAction` cleanAction
- ,sdistCommand `commandAddAction` sdistAction
- ,registerCommand `commandAddAction` registerAction
- ,unregisterCommand `commandAddAction` unregisterAction
- ]
-
-configureAction :: ConfigFlags -> [String] -> IO ()
-configureAction flags args = do
- noExtraFlags args
- let verbosity = fromFlag (configVerbosity flags)
- rawSystemExit verbosity "sh" $
- "configure"
- : configureArgs backwardsCompatHack flags
- where backwardsCompatHack = True
-
-copyAction :: CopyFlags -> [String] -> IO ()
-copyAction flags args = do
- noExtraFlags args
- let destArgs = case fromFlag $ copyDest flags of
- NoCopyDest -> ["install"]
- CopyTo path -> ["copy", "destdir=" ++ path]
- rawSystemExit (fromFlag $ copyVerbosity flags) "make" destArgs
-
-installAction :: InstallFlags -> [String] -> IO ()
-installAction flags args = do
- noExtraFlags args
- rawSystemExit (fromFlag $ installVerbosity flags) "make" ["install"]
- rawSystemExit (fromFlag $ installVerbosity flags) "make" ["register"]
-
-haddockAction :: HaddockFlags -> [String] -> IO ()
-haddockAction flags args = do
- noExtraFlags args
- rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["docs"]
- `catchIO` \_ ->
- rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["doc"]
-
-buildAction :: BuildFlags -> [String] -> IO ()
-buildAction flags args = do
- noExtraFlags args
- rawSystemExit (fromFlag $ buildVerbosity flags) "make" []
-
-cleanAction :: CleanFlags -> [String] -> IO ()
-cleanAction flags args = do
- noExtraFlags args
- rawSystemExit (fromFlag $ cleanVerbosity flags) "make" ["clean"]
-
-sdistAction :: SDistFlags -> [String] -> IO ()
-sdistAction flags args = do
- noExtraFlags args
- rawSystemExit (fromFlag $ sDistVerbosity flags) "make" ["dist"]
-
-registerAction :: RegisterFlags -> [String] -> IO ()
-registerAction flags args = do
- noExtraFlags args
- rawSystemExit (fromFlag $ regVerbosity flags) "make" ["register"]
-
-unregisterAction :: RegisterFlags -> [String] -> IO ()
-unregisterAction flags args = do
- noExtraFlags args
- rawSystemExit (fromFlag $ regVerbosity flags) "make" ["unregister"]
diff --git a/cabal/Cabal/Distribution/ModuleName.hs b/cabal/Cabal/Distribution/ModuleName.hs
deleted file mode 100644
index 5fe0cc1..0000000
--- a/cabal/Cabal/Distribution/ModuleName.hs
+++ /dev/null
@@ -1,130 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Distribution.ModuleName
--- Copyright : Duncan Coutts 2008
---
--- Maintainer : cabal-devel@haskell.org
--- Portability : portable
---
--- Data type for Haskell module names.
-
-{- All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
- * Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
- * Redistributions in binary form must reproduce the above
- copyright notice, this list of conditions and the following
- disclaimer in the documentation and/or other materials provided
- with the distribution.
-
- * Neither the name of Isaac Jones nor the names of other
- contributors may be used to endorse or promote products derived
- from this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
-
-module Distribution.ModuleName (
- ModuleName,
- fromString,
- components,
- toFilePath,
- main,
- simple,
- ) where
-
-import Distribution.Text
- ( Text(..) )
-
-import qualified Distribution.Compat.ReadP as Parse
-import qualified Text.PrettyPrint as Disp
-import qualified Data.Char as Char
- ( isAlphaNum, isUpper )
-import System.FilePath
- ( pathSeparator )
-import Data.List
- ( intersperse )
-
--- | A valid Haskell module name.
---
-newtype ModuleName = ModuleName [String]
- deriving (Eq, Ord, Read, Show)
-
-instance Text ModuleName where
- disp (ModuleName ms) =
- Disp.hcat (intersperse (Disp.char '.') (map Disp.text ms))
-
- parse = do
- ms <- Parse.sepBy1 component (Parse.char '.')
- return (ModuleName ms)
-
- where
- component = do
- c <- Parse.satisfy Char.isUpper
- cs <- Parse.munch validModuleChar
- return (c:cs)
-
-validModuleChar :: Char -> Bool
-validModuleChar c = Char.isAlphaNum c || c == '_' || c == '\''
-
-validModuleComponent :: String -> Bool
-validModuleComponent [] = False
-validModuleComponent (c:cs) = Char.isUpper c
- && all validModuleChar cs
-
-{-# DEPRECATED simple "use ModuleName.fromString instead" #-}
-simple :: String -> ModuleName
-simple str = ModuleName [str]
-
--- | Construct a 'ModuleName' from a valid module name 'String'.
---
--- This is just a convenience function intended for valid module strings. It is
--- an error if it is used with a string that is not a valid module name. If you
--- are parsing user input then use 'Distribution.Text.simpleParse' instead.
---
-fromString :: String -> ModuleName
-fromString string
- | all validModuleComponent components' = ModuleName components'
- | otherwise = error badName
-
- where
- components' = split string
- badName = "ModuleName.fromString: invalid module name " ++ show string
-
- split cs = case break (=='.') cs of
- (chunk,[]) -> chunk : []
- (chunk,_:rest) -> chunk : split rest
-
--- | The module name @Main@.
---
-main :: ModuleName
-main = ModuleName ["Main"]
-
--- | The individual components of a hierarchical module name. For example
---
--- > components (fromString "A.B.C") = ["A", "B", "C"]
---
-components :: ModuleName -> [String]
-components (ModuleName ms) = ms
-
--- | Convert a module name to a file path, but without any file extension.
--- For example:
---
--- > toFilePath (fromString "A.B.C") = "A/B/C"
---
-toFilePath :: ModuleName -> FilePath
-toFilePath = concat . intersperse [pathSeparator] . components
diff --git a/cabal/Cabal/Distribution/Package.hs b/cabal/Cabal/Distribution/Package.hs
deleted file mode 100644
index 0017b8c..0000000
--- a/cabal/Cabal/Distribution/Package.hs
+++ /dev/null
@@ -1,202 +0,0 @@
-{-# LANGUAGE DeriveDataTypeable #-}
------------------------------------------------------------------------------
--- |
--- Module : Distribution.Package
--- Copyright : Isaac Jones 2003-2004
---
--- Maintainer : cabal-devel@haskell.org
--- Portability : portable
---
--- Defines a package identifier along with a parser and pretty printer for it.
--- 'PackageIdentifier's consist of a name and an exact version. It also defines
--- a 'Dependency' data type. A dependency is a package name and a version
--- range, like @\"foo >= 1.2 && < 2\"@.
-
-{- All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
- * Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
- * Redistributions in binary form must reproduce the above
- copyright notice, this list of conditions and the following
- disclaimer in the documentation and/or other materials provided
- with the distribution.
-
- * Neither the name of Isaac Jones nor the names of other
- contributors may be used to endorse or promote products derived
- from this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
-
-module Distribution.Package (
- -- * Package ids
- PackageName(..),
- PackageIdentifier(..),
- PackageId,
-
- -- * Installed package identifiers
- InstalledPackageId(..),
-
- -- * Package source dependencies
- Dependency(..),
- thisPackageVersion,
- notThisPackageVersion,
- simplifyDependency,
-
- -- * Package classes
- Package(..), packageName, packageVersion,
- PackageFixedDeps(..),
- ) where
-
-import Distribution.Version
- ( Version(..), VersionRange, anyVersion, thisVersion
- , notThisVersion, simplifyVersionRange )
-
-import Distribution.Text (Text(..))
-import qualified Distribution.Compat.ReadP as Parse
-import Distribution.Compat.ReadP ((<++))
-import qualified Text.PrettyPrint as Disp
-import Text.PrettyPrint ((<>), (<+>), text)
-import 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, Typeable)
-
-instance Text PackageName where
- disp (PackageName n) = Disp.text n
- parse = do
- ns <- Parse.sepBy1 component (Parse.char '-')
- return (PackageName (concat (intersperse "-" ns)))
- where
- component = do
- cs <- Parse.munch1 Char.isAlphaNum
- if all Char.isDigit cs then Parse.pfail else return cs
- -- each component must contain an alphabetic character, to avoid
- -- ambiguity in identifiers like foo-1 (the 1 is the version number).
-
-instance NFData PackageName where
- rnf (PackageName pkg) = rnf pkg
-
--- | Type alias so we can use the shorter name PackageId.
-type PackageId = PackageIdentifier
-
--- | The name and version of a package.
-data PackageIdentifier
- = PackageIdentifier {
- pkgName :: PackageName, -- ^The name of this package, eg. foo
- pkgVersion :: Version -- ^the version of this package, eg 1.2
- }
- deriving (Read, Show, Eq, Ord, Typeable)
-
-instance Text PackageIdentifier where
- disp (PackageIdentifier n v) = case v of
- Version [] _ -> disp n -- if no version, don't show version.
- _ -> disp n <> Disp.char '-' <> disp v
-
- parse = do
- n <- parse
- v <- (Parse.char '-' >> parse) <++ return (Version [] [])
- return (PackageIdentifier n v)
-
-instance NFData PackageIdentifier where
- rnf (PackageIdentifier name version) = rnf name `seq` rnf version
-
--- ------------------------------------------------------------
--- * Installed Package Ids
--- ------------------------------------------------------------
-
--- | An InstalledPackageId uniquely identifies an instance of an installed package.
--- There can be at most one package with a given 'InstalledPackageId'
--- in a package database, or overlay of databases.
---
-newtype InstalledPackageId = InstalledPackageId String
- deriving (Read,Show,Eq,Ord)
-
-instance Text InstalledPackageId where
- disp (InstalledPackageId str) = text str
-
- parse = InstalledPackageId `fmap` Parse.munch1 abi_char
- where abi_char c = Char.isAlphaNum c || c `elem` ":-_."
-
--- ------------------------------------------------------------
--- * Package source dependencies
--- ------------------------------------------------------------
-
--- | Describes a dependency on a source package (API)
---
-data Dependency = Dependency PackageName VersionRange
- deriving (Read, Show, Eq)
-
-instance Text Dependency where
- disp (Dependency name ver) =
- disp name <+> disp ver
-
- parse = do name <- parse
- Parse.skipSpaces
- ver <- parse <++ return anyVersion
- Parse.skipSpaces
- return (Dependency name ver)
-
-thisPackageVersion :: PackageIdentifier -> Dependency
-thisPackageVersion (PackageIdentifier n v) =
- Dependency n (thisVersion v)
-
-notThisPackageVersion :: PackageIdentifier -> Dependency
-notThisPackageVersion (PackageIdentifier n v) =
- Dependency n (notThisVersion v)
-
--- | Simplify the 'VersionRange' expression in a 'Dependency'.
--- See 'simplifyVersionRange'.
---
-simplifyDependency :: Dependency -> Dependency
-simplifyDependency (Dependency name range) =
- Dependency name (simplifyVersionRange range)
-
--- | Class of things that have a 'PackageIdentifier'
---
--- Types in this class are all notions of a package. This allows us to have
--- different types for the different phases that packages go though, from
--- simple name\/id, package description, configured or installed packages.
---
--- Not all kinds of packages can be uniquely identified by a
--- 'PackageIdentifier'. In particular, installed packages cannot, there may be
--- many installed instances of the same source package.
---
-class Package pkg where
- packageId :: pkg -> PackageIdentifier
-
-packageName :: Package pkg => pkg -> PackageName
-packageName = pkgName . packageId
-
-packageVersion :: Package pkg => pkg -> Version
-packageVersion = pkgVersion . packageId
-
-instance Package PackageIdentifier where
- packageId = id
-
--- | Subclass of packages that have specific versioned dependencies.
---
--- So for example a not-yet-configured package has dependencies on version
--- ranges, not specific versions. A configured or an already installed package
--- depends on exact versions. Some operations or data structures (like
--- dependency graphs) only make sense on this subclass of package types.
---
-class Package pkg => PackageFixedDeps pkg where
- depends :: pkg -> [PackageIdentifier]
diff --git a/cabal/Cabal/Distribution/PackageDescription.hs b/cabal/Cabal/Distribution/PackageDescription.hs
deleted file mode 100644
index 034479b..0000000
--- a/cabal/Cabal/Distribution/PackageDescription.hs
+++ /dev/null
@@ -1,1034 +0,0 @@
-{-# LANGUAGE DeriveDataTypeable #-}
------------------------------------------------------------------------------
--- |
--- Module : Distribution.PackageDescription
--- Copyright : Isaac Jones 2003-2005
---
--- Maintainer : cabal-devel@haskell.org
--- Portability : portable
---
--- This defines the data structure for the @.cabal@ file format. There are
--- several parts to this structure. It has top level info and then 'Library',
--- 'Executable', '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
--- on each conditional. Once we've done that we get a 'PackageDescription'.
--- It was done this way initially to avoid breaking too much stuff when the
--- feature was introduced. It could probably do with being rationalised at some
--- point to make it simpler.
-
-{- All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
- * Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
- * Redistributions in binary form must reproduce the above
- copyright notice, this list of conditions and the following
- disclaimer in the documentation and/or other materials provided
- with the distribution.
-
- * Neither the name of Isaac Jones nor the names of other
- contributors may be used to endorse or promote products derived
- from this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
-
-module Distribution.PackageDescription (
- -- * Package descriptions
- PackageDescription(..),
- emptyPackageDescription,
- specVersion,
- descCabalVersion,
- BuildType(..),
- knownBuildTypes,
-
- -- ** Libraries
- Library(..),
- emptyLibrary,
- withLib,
- hasLibs,
- libModules,
-
- -- ** Executables
- Executable(..),
- emptyExecutable,
- withExe,
- hasExes,
- exeModules,
-
- -- * Tests
- TestSuite(..),
- TestSuiteInterface(..),
- TestType(..),
- testType,
- knownTestTypes,
- emptyTestSuite,
- hasTests,
- withTest,
- testModules,
- enabledTests,
-
- -- * Benchmarks
- Benchmark(..),
- BenchmarkInterface(..),
- BenchmarkType(..),
- benchmarkType,
- knownBenchmarkTypes,
- emptyBenchmark,
- hasBenchmarks,
- withBenchmark,
- benchmarkModules,
- enabledBenchmarks,
-
- -- * Build information
- BuildInfo(..),
- emptyBuildInfo,
- allBuildInfo,
- allLanguages,
- allExtensions,
- usedExtensions,
- hcOptions,
-
- -- ** Supplementary build information
- HookedBuildInfo,
- emptyHookedBuildInfo,
- updatePackageDescription,
-
- -- * package configuration
- GenericPackageDescription(..),
- Flag(..), FlagName(..), FlagAssignment,
- CondTree(..), ConfVar(..), Condition(..),
-
- -- * Source repositories
- SourceRepo(..),
- RepoKind(..),
- RepoType(..),
- knownRepoTypes,
- ) where
-
-import Data.List (nub, intersperse)
-import Data.Maybe (maybeToList)
-import Data.Monoid (Monoid(mempty, mappend))
-import Data.Typeable ( Typeable )
-import Control.Monad (MonadPlus(mplus))
-import Text.PrettyPrint as Disp
-import qualified Distribution.Compat.ReadP as Parse
-import qualified Data.Char as Char (isAlphaNum, isDigit, toLower)
-
-import Distribution.Package
- ( PackageName(PackageName), PackageIdentifier(PackageIdentifier)
- , Dependency, Package(..) )
-import Distribution.ModuleName ( ModuleName )
-import Distribution.Version
- ( Version(Version), VersionRange, anyVersion, orLaterVersion
- , asVersionIntervals, LowerBound(..) )
-import Distribution.License (License(AllRightsReserved))
-import Distribution.Compiler (CompilerFlavor)
-import Distribution.System (OS, Arch)
-import Distribution.Text
- ( Text(..), display )
-import Language.Haskell.Extension
- ( Language, Extension )
-
--- -----------------------------------------------------------------------------
--- The PackageDescription type
-
--- | This data type is the internal representation of the file @pkg.cabal@.
--- It contains two kinds of information about the package: information
--- which is needed for all packages, such as the package name and version, and
--- information which is needed for the simple build system only, such as
--- the compiler options and library name.
---
-data PackageDescription
- = PackageDescription {
- -- the following are required by all packages:
- package :: PackageIdentifier,
- license :: License,
- licenseFile :: FilePath,
- copyright :: String,
- maintainer :: String,
- author :: String,
- stability :: String,
- testedWith :: [(CompilerFlavor,VersionRange)],
- homepage :: String,
- pkgUrl :: String,
- bugReports :: String,
- sourceRepos :: [SourceRepo],
- synopsis :: String, -- ^A one-line summary of this package
- description :: String, -- ^A more verbose description of this package
- category :: String,
- customFieldsPD :: [(String,String)], -- ^Custom fields starting
- -- with x-, stored in a
- -- simple assoc-list.
- buildDepends :: [Dependency],
- -- | The version of the Cabal spec that this package description uses.
- -- For historical reasons this is specified with a version range but
- -- only ranges of the form @>= v@ make sense. We are in the process of
- -- transitioning to specifying just a single version, not a range.
- specVersionRaw :: Either Version VersionRange,
- buildType :: Maybe BuildType,
- -- components
- library :: Maybe Library,
- executables :: [Executable],
- testSuites :: [TestSuite],
- benchmarks :: [Benchmark],
- dataFiles :: [FilePath],
- dataDir :: FilePath,
- extraSrcFiles :: [FilePath],
- extraTmpFiles :: [FilePath]
- }
- deriving (Show, Read, Eq)
-
-instance Package PackageDescription where
- packageId = package
-
--- | The version of the Cabal spec that this package should be interpreted
--- against.
---
--- Historically we used a version range but we are switching to using a single
--- version. Currently we accept either. This function converts into a single
--- version by ignoring upper bounds in the version range.
---
-specVersion :: PackageDescription -> Version
-specVersion pkg = case specVersionRaw pkg of
- Left version -> version
- Right versionRange -> case asVersionIntervals versionRange of
- [] -> Version [0] []
- ((LowerBound version _, _):_) -> version
-
--- | The range of versions of the Cabal tools that this package is intended to
--- work with.
---
--- This function is deprecated and should not be used for new purposes, only to
--- support old packages that rely on the old interpretation.
---
-descCabalVersion :: PackageDescription -> VersionRange
-descCabalVersion pkg = case specVersionRaw pkg of
- Left version -> orLaterVersion version
- Right versionRange -> versionRange
-{-# DEPRECATED descCabalVersion "Use specVersion instead" #-}
-
-emptyPackageDescription :: PackageDescription
-emptyPackageDescription
- = PackageDescription {
- package = PackageIdentifier (PackageName "")
- (Version [] []),
- license = AllRightsReserved,
- licenseFile = "",
- specVersionRaw = Right anyVersion,
- buildType = Nothing,
- copyright = "",
- maintainer = "",
- author = "",
- stability = "",
- testedWith = [],
- buildDepends = [],
- homepage = "",
- pkgUrl = "",
- bugReports = "",
- sourceRepos = [],
- synopsis = "",
- description = "",
- category = "",
- customFieldsPD = [],
- library = Nothing,
- executables = [],
- testSuites = [],
- benchmarks = [],
- dataFiles = [],
- dataDir = "",
- extraSrcFiles = [],
- extraTmpFiles = []
- }
-
--- | The type of build system used by this package.
-data BuildType
- = Simple -- ^ calls @Distribution.Simple.defaultMain@
- | Configure -- ^ calls @Distribution.Simple.defaultMainWithHooks defaultUserHooks@,
- -- which invokes @configure@ to generate additional build
- -- information used by later phases.
- | Make -- ^ calls @Distribution.Make.defaultMain@
- | Custom -- ^ uses user-supplied @Setup.hs@ or @Setup.lhs@ (default)
- | UnknownBuildType String
- -- ^ a package that uses an unknown build type cannot actually
- -- be built. Doing it this way rather than just giving a
- -- parse error means we get better error messages and allows
- -- you to inspect the rest of the package description.
- deriving (Show, Read, Eq)
-
-knownBuildTypes :: [BuildType]
-knownBuildTypes = [Simple, Configure, Make, Custom]
-
-instance Text BuildType where
- disp (UnknownBuildType other) = Disp.text other
- disp other = Disp.text (show other)
-
- parse = do
- name <- Parse.munch1 Char.isAlphaNum
- return $ case name of
- "Simple" -> Simple
- "Configure" -> Configure
- "Custom" -> Custom
- "Make" -> Make
- _ -> UnknownBuildType name
-
--- ---------------------------------------------------------------------------
--- The Library type
-
-data Library = Library {
- exposedModules :: [ModuleName],
- libExposed :: Bool, -- ^ Is the lib to be exposed by default?
- libBuildInfo :: BuildInfo
- }
- deriving (Show, Eq, Read)
-
-instance Monoid Library where
- mempty = Library {
- exposedModules = mempty,
- libExposed = True,
- libBuildInfo = mempty
- }
- mappend a b = Library {
- exposedModules = combine exposedModules,
- libExposed = libExposed a && libExposed b, -- so False propagates
- libBuildInfo = combine libBuildInfo
- }
- where combine field = field a `mappend` field b
-
-emptyLibrary :: Library
-emptyLibrary = mempty
-
--- |does this package have any libraries?
-hasLibs :: PackageDescription -> Bool
-hasLibs p = maybe False (buildable . libBuildInfo) (library p)
-
--- |'Maybe' version of 'hasLibs'
-maybeHasLibs :: PackageDescription -> Maybe Library
-maybeHasLibs p =
- library p >>= \lib -> if buildable (libBuildInfo lib)
- then Just lib
- else Nothing
-
--- |If the package description has a library section, call the given
--- function with the library build info as argument.
-withLib :: PackageDescription -> (Library -> IO ()) -> IO ()
-withLib pkg_descr f =
- maybe (return ()) f (maybeHasLibs pkg_descr)
-
--- | Get all the module names from the library (exposed and internal modules)
-libModules :: Library -> [ModuleName]
-libModules lib = exposedModules lib
- ++ otherModules (libBuildInfo lib)
-
--- ---------------------------------------------------------------------------
--- The Executable type
-
-data Executable = Executable {
- exeName :: String,
- modulePath :: FilePath,
- buildInfo :: BuildInfo
- }
- deriving (Show, Read, Eq)
-
-instance Monoid Executable where
- mempty = Executable {
- exeName = mempty,
- modulePath = mempty,
- buildInfo = mempty
- }
- mappend a b = Executable{
- exeName = combine' exeName,
- modulePath = combine modulePath,
- buildInfo = combine buildInfo
- }
- where combine field = field a `mappend` field b
- combine' field = case (field a, field b) of
- ("","") -> ""
- ("", x) -> x
- (x, "") -> x
- (x, y) -> error $ "Ambiguous values for executable field: '"
- ++ x ++ "' and '" ++ y ++ "'"
-
-emptyExecutable :: Executable
-emptyExecutable = mempty
-
--- |does this package have any executables?
-hasExes :: PackageDescription -> Bool
-hasExes p = any (buildable . buildInfo) (executables p)
-
--- | Perform the action on each buildable 'Executable' in the package
--- description.
-withExe :: PackageDescription -> (Executable -> IO ()) -> IO ()
-withExe pkg_descr f =
- sequence_ [f exe | exe <- executables pkg_descr, buildable (buildInfo exe)]
-
--- | Get all the module names from an exe
-exeModules :: Executable -> [ModuleName]
-exeModules exe = otherModules (buildInfo exe)
-
--- ---------------------------------------------------------------------------
--- The TestSuite type
-
--- | A \"test-suite\" stanza in a cabal file.
---
-data TestSuite = TestSuite {
- testName :: String,
- testInterface :: TestSuiteInterface,
- testBuildInfo :: BuildInfo,
- testEnabled :: Bool
- -- TODO: By having a 'testEnabled' field in the PackageDescription, we
- -- are mixing build status information (i.e., arguments to 'configure')
- -- with static package description information. This is undesirable, but
- -- a better solution is waiting on the next overhaul to the
- -- GenericPackageDescription -> PackageDescription resolution process.
- }
- deriving (Show, Read, Eq)
-
--- | The test suite interfaces that are currently defined. Each test suite must
--- specify which interface it supports.
---
--- More interfaces may be defined in future, either new revisions or totally
--- new interfaces.
---
-data TestSuiteInterface =
-
- -- | Test interface \"exitcode-stdio-1.0\". The test-suite takes the form
- -- of an executable. It returns a zero exit code for success, non-zero for
- -- failure. The stdout and stderr channels may be logged. It takes no
- -- command line parameters and nothing on stdin.
- --
- TestSuiteExeV10 Version FilePath
-
- -- | Test interface \"detailed-0.9\". The test-suite takes the form of a
- -- library containing a designated module that exports \"tests :: [Test]\".
- --
- | TestSuiteLibV09 Version ModuleName
-
- -- | A test suite that does not conform to one of the above interfaces for
- -- the given reason (e.g. unknown test type).
- --
- | TestSuiteUnsupported TestType
- deriving (Eq, Read, Show)
-
-instance Monoid TestSuite where
- mempty = TestSuite {
- testName = mempty,
- testInterface = mempty,
- testBuildInfo = mempty,
- testEnabled = False
- }
-
- mappend a b = TestSuite {
- testName = combine' testName,
- testInterface = combine testInterface,
- testBuildInfo = combine testBuildInfo,
- testEnabled = if testEnabled a then True else testEnabled b
- }
- where combine field = field a `mappend` field b
- combine' f = case (f a, f b) of
- ("", x) -> x
- (x, "") -> x
- (x, y) -> error "Ambiguous values for test field: '"
- ++ x ++ "' and '" ++ y ++ "'"
-
-instance Monoid TestSuiteInterface where
- mempty = TestSuiteUnsupported (TestTypeUnknown mempty (Version [] []))
- mappend a (TestSuiteUnsupported _) = a
- mappend _ b = b
-
-emptyTestSuite :: TestSuite
-emptyTestSuite = mempty
-
--- | Does this package have any test suites?
-hasTests :: PackageDescription -> Bool
-hasTests = any (buildable . testBuildInfo) . testSuites
-
--- | Get all the enabled test suites from a package.
-enabledTests :: PackageDescription -> [TestSuite]
-enabledTests = filter testEnabled . testSuites
-
--- | Perform an action on each buildable 'TestSuite' in a package.
-withTest :: PackageDescription -> (TestSuite -> IO ()) -> IO ()
-withTest pkg_descr f =
- mapM_ f $ filter (buildable . testBuildInfo) $ enabledTests pkg_descr
-
--- | Get all the module names from a test suite.
-testModules :: TestSuite -> [ModuleName]
-testModules test = (case testInterface test of
- TestSuiteLibV09 _ m -> [m]
- _ -> [])
- ++ otherModules (testBuildInfo test)
-
--- | The \"test-type\" field in the test suite stanza.
---
-data TestType = TestTypeExe Version -- ^ \"type: exitcode-stdio-x.y\"
- | TestTypeLib Version -- ^ \"type: detailed-x.y\"
- | TestTypeUnknown String Version -- ^ Some unknown test type e.g. \"type: foo\"
- deriving (Show, Read, Eq)
-
-knownTestTypes :: [TestType]
-knownTestTypes = [ TestTypeExe (Version [1,0] [])
- , TestTypeLib (Version [0,9] []) ]
-
-instance Text TestType where
- disp (TestTypeExe ver) = text "exitcode-stdio-" <> disp ver
- disp (TestTypeLib ver) = text "detailed-" <> disp ver
- disp (TestTypeUnknown name ver) = text name <> char '-' <> disp ver
-
- parse = do
- cs <- Parse.sepBy1 component (Parse.char '-')
- _ <- Parse.char '-'
- ver <- parse
- let name = concat (intersperse "-" cs)
- return $! case lowercase name of
- "exitcode-stdio" -> TestTypeExe ver
- "detailed" -> TestTypeLib ver
- _ -> TestTypeUnknown name ver
-
- where
- component = do
- cs <- Parse.munch1 Char.isAlphaNum
- if all Char.isDigit cs then Parse.pfail else return cs
- -- each component must contain an alphabetic character, to avoid
- -- ambiguity in identifiers like foo-1 (the 1 is the version number).
-
-testType :: TestSuite -> TestType
-testType test = case testInterface test of
- TestSuiteExeV10 ver _ -> TestTypeExe ver
- TestSuiteLibV09 ver _ -> TestTypeLib ver
- TestSuiteUnsupported testtype -> testtype
-
--- ---------------------------------------------------------------------------
--- The 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.
-data BuildInfo = BuildInfo {
- buildable :: Bool, -- ^ component is buildable here
- buildTools :: [Dependency], -- ^ tools needed to build this bit
- cppOptions :: [String], -- ^ options for pre-processing Haskell code
- ccOptions :: [String], -- ^ options for C compiler
- ldOptions :: [String], -- ^ options for linker
- pkgconfigDepends :: [Dependency], -- ^ pkg-config packages that are used
- frameworks :: [String], -- ^support frameworks for Mac OS X
- cSources :: [FilePath],
- hsSourceDirs :: [FilePath], -- ^ where to look for the haskell module hierarchy
- otherModules :: [ModuleName], -- ^ non-exposed or non-main modules
-
- defaultLanguage :: Maybe Language,-- ^ language used when not explicitly specified
- otherLanguages :: [Language], -- ^ other languages used within the package
- defaultExtensions :: [Extension], -- ^ language extensions used by all modules
- otherExtensions :: [Extension], -- ^ other language extensions used within the package
- oldExtensions :: [Extension], -- ^ the old extensions field, treated same as 'defaultExtensions'
-
- extraLibs :: [String], -- ^ what libraries to link with when compiling a program that uses your package
- extraLibDirs :: [String],
- includeDirs :: [FilePath], -- ^directories to find .h files
- includes :: [FilePath], -- ^ The .h files to be found in includeDirs
- installIncludes :: [FilePath], -- ^ .h files to install with the package
- options :: [(CompilerFlavor,[String])],
- ghcProfOptions :: [String],
- ghcSharedOptions :: [String],
- customFieldsBI :: [(String,String)], -- ^Custom fields starting
- -- with x-, stored in a
- -- simple assoc-list.
- targetBuildDepends :: [Dependency] -- ^ Dependencies specific to a library or executable target
- }
- deriving (Show,Read,Eq)
-
-instance Monoid BuildInfo where
- mempty = BuildInfo {
- buildable = True,
- buildTools = [],
- cppOptions = [],
- ccOptions = [],
- ldOptions = [],
- pkgconfigDepends = [],
- frameworks = [],
- cSources = [],
- hsSourceDirs = [],
- otherModules = [],
- defaultLanguage = Nothing,
- otherLanguages = [],
- defaultExtensions = [],
- otherExtensions = [],
- oldExtensions = [],
- extraLibs = [],
- extraLibDirs = [],
- includeDirs = [],
- includes = [],
- installIncludes = [],
- options = [],
- ghcProfOptions = [],
- ghcSharedOptions = [],
- customFieldsBI = [],
- targetBuildDepends = []
- }
- mappend a b = BuildInfo {
- buildable = buildable a && buildable b,
- buildTools = combine buildTools,
- cppOptions = combine cppOptions,
- ccOptions = combine ccOptions,
- ldOptions = combine ldOptions,
- pkgconfigDepends = combine pkgconfigDepends,
- frameworks = combineNub frameworks,
- cSources = combineNub cSources,
- hsSourceDirs = combineNub hsSourceDirs,
- otherModules = combineNub otherModules,
- defaultLanguage = combineMby defaultLanguage,
- otherLanguages = combineNub otherLanguages,
- defaultExtensions = combineNub defaultExtensions,
- otherExtensions = combineNub otherExtensions,
- oldExtensions = combineNub oldExtensions,
- extraLibs = combine extraLibs,
- extraLibDirs = combineNub extraLibDirs,
- includeDirs = combineNub includeDirs,
- includes = combineNub includes,
- installIncludes = combineNub installIncludes,
- options = combine options,
- ghcProfOptions = combine ghcProfOptions,
- ghcSharedOptions = combine ghcSharedOptions,
- customFieldsBI = combine customFieldsBI,
- targetBuildDepends = combineNub targetBuildDepends
- }
- where
- combine field = field a `mappend` field b
- combineNub field = nub (combine field)
- combineMby field = field b `mplus` field a
-
-emptyBuildInfo :: BuildInfo
-emptyBuildInfo = mempty
-
--- | The 'BuildInfo' for the library (if there is one and it's buildable), and
--- all buildable executables, test suites and benchmarks. Useful for gathering
--- dependencies.
-allBuildInfo :: PackageDescription -> [BuildInfo]
-allBuildInfo pkg_descr = [ bi | Just lib <- [library pkg_descr]
- , let bi = libBuildInfo lib
- , buildable bi ]
- ++ [ bi | exe <- executables pkg_descr
- , let bi = buildInfo exe
- , buildable bi ]
- ++ [ bi | tst <- testSuites pkg_descr
- , let bi = testBuildInfo tst
- , buildable bi
- , testEnabled tst ]
- ++ [ 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
-
--- | The 'Language's used by this component
---
-allLanguages :: BuildInfo -> [Language]
-allLanguages bi = maybeToList (defaultLanguage bi)
- ++ otherLanguages bi
-
--- | The 'Extension's that are used somewhere by this component
---
-allExtensions :: BuildInfo -> [Extension]
-allExtensions bi = usedExtensions bi
- ++ otherExtensions bi
-
--- | The 'Extensions' that are used by all modules in this component
---
-usedExtensions :: BuildInfo -> [Extension]
-usedExtensions bi = oldExtensions bi
- ++ defaultExtensions bi
-
-type HookedBuildInfo = (Maybe BuildInfo, [(String, BuildInfo)])
-
-emptyHookedBuildInfo :: HookedBuildInfo
-emptyHookedBuildInfo = (Nothing, [])
-
--- |Select options for a particular Haskell compiler.
-hcOptions :: CompilerFlavor -> BuildInfo -> [String]
-hcOptions hc bi = [ opt | (hc',opts) <- options bi
- , hc' == hc
- , opt <- opts ]
-
--- ------------------------------------------------------------
--- * Source repos
--- ------------------------------------------------------------
-
--- | Information about the source revision control system for a package.
---
--- When specifying a repo it is useful to know the meaning or intention of the
--- information as doing so enables automation. There are two obvious common
--- purposes: one is to find the repo for the latest development version, the
--- other is to find the repo for this specific release. The 'ReopKind'
--- specifies which one we mean (or another custom one).
---
--- A package can specify one or the other kind or both. Most will specify just
--- a head repo but some may want to specify a repo to reconstruct the sources
--- for this package release.
---
--- The required information is the 'RepoType' which tells us if it's using
--- 'Darcs', 'Git' for example. The 'repoLocation' and other details are
--- interpreted according to the repo type.
---
-data SourceRepo = SourceRepo {
- -- | The kind of repo. This field is required.
- repoKind :: RepoKind,
-
- -- | The type of the source repository system for this repo, eg 'Darcs' or
- -- 'Git'. This field is required.
- repoType :: Maybe RepoType,
-
- -- | The location of the repository. For most 'RepoType's this is a URL.
- -- This field is required.
- repoLocation :: Maybe String,
-
- -- | 'CVS' can put multiple \"modules\" on one server and requires a
- -- module name in addition to the location to identify a particular repo.
- -- Logically this is part of the location but unfortunately has to be
- -- specified separately. This field is required for the 'CVS' 'RepoType' and
- -- should not be given otherwise.
- repoModule :: Maybe String,
-
- -- | The name or identifier of the branch, if any. Many source control
- -- systems have the notion of multiple branches in a repo that exist in the
- -- same location. For example 'Git' and 'CVS' use this while systems like
- -- 'Darcs' use different locations for different branches. This field is
- -- optional but should be used if necessary to identify the sources,
- -- especially for the 'RepoThis' repo kind.
- repoBranch :: Maybe String,
-
- -- | The tag identify a particular state of the repository. This should be
- -- given for the 'RepoThis' repo kind and not for 'RepoHead' kind.
- --
- repoTag :: Maybe String,
-
- -- | Some repositories contain multiple projects in different subdirectories
- -- This field specifies the subdirectory where this packages sources can be
- -- found, eg the subdirectory containing the @.cabal@ file. It is interpreted
- -- relative to the root of the repository. This field is optional. If not
- -- given the default is \".\" ie no subdirectory.
- repoSubdir :: Maybe FilePath
-}
- deriving (Eq, Read, Show)
-
--- | What this repo info is for, what it represents.
---
-data RepoKind =
- -- | The repository for the \"head\" or development version of the project.
- -- This repo is where we should track the latest development activity or
- -- the usual repo people should get to contribute patches.
- RepoHead
-
- -- | The repository containing the sources for this exact package version
- -- or release. For this kind of repo a tag should be given to give enough
- -- information to re-create the exact sources.
- | RepoThis
-
- | RepoKindUnknown String
- deriving (Eq, Ord, Read, Show)
-
--- | An enumeration of common source control systems. The fields used in the
--- 'SourceRepo' depend on the type of repo. The tools and methods used to
--- obtain and track the repo depend on the repo type.
---
-data RepoType = Darcs | Git | SVN | CVS
- | Mercurial | GnuArch | Bazaar | Monotone
- | OtherRepoType String
- deriving (Eq, Ord, Read, Show)
-
-knownRepoTypes :: [RepoType]
-knownRepoTypes = [Darcs, Git, SVN, CVS
- ,Mercurial, GnuArch, Bazaar, Monotone]
-
-repoTypeAliases :: RepoType -> [String]
-repoTypeAliases Bazaar = ["bzr"]
-repoTypeAliases Mercurial = ["hg"]
-repoTypeAliases GnuArch = ["arch"]
-repoTypeAliases _ = []
-
-instance Text RepoKind where
- disp RepoHead = Disp.text "head"
- disp RepoThis = Disp.text "this"
- disp (RepoKindUnknown other) = Disp.text other
-
- parse = do
- name <- ident
- return $ case lowercase name of
- "head" -> RepoHead
- "this" -> RepoThis
- _ -> RepoKindUnknown name
-
-instance Text RepoType where
- disp (OtherRepoType other) = Disp.text other
- disp other = Disp.text (lowercase (show other))
- parse = fmap classifyRepoType ident
-
-classifyRepoType :: String -> RepoType
-classifyRepoType s =
- case lookup (lowercase s) repoTypeMap of
- Just repoType' -> repoType'
- Nothing -> OtherRepoType s
- where
- repoTypeMap = [ (name, repoType')
- | repoType' <- knownRepoTypes
- , name <- display repoType' : repoTypeAliases repoType' ]
-
-ident :: Parse.ReadP r String
-ident = Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-')
-
-lowercase :: String -> String
-lowercase = map Char.toLower
-
--- ------------------------------------------------------------
--- * Utils
--- ------------------------------------------------------------
-
-updatePackageDescription :: HookedBuildInfo -> PackageDescription -> PackageDescription
-updatePackageDescription (mb_lib_bi, exe_bi) p
- = p{ executables = updateExecutables exe_bi (executables p)
- , library = updateLibrary mb_lib_bi (library p)
- }
- where
- updateLibrary :: Maybe BuildInfo -> Maybe Library -> Maybe Library
- updateLibrary (Just bi) (Just lib) = Just (lib{libBuildInfo = bi `mappend` libBuildInfo lib})
- updateLibrary Nothing mb_lib = mb_lib
- updateLibrary (Just _) Nothing = Nothing
-
- updateExecutables :: [(String, BuildInfo)] -- ^[(exeName, new buildinfo)]
- -> [Executable] -- ^list of executables to update
- -> [Executable] -- ^list with exeNames updated
- updateExecutables exe_bi' executables' = foldr updateExecutable executables' exe_bi'
-
- updateExecutable :: (String, BuildInfo) -- ^(exeName, new buildinfo)
- -> [Executable] -- ^list of executables to update
- -> [Executable] -- ^libst with exeName updated
- updateExecutable _ [] = []
- updateExecutable exe_bi'@(name,bi) (exe:exes)
- | exeName exe == name = exe{buildInfo = bi `mappend` buildInfo exe} : exes
- | otherwise = exe : updateExecutable exe_bi' exes
-
--- ---------------------------------------------------------------------------
--- The GenericPackageDescription type
-
-data GenericPackageDescription =
- GenericPackageDescription {
- packageDescription :: PackageDescription,
- genPackageFlags :: [Flag],
- condLibrary :: Maybe (CondTree ConfVar [Dependency] Library),
- condExecutables :: [(String, CondTree ConfVar [Dependency] Executable)],
- condTestSuites :: [(String, CondTree ConfVar [Dependency] TestSuite)],
- condBenchmarks :: [(String, CondTree ConfVar [Dependency] Benchmark)]
- }
- deriving (Show, Eq, Typeable)
-
-instance Package GenericPackageDescription where
- packageId = packageId . packageDescription
-
---TODO: make PackageDescription an instance of Text.
-
--- | A flag can represent a feature to be included, or a way of linking
--- a target against its dependencies, or in fact whatever you can think of.
-data Flag = MkFlag
- { flagName :: FlagName
- , flagDescription :: String
- , flagDefault :: Bool
- , flagManual :: Bool
- }
- deriving (Show, Eq)
-
--- | A 'FlagName' is the name of a user-defined configuration flag
-newtype FlagName = FlagName String
- deriving (Eq, Ord, Show, Read)
-
--- | A 'FlagAssignment' is a total or partial mapping of 'FlagName's to
--- 'Bool' flag values. It represents the flags chosen by the user or
--- discovered during configuration. For example @--flags=foo --flags=-bar@
--- becomes @[("foo", True), ("bar", False)]@
---
-type FlagAssignment = [(FlagName, Bool)]
-
--- | A @ConfVar@ represents the variable type used.
-data ConfVar = OS OS
- | Arch Arch
- | Flag FlagName
- | Impl CompilerFlavor VersionRange
- deriving (Eq, Show)
-
---instance Text ConfVar where
--- disp (OS os) = "os(" ++ display os ++ ")"
--- disp (Arch arch) = "arch(" ++ display arch ++ ")"
--- disp (Flag (ConfFlag f)) = "flag(" ++ f ++ ")"
--- disp (Impl c v) = "impl(" ++ display c
--- ++ " " ++ display v ++ ")"
-
--- | A boolean expression parameterized over the variable type used.
-data Condition c = Var c
- | Lit Bool
- | CNot (Condition c)
- | COr (Condition c) (Condition c)
- | CAnd (Condition c) (Condition c)
- deriving (Show, Eq)
-
---instance Text c => Text (Condition c) where
--- disp (Var x) = text (show x)
--- disp (Lit b) = text (show b)
--- disp (CNot c) = char '!' <> parens (ppCond c)
--- disp (COr c1 c2) = parens $ sep [ppCond c1, text "||" <+> ppCond c2]
--- disp (CAnd c1 c2) = parens $ sep [ppCond c1, text "&&" <+> ppCond c2]
-
-data CondTree v c a = CondNode
- { condTreeData :: a
- , condTreeConstraints :: c
- , condTreeComponents :: [( Condition v
- , CondTree v c a
- , Maybe (CondTree v c a))]
- }
- deriving (Show, Eq)
-
---instance (Text v, Text c) => Text (CondTree v c a) where
--- disp (CondNode _dat cs ifs) =
--- (text "build-depends: " <+>
--- disp cs)
--- $+$
--- (vcat $ map ppIf ifs)
--- where
--- ppIf (c,thenTree,mElseTree) =
--- ((text "if" <+> ppCond c <> colon) $$
--- nest 2 (ppCondTree thenTree disp))
--- $+$ (maybe empty (\t -> text "else: " $$ nest 2 (ppCondTree t disp))
--- mElseTree)
diff --git a/cabal/Cabal/Distribution/PackageDescription/Check.hs b/cabal/Cabal/Distribution/PackageDescription/Check.hs
deleted file mode 100644
index 56afa83..0000000
--- a/cabal/Cabal/Distribution/PackageDescription/Check.hs
+++ /dev/null
@@ -1,1495 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Distribution.PackageDescription.Check
--- Copyright : Lennart Kolmodin 2008
---
--- Maintainer : cabal-devel@haskell.org
--- Portability : portable
---
--- This has code for checking for various problems in packages. There is one
--- set of checks that just looks at a 'PackageDescription' in isolation and
--- another set of checks that also looks at files in the package. Some of the
--- checks are basic sanity checks, others are portability standards that we'd
--- like to encourage. There is a 'PackageCheck' type that distinguishes the
--- different kinds of check so we can see which ones are appropriate to report
--- in different situations. This code gets uses when configuring a package when
--- we consider only basic problems. The higher standard is uses when when
--- preparing a source tarball and by hackage when uploading new packages. The
--- reason for this is that we want to hold packages that are expected to be
--- distributed to a higher standard than packages that are only ever expected
--- to be used on the author's own environment.
-
-{- All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
- * Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
- * Redistributions in binary form must reproduce the above
- copyright notice, this list of conditions and the following
- disclaimer in the documentation and/or other materials provided
- with the distribution.
-
- * Neither the name of Isaac Jones nor the names of other
- contributors may be used to endorse or promote products derived
- from this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
-
-module Distribution.PackageDescription.Check (
- -- * Package Checking
- PackageCheck(..),
- checkPackage,
- checkConfiguredPackage,
-
- -- ** Checking package contents
- checkPackageFiles,
- checkPackageContent,
- CheckPackageContentOps(..),
- checkPackageFileNames,
- ) where
-
-import Data.Maybe
- ( isNothing, isJust, catMaybes, maybeToList, fromMaybe )
-import Data.List (sort, group, isPrefixOf, nub, find)
-import Control.Monad
- ( filterM, liftM )
-import qualified System.Directory as System
- ( doesFileExist, doesDirectoryExist )
-
-import Distribution.Package ( pkgName )
-import Distribution.PackageDescription
-import Distribution.PackageDescription.Configuration
- ( flattenPackageDescription, finalizePackageDescription )
-import Distribution.Compiler
- ( CompilerFlavor(..), buildCompilerFlavor, CompilerId(..) )
-import Distribution.System
- ( OS(..), Arch(..), buildPlatform )
-import Distribution.License
- ( License(..), knownLicenses )
-import Distribution.Simple.Utils
- ( cabalVersion, intercalate, parseFileGlob, FileGlob(..), lowercase )
-
-import Distribution.Version
- ( Version(..)
- , VersionRange(..), foldVersionRange'
- , anyVersion, noVersion, thisVersion, laterVersion, earlierVersion
- , orLaterVersion, orEarlierVersion
- , unionVersionRanges, intersectVersionRanges
- , asVersionIntervals, UpperBound(..), isNoVersion )
-import Distribution.Package
- ( PackageName(PackageName), packageName, packageVersion
- , Dependency(..) )
-
-import Distribution.Text
- ( display, disp )
-import qualified Text.PrettyPrint as Disp
-import Text.PrettyPrint ((<>), (<+>))
-
-import qualified Language.Haskell.Extension as Extension (deprecatedExtensions)
-import Language.Haskell.Extension
- ( Language(UnknownLanguage), knownLanguages, Extension(..), KnownExtension(..) )
-import System.FilePath
- ( (</>), takeExtension, isRelative, isAbsolute
- , splitDirectories, splitPath )
-import System.FilePath.Windows as FilePath.Windows
- ( isValid )
-
--- | Results of some kind of failed package check.
---
--- There are a range of severities, from merely dubious to totally insane.
--- All of them come with a human readable explanation. In future we may augment
--- them with more machine readable explanations, for example to help an IDE
--- suggest automatic corrections.
---
-data PackageCheck =
-
- -- | This package description is no good. There's no way it's going to
- -- build sensibly. This should give an error at configure time.
- PackageBuildImpossible { explanation :: String }
-
- -- | A problem that is likely to affect building the package, or an
- -- issue that we'd like every package author to be aware of, even if
- -- the package is never distributed.
- | PackageBuildWarning { explanation :: String }
-
- -- | An issue that might not be a problem for the package author but
- -- might be annoying or determental when the package is distributed to
- -- users. We should encourage distributed packages to be free from these
- -- issues, but occasionally there are justifiable reasons so we cannot
- -- ban them entirely.
- | PackageDistSuspicious { explanation :: String }
-
- -- | An issue that is ok in the author's environment but is almost
- -- certain to be a portability problem for other environments. We can
- -- quite legitimately refuse to publicly distribute packages with these
- -- problems.
- | PackageDistInexcusable { explanation :: String }
-
-instance Show PackageCheck where
- show notice = explanation notice
-
-check :: Bool -> PackageCheck -> Maybe PackageCheck
-check False _ = Nothing
-check True pc = Just pc
-
--- ------------------------------------------------------------
--- * Standard checks
--- ------------------------------------------------------------
-
--- | Check for common mistakes and problems in package descriptions.
---
--- This is the standard collection of checks covering all apsects except
--- for checks that require looking at files within the package. For those
--- see 'checkPackageFiles'.
---
--- It requires the 'GenericPackageDescription' and optionally a particular
--- configuration of that package. If you pass 'Nothing' then we just check
--- a version of the generic description using 'flattenPackageDescription'.
---
-checkPackage :: GenericPackageDescription
- -> Maybe PackageDescription
- -> [PackageCheck]
-checkPackage gpkg mpkg =
- checkConfiguredPackage pkg
- ++ checkConditionals gpkg
- ++ checkPackageVersions gpkg
- where
- pkg = fromMaybe (flattenPackageDescription gpkg) mpkg
-
---TODO: make this variant go away
--- we should alwaws know the GenericPackageDescription
-checkConfiguredPackage :: PackageDescription -> [PackageCheck]
-checkConfiguredPackage pkg =
- checkSanity pkg
- ++ checkFields pkg
- ++ checkLicense pkg
- ++ checkSourceRepos pkg
- ++ checkGhcOptions pkg
- ++ checkCCOptions pkg
- ++ checkCPPOptions pkg
- ++ checkPaths pkg
- ++ checkCabalVersion pkg
-
-
--- ------------------------------------------------------------
--- * Basic sanity checks
--- ------------------------------------------------------------
-
--- | Check that this package description is sane.
---
-checkSanity :: PackageDescription -> [PackageCheck]
-checkSanity pkg =
- catMaybes [
-
- check (null . (\(PackageName n) -> n) . packageName $ pkg) $
- PackageBuildImpossible "No 'name' field."
-
- , check (null . versionBranch . packageVersion $ pkg) $
- PackageBuildImpossible "No 'version' field."
-
- , check (null (executables pkg) && isNothing (library pkg)) $
- PackageBuildImpossible
- "No executables and no library found. Nothing to do."
-
- , check (not (null 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 [
-
- check (specVersion pkg > cabalVersion) $
- PackageBuildImpossible $
- "This package description follows version "
- ++ display (specVersion pkg) ++ " of the Cabal specification. This "
- ++ "tool only supports up to version " ++ display cabalVersion ++ "."
- ]
- where
- exeNames = map exeName $ executables pkg
- testNames = map testName $ testSuites pkg
- bmNames = map benchmarkName $ benchmarks pkg
- duplicateNames = dups $ exeNames ++ testNames ++ bmNames
-
-checkLibrary :: Library -> [PackageCheck]
-checkLibrary lib =
- catMaybes [
-
- check (not (null moduleDuplicates)) $
- PackageBuildWarning $
- "Duplicate modules in library: "
- ++ commaSep (map display moduleDuplicates)
- ]
-
- where
- moduleDuplicates = dups (libModules lib)
-
-checkExecutable :: Executable -> [PackageCheck]
-checkExecutable exe =
- catMaybes [
-
- check (null (modulePath exe)) $
- PackageBuildImpossible $
- "No 'Main-Is' field found for executable " ++ exeName exe
-
- , check (not (null (modulePath exe))
- && takeExtension (modulePath exe) `notElem` [".hs", ".lhs"]) $
- PackageBuildImpossible $
- "The 'Main-Is' field must specify a '.hs' or '.lhs' file "
- ++ "(even if it is generated by a preprocessor)."
-
- , check (not (null moduleDuplicates)) $
- PackageBuildWarning $
- "Duplicate modules in executable '" ++ exeName exe ++ "': "
- ++ commaSep (map display moduleDuplicates)
- ]
- where
- moduleDuplicates = dups (exeModules exe)
-
-checkTestSuite :: PackageDescription -> TestSuite -> [PackageCheck]
-checkTestSuite pkg test =
- catMaybes [
-
- case testInterface test of
- TestSuiteUnsupported tt@(TestTypeUnknown _ _) -> Just $
- PackageBuildWarning $
- quote (display tt) ++ " is not a known type of test suite. "
- ++ "The known test suite types are: "
- ++ commaSep (map display knownTestTypes)
-
- TestSuiteUnsupported tt -> Just $
- PackageBuildWarning $
- quote (display tt) ++ " is not a supported test suite version. "
- ++ "The known test suite types are: "
- ++ commaSep (map display knownTestTypes)
- _ -> Nothing
-
- , check (not $ null moduleDuplicates) $
- PackageBuildWarning $
- "Duplicate modules in test suite '" ++ testName test ++ "': "
- ++ commaSep (map display moduleDuplicates)
-
- , check mainIsWrongExt $
- PackageBuildImpossible $
- "The 'main-is' field must specify a '.hs' or '.lhs' file "
- ++ "(even if it is generated by a preprocessor)."
-
- -- 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
- ++ " has the same name as the package."
- ]
- where
- moduleDuplicates = dups $ testModules test
-
- mainIsWrongExt = case testInterface test of
- TestSuiteExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"]
- _ -> False
-
- 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
--- ------------------------------------------------------------
-
-checkFields :: PackageDescription -> [PackageCheck]
-checkFields pkg =
- catMaybes [
-
- check (not . FilePath.Windows.isValid . display . packageName $ pkg) $
- PackageDistInexcusable $
- "Unfortunately, the package name '" ++ display (packageName pkg)
- ++ "' is one of the reserved system file names on Windows. Many tools "
- ++ "need to convert package names to file names so using this name "
- ++ "would cause problems."
-
- , check (isNothing (buildType pkg)) $
- PackageBuildWarning $
- "No 'build-type' specified. If you do not need a custom Setup.hs or "
- ++ "./configure script then use 'build-type: Simple'."
-
- , case buildType pkg of
- Just (UnknownBuildType unknown) -> Just $
- PackageBuildWarning $
- quote unknown ++ " is not a known 'build-type'. "
- ++ "The known build types are: "
- ++ commaSep (map display knownBuildTypes)
- _ -> Nothing
-
- , check (not (null unknownCompilers)) $
- PackageBuildWarning $
- "Unknown compiler " ++ commaSep (map quote unknownCompilers)
- ++ " in 'tested-with' field."
-
- , check (not (null unknownLanguages)) $
- PackageBuildWarning $
- "Unknown languages: " ++ commaSep unknownLanguages
-
- , check (not (null unknownExtensions)) $
- PackageBuildWarning $
- "Unknown extensions: " ++ commaSep unknownExtensions
-
- , check (not (null languagesUsedAsExtensions)) $
- PackageBuildWarning $
- "Languages listed as extensions: "
- ++ commaSep languagesUsedAsExtensions
- ++ ". Languages must be specified in either the 'default-language' "
- ++ " or the 'other-languages' field."
-
- , check (not (null deprecatedExtensions)) $
- PackageDistSuspicious $
- "Deprecated extensions: "
- ++ commaSep (map (quote . display . fst) deprecatedExtensions)
- ++ ". " ++ intercalate " "
- [ "Instead of '" ++ display ext
- ++ "' use '" ++ display replacement ++ "'."
- | (ext, Just replacement) <- deprecatedExtensions ]
-
- , check (null (category pkg)) $
- PackageDistSuspicious "No 'category' field."
-
- , check (null (maintainer pkg)) $
- PackageDistSuspicious "No 'maintainer' field."
-
- , check (null (synopsis pkg) && null (description pkg)) $
- PackageDistInexcusable $ "No 'synopsis' or 'description' field."
-
- , check (null (description pkg) && not (null (synopsis pkg))) $
- PackageDistSuspicious "No 'description' field."
-
- , check (null (synopsis pkg) && not (null (description pkg))) $
- PackageDistSuspicious "No 'synopsis' field."
-
- --TODO: recommend the bug reports url, author and homepage fields
- --TODO: recommend not using the stability field
- --TODO: recommend specifying a source repo
-
- , check (length (synopsis pkg) >= 80) $
- PackageDistSuspicious
- "The 'synopsis' field is rather long (max 80 chars is recommended)."
-
- -- check use of impossible constraints "tested-with: GHC== 6.10 && ==6.12"
- , check (not (null testedWithImpossibleRanges)) $
- PackageDistInexcusable $
- "Invalid 'tested-with' version range: "
- ++ commaSep (map display testedWithImpossibleRanges)
- ++ ". To indicate that you have tested a package with multiple "
- ++ "different versions of the same compiler use multiple entries, "
- ++ "for example 'tested-with: GHC==6.10.4, GHC==6.12.3' and not "
- ++ "'tested-with: GHC==6.10.4 && ==6.12.3'."
- ]
- where
- unknownCompilers = [ name | (OtherCompiler name, _) <- testedWith pkg ]
- unknownLanguages = [ name | bi <- allBuildInfo pkg
- , UnknownLanguage name <- allLanguages bi ]
- unknownExtensions = [ name | bi <- allBuildInfo pkg
- , UnknownExtension name <- allExtensions bi
- , name `notElem` map display knownLanguages ]
- deprecatedExtensions = nub $ catMaybes
- [ find ((==ext) . fst) Extension.deprecatedExtensions
- | bi <- allBuildInfo pkg
- , ext <- allExtensions bi ]
- languagesUsedAsExtensions =
- [ name | bi <- allBuildInfo pkg
- , UnknownExtension name <- allExtensions bi
- , name `elem` map display knownLanguages ]
-
- testedWithImpossibleRanges =
- [ Dependency (PackageName (display compiler)) vr
- | (compiler, vr) <- testedWith pkg
- , isNoVersion vr ]
-
-
-checkLicense :: PackageDescription -> [PackageCheck]
-checkLicense pkg =
- catMaybes [
-
- check (license pkg == AllRightsReserved) $
- PackageDistInexcusable
- "The 'license' field is missing or specified as AllRightsReserved."
-
- , case license pkg of
- UnknownLicense l -> Just $
- PackageBuildWarning $
- quote ("license: " ++ l) ++ " is not a recognised license. The "
- ++ "known licenses are: "
- ++ commaSep (map display knownLicenses)
- _ -> Nothing
-
- , check (license pkg == BSD4) $
- PackageDistSuspicious $
- "Using 'license: BSD4' is almost always a misunderstanding. 'BSD4' "
- ++ "refers to the old 4-clause BSD license with the advertising "
- ++ "clause. 'BSD3' refers the new 3-clause BSD license."
-
- , case unknownLicenseVersion (license pkg) of
- Just knownVersions -> Just $
- PackageDistSuspicious $
- "'license: " ++ display (license pkg) ++ "' is not a known "
- ++ "version of that license. The known versions are "
- ++ commaSep (map display knownVersions)
- ++ ". If this is not a mistake and you think it should be a known "
- ++ "version then please file a ticket."
- _ -> Nothing
-
- , check (license pkg `notElem` [AllRightsReserved, PublicDomain]
- -- AllRightsReserved and PublicDomain are not strictly
- -- licenses so don't need license files.
- && null (licenseFile pkg)) $
- PackageDistSuspicious "A 'license-file' is not specified."
- ]
- where
- unknownLicenseVersion (GPL (Just v))
- | v `notElem` knownVersions = Just knownVersions
- where knownVersions = [ v' | GPL (Just v') <- knownLicenses ]
- unknownLicenseVersion (LGPL (Just v))
- | v `notElem` knownVersions = Just knownVersions
- where knownVersions = [ v' | LGPL (Just v') <- knownLicenses ]
- unknownLicenseVersion (Apache (Just v))
- | v `notElem` knownVersions = Just knownVersions
- where knownVersions = [ v' | Apache (Just v') <- knownLicenses ]
- unknownLicenseVersion _ = Nothing
-
-checkSourceRepos :: PackageDescription -> [PackageCheck]
-checkSourceRepos pkg =
- catMaybes $ concat [[
-
- case repoKind repo of
- RepoKindUnknown kind -> Just $ PackageDistInexcusable $
- quote kind ++ " is not a recognised kind of source-repository. "
- ++ "The repo kind is usually 'head' or 'this'"
- _ -> Nothing
-
- , check (repoType repo == Nothing) $
- PackageDistInexcusable
- "The source-repository 'type' is a required field."
-
- , check (repoLocation repo == Nothing) $
- PackageDistInexcusable
- "The source-repository 'location' is a required field."
-
- , check (repoType repo == Just CVS && repoModule repo == Nothing) $
- PackageDistInexcusable
- "For a CVS source-repository, the 'module' is a required field."
-
- , check (repoKind repo == RepoThis && repoTag repo == Nothing) $
- PackageDistInexcusable $
- "For the 'this' kind of source-repository, the 'tag' is a required "
- ++ "field. It should specify the tag corresponding to this version "
- ++ "or release of the package."
-
- , check (maybe False System.FilePath.isAbsolute (repoSubdir repo)) $
- PackageDistInexcusable
- "The 'subdir' field of a source-repository must be a relative path."
- ]
- | repo <- sourceRepos pkg ]
-
---TODO: check location looks like a URL for some repo types.
-
-checkGhcOptions :: PackageDescription -> [PackageCheck]
-checkGhcOptions pkg =
- catMaybes [
-
- check has_WerrorWall $
- PackageDistInexcusable $
- "'ghc-options: -Wall -Werror' makes the package very easy to "
- ++ "break with future GHC versions because new GHC versions often "
- ++ "add new warnings. Use just 'ghc-options: -Wall' instead."
-
- , check (not has_WerrorWall && has_Werror) $
- PackageDistSuspicious $
- "'ghc-options: -Werror' makes the package easy to "
- ++ "break with future GHC versions because new GHC versions often "
- ++ "add new warnings."
-
- , checkFlags ["-fasm"] $
- PackageDistInexcusable $
- "'ghc-options: -fasm' is unnecessary and will not work on CPU "
- ++ "architectures other than x86, x86-64, ppc or sparc."
-
- , checkFlags ["-fvia-C"] $
- PackageDistSuspicious $
- "'ghc-options: -fvia-C' is usually unnecessary. If your package "
- ++ "needs -via-C for correctness rather than performance then it "
- ++ "is using the FFI incorrectly and will probably not work with GHC "
- ++ "6.10 or later."
-
- , checkFlags ["-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."
-
- , check (any ("-d" `isPrefixOf`) all_ghc_options) $
- PackageDistInexcusable $
- "'ghc-options: -d*' debug flags are not appropriate for a distributed package."
-
- , checkFlags ["-prof"] $
- PackageBuildWarning $
- "'ghc-options: -prof' is not necessary and will lead to problems "
- ++ "when used on a library. Use the configure flag "
- ++ "--enable-library-profiling and/or --enable-executable-profiling."
-
- , checkFlags ["-o"] $
- PackageBuildWarning $
- "'ghc-options: -o' is not needed. The output files are named automatically."
-
- , checkFlags ["-hide-package"] $
- PackageBuildWarning $
- "'ghc-options: -hide-package' is never needed. Cabal hides all packages."
-
- , checkFlags ["--make"] $
- PackageBuildWarning $
- "'ghc-options: --make' is never needed. Cabal uses this automatically."
-
- , checkFlags ["-main-is"] $
- PackageDistSuspicious $
- "'ghc-options: -main-is' is not portable."
-
- , checkFlags ["-O0", "-Onot"] $
- PackageDistSuspicious $
- "'ghc-options: -O0' is not needed. Use the --disable-optimization configure flag."
-
- , checkFlags [ "-O", "-O1"] $
- PackageDistInexcusable $
- "'ghc-options: -O' is not needed. Cabal automatically adds the '-O' flag. "
- ++ "Setting it yourself interferes with the --disable-optimization flag."
-
- , checkFlags ["-O2"] $
- PackageDistSuspicious $
- "'ghc-options: -O2' is rarely needed. Check that it is giving a real benefit "
- ++ "and not just imposing longer compile times on your users."
-
- , checkFlags ["-split-objs"] $
- PackageBuildWarning $
- "'ghc-options: -split-objs' is not needed. Use the --enable-split-objs configure flag."
-
- , checkFlags ["-optl-Wl,-s", "-optl-s"] $
- PackageDistInexcusable $
- "'ghc-options: -optl-Wl,-s' is not needed and is not portable to all"
- ++ " operating systems. Cabal 1.4 and later automatically strip"
- ++ " executables. Cabal also has a flag --disable-executable-stripping"
- ++ " which is necessary when building packages for some Linux"
- ++ " distributions and using '-optl-Wl,-s' prevents that from working."
-
- , checkFlags ["-fglasgow-exts"] $
- PackageDistSuspicious $
- "Instead of 'ghc-options: -fglasgow-exts' it is preferable to use the 'extensions' field."
-
- , check ("-threaded" `elem` lib_ghc_options) $
- PackageDistSuspicious $
- "'ghc-options: -threaded' has no effect for libraries. It should "
- ++ "only be used for executables."
-
- , checkAlternatives "ghc-options" "extensions"
- [ (flag, display extension) | flag <- all_ghc_options
- , Just extension <- [ghcExtension flag] ]
-
- , checkAlternatives "ghc-options" "extensions"
- [ (flag, extension) | flag@('-':'X':extension) <- all_ghc_options ]
-
- , checkAlternatives "ghc-options" "cpp-options" $
- [ (flag, flag) | flag@('-':'D':_) <- all_ghc_options ]
- ++ [ (flag, flag) | flag@('-':'U':_) <- all_ghc_options ]
-
- , checkAlternatives "ghc-options" "include-dirs"
- [ (flag, dir) | flag@('-':'I':dir) <- all_ghc_options ]
-
- , checkAlternatives "ghc-options" "extra-libraries"
- [ (flag, lib) | flag@('-':'l':lib) <- all_ghc_options ]
-
- , checkAlternatives "ghc-options" "extra-lib-dirs"
- [ (flag, dir) | flag@('-':'L':dir) <- all_ghc_options ]
- ]
-
- where
- has_WerrorWall = flip any ghc_options $ \opts ->
- "-Werror" `elem` opts
- && ("-Wall" `elem` opts || "-W" `elem` opts)
- has_Werror = any (\opts -> "-Werror" `elem` opts) ghc_options
-
- ghc_options = [ strs | bi <- allBuildInfo pkg
- , (GHC, strs) <- options bi ]
- all_ghc_options = concat ghc_options
- lib_ghc_options = maybe [] (hcOptions GHC . libBuildInfo) (library pkg)
-
- checkFlags :: [String] -> PackageCheck -> Maybe PackageCheck
- checkFlags flags = check (any (`elem` flags) all_ghc_options)
-
- ghcExtension ('-':'f':name) = case name of
- "allow-overlapping-instances" -> Just (EnableExtension OverlappingInstances)
- "no-allow-overlapping-instances" -> Just (DisableExtension OverlappingInstances)
- "th" -> Just (EnableExtension TemplateHaskell)
- "no-th" -> Just (DisableExtension TemplateHaskell)
- "ffi" -> Just (EnableExtension ForeignFunctionInterface)
- "no-ffi" -> Just (DisableExtension ForeignFunctionInterface)
- "fi" -> Just (EnableExtension ForeignFunctionInterface)
- "no-fi" -> Just (DisableExtension ForeignFunctionInterface)
- "monomorphism-restriction" -> Just (EnableExtension MonomorphismRestriction)
- "no-monomorphism-restriction" -> Just (DisableExtension MonomorphismRestriction)
- "mono-pat-binds" -> Just (EnableExtension MonoPatBinds)
- "no-mono-pat-binds" -> Just (DisableExtension MonoPatBinds)
- "allow-undecidable-instances" -> Just (EnableExtension UndecidableInstances)
- "no-allow-undecidable-instances" -> Just (DisableExtension UndecidableInstances)
- "allow-incoherent-instances" -> Just (EnableExtension IncoherentInstances)
- "no-allow-incoherent-instances" -> Just (DisableExtension IncoherentInstances)
- "arrows" -> Just (EnableExtension Arrows)
- "no-arrows" -> Just (DisableExtension Arrows)
- "generics" -> Just (EnableExtension Generics)
- "no-generics" -> Just (DisableExtension Generics)
- "implicit-prelude" -> Just (EnableExtension ImplicitPrelude)
- "no-implicit-prelude" -> Just (DisableExtension ImplicitPrelude)
- "implicit-params" -> Just (EnableExtension ImplicitParams)
- "no-implicit-params" -> Just (DisableExtension ImplicitParams)
- "bang-patterns" -> Just (EnableExtension BangPatterns)
- "no-bang-patterns" -> Just (DisableExtension BangPatterns)
- "scoped-type-variables" -> Just (EnableExtension ScopedTypeVariables)
- "no-scoped-type-variables" -> Just (DisableExtension ScopedTypeVariables)
- "extended-default-rules" -> Just (EnableExtension ExtendedDefaultRules)
- "no-extended-default-rules" -> Just (DisableExtension ExtendedDefaultRules)
- _ -> Nothing
- ghcExtension "-cpp" = Just (EnableExtension CPP)
- ghcExtension _ = Nothing
-
-checkCCOptions :: PackageDescription -> [PackageCheck]
-checkCCOptions pkg =
- catMaybes [
-
- checkAlternatives "cc-options" "include-dirs"
- [ (flag, dir) | flag@('-':'I':dir) <- all_ccOptions ]
-
- , checkAlternatives "cc-options" "extra-libraries"
- [ (flag, lib) | flag@('-':'l':lib) <- all_ccOptions ]
-
- , checkAlternatives "cc-options" "extra-lib-dirs"
- [ (flag, dir) | flag@('-':'L':dir) <- all_ccOptions ]
-
- , checkAlternatives "ld-options" "extra-libraries"
- [ (flag, lib) | flag@('-':'l':lib) <- all_ldOptions ]
-
- , checkAlternatives "ld-options" "extra-lib-dirs"
- [ (flag, dir) | flag@('-':'L':dir) <- all_ldOptions ]
-
- , checkCCFlags [ "-O", "-Os", "-O0", "-O1", "-O2", "-O3" ] $
- PackageDistSuspicious $
- "'cc-options: -O[n]' is generally not needed. When building with "
- ++ " optimisations Cabal automatically adds '-O2' for C code. "
- ++ "Setting it yourself interferes with the --disable-optimization "
- ++ "flag."
- ]
-
- where all_ccOptions = [ opts | bi <- allBuildInfo pkg
- , opts <- ccOptions bi ]
- all_ldOptions = [ opts | bi <- allBuildInfo pkg
- , opts <- ldOptions bi ]
-
- checkCCFlags :: [String] -> PackageCheck -> Maybe PackageCheck
- checkCCFlags flags = check (any (`elem` flags) all_ccOptions)
-
-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)) $
- PackageBuildWarning $
- "Instead of " ++ quote (badField ++ ": " ++ unwords badFlags)
- ++ " use " ++ quote (goodField ++ ": " ++ unwords goodFlags)
-
- where (badFlags, goodFlags) = unzip flags
-
-checkPaths :: PackageDescription -> [PackageCheck]
-checkPaths pkg =
- [ PackageBuildWarning $
- quote (kind ++ ": " ++ path)
- ++ " is a relative path outside of the source tree. "
- ++ "This will not work when generating a tarball with 'sdist'."
- | (path, kind) <- relPaths ++ absPaths
- , isOutsideTree path ]
- ++
- [ PackageDistInexcusable $
- quote (kind ++ ": " ++ path) ++ " is an absolute directory."
- | (path, kind) <- relPaths
- , isAbsolute path ]
- ++
- [ PackageDistInexcusable $
- quote (kind ++ ": " ++ path) ++ " points inside the 'dist' "
- ++ "directory. This is not reliable because the location of this "
- ++ "directory is configurable by the user (or package manager). In "
- ++ "addition the layout of the 'dist' directory is subject to change "
- ++ "in future versions of Cabal."
- | (path, kind) <- relPaths ++ absPaths
- , isInsideDist path ]
- ++
- [ PackageDistInexcusable $
- "The 'ghc-options' contains the path '" ++ path ++ "' which points "
- ++ "inside the 'dist' directory. This is not reliable because the "
- ++ "location of this directory is configurable by the user (or package "
- ++ "manager). In addition the layout of the 'dist' directory is subject "
- ++ "to change in future versions of Cabal."
- | bi <- allBuildInfo pkg
- , (GHC, flags) <- options bi
- , path <- flags
- , isInsideDist path ]
- where
- isOutsideTree path = case splitDirectories path of
- "..":_ -> True
- ".":"..":_ -> True
- _ -> False
- isInsideDist path = case map lowercase (splitDirectories path) of
- "dist" :_ -> True
- ".":"dist":_ -> True
- _ -> False
- -- paths that must be relative
- relPaths =
- [ (path, "extra-src-files") | path <- extraSrcFiles pkg ]
- ++ [ (path, "extra-tmp-files") | path <- extraTmpFiles pkg ]
- ++ [ (path, "data-files") | path <- dataFiles pkg ]
- ++ [ (path, "data-dir") | path <- [dataDir pkg]]
- ++ concat
- [ [ (path, "c-sources") | path <- cSources bi ]
- ++ [ (path, "install-includes") | path <- installIncludes bi ]
- ++ [ (path, "hs-source-dirs") | path <- hsSourceDirs bi ]
- | bi <- allBuildInfo pkg ]
- -- paths that are allowed to be absolute
- absPaths = concat
- [ [ (path, "includes") | path <- includes bi ]
- ++ [ (path, "include-dirs") | path <- includeDirs bi ]
- ++ [ (path, "extra-lib-dirs") | path <- extraLibDirs bi ]
- | bi <- allBuildInfo pkg ]
-
---TODO: check sets of paths that would be interpreted differently between unix
--- and windows, ie case-sensitive or insensitive. Things that might clash, or
--- conversely be distinguished.
-
---TODO: use the tar path checks on all the above paths
-
--- | Check that the package declares the version in the @\"cabal-version\"@
--- field correctly.
---
-checkCabalVersion :: PackageDescription -> [PackageCheck]
-checkCabalVersion pkg =
- catMaybes [
-
- -- check syntax of cabal-version field
- check (specVersion pkg >= Version [1,10] []
- && not simpleSpecVersionRangeSyntax) $
- PackageBuildWarning $
- "Packages relying on Cabal 1.10 or later must only specify a "
- ++ "version range of the form 'cabal-version: >= x.y'. Use "
- ++ "'cabal-version: >= " ++ display (specVersion pkg) ++ "'."
-
- -- check syntax of cabal-version field
- , check (specVersion pkg < Version [1,9] []
- && not simpleSpecVersionRangeSyntax) $
- PackageDistSuspicious $
- "It is recommended that the 'cabal-version' field only specify a "
- ++ "version range of the form '>= x.y'. Use "
- ++ "'cabal-version: >= " ++ display (specVersion pkg) ++ "'. "
- ++ "Tools based on Cabal 1.10 and later will ignore upper bounds."
-
- -- check syntax of cabal-version field
- , checkVersion [1,12] simpleSpecVersionSyntax $
- PackageBuildWarning $
- "With Cabal 1.10 or earlier, the 'cabal-version' field must use "
- ++ "range syntax rather than a simple version number. Use "
- ++ "'cabal-version: >= " ++ display (specVersion pkg) ++ "'."
-
- -- check use of test suite sections
- , checkVersion [1,8] (not (null $ testSuites pkg)) $
- PackageDistInexcusable $
- "The 'test-suite' section is new in Cabal 1.10. "
- ++ "Unfortunately it messes up the parser in older Cabal versions "
- ++ "so you must specify at least 'cabal-version: >= 1.8', but note "
- ++ "that only Cabal 1.10 and later can actually run such test suites."
-
- -- check use of default-language field
- -- note that we do not need to do an equivalent check for the
- -- other-language field since that one does not change behaviour
- , checkVersion [1,10] (any isJust (buildInfoField defaultLanguage)) $
- PackageBuildWarning $
- "To use the 'default-language' field the package needs to specify "
- ++ "at least 'cabal-version: >= 1.10'."
-
- , check (specVersion pkg >= Version [1,10] []
- && (any isNothing (buildInfoField defaultLanguage))) $
- PackageBuildWarning $
- "Packages using 'cabal-version: >= 1.10' must specify the "
- ++ "'default-language' field for each component (e.g. Haskell98 or "
- ++ "Haskell2010). If a component uses different languages in "
- ++ "different modules then list the other ones in the "
- ++ "'other-languages' field."
-
- -- check use of default-extensions field
- -- don't need to do the equivalent check for other-extensions
- , checkVersion [1,10] (any (not . null) (buildInfoField defaultExtensions)) $
- PackageBuildWarning $
- "To use the 'default-extensions' field the package needs to specify "
- ++ "at least 'cabal-version: >= 1.10'."
-
- -- check use of extensions field
- , check (specVersion pkg >= Version [1,10] []
- && (any (not . null) (buildInfoField oldExtensions))) $
- PackageBuildWarning $
- "For packages using 'cabal-version: >= 1.10' the 'extensions' "
- ++ "field is deprecated. The new 'default-extensions' field lists "
- ++ "extensions that are used in all modules in the component, while "
- ++ "the 'other-extensions' field lists extensions that are used in "
- ++ "some modules, e.g. via the {-# LANGUAGE #-} pragma."
-
- -- check use of "foo (>= 1.0 && < 1.4) || >=1.8 " version-range syntax
- , checkVersion [1,8] (not (null versionRangeExpressions)) $
- PackageDistInexcusable $
- "The package uses full version-range expressions "
- ++ "in a 'build-depends' field: "
- ++ commaSep (map displayRawDependency versionRangeExpressions)
- ++ ". To use this new syntax the package needs to specify at least "
- ++ "'cabal-version: >= 1.8'. Alternatively, if broader compatibility "
- ++ "is important, then convert to conjunctive normal form, and use "
- ++ "multiple 'build-depends:' lines, one conjunct per line."
-
- -- check use of "build-depends: foo == 1.*" syntax
- , checkVersion [1,6] (not (null depsUsingWildcardSyntax)) $
- PackageDistInexcusable $
- "The package uses wildcard syntax in the 'build-depends' field: "
- ++ commaSep (map display depsUsingWildcardSyntax)
- ++ ". To use this new syntax the package need to specify at least "
- ++ "'cabal-version: >= 1.6'. Alternatively, if broader compatability "
- ++ "is important then use: " ++ commaSep
- [ display (Dependency name (eliminateWildcardSyntax versionRange))
- | Dependency name versionRange <- depsUsingWildcardSyntax ]
-
- -- check use of "tested-with: GHC (>= 1.0 && < 1.4) || >=1.8 " syntax
- , checkVersion [1,8] (not (null testedWithVersionRangeExpressions)) $
- PackageDistInexcusable $
- "The package uses full version-range expressions "
- ++ "in a 'tested-with' field: "
- ++ commaSep (map displayRawDependency testedWithVersionRangeExpressions)
- ++ ". To use this new syntax the package needs to specify at least "
- ++ "'cabal-version: >= 1.8'."
-
- -- check use of "tested-with: GHC == 6.12.*" syntax
- , checkVersion [1,6] (not (null testedWithUsingWildcardSyntax)) $
- PackageDistInexcusable $
- "The package uses wildcard syntax in the 'tested-with' field: "
- ++ commaSep (map display testedWithUsingWildcardSyntax)
- ++ ". To use this new syntax the package need to specify at least "
- ++ "'cabal-version: >= 1.6'. Alternatively, if broader compatability "
- ++ "is important then use: " ++ commaSep
- [ display (Dependency name (eliminateWildcardSyntax versionRange))
- | Dependency name versionRange <- testedWithUsingWildcardSyntax ]
-
- -- check use of "data-files: data/*.txt" syntax
- , checkVersion [1,6] (not (null dataFilesUsingGlobSyntax)) $
- PackageDistInexcusable $
- "Using wildcards like "
- ++ commaSep (map quote $ take 3 dataFilesUsingGlobSyntax)
- ++ " in the 'data-files' field requires 'cabal-version: >= 1.6'. "
- ++ "Alternatively if you require compatability with earlier Cabal "
- ++ "versions then list all the files explicitly."
-
- -- check use of "extra-source-files: mk/*.in" syntax
- , checkVersion [1,6] (not (null extraSrcFilesUsingGlobSyntax)) $
- PackageDistInexcusable $
- "Using wildcards like "
- ++ commaSep (map quote $ take 3 extraSrcFilesUsingGlobSyntax)
- ++ " in the 'extra-source-files' field requires "
- ++ "'cabal-version: >= 1.6'. Alternatively if you require "
- ++ "compatability with earlier Cabal versions then list all the files "
- ++ "explicitly."
-
- -- check use of "source-repository" section
- , checkVersion [1,6] (not (null (sourceRepos pkg))) $
- PackageDistInexcusable $
- "The 'source-repository' section is new in Cabal 1.6. "
- ++ "Unfortunately it messes up the parser in earlier Cabal versions "
- ++ "so you need to specify 'cabal-version: >= 1.6'."
-
- -- check for new licenses
- , checkVersion [1,4] (license pkg `notElem` compatLicenses) $
- PackageDistInexcusable $
- "Unfortunately the license " ++ quote (display (license pkg))
- ++ " messes up the parser in earlier Cabal versions so you need to "
- ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require "
- ++ "compatability with earlier Cabal versions then use 'OtherLicense'."
-
- -- check for new language extensions
- , checkVersion [1,2,3] (not (null mentionedExtensionsThatNeedCabal12)) $
- PackageDistInexcusable $
- "Unfortunately the language extensions "
- ++ commaSep (map (quote . display) mentionedExtensionsThatNeedCabal12)
- ++ " break the parser in earlier Cabal versions so you need to "
- ++ "specify 'cabal-version: >= 1.2.3'. Alternatively if you require "
- ++ "compatability with earlier Cabal versions then you may be able to "
- ++ "use an equivalent compiler-specific flag."
-
- , checkVersion [1,4] (not (null mentionedExtensionsThatNeedCabal14)) $
- PackageDistInexcusable $
- "Unfortunately the language extensions "
- ++ commaSep (map (quote . display) mentionedExtensionsThatNeedCabal14)
- ++ " break the parser in earlier Cabal versions so you need to "
- ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require "
- ++ "compatability with earlier Cabal versions then you may be able to "
- ++ "use an equivalent compiler-specific flag."
- ]
- where
- -- Perform a check on packages that use a version of the spec less than
- -- the version given. This is for cases where a new Cabal version adds
- -- a new feature and we want to check that it is not used prior to that
- -- version.
- checkVersion :: [Int] -> Bool -> PackageCheck -> Maybe PackageCheck
- checkVersion ver cond pc
- | specVersion pkg >= Version ver [] = Nothing
- | otherwise = check cond pc
-
- buildInfoField field = map field (allBuildInfo pkg)
- dataFilesUsingGlobSyntax = filter usesGlobSyntax (dataFiles pkg)
- extraSrcFilesUsingGlobSyntax = filter usesGlobSyntax (extraSrcFiles pkg)
- usesGlobSyntax str = case parseFileGlob str of
- Just (FileGlob _ _) -> True
- _ -> False
-
- versionRangeExpressions =
- [ dep | dep@(Dependency _ vr) <- buildDepends pkg
- , usesNewVersionRangeSyntax vr ]
-
- testedWithVersionRangeExpressions =
- [ Dependency (PackageName (display compiler)) vr
- | (compiler, vr) <- testedWith pkg
- , usesNewVersionRangeSyntax vr ]
-
- simpleSpecVersionRangeSyntax =
- either (const True)
- (foldVersionRange'
- True
- (\_ -> False)
- (\_ -> False) (\_ -> False)
- (\_ -> True) -- >=
- (\_ -> False)
- (\_ _ -> False)
- (\_ _ -> False) (\_ _ -> False)
- id)
- (specVersionRaw pkg)
-
- -- is the cabal-version field a simple version number, rather than a range
- simpleSpecVersionSyntax =
- either (const True) (const False) (specVersionRaw pkg)
-
- usesNewVersionRangeSyntax :: VersionRange -> Bool
- usesNewVersionRangeSyntax =
- (> 2) -- uses the new syntax if depth is more than 2
- . foldVersionRange'
- (1 :: Int)
- (const 1)
- (const 1) (const 1)
- (const 1) (const 1)
- (const (const 1))
- (+) (+)
- (const 3) -- uses new ()'s syntax
-
- depsUsingWildcardSyntax = [ dep | dep@(Dependency _ vr) <- buildDepends pkg
- , usesWildcardSyntax vr ]
-
- testedWithUsingWildcardSyntax = [ Dependency (PackageName (display compiler)) vr
- | (compiler, vr) <- testedWith pkg
- , usesWildcardSyntax vr ]
-
- usesWildcardSyntax :: VersionRange -> Bool
- usesWildcardSyntax =
- foldVersionRange'
- False (const False)
- (const False) (const False)
- (const False) (const False)
- (\_ _ -> True) -- the wildcard case
- (||) (||) id
-
- eliminateWildcardSyntax =
- foldVersionRange'
- anyVersion thisVersion
- laterVersion earlierVersion
- orLaterVersion orEarlierVersion
- (\v v' -> intersectVersionRanges (orLaterVersion v) (earlierVersion v'))
- intersectVersionRanges unionVersionRanges id
-
- compatLicenses = [ GPL Nothing, LGPL Nothing, BSD3, BSD4
- , PublicDomain, AllRightsReserved, OtherLicense ]
-
- mentionedExtensions = [ ext | bi <- allBuildInfo pkg
- , ext <- allExtensions bi ]
- mentionedExtensionsThatNeedCabal12 =
- nub (filter (`elem` compatExtensionsExtra) mentionedExtensions)
-
- -- As of Cabal-1.4 we can add new extensions without worrying about
- -- breaking old versions of cabal.
- mentionedExtensionsThatNeedCabal14 =
- nub (filter (`notElem` compatExtensions) mentionedExtensions)
-
- -- The known extensions in Cabal-1.2.3
- compatExtensions =
- map EnableExtension
- [ OverlappingInstances, UndecidableInstances, IncoherentInstances
- , RecursiveDo, ParallelListComp, MultiParamTypeClasses
- , FunctionalDependencies, Rank2Types
- , RankNTypes, PolymorphicComponents, ExistentialQuantification
- , ScopedTypeVariables, ImplicitParams, FlexibleContexts
- , FlexibleInstances, EmptyDataDecls, CPP, BangPatterns
- , TypeSynonymInstances, TemplateHaskell, ForeignFunctionInterface
- , Arrows, Generics, NamedFieldPuns, PatternGuards
- , GeneralizedNewtypeDeriving, ExtensibleRecords, RestrictedTypeSynonyms
- , HereDocuments] ++
- map DisableExtension
- [MonomorphismRestriction, ImplicitPrelude] ++
- compatExtensionsExtra
-
- -- The extra known extensions in Cabal-1.2.3 vs Cabal-1.1.6
- -- (Cabal-1.1.6 came with ghc-6.6. Cabal-1.2 came with ghc-6.8)
- compatExtensionsExtra =
- map EnableExtension
- [ KindSignatures, MagicHash, TypeFamilies, StandaloneDeriving
- , UnicodeSyntax, PatternSignatures, UnliftedFFITypes, LiberalTypeSynonyms
- , TypeOperators, RecordWildCards, RecordPuns, DisambiguateRecordFields
- , OverloadedStrings, GADTs, RelaxedPolyRec
- , ExtendedDefaultRules, UnboxedTuples, DeriveDataTypeable
- , ConstrainedClassMethods
- ] ++
- map DisableExtension
- [MonoPatBinds]
-
--- | A variation on the normal 'Text' instance, shows any ()'s in the original
--- textual syntax. We need to show these otherwise it's confusing to users when
--- we complain of their presense but do not pretty print them!
---
-displayRawVersionRange :: VersionRange -> String
-displayRawVersionRange =
- Disp.render
- . fst
- . foldVersionRange' -- precedence:
- -- All the same as the usual pretty printer, except for the parens
- ( Disp.text "-any" , 0 :: Int)
- (\v -> (Disp.text "==" <> disp v , 0))
- (\v -> (Disp.char '>' <> disp v , 0))
- (\v -> (Disp.char '<' <> disp v , 0))
- (\v -> (Disp.text ">=" <> disp v , 0))
- (\v -> (Disp.text "<=" <> disp v , 0))
- (\v _ -> (Disp.text "==" <> dispWild v , 0))
- (\(r1, p1) (r2, p2) -> (punct 2 p1 r1 <+> Disp.text "||" <+> punct 2 p2 r2 , 2))
- (\(r1, p1) (r2, p2) -> (punct 1 p1 r1 <+> Disp.text "&&" <+> punct 1 p2 r2 , 1))
- (\(r, _ ) -> (Disp.parens r, 0)) -- parens
-
- where
- dispWild (Version b _) =
- Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int b))
- <> Disp.text ".*"
- punct p p' | p < p' = Disp.parens
- | otherwise = id
-
-displayRawDependency :: Dependency -> String
-displayRawDependency (Dependency pkg vr) =
- display pkg ++ " " ++ displayRawVersionRange vr
-
-
--- ------------------------------------------------------------
--- * Checks on the GenericPackageDescription
--- ------------------------------------------------------------
-
--- | Check the build-depends fields for any weirdness or bad practise.
---
-checkPackageVersions :: GenericPackageDescription -> [PackageCheck]
-checkPackageVersions pkg =
- catMaybes [
-
- -- Check that the version of base is bounded above.
- -- For example this bans "build-depends: base >= 3".
- -- It should probably be "build-depends: base >= 3 && < 4"
- -- which is the same as "build-depends: base == 3.*"
- check (not (boundedAbove baseDependency)) $
- PackageDistInexcusable $
- "The dependency 'build-depends: base' does not specify an upper "
- ++ "bound on the version number. Each major release of the 'base' "
- ++ "package changes the API in various ways and most packages will "
- ++ "need some changes to compile with it. The recommended practise "
- ++ "is to specify an upper bound on the version of the 'base' "
- ++ "package. This ensures your package will continue to build when a "
- ++ "new major version of the 'base' package is released. If you are "
- ++ "not sure what upper bound to use then use the next major "
- ++ "version. For example if you have tested your package with 'base' "
- ++ "version 2 and 3 then use 'build-depends: base >= 2 && < 4'."
-
- ]
- where
- -- TODO: What we really want to do is test if there exists any
- -- configuration in which the base version is unboudned above.
- -- However that's a bit tricky because there are many possible
- -- configurations. As a cheap easy and safe approximation we will
- -- pick a single "typical" configuration and check if that has an
- -- open upper bound. To get a typical configuration we finalise
- -- using no package index and the current platform.
- finalised = finalizePackageDescription
- [] (const True) buildPlatform
- (CompilerId buildCompilerFlavor (Version [] []))
- [] pkg
- baseDependency = case finalised of
- Right (pkg', _) | not (null baseDeps) ->
- foldr intersectVersionRanges anyVersion baseDeps
- where
- baseDeps =
- [ vr | Dependency (PackageName "base") vr <- buildDepends pkg' ]
-
- -- Just in case finalizePackageDescription fails for any reason,
- -- or if the package doesn't depend on the base package at all,
- -- then we will just skip the check, since boundedAbove noVersion = True
- _ -> noVersion
-
- boundedAbove :: VersionRange -> Bool
- boundedAbove vr = case asVersionIntervals vr of
- [] -> True -- this is the inconsistent version range.
- intervals -> case last intervals of
- (_, UpperBound _ _) -> True
- (_, NoUpperBound ) -> False
-
-
-checkConditionals :: GenericPackageDescription -> [PackageCheck]
-checkConditionals pkg =
- catMaybes [
-
- check (not $ null unknownOSs) $
- PackageDistInexcusable $
- "Unknown operating system name "
- ++ commaSep (map quote unknownOSs)
-
- , check (not $ null unknownArches) $
- PackageDistInexcusable $
- "Unknown architecture name "
- ++ commaSep (map quote unknownArches)
-
- , check (not $ null unknownImpls) $
- PackageDistInexcusable $
- "Unknown compiler name "
- ++ commaSep (map quote unknownImpls)
- ]
- where
- unknownOSs = [ os | OS (OtherOS os) <- conditions ]
- unknownArches = [ arch | Arch (OtherArch arch) <- conditions ]
- unknownImpls = [ impl | Impl (OtherCompiler impl) _ <- conditions ]
- conditions = maybe [] freeVars (condLibrary pkg)
- ++ concatMap (freeVars . snd) (condExecutables pkg)
- freeVars (CondNode _ _ ifs) = concatMap compfv ifs
- compfv (c, ct, mct) = condfv c ++ freeVars ct ++ maybe [] freeVars mct
- condfv c = case c of
- Var v -> [v]
- Lit _ -> []
- CNot c1 -> condfv c1
- COr c1 c2 -> condfv c1 ++ condfv c2
- CAnd c1 c2 -> condfv c1 ++ condfv c2
-
--- ------------------------------------------------------------
--- * Checks involving files in the package
--- ------------------------------------------------------------
-
--- | Sanity check things that requires IO. It looks at the files in the
--- package and expects to find the package unpacked in at the given filepath.
---
-checkPackageFiles :: PackageDescription -> FilePath -> IO [PackageCheck]
-checkPackageFiles pkg root = checkPackageContent checkFilesIO pkg
- where
- checkFilesIO = CheckPackageContentOps {
- doesFileExist = System.doesFileExist . relative,
- doesDirectoryExist = System.doesDirectoryExist . relative
- }
- relative path = root </> path
-
--- | A record of operations needed to check the contents of packages.
--- Used by 'checkPackageContent'.
---
-data CheckPackageContentOps m = CheckPackageContentOps {
- doesFileExist :: FilePath -> m Bool,
- doesDirectoryExist :: FilePath -> m Bool
- }
-
--- | Sanity check things that requires looking at files in the package.
--- This is a generalised version of 'checkPackageFiles' that can work in any
--- monad for which you can provide 'CheckPackageContentOps' operations.
---
--- The point of this extra generality is to allow doing checks in some virtual
--- file system, for example a tarball in memory.
---
-checkPackageContent :: Monad m => CheckPackageContentOps m
- -> PackageDescription
- -> m [PackageCheck]
-checkPackageContent ops pkg = do
- licenseError <- checkLicenseExists ops pkg
- setupError <- checkSetupExists ops pkg
- configureError <- checkConfigureExists ops pkg
- localPathErrors <- checkLocalPathsExist ops pkg
- vcsLocation <- checkMissingVcsInfo ops pkg
-
- return $ catMaybes [licenseError, setupError, configureError]
- ++ localPathErrors
- ++ vcsLocation
-
-checkLicenseExists :: Monad m => CheckPackageContentOps m
- -> PackageDescription
- -> m (Maybe PackageCheck)
-checkLicenseExists ops pkg
- | null (licenseFile pkg) = return Nothing
- | otherwise = do
- exists <- doesFileExist ops file
- return $ check (not exists) $
- PackageBuildWarning $
- "The 'license-file' field refers to the file " ++ quote file
- ++ " which does not exist."
-
- where
- file = licenseFile pkg
-
-checkSetupExists :: Monad m => CheckPackageContentOps m
- -> PackageDescription
- -> m (Maybe PackageCheck)
-checkSetupExists ops _ = do
- hsexists <- doesFileExist ops "Setup.hs"
- lhsexists <- doesFileExist ops "Setup.lhs"
- return $ check (not hsexists && not lhsexists) $
- PackageDistInexcusable $
- "The package is missing a Setup.hs or Setup.lhs script."
-
-checkConfigureExists :: Monad m => CheckPackageContentOps m
- -> PackageDescription
- -> m (Maybe PackageCheck)
-checkConfigureExists ops PackageDescription { buildType = Just Configure } = do
- exists <- doesFileExist ops "configure"
- return $ check (not exists) $
- PackageBuildWarning $
- "The 'build-type' is 'Configure' but there is no 'configure' script."
-checkConfigureExists _ _ = return Nothing
-
-checkLocalPathsExist :: Monad m => CheckPackageContentOps m
- -> PackageDescription
- -> m [PackageCheck]
-checkLocalPathsExist ops pkg = do
- let dirs = [ (dir, kind)
- | bi <- allBuildInfo pkg
- , (dir, kind) <-
- [ (dir, "extra-lib-dirs") | dir <- extraLibDirs bi ]
- ++ [ (dir, "include-dirs") | dir <- includeDirs bi ]
- ++ [ (dir, "hs-source-dirs") | dir <- hsSourceDirs bi ]
- , isRelative dir ]
- missing <- filterM (liftM not . doesDirectoryExist ops . fst) dirs
- return [ PackageBuildWarning {
- explanation = quote (kind ++ ": " ++ dir)
- ++ " directory does not exist."
- }
- | (dir, kind) <- missing ]
-
-checkMissingVcsInfo :: Monad m => CheckPackageContentOps m
- -> PackageDescription
- -> m [PackageCheck]
-checkMissingVcsInfo ops pkg | null (sourceRepos pkg) = do
- vcsInUse <- liftM or $ mapM (doesDirectoryExist ops) repoDirnames
- if vcsInUse
- then return [ PackageDistSuspicious message ]
- else return []
- where
- repoDirnames = [ dirname | repo <- knownRepoTypes
- , dirname <- repoTypeDirname repo ]
- message = "When distributing packages it is encouraged to specify source "
- ++ "control information in the .cabal file using one or more "
- ++ "'source-repository' sections. See the Cabal user guide for "
- ++ "details."
-
-checkMissingVcsInfo _ _ = return []
-
-repoTypeDirname :: RepoType -> [FilePath]
-repoTypeDirname Darcs = ["_darcs"]
-repoTypeDirname Git = [".git"]
-repoTypeDirname SVN = [".svn"]
-repoTypeDirname CVS = ["CVS"]
-repoTypeDirname Mercurial = [".hg"]
-repoTypeDirname GnuArch = [".arch-params"]
-repoTypeDirname Bazaar = [".bzr"]
-repoTypeDirname Monotone = ["_MTN"]
-repoTypeDirname _ = []
-
--- ------------------------------------------------------------
--- * Checks involving files in the package
--- ------------------------------------------------------------
-
--- | Check the names of all files in a package for portability problems. This
--- should be done for example when creating or validating a package tarball.
---
-checkPackageFileNames :: [FilePath] -> [PackageCheck]
-checkPackageFileNames files =
- (take 1 . catMaybes . map checkWindowsPath $ files)
- ++ (take 1 . catMaybes . map checkTarPath $ files)
- -- If we get any of these checks triggering then we're likely to get
- -- many, and that's probably not helpful, so return at most one.
-
-checkWindowsPath :: FilePath -> Maybe PackageCheck
-checkWindowsPath path =
- check (not $ FilePath.Windows.isValid path') $
- PackageDistInexcusable $
- "Unfortunately, the file " ++ quote path ++ " is not a valid file "
- ++ "name on Windows which would cause portability problems for this "
- ++ "package. Windows file names cannot contain any of the characters "
- ++ "\":*?<>|\" and there are a few reserved names including \"aux\", "
- ++ "\"nul\", \"con\", \"prn\", \"com1-9\", \"lpt1-9\" and \"clock$\"."
- where
- path' = ".\\" ++ path
- -- force a relative name to catch invalid file names like "f:oo" which
- -- otherwise parse as file "oo" in the current directory on the 'f' drive.
-
--- | Check a file name is valid for the portable POSIX tar format.
---
--- The POSIX tar format has a restriction on the length of file names. It is
--- unfortunately not a simple restriction like a maximum length. The exact
--- restriction is that either the whole path be 100 characters or less, or it
--- be possible to split the path on a directory separator such that the first
--- part is 155 characters or less and the second part 100 characters or less.
---
-checkTarPath :: FilePath -> Maybe PackageCheck
-checkTarPath path
- | length path > 255 = Just longPath
- | otherwise = case pack nameMax (reverse (splitPath path)) of
- Left err -> Just err
- Right [] -> Nothing
- Right (first:rest) -> case pack prefixMax remainder of
- Left err -> Just err
- Right [] -> Nothing
- Right (_:_) -> Just noSplit
- where
- -- drop the '/' between the name and prefix:
- remainder = init first : rest
-
- where
- nameMax, prefixMax :: Int
- nameMax = 100
- prefixMax = 155
-
- pack _ [] = Left emptyName
- pack maxLen (c:cs)
- | n > maxLen = Left longName
- | otherwise = Right (pack' maxLen n cs)
- where n = length c
-
- pack' maxLen n (c:cs)
- | n' <= maxLen = pack' maxLen n' cs
- where n' = n + length c
- pack' _ _ cs = cs
-
- longPath = PackageDistInexcusable $
- "The following file name is too long to store in a portable POSIX "
- ++ "format tar archive. The maximum length is 255 ASCII characters.\n"
- ++ "The file in question is:\n " ++ path
- longName = PackageDistInexcusable $
- "The following file name is too long to store in a portable POSIX "
- ++ "format tar archive. The maximum length for the name part (including "
- ++ "extension) is 100 ASCII characters. The maximum length for any "
- ++ "individual directory component is 155.\n"
- ++ "The file in question is:\n " ++ path
- noSplit = PackageDistInexcusable $
- "The following file name is too long to store in a portable POSIX "
- ++ "format tar archive. While the total length is less than 255 ASCII "
- ++ "characters, there are unfortunately further restrictions. It has to "
- ++ "be possible to split the file path on a directory separator into "
- ++ "two parts such that the first part fits in 155 characters or less "
- ++ "and the second part fits in 100 characters or less. Basically you "
- ++ "have to make the file name or directory names shorter, or you could "
- ++ "split a long directory name into nested subdirectories with shorter "
- ++ "names.\nThe file in question is:\n " ++ path
- emptyName = PackageDistInexcusable $
- "Encountered a file with an empty name, something is very wrong! "
- ++ "Files with an empty name cannot be stored in a tar archive or in "
- ++ "standard file systems."
-
--- ------------------------------------------------------------
--- * Utils
--- ------------------------------------------------------------
-
-quote :: String -> String
-quote s = "'" ++ s ++ "'"
-
-commaSep :: [String] -> String
-commaSep = intercalate ", "
-
-dups :: Ord a => [a] -> [a]
-dups xs = [ x | (x:_:_) <- group (sort xs) ]
diff --git a/cabal/Cabal/Distribution/PackageDescription/Configuration.hs b/cabal/Cabal/Distribution/PackageDescription/Configuration.hs
deleted file mode 100644
index 19d5fda..0000000
--- a/cabal/Cabal/Distribution/PackageDescription/Configuration.hs
+++ /dev/null
@@ -1,652 +0,0 @@
-{-# OPTIONS -cpp #-}
--- OPTIONS required for ghc-6.4.x compat, and must appear first
-{-# LANGUAGE CPP #-}
--- -fno-warn-deprecations for use of Map.foldWithKey
-{-# OPTIONS_GHC -cpp -fno-warn-deprecations #-}
-{-# OPTIONS_NHC98 -cpp #-}
-{-# OPTIONS_JHC -fcpp #-}
------------------------------------------------------------------------------
--- |
--- Module : Distribution.Configuration
--- Copyright : Thomas Schilling, 2007
---
--- Maintainer : cabal-devel@haskell.org
--- Portability : portable
---
--- This is about the cabal configurations feature. It exports
--- 'finalizePackageDescription' and 'flattenPackageDescription' which are
--- functions for converting 'GenericPackageDescription's down to
--- 'PackageDescription's. It has code for working with the tree of conditions
--- and resolving or flattening conditions.
-
-{- All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
- * Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
- * Redistributions in binary form must reproduce the above
- copyright notice, this list of conditions and the following
- disclaimer in the documentation and/or other materials provided
- with the distribution.
-
- * Neither the name of Isaac Jones nor the names of other
- contributors may be used to endorse or promote products derived
- from this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
-
-module Distribution.PackageDescription.Configuration (
- finalizePackageDescription,
- flattenPackageDescription,
-
- -- Utils
- parseCondition,
- freeVars,
- mapCondTree,
- mapTreeData,
- mapTreeConds,
- mapTreeConstrs,
- ) where
-
-import Distribution.Package
- ( PackageName, Dependency(..) )
-import Distribution.PackageDescription
- ( GenericPackageDescription(..), PackageDescription(..)
- , Library(..), Executable(..), BuildInfo(..)
- , Flag(..), FlagName(..), FlagAssignment
- , Benchmark(..), CondTree(..), ConfVar(..), Condition(..)
- , TestSuite(..) )
-import Distribution.Version
- ( VersionRange, anyVersion, intersectVersionRanges, withinRange )
-import Distribution.Compiler
- ( CompilerId(CompilerId) )
-import Distribution.System
- ( Platform(..), OS, Arch )
-import Distribution.Simple.Utils
- ( currentDir, lowercase )
-
-import Distribution.Text
- ( Text(parse) )
-import Distribution.Compat.ReadP as ReadP hiding ( char )
-import Control.Arrow (first)
-import qualified Distribution.Compat.ReadP as ReadP ( char )
-
-import Data.Char ( isAlphaNum )
-import Data.Maybe ( catMaybes, maybeToList )
-import Data.Map ( Map, fromListWith, toList )
-import qualified Data.Map as Map
-import Data.Monoid
-
-#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 606)
-import qualified Text.Read as R
-import qualified Text.Read.Lex as L
-#endif
-
-------------------------------------------------------------------------------
-
--- | Simplify the condition and return its free variables.
-simplifyCondition :: Condition c
- -> (c -> Either d Bool) -- ^ (partial) variable assignment
- -> (Condition d, [d])
-simplifyCondition cond i = fv . walk $ cond
- where
- walk cnd = case cnd of
- Var v -> either Var Lit (i v)
- Lit b -> Lit b
- CNot c -> case walk c of
- Lit True -> Lit False
- Lit False -> Lit True
- c' -> CNot c'
- COr c d -> case (walk c, walk d) of
- (Lit False, d') -> d'
- (Lit True, _) -> Lit True
- (c', Lit False) -> c'
- (_, Lit True) -> Lit True
- (c',d') -> COr c' d'
- CAnd c d -> case (walk c, walk d) of
- (Lit False, _) -> Lit False
- (Lit True, d') -> d'
- (_, Lit False) -> Lit False
- (c', Lit True) -> c'
- (c',d') -> CAnd c' d'
- -- gather free vars
- fv c = (c, fv' c)
- fv' c = case c of
- Var v -> [v]
- Lit _ -> []
- CNot c' -> fv' c'
- COr c1 c2 -> fv' c1 ++ fv' c2
- CAnd c1 c2 -> fv' c1 ++ fv' c2
-
--- | Simplify a configuration condition using the os and arch names. Returns
--- the names of all the flags occurring in the condition.
-simplifyWithSysParams :: OS -> Arch -> CompilerId -> Condition ConfVar
- -> (Condition FlagName, [FlagName])
-simplifyWithSysParams os arch (CompilerId comp compVer) cond = (cond', flags)
- where
- (cond', flags) = simplifyCondition cond interp
- interp (OS os') = Right $ os' == os
- interp (Arch arch') = Right $ arch' == arch
- interp (Impl comp' vr) = Right $ comp' == comp
- && compVer `withinRange` vr
- interp (Flag f) = Left f
-
--- TODO: Add instances and check
---
--- prop_sC_idempotent cond a o = cond' == cond''
--- where
--- cond' = simplifyCondition cond a o
--- cond'' = simplifyCondition cond' a o
---
--- prop_sC_noLits cond a o = isLit res || not (hasLits res)
--- where
--- res = simplifyCondition cond a o
--- hasLits (Lit _) = True
--- hasLits (CNot c) = hasLits c
--- hasLits (COr l r) = hasLits l || hasLits r
--- hasLits (CAnd l r) = hasLits l || hasLits r
--- hasLits _ = False
---
-
--- | Parse a configuration condition from a string.
-parseCondition :: ReadP r (Condition ConfVar)
-parseCondition = condOr
- where
- condOr = sepBy1 condAnd (oper "||") >>= return . foldl1 COr
- condAnd = sepBy1 cond (oper "&&")>>= return . foldl1 CAnd
- cond = sp >> (boolLiteral +++ inparens condOr +++ notCond +++ osCond
- +++ archCond +++ flagCond +++ implCond )
- inparens = between (ReadP.char '(' >> sp) (sp >> ReadP.char ')' >> sp)
- notCond = ReadP.char '!' >> sp >> cond >>= return . CNot
- osCond = string "os" >> sp >> inparens osIdent >>= return . Var
- archCond = string "arch" >> sp >> inparens archIdent >>= return . Var
- flagCond = string "flag" >> sp >> inparens flagIdent >>= return . Var
- implCond = string "impl" >> sp >> inparens implIdent >>= return . Var
- boolLiteral = fmap Lit parse
- archIdent = fmap Arch parse
- osIdent = fmap OS parse
- flagIdent = fmap (Flag . FlagName . lowercase) (munch1 isIdentChar)
- isIdentChar c = isAlphaNum c || c == '_' || c == '-'
- oper s = sp >> string s >> sp
- sp = skipSpaces
- implIdent = do i <- parse
- vr <- sp >> option anyVersion parse
- return $ Impl i vr
-
-------------------------------------------------------------------------------
-
-mapCondTree :: (a -> b) -> (c -> d) -> (Condition v -> Condition w)
- -> CondTree v c a -> CondTree w d b
-mapCondTree fa fc fcnd (CondNode a c ifs) =
- CondNode (fa a) (fc c) (map g ifs)
- where
- g (cnd, t, me) = (fcnd cnd, mapCondTree fa fc fcnd t,
- fmap (mapCondTree fa fc fcnd) me)
-
-mapTreeConstrs :: (c -> d) -> CondTree v c a -> CondTree v d a
-mapTreeConstrs f = mapCondTree id f id
-
-mapTreeConds :: (Condition v -> Condition w) -> CondTree v c a -> CondTree w c a
-mapTreeConds f = mapCondTree id id f
-
-mapTreeData :: (a -> b) -> CondTree v c a -> CondTree v c b
-mapTreeData f = mapCondTree f id id
-
--- | Result of dependency test. Isomorphic to @Maybe d@ but renamed for
--- clarity.
-data DepTestRslt d = DepOk | MissingDeps d
-
-instance Monoid d => Monoid (DepTestRslt d) where
- mempty = DepOk
- mappend DepOk x = x
- mappend x DepOk = x
- mappend (MissingDeps d) (MissingDeps d') = MissingDeps (d `mappend` d')
-
-
-data BT a = BTN a | BTB (BT a) (BT a) -- very simple binary tree
-
-
--- | Try to find a flag assignment that satisfies the constaints of all trees.
---
--- Returns either the missing dependencies, or a tuple containing the
--- resulting data, the associated dependencies, and the chosen flag
--- assignments.
---
--- In case of failure, the _smallest_ number of of missing dependencies is
--- returned. [TODO: Could also be specified with a function argument.]
---
--- TODO: The current algorithm is rather naive. A better approach would be to:
---
--- * Rule out possible paths, by taking a look at the associated dependencies.
---
--- * Infer the required values for the conditions of these paths, and
--- calculate the required domains for the variables used in these
--- conditions. Then picking a flag assignment would be linear (I guess).
---
--- This would require some sort of SAT solving, though, thus it's not
--- implemented unless we really need it.
---
-resolveWithFlags ::
- [(FlagName,[Bool])]
- -- ^ Domain for each flag name, will be tested in order.
- -> OS -- ^ OS as returned by Distribution.System.buildOS
- -> Arch -- ^ Arch as returned by Distribution.System.buildArch
- -> CompilerId -- ^ Compiler flavour + version
- -> [Dependency] -- ^ Additional constraints
- -> [CondTree ConfVar [Dependency] PDTagged]
- -> ([Dependency] -> DepTestRslt [Dependency]) -- ^ Dependency test function.
- -> Either [Dependency] (TargetSet PDTagged, FlagAssignment)
- -- ^ Either the missing dependencies (error case), or a pair of
- -- (set of build targets with dependencies, chosen flag assignments)
-resolveWithFlags dom os arch impl constrs trees checkDeps =
- case try dom [] of
- Right r -> Right r
- Left dbt -> Left $ findShortest dbt
- where
- extraConstrs = toDepMap constrs
-
- -- simplify trees by (partially) evaluating all conditions and converting
- -- dependencies to dependency maps.
- simplifiedTrees = map ( mapTreeConstrs toDepMap -- convert to maps
- . mapTreeConds (fst . simplifyWithSysParams os arch impl))
- trees
-
- -- @try@ recursively tries all possible flag assignments in the domain and
- -- either succeeds or returns a binary tree with the missing dependencies
- -- encountered in each run. Since the tree is constructed lazily, we
- -- avoid some computation overhead in the successful case.
- try [] flags =
- let targetSet = TargetSet $ flip map simplifiedTrees $
- -- apply additional constraints to all dependencies
- first (`constrainBy` extraConstrs) .
- simplifyCondTree (env flags)
- deps = overallDependencies targetSet
- in case checkDeps (fromDepMap deps) of
- DepOk -> Right (targetSet, flags)
- MissingDeps mds -> Left (BTN mds)
-
- try ((n, vals):rest) flags =
- tryAll $ map (\v -> try rest ((n, v):flags)) vals
-
- tryAll = foldr mp mz
-
- -- special version of `mplus' for our local purposes
- mp (Left xs) (Left ys) = (Left (BTB xs ys))
- mp (Left _) m@(Right _) = m
- mp m@(Right _) _ = m
-
- -- `mzero'
- mz = Left (BTN [])
-
- env flags flag = (maybe (Left flag) Right . lookup flag) flags
-
- -- for the error case we inspect our lazy tree of missing dependencies and
- -- pick the shortest list of missing dependencies
- findShortest (BTN x) = x
- findShortest (BTB lt rt) =
- let l = findShortest lt
- r = findShortest rt
- in case (l,r) of
- ([], xs) -> xs -- [] is too short
- (xs, []) -> xs
- ([x], _) -> [x] -- single elem is optimum
- (_, [x]) -> [x]
- (xs, ys) -> if lazyLengthCmp xs ys
- then xs else ys
- -- lazy variant of @\xs ys -> length xs <= length ys@
- lazyLengthCmp [] _ = True
- lazyLengthCmp _ [] = False
- lazyLengthCmp (_:xs) (_:ys) = lazyLengthCmp xs ys
-
--- | A map of dependencies. Newtyped since the default monoid instance is not
--- appropriate. The monoid instance uses 'intersectVersionRanges'.
-newtype DependencyMap = DependencyMap { unDependencyMap :: Map PackageName VersionRange }
-#if !defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ >= 606)
- deriving (Show, Read)
-#else
--- The Show/Read instance for Data.Map in ghc-6.4 is useless
--- so we have to re-implement it here:
-instance Show DependencyMap where
- showsPrec d (DependencyMap m) =
- showParen (d > 10) (showString "DependencyMap" . shows (M.toList m))
-
-instance Read DependencyMap where
- readPrec = parens $ R.prec 10 $ do
- R.Ident "DependencyMap" <- R.lexP
- xs <- R.readPrec
- return (DependencyMap (M.fromList xs))
- where parens :: R.ReadPrec a -> R.ReadPrec a
- parens p = optional
- where
- optional = p R.+++ mandatory
- mandatory = paren optional
-
- paren :: R.ReadPrec a -> R.ReadPrec a
- paren p = do L.Punc "(" <- R.lexP
- x <- R.reset p
- L.Punc ")" <- R.lexP
- return x
-
- readListPrec = R.readListPrecDefault
-#endif
-
-instance Monoid DependencyMap where
- mempty = DependencyMap Map.empty
- (DependencyMap a) `mappend` (DependencyMap b) =
- DependencyMap (Map.unionWith intersectVersionRanges a b)
-
-toDepMap :: [Dependency] -> DependencyMap
-toDepMap ds =
- DependencyMap $ fromListWith intersectVersionRanges [ (p,vr) | Dependency p vr <- ds ]
-
-fromDepMap :: DependencyMap -> [Dependency]
-fromDepMap m = [ Dependency p vr | (p,vr) <- toList (unDependencyMap m) ]
-
-simplifyCondTree :: (Monoid a, Monoid d) =>
- (v -> Either v Bool)
- -> CondTree v d a
- -> (d, a)
-simplifyCondTree env (CondNode a d ifs) =
- foldr mappend (d, a) $ catMaybes $ map simplifyIf ifs
- where
- simplifyIf (cnd, t, me) =
- case simplifyCondition cnd env of
- (Lit True, _) -> Just $ simplifyCondTree env t
- (Lit False, _) -> fmap (simplifyCondTree env) me
- _ -> error $ "Environment not defined for all free vars"
-
--- | Flatten a CondTree. This will resolve the CondTree by taking all
--- possible paths into account. Note that since branches represent exclusive
--- choices this may not result in a \"sane\" result.
-ignoreConditions :: (Monoid a, Monoid c) => CondTree v c a -> (a, c)
-ignoreConditions (CondNode a c ifs) = (a, c) `mappend` mconcat (concatMap f ifs)
- where f (_, t, me) = ignoreConditions t
- : maybeToList (fmap ignoreConditions me)
-
-freeVars :: CondTree ConfVar c a -> [FlagName]
-freeVars t = [ f | Flag f <- freeVars' t ]
- where
- freeVars' (CondNode _ _ ifs) = concatMap compfv ifs
- compfv (c, ct, mct) = condfv c ++ freeVars' ct ++ maybe [] freeVars' mct
- condfv c = case c of
- Var v -> [v]
- Lit _ -> []
- CNot c' -> condfv c'
- COr c1 c2 -> condfv c1 ++ condfv c2
- CAnd c1 c2 -> condfv c1 ++ condfv c2
-
-
-------------------------------------------------------------------------------
-
--- | A set of targets with their package dependencies
-newtype TargetSet a = TargetSet [(DependencyMap, a)]
-
--- | Combine the target-specific dependencies in a TargetSet to give the
--- dependencies for the package as a whole.
-overallDependencies :: TargetSet PDTagged -> DependencyMap
-overallDependencies (TargetSet targets) = mconcat depss
- where
- (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
--- (first) map. If a key also exists in the right map, both constraints will
--- be intersected.
-constrainBy :: DependencyMap -- ^ Input map
- -> DependencyMap -- ^ Extra constraints
- -> DependencyMap
-constrainBy left extra =
- DependencyMap $
- Map.foldWithKey tightenConstraint (unDependencyMap left)
- (unDependencyMap extra)
- where tightenConstraint n c l =
- case Map.lookup n l of
- Nothing -> l
- Just vr -> Map.insert n (intersectVersionRanges vr c) l
-
--- | 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)]
- , [(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, bms) =
- (Just l', exes, tests, bms)
- where
- l' = l {
- libBuildInfo = (libBuildInfo l) { targetBuildDepends = fromDepMap deps }
- }
- 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"
- | 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, bms)
- | any ((== n) . fst) tests = bug "Test with same name found"
- | any ((== n) . fst) exes = bug "Test sharing name of exe found"
- | 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
-
-
-------------------------------------------------------------------------------
--- Convert GenericPackageDescription to PackageDescription
---
-
-data PDTagged = Lib Library
- | Exe String Executable
- | Test String TestSuite
- | Bench String Benchmark
- | PDNull
- deriving Show
-
-instance Monoid PDTagged where
- mempty = PDNull
- PDNull `mappend` x = x
- x `mappend` PDNull = x
- 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.
---
--- This function takes a `GenericPackageDescription` and several environment
--- parameters and tries to generate `PackageDescription` by finding a flag
--- assignment that result in satisfiable dependencies.
---
--- It takes as inputs a not necessarily complete specifications of flags
--- assignments, an optional package index as well as platform parameters. If
--- some flags are not assigned explicitly, this function will try to pick an
--- assignment that causes this function to succeed. The package index is
--- optional since on some platforms we cannot determine which packages have
--- been installed before. When no package index is supplied, every dependency
--- is assumed to be satisfiable, therefore all not explicitly assigned flags
--- will get their default values.
---
--- This function will fail if it cannot find a flag assignment that leads to
--- satisfiable dependencies. (It will not try alternative assignments for
--- explicitly specified flags.) In case of failure it will return a /minimum/
--- number of dependencies that could not be satisfied. On success, it will
--- return the package description and the full flag assignment chosen.
---
-finalizePackageDescription ::
- FlagAssignment -- ^ Explicitly specified flag assignments
- -> (Dependency -> Bool) -- ^ Is a given depenency satisfiable from the set of available packages?
- -- If this is unknown then use True.
- -> Platform -- ^ The 'Arch' and 'OS'
- -> CompilerId -- ^ Compiler + Version
- -> [Dependency] -- ^ Additional constraints
- -> GenericPackageDescription
- -> Either [Dependency]
- (PackageDescription, FlagAssignment)
- -- ^ 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 bms0) =
- case resolveFlags of
- 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
- -- filter at this stage, since if the package were not
- -- available we would have failed already.
- }
- , flagVals )
-
- Left missing -> Left missing
- where
- -- Combine lib, exes, and tests into one list of @CondTree@s with tagged data
- 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, 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,b) -> (benchFillInDefaults b) { benchmarkName = n }) bms),
- targetSet, fs)
- Left missing -> Left missing
-
- flagChoices = map (\(MkFlag n _ d manual) -> (n, d2c manual n d)) flags
- d2c manual n b = case lookup n userflags of
- Just val -> [val]
- Nothing
- | manual -> [b]
- | otherwise -> [b, not b]
- --flagDefaults = map (\(n,x:_) -> (n,x)) flagChoices
- check ds = if all satisfyDep ds
- then DepOk
- else MissingDeps $ filter (not . satisfyDep) ds
-
-{-
-let tst_p = (CondNode [1::Int] [Distribution.Package.Dependency "a" AnyVersion] [])
-let tst_p2 = (CondNode [1::Int] [Distribution.Package.Dependency "a" (EarlierVersion (Version [1,0] [])), Distribution.Package.Dependency "a" (LaterVersion (Version [2,0] []))] [])
-
-let p_index = Distribution.Simple.PackageIndex.fromList [Distribution.Package.PackageIdentifier "a" (Version [0,5] []), Distribution.Package.PackageIdentifier "a" (Version [2,5] [])]
-let look = not . null . Distribution.Simple.PackageIndex.lookupDependency p_index
-let looks ds = mconcat $ map (\d -> if look d then DepOk else MissingDeps [d]) ds
-resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribution.Compiler.GHC,Version [6,8,2] []) [tst_p] looks ===> Right ...
-resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribution.Compiler.GHC,Version [6,8,2] []) [tst_p2] looks ===> Left ...
--}
-
--- | Flatten a generic package description by ignoring all conditions and just
--- join the field descriptors into on package description. Note, however,
--- that this may lead to inconsistent field values, since all values are
--- joined into one field, which may not be possible in the original package
--- description, due to the use of exclusive choices (if ... else ...).
---
--- TODO: One particularly tricky case is defaulting. In the original package
--- description, e.g., the source directory might either be the default or a
--- certain, explicitly set path. Since defaults are filled in only after the
--- package has been resolved and when no explicit value has been set, the
--- default path will be missing from the package description returned by this
--- function.
-flattenPackageDescription :: GenericPackageDescription -> PackageDescription
-flattenPackageDescription (GenericPackageDescription pkg _ mlib0 exes0 tests0 bms0) =
- pkg { library = mlib
- , executables = reverse exes
- , testSuites = reverse tests
- , benchmarks = reverse bms
- , buildDepends = ldeps ++ reverse edeps ++ reverse tdeps ++ reverse bdeps
- }
- where
- (mlib, ldeps) = case mlib0 of
- Just lib -> let (l,ds) = ignoreConditions lib in
- (Just (libFillInDefaults l), ds)
- 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
--- modifier-based approach. There, nothing is ever overwritten, but only
--- joined together.
---
--- This is the cleanest way i could think of, that doesn't require
--- changing all field parsing functions to return modifiers instead.
-libFillInDefaults :: Library -> Library
-libFillInDefaults lib@(Library { libBuildInfo = bi }) =
- lib { libBuildInfo = biFillInDefaults bi }
-
-exeFillInDefaults :: Executable -> Executable
-exeFillInDefaults exe@(Executable { buildInfo = bi }) =
- exe { buildInfo = biFillInDefaults bi }
-
-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)
- then bi { hsSourceDirs = [currentDir] }
- else bi
-
-bug :: String -> a
-bug msg = error $ msg ++ ". Consider this a bug."
diff --git a/cabal/Cabal/Distribution/PackageDescription/Parse.hs b/cabal/Cabal/Distribution/PackageDescription/Parse.hs
deleted file mode 100644
index fe85990..0000000
--- a/cabal/Cabal/Distribution/PackageDescription/Parse.hs
+++ /dev/null
@@ -1,1205 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Distribution.PackageDescription.Parse
--- Copyright : Isaac Jones 2003-2005
---
--- Maintainer : cabal-devel@haskell.org
--- Portability : portable
---
--- This defined parsers and partial pretty printers for the @.cabal@ format.
--- Some of the complexity in this module is due to the fact that we have to be
--- backwards compatible with old @.cabal@ files, so there's code to translate
--- into the newer structure.
-
-{- All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
- * Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
- * Redistributions in binary form must reproduce the above
- copyright notice, this list of conditions and the following
- disclaimer in the documentation and/or other materials provided
- with the distribution.
-
- * Neither the name of Isaac Jones nor the names of other
- contributors may be used to endorse or promote products derived
- from this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
-
-module Distribution.PackageDescription.Parse (
- -- * Package descriptions
- readPackageDescription,
- writePackageDescription,
- parsePackageDescription,
- showPackageDescription,
-
- -- ** Parsing
- ParseResult(..),
- FieldDescr(..),
- LineNo,
-
- -- ** Supplementary build information
- readHookedBuildInfo,
- parseHookedBuildInfo,
- writeHookedBuildInfo,
- showHookedBuildInfo,
-
- pkgDescrFieldDescrs,
- libFieldDescrs,
- executableFieldDescrs,
- binfoFieldDescrs,
- sourceRepoFieldDescrs,
- testSuiteFieldDescrs,
- flagFieldDescrs
- ) where
-
-import Data.Char (isSpace)
-import Data.Maybe (listToMaybe, isJust)
-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
-
-import Distribution.ParseUtils hiding (parseFields)
-import Distribution.PackageDescription
-import Distribution.Package
- ( PackageIdentifier(..), Dependency(..), packageName, packageVersion )
-import Distribution.ModuleName ( ModuleName )
-import Distribution.Version
- ( Version(Version), orLaterVersion
- , LowerBound(..), asVersionIntervals )
-import Distribution.Verbosity (Verbosity)
-import Distribution.Compiler (CompilerFlavor(..))
-import Distribution.PackageDescription.Configuration (parseCondition, freeVars)
-import Distribution.Simple.Utils
- ( die, dieWithLocation, warn, intercalate, lowercase, cabalVersion
- , withFileContents, withUTF8FileContents
- , writeFileAtomic, writeUTF8File )
-
-
--- -----------------------------------------------------------------------------
--- The PackageDescription type
-
-pkgDescrFieldDescrs :: [FieldDescr PackageDescription]
-pkgDescrFieldDescrs =
- [ simpleField "name"
- disp parse
- packageName (\name pkg -> pkg{package=(package pkg){pkgName=name}})
- , simpleField "version"
- disp parse
- packageVersion (\ver pkg -> pkg{package=(package pkg){pkgVersion=ver}})
- , simpleField "cabal-version"
- (either disp disp) (liftM Left parse +++ liftM Right parse)
- specVersionRaw (\v pkg -> pkg{specVersionRaw=v})
- , simpleField "build-type"
- (maybe empty disp) (fmap Just parse)
- buildType (\t pkg -> pkg{buildType=t})
- , simpleField "license"
- disp parseLicenseQ
- license (\l pkg -> pkg{license=l})
- , simpleField "license-file"
- showFilePath parseFilePathQ
- licenseFile (\l pkg -> pkg{licenseFile=l})
- , simpleField "copyright"
- showFreeText parseFreeText
- copyright (\val pkg -> pkg{copyright=val})
- , simpleField "maintainer"
- showFreeText parseFreeText
- maintainer (\val pkg -> pkg{maintainer=val})
- , commaListField "build-depends"
- disp parse
- buildDepends (\xs pkg -> pkg{buildDepends=xs})
- , simpleField "stability"
- showFreeText parseFreeText
- stability (\val pkg -> pkg{stability=val})
- , simpleField "homepage"
- showFreeText parseFreeText
- homepage (\val pkg -> pkg{homepage=val})
- , simpleField "package-url"
- showFreeText parseFreeText
- pkgUrl (\val pkg -> pkg{pkgUrl=val})
- , simpleField "bug-reports"
- showFreeText parseFreeText
- bugReports (\val pkg -> pkg{bugReports=val})
- , simpleField "synopsis"
- showFreeText parseFreeText
- synopsis (\val pkg -> pkg{synopsis=val})
- , simpleField "description"
- showFreeText parseFreeText
- description (\val pkg -> pkg{description=val})
- , simpleField "category"
- showFreeText parseFreeText
- category (\val pkg -> pkg{category=val})
- , simpleField "author"
- showFreeText parseFreeText
- author (\val pkg -> pkg{author=val})
- , listField "tested-with"
- showTestedWith parseTestedWithQ
- testedWith (\val pkg -> pkg{testedWith=val})
- , listField "data-files"
- showFilePath parseFilePathQ
- dataFiles (\val pkg -> pkg{dataFiles=val})
- , simpleField "data-dir"
- showFilePath parseFilePathQ
- dataDir (\val pkg -> pkg{dataDir=val})
- , listField "extra-source-files"
- showFilePath parseFilePathQ
- extraSrcFiles (\val pkg -> pkg{extraSrcFiles=val})
- , listField "extra-tmp-files"
- showFilePath parseFilePathQ
- extraTmpFiles (\val pkg -> pkg{extraTmpFiles=val})
- ]
-
--- | Store any fields beginning with "x-" in the customFields field of
--- a PackageDescription. All other fields will generate a warning.
-storeXFieldsPD :: UnrecFieldParser PackageDescription
-storeXFieldsPD (f@('x':'-':_),val) pkg = Just pkg{ customFieldsPD =
- (customFieldsPD pkg) ++ [(f,val)]}
-storeXFieldsPD _ _ = Nothing
-
--- ---------------------------------------------------------------------------
--- The Library type
-
-libFieldDescrs :: [FieldDescr Library]
-libFieldDescrs =
- [ listField "exposed-modules" disp parseModuleNameQ
- exposedModules (\mods lib -> lib{exposedModules=mods})
-
- , boolField "exposed"
- libExposed (\val lib -> lib{libExposed=val})
- ] ++ map biToLib binfoFieldDescrs
- where biToLib = liftField libBuildInfo (\bi lib -> lib{libBuildInfo=bi})
-
-storeXFieldsLib :: UnrecFieldParser Library
-storeXFieldsLib (f@('x':'-':_), val) l@(Library { libBuildInfo = bi }) =
- Just $ l {libBuildInfo = bi{ customFieldsBI = (customFieldsBI bi) ++ [(f,val)]}}
-storeXFieldsLib _ _ = Nothing
-
--- ---------------------------------------------------------------------------
--- The Executable type
-
-
-executableFieldDescrs :: [FieldDescr Executable]
-executableFieldDescrs =
- [ -- note ordering: configuration must come first, for
- -- showPackageDescription.
- simpleField "executable"
- showToken parseTokenQ
- exeName (\xs exe -> exe{exeName=xs})
- , simpleField "main-is"
- showFilePath parseFilePathQ
- modulePath (\xs exe -> exe{modulePath=xs})
- ]
- ++ map biToExe binfoFieldDescrs
- where biToExe = liftField buildInfo (\bi exe -> exe{buildInfo=bi})
-
-storeXFieldsExe :: UnrecFieldParser Executable
-storeXFieldsExe (f@('x':'-':_), val) e@(Executable { buildInfo = bi }) =
- Just $ e {buildInfo = bi{ customFieldsBI = (f,val):(customFieldsBI bi)}}
-storeXFieldsExe _ _ = Nothing
-
--- ---------------------------------------------------------------------------
--- The TestSuite type
-
--- | An intermediate type just used for parsing the test-suite stanza.
--- After validation it is converted into the proper 'TestSuite' type.
-data TestSuiteStanza = TestSuiteStanza {
- testStanzaTestType :: Maybe TestType,
- testStanzaMainIs :: Maybe FilePath,
- testStanzaTestModule :: Maybe ModuleName,
- testStanzaBuildInfo :: BuildInfo
- }
-
-emptyTestStanza :: TestSuiteStanza
-emptyTestStanza = TestSuiteStanza Nothing Nothing Nothing mempty
-
-testSuiteFieldDescrs :: [FieldDescr TestSuiteStanza]
-testSuiteFieldDescrs =
- [ simpleField "type"
- (maybe empty disp) (fmap Just parse)
- testStanzaTestType (\x suite -> suite { testStanzaTestType = x })
- , simpleField "main-is"
- (maybe empty showFilePath) (fmap Just parseFilePathQ)
- testStanzaMainIs (\x suite -> suite { testStanzaMainIs = x })
- , simpleField "test-module"
- (maybe empty disp) (fmap Just parseModuleNameQ)
- testStanzaTestModule (\x suite -> suite { testStanzaTestModule = x })
- ]
- ++ map biToTest binfoFieldDescrs
- where
- biToTest = liftField testStanzaBuildInfo
- (\bi suite -> suite { testStanzaBuildInfo = bi })
-
-storeXFieldsTest :: UnrecFieldParser TestSuiteStanza
-storeXFieldsTest (f@('x':'-':_), val) t@(TestSuiteStanza { testStanzaBuildInfo = bi }) =
- Just $ t {testStanzaBuildInfo = bi{ customFieldsBI = (f,val):(customFieldsBI bi)}}
-storeXFieldsTest _ _ = Nothing
-
-validateTestSuite :: LineNo -> TestSuiteStanza -> ParseResult TestSuite
-validateTestSuite line stanza =
- case testStanzaTestType stanza of
- Nothing -> return $
- emptyTestSuite { testBuildInfo = testStanzaBuildInfo stanza }
-
- Just tt@(TestTypeUnknown _ _) ->
- return emptyTestSuite {
- testInterface = TestSuiteUnsupported tt,
- testBuildInfo = testStanzaBuildInfo stanza
- }
-
- Just tt | tt `notElem` knownTestTypes ->
- return emptyTestSuite {
- testInterface = TestSuiteUnsupported tt,
- testBuildInfo = testStanzaBuildInfo stanza
- }
-
- Just tt@(TestTypeExe ver) ->
- case testStanzaMainIs stanza of
- Nothing -> syntaxError line (missingField "main-is" tt)
- Just file -> do
- when (isJust (testStanzaTestModule stanza)) $
- warning (extraField "test-module" tt)
- return emptyTestSuite {
- testInterface = TestSuiteExeV10 ver file,
- testBuildInfo = testStanzaBuildInfo stanza
- }
-
- Just tt@(TestTypeLib ver) ->
- case testStanzaTestModule stanza of
- Nothing -> syntaxError line (missingField "test-module" tt)
- Just module_ -> do
- when (isJust (testStanzaMainIs stanza)) $
- warning (extraField "main-is" tt)
- return emptyTestSuite {
- testInterface = TestSuiteLibV09 ver module_,
- testBuildInfo = testStanzaBuildInfo stanza
- }
-
- where
- missingField name tt = "The '" ++ name ++ "' field is required for the "
- ++ display tt ++ " test suite type."
-
- extraField name tt = "The '" ++ name ++ "' field is not used for the '"
- ++ display tt ++ "' test suite type."
-
-
--- ---------------------------------------------------------------------------
--- 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
-
-
-binfoFieldDescrs :: [FieldDescr BuildInfo]
-binfoFieldDescrs =
- [ boolField "buildable"
- buildable (\val binfo -> binfo{buildable=val})
- , commaListField "build-tools"
- disp parseBuildTool
- buildTools (\xs binfo -> binfo{buildTools=xs})
- , spaceListField "cpp-options"
- showToken parseTokenQ'
- cppOptions (\val binfo -> binfo{cppOptions=val})
- , spaceListField "cc-options"
- showToken parseTokenQ'
- ccOptions (\val binfo -> binfo{ccOptions=val})
- , spaceListField "ld-options"
- showToken parseTokenQ'
- ldOptions (\val binfo -> binfo{ldOptions=val})
- , commaListField "pkgconfig-depends"
- disp parsePkgconfigDependency
- pkgconfigDepends (\xs binfo -> binfo{pkgconfigDepends=xs})
- , listField "frameworks"
- showToken parseTokenQ
- frameworks (\val binfo -> binfo{frameworks=val})
- , listField "c-sources"
- showFilePath parseFilePathQ
- cSources (\paths binfo -> binfo{cSources=paths})
-
- , simpleField "default-language"
- (maybe empty disp) (option Nothing (fmap Just parseLanguageQ))
- defaultLanguage (\lang binfo -> binfo{defaultLanguage=lang})
- , listField "other-languages"
- disp parseLanguageQ
- otherLanguages (\langs binfo -> binfo{otherLanguages=langs})
- , listField "default-extensions"
- disp parseExtensionQ
- defaultExtensions (\exts binfo -> binfo{defaultExtensions=exts})
- , listField "other-extensions"
- disp parseExtensionQ
- otherExtensions (\exts binfo -> binfo{otherExtensions=exts})
- , listField "extensions"
- disp parseExtensionQ
- oldExtensions (\exts binfo -> binfo{oldExtensions=exts})
-
- , listField "extra-libraries"
- showToken parseTokenQ
- extraLibs (\xs binfo -> binfo{extraLibs=xs})
- , listField "extra-lib-dirs"
- showFilePath parseFilePathQ
- extraLibDirs (\xs binfo -> binfo{extraLibDirs=xs})
- , listField "includes"
- showFilePath parseFilePathQ
- includes (\paths binfo -> binfo{includes=paths})
- , listField "install-includes"
- showFilePath parseFilePathQ
- installIncludes (\paths binfo -> binfo{installIncludes=paths})
- , listField "include-dirs"
- showFilePath parseFilePathQ
- includeDirs (\paths binfo -> binfo{includeDirs=paths})
- , listField "hs-source-dirs"
- showFilePath parseFilePathQ
- hsSourceDirs (\paths binfo -> binfo{hsSourceDirs=paths})
- , listField "other-modules"
- disp parseModuleNameQ
- otherModules (\val binfo -> binfo{otherModules=val})
- , listField "ghc-prof-options"
- text parseTokenQ
- ghcProfOptions (\val binfo -> binfo{ghcProfOptions=val})
- , listField "ghc-shared-options"
- text parseTokenQ
- ghcSharedOptions (\val binfo -> binfo{ghcSharedOptions=val})
- , optsField "ghc-options" GHC
- options (\path binfo -> binfo{options=path})
- , optsField "hugs-options" Hugs
- options (\path binfo -> binfo{options=path})
- , optsField "nhc98-options" NHC
- options (\path binfo -> binfo{options=path})
- , optsField "jhc-options" JHC
- options (\path binfo -> binfo{options=path})
- ]
-
-storeXFieldsBI :: UnrecFieldParser BuildInfo
-storeXFieldsBI (f@('x':'-':_),val) bi = Just bi{ customFieldsBI = (f,val):(customFieldsBI bi) }
-storeXFieldsBI _ _ = Nothing
-
-------------------------------------------------------------------------------
-
-flagFieldDescrs :: [FieldDescr Flag]
-flagFieldDescrs =
- [ simpleField "description"
- showFreeText parseFreeText
- flagDescription (\val fl -> fl{ flagDescription = val })
- , boolField "default"
- flagDefault (\val fl -> fl{ flagDefault = val })
- , boolField "manual"
- flagManual (\val fl -> fl{ flagManual = val })
- ]
-
-------------------------------------------------------------------------------
-
-sourceRepoFieldDescrs :: [FieldDescr SourceRepo]
-sourceRepoFieldDescrs =
- [ simpleField "type"
- (maybe empty disp) (fmap Just parse)
- repoType (\val repo -> repo { repoType = val })
- , simpleField "location"
- (maybe empty showFreeText) (fmap Just parseFreeText)
- repoLocation (\val repo -> repo { repoLocation = val })
- , simpleField "module"
- (maybe empty showToken) (fmap Just parseTokenQ)
- repoModule (\val repo -> repo { repoModule = val })
- , simpleField "branch"
- (maybe empty showToken) (fmap Just parseTokenQ)
- repoBranch (\val repo -> repo { repoBranch = val })
- , simpleField "tag"
- (maybe empty showToken) (fmap Just parseTokenQ)
- repoTag (\val repo -> repo { repoTag = val })
- , simpleField "subdir"
- (maybe empty showFilePath) (fmap Just parseFilePathQ)
- repoSubdir (\val repo -> repo { repoSubdir = val })
- ]
-
--- ---------------------------------------------------------------
--- Parsing
-
--- | Given a parser and a filename, return the parse of the file,
--- after checking if the file exists.
-readAndParseFile :: (FilePath -> (String -> IO a) -> IO a)
- -> (String -> ParseResult a)
- -> Verbosity
- -> FilePath -> IO a
-readAndParseFile withFileContents' parser verbosity fpath = do
- exists <- doesFileExist fpath
- when (not exists) (die $ "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue.")
- withFileContents' fpath $ \str -> case parser str of
- ParseFailed e -> do
- let (line, message) = locatedErrorMsg e
- dieWithLocation fpath line message
- ParseOk warnings x -> do
- mapM_ (warn verbosity . showPWarning fpath) $ reverse warnings
- return x
-
-readHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo
-readHookedBuildInfo =
- readAndParseFile withFileContents parseHookedBuildInfo
-
--- |Parse the given package file.
-readPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription
-readPackageDescription =
- readAndParseFile withUTF8FileContents parsePackageDescription
-
-stanzas :: [Field] -> [[Field]]
-stanzas [] = []
-stanzas (f:fields) = (f:this) : stanzas rest
- where
- (this, rest) = break isStanzaHeader fields
-
-isStanzaHeader :: Field -> Bool
-isStanzaHeader (F _ f _) = f == "executable"
-isStanzaHeader _ = False
-
-------------------------------------------------------------------------------
-
-
-mapSimpleFields :: (Field -> ParseResult Field) -> [Field]
- -> ParseResult [Field]
-mapSimpleFields f fs = mapM walk fs
- where
- walk fld@(F _ _ _) = f fld
- walk (IfBlock l c fs1 fs2) = do
- fs1' <- mapM walk fs1
- fs2' <- mapM walk fs2
- return (IfBlock l c fs1' fs2')
- walk (Section ln n l fs1) = do
- fs1' <- mapM walk fs1
- return (Section ln n l fs1')
-
--- prop_isMapM fs = mapSimpleFields return fs == return fs
-
-
--- names of fields that represents dependencies, thus consrca
-constraintFieldNames :: [String]
-constraintFieldNames = ["build-depends"]
-
--- Possible refactoring would be to have modifiers be explicit about what
--- they add and define an accessor that specifies what the dependencies
--- are. This way we would completely reuse the parsing knowledge from the
--- field descriptor.
-parseConstraint :: Field -> ParseResult [Dependency]
-parseConstraint (F l n v)
- | n == "build-depends" = runP l n (parseCommaList parse) v
-parseConstraint f = bug $ "Constraint was expected (got: " ++ show f ++ ")"
-
-{-
-headerFieldNames :: [String]
-headerFieldNames = filter (\n -> not (n `elem` constraintFieldNames))
- . map fieldName $ pkgDescrFieldDescrs
--}
-
-libFieldNames :: [String]
-libFieldNames = map fieldName libFieldDescrs
- ++ buildInfoNames ++ constraintFieldNames
-
--- exeFieldNames :: [String]
--- exeFieldNames = map fieldName executableFieldDescrs
--- ++ buildInfoNames
-
-buildInfoNames :: [String]
-buildInfoNames = map fieldName binfoFieldDescrs
- ++ map fst deprecatedFieldsBuildInfo
-
--- A minimal implementation of the StateT monad transformer to avoid depending
--- on the 'mtl' package.
-newtype StT s m a = StT { runStT :: s -> m (a,s) }
-
-instance Monad m => Monad (StT s m) where
- return a = StT (\s -> return (a,s))
- StT f >>= g = StT $ \s -> do
- (a,s') <- f s
- runStT (g a) s'
-
-get :: Monad m => StT s m s
-get = StT $ \s -> return (s, s)
-
-modify :: Monad m => (s -> s) -> StT s m ()
-modify f = StT $ \s -> return ((),f s)
-
-lift :: Monad m => m a -> StT s m a
-lift m = StT $ \s -> m >>= \a -> return (a,s)
-
-evalStT :: Monad m => StT s m a -> s -> m a
-evalStT st s = runStT st s >>= return . fst
-
--- Our monad for parsing a list/tree of fields.
---
--- The state represents the remaining fields to be processed.
-type PM a = StT [Field] ParseResult a
-
-
-
--- return look-ahead field or nothing if we're at the end of the file
-peekField :: PM (Maybe Field)
-peekField = get >>= return . listToMaybe
-
--- Unconditionally discard the first field in our state. Will error when it
--- reaches end of file. (Yes, that's evil.)
-skipField :: PM ()
-skipField = modify tail
-
---FIXME: this should take a ByteString, not a String. We have to be able to
--- decode UTF8 and handle the BOM.
-
--- | Parses the given file into a 'GenericPackageDescription'.
---
--- In Cabal 1.2 the syntax for package descriptions was changed to a format
--- with sections and possibly indented property descriptions.
-parsePackageDescription :: String -> ParseResult GenericPackageDescription
-parsePackageDescription file = do
-
- -- This function is quite complex because it needs to be able to parse
- -- both pre-Cabal-1.2 and post-Cabal-1.2 files. Additionally, it contains
- -- a lot of parser-related noise since we do not want to depend on Parsec.
- --
- -- If we detect an pre-1.2 file we implicitly convert it to post-1.2
- -- style. See 'sectionizeFields' below for details about the conversion.
-
- fields0 <- readFields file `catchParseError` \err ->
- let tabs = findIndentTabs file in
- case err of
- -- In case of a TabsError report them all at once.
- TabsError tabLineNo -> reportTabsError
- -- but only report the ones including and following
- -- the one that caused the actual error
- [ t | t@(lineNo',_) <- tabs
- , lineNo' >= tabLineNo ]
- _ -> parseFail err
-
- let cabalVersionNeeded =
- head $ [ minVersionBound versionRange
- | Just versionRange <- [ simpleParse v
- | F _ "cabal-version" v <- fields0 ] ]
- ++ [Version [0] []]
- minVersionBound versionRange =
- case asVersionIntervals versionRange of
- [] -> Version [0] []
- ((LowerBound version _, _):_) -> version
-
- handleFutureVersionParseFailure cabalVersionNeeded $ do
-
- let sf = sectionizeFields fields0 -- ensure 1.2 format
-
- -- figure out and warn about deprecated stuff (warnings are collected
- -- inside our parsing monad)
- fields <- mapSimpleFields deprecField sf
-
- -- Our parsing monad takes the not-yet-parsed fields as its state.
- -- After each successful parse we remove the field from the state
- -- ('skipField') and move on to the next one.
- --
- -- Things are complicated a bit, because fields take a tree-like
- -- structure -- they can be sections or "if"/"else" conditionals.
-
- flip evalStT fields $ do
-
- -- The header consists of all simple fields up to the first section
- -- (flag, library, executable).
- header_fields <- getHeader []
-
- -- Parses just the header fields and stores them in a
- -- 'PackageDescription'. Note that our final result is a
- -- 'GenericPackageDescription'; for pragmatic reasons we just store
- -- the partially filled-out 'PackageDescription' inside the
- -- 'GenericPackageDescription'.
- pkg <- lift $ parseFields pkgDescrFieldDescrs
- storeXFieldsPD
- emptyPackageDescription
- header_fields
-
- -- 'getBody' assumes that the remaining fields only consist of
- -- flags, lib and exe sections.
- (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 bms
-
- where
- oldSyntax flds = all isSimpleField flds
- reportTabsError tabs =
- syntaxError (fst (head tabs)) $
- "Do not use tabs for indentation (use spaces instead)\n"
- ++ " Tabs were used at (line,column): " ++ show tabs
-
- maybeWarnCabalVersion newsyntax pkg
- | newsyntax && specVersion pkg < Version [1,2] []
- = lift $ warning $
- "A package using section syntax must specify at least\n"
- ++ "'cabal-version: >= 1.2'."
-
- maybeWarnCabalVersion newsyntax pkg
- | not newsyntax && specVersion pkg >= Version [1,2] []
- = lift $ warning $
- "A package using 'cabal-version: "
- ++ displaySpecVersion (specVersionRaw pkg)
- ++ "' must use section syntax. See the Cabal user guide for details."
- where
- displaySpecVersion (Left version) = display version
- displaySpecVersion (Right versionRange) =
- case asVersionIntervals versionRange of
- [] {- impossible -} -> display versionRange
- ((LowerBound version _, _):_) -> display (orLaterVersion version)
-
- maybeWarnCabalVersion _ _ = return ()
-
-
- handleFutureVersionParseFailure cabalVersionNeeded parseBody =
- (unless versionOk (warning message) >> parseBody)
- `catchParseError` \parseError -> case parseError of
- TabsError _ -> parseFail parseError
- _ | versionOk -> parseFail parseError
- | otherwise -> fail message
- where versionOk = cabalVersionNeeded <= cabalVersion
- message = "This package requires at least Cabal version "
- ++ display cabalVersionNeeded
-
- -- "Sectionize" an old-style Cabal file. A sectionized file has:
- --
- -- * all global fields at the beginning, followed by
- --
- -- * all flag declarations, followed by
- --
- -- * an optional library section, and an arbitrary number of executable
- -- sections (in any order).
- --
- -- The current implementatition just gathers all library-specific fields
- -- in a library section and wraps all executable stanzas in an executable
- -- section.
- sectionizeFields :: [Field] -> [Field]
- sectionizeFields fs
- | oldSyntax fs =
- let
- -- "build-depends" is a local field now. To be backwards
- -- compatible, we still allow it as a global field in old-style
- -- package description files and translate it to a local field by
- -- adding it to every non-empty section
- (hdr0, exes0) = break ((=="executable") . fName) fs
- (hdr, libfs0) = partition (not . (`elem` libFieldNames) . fName) hdr0
-
- (deps, libfs) = partition ((== "build-depends") . fName)
- libfs0
-
- exes = unfoldr toExe exes0
- toExe [] = Nothing
- toExe (F l e n : r)
- | e == "executable" =
- let (efs, r') = break ((=="executable") . fName) r
- in Just (Section l "executable" n (deps ++ efs), r')
- toExe _ = bug "unexpeced input to 'toExe'"
- in
- hdr ++
- (if null libfs then []
- else [Section (lineNo (head libfs)) "library" "" (deps ++ libfs)])
- ++ exes
- | otherwise = fs
-
- isSimpleField (F _ _ _) = True
- isSimpleField _ = False
-
- -- warn if there's something at the end of the file
- warnIfRest :: PM ()
- warnIfRest = do
- s <- get
- case s of
- [] -> return ()
- _ -> lift $ warning "Ignoring trailing declarations." -- add line no.
-
- -- all simple fields at the beginning of the file are (considered) header
- -- fields
- getHeader :: [Field] -> PM [Field]
- getHeader acc = peekField >>= \mf -> case mf of
- Just f@(F _ _ _) -> skipField >> getHeader (f:acc)
- _ -> return (reverse acc)
-
- --
- -- body ::= { repo | flag | library | executable | test }+ -- at most one lib
- --
- -- The body consists of an optional sequence of declarations of flags and
- -- an arbitrary number of executables and at most one library.
- getBody :: PM ([SourceRepo], [Flag]
- ,Maybe (CondTree ConfVar [Dependency] Library)
- ,[(String, CondTree ConfVar [Dependency] Executable)]
- ,[(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
- when (null sec_label) $ lift $ syntaxError line_no
- "'executable' needs one argument (the executable's name)"
- exename <- lift $ runP line_no "executable" parseTokenQ sec_label
- flds <- collectFields parseExeFields sec_fields
- skipField
- (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
- "'test-suite' needs one argument (the test suite's name)"
- testname <- lift $ runP line_no "test" parseTokenQ sec_label
- flds <- collectFields (parseTestFields line_no) sec_fields
-
- -- Check that a valid test suite 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 test suite 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 checkTestType 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 test type, unless the
- -- type is specified higher in the tree.
- checkComponent (_, t, Just e) =
- checkTestType ts' t && checkTestType ts' e
- -- Does the current node specify a test type?
- hasTestType = testInterface ts'
- /= testInterface emptyTestSuite
- 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 hasTestType || (any checkComponent components)
- if checkTestType emptyTestSuite flds
- then do
- skipField
- (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 "
- ++ "is not present in all conditional branches. The "
- ++ "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, 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, bms)
-
- | sec_type == "flag" -> do
- when (null sec_label) $ lift $
- syntaxError line_no "'flag' needs one argument (the flag's name)"
- flag <- lift $ parseFields
- flagFieldDescrs
- warnUnrec
- (MkFlag (FlagName (lowercase sec_label)) "" True False)
- sec_fields
- skipField
- (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 $
- "'source-repository' needs one argument, "
- ++ "the repo kind which is usually 'head' or 'this'"
- kind <- case simpleParse sec_label of
- Just kind -> return kind
- Nothing -> lift $ syntaxError line_no $
- "could not parse repo kind: " ++ sec_label
- repo <- lift $ parseFields
- sourceRepoFieldDescrs
- warnUnrec
- (SourceRepo {
- repoKind = kind,
- repoType = Nothing,
- repoLocation = Nothing,
- repoModule = Nothing,
- repoBranch = Nothing,
- repoTag = Nothing,
- repoSubdir = Nothing
- })
- sec_fields
- skipField
- (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
- skipField
- getBody
- Just f -> do
- _ <- lift $ syntaxError (lineNo f) $
- "Construct not supported at this position: " ++ show f
- skipField
- getBody
- Nothing -> return ([], [], Nothing, [], [], [])
-
- -- Extracts all fields in a block and returns a 'CondTree'.
- --
- -- We have to recurse down into conditionals and we treat fields that
- -- describe dependencies specially.
- collectFields :: ([Field] -> PM a) -> [Field]
- -> PM (CondTree ConfVar [Dependency] a)
- collectFields parser allflds = do
-
- let simplFlds = [ F l n v | F l n v <- allflds ]
- condFlds = [ f | f@(IfBlock _ _ _ _) <- allflds ]
-
- let (depFlds, dataFlds) = partition isConstraint simplFlds
-
- a <- parser dataFlds
- deps <- liftM concat . mapM (lift . parseConstraint) $ depFlds
-
- ifs <- mapM processIfs condFlds
-
- return (CondNode a deps ifs)
- where
- isConstraint (F _ n _) = n `elem` constraintFieldNames
- isConstraint _ = False
-
- processIfs (IfBlock l c t e) = do
- cnd <- lift $ runP l "if" parseCondition c
- t' <- collectFields parser t
- e' <- case e of
- [] -> return Nothing
- es -> do fs <- collectFields parser es
- return (Just fs)
- return (cnd, t', e')
- processIfs _ = bug "processIfs called with wrong field type"
-
- parseLibFields :: [Field] -> PM Library
- parseLibFields = lift . parseFields libFieldDescrs storeXFieldsLib emptyLibrary
-
- -- Note: we don't parse the "executable" field here, hence the tail hack.
- parseExeFields :: [Field] -> PM Executable
- parseExeFields = lift . parseFields (tail executableFieldDescrs) storeXFieldsExe emptyExecutable
-
- parseTestFields :: LineNo -> [Field] -> PM TestSuite
- parseTestFields line fields = do
- x <- lift $ parseFields testSuiteFieldDescrs storeXFieldsTest
- 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) ->
- [(String, CondTree ConfVar [Dependency] Executable)] ->
- [(String, CondTree ConfVar [Dependency] TestSuite)] ->
- PM ()
- checkForUndefinedFlags flags mlib exes tests = do
- let definedFlags = map flagName flags
- maybe (return ()) (checkCondTreeFlags definedFlags) mlib
- mapM_ (checkCondTreeFlags definedFlags . snd) exes
- mapM_ (checkCondTreeFlags definedFlags . snd) tests
-
- checkCondTreeFlags :: [FlagName] -> CondTree ConfVar c a -> PM ()
- checkCondTreeFlags definedFlags ct = do
- let fv = nub $ freeVars ct
- when (not . all (`elem` definedFlags) $ fv) $
- fail $ "These flags are used without having been defined: "
- ++ intercalate ", " [ n | FlagName n <- fv \\ definedFlags ]
-
-
--- | Parse a list of fields, given a list of field descriptions,
--- a structure to accumulate the parsed fields, and a function
--- that can decide what to do with fields which don't match any
--- of the field descriptions.
-parseFields :: [FieldDescr a] -- ^ descriptions of fields we know how to
- -- parse
- -> UnrecFieldParser a -- ^ possibly do something with
- -- unrecognized fields
- -> a -- ^ accumulator
- -> [Field] -- ^ fields to be parsed
- -> ParseResult a
-parseFields descrs unrec ini fields =
- do (a, unknowns) <- foldM (parseField descrs unrec) (ini, []) fields
- when (not (null unknowns)) $ do
- warning $ render $
- text "Unknown fields:" <+>
- commaSep (map (\(l,u) -> u ++ " (line " ++ show l ++ ")")
- (reverse unknowns))
- $+$
- text "Fields allowed in this section:" $$
- nest 4 (commaSep $ map fieldName descrs)
- return a
- where
- commaSep = fsep . punctuate comma . map text
-
-parseField :: [FieldDescr a] -- ^ list of parseable fields
- -> UnrecFieldParser a -- ^ possibly do something with
- -- unrecognized fields
- -> (a,[(Int,String)]) -- ^ accumulated result and warnings
- -> Field -- ^ the field to be parsed
- -> ParseResult (a, [(Int,String)])
-parseField ((FieldDescr name _ parser):fields) unrec (a, us) (F line f val)
- | name == f = parser line val a >>= \a' -> return (a',us)
- | otherwise = parseField fields unrec (a,us) (F line f val)
-parseField [] unrec (a,us) (F l f val) = return $
- case unrec (f,val) a of -- no fields matched, see if the 'unrec'
- Just a' -> (a',us) -- function wants to do anything with it
- Nothing -> (a, ((l,f):us))
-parseField _ _ _ _ = bug "'parseField' called on a non-field"
-
-deprecatedFields :: [(String,String)]
-deprecatedFields =
- deprecatedFieldsPkgDescr ++ deprecatedFieldsBuildInfo
-
-deprecatedFieldsPkgDescr :: [(String,String)]
-deprecatedFieldsPkgDescr = [ ("other-files", "extra-source-files") ]
-
-deprecatedFieldsBuildInfo :: [(String,String)]
-deprecatedFieldsBuildInfo = [ ("hs-source-dir","hs-source-dirs") ]
-
--- Handle deprecated fields
-deprecField :: Field -> ParseResult Field
-deprecField (F line fld val) = do
- fld' <- case lookup fld deprecatedFields of
- Nothing -> return fld
- Just newName -> do
- warning $ "The field \"" ++ fld
- ++ "\" is deprecated, please use \"" ++ newName ++ "\""
- return newName
- return (F line fld' val)
-deprecField _ = bug "'deprecField' called on a non-field"
-
-
-parseHookedBuildInfo :: String -> ParseResult HookedBuildInfo
-parseHookedBuildInfo inp = do
- fields <- readFields inp
- let ss@(mLibFields:exes) = stanzas fields
- mLib <- parseLib mLibFields
- biExes <- mapM parseExe (maybe ss (const exes) mLib)
- return (mLib, biExes)
- where
- parseLib :: [Field] -> ParseResult (Maybe BuildInfo)
- parseLib (bi@((F _ inFieldName _):_))
- | lowercase inFieldName /= "executable" = liftM Just (parseBI bi)
- parseLib _ = return Nothing
-
- parseExe :: [Field] -> ParseResult (String, BuildInfo)
- parseExe ((F line inFieldName mName):bi)
- | lowercase inFieldName == "executable"
- = do bis <- parseBI bi
- return (mName, bis)
- | otherwise = syntaxError line "expecting 'executable' at top of stanza"
- parseExe (_:_) = bug "`parseExe' called on a non-field"
- parseExe [] = syntaxError 0 "error in parsing buildinfo file. Expected executable stanza"
-
- parseBI st = parseFields binfoFieldDescrs storeXFieldsBI emptyBuildInfo st
-
--- ---------------------------------------------------------------------------
--- Pretty printing
-
-writePackageDescription :: FilePath -> PackageDescription -> IO ()
-writePackageDescription fpath pkg = writeUTF8File fpath (showPackageDescription pkg)
-
---TODO: make this use section syntax
--- add equivalent for GenericPackageDescription
-showPackageDescription :: PackageDescription -> String
-showPackageDescription pkg = render $
- ppPackage pkg
- $$ ppCustomFields (customFieldsPD pkg)
- $$ (case library pkg of
- Nothing -> empty
- Just lib -> ppLibrary lib)
- $$ vcat [ space $$ ppExecutable exe | exe <- executables pkg ]
- where
- ppPackage = ppFields pkgDescrFieldDescrs
- ppLibrary = ppFields libFieldDescrs
- ppExecutable = ppFields executableFieldDescrs
-
-ppCustomFields :: [(String,String)] -> Doc
-ppCustomFields flds = vcat (map ppCustomField flds)
-
-ppCustomField :: (String,String) -> Doc
-ppCustomField (name,val) = text name <> colon <+> showFreeText val
-
-writeHookedBuildInfo :: FilePath -> HookedBuildInfo -> IO ()
-writeHookedBuildInfo fpath = writeFileAtomic fpath . BS.Char8.pack
- . showHookedBuildInfo
-
-showHookedBuildInfo :: HookedBuildInfo -> String
-showHookedBuildInfo (mb_lib_bi, ex_bis) = render $
- (case mb_lib_bi of
- Nothing -> empty
- Just bi -> ppBuildInfo bi)
- $$ vcat [ space
- $$ text "executable:" <+> text name
- $$ ppBuildInfo bi
- | (name, bi) <- ex_bis ]
- where
- ppBuildInfo bi = ppFields binfoFieldDescrs bi
- $$ ppCustomFields (customFieldsBI bi)
-
--- replace all tabs used as indentation with whitespace, also return where
--- tabs were found
-findIndentTabs :: String -> [(Int,Int)]
-findIndentTabs = concatMap checkLine
- . zip [1..]
- . lines
- where
- checkLine (lineno, l) =
- let (indent, _content) = span isSpace l
- tabCols = map fst . filter ((== '\t') . snd) . zip [0..]
- addLineNo = map (\col -> (lineno,col))
- in addLineNo (tabCols indent)
-
---test_findIndentTabs = findIndentTabs $ unlines $
--- [ "foo", " bar", " \t baz", "\t biz\t", "\t\t \t mib" ]
-
-bug :: String -> a
-bug msg = error $ msg ++ ". Consider this a bug."
diff --git a/cabal/Cabal/Distribution/PackageDescription/PrettyPrint.hs b/cabal/Cabal/Distribution/PackageDescription/PrettyPrint.hs
deleted file mode 100644
index b4b8d1d..0000000
--- a/cabal/Cabal/Distribution/PackageDescription/PrettyPrint.hs
+++ /dev/null
@@ -1,238 +0,0 @@
------------------------------------------------------------------------------
---
--- Module : Distribution.PackageDescription.PrettyPrint
--- Copyright : Jürgen Nicklisch-Franken 2010
--- License : AllRightsReserved
---
--- Maintainer : cabal-devel@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- | Pretty printing for cabal files
---
------------------------------------------------------------------------------
-{- All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
- * Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
- * Redistributions in binary form must reproduce the above
- copyright notice, this list of conditions and the following
- disclaimer in the documentation and/or other materials provided
- with the distribution.
-
- * Neither the name of Isaac Jones nor the names of other
- contributors may be used to endorse or promote products derived
- from this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
-
-module Distribution.PackageDescription.PrettyPrint (
- writeGenericPackageDescription,
- showGenericPackageDescription,
-) where
-
-import Distribution.PackageDescription
- ( TestSuite(..), TestSuiteInterface(..), testType
- , SourceRepo(..),
- customFieldsBI, CondTree(..), Condition(..),
- FlagName(..), ConfVar(..), Executable(..), Library(..),
- Flag(..), PackageDescription(..),
- GenericPackageDescription(..))
-import Text.PrettyPrint
- (hsep, comma, punctuate, fsep, parens, char, nest, empty,
- isEmpty, ($$), (<+>), colon, (<>), text, vcat, ($+$), Doc, render)
-import Distribution.Simple.Utils (writeUTF8File)
-import Distribution.ParseUtils (showFreeText, FieldDescr(..))
-import Distribution.PackageDescription.Parse (pkgDescrFieldDescrs,binfoFieldDescrs,libFieldDescrs,
- sourceRepoFieldDescrs)
-import Distribution.Package (Dependency(..))
-import Distribution.Text (Text(..))
-import Data.Maybe (isJust, fromJust, isNothing)
-
-indentWith :: Int
-indentWith = 4
-
--- | Recompile with false for regression testing
-simplifiedPrinting :: Bool
-simplifiedPrinting = False
-
--- | Writes a .cabal file from a generic package description
-writeGenericPackageDescription :: FilePath -> GenericPackageDescription -> IO ()
-writeGenericPackageDescription fpath pkg = writeUTF8File fpath (showGenericPackageDescription pkg)
-
--- | Writes a generic package description to a string
-showGenericPackageDescription :: GenericPackageDescription -> String
-showGenericPackageDescription = render . ppGenericPackageDescription
-
-ppGenericPackageDescription :: GenericPackageDescription -> Doc
-ppGenericPackageDescription gpd =
- ppPackageDescription (packageDescription gpd)
- $+$ ppGenPackageFlags (genPackageFlags gpd)
- $+$ ppLibrary (condLibrary gpd)
- $+$ ppExecutables (condExecutables gpd)
- $+$ ppTestSuites (condTestSuites gpd)
-
-ppPackageDescription :: PackageDescription -> Doc
-ppPackageDescription pd = ppFields pkgDescrFieldDescrs pd
- $+$ ppCustomFields (customFieldsPD pd)
- $+$ ppSourceRepos (sourceRepos pd)
-
-ppSourceRepos :: [SourceRepo] -> Doc
-ppSourceRepos [] = empty
-ppSourceRepos (hd:tl) = ppSourceRepo hd $+$ ppSourceRepos tl
-
-ppSourceRepo :: SourceRepo -> Doc
-ppSourceRepo repo =
- emptyLine $ text "source-repository" <+> disp (repoKind repo) $+$
- (nest indentWith (ppFields sourceRepoFieldDescrs' repo))
- where
- sourceRepoFieldDescrs' = [fd | fd <- sourceRepoFieldDescrs, fieldName fd /= "kind"]
-
-ppFields :: [FieldDescr a] -> a -> Doc
-ppFields fields x =
- vcat [ ppField name (getter x)
- | FieldDescr name getter _ <- fields]
-
-ppField :: String -> Doc -> Doc
-ppField name fielddoc | isEmpty fielddoc = empty
- | otherwise = text name <> colon <+> fielddoc
-
-ppDiffFields :: [FieldDescr a] -> a -> a -> Doc
-ppDiffFields fields x y =
- vcat [ ppField name (getter x)
- | FieldDescr name getter _ <- fields,
- render (getter x) /= render (getter y)]
-
-ppCustomFields :: [(String,String)] -> Doc
-ppCustomFields flds = vcat [ppCustomField f | f <- flds]
-
-ppCustomField :: (String,String) -> Doc
-ppCustomField (name,val) = text name <> colon <+> showFreeText val
-
-ppGenPackageFlags :: [Flag] -> Doc
-ppGenPackageFlags flds = vcat [ppFlag f | f <- flds]
-
-ppFlag :: Flag -> Doc
-ppFlag (MkFlag name desc dflt manual) =
- emptyLine $ text "flag" <+> ppFlagName name $+$
- (nest indentWith ((if null desc
- then empty
- else text "Description: " <+> showFreeText desc) $+$
- (if dflt then empty else text "Default: False") $+$
- (if manual then text "Manual: True" else empty)))
-
-ppLibrary :: (Maybe (CondTree ConfVar [Dependency] Library)) -> Doc
-ppLibrary Nothing = empty
-ppLibrary (Just condTree) =
- emptyLine $ text "library" $+$ nest indentWith (ppCondTree condTree Nothing ppLib)
- where
- ppLib lib Nothing = ppFields libFieldDescrs lib
- $$ ppCustomFields (customFieldsBI (libBuildInfo lib))
- ppLib lib (Just plib) = ppDiffFields libFieldDescrs lib plib
- $$ ppCustomFields (customFieldsBI (libBuildInfo lib))
-
-ppExecutables :: [(String, CondTree ConfVar [Dependency] Executable)] -> Doc
-ppExecutables exes =
- vcat [emptyLine $ text ("executable " ++ n)
- $+$ nest indentWith (ppCondTree condTree Nothing ppExe)| (n,condTree) <- exes]
- where
- ppExe (Executable _ modulePath' buildInfo') Nothing =
- (if modulePath' == "" then empty else text "main-is:" <+> text modulePath')
- $+$ ppFields binfoFieldDescrs buildInfo'
- $+$ ppCustomFields (customFieldsBI buildInfo')
- ppExe (Executable _ modulePath' buildInfo')
- (Just (Executable _ modulePath2 buildInfo2)) =
- (if modulePath' == "" || modulePath' == modulePath2
- then empty else text "main-is:" <+> text modulePath')
- $+$ ppDiffFields binfoFieldDescrs buildInfo' buildInfo2
- $+$ ppCustomFields (customFieldsBI buildInfo')
-
-ppTestSuites :: [(String, CondTree ConfVar [Dependency] TestSuite)] -> Doc
-ppTestSuites suites =
- emptyLine $ vcat [ text ("test-suite " ++ n)
- $+$ nest indentWith (ppCondTree condTree Nothing ppTestSuite)
- | (n,condTree) <- suites]
- where
- ppTestSuite testsuite Nothing =
- text "type:" <+> disp (testType testsuite)
- $+$ maybe empty (\f -> text "main-is:" <+> text f)
- (testSuiteMainIs testsuite)
- $+$ maybe empty (\m -> text "test-module:" <+> disp m)
- (testSuiteModule testsuite)
- $+$ ppFields binfoFieldDescrs (testBuildInfo testsuite)
- $+$ ppCustomFields (customFieldsBI (testBuildInfo testsuite))
-
- ppTestSuite (TestSuite _ _ buildInfo' _)
- (Just (TestSuite _ _ buildInfo2 _)) =
- ppDiffFields binfoFieldDescrs buildInfo' buildInfo2
- $+$ ppCustomFields (customFieldsBI buildInfo')
-
- testSuiteMainIs test = case testInterface test of
- TestSuiteExeV10 _ f -> Just f
- _ -> Nothing
-
- testSuiteModule test = case testInterface test of
- TestSuiteLibV09 _ m -> Just m
- _ -> Nothing
-
-ppCondition :: Condition ConfVar -> Doc
-ppCondition (Var x) = ppConfVar x
-ppCondition (Lit b) = text (show b)
-ppCondition (CNot c) = char '!' <> (ppCondition c)
-ppCondition (COr c1 c2) = parens (hsep [ppCondition c1, text "||"
- <+> ppCondition c2])
-ppCondition (CAnd c1 c2) = parens (hsep [ppCondition c1, text "&&"
- <+> ppCondition c2])
-ppConfVar :: ConfVar -> Doc
-ppConfVar (OS os) = text "os" <> parens (disp os)
-ppConfVar (Arch arch) = text "arch" <> parens (disp arch)
-ppConfVar (Flag name) = text "flag" <> parens (ppFlagName name)
-ppConfVar (Impl c v) = text "impl" <> parens (disp c <+> disp v)
-
-ppFlagName :: FlagName -> Doc
-ppFlagName (FlagName name) = text name
-
-ppCondTree :: CondTree ConfVar [Dependency] a -> Maybe a -> (a -> Maybe a -> Doc) -> Doc
-ppCondTree ct@(CondNode it deps ifs) mbIt ppIt =
- let res = ppDeps deps
- $+$ (vcat $ map ppIf ifs)
- $+$ ppIt it mbIt
- in if isJust mbIt && isEmpty res
- then ppCondTree ct Nothing ppIt
- else res
- where
- ppIf (c,thenTree,mElseTree) =
- ((emptyLine $ text "if" <+> ppCondition c) $$
- nest indentWith (ppCondTree thenTree
- (if simplifiedPrinting then (Just it) else Nothing) ppIt))
- $+$ (if isNothing mElseTree
- then empty
- else text "else"
- $$ nest indentWith (ppCondTree (fromJust mElseTree)
- (if simplifiedPrinting then (Just it) else Nothing) ppIt))
-
-ppDeps :: [Dependency] -> Doc
-ppDeps [] = empty
-ppDeps deps =
- text "build-depends:" <+> fsep (punctuate comma (map disp deps))
-
-emptyLine :: Doc -> Doc
-emptyLine d = text " " $+$ d
-
-
-
diff --git a/cabal/Cabal/Distribution/ParseUtils.hs b/cabal/Cabal/Distribution/ParseUtils.hs
deleted file mode 100644
index d390458..0000000
--- a/cabal/Cabal/Distribution/ParseUtils.hs
+++ /dev/null
@@ -1,715 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Distribution.ParseUtils
--- Copyright : (c) The University of Glasgow 2004
---
--- Maintainer : cabal-devel@haskell.org
--- Portability : portable
---
--- Utilities for parsing 'PackageDescription' and 'InstalledPackageInfo'.
---
--- The @.cabal@ file format is not trivial, especially with the introduction
--- of configurations and the section syntax that goes with that. This module
--- has a bunch of parsing functions that is used by the @.cabal@ parser and a
--- couple others. It has the parsing framework code and also little parsers for
--- many of the formats we get in various @.cabal@ file fields, like module
--- names, comma separated lists etc.
-
-{- All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
- * Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
- * Redistributions in binary form must reproduce the above
- copyright notice, this list of conditions and the following
- disclaimer in the documentation and/or other materials provided
- with the distribution.
-
- * Neither the name of the University nor the names of other
- contributors may be used to endorse or promote products derived
- from this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
-
--- This module is meant to be local-only to Distribution...
-
--- #hide
-module Distribution.ParseUtils (
- LineNo, PError(..), PWarning(..), locatedErrorMsg, syntaxError, warning,
- runP, runE, ParseResult(..), catchParseError, parseFail, showPWarning,
- Field(..), fName, lineNo,
- FieldDescr(..), ppField, ppFields, readFields, readFieldsFlat,
- showFields, showSingleNamedField, parseFields, parseFieldsFlat,
- parseFilePathQ, parseTokenQ, parseTokenQ',
- parseModuleNameQ, parseBuildTool, parsePkgconfigDependency,
- parseOptVersion, parsePackageNameQ, parseVersionRangeQ,
- parseTestedWithQ, parseLicenseQ, parseLanguageQ, parseExtensionQ,
- parseSepList, parseCommaList, parseOptCommaList,
- showFilePath, showToken, showTestedWith, showFreeText, parseFreeText,
- field, simpleField, listField, spaceListField, commaListField,
- optsField, liftField, boolField, parseQuoted,
-
- UnrecFieldParser, warnUnrec, ignoreUnrec,
- ) where
-
-import Distribution.Compiler (CompilerFlavor, parseCompilerFlavorCompat)
-import Distribution.License
-import Distribution.Version
- ( Version(..), VersionRange, anyVersion )
-import Distribution.Package ( PackageName(..), Dependency(..) )
-import Distribution.ModuleName (ModuleName)
-import Distribution.Compat.ReadP as ReadP hiding (get)
-import Distribution.ReadE
-import Distribution.Text
- ( Text(..) )
-import Distribution.Simple.Utils
- ( comparing, intercalate, lowercase, normaliseLineEndings )
-import Language.Haskell.Extension
- ( Language, Extension )
-
-import Text.PrettyPrint hiding (braces)
-import Data.Char (isSpace, toLower, isAlphaNum, isDigit)
-import Data.Maybe (fromMaybe)
-import Data.Tree as Tree (Tree(..), flatten)
-import qualified Data.Map as Map
-import Control.Monad (foldM)
-import System.FilePath (normalise)
-import Data.List (sortBy)
-
--- -----------------------------------------------------------------------------
-
-type LineNo = Int
-
-data PError = AmbigousParse String LineNo
- | NoParse String LineNo
- | TabsError LineNo
- | FromString String (Maybe LineNo)
- deriving Show
-
-data PWarning = PWarning String
- | UTFWarning LineNo String
- deriving Show
-
-showPWarning :: FilePath -> PWarning -> String
-showPWarning fpath (PWarning msg) =
- normalise fpath ++ ": " ++ msg
-showPWarning fpath (UTFWarning line fname) =
- normalise fpath ++ ":" ++ show line
- ++ ": Invalid UTF-8 text in the '" ++ fname ++ "' field."
-
-data ParseResult a = ParseFailed PError | ParseOk [PWarning] a
- deriving Show
-
-instance Monad ParseResult where
- return x = ParseOk [] x
- ParseFailed err >>= _ = ParseFailed err
- ParseOk ws x >>= f = case f x of
- ParseFailed err -> ParseFailed err
- ParseOk ws' x' -> ParseOk (ws'++ws) x'
- fail s = ParseFailed (FromString s Nothing)
-
-catchParseError :: ParseResult a -> (PError -> ParseResult a)
- -> ParseResult a
-p@(ParseOk _ _) `catchParseError` _ = p
-ParseFailed e `catchParseError` k = k e
-
-parseFail :: PError -> ParseResult a
-parseFail = ParseFailed
-
-runP :: LineNo -> String -> ReadP a a -> String -> ParseResult a
-runP line fieldname p s =
- case [ x | (x,"") <- results ] of
- [a] -> ParseOk (utf8Warnings line fieldname s) a
- --TODO: what is this double parse thing all about?
- -- Can't we just do the all isSpace test the first time?
- [] -> case [ x | (x,ys) <- results, all isSpace ys ] of
- [a] -> ParseOk (utf8Warnings line fieldname s) a
- [] -> ParseFailed (NoParse fieldname line)
- _ -> ParseFailed (AmbigousParse fieldname line)
- _ -> ParseFailed (AmbigousParse fieldname line)
- where results = readP_to_S p s
-
-runE :: LineNo -> String -> ReadE a -> String -> ParseResult a
-runE line fieldname p s =
- case runReadE p s of
- Right a -> ParseOk (utf8Warnings line fieldname s) a
- Left e -> syntaxError line $
- "Parse of field '" ++ fieldname ++ "' failed (" ++ e ++ "): " ++ s
-
-utf8Warnings :: LineNo -> String -> String -> [PWarning]
-utf8Warnings line fieldname s =
- take 1 [ UTFWarning n fieldname
- | (n,l) <- zip [line..] (lines s)
- , '\xfffd' `elem` l ]
-
-locatedErrorMsg :: PError -> (Maybe LineNo, String)
-locatedErrorMsg (AmbigousParse f n) = (Just n, "Ambiguous parse in field '"++f++"'.")
-locatedErrorMsg (NoParse f n) = (Just n, "Parse of field '"++f++"' failed.")
-locatedErrorMsg (TabsError n) = (Just n, "Tab used as indentation.")
-locatedErrorMsg (FromString s n) = (n, s)
-
-syntaxError :: LineNo -> String -> ParseResult a
-syntaxError n s = ParseFailed $ FromString s (Just n)
-
-tabsError :: LineNo -> ParseResult a
-tabsError ln = ParseFailed $ TabsError ln
-
-warning :: String -> ParseResult ()
-warning s = ParseOk [PWarning s] ()
-
--- | Field descriptor. The parameter @a@ parameterizes over where the field's
--- value is stored in.
-data FieldDescr a
- = FieldDescr
- { fieldName :: String
- , fieldGet :: a -> Doc
- , fieldSet :: LineNo -> String -> a -> ParseResult a
- -- ^ @fieldSet n str x@ Parses the field value from the given input
- -- string @str@ and stores the result in @x@ if the parse was
- -- successful. Otherwise, reports an error on line number @n@.
- }
-
-field :: String -> (a -> Doc) -> (ReadP a a) -> FieldDescr a
-field name showF readF =
- FieldDescr name showF (\line val _st -> runP line name readF val)
-
--- Lift a field descriptor storing into an 'a' to a field descriptor storing
--- into a 'b'.
-liftField :: (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
-liftField get set (FieldDescr name showF parseF)
- = FieldDescr name (\b -> showF (get b))
- (\line str b -> do
- a <- parseF line str (get b)
- return (set a b))
-
--- Parser combinator for simple fields. Takes a field name, a pretty printer,
--- a parser function, an accessor, and a setter, returns a FieldDescr over the
--- compoid structure.
-simpleField :: String -> (a -> Doc) -> (ReadP a a)
- -> (b -> a) -> (a -> b -> b) -> FieldDescr b
-simpleField name showF readF get set
- = liftField get set $ field name showF readF
-
-commaListField :: String -> (a -> Doc) -> (ReadP [a] a)
- -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
-commaListField name showF readF get set =
- liftField get set' $
- field name (fsep . punctuate comma . map showF) (parseCommaList readF)
- where
- set' xs b = set (get b ++ xs) b
-
-spaceListField :: String -> (a -> Doc) -> (ReadP [a] a)
- -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
-spaceListField name showF readF get set =
- liftField get set' $
- field name (fsep . map showF) (parseSpaceList readF)
- where
- set' xs b = set (get b ++ xs) b
-
-listField :: String -> (a -> Doc) -> (ReadP [a] a)
- -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
-listField name showF readF get set =
- liftField get set' $
- field name (fsep . map showF) (parseOptCommaList readF)
- where
- set' xs b = set (get b ++ xs) b
-
-optsField :: String -> CompilerFlavor -> (b -> [(CompilerFlavor,[String])]) -> ([(CompilerFlavor,[String])] -> b -> b) -> FieldDescr b
-optsField name flavor get set =
- liftField (fromMaybe [] . lookup flavor . get)
- (\opts b -> set (reorder (update flavor opts (get b))) b) $
- field name (hsep . map text)
- (sepBy parseTokenQ' (munch1 isSpace))
- where
- update _ opts l | all null opts = l --empty opts as if no opts
- update f opts [] = [(f,opts)]
- update f opts ((f',opts'):rest)
- | f == f' = (f, opts' ++ opts) : rest
- | otherwise = (f',opts') : update f opts rest
- reorder = sortBy (comparing fst)
-
--- TODO: this is a bit smelly hack. It's because we want to parse bool fields
--- liberally but not accept new parses. We cannot do that with ReadP
--- because it does not support warnings. We need a new parser framwork!
-boolField :: String -> (b -> Bool) -> (Bool -> b -> b) -> FieldDescr b
-boolField name get set = liftField get set (FieldDescr name showF readF)
- where
- showF = text . show
- readF line str _
- | str == "True" = ParseOk [] True
- | str == "False" = ParseOk [] False
- | lstr == "true" = ParseOk [caseWarning] True
- | lstr == "false" = ParseOk [caseWarning] False
- | otherwise = ParseFailed (NoParse name line)
- where
- lstr = lowercase str
- caseWarning = PWarning $
- "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'."
-
-ppFields :: [FieldDescr a] -> a -> Doc
-ppFields fields x = vcat [ ppField name (getter x)
- | FieldDescr name getter _ <- fields]
-
-ppField :: String -> Doc -> Doc
-ppField name fielddoc = text name <> colon <+> fielddoc
-
-showFields :: [FieldDescr a] -> a -> String
-showFields fields = render . ($+$ text "") . ppFields fields
-
-showSingleNamedField :: [FieldDescr a] -> String -> Maybe (a -> String)
-showSingleNamedField fields f =
- case [ get | (FieldDescr f' get _) <- fields, f' == f ] of
- [] -> Nothing
- (get:_) -> Just (render . ppField f . get)
-
-parseFields :: [FieldDescr a] -> a -> String -> ParseResult a
-parseFields fields initial = \str ->
- readFields str >>= accumFields fields initial
-
-parseFieldsFlat :: [FieldDescr a] -> a -> String -> ParseResult a
-parseFieldsFlat fields initial = \str ->
- readFieldsFlat str >>= accumFields fields initial
-
-accumFields :: [FieldDescr a] -> a -> [Field] -> ParseResult a
-accumFields fields = foldM setField
- where
- fieldMap = Map.fromList
- [ (name, f) | f@(FieldDescr name _ _) <- fields ]
- setField accum (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
-
--- | The type of a function which, given a name-value pair of an
--- unrecognized field, and the current structure being built,
--- decides whether to incorporate the unrecognized field
--- (by returning Just x, where x is a possibly modified version
--- of the structure being built), or not (by returning Nothing).
-type UnrecFieldParser a = (String,String) -> a -> Maybe a
-
--- | A default unrecognized field parser which simply returns Nothing,
--- i.e. ignores all unrecognized fields, so warnings will be generated.
-warnUnrec :: UnrecFieldParser a
-warnUnrec _ _ = Nothing
-
--- | A default unrecognized field parser which silently (i.e. no
--- warnings will be generated) ignores unrecognized fields, by
--- returning the structure being built unmodified.
-ignoreUnrec :: UnrecFieldParser a
-ignoreUnrec _ x = Just x
-
-------------------------------------------------------------------------------
-
--- The data type for our three syntactic categories
-data Field
- = F LineNo String String
- -- ^ A regular @<property>: <value>@ field
- | Section LineNo String String [Field]
- -- ^ A section with a name and possible parameter. The syntactic
- -- structure is:
- --
- -- @
- -- <sectionname> <arg> {
- -- <field>*
- -- }
- -- @
- | IfBlock LineNo String [Field] [Field]
- -- ^ A conditional block with an optional else branch:
- --
- -- @
- -- if <condition> {
- -- <field>*
- -- } else {
- -- <field>*
- -- }
- -- @
- deriving (Show
- ,Eq) -- for testing
-
-lineNo :: Field -> LineNo
-lineNo (F n _ _) = n
-lineNo (Section n _ _ _) = n
-lineNo (IfBlock n _ _ _) = n
-
-fName :: Field -> String
-fName (F _ n _) = n
-fName (Section _ n _ _) = n
-fName _ = error "fname: not a field or section"
-
-readFields :: String -> ParseResult [Field]
-readFields input = ifelse
- =<< mapM (mkField 0)
- =<< mkTree tokens
-
- where ls = (lines . normaliseLineEndings) input
- tokens = (concatMap tokeniseLine . trimLines) ls
-
-readFieldsFlat :: String -> ParseResult [Field]
-readFieldsFlat input = mapM (mkField 0)
- =<< mkTree tokens
- where ls = (lines . normaliseLineEndings) input
- tokens = (concatMap tokeniseLineFlat . trimLines) ls
-
--- attach line number and determine indentation
-trimLines :: [String] -> [(LineNo, Indent, HasTabs, String)]
-trimLines ls = [ (lineno, indent, hastabs, (trimTrailing l'))
- | (lineno, l) <- zip [1..] ls
- , let (sps, l') = span isSpace l
- indent = length sps
- hastabs = '\t' `elem` sps
- , validLine l' ]
- where validLine ('-':'-':_) = False -- Comment
- validLine [] = False -- blank line
- validLine _ = True
-
--- | We parse generically based on indent level and braces '{' '}'. To do that
--- we split into lines and then '{' '}' tokens and other spans within a line.
-data Token =
- -- | The 'Line' token is for bits that /start/ a line, eg:
- --
- -- > "\n blah blah { blah"
- --
- -- tokenises to:
- --
- -- > [Line n 2 False "blah blah", OpenBracket, Span n "blah"]
- --
- -- so lines are the only ones that can have nested layout, since they
- -- have a known indentation level.
- --
- -- eg: we can't have this:
- --
- -- > if ... {
- -- > } else
- -- > other
- --
- -- because other cannot nest under else, since else doesn't start a line
- -- so cannot have nested layout. It'd have to be:
- --
- -- > if ... {
- -- > }
- -- > else
- -- > other
- --
- -- but that's not so common, people would normally use layout or
- -- brackets not both in a single @if else@ construct.
- --
- -- > if ... { foo : bar }
- -- > else
- -- > other
- --
- -- this is ok
- Line LineNo Indent HasTabs String
- | Span LineNo String -- ^ span in a line, following brackets
- | OpenBracket LineNo | CloseBracket LineNo
-
-type Indent = Int
-type HasTabs = Bool
-
--- | Tokenise a single line, splitting on '{' '}' and the spans inbetween.
--- Also trims leading & trailing space on those spans within the line.
-tokeniseLine :: (LineNo, Indent, HasTabs, String) -> [Token]
-tokeniseLine (n0, i, t, l) = case split n0 l of
- (Span _ l':ss) -> Line n0 i t l' :ss
- cs -> cs
- where split _ "" = []
- split n s = case span (\c -> c /='}' && c /= '{') s of
- ("", '{' : s') -> OpenBracket n : split n s'
- (w , '{' : s') -> mkspan n w (OpenBracket n : split n s')
- ("", '}' : s') -> CloseBracket n : split n s'
- (w , '}' : s') -> mkspan n w (CloseBracket n : split n s')
- (w , _) -> mkspan n w []
-
- mkspan n s ss | null s' = ss
- | otherwise = Span n s' : ss
- where s' = trimTrailing (trimLeading s)
-
-tokeniseLineFlat :: (LineNo, Indent, HasTabs, String) -> [Token]
-tokeniseLineFlat (n0, i, t, l)
- | null l' = []
- | otherwise = [Line n0 i t l']
- where
- l' = trimTrailing (trimLeading l)
-
-trimLeading, trimTrailing :: String -> String
-trimLeading = dropWhile isSpace
-trimTrailing = reverse . dropWhile isSpace . reverse
-
-
-type SyntaxTree = Tree (LineNo, HasTabs, String)
-
--- | Parse the stream of tokens into a tree of them, based on indent \/ layout
-mkTree :: [Token] -> ParseResult [SyntaxTree]
-mkTree toks =
- layout 0 [] toks >>= \(trees, trailing) -> case trailing of
- [] -> return trees
- OpenBracket n:_ -> syntaxError n "mismatched backets, unexpected {"
- CloseBracket n:_ -> syntaxError n "mismatched backets, unexpected }"
- -- the following two should never happen:
- Span n l :_ -> syntaxError n $ "unexpected span: " ++ show l
- Line n _ _ l :_ -> syntaxError n $ "unexpected line: " ++ show l
-
-
--- | Parse the stream of tokens into a tree of them, based on indent
--- This parse state expect to be in a layout context, though possibly
--- nested within a braces context so we may still encounter closing braces.
-layout :: Indent -- ^ indent level of the parent\/previous line
- -> [SyntaxTree] -- ^ accumulating param, trees in this level
- -> [Token] -- ^ remaining tokens
- -> ParseResult ([SyntaxTree], [Token])
- -- ^ collected trees on this level and trailing tokens
-layout _ a [] = return (reverse a, [])
-layout i a (s@(Line _ i' _ _):ss) | i' < i = return (reverse a, s:ss)
-layout i a (Line n _ t l:OpenBracket n':ss) = do
- (sub, ss') <- braces n' [] ss
- layout i (Node (n,t,l) sub:a) ss'
-
-layout i a (Span n l:OpenBracket n':ss) = do
- (sub, ss') <- braces n' [] ss
- layout i (Node (n,False,l) sub:a) ss'
-
--- look ahead to see if following lines are more indented, giving a sub-tree
-layout i a (Line n i' t l:ss) = do
- lookahead <- layout (i'+1) [] ss
- case lookahead of
- ([], _) -> layout i (Node (n,t,l) [] :a) ss
- (ts, ss') -> layout i (Node (n,t,l) ts :a) ss'
-
-layout _ _ ( OpenBracket n :_) = syntaxError n $ "unexpected '{'"
-layout _ a (s@(CloseBracket _):ss) = return (reverse a, s:ss)
-layout _ _ ( Span n l : _) = syntaxError n $ "unexpected span: "
- ++ show l
-
--- | Parse the stream of tokens into a tree of them, based on explicit braces
--- This parse state expects to find a closing bracket.
-braces :: LineNo -- ^ line of the '{', used for error messages
- -> [SyntaxTree] -- ^ accumulating param, trees in this level
- -> [Token] -- ^ remaining tokens
- -> ParseResult ([SyntaxTree],[Token])
- -- ^ collected trees on this level and trailing tokens
-braces m a (Line n _ t l:OpenBracket n':ss) = do
- (sub, ss') <- braces n' [] ss
- braces m (Node (n,t,l) sub:a) ss'
-
-braces m a (Span n l:OpenBracket n':ss) = do
- (sub, ss') <- braces n' [] ss
- braces m (Node (n,False,l) sub:a) ss'
-
-braces m a (Line n i t l:ss) = do
- lookahead <- layout (i+1) [] ss
- case lookahead of
- ([], _) -> braces m (Node (n,t,l) [] :a) ss
- (ts, ss') -> braces m (Node (n,t,l) ts :a) ss'
-
-braces m a (Span n l:ss) = braces m (Node (n,False,l) []:a) ss
-braces _ a (CloseBracket _:ss) = return (reverse a, ss)
-braces n _ [] = syntaxError n $ "opening brace '{'"
- ++ "has no matching closing brace '}'"
-braces _ _ (OpenBracket n:_) = syntaxError n "unexpected '{'"
-
--- | Convert the parse tree into the Field AST
--- Also check for dodgy uses of tabs in indentation.
-mkField :: Int -> SyntaxTree -> ParseResult Field
-mkField d (Node (n,t,_) _) | d >= 1 && t = tabsError n
-mkField d (Node (n,_,l) ts) = case span (\c -> isAlphaNum c || c == '-') l of
- ([], _) -> syntaxError n $ "unrecognised field or section: " ++ show l
- (name, rest) -> case trimLeading rest of
- (':':rest') -> do let followingLines = concatMap Tree.flatten ts
- tabs = not (null [()| (_,True,_) <- followingLines ])
- if tabs && d >= 1
- then tabsError n
- else return $ F n (map toLower name)
- (fieldValue rest' followingLines)
- rest' -> do ts' <- mapM (mkField (d+1)) ts
- return (Section n (map toLower name) rest' ts')
- where fieldValue firstLine followingLines =
- let firstLine' = trimLeading firstLine
- followingLines' = map (\(_,_,s) -> stripDot s) followingLines
- allLines | null firstLine' = followingLines'
- | otherwise = firstLine' : followingLines'
- in intercalate "\n" allLines
- stripDot "." = ""
- stripDot s = s
-
--- | Convert if/then/else 'Section's to 'IfBlock's
-ifelse :: [Field] -> ParseResult [Field]
-ifelse [] = return []
-ifelse (Section n "if" cond thenpart
- :Section _ "else" as elsepart:fs)
- | null cond = syntaxError n "'if' with missing condition"
- | null thenpart = syntaxError n "'then' branch of 'if' is empty"
- | not (null as) = syntaxError n "'else' takes no arguments"
- | null elsepart = syntaxError n "'else' branch of 'if' is empty"
- | otherwise = do tp <- ifelse thenpart
- ep <- ifelse elsepart
- fs' <- ifelse fs
- return (IfBlock n cond tp ep:fs')
-ifelse (Section n "if" cond thenpart:fs)
- | null cond = syntaxError n "'if' with missing condition"
- | null thenpart = syntaxError n "'then' branch of 'if' is empty"
- | otherwise = do tp <- ifelse thenpart
- fs' <- ifelse fs
- return (IfBlock n cond tp []:fs')
-ifelse (Section n "else" _ _:_) = syntaxError n "stray 'else' with no preceding 'if'"
-ifelse (Section n s a fs':fs) = do fs'' <- ifelse fs'
- fs''' <- ifelse fs
- return (Section n s a fs'' : fs''')
-ifelse (f:fs) = do fs' <- ifelse fs
- return (f : fs')
-
-------------------------------------------------------------------------------
-
--- |parse a module name
-parseModuleNameQ :: ReadP r ModuleName
-parseModuleNameQ = parseQuoted parse <++ parse
-
-parseFilePathQ :: ReadP r FilePath
-parseFilePathQ = parseTokenQ
- -- removed until normalise is no longer broken, was:
- -- liftM normalise parseTokenQ
-
-parseBuildTool :: ReadP r Dependency
-parseBuildTool = do name <- parseBuildToolNameQ
- skipSpaces
- ver <- parseVersionRangeQ <++ return anyVersion
- skipSpaces
- return $ Dependency name ver
-
-parseBuildToolNameQ :: ReadP r PackageName
-parseBuildToolNameQ = parseQuoted parseBuildToolName <++ parseBuildToolName
-
--- like parsePackageName but accepts symbols in components
-parseBuildToolName :: ReadP r PackageName
-parseBuildToolName = do ns <- sepBy1 component (ReadP.char '-')
- return (PackageName (intercalate "-" ns))
- where component = do
- cs <- munch1 (\c -> isAlphaNum c || c == '+' || c == '_')
- if all isDigit cs then pfail else return cs
-
--- pkg-config allows versions and other letters in package names,
--- eg "gtk+-2.0" is a valid pkg-config package _name_.
--- It then has a package version number like 2.10.13
-parsePkgconfigDependency :: ReadP r Dependency
-parsePkgconfigDependency = do name <- munch1 (\c -> isAlphaNum c || c `elem` "+-._")
- skipSpaces
- ver <- parseVersionRangeQ <++ return anyVersion
- skipSpaces
- return $ Dependency (PackageName name) ver
-
-parsePackageNameQ :: ReadP r PackageName
-parsePackageNameQ = parseQuoted parse <++ parse
-
-parseVersionRangeQ :: ReadP r VersionRange
-parseVersionRangeQ = parseQuoted parse <++ parse
-
-parseOptVersion :: ReadP r Version
-parseOptVersion = parseQuoted ver <++ ver
- where ver :: ReadP r Version
- ver = parse <++ return noVersion
- noVersion = Version{ versionBranch=[], versionTags=[] }
-
-parseTestedWithQ :: ReadP r (CompilerFlavor,VersionRange)
-parseTestedWithQ = parseQuoted tw <++ tw
- where
- tw :: ReadP r (CompilerFlavor,VersionRange)
- tw = do compiler <- parseCompilerFlavorCompat
- skipSpaces
- version <- parse <++ return anyVersion
- skipSpaces
- return (compiler,version)
-
-parseLicenseQ :: ReadP r License
-parseLicenseQ = parseQuoted parse <++ parse
-
--- urgh, we can't define optQuotes :: ReadP r a -> ReadP r a
--- because the "compat" version of ReadP isn't quite powerful enough. In
--- particular, the type of <++ is ReadP r r -> ReadP r a -> ReadP r a
--- Hence the trick above to make 'lic' polymorphic.
-
-parseLanguageQ :: ReadP r Language
-parseLanguageQ = parseQuoted parse <++ parse
-
-parseExtensionQ :: ReadP r Extension
-parseExtensionQ = parseQuoted parse <++ parse
-
-parseHaskellString :: ReadP r String
-parseHaskellString = readS_to_P reads
-
-parseTokenQ :: ReadP r String
-parseTokenQ = parseHaskellString <++ munch1 (\x -> not (isSpace x) && x /= ',')
-
-parseTokenQ' :: ReadP r String
-parseTokenQ' = parseHaskellString <++ munch1 (\x -> not (isSpace x))
-
-parseSepList :: ReadP r b
- -> ReadP r a -- ^The parser for the stuff between commas
- -> ReadP r [a]
-parseSepList sepr p = sepBy p separator
- where separator = skipSpaces >> sepr >> skipSpaces
-
-parseSpaceList :: ReadP r a -- ^The parser for the stuff between commas
- -> ReadP r [a]
-parseSpaceList p = sepBy p skipSpaces
-
-parseCommaList :: ReadP r a -- ^The parser for the stuff between commas
- -> ReadP r [a]
-parseCommaList = parseSepList (ReadP.char ',')
-
-parseOptCommaList :: ReadP r a -- ^The parser for the stuff between commas
- -> ReadP r [a]
-parseOptCommaList = parseSepList (optional (ReadP.char ','))
-
-parseQuoted :: ReadP r a -> ReadP r a
-parseQuoted p = between (ReadP.char '"') (ReadP.char '"') p
-
-parseFreeText :: ReadP.ReadP s String
-parseFreeText = ReadP.munch (const True)
-
--- --------------------------------------------
--- ** Pretty printing
-
-showFilePath :: FilePath -> Doc
-showFilePath = showToken
-
-showToken :: String -> Doc
-showToken str
- | not (any dodgy str) &&
- not (null str) = text str
- | otherwise = text (show str)
- where dodgy c = isSpace c || c == ','
-
-showTestedWith :: (CompilerFlavor,VersionRange) -> Doc
-showTestedWith (compiler, version) = text (show compiler) <+> disp version
-
--- | Pretty-print free-format text, ensuring that it is vertically aligned,
--- and with blank lines replaced by dots for correct re-parsing.
-showFreeText :: String -> Doc
-showFreeText "" = empty
-showFreeText ('\n' :r) = text " " $+$ text "." $+$ showFreeText r
-showFreeText s = vcat [text (if null l then "." else l) | l <- lines_ s]
-
--- | 'lines_' breaks a string up into a list of strings at newline
--- characters. The resulting strings do not contain newlines.
-lines_ :: String -> [String]
-lines_ [] = [""]
-lines_ s = let (l, s') = break (== '\n') s
- in l : case s' of
- [] -> []
- (_:s'') -> lines_ s''
diff --git a/cabal/Cabal/Distribution/ReadE.hs b/cabal/Cabal/Distribution/ReadE.hs
deleted file mode 100644
index ce165e2..0000000
--- a/cabal/Cabal/Distribution/ReadE.hs
+++ /dev/null
@@ -1,81 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Distribution.ReadE
--- Copyright : Jose Iborra 2008
---
--- Maintainer : cabal-devel@haskell.org
--- Portability : portable
---
--- Simple parsing with failure
-
-{- Copyright (c) 2007, Jose Iborra
-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.ReadE (
- -- * ReadE
- ReadE(..), succeedReadE, failReadE,
- -- * Projections
- parseReadE, readEOrFail,
- readP_to_E
- ) where
-
-import Distribution.Compat.ReadP
-import Data.Char ( isSpace )
-
--- | Parser with simple error reporting
-newtype ReadE a = ReadE {runReadE :: String -> Either ErrorMsg a}
-type ErrorMsg = String
-
-instance Functor ReadE where
- fmap f (ReadE p) = ReadE $ \txt -> case p txt of
- Right a -> Right (f a)
- Left err -> Left err
-
-succeedReadE :: (String -> a) -> ReadE a
-succeedReadE f = ReadE (Right . f)
-
-failReadE :: ErrorMsg -> ReadE a
-failReadE = ReadE . const Left
-
-parseReadE :: ReadE a -> ReadP r a
-parseReadE (ReadE p) = do
- txt <- look
- either fail return (p txt)
-
-readEOrFail :: ReadE a -> (String -> a)
-readEOrFail r = either error id . runReadE r
-
-readP_to_E :: (String -> ErrorMsg) -> ReadP a a -> ReadE a
-readP_to_E err r =
- ReadE $ \txt -> case [ p | (p, s) <- readP_to_S r txt
- , all isSpace s ]
- of [] -> Left (err txt)
- (p:_) -> Right p
diff --git a/cabal/Cabal/Distribution/Simple.hs b/cabal/Cabal/Distribution/Simple.hs
deleted file mode 100644
index fef0523..0000000
--- a/cabal/Cabal/Distribution/Simple.hs
+++ /dev/null
@@ -1,703 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Distribution.Simple
--- Copyright : Isaac Jones 2003-2005
---
--- Maintainer : cabal-devel@haskell.org
--- Portability : portable
---
--- This is the command line front end to the Simple build system. When given
--- the parsed command-line args and package information, is able to perform
--- basic commands like configure, build, install, register, etc.
---
--- This module exports the main functions that Setup.hs scripts use. It
--- re-exports the 'UserHooks' type, the standard entry points like
--- 'defaultMain' and 'defaultMainWithHooks' and the predefined sets of
--- 'UserHooks' that custom @Setup.hs@ scripts can extend to add their own
--- behaviour.
---
--- This module isn't called \"Simple\" because it's simple. Far from
--- it. It's called \"Simple\" because it does complicated things to
--- simple software.
---
--- The original idea was that there could be different build systems that all
--- presented the same compatible command line interfaces. There is still a
--- "Distribution.Make" system but in practice no packages use it.
-
-{- 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. -}
-
-{-
-Work around this warning:
-libraries/Cabal/Distribution/Simple.hs:78:0:
- Warning: In the use of `runTests'
- (imported from Distribution.Simple.UserHooks):
- Deprecated: "Please use the new testing interface instead!"
--}
-{-# OPTIONS_GHC -fno-warn-deprecations #-}
-
-module Distribution.Simple (
- module Distribution.Package,
- module Distribution.Version,
- module Distribution.License,
- module Distribution.Simple.Compiler,
- module Language.Haskell.Extension,
- -- * Simple interface
- defaultMain, defaultMainNoRead, defaultMainArgs,
- -- * Customization
- UserHooks(..), Args,
- defaultMainWithHooks, defaultMainWithHooksArgs,
- -- ** Standard sets of hooks
- simpleUserHooks,
- autoconfUserHooks,
- defaultUserHooks, emptyUserHooks,
- -- ** Utils
- defaultHookedPackageDesc
- ) where
-
--- local
-import Distribution.Simple.Compiler hiding (Flag)
-import Distribution.Simple.UserHooks
-import Distribution.Package --must not specify imports, since we're exporting moule.
-import Distribution.PackageDescription
- ( PackageDescription(..), GenericPackageDescription, Executable(..)
- , updatePackageDescription, hasLibs
- , HookedBuildInfo, emptyHookedBuildInfo )
-import Distribution.PackageDescription.Parse
- ( readPackageDescription, readHookedBuildInfo )
-import Distribution.PackageDescription.Configuration
- ( flattenPackageDescription )
-import Distribution.Simple.Program
- ( defaultProgramConfiguration, addKnownPrograms, builtinPrograms
- , restoreProgramConfiguration, reconfigurePrograms )
-import Distribution.Simple.PreProcess (knownSuffixHandlers, PPSuffixHandler)
-import Distribution.Simple.Setup
-import Distribution.Simple.Command
-
-import Distribution.Simple.Build ( build )
-import Distribution.Simple.SrcDist ( sdist )
-import Distribution.Simple.Register
- ( register, unregister )
-
-import Distribution.Simple.Configure
- ( getPersistBuildConfig, maybeGetPersistBuildConfig
- , writePersistBuildConfig, checkPersistBuildConfigOutdated
- , 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)
-import Distribution.Simple.Haddock (haddock, hscolour)
-import Distribution.Simple.Utils
- (die, notice, info, warn, setupMessage, chattyTry,
- defaultPackageDesc, defaultHookedPackageDesc,
- rawSystemExitWithEnv, cabalVersion, topHandler )
-import Distribution.System
- ( OS(..), buildOS )
-import Distribution.Verbosity
-import Language.Haskell.Extension
-import Distribution.Version
-import Distribution.License
-import Distribution.Text
- ( display )
-
--- Base
-import System.Environment(getArgs, getProgName, getEnvironment)
-import System.Directory(removeFile, doesFileExist,
- doesDirectoryExist, removeDirectoryRecursive)
-import System.Exit
-import System.IO.Error (isDoesNotExistError)
-import Distribution.Compat.Exception (catchIO, throwIOIO)
-
-import Control.Monad (when)
-import Data.List (intersperse, unionBy, nub, (\\))
-
--- | A simple implementation of @main@ for a Cabal setup script.
--- It reads the package description file using IO, and performs the
--- action specified on the command line.
-defaultMain :: IO ()
-defaultMain = getArgs >>= defaultMainHelper simpleUserHooks
-
--- | A version of 'defaultMain' that is passed the command line
--- arguments, rather than getting them from the environment.
-defaultMainArgs :: [String] -> IO ()
-defaultMainArgs = defaultMainHelper simpleUserHooks
-
--- | A customizable version of 'defaultMain'.
-defaultMainWithHooks :: UserHooks -> IO ()
-defaultMainWithHooks hooks = getArgs >>= defaultMainHelper hooks
-
--- | A customizable version of 'defaultMain' that also takes the command
--- line arguments.
-defaultMainWithHooksArgs :: UserHooks -> [String] -> IO ()
-defaultMainWithHooksArgs = defaultMainHelper
-
--- | Like 'defaultMain', but accepts the package description as input
--- rather than using IO to read it.
-defaultMainNoRead :: GenericPackageDescription -> IO ()
-defaultMainNoRead pkg_descr =
- getArgs >>=
- defaultMainHelper simpleUserHooks { readDesc = return (Just pkg_descr) }
-
-defaultMainHelper :: UserHooks -> Args -> IO ()
-defaultMainHelper hooks args = topHandler $
- case commandsRun globalCommand commands args of
- CommandHelp help -> printHelp help
- CommandList opts -> printOptionsList opts
- CommandErrors errs -> printErrors errs
- CommandReadyToGo (flags, commandParse) ->
- case commandParse of
- _ | fromFlag (globalVersion flags) -> printVersion
- | fromFlag (globalNumericVersion flags) -> printNumericVersion
- CommandHelp help -> printHelp help
- CommandList opts -> printOptionsList opts
- CommandErrors errs -> printErrors errs
- CommandReadyToGo action -> action
-
- where
- printHelp help = getProgName >>= putStr . help
- printOptionsList = putStr . unlines
- printErrors errs = do
- putStr (concat (intersperse "\n" errs))
- exitWith (ExitFailure 1)
- printNumericVersion = putStrLn $ display cabalVersion
- printVersion = putStrLn $ "Cabal library version "
- ++ display cabalVersion
-
- progs = addKnownPrograms (hookedPrograms hooks) defaultProgramConfiguration
- commands =
- [configureCommand progs `commandAddAction` \fs as ->
- configureAction hooks fs as >> return ()
- ,buildCommand progs `commandAddAction` buildAction hooks
- ,installCommand `commandAddAction` installAction hooks
- ,copyCommand `commandAddAction` copyAction hooks
- ,haddockCommand `commandAddAction` haddockAction hooks
- ,cleanCommand `commandAddAction` cleanAction hooks
- ,sdistCommand `commandAddAction` sdistAction hooks
- ,hscolourCommand `commandAddAction` hscolourAction hooks
- ,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
--- preprocessors built into cabal.
-allSuffixHandlers :: UserHooks
- -> [PPSuffixHandler]
-allSuffixHandlers hooks
- = overridesPP (hookedPreProcessors hooks) knownSuffixHandlers
- where
- overridesPP :: [PPSuffixHandler] -> [PPSuffixHandler] -> [PPSuffixHandler]
- overridesPP = unionBy (\x y -> fst x == fst y)
-
-configureAction :: UserHooks -> ConfigFlags -> Args -> IO LocalBuildInfo
-configureAction hooks flags args = do
- let distPref = fromFlag $ configDistPref flags
- pbi <- preConf hooks args flags
-
- (mb_pd_file, pkg_descr0) <- confPkgDescr
-
- -- get_pkg_descr (configVerbosity flags')
- --let pkg_descr = updatePackageDescription pbi pkg_descr0
- let epkg_descr = (pkg_descr0, pbi)
-
- --(warns, ers) <- sanityCheckPackage pkg_descr
- --errorOut (configVerbosity flags') warns ers
-
- localbuildinfo0 <- confHook hooks epkg_descr flags
-
- -- remember the .cabal filename if we know it
- -- and all the extra command line args
- let localbuildinfo = localbuildinfo0 {
- pkgDescrFile = mb_pd_file,
- extraConfigArgs = args
- }
- writePersistBuildConfig distPref localbuildinfo
-
- let pkg_descr = localPkgDescr localbuildinfo
- postConf hooks args flags pkg_descr localbuildinfo
- return localbuildinfo
- where
- verbosity = fromFlag (configVerbosity flags)
- confPkgDescr :: IO (Maybe FilePath, GenericPackageDescription)
- confPkgDescr = do
- mdescr <- readDesc hooks
- case mdescr of
- Just descr -> return (Nothing, descr)
- Nothing -> do
- pdfile <- defaultPackageDesc verbosity
- descr <- readPackageDescription verbosity pdfile
- return (Just pdfile, descr)
-
-buildAction :: UserHooks -> BuildFlags -> Args -> IO ()
-buildAction hooks flags args = do
- let distPref = fromFlag $ buildDistPref flags
- verbosity = fromFlag $ buildVerbosity flags
-
- lbi <- getBuildConfig hooks verbosity distPref
- progs <- reconfigurePrograms verbosity
- (buildProgramPaths flags)
- (buildProgramArgs flags)
- (withPrograms lbi)
-
- hookedAction preBuild buildHook postBuild
- (return lbi { withPrograms = progs })
- hooks flags args
-
-hscolourAction :: UserHooks -> HscolourFlags -> Args -> IO ()
-hscolourAction hooks flags args
- = do let distPref = fromFlag $ hscolourDistPref flags
- verbosity = fromFlag $ hscolourVerbosity flags
- hookedAction preHscolour hscolourHook postHscolour
- (getBuildConfig hooks verbosity distPref)
- hooks flags args
-
-haddockAction :: UserHooks -> HaddockFlags -> Args -> IO ()
-haddockAction hooks flags args = do
- let distPref = fromFlag $ haddockDistPref flags
- verbosity = fromFlag $ haddockVerbosity flags
-
- lbi <- getBuildConfig hooks verbosity distPref
- progs <- reconfigurePrograms verbosity
- (haddockProgramPaths flags)
- (haddockProgramArgs flags)
- (withPrograms lbi)
-
- hookedAction preHaddock haddockHook postHaddock
- (return lbi { withPrograms = progs })
- hooks flags args
-
-cleanAction :: UserHooks -> CleanFlags -> Args -> IO ()
-cleanAction hooks flags args = do
- pbi <- preClean hooks args flags
-
- pdfile <- defaultPackageDesc verbosity
- ppd <- readPackageDescription verbosity pdfile
- let pkg_descr0 = flattenPackageDescription ppd
- -- We don't sanity check for clean as an error
- -- here would prevent cleaning:
- --sanityCheckHookedBuildInfo pkg_descr0 pbi
- let pkg_descr = updatePackageDescription pbi pkg_descr0
-
- cleanHook hooks pkg_descr () hooks flags
- postClean hooks args flags pkg_descr ()
- where verbosity = fromFlag (cleanVerbosity flags)
-
-copyAction :: UserHooks -> CopyFlags -> Args -> IO ()
-copyAction hooks flags args
- = do let distPref = fromFlag $ copyDistPref flags
- verbosity = fromFlag $ copyVerbosity flags
- hookedAction preCopy copyHook postCopy
- (getBuildConfig hooks verbosity distPref)
- hooks flags args
-
-installAction :: UserHooks -> InstallFlags -> Args -> IO ()
-installAction hooks flags args
- = do let distPref = fromFlag $ installDistPref flags
- verbosity = fromFlag $ installVerbosity flags
- hookedAction preInst instHook postInst
- (getBuildConfig hooks verbosity distPref)
- hooks flags args
-
-sdistAction :: UserHooks -> SDistFlags -> Args -> IO ()
-sdistAction hooks flags args = do
- let distPref = fromFlag $ sDistDistPref flags
- pbi <- preSDist hooks args flags
-
- mlbi <- maybeGetPersistBuildConfig distPref
- pdfile <- defaultPackageDesc verbosity
- ppd <- readPackageDescription verbosity pdfile
- let pkg_descr0 = flattenPackageDescription ppd
- sanityCheckHookedBuildInfo pkg_descr0 pbi
- let pkg_descr = updatePackageDescription pbi pkg_descr0
-
- sDistHook hooks pkg_descr mlbi hooks flags
- postSDist hooks args flags pkg_descr mlbi
- where verbosity = fromFlag (sDistVerbosity flags)
-
-testAction :: UserHooks -> TestFlags -> Args -> IO ()
-testAction hooks flags args = do
- let distPref = fromFlag $ testDistPref flags
- verbosity = fromFlag $ testVerbosity flags
- localBuildInfo <- getBuildConfig hooks verbosity distPref
- let pkg_descr = localPkgDescr localBuildInfo
- -- It is safe to do 'runTests' before the new test handler because the
- -- default action is a no-op and if the package uses the old test interface
- -- the new handler will find no tests.
- runTests hooks args False pkg_descr localBuildInfo
- --FIXME: this is a hack, passing the args inside the flags
- -- it's because the args to not get passed to the main test hook
- let flags' = flags { testList = Flag args }
- hookedAction preTest testHook postTest
- (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
- verbosity = fromFlag $ regVerbosity flags
- hookedAction preReg regHook postReg
- (getBuildConfig hooks verbosity distPref)
- hooks flags args
-
-unregisterAction :: UserHooks -> RegisterFlags -> Args -> IO ()
-unregisterAction hooks flags args
- = do let distPref = fromFlag $ regDistPref flags
- verbosity = fromFlag $ regVerbosity flags
- hookedAction preUnreg unregHook postUnreg
- (getBuildConfig hooks verbosity distPref)
- hooks flags args
-
-hookedAction :: (UserHooks -> Args -> flags -> IO HookedBuildInfo)
- -> (UserHooks -> PackageDescription -> LocalBuildInfo
- -> UserHooks -> flags -> IO ())
- -> (UserHooks -> Args -> flags -> PackageDescription
- -> LocalBuildInfo -> IO ())
- -> IO LocalBuildInfo
- -> UserHooks -> flags -> Args -> IO ()
-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
- --pkg_descr0 <- get_pkg_descr (get_verbose flags)
- sanityCheckHookedBuildInfo pkg_descr0 pbi
- let pkg_descr = updatePackageDescription pbi pkg_descr0
- -- TODO: should we write the modified package descr back to the
- -- localbuildinfo?
- cmd_hook hooks args pkg_descr localbuildinfo hooks flags
- post_hook hooks args flags pkg_descr localbuildinfo
-
-sanityCheckHookedBuildInfo :: PackageDescription -> HookedBuildInfo -> IO ()
-sanityCheckHookedBuildInfo PackageDescription { library = Nothing } (Just _,_)
- = die $ "The buildinfo contains info for a library, "
- ++ "but the package does not have a library."
-
-sanityCheckHookedBuildInfo pkg_descr (_, hookExes)
- | not (null nonExistant)
- = die $ "The buildinfo contains info for an executable called '"
- ++ head nonExistant ++ "' but the package does not have a "
- ++ "executable with that name."
- where
- pkgExeNames = nub (map exeName (executables pkg_descr))
- hookExeNames = nub (map fst hookExes)
- nonExistant = hookExeNames \\ pkgExeNames
-
-sanityCheckHookedBuildInfo _ _ = return ()
-
-
-getBuildConfig :: UserHooks -> Verbosity -> FilePath -> IO LocalBuildInfo
-getBuildConfig hooks verbosity distPref = do
- lbi_wo_programs <- getPersistBuildConfig distPref
- -- Restore info about unconfigured programs, since it is not serialized
- let lbi = lbi_wo_programs {
- withPrograms = restoreProgramConfiguration
- (builtinPrograms ++ hookedPrograms hooks)
- (withPrograms lbi_wo_programs)
- }
-
- case pkgDescrFile lbi of
- Nothing -> return lbi
- Just pkg_descr_file -> do
- outdated <- checkPersistBuildConfigOutdated distPref pkg_descr_file
- if outdated
- then reconfigure pkg_descr_file lbi
- else return lbi
-
- where
- reconfigure :: FilePath -> LocalBuildInfo -> IO LocalBuildInfo
- reconfigure pkg_descr_file lbi = do
- notice verbosity $ pkg_descr_file ++ " has been changed. "
- ++ "Re-configuring with most recently used options. "
- ++ "If this fails, please run configure manually.\n"
- let cFlags = configFlags lbi
- let cFlags' = cFlags {
- -- Since the list of unconfigured programs is not serialized,
- -- restore it to the same value as normally used at the beginning
- -- of a conigure run:
- configPrograms = restoreProgramConfiguration
- (builtinPrograms ++ hookedPrograms hooks)
- (configPrograms cFlags),
-
- -- Use the current, not saved verbosity level:
- configVerbosity = Flag verbosity
- }
- configureAction hooks cFlags' (extraConfigArgs lbi)
-
-
--- --------------------------------------------------------------------------
--- Cleaning
-
-clean :: PackageDescription -> CleanFlags -> IO ()
-clean pkg_descr flags = do
- let distPref = fromFlag $ cleanDistPref flags
- notice verbosity "cleaning..."
-
- maybeConfig <- if fromFlag (cleanSaveConf flags)
- then maybeGetPersistBuildConfig distPref
- else return Nothing
-
- -- remove the whole dist/ directory rather than tracking exactly what files
- -- we created in there.
- chattyTry "removing dist/" $ do
- exists <- doesDirectoryExist distPref
- when exists (removeDirectoryRecursive distPref)
-
- -- Any extra files the user wants to remove
- mapM_ removeFileOrDirectory (extraTmpFiles pkg_descr)
-
- -- If the user wanted to save the config, write it back
- maybe (return ()) (writePersistBuildConfig distPref) maybeConfig
-
- where
- removeFileOrDirectory :: FilePath -> IO ()
- removeFileOrDirectory fname = do
- isDir <- doesDirectoryExist fname
- isFile <- doesFileExist fname
- if isDir then removeDirectoryRecursive fname
- else if isFile then removeFile fname
- else return ()
- verbosity = fromFlag (cleanVerbosity flags)
-
--- --------------------------------------------------------------------------
--- Default hooks
-
--- | Hooks that correspond to a plain instantiation of the
--- \"simple\" build system
-simpleUserHooks :: UserHooks
-simpleUserHooks =
- emptyUserHooks {
- confHook = configure,
- postConf = finalChecks,
- 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,
- hscolourHook = \p l h f -> hscolour p l (allSuffixHandlers h) f,
- haddockHook = \p l h f -> haddock p l (allSuffixHandlers h) f,
- regHook = defaultRegHook,
- unregHook = \p l _ f -> unregister p l f
- }
- where
- finalChecks _args flags pkg_descr lbi =
- checkForeignDeps pkg_descr lbi (lessVerbose verbosity)
- where
- verbosity = fromFlag (configVerbosity flags)
-
--- | Basic autoconf 'UserHooks':
---
--- * 'postConf' runs @.\/configure@, if present.
---
--- * the pre-hooks 'preBuild', 'preClean', 'preCopy', 'preInst',
--- 'preReg' and 'preUnreg' read additional build information from
--- /package/@.buildinfo@, if present.
---
--- Thus @configure@ can use local system information to generate
--- /package/@.buildinfo@ and possibly other files.
-
-{-# DEPRECATED defaultUserHooks
- "Use simpleUserHooks or autoconfUserHooks, unless you need Cabal-1.2\n compatibility in which case you must stick with defaultUserHooks" #-}
-defaultUserHooks :: UserHooks
-defaultUserHooks = autoconfUserHooks {
- confHook = \pkg flags -> do
- let verbosity = fromFlag (configVerbosity flags)
- warn verbosity $
- "defaultUserHooks in Setup script is deprecated."
- confHook autoconfUserHooks pkg flags,
- postConf = oldCompatPostConf
- }
- -- This is the annoying old version that only runs configure if it exists.
- -- It's here for compatibility with existing Setup.hs scripts. See:
- -- http://hackage.haskell.org/trac/hackage/ticket/165
- where oldCompatPostConf args flags pkg_descr lbi
- = do let verbosity = fromFlag (configVerbosity flags)
- noExtraFlags args
- confExists <- doesFileExist "configure"
- when confExists $
- runConfigureScript verbosity
- backwardsCompatHack flags lbi
-
- pbi <- getHookedBuildInfo verbosity
- sanityCheckHookedBuildInfo pkg_descr pbi
- let pkg_descr' = updatePackageDescription pbi pkg_descr
- postConf simpleUserHooks args flags pkg_descr' lbi
-
- backwardsCompatHack = True
-
-autoconfUserHooks :: UserHooks
-autoconfUserHooks
- = simpleUserHooks
- {
- postConf = defaultPostConf,
- preBuild = readHook buildVerbosity,
- preClean = readHook cleanVerbosity,
- preCopy = readHook copyVerbosity,
- preInst = readHook installVerbosity,
- preHscolour = readHook hscolourVerbosity,
- preHaddock = readHook haddockVerbosity,
- preReg = readHook regVerbosity,
- preUnreg = readHook regVerbosity
- }
- where defaultPostConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO ()
- defaultPostConf args flags pkg_descr lbi
- = do let verbosity = fromFlag (configVerbosity flags)
- noExtraFlags args
- confExists <- doesFileExist "configure"
- if confExists
- then runConfigureScript verbosity
- backwardsCompatHack flags lbi
- else die "configure script not found."
-
- pbi <- getHookedBuildInfo verbosity
- sanityCheckHookedBuildInfo pkg_descr pbi
- let pkg_descr' = updatePackageDescription pbi pkg_descr
- postConf simpleUserHooks args flags pkg_descr' lbi
-
- backwardsCompatHack = False
-
- readHook :: (a -> Flag Verbosity) -> Args -> a -> IO HookedBuildInfo
- readHook get_verbosity a flags = do
- noExtraFlags a
- getHookedBuildInfo verbosity
- where
- verbosity = fromFlag (get_verbosity flags)
-
-runConfigureScript :: Verbosity -> Bool -> ConfigFlags -> LocalBuildInfo
- -> IO ()
-runConfigureScript verbosity backwardsCompatHack flags lbi = do
-
- env <- getEnvironment
- let programConfig = withPrograms lbi
- (ccProg, ccFlags) <- configureCCompiler verbosity programConfig
- -- The C compiler's compilation and linker flags (e.g.
- -- "C compiler flags" and "Gcc Linker flags" from GHC) have already
- -- been merged into ccFlags, so we set both CFLAGS and LDFLAGS
- -- to ccFlags
- -- We don't try and tell configure which ld to use, as we don't have
- -- a way to pass its flags too
- let env' = appendToEnvironment ("CFLAGS", unwords ccFlags)
- env
- args' = args ++ ["--with-gcc=" ++ ccProg]
- handleNoWindowsSH $
- rawSystemExitWithEnv verbosity "sh" args' env'
-
- where
- args = "configure" : configureArgs backwardsCompatHack flags
-
- appendToEnvironment (key, val) [] = [(key, val)]
- appendToEnvironment (key, val) (kv@(k, v) : rest)
- | key == k = (key, v ++ " " ++ val) : rest
- | otherwise = kv : appendToEnvironment (key, val) rest
-
- handleNoWindowsSH action
- | buildOS /= Windows
- = action
-
- | otherwise
- = action
- `catchIO` \ioe -> if isDoesNotExistError ioe
- then die notFoundMsg
- else throwIOIO ioe
-
- notFoundMsg = "The package has a './configure' script. This requires a "
- ++ "Unix compatibility toolchain such as MinGW+MSYS or Cygwin."
-
-getHookedBuildInfo :: Verbosity -> IO HookedBuildInfo
-getHookedBuildInfo verbosity = do
- maybe_infoFile <- defaultHookedPackageDesc
- case maybe_infoFile of
- Nothing -> return emptyHookedBuildInfo
- Just infoFile -> do
- info verbosity $ "Reading parameters from " ++ infoFile
- readHookedBuildInfo verbosity infoFile
-
-defaultTestHook :: PackageDescription -> LocalBuildInfo
- -> UserHooks -> TestFlags -> IO ()
-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
- let copyFlags = defaultCopyFlags {
- copyDistPref = installDistPref flags,
- copyDest = toFlag NoCopyDest,
- copyVerbosity = installVerbosity flags
- }
- install pkg_descr localbuildinfo copyFlags
- let registerFlags = defaultRegisterFlags {
- regDistPref = installDistPref flags,
- regInPlace = installInPlace flags,
- regPackageDB = installPackageDB flags,
- regVerbosity = installVerbosity flags
- }
- when (hasLibs pkg_descr) $ register pkg_descr localbuildinfo registerFlags
-
-defaultBuildHook :: PackageDescription -> LocalBuildInfo
- -> UserHooks -> BuildFlags -> IO ()
-defaultBuildHook pkg_descr localbuildinfo hooks flags =
- build pkg_descr localbuildinfo flags (allSuffixHandlers hooks)
-
-defaultRegHook :: PackageDescription -> LocalBuildInfo
- -> UserHooks -> RegisterFlags -> IO ()
-defaultRegHook pkg_descr localbuildinfo _ flags =
- if hasLibs pkg_descr
- then register pkg_descr localbuildinfo flags
- else setupMessage verbosity
- "Package contains no library to register:" (packageId pkg_descr)
- where verbosity = fromFlag (regVerbosity flags)
diff --git a/cabal/Cabal/Distribution/Simple/Bench.hs b/cabal/Cabal/Distribution/Simple/Bench.hs
deleted file mode 100644
index f34c888..0000000
--- a/cabal/Cabal/Distribution/Simple/Bench.hs
+++ /dev/null
@@ -1,156 +0,0 @@
------------------------------------------------------------------------------
--- |
--- 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
deleted file mode 100644
index 6fbcfb1..0000000
--- a/cabal/Cabal/Distribution/Simple/Build.hs
+++ /dev/null
@@ -1,349 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Distribution.Simple.Build
--- Copyright : Isaac Jones 2003-2005,
--- Ross Paterson 2006,
--- Duncan Coutts 2007-2008
---
--- Maintainer : cabal-devel@haskell.org
--- Portability : portable
---
--- This is the entry point to actually building the modules in a package. It
--- doesn't actually do much itself, most of the work is delegated to
--- compiler-specific actions. It does do some non-compiler specific bits like
--- running pre-processors.
---
-
-{- Copyright (c) 2003-2005, Isaac Jones
-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.Build (
- build,
-
- initialBuildSteps,
- writeAutogenFiles,
- ) where
-
-import qualified Distribution.Simple.GHC as GHC
-import qualified Distribution.Simple.JHC as JHC
-import qualified Distribution.Simple.LHC as LHC
-import qualified Distribution.Simple.NHC as NHC
-import qualified Distribution.Simple.Hugs as Hugs
-import qualified Distribution.Simple.UHC as UHC
-
-import qualified Distribution.Simple.Build.Macros as Build.Macros
-import qualified Distribution.Simple.Build.PathsModule as Build.PathsModule
-
-import Distribution.Package
- ( Package(..), PackageName(..), PackageIdentifier(..)
- , Dependency(..), thisPackageVersion )
-import Distribution.Simple.Compiler
- ( CompilerFlavor(..), compilerFlavor, PackageDB(..) )
-import Distribution.PackageDescription
- ( PackageDescription(..), BuildInfo(..), Library(..), Executable(..)
- , TestSuite(..), TestSuiteInterface(..), Benchmark(..)
- , BenchmarkInterface(..) )
-import qualified Distribution.InstalledPackageInfo as IPI
-import qualified Distribution.ModuleName as ModuleName
-
-import Distribution.Simple.Setup
- ( BuildFlags(..), fromFlag )
-import Distribution.Simple.PreProcess
- ( preprocessComponent, PPSuffixHandler )
-import Distribution.Simple.LocalBuildInfo
- ( LocalBuildInfo(compiler, buildDir, withPackageDB, withPrograms)
- , Component(..), ComponentLocalBuildInfo(..), withComponentsLBI
- , componentBuildInfo, inplacePackageId )
-import Distribution.Simple.Program.Types
-import Distribution.Simple.Program.Db
-import Distribution.Simple.BuildPaths
- ( autogenModulesDir, autogenModuleName, cppHeaderName, exeExtension )
-import Distribution.Simple.Register
- ( registerPackage, inplaceInstalledPackageInfo )
-import Distribution.Simple.Test ( stubFilePath, stubName )
-import Distribution.Simple.Utils
- ( createDirectoryIfMissingVerbose, rewriteFile
- , die, info, setupMessage )
-
-import Distribution.Verbosity
- ( Verbosity )
-import Distribution.Text
- ( display )
-
-import Data.Maybe
- ( maybeToList )
-import Data.List
- ( intersect )
-import Control.Monad
- ( unless )
-import System.FilePath
- ( (</>), (<.>) )
-import System.Directory
- ( getCurrentDirectory )
-
--- -----------------------------------------------------------------------------
--- |Build the libraries and executables in this package.
-
-build :: PackageDescription -- ^ Mostly information from the .cabal file
- -> LocalBuildInfo -- ^ Configuration information
- -> BuildFlags -- ^ Flags that the user passed to build
- -> [ PPSuffixHandler ] -- ^ preprocessors to run before compiling
- -> IO ()
-build pkg_descr lbi flags suffixes = do
- let distPref = fromFlag (buildDistPref flags)
- verbosity = fromFlag (buildVerbosity flags)
- initialBuildSteps distPref pkg_descr lbi verbosity
- setupMessage verbosity "Building" (packageId pkg_descr)
-
- internalPackageDB <- createInternalPackageDB distPref
-
- 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
- }
- 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.
-createInternalPackageDB :: FilePath -> IO PackageDB
-createInternalPackageDB distPref = do
- let dbFile = distPref </> "package.conf.inplace"
- packageDB = SpecificPackageDB dbFile
- 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
- -> Library -> ComponentLocalBuildInfo -> IO ()
-buildLib verbosity pkg_descr lbi lib clbi =
- case compilerFlavor (compiler lbi) of
- GHC -> GHC.buildLib verbosity pkg_descr lbi lib clbi
- JHC -> JHC.buildLib verbosity pkg_descr lbi lib clbi
- LHC -> LHC.buildLib verbosity pkg_descr lbi lib clbi
- Hugs -> Hugs.buildLib verbosity pkg_descr lbi lib clbi
- NHC -> NHC.buildLib verbosity pkg_descr lbi lib clbi
- UHC -> UHC.buildLib verbosity pkg_descr lbi lib clbi
- _ -> die "Building is not supported with this compiler."
-
-buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo
- -> Executable -> ComponentLocalBuildInfo -> IO ()
-buildExe verbosity pkg_descr lbi exe clbi =
- case compilerFlavor (compiler lbi) of
- GHC -> GHC.buildExe verbosity pkg_descr lbi exe clbi
- JHC -> JHC.buildExe verbosity pkg_descr lbi exe clbi
- LHC -> LHC.buildExe verbosity pkg_descr lbi exe clbi
- Hugs -> Hugs.buildExe verbosity pkg_descr lbi exe clbi
- NHC -> NHC.buildExe verbosity pkg_descr lbi exe clbi
- UHC -> UHC.buildExe verbosity pkg_descr lbi exe clbi
- _ -> die "Building is not supported with this compiler."
-
-initialBuildSteps :: FilePath -- ^"dist" prefix
- -> PackageDescription -- ^mostly information from the .cabal file
- -> LocalBuildInfo -- ^Configuration information
- -> Verbosity -- ^The verbosity to use
- -> IO ()
-initialBuildSteps _distPref pkg_descr lbi verbosity = do
- -- check that there's something to build
- let buildInfos =
- map libBuildInfo (maybeToList (library pkg_descr)) ++
- map buildInfo (executables pkg_descr)
- unless (any buildable buildInfos) $ do
- let name = display (packageId pkg_descr)
- die ("Package " ++ name ++ " can't be built on this system.")
-
- createDirectoryIfMissingVerbose verbosity True (buildDir lbi)
-
- writeAutogenFiles verbosity pkg_descr lbi
-
--- | Generate and write out the Paths_<pkg>.hs and cabal_macros.h files
---
-writeAutogenFiles :: Verbosity
- -> PackageDescription
- -> LocalBuildInfo
- -> IO ()
-writeAutogenFiles verbosity pkg lbi = do
- createDirectoryIfMissingVerbose verbosity True (autogenModulesDir lbi)
-
- let pathsModulePath = autogenModulesDir lbi
- </> ModuleName.toFilePath (autogenModuleName pkg) <.> "hs"
- rewriteFile pathsModulePath (Build.PathsModule.generate pkg lbi)
-
- let cppHeaderPath = autogenModulesDir lbi </> cppHeaderName
- rewriteFile cppHeaderPath (Build.Macros.generate pkg lbi)
diff --git a/cabal/Cabal/Distribution/Simple/Build/Macros.hs b/cabal/Cabal/Distribution/Simple/Build/Macros.hs
deleted file mode 100644
index 58e2ed4..0000000
--- a/cabal/Cabal/Distribution/Simple/Build/Macros.hs
+++ /dev/null
@@ -1,57 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Distribution.Simple.Build.Macros
--- Copyright : Simon Marlow 2008
---
--- Maintainer : cabal-devel@haskell.org
--- Portability : portable
---
--- Generate cabal_macros.h - CPP macros for package version testing
---
--- When using CPP you get
---
--- > VERSION_<package>
--- > MIN_VERSION_<package>(A,B,C)
---
--- for each /package/ in @build-depends@, which is true if the version of
--- /package/ in use is @>= A.B.C@, using the normal ordering on version
--- numbers.
---
-module Distribution.Simple.Build.Macros (
- generate
- ) where
-
-import Distribution.Package
- ( PackageIdentifier(PackageIdentifier) )
-import Distribution.Version
- ( Version(versionBranch) )
-import Distribution.PackageDescription
- ( PackageDescription )
-import Distribution.Simple.LocalBuildInfo
- ( LocalBuildInfo, externalPackageDeps )
-import Distribution.Text
- ( display )
-
--- ------------------------------------------------------------
--- * Generate cabal_macros.h
--- ------------------------------------------------------------
-
-generate :: PackageDescription -> LocalBuildInfo -> String
-generate _pkg_descr lbi = concat $
- "/* DO NOT EDIT: This file is automatically generated by Cabal */\n\n" :
- [ concat
- ["/* package ",display pkgid," */\n"
- ,"#define VERSION_",pkgname," ",show (display version),"\n"
- ,"#define MIN_VERSION_",pkgname,"(major1,major2,minor) (\\\n"
- ," (major1) < ",major1," || \\\n"
- ," (major1) == ",major1," && (major2) < ",major2," || \\\n"
- ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"
- ,"\n\n"
- ]
- | (_, pkgid@(PackageIdentifier name version)) <- externalPackageDeps lbi
- , let (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)
- pkgname = map fixchar (display name)
- ]
- where fixchar '-' = '_'
- fixchar c = c
-
diff --git a/cabal/Cabal/Distribution/Simple/Build/PathsModule.hs b/cabal/Cabal/Distribution/Simple/Build/PathsModule.hs
deleted file mode 100644
index 5980ba0..0000000
--- a/cabal/Cabal/Distribution/Simple/Build/PathsModule.hs
+++ /dev/null
@@ -1,262 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Distribution.Simple.Build.Macros
--- Copyright : Isaac Jones 2003-2005,
--- Ross Paterson 2006,
--- Duncan Coutts 2007-2008
---
--- Maintainer : cabal-devel@haskell.org
--- Portability : portable
---
--- Generating the Paths_pkgname module.
---
--- This is a module that Cabal generates for the benefit of packages. It
--- enables them to find their version number and find any installed data files
--- at runtime. This code should probably be split off into another module.
---
-module Distribution.Simple.Build.PathsModule (
- generate, pkgPathEnvVar
- ) where
-
-import Distribution.System
- ( OS(Windows), buildOS, Arch(..), buildArch )
-import Distribution.Simple.Compiler
- ( CompilerFlavor(..), compilerFlavor, compilerVersion )
-import Distribution.Package
- ( packageId, packageName, packageVersion )
-import Distribution.PackageDescription
- ( PackageDescription(..), hasLibs )
-import Distribution.Simple.LocalBuildInfo
- ( LocalBuildInfo(..), InstallDirs(..)
- , absoluteInstallDirs, prefixRelativeInstallDirs )
-import Distribution.Simple.Setup ( CopyDest(NoCopyDest) )
-import Distribution.Simple.BuildPaths
- ( autogenModuleName )
-import Distribution.Text
- ( display )
-import Distribution.Version
- ( Version(..), orLaterVersion, withinRange )
-
-import System.FilePath
- ( pathSeparator )
-import Data.Maybe
- ( fromJust, isNothing )
-
--- ------------------------------------------------------------
--- * Building Paths_<pkg>.hs
--- ------------------------------------------------------------
-
-generate :: PackageDescription -> LocalBuildInfo -> String
-generate pkg_descr lbi =
- let pragmas
- | absolute || isHugs = ""
- | supports_language_pragma =
- "{-# LANGUAGE ForeignFunctionInterface #-}\n"
- | otherwise =
- "{-# OPTIONS_GHC -fffi #-}\n"++
- "{-# OPTIONS_JHC -fffi #-}\n"
-
- foreign_imports
- | absolute = ""
- | isHugs = "import System.Environment\n"
- | otherwise =
- "import Foreign\n"++
- "import Foreign.C\n"
-
- header =
- pragmas++
- "module " ++ display paths_modulename ++ " (\n"++
- " version,\n"++
- " getBinDir, getLibDir, getDataDir, getLibexecDir,\n"++
- " getDataFileName\n"++
- " ) where\n"++
- "\n"++
- foreign_imports++
- "import qualified Control.Exception as Exception\n"++
- "import Data.Version (Version(..))\n"++
- "import System.Environment (getEnv)\n"++
- "import Prelude\n"++
- "\n"++
- "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"++
- "catchIO = Exception.catch\n" ++
- "\n"++
- "\nversion :: Version"++
- "\nversion = " ++ show (packageVersion pkg_descr)
-
- body
- | absolute =
- "\nbindir, libdir, datadir, libexecdir :: FilePath\n"++
- "\nbindir = " ++ show flat_bindir ++
- "\nlibdir = " ++ show flat_libdir ++
- "\ndatadir = " ++ show flat_datadir ++
- "\nlibexecdir = " ++ show flat_libexecdir ++
- "\n"++
- "\ngetBinDir, getLibDir, getDataDir, getLibexecDir :: IO FilePath\n"++
- "getBinDir = "++mkGetEnvOr "bindir" "return bindir"++"\n"++
- "getLibDir = "++mkGetEnvOr "libdir" "return libdir"++"\n"++
- "getDataDir = "++mkGetEnvOr "datadir" "return datadir"++"\n"++
- "getLibexecDir = "++mkGetEnvOr "libexecdir" "return libexecdir"++"\n"++
- "\n"++
- "getDataFileName :: FilePath -> IO FilePath\n"++
- "getDataFileName name = do\n"++
- " dir <- getDataDir\n"++
- " return (dir ++ "++path_sep++" ++ name)\n"
- | otherwise =
- "\nprefix, bindirrel :: FilePath" ++
- "\nprefix = " ++ show flat_prefix ++
- "\nbindirrel = " ++ show (fromJust flat_bindirrel) ++
- "\n\n"++
- "getBinDir :: IO FilePath\n"++
- "getBinDir = getPrefixDirRel bindirrel\n\n"++
- "getLibDir :: IO FilePath\n"++
- "getLibDir = "++mkGetDir flat_libdir flat_libdirrel++"\n\n"++
- "getDataDir :: IO FilePath\n"++
- "getDataDir = "++ mkGetEnvOr "datadir"
- (mkGetDir flat_datadir flat_datadirrel)++"\n\n"++
- "getLibexecDir :: IO FilePath\n"++
- "getLibexecDir = "++mkGetDir flat_libexecdir flat_libexecdirrel++"\n\n"++
- "getDataFileName :: FilePath -> IO FilePath\n"++
- "getDataFileName name = do\n"++
- " dir <- getDataDir\n"++
- " return (dir `joinFileName` name)\n"++
- "\n"++
- get_prefix_stuff++
- "\n"++
- filename_stuff
- in header++body
-
- where
- InstallDirs {
- prefix = flat_prefix,
- bindir = flat_bindir,
- libdir = flat_libdir,
- datadir = flat_datadir,
- libexecdir = flat_libexecdir
- } = absoluteInstallDirs pkg_descr lbi NoCopyDest
- InstallDirs {
- bindir = flat_bindirrel,
- libdir = flat_libdirrel,
- datadir = flat_datadirrel,
- libexecdir = flat_libexecdirrel,
- progdir = flat_progdirrel
- } = prefixRelativeInstallDirs (packageId pkg_descr) lbi
-
- mkGetDir _ (Just dirrel) = "getPrefixDirRel " ++ show dirrel
- mkGetDir dir Nothing = "return " ++ show dir
-
- mkGetEnvOr var expr = "catchIO (getEnv \""++var'++"\")"++
- " (\\_ -> "++expr++")"
- where var' = pkgPathEnvVar pkg_descr var
-
- -- In several cases we cannot make relocatable installations
- absolute =
- hasLibs pkg_descr -- we can only make progs relocatable
- || isNothing flat_bindirrel -- if the bin dir is an absolute path
- || (isHugs && isNothing flat_progdirrel)
- || not (supportsRelocatableProgs (compilerFlavor (compiler lbi)))
-
- supportsRelocatableProgs Hugs = True
- supportsRelocatableProgs GHC = case buildOS of
- Windows -> True
- _ -> False
- supportsRelocatableProgs _ = False
-
- paths_modulename = autogenModuleName pkg_descr
-
- isHugs = compilerFlavor (compiler lbi) == Hugs
- get_prefix_stuff
- | isHugs = "progdirrel :: String\n"++
- "progdirrel = "++show (fromJust flat_progdirrel)++"\n\n"++
- get_prefix_hugs
- | otherwise = get_prefix_win32 buildArch
-
- path_sep = show [pathSeparator]
-
- supports_language_pragma =
- compilerFlavor (compiler lbi) == GHC &&
- (compilerVersion (compiler lbi)
- `withinRange` orLaterVersion (Version [6,6,1] []))
-
--- | Generates the name of the environment variable controlling the path
--- component of interest.
-pkgPathEnvVar :: PackageDescription
- -> String -- ^ path component; one of \"bindir\", \"libdir\",
- -- \"datadir\" or \"libexecdir\"
- -> String -- ^ environment variable name
-pkgPathEnvVar pkg_descr var =
- showPkgName (packageName pkg_descr) ++ "_" ++ var
- where
- showPkgName = map fixchar . display
- fixchar '-' = '_'
- fixchar c = c
-
-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"++
- " try_size size = allocaArray (fromIntegral size) $ \\buf -> do\n"++
- " ret <- c_GetModuleFileName nullPtr buf size\n"++
- " case ret of\n"++
- " 0 -> return (prefix `joinFileName` dirRel)\n"++
- " _ | ret < size -> do\n"++
- " exePath <- peekCWString buf\n"++
- " let (bindir,_) = splitFileName exePath\n"++
- " return ((bindir `minusFileName` bindirrel) `joinFileName` dirRel)\n"++
- " | otherwise -> try_size (size * 2)\n"++
- "\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
-get_prefix_hugs =
- "getPrefixDirRel :: FilePath -> IO FilePath\n"++
- "getPrefixDirRel dirRel = do\n"++
- " mainPath <- getProgName\n"++
- " let (progPath,_) = splitFileName mainPath\n"++
- " let (progdir,_) = splitFileName progPath\n"++
- " return ((progdir `minusFileName` progdirrel) `joinFileName` dirRel)\n"
-
-filename_stuff :: String
-filename_stuff =
- "minusFileName :: FilePath -> String -> FilePath\n"++
- "minusFileName dir \"\" = dir\n"++
- "minusFileName dir \".\" = dir\n"++
- "minusFileName dir suffix =\n"++
- " minusFileName (fst (splitFileName dir)) (fst (splitFileName suffix))\n"++
- "\n"++
- "joinFileName :: String -> String -> FilePath\n"++
- "joinFileName \"\" fname = fname\n"++
- "joinFileName \".\" fname = fname\n"++
- "joinFileName dir \"\" = dir\n"++
- "joinFileName dir fname\n"++
- " | isPathSeparator (last dir) = dir++fname\n"++
- " | otherwise = dir++pathSeparator:fname\n"++
- "\n"++
- "splitFileName :: FilePath -> (String, String)\n"++
- "splitFileName p = (reverse (path2++drive), reverse fname)\n"++
- " where\n"++
- " (path,drive) = case p of\n"++
- " (c:':':p') -> (reverse p',[':',c])\n"++
- " _ -> (reverse p ,\"\")\n"++
- " (fname,path1) = break isPathSeparator path\n"++
- " path2 = case path1 of\n"++
- " [] -> \".\"\n"++
- " [_] -> path1 -- don't remove the trailing slash if \n"++
- " -- there is only one character\n"++
- " (c:path') | isPathSeparator c -> path'\n"++
- " _ -> path1\n"++
- "\n"++
- "pathSeparator :: Char\n"++
- (case buildOS of
- Windows -> "pathSeparator = '\\\\'\n"
- _ -> "pathSeparator = '/'\n") ++
- "\n"++
- "isPathSeparator :: Char -> Bool\n"++
- (case buildOS of
- Windows -> "isPathSeparator c = c == '/' || c == '\\\\'\n"
- _ -> "isPathSeparator c = c == '/'\n")
diff --git a/cabal/Cabal/Distribution/Simple/BuildPaths.hs b/cabal/Cabal/Distribution/Simple/BuildPaths.hs
deleted file mode 100644
index 575545f..0000000
--- a/cabal/Cabal/Distribution/Simple/BuildPaths.hs
+++ /dev/null
@@ -1,150 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Distribution.Simple.BuildPaths
--- Copyright : Isaac Jones 2003-2004,
--- Duncan Coutts 2008
---
--- Maintainer : cabal-devel@haskell.org
--- Portability : portable
---
--- A bunch of dirs, paths and file names used for intermediate build steps.
---
-