summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSergeiTrofimovich <>2016-02-06 22:26:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2016-02-06 22:26:00 (GMT)
commita821d8e8e582926c6f6398527a85a83c59fa9077 (patch)
tree1f855e3dc25befa959ca4c9bd37e62bd01bb64ff
parent7206f745a3d50b593e3c66b6445f9212eb2726fe (diff)
version 0.4.70.4.7
-rw-r--r--Hackage.hs11
-rw-r--r--Main.hs4
-rw-r--r--Merge.hs6
-rw-r--r--Merge/Dependencies.hs40
-rw-r--r--Portage/Cabal.hs6
-rw-r--r--Portage/EBuild.hs6
-rw-r--r--Portage/GHCCore.hs83
-rw-r--r--Portage/Metadata.hs15
-rw-r--r--Portage/Overlay.hs8
-rw-r--r--Status.hs2
-rw-r--r--cabal/.travis.yml67
-rw-r--r--cabal/Cabal/Cabal.cabal112
-rw-r--r--cabal/Cabal/Distribution/Compat/Binary.hs60
-rw-r--r--cabal/Cabal/Distribution/Compat/Binary/Class.hs530
-rw-r--r--cabal/Cabal/Distribution/Compat/Binary/Generic.hs128
-rw-r--r--cabal/Cabal/Distribution/Compat/CreatePipe.hs62
-rw-r--r--cabal/Cabal/Distribution/Compat/Environment.hs69
-rw-r--r--cabal/Cabal/Distribution/Compat/ReadP.hs8
-rw-r--r--cabal/Cabal/Distribution/Compat/TempFile.hs15
-rw-r--r--cabal/Cabal/Distribution/Compiler.hs103
-rw-r--r--cabal/Cabal/Distribution/InstalledPackageInfo.hs204
-rw-r--r--cabal/Cabal/Distribution/Lex.hs55
-rw-r--r--cabal/Cabal/Distribution/License.hs170
-rw-r--r--cabal/Cabal/Distribution/Make.hs35
-rw-r--r--cabal/Cabal/Distribution/ModuleName.hs47
-rw-r--r--cabal/Cabal/Distribution/Package.hs266
-rw-r--r--cabal/Cabal/Distribution/PackageDescription.hs408
-rw-r--r--cabal/Cabal/Distribution/PackageDescription/Check.hs561
-rw-r--r--cabal/Cabal/Distribution/PackageDescription/Configuration.hs61
-rw-r--r--cabal/Cabal/Distribution/PackageDescription/Parse.hs245
-rw-r--r--cabal/Cabal/Distribution/PackageDescription/PrettyPrint.hs155
-rw-r--r--cabal/Cabal/Distribution/ParseUtils.hs127
-rw-r--r--cabal/Cabal/Distribution/ReadE.hs32
-rw-r--r--cabal/Cabal/Distribution/Simple.hs306
-rw-r--r--cabal/Cabal/Distribution/Simple/Bench.hs43
-rw-r--r--cabal/Cabal/Distribution/Simple/Build.hs270
-rw-r--r--cabal/Cabal/Distribution/Simple/Build/Macros.hs16
-rw-r--r--cabal/Cabal/Distribution/Simple/Build/PathsModule.hs113
-rw-r--r--cabal/Cabal/Distribution/Simple/BuildPaths.hs48
-rw-r--r--cabal/Cabal/Distribution/Simple/BuildTarget.hs40
-rw-r--r--cabal/Cabal/Distribution/Simple/CCompiler.hs5
-rw-r--r--cabal/Cabal/Distribution/Simple/Command.hs194
-rw-r--r--cabal/Cabal/Distribution/Simple/Compiler.hs192
-rw-r--r--cabal/Cabal/Distribution/Simple/Configure.hs998
-rw-r--r--cabal/Cabal/Distribution/Simple/GHC.hs1189
-rw-r--r--cabal/Cabal/Distribution/Simple/GHC/IPI641.hs51
-rw-r--r--cabal/Cabal/Distribution/Simple/GHC/IPI642.hs51
-rw-r--r--cabal/Cabal/Distribution/Simple/GHC/ImplInfo.hs111
-rw-r--r--cabal/Cabal/Distribution/Simple/GHC/Internal.hs521
-rw-r--r--cabal/Cabal/Distribution/Simple/GHCJS.hs896
-rw-r--r--cabal/Cabal/Distribution/Simple/Haddock.hs668
-rw-r--r--cabal/Cabal/Distribution/Simple/HaskellSuite.hs10
-rw-r--r--cabal/Cabal/Distribution/Simple/Hpc.hs124
-rw-r--r--cabal/Cabal/Distribution/Simple/Hugs.hs639
-rw-r--r--cabal/Cabal/Distribution/Simple/Install.hs70
-rw-r--r--cabal/Cabal/Distribution/Simple/InstallDirs.hs165
-rw-r--r--cabal/Cabal/Distribution/Simple/JHC.hs42
-rw-r--r--cabal/Cabal/Distribution/Simple/LHC.hs114
-rw-r--r--cabal/Cabal/Distribution/Simple/LocalBuildInfo.hs194
-rw-r--r--cabal/Cabal/Distribution/Simple/NHC.hs436
-rw-r--r--cabal/Cabal/Distribution/Simple/PackageIndex.hs184
-rw-r--r--cabal/Cabal/Distribution/Simple/PreProcess.hs171
-rw-r--r--cabal/Cabal/Distribution/Simple/Program.hs16
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Ar.hs26
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Builtin.hs105
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Db.hs101
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Find.hs1
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/GHC.hs233
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/HcPkg.hs243
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Hpc.hs2
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Internal.hs46
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Run.hs4
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Strip.hs40
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Types.hs24
-rw-r--r--cabal/Cabal/Distribution/Simple/Register.hs289
-rw-r--r--cabal/Cabal/Distribution/Simple/Setup.hs805
-rw-r--r--cabal/Cabal/Distribution/Simple/SrcDist.hs84
-rw-r--r--cabal/Cabal/Distribution/Simple/Test.hs493
-rw-r--r--cabal/Cabal/Distribution/Simple/Test/ExeV10.hs168
-rw-r--r--cabal/Cabal/Distribution/Simple/Test/LibV09.hs262
-rw-r--r--cabal/Cabal/Distribution/Simple/Test/Log.hs161
-rw-r--r--cabal/Cabal/Distribution/Simple/UHC.hs46
-rw-r--r--cabal/Cabal/Distribution/Simple/UserHooks.hs37
-rw-r--r--cabal/Cabal/Distribution/Simple/Utils.hs402
-rw-r--r--cabal/Cabal/Distribution/System.hs46
-rw-r--r--cabal/Cabal/Distribution/TestSuite.hs31
-rw-r--r--cabal/Cabal/Distribution/Text.hs5
-rw-r--r--cabal/Cabal/Distribution/Utils/NubList.hs100
-rw-r--r--cabal/Cabal/Distribution/Verbosity.hs42
-rw-r--r--cabal/Cabal/Distribution/Version.hs148
-rw-r--r--cabal/Cabal/LICENSE5
-rw-r--r--cabal/Cabal/Language/Haskell/Extension.hs98
-rw-r--r--cabal/Cabal/Makefile28
-rw-r--r--cabal/Cabal/README179
-rw-r--r--cabal/Cabal/README.md182
-rw-r--r--cabal/Cabal/cabal.config1
-rw-r--r--cabal/Cabal/changelog76
-rw-r--r--cabal/Cabal/doc/developing-packages.markdown341
-rw-r--r--cabal/Cabal/doc/index.markdown7
-rw-r--r--cabal/Cabal/doc/installing-packages.markdown241
-rw-r--r--cabal/Cabal/doc/misc.markdown24
-rwxr-xr-xcabal/Cabal/misc/gen-extra-source-files.sh2
-rw-r--r--cabal/HACKING25
-rw-r--r--cabal/HACKING.md147
-rw-r--r--cabal/Paths_Cabal.hs2
-rw-r--r--cabal/Paths_cabal_install.hs2
-rw-r--r--cabal/README.md16
-rw-r--r--cabal/cabal-install/Distribution/Client/BuildReports/Anonymous.hs21
-rw-r--r--cabal/cabal-install/Distribution/Client/BuildReports/Storage.hs80
-rw-r--r--cabal/cabal-install/Distribution/Client/BuildReports/Upload.hs62
-rw-r--r--cabal/cabal-install/Distribution/Client/Check.hs10
-rw-r--r--cabal/cabal-install/Distribution/Client/Compat/Environment.hs88
-rw-r--r--cabal/cabal-install/Distribution/Client/Compat/ExecutablePath.hs23
-rw-r--r--cabal/cabal-install/Distribution/Client/Compat/Process.hs5
-rw-r--r--cabal/cabal-install/Distribution/Client/Compat/Time.hs30
-rw-r--r--cabal/cabal-install/Distribution/Client/ComponentDeps.hs142
-rw-r--r--cabal/cabal-install/Distribution/Client/Config.hs577
-rw-r--r--cabal/cabal-install/Distribution/Client/Configure.hs232
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency.hs330
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular.hs15
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Assignment.hs25
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs128
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Configured.hs3
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs37
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs379
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Explore.hs10
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Flag.hs21
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Index.hs24
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs141
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Linking.hs523
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Log.hs5
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Message.hs77
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/PSQ.hs20
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Package.hs58
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs209
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs31
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs98
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs50
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/TopDown.hs237
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/TopDown/Constraints.hs29
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs64
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Types.hs159
-rw-r--r--cabal/cabal-install/Distribution/Client/Exec.hs133
-rw-r--r--cabal/cabal-install/Distribution/Client/Fetch.hs31
-rw-r--r--cabal/cabal-install/Distribution/Client/FetchUtils.hs31
-rw-r--r--cabal/cabal-install/Distribution/Client/Freeze.hs137
-rw-r--r--cabal/cabal-install/Distribution/Client/GZipUtils.hs50
-rw-r--r--cabal/cabal-install/Distribution/Client/Get.hs23
-rw-r--r--cabal/cabal-install/Distribution/Client/Haddock.hs67
-rw-r--r--cabal/cabal-install/Distribution/Client/HttpUtils.hs753
-rw-r--r--cabal/cabal-install/Distribution/Client/IndexUtils.hs224
-rw-r--r--cabal/cabal-install/Distribution/Client/Init.hs270
-rw-r--r--cabal/cabal-install/Distribution/Client/Init/Heuristics.hs100
-rw-r--r--cabal/cabal-install/Distribution/Client/Init/Licenses.hs681
-rw-r--r--cabal/cabal-install/Distribution/Client/Init/Types.hs8
-rw-r--r--cabal/cabal-install/Distribution/Client/Install.hs557
-rw-r--r--cabal/cabal-install/Distribution/Client/InstallPlan.hs594
-rw-r--r--cabal/cabal-install/Distribution/Client/InstallSymlink.hs90
-rw-r--r--cabal/cabal-install/Distribution/Client/List.hs96
-rw-r--r--cabal/cabal-install/Distribution/Client/PackageIndex.hs221
-rw-r--r--cabal/cabal-install/Distribution/Client/ParseUtils.hs13
-rw-r--r--cabal/cabal-install/Distribution/Client/PlanIndex.hs339
-rw-r--r--cabal/cabal-install/Distribution/Client/Run.hs121
-rw-r--r--cabal/cabal-install/Distribution/Client/Sandbox.hs137
-rw-r--r--cabal/cabal-install/Distribution/Client/Sandbox/Index.hs15
-rw-r--r--cabal/cabal-install/Distribution/Client/Sandbox/PackageEnvironment.hs187
-rw-r--r--cabal/cabal-install/Distribution/Client/Sandbox/Timestamp.hs40
-rw-r--r--cabal/cabal-install/Distribution/Client/Sandbox/Types.hs5
-rw-r--r--cabal/cabal-install/Distribution/Client/Setup.hs894
-rw-r--r--cabal/cabal-install/Distribution/Client/SetupWrapper.hs225
-rw-r--r--cabal/cabal-install/Distribution/Client/SrcDist.hs7
-rw-r--r--cabal/cabal-install/Distribution/Client/Tar.hs15
-rw-r--r--cabal/cabal-install/Distribution/Client/Targets.hs73
-rw-r--r--cabal/cabal-install/Distribution/Client/Types.hs175
-rw-r--r--cabal/cabal-install/Distribution/Client/Update.hs66
-rw-r--r--cabal/cabal-install/Distribution/Client/Upload.hs156
-rw-r--r--cabal/cabal-install/Distribution/Client/Utils.hs83
-rw-r--r--cabal/cabal-install/Distribution/Client/Utils/LabeledGraph.hs116
-rw-r--r--cabal/cabal-install/Distribution/Client/Win32SelfUpgrade.hs27
-rw-r--r--cabal/cabal-install/Distribution/Client/World.hs8
-rw-r--r--cabal/cabal-install/Main.hs541
-rw-r--r--cabal/cabal-install/README143
-rw-r--r--cabal/cabal-install/README.md155
-rw-r--r--cabal/cabal-install/bash-completion/cabal52
-rwxr-xr-xcabal/cabal-install/bootstrap.sh345
-rw-r--r--cabal/cabal-install/cabal-install.cabal108
-rw-r--r--cabal/cabal-install/cabal.config1
-rw-r--r--cabal/cabal-install/changelog68
-rw-r--r--cabal/cabal-install/tests/PackageTests.hs95
-rw-r--r--cabal/cabal-install/tests/PackageTests/Exec/Check.hs145
-rw-r--r--cabal/cabal-install/tests/PackageTests/Exec/Foo.hs4
-rw-r--r--cabal/cabal-install/tests/PackageTests/Exec/My.hs5
-rw-r--r--cabal/cabal-install/tests/PackageTests/Exec/my.cabal14
-rw-r--r--cabal/cabal-install/tests/PackageTests/Freeze/Check.hs116
-rw-r--r--cabal/cabal-install/tests/PackageTests/Freeze/my.cabal21
-rw-r--r--cabal/cabal-install/tests/PackageTests/MultipleSource/Check.hs28
-rw-r--r--cabal/cabal-install/tests/PackageTests/MultipleSource/p/LICENSE0
-rw-r--r--cabal/cabal-install/tests/PackageTests/MultipleSource/p/Setup.hs2
-rw-r--r--cabal/cabal-install/tests/PackageTests/MultipleSource/p/p.cabal11
-rw-r--r--cabal/cabal-install/tests/PackageTests/MultipleSource/q/LICENSE0
-rw-r--r--cabal/cabal-install/tests/PackageTests/MultipleSource/q/Setup.hs2
-rw-r--r--cabal/cabal-install/tests/PackageTests/MultipleSource/q/q.cabal11
-rw-r--r--cabal/cabal-install/tests/PackageTests/PackageTester.hs232
-rw-r--r--cabal/cabal-install/tests/UnitTests.hs28
-rw-r--r--cabal/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/DSL.hs322
-rw-r--r--cabal/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/PSQ.hs6
-rw-r--r--cabal/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs360
-rw-r--r--cabal/cabal-install/tests/UnitTests/Distribution/Client/GZipUtils.hs60
-rw-r--r--cabal/cabal-install/tests/UnitTests/Distribution/Client/Sandbox.hs11
-rw-r--r--cabal/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs7
-rw-r--r--cabal/cabal-install/tests/UnitTests/Distribution/Client/UserConfig.hs103
-rwxr-xr-xcabal/setup-dev.sh50
-rw-r--r--cabal/stack.yaml39
-rw-r--r--hackport.cabal44
214 files changed, 21037 insertions, 9701 deletions
diff --git a/Hackage.hs b/Hackage.hs
index 57a5db2..99f62dc 100644
--- a/Hackage.hs
+++ b/Hackage.hs
@@ -17,13 +17,16 @@ import System.FilePath
defaultRepo :: FilePath -> Repo
defaultRepo overlayPath =
Repo {
- repoKind = Left hackage,
+ repoKind = Left defaultRemoteRepo,
repoLocalDir = overlayPath </> ".hackport"
}
+
+-- A copy from cabal-install/Distribution.Client.Config
+defaultRemoteRepo :: RemoteRepo
+defaultRemoteRepo = RemoteRepo name uri () False
where
- hackage = RemoteRepo server_name uri
- server_name = "hackage.haskell.org"
- uri = URI "http:" (Just (URIAuth "" server_name "")) "/packages/archive" "" ""
+ name = "hackage.haskell.org"
+ uri = URI "http:" (Just (URIAuth "" name "")) "/" "" ""
defaultRepoURI :: FilePath -> URI
defaultRepoURI overlayPath =
diff --git a/Main.hs b/Main.hs
index fec2480..2da6200 100644
--- a/Main.hs
+++ b/Main.hs
@@ -24,6 +24,7 @@ import Distribution.Text (display, simpleParse)
import Distribution.Client.Types
import Distribution.Client.Update
+import qualified Distribution.Client.HttpUtils as DCH
import qualified Distribution.Client.PackageIndex as Index
import qualified Distribution.Client.IndexUtils as Index
@@ -300,7 +301,8 @@ updateAction flags extraArgs globalFlags = do
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 ]
+ http_transport <- DCH.configureTransport verbosity Nothing
+ update http_transport verbosity [ defaultRepo overlayPath ]
-----------------------------------------------------------------------
diff --git a/Merge.hs b/Merge.hs
index 58beb92..171e483 100644
--- a/Merge.hs
+++ b/Merge.hs
@@ -204,7 +204,7 @@ mergeGenericPackageDescription verbosity overlayPath cat pkgGenericDesc fetch us
(user_specified_fas, cf_to_iuse_rename) = read_fas requested_cabal_flags
debug verbosity "searching for minimal suitable ghc version"
- (compilerId, ghc_packages, pkgDesc0, _flags, pix) <- case GHCCore.minimumGHCVersionToBuildPackage pkgGenericDesc user_specified_fas of
+ (compiler_info, ghc_packages, pkgDesc0, _flags, pix) <- case GHCCore.minimumGHCVersionToBuildPackage pkgGenericDesc user_specified_fas of
Just v -> return v
Nothing -> let pn = display merged_cabal_pkg_name
cn = display cat
@@ -252,7 +252,7 @@ mergeGenericPackageDescription verbosity overlayPath cat pkgGenericDesc fetch us
, Right (pkgDesc1,fr) <- [GHCCore.finalizePackageDescription f
(GHCCore.dependencySatisfiable pix)
GHCCore.platform
- compilerId
+ compiler_info
[]
pkgGenericDesc]
-- drop circular deps and shipped deps
@@ -330,7 +330,7 @@ mergeGenericPackageDescription verbosity overlayPath cat pkgGenericDesc fetch us
in k e
cabal_to_emerge_dep :: Cabal.PackageDescription -> Merge.EDep
- cabal_to_emerge_dep cabal_pkg = Merge.resolveDependencies overlay cabal_pkg compilerId ghc_packages merged_cabal_pkg_name
+ cabal_to_emerge_dep cabal_pkg = Merge.resolveDependencies overlay cabal_pkg compiler_info ghc_packages merged_cabal_pkg_name
debug verbosity $ "buildDepends pkgDesc0 raw: " ++ Cabal.showPackageDescription pkgDesc0
debug verbosity $ "buildDepends pkgDesc0: " ++ show (map display (Cabal.buildDepends pkgDesc0))
diff --git a/Merge/Dependencies.hs b/Merge/Dependencies.hs
index 3a3eb0e..4581b4b 100644
--- a/Merge/Dependencies.hs
+++ b/Merge/Dependencies.hs
@@ -107,10 +107,10 @@ instance Monoid EDep where
, dep_e = dep_eA `S.union` dep_eB
}
-resolveDependencies :: Portage.Overlay -> PackageDescription -> Cabal.CompilerId
+resolveDependencies :: Portage.Overlay -> PackageDescription -> Cabal.CompilerInfo
-> [Cabal.PackageName] -> Cabal.PackageName
-> EDep
-resolveDependencies overlay pkg compiler ghc_package_names merged_cabal_pkg_name = edeps
+resolveDependencies overlay pkg compiler_info ghc_package_names merged_cabal_pkg_name = edeps
where
-- hasBuildableExes p = any (buildable . buildInfo) . executables $ p
treatAsLibrary :: Bool
@@ -126,9 +126,9 @@ resolveDependencies overlay pkg compiler ghc_package_names merged_cabal_pkg_name
map PN.normalize_depend $
testDependencies overlay pkg ghc_package_names merged_cabal_pkg_name
cabal_dep :: Portage.Dependency
- cabal_dep = cabalDependency overlay pkg compiler
+ cabal_dep = cabalDependency overlay pkg compiler_info
ghc_dep :: Portage.Dependency
- ghc_dep = compilerIdToDependency compiler
+ ghc_dep = compilerInfoToDependency compiler_info
extra_libs :: Portage.Dependency
extra_libs = Portage.DependAllOf $ findCLibs pkg
pkg_config_libs :: [Portage.Dependency]
@@ -197,8 +197,11 @@ haskellDependencies overlay deps =
-- | Select the most restrictive dependency on Cabal, either the .cabal
-- file's descCabalVersion, or the Cabal GHC shipped with.
-cabalDependency :: Portage.Overlay -> PackageDescription -> Cabal.CompilerId -> Portage.Dependency
-cabalDependency overlay pkg ~(Cabal.CompilerId Cabal.GHC _ghcVersion@(Cabal.Version versionNumbers _)) =
+cabalDependency :: Portage.Overlay -> PackageDescription -> Cabal.CompilerInfo -> Portage.Dependency
+cabalDependency overlay pkg ~(Cabal.CompilerInfo {
+ Cabal.compilerInfoId =
+ Cabal.CompilerId Cabal.GHC (Cabal.Version versionNumbers _)
+ }) =
C2E.convertDependency overlay
(Portage.Category "dev-haskell")
(Cabal.Dependency (Cabal.PackageName "Cabal")
@@ -216,8 +219,10 @@ cabalDependency overlay pkg ~(Cabal.CompilerId Cabal.GHC _ghcVersion@(Cabal.Vers
-- GHC Dependency
---------------------------------------------------------------
-compilerIdToDependency :: Cabal.CompilerId -> Portage.Dependency
-compilerIdToDependency ~(Cabal.CompilerId Cabal.GHC versionNumbers) =
+compilerInfoToDependency :: Cabal.CompilerInfo -> Portage.Dependency
+compilerInfoToDependency ~(Cabal.CompilerInfo {
+ Cabal.compilerInfoId =
+ Cabal.CompilerId Cabal.GHC versionNumbers}) =
at_least_c_p_v "dev-lang" "ghc" (Cabal.versionBranch versionNumbers)
---------------------------------------------------------------
@@ -344,6 +349,14 @@ staticTranslateExtraLib lib = lookup lib m
, ("Xrender", any_c_p "x11-libs" "libXrender")
, ("Xcursor", any_c_p "x11-libs" "libXcursor")
, ("Xinerama", any_c_p "x11-libs" "libXinerama")
+ , ("wayland-client", any_c_p "dev-libs" "wayland")
+ , ("wayland-cursor", any_c_p "dev-libs" "wayland")
+ , ("wayland-server", any_c_p "dev-libs" "wayland")
+ , ("wayland-egl", any_c_p_s_u "media-libs" "mesa" Portage.AnySlot [Portage.mkUse (Portage.Use "wayland")])
+ , ("xkbcommon", any_c_p "x11-libs" "libxkbcommon")
+ , ("SDL_gfx", any_c_p "media-libs" "sdl-gfx")
+ , ("SDL_image", any_c_p "media-libs" "sdl-image")
+ , ("SDL_ttf", any_c_p "media-libs" "sdl-ttf")
]
---------------------------------------------------------------
@@ -370,14 +383,15 @@ buildToolsTable =
[ ("happy", any_c_p "dev-haskell" "happy")
, ("alex", any_c_p "dev-haskell" "alex")
, ("c2hs", any_c_p "dev-haskell" "c2hs")
+ , ("cabal", any_c_p "dev-haskell" "cabal-install")
, ("cabal-install", any_c_p "dev-haskell" "cabal-install")
+ , ("cpphs", any_c_p "dev-haskell" "cpphs")
+ , ("ghc", any_c_p "dev-lang" "ghc")
, ("gtk2hsTypeGen", any_c_p "dev-haskell" "gtk2hs-buildtools")
, ("gtk2hsHookGenerator", any_c_p "dev-haskell" "gtk2hs-buildtools")
, ("gtk2hsC2hs", any_c_p "dev-haskell" "gtk2hs-buildtools")
- , ("cabal", any_c_p "dev-haskell" "cabal-install")
+ , ("hsb2hs", any_c_p "dev-haskell" "hsb2hs")
, ("llvm-config", any_c_p "sys-devel" "llvm")
- , ("cpphs", any_c_p "dev-haskell" "cpphs")
- , ("ghc", any_c_p "dev-lang" "ghc")
]
-- tools that are provided by ghc or some other existing program
@@ -427,6 +441,7 @@ pkgconfig_table =
,("gtk+-2.0", ("x11-libs", "gtk+", Portage.GivenSlot "2"))
,("gdk-2.0", ("x11-libs", "gtk+", Portage.GivenSlot "2"))
+ ,("gdk-3.0", ("x11-libs", "gtk+", Portage.GivenSlot "3"))
,("gdk-pixbuf-2.0", ("x11-libs", "gtk+", Portage.GivenSlot "2"))
,("gdk-pixbuf-xlib-2.0", ("x11-libs", "gtk+", Portage.GivenSlot "2"))
,("gdk-x11-2.0", ("x11-libs", "gtk+", Portage.GivenSlot "2"))
@@ -455,6 +470,7 @@ pkgconfig_table =
,("gnome-vfs-2.0", ("gnome-base", "gnome-vfs", Portage.AnySlot))
,("gnome-vfs-module-2.0", ("gnome-base", "gnome-vfs", Portage.AnySlot))
,("webkit-1.0", ("net-libs","webkit-gtk", Portage.GivenSlot "2"))
+ ,("gtksourceview-3.0", ("x11-libs", "gtksourceview", Portage.GivenSlot "3.0"))
,("gstreamer-0.10", ("media-libs", "gstreamer", Portage.AnySlot))
,("gstreamer-base-0.10", ("media-libs", "gstreamer", Portage.AnySlot))
@@ -499,4 +515,6 @@ pkgconfig_table =
,("taglib_c", ("media-libs", "taglib", Portage.AnySlot))
,("libcurl", ("net-misc", "curl", Portage.AnySlot))
,("libpq", ("dev-db", "postgresql", Portage.AnySlot))
+ ,("poppler-glib", ("app-text", "poppler", Portage.AnySlot))
+ ,("gsl", ("sci-libs", "gsl", Portage.AnySlot))
]
diff --git a/Portage/Cabal.hs b/Portage/Cabal.hs
index ec102b0..a25092f 100644
--- a/Portage/Cabal.hs
+++ b/Portage/Cabal.hs
@@ -29,15 +29,19 @@ convertLicense l =
Cabal.AGPL mv -> Right $ "AGPL-" ++ (maybe "3" Cabal.display mv) -- almost certainly version 3
Cabal.GPL mv -> Right $ "GPL-" ++ (maybe "2" Cabal.display mv) -- almost certainly version 2
Cabal.LGPL mv -> Right $ "LGPL-" ++ (maybe "2.1" Cabal.display mv) -- probably version 2.1
+ Cabal.BSD2 -> Right "BSD-2"
Cabal.BSD3 -> Right "BSD"
Cabal.BSD4 -> Right "BSD-4"
Cabal.PublicDomain -> Right "public-domain"
Cabal.MIT -> Right "MIT"
Cabal.Apache mv -> Right $ "Apache-" ++ (maybe "1.1" Cabal.display mv) -- probably version 1.1
+ Cabal.ISC -> Right "ISC"
+ Cabal.MPL v -> Right $ "MPL-" ++ Cabal.display v -- probably version 1.0
-- bad ones
Cabal.AllRightsReserved -> Left "EULA-style licence. Please pick it manually."
Cabal.UnknownLicense _ -> Left "license unknown to cabal. Please pick it manually."
- Cabal.OtherLicense -> Left "Please look at license file of package and pick it manually."
+ Cabal.OtherLicense -> Left "(Other) Please look at license file of package and pick it manually."
+ Cabal.UnspecifiedLicense -> Left "(Unspecified) Please look at license file of package and pick it manually."
partition_depends :: [Cabal.PackageName] -> Cabal.PackageName -> [Cabal.Dependency] -> ([Cabal.Dependency], [Cabal.Dependency])
partition_depends ghc_package_names merged_cabal_pkg_name = L.partition (not . is_internal_depend)
diff --git a/Portage/EBuild.hs b/Portage/EBuild.hs
index 635b4c7..e68b8c7 100644
--- a/Portage/EBuild.hs
+++ b/Portage/EBuild.hs
@@ -109,7 +109,7 @@ showEBuild now ebuild =
Just pn -> ss "MY_PN=". quote pn. nl.
ss "MY_P=". quote "${MY_PN}-${PV}". nl. nl).
ss "DESCRIPTION=". quote (drop_tdot $ description ebuild). nl.
- ss "HOMEPAGE=". quote (expandVars (homepage ebuild)). nl.
+ ss "HOMEPAGE=". quote (toHttps $ expandVars (homepage ebuild)). nl.
ss "SRC_URI=". quote (toMirror $ src_uri ebuild). nl.
nl.
ss "LICENSE=". (either (\err -> quote "" . ss ("\t# FIXME: " ++ err))
@@ -148,7 +148,7 @@ showEBuild now ebuild =
ss "}" . nl).
if_games (nl . ss "pkg_postinst() {" . nl.
- ss (tabify_line " ghc-package_pkg_postinst") . nl.
+ ss (tabify_line " haskell-cabal_pkg_postinst") . nl.
ss (tabify_line " games_pkg_postinst") . nl.
ss "}" . nl).
@@ -158,6 +158,8 @@ showEBuild now ebuild =
, (hackage_name ebuild, "${HACKAGE_N}")
]
toMirror = replace "http://hackage.haskell.org/" "mirror://hackage/"
+ -- TODO: this needs to be more generic
+ toHttps = replace "http://github.com/" "https://github.com/"
this_year :: String
this_year = TC.formatTime TC.defaultTimeLocale "%Y" now
if_games :: DString -> DString
diff --git a/Portage/GHCCore.hs b/Portage/GHCCore.hs
index 0628ee7..93bb2e2 100644
--- a/Portage/GHCCore.hs
+++ b/Portage/GHCCore.hs
@@ -8,10 +8,11 @@ module Portage.GHCCore
, dependencySatisfiable
) where
+import qualified Distribution.Compiler as DC
import Distribution.Package
import Distribution.Version
import Distribution.Simple.PackageIndex
-import Distribution.InstalledPackageInfo
+import Distribution.InstalledPackageInfo as IPI
import Distribution.PackageDescription
import Distribution.PackageDescription.Configuration
@@ -28,9 +29,9 @@ import Debug.Trace
-- ghcs tried in specified order.
-- It means that first ghc in this list is a minmum default.
-ghcs :: [(CompilerId, PackageIndex)]
+ghcs :: [(DC.CompilerInfo, InstalledPackageIndex)]
ghcs = modern_ghcs
- where modern_ghcs = [ghc741, ghc742, ghc761, ghc762, ghc782, ghc7101]
+ where modern_ghcs = [ghc741, ghc742, ghc761, ghc762, ghc782, ghc7101, ghc7102]
cabalFromGHC :: [Int] -> Maybe Version
cabalFromGHC ver = lookup ver table
@@ -40,12 +41,13 @@ cabalFromGHC ver = lookup ver table
, ([7,6,2], Version [1,16,0] [])
, ([7,8,2], Version [1,18,1,3] [])
, ([7,10,1], Version [1,22,2,0] [])
+ , ([7,10,2], Version [1,22,4,0] [])
]
platform :: Platform
platform = Platform X86_64 Linux
-packageIsCore :: PackageIndex -> PackageName -> Bool
+packageIsCore :: InstalledPackageIndex -> PackageName -> Bool
packageIsCore index pn = not . null $ lookupPackageName index pn
packageIsCoreInAnyGHC :: PackageName -> Bool
@@ -55,7 +57,7 @@ packageIsCoreInAnyGHC pn = any (flip packageIsCore pn) (map snd ghcs)
-- 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 :: InstalledPackageIndex -> Dependency -> Bool
dependencySatisfiable pindex dep@(Dependency pn _rang)
| pn == PackageName "Win32" = False -- only exists on windows, not in linux
| not . null $ lookupDependency pindex dep = True -- the package index satisfies the dep
@@ -65,68 +67,99 @@ dependencySatisfiable pindex dep@(Dependency pn _rang)
packageBuildableWithGHCVersion
:: GenericPackageDescription
-> FlagAssignment
- -> (CompilerId, PackageIndex)
+ -> (DC.CompilerInfo, InstalledPackageIndex)
-> Either [Dependency] (PackageDescription, FlagAssignment)
-packageBuildableWithGHCVersion pkg user_specified_fas (compiler, pkgIndex) = trace_failure $
- finalizePackageDescription user_specified_fas (dependencySatisfiable pkgIndex) platform compiler [] pkg
+packageBuildableWithGHCVersion pkg user_specified_fas (compiler_info, pkgIndex) = trace_failure $
+ finalizePackageDescription user_specified_fas (dependencySatisfiable pkgIndex) platform compiler_info [] pkg
where trace_failure v = case v of
- (Left deps) -> trace (unwords ["rejecting dep:" , show_compiler compiler
+ (Left deps) -> trace (unwords ["rejecting dep:" , show_compiler compiler_info
, "as", show_deps deps
, "were not found."
]
) v
- _ -> trace (unwords ["accepting dep:" , show_compiler compiler
+ _ -> trace (unwords ["accepting dep:" , show_compiler compiler_info
]
) v
show_deps = show . map display
- show_compiler (CompilerId GHC v) = "ghc-" ++ showVersion v
+ show_compiler (DC.CompilerInfo { DC.compilerInfoId = CompilerId GHC v }) = "ghc-" ++ showVersion v
show_compiler c = show c
-- | 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 -> FlagAssignment -> Maybe (CompilerId, [PackageName], PackageDescription, FlagAssignment, PackageIndex)
+minimumGHCVersionToBuildPackage :: GenericPackageDescription -> FlagAssignment -> Maybe (DC.CompilerInfo, [PackageName], PackageDescription, FlagAssignment, InstalledPackageIndex)
minimumGHCVersionToBuildPackage gpd user_specified_fas =
- listToMaybe [ (cid, packageNamesFromPackageIndex pix, pkg_desc, picked_flags, pix)
- | g@(cid, pix) <- ghcs
+ listToMaybe [ (cinfo, packageNamesFromPackageIndex pix, pkg_desc, picked_flags, pix)
+ | g@(cinfo, pix) <- ghcs
, Right (pkg_desc, picked_flags) <- return (packageBuildableWithGHCVersion gpd user_specified_fas g)]
-mkIndex :: [PackageIdentifier] -> PackageIndex
+mkIndex :: [PackageIdentifier] -> InstalledPackageIndex
mkIndex pids = fromList
[ emptyInstalledPackageInfo
- { installedPackageId = InstalledPackageId $ display name ++ "-" ++ display version
+ { IPI.installedPackageId = InstalledPackageId $ display name ++ "-" ++ display version
, sourcePackageId = pindex
, exposed = True
}
| pindex@(PackageIdentifier name version) <- pids ]
-packageNamesFromPackageIndex :: PackageIndex -> [PackageName]
+packageNamesFromPackageIndex :: InstalledPackageIndex -> [PackageName]
packageNamesFromPackageIndex pix = nub $ map fst $ allPackagesByName pix
-ghc :: [Int] -> CompilerId
-ghc nrs = CompilerId GHC (Version nrs [])
+ghc :: [Int] -> DC.CompilerInfo
+ghc nrs = DC.unknownCompilerInfo c_id DC.NoAbiTag
+ where c_id = CompilerId GHC (Version nrs [])
-ghc7101 :: (CompilerId, PackageIndex)
+ghc7102 :: (DC.CompilerInfo, InstalledPackageIndex)
+ghc7102 = (ghc [7,10,2], mkIndex ghc7102_pkgs)
+
+ghc7101 :: (DC.CompilerInfo, InstalledPackageIndex)
ghc7101 = (ghc [7,10,1], mkIndex ghc7101_pkgs)
-ghc782 :: (CompilerId, PackageIndex)
+ghc782 :: (DC.CompilerInfo, InstalledPackageIndex)
ghc782 = (ghc [7,8,2], mkIndex ghc782_pkgs)
-ghc762 :: (CompilerId, PackageIndex)
+ghc762 :: (DC.CompilerInfo, InstalledPackageIndex)
ghc762 = (ghc [7,6,2], mkIndex ghc762_pkgs)
-ghc761 :: (CompilerId, PackageIndex)
+ghc761 :: (DC.CompilerInfo, InstalledPackageIndex)
ghc761 = (ghc [7,6,1], mkIndex ghc761_pkgs)
-ghc742 :: (CompilerId, PackageIndex)
+ghc742 :: (DC.CompilerInfo, InstalledPackageIndex)
ghc742 = (ghc [7,4,2], mkIndex ghc742_pkgs)
-ghc741 :: (CompilerId, PackageIndex)
+ghc741 :: (DC.CompilerInfo, InstalledPackageIndex)
ghc741 = (ghc [7,4,1], mkIndex ghc741_pkgs)
-- | Non-upgradeable core packages
-- Source: http://haskell.org/haskellwiki/Libraries_released_with_GHC
-- and our binary tarballs (package.conf.d.initial subdir)
+ghc7102_pkgs :: [PackageIdentifier]
+ghc7102_pkgs =
+ [ p "array" [0,5,1,0]
+ , p "base" [4,8,1,0]
+-- , p "binary" [0,7,3,0] package is upgradeable
+ , p "bytestring" [0,10,6,0]
+-- , p "Cabal" [1,18,1,3] package is upgradeable
+ , p "containers" [0,5,6,2]
+ , p "deepseq" [1,4,1,1] -- used by time
+ , p "directory" [1,2,2,0]
+ , p "filepath" [1,4,0,0]
+ , p "ghc-prim" [0,4,0,0]
+ -- , p "haskell2010" [1,1,2,0] -- stopped shipping in 7.10, deprecated
+ -- , p "haskell98" [2,0,0,3] -- stopped shipping in 7.10, deprecated
+ , p "hoopl" [3,10,1,0] -- used by libghc
+ , p "hpc" [0,6,0,2] -- used by libghc
+ , p "integer-gmp" [1,0,0,0]
+ -- , p "old-locale" [1,0,0,6] -- stopped shipping in 7.10, deprecated
+ -- , p "old-time" [1,1,0,2] -- stopped shipping in 7.10, deprecated
+ , p "pretty" [1,1,2,0]
+ , p "process" [1,2,3,0]
+ , p "template-haskell" [2,10,0,0] -- used by libghc
+ , p "time" [1,5,0,1] -- used by haskell98, unix, directory, hpc, ghc. unsafe to upgrade
+-- , p "transformers" [0,4,2,0] -- used by libghc
+ , p "unix" [2,7,1,0]
+ ]
+
ghc7101_pkgs :: [PackageIdentifier]
ghc7101_pkgs =
[ p "array" [0,5,1,0]
diff --git a/Portage/Metadata.hs b/Portage/Metadata.hs
index 5a7a2c0..9b59b13 100644
--- a/Portage/Metadata.hs
+++ b/Portage/Metadata.hs
@@ -11,7 +11,7 @@ import Control.Applicative
import Text.XML.Light
data Metadata = Metadata
- { metadataHerds :: [String]
+ { metadata_emails :: [String]
-- , metadataMaintainers :: [String],
-- , metadataUseFlags :: [(String,String)]
} deriving (Show)
@@ -22,12 +22,8 @@ metadataFromFile fp = do
return (doc >>= parseMetadata)
parseMetadata :: Element -> Maybe Metadata
-parseMetadata xml = do
- let herds = map strContent (findChildren (unqual "herd") xml)
- return Metadata
- {
- metadataHerds = herds
- }
+parseMetadata xml =
+ return Metadata { metadata_emails = map strContent (findElements (unqual "email") xml) }
-- don't use Text.XML.Light as we like our own pretty printer
makeDefaultMetadata :: String -> String
@@ -35,7 +31,10 @@ 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 type=\"project\">"
+ , "\t\t<email>haskell@gentoo.org</email>"
+ , "\t\t<name>Gentoo Haskell</name>"
+ , "\t</maintainer>"
, (init {- strip trailing newline-}
. unlines
. map (\l -> if l `elem` ["<longdescription>", "</longdescription>"]
diff --git a/Portage/Overlay.hs b/Portage/Overlay.hs
index 3602139..2fa8aaf 100644
--- a/Portage/Overlay.hs
+++ b/Portage/Overlay.hs
@@ -6,7 +6,7 @@ module Portage.Overlay
, getDirectoryTree, DirectoryTree
, reduceOverlay
- , filterByHerd
+ , filterByEmail
, inOverlay
)
where
@@ -96,13 +96,13 @@ mkMetadataMap root dir =
, File "metadata.xml" <- files
]
-filterByHerd :: ([String] -> Bool) -> Overlay -> Overlay
-filterByHerd p overlay = overlay
+filterByEmail :: ([String] -> Bool) -> Overlay -> Overlay
+filterByEmail p overlay = overlay
{ overlayMetadata = metadataMap'
, overlayMap = pkgMap'
}
where
- metadataMap' = Map.filter (p . Portage.metadataHerds) (overlayMetadata overlay)
+ metadataMap' = Map.filter (p . Portage.metadata_emails) (overlayMetadata overlay)
pkgMap' = Map.intersection (overlayMap overlay) metadataMap'
diff --git a/Status.hs b/Status.hs
index d2f0900..c3260b7 100644
--- a/Status.hs
+++ b/Status.hs
@@ -94,7 +94,7 @@ status verbosity portdir overlaydir = do
let repo = defaultRepo overlaydir
overlay <- loadLazy overlaydir
hackage <- loadHackage verbosity repo overlay
- portage <- filterByHerd ("haskell" `elem`) <$> loadLazy portdir
+ portage <- filterByEmail ("haskell@gentoo.org" `elem`) <$> loadLazy portdir
let (over, both, port) = portageDiff (overlayMap overlay) (overlayMap portage)
both' <- T.forM both $ mapM $ \e -> do
diff --git a/cabal/.travis.yml b/cabal/.travis.yml
index 1464254..5f5f3f6 100644
--- a/cabal/.travis.yml
+++ b/cabal/.travis.yml
@@ -2,42 +2,69 @@
# The following enables several GHC versions to be tested; often it's enough to test only against the last release in a major GHC version. Feel free to omit lines listings versions you don't need/want testing for.
env:
- - GHCVER=7.0.4
- GHCVER=7.4.2
- GHCVER=7.6.3
+ - GHCVER=7.8.4
+ - GHCVER=7.10.1
- GHCVER=head
# Note: the distinction between `before_install` and `install` is not important.
before_install:
- - sudo add-apt-repository -y ppa:hvr/ghc
- - sudo apt-get update
- - sudo apt-get install cabal-install-1.18 ghc-$GHCVER happy
- - export PATH=/opt/ghc/$GHCVER/bin:$PATH
- - export CABAL_TEST_RUNNING_ON_TRAVIS=1
+ - travis_retry sudo add-apt-repository -y ppa:hvr/ghc
+ - travis_retry sudo apt-get update
+ - travis_retry sudo apt-get install cabal-install-1.22 ghc-$GHCVER-prof ghc-$GHCVER-dyn happy
+ - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/1.22/bin:$PATH
install:
- - sudo /opt/ghc/$GHCVER/bin/ghc-pkg recache
- - cabal-1.18 update
- - cd Cabal
- - cabal-1.18 install --only-dependencies --enable-tests --enable-benchmarks
+ - cabal update
+# We intentionally do not install anything before trying to build Cabal because
+# it should build with each supported GHC version out-of-the-box.
# Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail.
+# Using ./dist/setup/setup here instead of cabal-install to avoid breakage
+# when the build config format changed
script:
- - cabal-1.18 configure --enable-tests --enable-benchmarks -v2 # -v2 provides useful information for debugging
- - cabal-1.18 build # this builds all libraries and executables (including tests/benchmarks)
- - cabal-1.18 test
- - cabal-1.18 check
- - cabal-1.18 sdist # tests that a source-distribution can be generated
+ - cd Cabal
+ - mkdir -p ./dist/setup
+ - cp Setup.hs ./dist/setup/setup.hs
+# Should be able to build setup without extra dependencies
+ - /opt/ghc/$GHCVER/bin/ghc --make -odir ./dist/setup -hidir ./dist/setup -i -i. ./dist/setup/setup.hs -o ./dist/setup/setup -Wall -Werror -threaded # the command cabal-install would use to build setup
+
+# Need extra dependencies for test suite
+ - cabal install --only-dependencies --enable-tests
+ - sudo /opt/ghc/$GHCVER/bin/ghc-pkg recache
+ - /opt/ghc/$GHCVER/bin/ghc-pkg recache --user
+
+ - ./dist/setup/setup configure --user --enable-tests --enable-benchmarks --ghc-option=-Werror -v2 # -v2 provides useful information for debugging
+ - ./dist/setup/setup build # this builds all libraries and executables (including tests/benchmarks)
+ - ./dist/setup/setup haddock # see #2198
+ - ./dist/setup/setup test --show-details=streaming
+ - cabal check
+ - cabal sdist # tests that a source-distribution can be generated
# The following scriptlet checks that the resulting source distribution can be built & installed
- - export SRC_TGZ=$(cabal-1.18 info . | awk '{print $2 ".tar.gz";exit}') ;
- cd dist/;
- if [ -f "$SRC_TGZ" ]; then
- cabal-1.18 install "$SRC_TGZ";
+ - function install_from_tarball {
+ export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ;
+ if [ -f "dist/$SRC_TGZ" ]; then
+ cabal install "dist/$SRC_TGZ" -v2;
else
- echo "expected '$SRC_TGZ' not found";
+ echo "expected 'dist/$SRC_TGZ' not found";
exit 1;
fi
+ }
+ - install_from_tarball
+
+# Also build cabal-install.
+ - cd ../cabal-install
+ - cabal sandbox init
+ - cabal sandbox add-source ../Cabal
+ - cabal install --dependencies-only --enable-tests
+ - cabal configure --enable-tests --ghc-option=-Werror
+ - cabal build
+ - cabal test
+ - cabal check
+ - cabal sdist
+ - install_from_tarball
matrix:
allow_failures:
diff --git a/cabal/Cabal/Cabal.cabal b/cabal/Cabal/Cabal.cabal
index d01caf5..d94e964 100644
--- a/cabal/Cabal/Cabal.cabal
+++ b/cabal/Cabal/Cabal.cabal
@@ -1,5 +1,5 @@
name: Cabal
-version: 1.19.2
+version: 1.23.0.0
copyright: 2003-2006, Isaac Jones
2005-2011, Duncan Coutts
license: BSD3
@@ -24,7 +24,10 @@ build-type: Custom
-- that we build Setup.lhs using our own local Cabal source code.
extra-source-files:
- README tests/README changelog
+ README.md tests/README.md changelog
+ doc/developing-packages.markdown doc/index.markdown
+ doc/installing-packages.markdown
+ doc/misc.markdown
-- Generated with 'misc/gen-extra-source-files.sh' & 'M-x sort-lines':
tests/PackageTests/BenchmarkExeV10/Foo.hs
@@ -71,8 +74,6 @@ extra-source-files:
tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs
tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs
tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal
- tests/PackageTests/BuildTestSuiteDetailedV09/Dummy.hs
- tests/PackageTests/BuildTestSuiteDetailedV09/my.cabal
tests/PackageTests/CMain/Bar.hs
tests/PackageTests/CMain/Setup.hs
tests/PackageTests/CMain/foo.c
@@ -80,6 +81,11 @@ extra-source-files:
tests/PackageTests/DeterministicAr/Lib.hs
tests/PackageTests/DeterministicAr/my.cabal
tests/PackageTests/EmptyLib/empty/empty.cabal
+ tests/PackageTests/Haddock/CPP.hs
+ tests/PackageTests/Haddock/Literate.lhs
+ tests/PackageTests/Haddock/NoCPP.hs
+ tests/PackageTests/Haddock/Simple.hs
+ tests/PackageTests/Haddock/my.cabal
tests/PackageTests/OrderFlags/Foo.hs
tests/PackageTests/OrderFlags/my.cabal
tests/PackageTests/PathsModule/Executable/Main.hs
@@ -88,6 +94,7 @@ extra-source-files:
tests/PackageTests/PreProcess/Foo.hsc
tests/PackageTests/PreProcess/Main.hs
tests/PackageTests/PreProcess/my.cabal
+ tests/PackageTests/ReexportedModules/ReexportedModules.cabal
tests/PackageTests/TemplateHaskell/dynamic/Exe.hs
tests/PackageTests/TemplateHaskell/dynamic/Lib.hs
tests/PackageTests/TemplateHaskell/dynamic/TH.hs
@@ -103,9 +110,12 @@ extra-source-files:
tests/PackageTests/TestOptions/TestOptions.cabal
tests/PackageTests/TestOptions/test-TestOptions.hs
tests/PackageTests/TestStanza/my.cabal
- tests/PackageTests/TestSuiteExeV10/Foo.hs
- tests/PackageTests/TestSuiteExeV10/my.cabal
- tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs
+ tests/PackageTests/TestSuiteTests/ExeV10/Foo.hs
+ tests/PackageTests/TestSuiteTests/ExeV10/my.cabal
+ tests/PackageTests/TestSuiteTests/ExeV10/tests/test-Foo.hs
+ tests/PackageTests/TestSuiteTests/LibV09/LibV09.cabal
+ tests/PackageTests/TestSuiteTests/LibV09/Lib.hs
+ tests/PackageTests/TestSuiteTests/LibV09/tests/Deadlock.hs
tests/Setup.hs
tests/hackage/check.sh
tests/hackage/download.sh
@@ -117,19 +127,31 @@ source-repository head
location: https://github.com/haskell/cabal/
subdir: Cabal
+flag bundled-binary-generic
+ default: False
+
library
build-depends:
- base >= 4 && < 5,
- deepseq >= 1.3 && < 1.4,
- filepath >= 1 && < 1.4,
- directory >= 1 && < 1.3,
- process >= 1.0.1.1 && < 1.3,
- time >= 1.1 && < 1.5,
- containers >= 0.1 && < 0.6,
- array >= 0.1 && < 0.6,
- pretty >= 1 && < 1.2,
+ base >= 4.4 && < 5,
+ deepseq >= 1.3 && < 1.5,
+ filepath >= 1 && < 1.5,
+ directory >= 1 && < 1.3,
+ process >= 1.1.0.1 && < 1.4,
+ time >= 1.1 && < 1.6,
+ containers >= 0.1 && < 0.6,
+ array >= 0.1 && < 0.6,
+ pretty >= 1 && < 1.2,
bytestring >= 0.9
+ if flag(bundled-binary-generic)
+ build-depends: binary >= 0.5 && < 0.7
+ else
+ build-depends: binary >= 0.7 && < 0.8
+
+ -- Needed for GHC.Generics before GHC 7.6
+ if impl(ghc < 7.6)
+ build-depends: ghc-prim >= 0.2 && < 0.3
+
if !os(windows)
build-depends:
unix >= 2.0 && < 2.8
@@ -137,6 +159,7 @@ library
ghc-options: -Wall -fno-ignore-asserts -fwarn-tabs
exposed-modules:
+ Distribution.Compat.CreatePipe
Distribution.Compat.Environment
Distribution.Compat.Exception
Distribution.Compat.ReadP
@@ -166,16 +189,15 @@ library
Distribution.Simple.Compiler
Distribution.Simple.Configure
Distribution.Simple.GHC
+ Distribution.Simple.GHCJS
Distribution.Simple.Haddock
Distribution.Simple.HaskellSuite
Distribution.Simple.Hpc
- Distribution.Simple.Hugs
Distribution.Simple.Install
Distribution.Simple.InstallDirs
Distribution.Simple.JHC
Distribution.Simple.LHC
Distribution.Simple.LocalBuildInfo
- Distribution.Simple.NHC
Distribution.Simple.PackageIndex
Distribution.Simple.PreProcess
Distribution.Simple.PreProcess.Unlit
@@ -187,6 +209,7 @@ library
Distribution.Simple.Program.GHC
Distribution.Simple.Program.HcPkg
Distribution.Simple.Program.Hpc
+ Distribution.Simple.Program.Internal
Distribution.Simple.Program.Ld
Distribution.Simple.Program.Run
Distribution.Simple.Program.Script
@@ -196,24 +219,37 @@ library
Distribution.Simple.Setup
Distribution.Simple.SrcDist
Distribution.Simple.Test
+ Distribution.Simple.Test.ExeV10
+ Distribution.Simple.Test.LibV09
+ Distribution.Simple.Test.Log
Distribution.Simple.UHC
Distribution.Simple.UserHooks
Distribution.Simple.Utils
Distribution.System
Distribution.TestSuite
Distribution.Text
+ Distribution.Utils.NubList
Distribution.Verbosity
Distribution.Version
Language.Haskell.Extension
other-modules:
+ Distribution.Compat.Binary
Distribution.Compat.CopyFile
Distribution.Compat.TempFile
Distribution.GetOpt
+ Distribution.Lex
+ Distribution.Simple.GHC.Internal
Distribution.Simple.GHC.IPI641
Distribution.Simple.GHC.IPI642
+ Distribution.Simple.GHC.ImplInfo
Paths_Cabal
+ if flag(bundled-binary-generic)
+ other-modules:
+ Distribution.Compat.Binary.Class
+ Distribution.Compat.Binary.Generic
+
default-language: Haskell98
default-extensions: CPP
@@ -221,15 +257,19 @@ library
test-suite unit-tests
type: exitcode-stdio-1.0
hs-source-dirs: tests
- other-modules: UnitTests.Distribution.Compat.ReadP
+ other-modules:
+ UnitTests.Distribution.Compat.CreatePipe
+ UnitTests.Distribution.Compat.ReadP
+ UnitTests.Distribution.Simple.Program.Internal
+ UnitTests.Distribution.Utils.NubList
main-is: UnitTests.hs
build-depends:
base,
- test-framework,
- test-framework-hunit,
- test-framework-quickcheck2,
- HUnit,
- QuickCheck,
+ tasty,
+ tasty-hunit,
+ tasty-quickcheck,
+ pretty,
+ QuickCheck < 2.9,
Cabal
ghc-options: -Wall
default-language: Haskell98
@@ -239,7 +279,6 @@ test-suite package-tests
type: exitcode-stdio-1.0
main-is: PackageTests.hs
other-modules:
- Distribution.Compat.CreatePipe
PackageTests.BenchmarkExeV10.Check
PackageTests.BenchmarkOptions.Check
PackageTests.BenchmarkStanza.Check
@@ -254,34 +293,41 @@ test-suite package-tests
PackageTests.BuildDeps.TargetSpecificDeps1.Check
PackageTests.BuildDeps.TargetSpecificDeps2.Check
PackageTests.BuildDeps.TargetSpecificDeps3.Check
- PackageTests.BuildTestSuiteDetailedV09.Check
PackageTests.CMain.Check
PackageTests.DeterministicAr.Check
PackageTests.EmptyLib.Check
+ PackageTests.Haddock.Check
PackageTests.OrderFlags.Check
PackageTests.PackageTester
PackageTests.PathsModule.Executable.Check
PackageTests.PathsModule.Library.Check
PackageTests.PreProcess.Check
+ PackageTests.PreProcessExtraSources.Check
+ PackageTests.ReexportedModules.Check
PackageTests.TemplateHaskell.Check
PackageTests.TestOptions.Check
PackageTests.TestStanza.Check
- PackageTests.TestSuiteExeV10.Check
+ PackageTests.TestSuiteTests.ExeV10.Check
+ PackageTests.TestSuiteTests.LibV09.Check
+ Test.Distribution.Version
+ Test.Laws
+ Test.QuickCheck.Utils
hs-source-dirs: tests
build-depends:
base,
- test-framework,
- test-framework-quickcheck2 >= 0.2.12,
- test-framework-hunit,
- HUnit,
- QuickCheck >= 2.1.0.1,
+ containers,
+ tasty,
+ tasty-quickcheck,
+ tasty-hunit,
+ QuickCheck >= 2.1.0.1 && < 2.9,
Cabal,
process,
directory,
filepath,
extensible-exceptions,
bytestring,
- regex-posix
+ regex-posix,
+ old-time
if !os(windows)
build-depends: unix
ghc-options: -Wall
diff --git a/cabal/Cabal/Distribution/Compat/Binary.hs b/cabal/Cabal/Distribution/Compat/Binary.hs
new file mode 100644
index 0000000..5b842c7
--- /dev/null
+++ b/cabal/Cabal/Distribution/Compat/Binary.hs
@@ -0,0 +1,60 @@
+{-# LANGUAGE CPP #-}
+#if __GLASGOW_HASKELL__ >= 711
+{-# LANGUAGE PatternSynonyms #-}
+#endif
+
+#ifndef MIN_VERSION_binary
+#define MIN_VERSION_binary(x, y, z) 0
+#endif
+
+module Distribution.Compat.Binary
+ ( decodeOrFailIO
+#if __GLASGOW_HASKELL__ >= 708 || MIN_VERSION_binary(0,7,0)
+ , module Data.Binary
+#else
+ , Binary(..)
+ , decode, encode
+#endif
+ ) where
+
+import Control.Exception (catch, evaluate)
+#if __GLASGOW_HASKELL__ >= 711
+import Control.Exception (pattern ErrorCall)
+#else
+import Control.Exception (ErrorCall(..))
+#endif
+import Data.ByteString.Lazy (ByteString)
+
+#if __GLASGOW_HASKELL__ < 706
+import Prelude hiding (catch)
+#endif
+
+#if __GLASGOW_HASKELL__ >= 708 || MIN_VERSION_binary(0,7,0)
+
+import Data.Binary
+
+#else
+
+import Data.Binary.Get
+import Data.Binary.Put
+
+import Distribution.Compat.Binary.Class
+import Distribution.Compat.Binary.Generic ()
+
+-- | Decode a value from a lazy ByteString, reconstructing the original structure.
+--
+decode :: Binary a => ByteString -> a
+decode = runGet get
+
+-- | Encode a value using binary serialisation to a lazy ByteString.
+--
+encode :: Binary a => a -> ByteString
+encode = runPut . put
+{-# INLINE encode #-}
+
+#endif
+
+decodeOrFailIO :: Binary a => ByteString -> IO (Either String a)
+decodeOrFailIO bs =
+ catch (evaluate (decode bs) >>= return . Right)
+ $ \(ErrorCall str) -> return $ Left str
diff --git a/cabal/Cabal/Distribution/Compat/Binary/Class.hs b/cabal/Cabal/Distribution/Compat/Binary/Class.hs
new file mode 100644
index 0000000..9c4ef55
--- /dev/null
+++ b/cabal/Cabal/Distribution/Compat/Binary/Class.hs
@@ -0,0 +1,530 @@
+{-# LANGUAGE CPP, FlexibleContexts #-}
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE DefaultSignatures #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Compat.Binary.Class
+-- Copyright : Lennart Kolmodin
+-- License : BSD3-style (see LICENSE)
+--
+-- Maintainer : Lennart Kolmodin <kolmodin@gmail.com>
+-- Stability : unstable
+-- Portability : portable to Hugs and GHC. Requires the FFI and some flexible instances
+--
+-- Typeclass and instances for binary serialization.
+--
+-----------------------------------------------------------------------------
+
+module Distribution.Compat.Binary.Class (
+
+ -- * The Binary class
+ Binary(..)
+
+ -- * Support for generics
+ , GBinary(..)
+
+ ) where
+
+import Data.Word
+
+import Data.Binary.Put
+import Data.Binary.Get
+
+import Control.Monad
+import Foreign
+
+import Data.ByteString.Lazy (ByteString)
+import qualified Data.ByteString.Lazy as L
+
+import Data.Char (chr,ord)
+import Data.List (unfoldr)
+
+-- And needed for the instances:
+import qualified Data.ByteString as B
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified Data.IntMap as IntMap
+import qualified Data.IntSet as IntSet
+import qualified Data.Ratio as R
+
+import qualified Data.Tree as T
+
+import Data.Array.Unboxed
+
+import GHC.Generics
+
+--
+-- This isn't available in older Hugs or older GHC
+--
+#if __GLASGOW_HASKELL__ >= 606
+import qualified Data.Sequence as Seq
+import qualified Data.Foldable as Fold
+#endif
+
+------------------------------------------------------------------------
+
+class GBinary f where
+ gput :: f t -> Put
+ gget :: Get (f t)
+
+-- | The 'Binary' class provides 'put' and 'get', methods to encode and
+-- decode a Haskell value to a lazy 'ByteString'. It mirrors the 'Read' and
+-- 'Show' classes for textual representation of Haskell types, and is
+-- suitable for serialising Haskell values to disk, over the network.
+--
+-- For decoding and generating simple external binary formats (e.g. C
+-- structures), Binary may be used, but in general is not suitable
+-- for complex protocols. Instead use the 'Put' and 'Get' primitives
+-- directly.
+--
+-- Instances of Binary should satisfy the following property:
+--
+-- > decode . encode == id
+--
+-- That is, the 'get' and 'put' methods should be the inverse of each
+-- other. A range of instances are provided for basic Haskell types.
+--
+class Binary t where
+ -- | Encode a value in the Put monad.
+ put :: t -> Put
+ -- | Decode a value in the Get monad
+ get :: Get t
+
+ default put :: (Generic t, GBinary (Rep t)) => t -> Put
+ put = gput . from
+
+ default get :: (Generic t, GBinary (Rep t)) => Get t
+ get = to `fmap` gget
+
+------------------------------------------------------------------------
+-- Simple instances
+
+-- The () type need never be written to disk: values of singleton type
+-- can be reconstructed from the type alone
+instance Binary () where
+ put () = return ()
+ get = return ()
+
+-- Bools are encoded as a byte in the range 0 .. 1
+instance Binary Bool where
+ put = putWord8 . fromIntegral . fromEnum
+ get = liftM (toEnum . fromIntegral) getWord8
+
+-- Values of type 'Ordering' are encoded as a byte in the range 0 .. 2
+instance Binary Ordering where
+ put = putWord8 . fromIntegral . fromEnum
+ get = liftM (toEnum . fromIntegral) getWord8
+
+------------------------------------------------------------------------
+-- Words and Ints
+
+-- Words8s are written as bytes
+instance Binary Word8 where
+ put = putWord8
+ get = getWord8
+
+-- Words16s are written as 2 bytes in big-endian (network) order
+instance Binary Word16 where
+ put = putWord16be
+ get = getWord16be
+
+-- Words32s are written as 4 bytes in big-endian (network) order
+instance Binary Word32 where
+ put = putWord32be
+ get = getWord32be
+
+-- Words64s are written as 8 bytes in big-endian (network) order
+instance Binary Word64 where
+ put = putWord64be
+ get = getWord64be
+
+-- Int8s are written as a single byte.
+instance Binary Int8 where
+ put i = put (fromIntegral i :: Word8)
+ get = liftM fromIntegral (get :: Get Word8)
+
+-- Int16s are written as a 2 bytes in big endian format
+instance Binary Int16 where
+ put i = put (fromIntegral i :: Word16)
+ get = liftM fromIntegral (get :: Get Word16)
+
+-- Int32s are written as a 4 bytes in big endian format
+instance Binary Int32 where
+ put i = put (fromIntegral i :: Word32)
+ get = liftM fromIntegral (get :: Get Word32)
+
+-- Int64s are written as a 4 bytes in big endian format
+instance Binary Int64 where
+ put i = put (fromIntegral i :: Word64)
+ get = liftM fromIntegral (get :: Get Word64)
+
+------------------------------------------------------------------------
+
+-- Words are are written as Word64s, that is, 8 bytes in big endian format
+instance Binary Word where
+ put i = put (fromIntegral i :: Word64)
+ get = liftM fromIntegral (get :: Get Word64)
+
+-- Ints are are written as Int64s, that is, 8 bytes in big endian format
+instance Binary Int where
+ put i = put (fromIntegral i :: Int64)
+ get = liftM fromIntegral (get :: Get Int64)
+
+------------------------------------------------------------------------
+--
+-- Portable, and pretty efficient, serialisation of Integer
+--
+
+-- Fixed-size type for a subset of Integer
+type SmallInt = Int32
+
+-- Integers are encoded in two ways: if they fit inside a SmallInt,
+-- they're written as a byte tag, and that value. If the Integer value
+-- is too large to fit in a SmallInt, it is written as a byte array,
+-- along with a sign and length field.
+
+instance Binary Integer where
+
+ {-# INLINE put #-}
+ put n | n >= lo && n <= hi = do
+ putWord8 0
+ put (fromIntegral n :: SmallInt) -- fast path
+ where
+ lo = fromIntegral (minBound :: SmallInt) :: Integer
+ hi = fromIntegral (maxBound :: SmallInt) :: Integer
+
+ put n = do
+ putWord8 1
+ put sign
+ put (unroll (abs n)) -- unroll the bytes
+ where
+ sign = fromIntegral (signum n) :: Word8
+
+ {-# INLINE get #-}
+ get = do
+ tag <- get :: Get Word8
+ case tag of
+ 0 -> liftM fromIntegral (get :: Get SmallInt)
+ _ -> do sign <- get
+ bytes <- get
+ let v = roll bytes
+ return $! if sign == (1 :: Word8) then v else - v
+
+--
+-- Fold and unfold an Integer to and from a list of its bytes
+--
+unroll :: Integer -> [Word8]
+unroll = unfoldr step
+ where
+ step 0 = Nothing
+ step i = Just (fromIntegral i, i `shiftR` 8)
+
+roll :: [Word8] -> Integer
+roll = foldr unstep 0
+ where
+ unstep b a = a `shiftL` 8 .|. fromIntegral b
+
+{-
+
+--
+-- An efficient, raw serialisation for Integer (GHC only)
+--
+
+-- TODO This instance is not architecture portable. GMP stores numbers as
+-- arrays of machine sized words, so the byte format is not portable across
+-- architectures with different endianness and word size.
+
+import Data.ByteString.Base (toForeignPtr,unsafePackAddress, memcpy)
+import GHC.Base hiding (ord, chr)
+import GHC.Prim
+import GHC.Ptr (Ptr(..))
+import GHC.IOBase (IO(..))
+
+instance Binary Integer where
+ put (S# i) = putWord8 0 >> put (I# i)
+ put (J# s ba) = do
+ putWord8 1
+ put (I# s)
+ put (BA ba)
+
+ get = do
+ b <- getWord8
+ case b of
+ 0 -> do (I# i#) <- get
+ return (S# i#)
+ _ -> do (I# s#) <- get
+ (BA a#) <- get
+ return (J# s# a#)
+
+instance Binary ByteArray where
+
+ -- Pretty safe.
+ put (BA ba) =
+ let sz = sizeofByteArray# ba -- (primitive) in *bytes*
+ addr = byteArrayContents# ba
+ bs = unsafePackAddress (I# sz) addr
+ in put bs -- write as a ByteString. easy, yay!
+
+ -- Pretty scary. Should be quick though
+ get = do
+ (fp, off, n@(I# sz)) <- liftM toForeignPtr get -- so decode a ByteString
+ assert (off == 0) $ return $ unsafePerformIO $ do
+ (MBA arr) <- newByteArray sz -- and copy it into a ByteArray#
+ let to = byteArrayContents# (unsafeCoerce# arr) -- urk, is this safe?
+ withForeignPtr fp $ \from -> memcpy (Ptr to) from (fromIntegral n)
+ freezeByteArray arr
+
+-- wrapper for ByteArray#
+data ByteArray = BA {-# UNPACK #-} !ByteArray#
+data MBA = MBA {-# UNPACK #-} !(MutableByteArray# RealWorld)
+
+newByteArray :: Int# -> IO MBA
+newByteArray sz = IO $ \s ->
+ case newPinnedByteArray# sz s of { (# s', arr #) ->
+ (# s', MBA arr #) }
+
+freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
+freezeByteArray arr = IO $ \s ->
+ case unsafeFreezeByteArray# arr s of { (# s', arr' #) ->
+ (# s', BA arr' #) }
+
+-}
+
+instance (Binary a,Integral a) => Binary (R.Ratio a) where
+ put r = put (R.numerator r) >> put (R.denominator r)
+ get = liftM2 (R.%) get get
+
+------------------------------------------------------------------------
+
+-- Char is serialised as UTF-8
+instance Binary Char where
+ put a | c <= 0x7f = put (fromIntegral c :: Word8)
+ | c <= 0x7ff = do put (0xc0 .|. y)
+ put (0x80 .|. z)
+ | c <= 0xffff = do put (0xe0 .|. x)
+ put (0x80 .|. y)
+ put (0x80 .|. z)
+ | c <= 0x10ffff = do put (0xf0 .|. w)
+ put (0x80 .|. x)
+ put (0x80 .|. y)
+ put (0x80 .|. z)
+ | otherwise = error "Not a valid Unicode code point"
+ where
+ c = ord a
+ z, y, x, w :: Word8
+ z = fromIntegral (c .&. 0x3f)
+ y = fromIntegral (shiftR c 6 .&. 0x3f)
+ x = fromIntegral (shiftR c 12 .&. 0x3f)
+ w = fromIntegral (shiftR c 18 .&. 0x7)
+
+ get = do
+ let getByte = liftM (fromIntegral :: Word8 -> Int) get
+ shiftL6 = flip shiftL 6 :: Int -> Int
+ w <- getByte
+ r <- case () of
+ _ | w < 0x80 -> return w
+ | w < 0xe0 -> do
+ x <- liftM (xor 0x80) getByte
+ return (x .|. shiftL6 (xor 0xc0 w))
+ | w < 0xf0 -> do
+ x <- liftM (xor 0x80) getByte
+ y <- liftM (xor 0x80) getByte
+ return (y .|. shiftL6 (x .|. shiftL6
+ (xor 0xe0 w)))
+ | otherwise -> do
+ x <- liftM (xor 0x80) getByte
+ y <- liftM (xor 0x80) getByte
+ z <- liftM (xor 0x80) getByte
+ return (z .|. shiftL6 (y .|. shiftL6
+ (x .|. shiftL6 (xor 0xf0 w))))
+ return $! chr r
+
+------------------------------------------------------------------------
+-- Instances for the first few tuples
+
+instance (Binary a, Binary b) => Binary (a,b) where
+ put (a,b) = put a >> put b
+ get = liftM2 (,) get get
+
+instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
+ put (a,b,c) = put a >> put b >> put c
+ get = liftM3 (,,) get get get
+
+instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
+ put (a,b,c,d) = put a >> put b >> put c >> put d
+ get = liftM4 (,,,) get get get get
+
+instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d,e) where
+ put (a,b,c,d,e) = put a >> put b >> put c >> put d >> put e
+ get = liftM5 (,,,,) get get get get get
+
+--
+-- and now just recurse:
+--
+
+instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f)
+ => Binary (a,b,c,d,e,f) where
+ put (a,b,c,d,e,f) = put (a,(b,c,d,e,f))
+ get = do (a,(b,c,d,e,f)) <- get ; return (a,b,c,d,e,f)
+
+instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g)
+ => Binary (a,b,c,d,e,f,g) where
+ put (a,b,c,d,e,f,g) = put (a,(b,c,d,e,f,g))
+ get = do (a,(b,c,d,e,f,g)) <- get ; return (a,b,c,d,e,f,g)
+
+instance (Binary a, Binary b, Binary c, Binary d, Binary e,
+ Binary f, Binary g, Binary h)
+ => Binary (a,b,c,d,e,f,g,h) where
+ put (a,b,c,d,e,f,g,h) = put (a,(b,c,d,e,f,g,h))
+ get = do (a,(b,c,d,e,f,g,h)) <- get ; return (a,b,c,d,e,f,g,h)
+
+instance (Binary a, Binary b, Binary c, Binary d, Binary e,
+ Binary f, Binary g, Binary h, Binary i)
+ => Binary (a,b,c,d,e,f,g,h,i) where
+ put (a,b,c,d,e,f,g,h,i) = put (a,(b,c,d,e,f,g,h,i))
+ get = do (a,(b,c,d,e,f,g,h,i)) <- get ; return (a,b,c,d,e,f,g,h,i)
+
+instance (Binary a, Binary b, Binary c, Binary d, Binary e,
+ Binary f, Binary g, Binary h, Binary i, Binary j)
+ => Binary (a,b,c,d,e,f,g,h,i,j) where
+ put (a,b,c,d,e,f,g,h,i,j) = put (a,(b,c,d,e,f,g,h,i,j))
+ get = do (a,(b,c,d,e,f,g,h,i,j)) <- get ; return (a,b,c,d,e,f,g,h,i,j)
+
+------------------------------------------------------------------------
+-- Container types
+
+instance Binary a => Binary [a] where
+ put l = put (length l) >> mapM_ put l
+ get = do n <- get :: Get Int
+ getMany n
+
+-- | 'getMany n' get 'n' elements in order, without blowing the stack.
+getMany :: Binary a => Int -> Get [a]
+getMany n = go [] n
+ where
+ go xs 0 = return $! reverse xs
+ go xs i = do x <- get
+ -- we must seq x to avoid stack overflows due to laziness in
+ -- (>>=)
+ x `seq` go (x:xs) (i-1)
+{-# INLINE getMany #-}
+
+instance (Binary a) => Binary (Maybe a) where
+ put Nothing = putWord8 0
+ put (Just x) = putWord8 1 >> put x
+ get = do
+ w <- getWord8
+ case w of
+ 0 -> return Nothing
+ _ -> liftM Just get
+
+instance (Binary a, Binary b) => Binary (Either a b) where
+ put (Left a) = putWord8 0 >> put a
+ put (Right b) = putWord8 1 >> put b
+ get = do
+ w <- getWord8
+ case w of
+ 0 -> liftM Left get
+ _ -> liftM Right get
+
+------------------------------------------------------------------------
+-- ByteStrings (have specially efficient instances)
+
+instance Binary B.ByteString where
+ put bs = do put (B.length bs)
+ putByteString bs
+ get = get >>= getByteString
+
+--
+-- Using old versions of fps, this is a type synonym, and non portable
+--
+-- Requires 'flexible instances'
+--
+instance Binary ByteString where
+ put bs = do put (fromIntegral (L.length bs) :: Int)
+ putLazyByteString bs
+ get = get >>= getLazyByteString
+
+------------------------------------------------------------------------
+-- Maps and Sets
+
+instance (Binary a) => Binary (Set.Set a) where
+ put s = put (Set.size s) >> mapM_ put (Set.toAscList s)
+ get = liftM Set.fromDistinctAscList get
+
+instance (Binary k, Binary e) => Binary (Map.Map k e) where
+ put m = put (Map.size m) >> mapM_ put (Map.toAscList m)
+ get = liftM Map.fromDistinctAscList get
+
+instance Binary IntSet.IntSet where
+ put s = put (IntSet.size s) >> mapM_ put (IntSet.toAscList s)
+ get = liftM IntSet.fromDistinctAscList get
+
+instance (Binary e) => Binary (IntMap.IntMap e) where
+ put m = put (IntMap.size m) >> mapM_ put (IntMap.toAscList m)
+ get = liftM IntMap.fromDistinctAscList get
+
+------------------------------------------------------------------------
+-- Queues and Sequences
+
+#if __GLASGOW_HASKELL__ >= 606
+--
+-- This is valid Hugs, but you need the most recent Hugs
+--
+
+instance (Binary e) => Binary (Seq.Seq e) where
+ put s = put (Seq.length s) >> Fold.mapM_ put s
+ get = do n <- get :: Get Int
+ rep Seq.empty n get
+ where rep xs 0 _ = return $! xs
+ rep xs n g = xs `seq` n `seq` do
+ x <- g
+ rep (xs Seq.|> x) (n-1) g
+
+#endif
+
+------------------------------------------------------------------------
+-- Floating point
+
+instance Binary Double where
+ put d = put (decodeFloat d)
+ get = liftM2 encodeFloat get get
+
+instance Binary Float where
+ put f = put (decodeFloat f)
+ get = liftM2 encodeFloat get get
+
+------------------------------------------------------------------------
+-- Trees
+
+instance (Binary e) => Binary (T.Tree e) where
+ put (T.Node r s) = put r >> put s
+ get = liftM2 T.Node get get
+
+------------------------------------------------------------------------
+-- Arrays
+
+instance (Binary i, Ix i, Binary e) => Binary (Array i e) where
+ put a = do
+ put (bounds a)
+ put (rangeSize $ bounds a) -- write the length
+ mapM_ put (elems a) -- now the elems.
+ get = do
+ bs <- get
+ n <- get -- read the length
+ xs <- getMany n -- now the elems.
+ return (listArray bs xs)
+
+--
+-- The IArray UArray e constraint is non portable. Requires flexible instances
+--
+instance (Binary i, Ix i, Binary e, IArray UArray e) => Binary (UArray i e) where
+ put a = do
+ put (bounds a)
+ put (rangeSize $ bounds a) -- now write the length
+ mapM_ put (elems a)
+ get = do
+ bs <- get
+ n <- get
+ xs <- getMany n
+ return (listArray bs xs)
diff --git a/cabal/Cabal/Distribution/Compat/Binary/Generic.hs b/cabal/Cabal/Distribution/Compat/Binary/Generic.hs
new file mode 100644
index 0000000..aa6d27e
--- /dev/null
+++ b/cabal/Cabal/Distribution/Compat/Binary/Generic.hs
@@ -0,0 +1,128 @@
+{-# LANGUAGE BangPatterns, CPP, FlexibleInstances, KindSignatures,
+ ScopedTypeVariables, Trustworthy, TypeOperators, TypeSynonymInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Compat.Binary.Generic
+-- Copyright : Bryan O'Sullivan
+-- License : BSD3-style (see LICENSE)
+--
+-- Maintainer : Bryan O'Sullivan <bos@serpentine.com>
+-- Stability : unstable
+-- Portability : Only works with GHC 7.2 and newer
+--
+-- Instances for supporting GHC generics.
+--
+-----------------------------------------------------------------------------
+module Distribution.Compat.Binary.Generic
+ (
+ ) where
+
+import Control.Applicative
+import Distribution.Compat.Binary.Class
+import Data.Binary.Get
+import Data.Binary.Put
+import Data.Bits
+import Data.Word
+import GHC.Generics
+
+-- Type without constructors
+instance GBinary V1 where
+ gput _ = return ()
+ gget = return undefined
+
+-- Constructor without arguments
+instance GBinary U1 where
+ gput U1 = return ()
+ gget = return U1
+
+-- Product: constructor with parameters
+instance (GBinary a, GBinary b) => GBinary (a :*: b) where
+ gput (x :*: y) = gput x >> gput y
+ gget = (:*:) <$> gget <*> gget
+
+-- Metadata (constructor name, etc)
+instance GBinary a => GBinary (M1 i c a) where
+ gput = gput . unM1
+ gget = M1 <$> gget
+
+-- Constants, additional parameters, and rank-1 recursion
+instance Binary a => GBinary (K1 i a) where
+ gput = put . unK1
+ gget = K1 <$> get
+
+-- Borrowed from the cereal package.
+
+-- The following GBinary instance for sums has support for serializing
+-- types with up to 2^64-1 constructors. It will use the minimal
+-- number of bytes needed to encode the constructor. For example when
+-- a type has 2^8 constructors or less it will use a single byte to
+-- encode the constructor. If it has 2^16 constructors or less it will
+-- use two bytes, and so on till 2^64-1.
+
+#define GUARD(WORD) (size - 1) <= fromIntegral (maxBound :: WORD)
+#define PUTSUM(WORD) GUARD(WORD) = putSum (0 :: WORD) (fromIntegral size)
+#define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral size)
+
+instance ( GSum a, GSum b
+ , GBinary a, GBinary b
+ , SumSize a, SumSize b) => GBinary (a :+: b) where
+ gput | PUTSUM(Word8) | PUTSUM(Word16) | PUTSUM(Word32) | PUTSUM(Word64)
+ | otherwise = sizeError "encode" size
+ where
+ size = unTagged (sumSize :: Tagged (a :+: b) Word64)
+
+ gget | GETSUM(Word8) | GETSUM(Word16) | GETSUM(Word32) | GETSUM(Word64)
+ | otherwise = sizeError "decode" size
+ where
+ size = unTagged (sumSize :: Tagged (a :+: b) Word64)
+
+sizeError :: Show size => String -> size -> error
+sizeError s size =
+ error $ "Can't " ++ s ++ " a type with " ++ show size ++ " constructors"
+
+------------------------------------------------------------------------
+
+checkGetSum :: (Ord word, Num word, Bits word, GSum f)
+ => word -> word -> Get (f a)
+checkGetSum size code | code < size = getSum code size
+ | otherwise = fail "Unknown encoding for constructor"
+{-# INLINE checkGetSum #-}
+
+class GSum f where
+ getSum :: (Ord word, Num word, Bits word) => word -> word -> Get (f a)
+ putSum :: (Num w, Bits w, Binary w) => w -> w -> f a -> Put
+
+instance (GSum a, GSum b, GBinary a, GBinary b) => GSum (a :+: b) where
+ getSum !code !size | code < sizeL = L1 <$> getSum code sizeL
+ | otherwise = R1 <$> getSum (code - sizeL) sizeR
+ where
+ sizeL = size `shiftR` 1
+ sizeR = size - sizeL
+
+ putSum !code !size s = case s of
+ L1 x -> putSum code sizeL x
+ R1 x -> putSum (code + sizeL) sizeR x
+ where
+ sizeL = size `shiftR` 1
+ sizeR = size - sizeL
+
+instance GBinary a => GSum (C1 c a) where
+ getSum _ _ = gget
+
+ putSum !code _ x = put code *> gput x
+
+------------------------------------------------------------------------
+
+class SumSize f where
+ sumSize :: Tagged f Word64
+
+newtype Tagged (s :: * -> *) b = Tagged {unTagged :: b}
+
+instance (SumSize a, SumSize b) => SumSize (a :+: b) where
+ sumSize = Tagged $ unTagged (sumSize :: Tagged a Word64) +
+ unTagged (sumSize :: Tagged b Word64)
+
+instance SumSize (C1 c a) where
+ sumSize = Tagged 1
diff --git a/cabal/Cabal/Distribution/Compat/CreatePipe.hs b/cabal/Cabal/Distribution/Compat/CreatePipe.hs
new file mode 100644
index 0000000..22b3b2e
--- /dev/null
+++ b/cabal/Cabal/Distribution/Compat/CreatePipe.hs
@@ -0,0 +1,62 @@
+{-# LANGUAGE CPP, ForeignFunctionInterface #-}
+module Distribution.Compat.CreatePipe (createPipe) where
+
+import System.IO (Handle, hSetEncoding, localeEncoding)
+
+-- The mingw32_HOST_OS CPP macro is GHC-specific
+#if mingw32_HOST_OS
+import Control.Exception (onException)
+import Foreign.C.Error (throwErrnoIfMinus1_)
+import Foreign.C.Types (CInt(..), CUInt(..))
+import Foreign.Ptr (Ptr)
+import Foreign.Marshal.Array (allocaArray)
+import Foreign.Storable (peek, peekElemOff)
+import GHC.IO.FD (mkFD)
+import GHC.IO.Device (IODeviceType(Stream))
+import GHC.IO.Handle.FD (mkHandleFromFD)
+import System.IO (IOMode(ReadMode, WriteMode))
+#elif ghcjs_HOST_OS
+#else
+import System.Posix.IO (fdToHandle)
+import qualified System.Posix.IO as Posix
+#endif
+
+createPipe :: IO (Handle, Handle)
+-- The mingw32_HOST_OS CPP macro is GHC-specific
+#if mingw32_HOST_OS
+createPipe = do
+ (readfd, writefd) <- allocaArray 2 $ \ pfds -> do
+ throwErrnoIfMinus1_ "_pipe" $ c__pipe pfds 2 ({- _O_BINARY -} 32768)
+ readfd <- peek pfds
+ writefd <- peekElemOff pfds 1
+ return (readfd, writefd)
+ (do readh <- fdToHandle readfd ReadMode
+ writeh <- fdToHandle writefd WriteMode
+ hSetEncoding readh localeEncoding
+ hSetEncoding writeh localeEncoding
+ return (readh, writeh)) `onException` (close readfd >> close writefd)
+ where
+ fdToHandle :: CInt -> IOMode -> IO Handle
+ fdToHandle fd mode = do
+ (fd', deviceType) <- mkFD fd mode (Just (Stream, 0, 0)) False False
+ mkHandleFromFD fd' deviceType "" mode False Nothing
+
+ close :: CInt -> IO ()
+ close = throwErrnoIfMinus1_ "_close" . c__close
+
+foreign import ccall "io.h _pipe" c__pipe ::
+ Ptr CInt -> CUInt -> CInt -> IO CInt
+
+foreign import ccall "io.h _close" c__close ::
+ CInt -> IO CInt
+#elif ghcjs_HOST_OS
+createPipe = error "createPipe"
+#else
+createPipe = do
+ (readfd, writefd) <- Posix.createPipe
+ readh <- fdToHandle readfd
+ writeh <- fdToHandle writefd
+ hSetEncoding readh localeEncoding
+ hSetEncoding writeh localeEncoding
+ return (readh, writeh)
+#endif
diff --git a/cabal/Cabal/Distribution/Compat/Environment.hs b/cabal/Cabal/Distribution/Compat/Environment.hs
index 6430767..69cde27 100644
--- a/cabal/Cabal/Distribution/Compat/Environment.hs
+++ b/cabal/Cabal/Distribution/Compat/Environment.hs
@@ -1,14 +1,29 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
{-# OPTIONS_HADDOCK hide #-}
-module Distribution.Compat.Environment (getEnvironment)
+module Distribution.Compat.Environment
+ ( getEnvironment, lookupEnv, setEnv )
where
import qualified System.Environment as System
+#if __GLASGOW_HASKELL__ >= 706
+import System.Environment (lookupEnv)
+#else
+import Distribution.Compat.Exception (catchIO)
+#endif
#ifdef mingw32_HOST_OS
+import Control.Monad
import qualified Data.Char as Char (toUpper)
-#endif
+import Foreign.C
+import GHC.Windows
+#else
+import Foreign.C.Types
+import Foreign.C.String
+import Foreign.C.Error (throwErrnoIfMinus1_)
+import System.Posix.Internals ( withFilePath )
+#endif /* mingw32_HOST_OS */
getEnvironment :: IO [(String, String)]
#ifdef mingw32_HOST_OS
@@ -22,3 +37,53 @@ getEnvironment = fmap upcaseVars System.getEnvironment
#else
getEnvironment = System.getEnvironment
#endif
+
+#if __GLASGOW_HASKELL__ < 706
+-- | @lookupEnv var@ returns the value of the environment variable @var@, or
+-- @Nothing@ if there is no such value.
+lookupEnv :: String -> IO (Maybe String)
+lookupEnv name = (Just `fmap` System.getEnv name) `catchIO` const (return Nothing)
+#endif /* __GLASGOW_HASKELL__ < 706 */
+
+-- | @setEnv name value@ sets the specified environment variable to @value@.
+--
+-- Throws `Control.Exception.IOException` if either @name@ or @value@ is the
+-- empty string or contains an equals sign.
+setEnv :: String -> String -> IO ()
+setEnv key value_
+ | null value = error "Distribuiton.Compat.setEnv: empty string"
+ | otherwise = setEnv_ key value
+ where
+ -- NOTE: Anything that follows NUL is ignored on both POSIX and Windows. We
+ -- still strip it manually so that the null check above succeeds if a value
+ -- starts with NUL.
+ value = takeWhile (/= '\NUL') value_
+
+setEnv_ :: String -> String -> IO ()
+
+#ifdef mingw32_HOST_OS
+
+setEnv_ key value = withCWString key $ \k -> withCWString value $ \v -> do
+ success <- c_SetEnvironmentVariable k v
+ unless success (throwGetLastError "setEnv")
+
+# if defined(i386_HOST_ARCH)
+# define WINDOWS_CCONV stdcall
+# elif defined(x86_64_HOST_ARCH)
+# define WINDOWS_CCONV ccall
+# else
+# error Unknown mingw32 arch
+# endif /* i386_HOST_ARCH */
+
+foreign import WINDOWS_CCONV unsafe "windows.h SetEnvironmentVariableW"
+ c_SetEnvironmentVariable :: LPTSTR -> LPTSTR -> IO Bool
+#else
+setEnv_ key value = do
+ withFilePath key $ \ keyP ->
+ withFilePath value $ \ valueP ->
+ throwErrnoIfMinus1_ "setenv" $
+ c_setenv keyP valueP (fromIntegral (fromEnum True))
+
+foreign import ccall unsafe "setenv"
+ c_setenv :: CString -> CString -> CInt -> IO CInt
+#endif /* mingw32_HOST_OS */
diff --git a/cabal/Cabal/Distribution/Compat/ReadP.hs b/cabal/Cabal/Distribution/Compat/ReadP.hs
index c4fc7b1..3a50838 100644
--- a/cabal/Cabal/Distribution/Compat/ReadP.hs
+++ b/cabal/Cabal/Distribution/Compat/ReadP.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Compat.ReadP
@@ -14,7 +15,7 @@
-- it makes no difference which branch is \"shorter\".
--
-- See also Koen's paper /Parallel Parsing Processes/
--- (<http://www.cs.chalmers.se/~koen/publications.html>).
+-- (<http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.19.9217>).
--
-- This version of ReadP has been locally hacked to make it H98, by
-- Martin Sj&#xF6;gren <mailto:msjogren@gmail.com>
@@ -71,7 +72,10 @@ module Distribution.Compat.ReadP
import Control.Monad( MonadPlus(..), liftM, liftM2, ap )
import Data.Char (isSpace)
-import Control.Applicative (Applicative(..), Alternative(empty, (<|>)))
+#if __GLASGOW_HASKELL__ < 710
+import Control.Applicative (Applicative(..))
+#endif
+import Control.Applicative (Alternative(empty, (<|>)))
infixr 5 +++, <++
diff --git a/cabal/Cabal/Distribution/Compat/TempFile.hs b/cabal/Cabal/Distribution/Compat/TempFile.hs
index fe01c29..5892340 100644
--- a/cabal/Cabal/Distribution/Compat/TempFile.hs
+++ b/cabal/Cabal/Distribution/Compat/TempFile.hs
@@ -25,7 +25,7 @@ import Foreign.C (getErrno, errnoToIOError)
import System.Posix.Internals (c_getpid)
-#ifdef mingw32_HOST_OS
+#if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS)
import System.Directory ( createDirectory )
#else
import qualified System.Posix
@@ -37,7 +37,8 @@ import qualified System.Posix
-- 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
+-- TODO: Not sure about JHC
+-- TODO: This file should probably be removed.
-- This is a copy/paste of the openBinaryTempFile definition, but
-- if uses 666 rather than 600 for the permissions. The base library
@@ -49,7 +50,7 @@ openNewBinaryFile dir template = do
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.
+ -- below file path in the hierarchy here.
(prefix,suffix) =
case break (== '.') $ reverse template of
-- First case: template contains no '.'s. Just re-reverse it.
@@ -76,9 +77,9 @@ openNewBinaryFile dir template = do
then findTempName (x+1)
else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir))
else do
- -- TODO: We want to tell fdToHandle what the filepath is,
+ -- TODO: We want to tell fdToHandle what the file path is,
-- as any exceptions etc will only be able to report the
- -- fd currently
+ -- FD currently
h <- fdToHandle fd `onException` c_close fd
return (filepath, h)
where
@@ -92,7 +93,7 @@ openNewBinaryFile dir template = do
| last a == pathSeparator = a ++ b
| otherwise = a ++ [pathSeparator] ++ b
--- FIXME: Should use filepath library
+-- FIXME: Should use System.FilePath library
pathSeparator :: Char
#ifdef mingw32_HOST_OS
pathSeparator = '\\'
@@ -120,7 +121,7 @@ createTempDirectory dir template = do
| otherwise -> ioError e
mkPrivateDir :: String -> IO ()
-#ifdef mingw32_HOST_OS
+#if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS)
mkPrivateDir s = createDirectory s
#else
mkPrivateDir s = System.Posix.createDirectory s 0o700
diff --git a/cabal/Cabal/Distribution/Compiler.hs b/cabal/Cabal/Distribution/Compiler.hs
index b2f07eb..dc99b2f 100644
--- a/cabal/Cabal/Distribution/Compiler.hs
+++ b/cabal/Cabal/Distribution/Compiler.hs
@@ -1,8 +1,11 @@
{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
+
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Compiler
-- Copyright : Isaac Jones 2003-2004
+-- License : BSD3
--
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
@@ -22,36 +25,6 @@
-- moment we just have to live with this deficiency. If you're interested, see
-- ticket #57.
-{- 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(..),
@@ -62,12 +35,21 @@ module Distribution.Compiler (
-- * Compiler id
CompilerId(..),
+
+ -- * Compiler info
+ CompilerInfo(..),
+ unknownCompilerInfo,
+ AbiTag(..), abiTagString
) where
+import Distribution.Compat.Binary (Binary)
import Data.Data (Data)
import Data.Typeable (Typeable)
import Data.Maybe (fromMaybe)
import Distribution.Version (Version(..))
+import GHC.Generics (Generic)
+
+import Language.Haskell.Extension (Language, Extension)
import qualified System.Info (compilerName, compilerVersion)
import Distribution.Text (Text(..), display)
@@ -78,13 +60,15 @@ 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
+data CompilerFlavor = GHC | GHCJS | NHC | YHC | Hugs | HBC | Helium | JHC | LHC | UHC
| HaskellSuite String -- string is the id of the actual compiler
| OtherCompiler String
- deriving (Show, Read, Eq, Ord, Typeable, Data)
+ deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)
+
+instance Binary CompilerFlavor
knownCompilerFlavors :: [CompilerFlavor]
-knownCompilerFlavors = [GHC, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC]
+knownCompilerFlavors = [GHC, GHCJS, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC]
instance Text CompilerFlavor where
disp (OtherCompiler name) = Disp.text name
@@ -154,7 +138,9 @@ defaultCompilerFlavor = case buildCompilerFlavor of
-- ------------------------------------------------------------
data CompilerId = CompilerId CompilerFlavor Version
- deriving (Eq, Ord, Read, Show)
+ deriving (Eq, Generic, Ord, Read, Show)
+
+instance Binary CompilerId
instance Text CompilerId where
disp (CompilerId f (Version [] _)) = disp f
@@ -167,3 +153,52 @@ instance Text CompilerId where
lowercase :: String -> String
lowercase = map Char.toLower
+
+-- ------------------------------------------------------------
+-- * Compiler Info
+-- ------------------------------------------------------------
+
+-- | Compiler information used for resolving configurations. Some fields can be
+-- set to Nothing to indicate that the information is unknown.
+
+data CompilerInfo = CompilerInfo {
+ compilerInfoId :: CompilerId,
+ -- ^ Compiler flavour and version.
+ compilerInfoAbiTag :: AbiTag,
+ -- ^ Tag for distinguishing incompatible ABI's on the same architecture/os.
+ compilerInfoCompat :: Maybe [CompilerId],
+ -- ^ Other implementations that this compiler claims to be compatible with, if known.
+ compilerInfoLanguages :: Maybe [Language],
+ -- ^ Supported language standards, if known.
+ compilerInfoExtensions :: Maybe [Extension]
+ -- ^ Supported extensions, if known.
+ }
+ deriving (Generic, Show, Read)
+
+instance Binary CompilerInfo
+
+data AbiTag
+ = NoAbiTag
+ | AbiTag String
+ deriving (Generic, Show, Read)
+
+instance Binary AbiTag
+
+instance Text AbiTag where
+ disp NoAbiTag = Disp.empty
+ disp (AbiTag tag) = Disp.text tag
+
+ parse = do
+ tag <- Parse.munch (\c -> Char.isAlphaNum c || c == '_')
+ if null tag then return NoAbiTag else return (AbiTag tag)
+
+abiTagString :: AbiTag -> String
+abiTagString NoAbiTag = ""
+abiTagString (AbiTag tag) = tag
+
+-- | Make a CompilerInfo of which only the known information is its CompilerId,
+-- its AbiTag and that it does not claim to be compatible with other
+-- compiler id's.
+unknownCompilerInfo :: CompilerId -> AbiTag -> CompilerInfo
+unknownCompilerInfo compilerId abiTag =
+ CompilerInfo compilerId abiTag (Just []) Nothing Nothing
diff --git a/cabal/Cabal/Distribution/InstalledPackageInfo.hs b/cabal/Cabal/Distribution/InstalledPackageInfo.hs
index dfccb1d..2ca113f 100644
--- a/cabal/Cabal/Distribution/InstalledPackageInfo.hs
+++ b/cabal/Cabal/Distribution/InstalledPackageInfo.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE DeriveGeneric #-}
+
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.InstalledPackageInfo
@@ -22,40 +24,12 @@
-- 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,
+ InstalledPackageInfo(..),
+ libraryName,
+ OriginalModule(..), ExposedModule(..),
ParseResult(..), PError(..), PWarning,
emptyInstalledPackageInfo,
parseInstalledPackageInfo,
@@ -72,29 +46,37 @@ import Distribution.ParseUtils
, parseFieldsFlat
, parseFilePathQ, parseTokenQ, parseModuleNameQ, parsePackageNameQ
, showFilePath, showToken, boolField, parseOptVersion
- , parseFreeText, showFreeText )
+ , parseFreeText, showFreeText, parseOptCommaList )
import Distribution.License ( License(..) )
import Distribution.Package
( PackageName(..), PackageIdentifier(..)
, PackageId, InstalledPackageId(..)
- , packageName, packageVersion )
+ , packageName, packageVersion, PackageKey(..)
+ , LibraryName(..) )
import qualified Distribution.Package as Package
- ( Package(..) )
import Distribution.ModuleName
( ModuleName )
import Distribution.Version
( Version(..) )
import Distribution.Text
( Text(disp, parse) )
+import Text.PrettyPrint as Disp
+import qualified Distribution.Compat.ReadP as Parse
+
+import Distribution.Compat.Binary (Binary)
+import Data.Maybe (fromMaybe)
+import GHC.Generics (Generic)
-- -----------------------------------------------------------------------------
-- The InstalledPackageInfo type
-data InstalledPackageInfo_ m
+
+data InstalledPackageInfo
= InstalledPackageInfo {
-- these parts are exactly the same as PackageDescription
installedPackageId :: InstalledPackageId,
sourcePackageId :: PackageId,
+ packageKey :: PackageKey,
license :: License,
copyright :: String,
maintainer :: String,
@@ -107,38 +89,51 @@ data InstalledPackageInfo_ m
category :: String,
-- these parts are required by an installed package only:
exposed :: Bool,
- exposedModules :: [m],
- hiddenModules :: [m],
+ exposedModules :: [ExposedModule],
+ instantiatedWith :: [(ModuleName, OriginalModule)],
+ hiddenModules :: [ModuleName],
trusted :: Bool,
- importDirs :: [FilePath], -- contain sources in case of Hugs
+ importDirs :: [FilePath],
libraryDirs :: [FilePath],
+ dataDir :: 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]
+ haddockHTMLs :: [FilePath],
+ pkgRoot :: Maybe FilePath
}
- deriving (Read, Show)
+ deriving (Generic, Read, Show)
+
+libraryName :: InstalledPackageInfo -> LibraryName
+libraryName ipi = Package.packageKeyLibraryName (sourcePackageId ipi) (packageKey ipi)
-instance Package.Package (InstalledPackageInfo_ str) where
+instance Binary InstalledPackageInfo
+
+instance Package.Package InstalledPackageInfo where
packageId = sourcePackageId
-type InstalledPackageInfo = InstalledPackageInfo_ ModuleName
+instance Package.HasInstalledPackageId InstalledPackageInfo where
+ installedPackageId = installedPackageId
+
+instance Package.PackageInstalled InstalledPackageInfo where
+ installedDepends = depends
-emptyInstalledPackageInfo :: InstalledPackageInfo_ m
+emptyInstalledPackageInfo :: InstalledPackageInfo
emptyInstalledPackageInfo
= InstalledPackageInfo {
installedPackageId = InstalledPackageId "",
sourcePackageId = PackageIdentifier (PackageName "") noVersion,
- license = AllRightsReserved,
+ packageKey = OldPackageKey (PackageIdentifier
+ (PackageName "") noVersion),
+ license = UnspecifiedLicense,
copyright = "",
maintainer = "",
author = "",
@@ -151,33 +146,115 @@ emptyInstalledPackageInfo
exposed = False,
exposedModules = [],
hiddenModules = [],
+ instantiatedWith = [],
trusted = False,
importDirs = [],
libraryDirs = [],
+ dataDir = "",
hsLibraries = [],
extraLibraries = [],
extraGHCiLibraries= [],
includeDirs = [],
includes = [],
depends = [],
- hugsOptions = [],
ccOptions = [],
ldOptions = [],
frameworkDirs = [],
frameworks = [],
haddockInterfaces = [],
- haddockHTMLs = []
+ haddockHTMLs = [],
+ pkgRoot = Nothing
}
noVersion :: Version
-noVersion = Version{ versionBranch=[], versionTags=[] }
+noVersion = Version [] []
+
+-- -----------------------------------------------------------------------------
+-- Exposed modules
+
+data OriginalModule
+ = OriginalModule {
+ originalPackageId :: InstalledPackageId,
+ originalModuleName :: ModuleName
+ }
+ deriving (Generic, Eq, Read, Show)
+
+data ExposedModule
+ = ExposedModule {
+ exposedName :: ModuleName,
+ exposedReexport :: Maybe OriginalModule,
+ exposedSignature :: Maybe OriginalModule -- This field is unused for now.
+ }
+ deriving (Generic, Read, Show)
+
+instance Text OriginalModule where
+ disp (OriginalModule ipi m) =
+ disp ipi <> Disp.char ':' <> disp m
+ parse = do
+ ipi <- parse
+ _ <- Parse.char ':'
+ m <- parse
+ return (OriginalModule ipi m)
+
+instance Text ExposedModule where
+ disp (ExposedModule m reexport signature) =
+ Disp.sep [ disp m
+ , case reexport of
+ Just m' -> Disp.sep [Disp.text "from", disp m']
+ Nothing -> Disp.empty
+ , case signature of
+ Just m' -> Disp.sep [Disp.text "is", disp m']
+ Nothing -> Disp.empty
+ ]
+ parse = do
+ m <- parseModuleNameQ
+ Parse.skipSpaces
+ reexport <- Parse.option Nothing $ do
+ _ <- Parse.string "from"
+ Parse.skipSpaces
+ fmap Just parse
+ Parse.skipSpaces
+ signature <- Parse.option Nothing $ do
+ _ <- Parse.string "is"
+ Parse.skipSpaces
+ fmap Just parse
+ return (ExposedModule m reexport signature)
+
+
+instance Binary OriginalModule
+
+instance Binary ExposedModule
+
+-- To maintain backwards-compatibility, we accept both comma/non-comma
+-- separated variants of this field. You SHOULD use the comma syntax if you
+-- use any new functions, although actually it's unambiguous due to a quirk
+-- of the fact that modules must start with capital letters.
+
+showExposedModules :: [ExposedModule] -> Disp.Doc
+showExposedModules xs
+ | all isExposedModule xs = fsep (map disp xs)
+ | otherwise = fsep (Disp.punctuate comma (map disp xs))
+ where isExposedModule (ExposedModule _ Nothing Nothing) = True
+ isExposedModule _ = False
+
+parseExposedModules :: Parse.ReadP r [ExposedModule]
+parseExposedModules = parseOptCommaList parse
-- -----------------------------------------------------------------------------
-- Parsing
parseInstalledPackageInfo :: String -> ParseResult InstalledPackageInfo
parseInstalledPackageInfo =
- parseFieldsFlat fieldsInstalledPackageInfo emptyInstalledPackageInfo
+ parseFieldsFlat (fieldsInstalledPackageInfo ++ deprecatedFieldDescrs)
+ emptyInstalledPackageInfo
+
+parseInstantiatedWith :: Parse.ReadP r (ModuleName, OriginalModule)
+parseInstantiatedWith = do k <- parse
+ _ <- Parse.char '='
+ n <- parse
+ _ <- Parse.char '@'
+ p <- parse
+ return (k, OriginalModule p n)
-- -----------------------------------------------------------------------------
-- Pretty-printing
@@ -191,6 +268,9 @@ showInstalledPackageInfoField = showSingleNamedField fieldsInstalledPackageInfo
showSimpleInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String)
showSimpleInstalledPackageInfoField = showSimpleSingleNamedField fieldsInstalledPackageInfo
+showInstantiatedWith :: (ModuleName, OriginalModule) -> Doc
+showInstantiatedWith (k, OriginalModule p m) = disp k <> text "=" <> disp m <> text "@" <> disp p
+
-- -----------------------------------------------------------------------------
-- Description of the fields, for parsing/printing
@@ -208,6 +288,9 @@ basicFieldDescrs =
, simpleField "id"
disp parse
installedPackageId (\ipid pkg -> pkg{installedPackageId=ipid})
+ , simpleField "key"
+ disp parse
+ packageKey (\pk pkg -> pkg{packageKey=pk})
, simpleField "license"
disp parseLicenseQ
license (\l pkg -> pkg{license=l})
@@ -244,12 +327,15 @@ installedFieldDescrs :: [FieldDescr InstalledPackageInfo]
installedFieldDescrs = [
boolField "exposed"
exposed (\val pkg -> pkg{exposed=val})
- , listField "exposed-modules"
- disp parseModuleNameQ
+ , simpleField "exposed-modules"
+ showExposedModules parseExposedModules
exposedModules (\xs pkg -> pkg{exposedModules=xs})
, listField "hidden-modules"
disp parseModuleNameQ
hiddenModules (\xs pkg -> pkg{hiddenModules=xs})
+ , listField "instantiated-with"
+ showInstantiatedWith parseInstantiatedWith
+ instantiatedWith (\xs pkg -> pkg{instantiatedWith=xs})
, boolField "trusted"
trusted (\val pkg -> pkg{trusted=val})
, listField "import-dirs"
@@ -258,6 +344,9 @@ installedFieldDescrs = [
, listField "library-dirs"
showFilePath parseFilePathQ
libraryDirs (\xs pkg -> pkg{libraryDirs=xs})
+ , simpleField "data-dir"
+ showFilePath (parseFilePathQ Parse.<++ return "")
+ dataDir (\val pkg -> pkg{dataDir=val})
, listField "hs-libraries"
showFilePath parseTokenQ
hsLibraries (\xs pkg -> pkg{hsLibraries=xs})
@@ -276,9 +365,6 @@ installedFieldDescrs = [
, 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})
@@ -297,4 +383,14 @@ installedFieldDescrs = [
, listField "haddock-html"
showFilePath parseFilePathQ
haddockHTMLs (\xs pkg -> pkg{haddockHTMLs=xs})
+ , simpleField "pkgroot"
+ (const Disp.empty) parseFilePathQ
+ (fromMaybe "" . pkgRoot) (\xs pkg -> pkg{pkgRoot=Just xs})
]
+
+deprecatedFieldDescrs :: [FieldDescr InstalledPackageInfo]
+deprecatedFieldDescrs = [
+ listField "hugs-options"
+ showToken parseTokenQ
+ (const []) (const id)
+ ]
diff --git a/cabal/Cabal/Distribution/Lex.hs b/cabal/Cabal/Distribution/Lex.hs
new file mode 100644
index 0000000..2da9de8
--- /dev/null
+++ b/cabal/Cabal/Distribution/Lex.hs
@@ -0,0 +1,55 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE PatternGuards #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Lex
+-- Copyright : Ben Gamari 2015-2019
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Portability : portable
+--
+-- This module contains a simple lexer supporting quoted strings
+
+module Distribution.Lex (
+ tokenizeQuotedWords
+ ) where
+
+import Data.Char (isSpace)
+#if __GLASGOW_HASKELL__ < 710
+import Data.Monoid
+#endif
+
+newtype DList a = DList ([a] -> [a])
+
+runDList :: DList a -> [a]
+runDList (DList run) = run []
+
+singleton :: a -> DList a
+singleton a = DList (a:)
+
+instance Monoid (DList a) where
+ mempty = DList id
+ DList a `mappend` DList b = DList (a . b)
+
+tokenizeQuotedWords :: String -> [String]
+tokenizeQuotedWords = filter (not . null) . go False mempty
+ where
+ go :: Bool -- ^ in quoted region
+ -> DList Char -- ^ accumulator
+ -> String -- ^ string to be parsed
+ -> [String] -- ^ parse result
+ go _ accum []
+ | [] <- accum' = []
+ | otherwise = [accum']
+ where accum' = runDList accum
+
+ go False accum (c:cs)
+ | isSpace c = runDList accum : go False mempty cs
+ | c == '"' = go True accum cs
+
+ go True accum (c:cs)
+ | c == '"' = go False accum cs
+
+ go quoted accum (c:cs)
+ = go quoted (accum `mappend` singleton c) cs
+
diff --git a/cabal/Cabal/Distribution/License.hs b/cabal/Cabal/Distribution/License.hs
index 9078297..1d06e4a 100644
--- a/cabal/Cabal/Distribution/License.hs
+++ b/cabal/Cabal/Distribution/License.hs
@@ -1,52 +1,46 @@
{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
+
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.License
+-- Description : The License data type.
-- Copyright : Isaac Jones 2003-2005
-- Duncan Coutts 2008
+-- License : BSD3
--
-- 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/>.
+-- Package descriptions contain fields for specifying the name of a software
+-- license and the name of the file containing the text of that license. While
+-- package authors may choose any license they like, Cabal provides an
+-- enumeration of a small set of common free and open source software licenses.
+-- This is done so that Hackage can recognise licenses, so that tools can detect
+-- <https://en.wikipedia.org/wiki/License_compatibility licensing conflicts>,
+-- and to deter
+-- <https://en.wikipedia.org/wiki/License_proliferation license proliferation>.
+--
+-- It is recommended that all package authors use the @license-file@ or
+-- @license-files@ fields in their package descriptions. Further information
+-- about these fields can be found in the
+-- <http://www.haskell.org/cabal/users-guide/developing-packages.html#package-descriptions Cabal users guide>.
+--
+-- = Additional resources
+--
+-- The following websites provide information about free and open source
+-- software licenses:
+--
+-- * <http://www.opensource.org The Open Source Initiative (OSI)>
+--
+-- * <https://www.fsf.org The Free Software Foundation (FSF)>
+--
+-- = Disclaimer
--
--- 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', 'AGPL', 'LGPL', 'Apache 2.0', 'MIT' 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. -}
+-- The descriptions of software licenses provided by this documentation are
+-- intended for informational purposes only and in no way constitute legal
+-- advice. Please read the text of the licenses and consult a lawyer for any
+-- advice regarding software licensing.
module Distribution.License (
License(..),
@@ -59,66 +53,87 @@ import Distribution.Text (Text(..), display)
import qualified Distribution.Compat.ReadP as Parse
import qualified Text.PrettyPrint as Disp
import Text.PrettyPrint ((<>))
+import Distribution.Compat.Binary (Binary)
import qualified Data.Char as Char (isAlphaNum)
import Data.Data (Data)
import Data.Typeable (Typeable)
+import GHC.Generics (Generic)
--- |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.
---
+-- | Indicates the license under which a package's source code is released.
+-- Versions of the licenses not listed here will be rejected by Hackage and
+-- cause @cabal check@ to issue a warning.
data License =
+ -- TODO: * remove BSD4
---TODO: * remove BSD4
-
- -- | GNU Public License. Source code must accompany alterations.
+ -- | GNU General Public License,
+ -- <https://www.gnu.org/licenses/old-licenses/gpl-2.0.html version 2> or
+ -- <https://www.gnu.org/licenses/gpl.html version 3>.
GPL (Maybe Version)
- -- | GNU Affero General Public License
+ -- | <https://www.gnu.org/licenses/agpl.html GNU Affero General Public License, version 3>.
| AGPL (Maybe Version)
- -- | Lesser GPL, Less restrictive than GPL, useful for libraries.
+ -- | GNU Lesser General Public License,
+ -- <https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html version 2.1> or
+ -- <https://www.gnu.org/licenses/lgpl.html version 3>.
| LGPL (Maybe Version)
- -- | 3-clause BSD license, newer, no advertising clause. Very free license.
+ -- | <http://www.opensource.org/licenses/bsd-license 2-clause BSD license>.
+ | BSD2
+
+ -- | <http://www.opensource.org/licenses/bsd-3-clause 3-clause BSD license>.
| BSD3
- -- | 4-clause BSD license, older, with advertising clause. You almost
- -- certainly want to use the BSD3 license instead.
+ -- | <http://directory.fsf.org/wiki/License:BSD_4Clause 4-clause BSD license>.
+ -- This license has not been approved by the OSI and is incompatible with
+ -- the GNU GPL. It is provided for historical reasons and should be avoided.
| BSD4
- -- | The MIT license, similar to the BSD3. Very free license.
+ -- | <http://www.opensource.org/licenses/MIT MIT license>.
| MIT
- -- | The Apache License. Version 2.0 is the current version,
- -- previous versions are considered historical.
+ -- | <http://www.isc.org/downloads/software-support-policy/isc-license/ ISC license>
+ | ISC
+
+ -- | <https://www.mozilla.org/MPL/ Mozilla Public License, version 2.0>.
+ | MPL Version
+ -- | <https://www.apache.org/licenses/ Apache License, version 2.0>.
| Apache (Maybe Version)
- -- | Holder makes no claim to ownership, least restrictive license.
+ -- | The author of a package disclaims any copyright to its source code and
+ -- dedicates it to the public domain. This is not a software license. Please
+ -- note that it is not possible to dedicate works to the public domain in
+ -- every jurisdiction, nor is a work that is in the public domain in one
+ -- jurisdiction necessarily in the public domain elsewhere.
| PublicDomain
- -- | No rights are granted to others. Undistributable. Most restrictive.
+ -- | Explicitly 'All Rights Reserved', eg for proprietary software. The
+ -- package may not be legally modified or redistributed by anyone but the
+ -- rightsholder.
| AllRightsReserved
- -- | Some other license.
+ -- | No license specified which legally defaults to 'All Rights Reserved'.
+ -- The package may not be legally modified or redistributed by anyone but
+ -- the rightsholder.
+ | UnspecifiedLicense
+
+ -- | Any other software license.
| OtherLicense
- -- | Not a recognised license.
- -- Allows us to deal with future extensions more gracefully.
+ -- | Indicates an erroneous license name.
| UnknownLicense String
- deriving (Read, Show, Eq, Typeable, Data)
+ deriving (Generic, Read, Show, Eq, Typeable, Data)
+
+instance Binary License
+-- | The list of all currently recognised licenses.
knownLicenses :: [License]
-knownLicenses = [ GPL unversioned, GPL (version [2]), GPL (version [3])
- , LGPL unversioned, LGPL (version [2,1]), LGPL (version [3])
- , AGPL unversioned, AGPL (version [3])
- , BSD3, MIT
+knownLicenses = [ GPL unversioned, GPL (version [2]), GPL (version [3])
+ , LGPL unversioned, LGPL (version [2, 1]), LGPL (version [3])
+ , AGPL unversioned, AGPL (version [3])
+ , BSD2, BSD3, MIT, ISC
+ , MPL (Version [2, 0] [])
, Apache unversioned, Apache (version [2, 0])
, PublicDomain, AllRightsReserved, OtherLicense]
where
@@ -126,9 +141,10 @@ knownLicenses = [ GPL unversioned, GPL (version [2]), GPL (version [3])
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 (AGPL version) = Disp.text "AGPL" <> dispOptVersion version
+ disp (GPL version) = Disp.text "GPL" <> dispOptVersion version
+ disp (LGPL version) = Disp.text "LGPL" <> dispOptVersion version
+ disp (AGPL version) = Disp.text "AGPL" <> dispOptVersion version
+ disp (MPL version) = Disp.text "MPL" <> dispVersion version
disp (Apache version) = Disp.text "Apache" <> dispOptVersion version
disp (UnknownLicense other) = Disp.text other
disp other = Disp.text (show other)
@@ -140,16 +156,22 @@ instance Text License where
("GPL", _ ) -> GPL version
("LGPL", _ ) -> LGPL version
("AGPL", _ ) -> AGPL version
+ ("BSD2", Nothing) -> BSD2
("BSD3", Nothing) -> BSD3
("BSD4", Nothing) -> BSD4
+ ("ISC", Nothing) -> ISC
("MIT", Nothing) -> MIT
+ ("MPL", Just version') -> MPL version'
("Apache", _ ) -> Apache version
("PublicDomain", Nothing) -> PublicDomain
("AllRightsReserved", Nothing) -> AllRightsReserved
("OtherLicense", Nothing) -> OtherLicense
- _ -> UnknownLicense $ name
- ++ maybe "" (('-':) . display) version
+ _ -> UnknownLicense $ name ++
+ maybe "" (('-':) . display) version
dispOptVersion :: Maybe Version -> Disp.Doc
dispOptVersion Nothing = Disp.empty
-dispOptVersion (Just v) = Disp.char '-' <> disp v
+dispOptVersion (Just v) = dispVersion v
+
+dispVersion :: Version -> Disp.Doc
+dispVersion v = Disp.char '-' <> disp v
diff --git a/cabal/Cabal/Distribution/Make.hs b/cabal/Cabal/Distribution/Make.hs
index 1bab509..4826e7d 100644
--- a/cabal/Cabal/Distribution/Make.hs
+++ b/cabal/Cabal/Distribution/Make.hs
@@ -2,6 +2,7 @@
-- |
-- Module : Distribution.Make
-- Copyright : Martin Sj&#xF6;gren 2004
+-- License : BSD3
--
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
@@ -16,7 +17,7 @@
-- 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
+-- Haskell tools using a back-end 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:
--
@@ -53,36 +54,6 @@
-- $(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(..),
@@ -121,7 +92,7 @@ defaultMainNoRead = const defaultMain
defaultMainHelper :: [String] -> IO ()
defaultMainHelper args =
- case commandsRun globalCommand commands args of
+ case commandsRun (globalCommand commands) commands args of
CommandHelp help -> printHelp help
CommandList opts -> printOptionsList opts
CommandErrors errs -> printErrors errs
diff --git a/cabal/Cabal/Distribution/ModuleName.hs b/cabal/Cabal/Distribution/ModuleName.hs
index 45babda..9d04513 100644
--- a/cabal/Cabal/Distribution/ModuleName.hs
+++ b/cabal/Cabal/Distribution/ModuleName.hs
@@ -1,44 +1,17 @@
{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
+
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.ModuleName
-- Copyright : Duncan Coutts 2008
+-- License : BSD3
--
-- 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,
@@ -51,21 +24,25 @@ module Distribution.ModuleName (
import Distribution.Text
( Text(..) )
+import Distribution.Compat.Binary (Binary)
+import qualified Data.Char as Char
+ ( isAlphaNum, isUpper )
import Data.Data (Data)
import Data.Typeable (Typeable)
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
( intercalate, intersperse )
+import GHC.Generics (Generic)
+import System.FilePath
+ ( pathSeparator )
-- | A valid Haskell module name.
--
newtype ModuleName = ModuleName [String]
- deriving (Eq, Ord, Read, Show, Typeable, Data)
+ deriving (Eq, Generic, Ord, Read, Show, Typeable, Data)
+
+instance Binary ModuleName
instance Text ModuleName where
disp (ModuleName ms) =
diff --git a/cabal/Cabal/Distribution/Package.hs b/cabal/Cabal/Distribution/Package.hs
index b561bf5..56682c3 100644
--- a/cabal/Cabal/Distribution/Package.hs
+++ b/cabal/Cabal/Distribution/Package.hs
@@ -1,8 +1,11 @@
{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
+
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Package
-- Copyright : Isaac Jones 2003-2004
+-- License : BSD3
--
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
@@ -12,36 +15,6 @@
-- 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(..),
@@ -51,6 +24,17 @@ module Distribution.Package (
-- * Installed package identifiers
InstalledPackageId(..),
+ -- * Package keys (used for linker symbols)
+ PackageKey(..),
+ mkPackageKey,
+ packageKeyHash,
+ packageKeyLibraryName,
+
+ -- * Library name (used for install path, package key)
+ LibraryName(..),
+ emptyLibraryName,
+ getHSLibraryName,
+
-- * Package source dependencies
Dependency(..),
thisPackageVersion,
@@ -59,26 +43,36 @@ module Distribution.Package (
-- * Package classes
Package(..), packageName, packageVersion,
- PackageFixedDeps(..),
+ HasInstalledPackageId(..),
+ PackageInstalled(..),
) where
import Distribution.Version
( Version(..), VersionRange, anyVersion, thisVersion
, notThisVersion, simplifyVersionRange )
-import Distribution.Text (Text(..))
+import Distribution.Text (Text(..), display)
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 ( intercalate )
+import Distribution.Compat.Binary (Binary)
+import qualified Data.Char as Char
+ ( isDigit, isAlphaNum, isUpper, isLower, ord, chr )
import Data.Data ( Data )
+import Data.List ( intercalate, foldl', sort )
import Data.Typeable ( Typeable )
+import Data.Word ( Word64 )
+import GHC.Fingerprint ( Fingerprint(..), fingerprintString )
+import GHC.Generics (Generic)
+import Numeric ( showIntAtBase )
+import Text.PrettyPrint ((<>), (<+>), text)
+
+newtype PackageName = PackageName { unPackageName :: String }
+ deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
-newtype PackageName = PackageName String
- deriving (Read, Show, Eq, Ord, Typeable, Data)
+instance Binary PackageName
instance Text PackageName where
disp (PackageName n) = Disp.text n
@@ -104,7 +98,9 @@ data PackageIdentifier
pkgName :: PackageName, -- ^The name of this package, eg. foo
pkgVersion :: Version -- ^the version of this package, eg 1.2
}
- deriving (Read, Show, Eq, Ord, Typeable, Data)
+ deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
+
+instance Binary PackageIdentifier
instance Text PackageIdentifier where
disp (PackageIdentifier n v) = case v of
@@ -128,13 +124,180 @@ instance NFData PackageIdentifier where
-- in a package database, or overlay of databases.
--
newtype InstalledPackageId = InstalledPackageId String
- deriving (Read,Show,Eq,Ord,Typeable,Data)
+ deriving (Generic, Read,Show,Eq,Ord,Typeable,Data)
+
+instance Binary InstalledPackageId
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` ":-_."
+ where abi_char c = Char.isAlphaNum c || c `elem` "-_."
+
+-- ------------------------------------------------------------
+-- * Package Keys
+-- ------------------------------------------------------------
+
+-- | A 'PackageKey' is the notion of "package ID" which is visible to the
+-- compiler. Why is this not a 'PackageId'? The 'PackageId' is a user-visible
+-- concept written explicity in Cabal files; on the other hand, a 'PackageKey'
+-- may contain, for example, information about the transitive dependency
+-- tree of a package. Why is this not an 'InstalledPackageId'? A 'PackageKey'
+-- should be stable so that we can incrementally recompile after a source edit;
+-- however, an 'InstalledPackageId' may change even with source.
+--
+-- Package keys may be generated either by Cabal or GHC. In particular,
+-- ordinary, "old-style" packages which don't use Backpack features can
+-- have their package keys generated directly by Cabal and coincide with
+-- 'LibraryName's. However, Backpack keys are generated by GHC may exhibit
+-- more variation than a 'LibraryName'.
+--
+data PackageKey
+ -- | Modern package key which is a hash of the PackageId and the transitive
+ -- dependency key. It's manually inlined here so we can get the instances
+ -- we need. There's an optional prefix for compatibility with GHC 7.10.
+ = PackageKey (Maybe String) {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
+ -- | Old-style package key which is just a 'PackageId'. Required because
+ -- old versions of GHC assume that the 'sourcePackageId' recorded for an
+ -- installed package coincides with the package key it was compiled with.
+ | OldPackageKey !PackageId
+ deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
+
+instance Binary PackageKey
+
+-- | Convenience function which converts a fingerprint into a new-style package
+-- key.
+fingerprintPackageKey :: Fingerprint -> PackageKey
+fingerprintPackageKey (Fingerprint a b) = PackageKey Nothing a b
+
+-- | Generates a 'PackageKey' from a 'PackageId', sorted package keys of the
+-- immediate dependencies.
+mkPackageKey :: Bool -- are modern style package keys supported?
+ -> PackageId
+ -> [LibraryName] -- dependencies
+ -> PackageKey
+mkPackageKey True pid deps =
+ fingerprintPackageKey . fingerprintString $
+ display pid ++ "\n" ++
+ concat [ display dep ++ "\n" | dep <- sort deps ]
+mkPackageKey False pid _ = OldPackageKey pid
+
+-- The base-62 code is based off of 'locators'
+-- ((c) Operational Dynamics Consulting, BSD3 licensed)
+
+-- Note: Instead of base-62 encoding a single 128-bit integer
+-- (ceil(21.49) characters), we'll base-62 a pair of 64-bit integers
+-- (2 * ceil(10.75) characters). Luckily for us, it's the same number of
+-- characters! In the long term, this should go in GHC.Fingerprint,
+-- but not now...
+
+-- | Size of a 64-bit word when written as a base-62 string
+word64Base62Len :: Int
+word64Base62Len = 11
+
+-- | Converts a 64-bit word into a base-62 string
+toBase62 :: Word64 -> String
+toBase62 w = pad ++ str
+ where
+ pad = replicate len '0'
+ len = word64Base62Len - length str -- 11 == ceil(64 / lg 62)
+ str = showIntAtBase 62 represent w ""
+ represent :: Int -> Char
+ represent x
+ | x < 10 = Char.chr (48 + x)
+ | x < 36 = Char.chr (65 + x - 10)
+ | x < 62 = Char.chr (97 + x - 36)
+ | otherwise = error ("represent (base 62): impossible!")
+
+-- | Parses a base-62 string into a 64-bit word
+fromBase62 :: String -> Word64
+fromBase62 ss = foldl' multiply 0 ss
+ where
+ value :: Char -> Int
+ value c
+ | Char.isDigit c = Char.ord c - 48
+ | Char.isUpper c = Char.ord c - 65 + 10
+ | Char.isLower c = Char.ord c - 97 + 36
+ | otherwise = error ("value (base 62): impossible!")
+
+ multiply :: Word64 -> Char -> Word64
+ multiply acc c = acc * 62 + (fromIntegral $ value c)
+
+-- | Parses a base-62 string into a fingerprint.
+readBase62Fingerprint :: String -> Fingerprint
+readBase62Fingerprint s = Fingerprint w1 w2
+ where (s1,s2) = splitAt word64Base62Len s
+ w1 = fromBase62 s1
+ w2 = fromBase62 (take word64Base62Len s2)
+
+-- | Compute the hash (without a prefix) of a package key. In GHC 7.12
+-- this is equivalent to display.
+packageKeyHash :: PackageKey -> String
+packageKeyHash (PackageKey _ w1 w2) = toBase62 w1 ++ toBase62 w2
+packageKeyHash (OldPackageKey pid) = display pid
+
+-- | Legacy function for GHC 7.10 to compute a LibraryName based on
+-- the package key.
+packageKeyLibraryName :: PackageId -> PackageKey -> LibraryName
+packageKeyLibraryName pid (PackageKey _ w1 w2) =
+ LibraryName (display pid ++ "-" ++ toBase62 w1 ++ toBase62 w2)
+packageKeyLibraryName _ (OldPackageKey pid) = LibraryName (display pid)
+
+instance Text PackageKey where
+ disp (PackageKey mb_prefix w1 w2)
+ = maybe Disp.empty (\r -> Disp.text r <> Disp.char '_') mb_prefix <>
+ Disp.text (toBase62 w1) <> Disp.text (toBase62 w2)
+ disp (OldPackageKey pid) = disp pid
+
+ parse = parseNewWithAnnot <++ parseNew <++ parseOld
+ where parseNew = do
+ fmap (fingerprintPackageKey . readBase62Fingerprint)
+ . Parse.count (word64Base62Len * 2)
+ $ Parse.satisfy Char.isAlphaNum
+ parseNewWithAnnot = do
+ -- this is ignored
+ prefix <- Parse.munch1 (\c -> Char.isAlphaNum c || c `elem` "-")
+ _ <- Parse.char '_' -- if we use '-' it's ambiguous
+ PackageKey _ w1 w2 <- parseNew
+ return (PackageKey (Just prefix) w1 w2)
+ parseOld = do pid <- parse
+ return (OldPackageKey pid)
+
+instance NFData PackageKey where
+ rnf (PackageKey mb _ _) = rnf mb
+ rnf (OldPackageKey pid) = rnf pid
+
+-- ------------------------------------------------------------
+-- * Library names
+-- ------------------------------------------------------------
+
+-- | A library name consists of not only a source package
+-- id ('PackageId') but also the library names of all textual
+-- dependencies; thus, a library name uniquely identifies an
+-- installed package up to the dependency resolution done by Cabal.
+-- Create using 'packageKeyLibraryName'. Library names are opaque,
+-- Cabal-defined strings.
+newtype LibraryName
+ = LibraryName String
+ deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
+
+instance Binary LibraryName
+
+-- | Default library name for when it is not known.
+emptyLibraryName :: LibraryName
+emptyLibraryName = LibraryName ""
+
+-- | Returns library name prefixed with HS, suitable for filenames
+getHSLibraryName :: LibraryName -> String
+getHSLibraryName (LibraryName s) = "HS" ++ s
+
+instance Text LibraryName where
+ disp (LibraryName s) = Disp.text s
+ parse = LibraryName `fmap` Parse.munch1 hash_char
+ where hash_char c = Char.isAlphaNum c || c `elem` "-_."
+
+instance NFData LibraryName where
+ rnf (LibraryName s) = rnf s
-- ------------------------------------------------------------
-- * Package source dependencies
@@ -143,7 +306,9 @@ instance Text InstalledPackageId where
-- | Describes a dependency on a source package (API)
--
data Dependency = Dependency PackageName VersionRange
- deriving (Read, Show, Eq, Typeable, Data)
+ deriving (Generic, Read, Show, Eq, Typeable, Data)
+
+instance Binary Dependency
instance Text Dependency where
disp (Dependency name ver) =
@@ -192,12 +357,15 @@ 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.
+-- | Packages that have an installed package ID
+class Package pkg => HasInstalledPackageId pkg where
+ installedPackageId :: pkg -> InstalledPackageId
+
+-- | Class of installed packages.
--
-class Package pkg => PackageFixedDeps pkg where
- depends :: pkg -> [PackageIdentifier]
+-- The primary data type which is an instance of this package is
+-- 'InstalledPackageInfo', but when we are doing install plans in Cabal install
+-- we may have other, installed package-like things which contain more metadata.
+-- Installed packages have exact dependencies 'installedDepends'.
+class HasInstalledPackageId pkg => PackageInstalled pkg where
+ installedDepends :: pkg -> [InstalledPackageId]
diff --git a/cabal/Cabal/Distribution/PackageDescription.hs b/cabal/Cabal/Distribution/PackageDescription.hs
index 585506b..17e10c1 100644
--- a/cabal/Cabal/Distribution/PackageDescription.hs
+++ b/cabal/Cabal/Distribution/PackageDescription.hs
@@ -1,8 +1,12 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
+
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.PackageDescription
-- Copyright : Isaac Jones 2003-2005
+-- License : BSD3
--
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
@@ -21,36 +25,6 @@
-- 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(..),
@@ -60,8 +34,14 @@ module Distribution.PackageDescription (
BuildType(..),
knownBuildTypes,
+ -- ** Renaming
+ ModuleRenaming(..),
+ defaultRenaming,
+ lookupRenaming,
+
-- ** Libraries
Library(..),
+ ModuleReexport(..),
emptyLibrary,
withLib,
hasLibs,
@@ -106,6 +86,8 @@ module Distribution.PackageDescription (
allExtensions,
usedExtensions,
hcOptions,
+ hcProfOptions,
+ hcSharedOptions,
-- ** Supplementary build information
HookedBuildInfo,
@@ -116,32 +98,48 @@ module Distribution.PackageDescription (
GenericPackageDescription(..),
Flag(..), FlagName(..), FlagAssignment,
CondTree(..), ConfVar(..), Condition(..),
+ cNot,
-- * Source repositories
SourceRepo(..),
RepoKind(..),
RepoType(..),
knownRepoTypes,
+
+ -- * Custom setup build information
+ SetupBuildInfo(..),
) where
-import Data.Data (Data)
-import Data.List (nub, intercalate)
-import Data.Maybe (fromMaybe, maybeToList)
-import Data.Monoid (Monoid(mempty, mappend))
-import Data.Typeable ( Typeable )
-import Control.Monad (MonadPlus(mplus))
+import Distribution.Compat.Binary (Binary)
+import Data.Data (Data)
+import Data.Foldable (traverse_)
+import Data.List (nub, intercalate)
+import Data.Maybe (fromMaybe, maybeToList)
+#if __GLASGOW_HASKELL__ < 710
+import Control.Applicative (Applicative((<*>), pure))
+import Data.Monoid (Monoid(mempty, mappend))
+import Data.Foldable (Foldable(foldMap))
+import Data.Traversable (Traversable(traverse))
+#endif
+import Data.Typeable ( Typeable )
+import Control.Applicative (Alternative(..))
+import Control.Monad (MonadPlus(mplus,mzero), ap)
+import GHC.Generics (Generic)
import Text.PrettyPrint as Disp
import qualified Distribution.Compat.ReadP as Parse
+import Distribution.Compat.ReadP ((<++))
import qualified Data.Char as Char (isAlphaNum, isDigit, toLower)
+import qualified Data.Map as Map
+import Data.Map (Map)
import Distribution.Package
( PackageName(PackageName), PackageIdentifier(PackageIdentifier)
- , Dependency, Package(..) )
+ , Dependency, Package(..), PackageName, packageName )
import Distribution.ModuleName ( ModuleName )
import Distribution.Version
( Version(Version), VersionRange, anyVersion, orLaterVersion
, asVersionIntervals, LowerBound(..) )
-import Distribution.License (License(AllRightsReserved))
+import Distribution.License (License(UnspecifiedLicense))
import Distribution.Compiler (CompilerFlavor)
import Distribution.System (OS, Arch)
import Distribution.Text
@@ -163,7 +161,7 @@ data PackageDescription
-- the following are required by all packages:
package :: PackageIdentifier,
license :: License,
- licenseFile :: FilePath,
+ licenseFiles :: [FilePath],
copyright :: String,
maintainer :: String,
author :: String,
@@ -179,6 +177,17 @@ data PackageDescription
customFieldsPD :: [(String,String)], -- ^Custom fields starting
-- with x-, stored in a
-- simple assoc-list.
+ -- | YOU PROBABLY DON'T WANT TO USE THIS FIELD. This field is
+ -- special! Depending on how far along processing the
+ -- PackageDescription we are, the contents of this field are
+ -- either nonsense, or the collected dependencies of *all* the
+ -- components in this package. buildDepends is initialized by
+ -- 'finalizePackageDescription' and 'flattenPackageDescription';
+ -- prior to that, dependency info is stored in the 'CondTree'
+ -- built around a 'GenericPackageDescription'. When this
+ -- resolution is done, dependency info is written to the inner
+ -- 'BuildInfo' and this field. This is all horrible, and #2066
+ -- tracks progress to get rid of this field.
buildDepends :: [Dependency],
-- | The version of the Cabal spec that this package description uses.
-- For historical reasons this is specified with a version range but
@@ -186,6 +195,7 @@ data PackageDescription
-- transitioning to specifying just a single version, not a range.
specVersionRaw :: Either Version VersionRange,
buildType :: Maybe BuildType,
+ setupBuildInfo :: Maybe SetupBuildInfo,
-- components
library :: Maybe Library,
executables :: [Executable],
@@ -197,7 +207,9 @@ data PackageDescription
extraTmpFiles :: [FilePath],
extraDocFiles :: [FilePath]
}
- deriving (Show, Read, Eq, Typeable, Data)
+ deriving (Generic, Show, Read, Eq, Typeable, Data)
+
+instance Binary PackageDescription
instance Package PackageDescription where
packageId = package
@@ -233,8 +245,8 @@ emptyPackageDescription
= PackageDescription {
package = PackageIdentifier (PackageName "")
(Version [] []),
- license = AllRightsReserved,
- licenseFile = "",
+ license = UnspecifiedLicense,
+ licenseFiles = [],
specVersionRaw = Right anyVersion,
buildType = Nothing,
copyright = "",
@@ -251,6 +263,7 @@ emptyPackageDescription
description = "",
category = "",
customFieldsPD = [],
+ setupBuildInfo = Nothing,
library = Nothing,
executables = [],
testSuites = [],
@@ -275,7 +288,9 @@ data BuildType
-- 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, Typeable, Data)
+ deriving (Generic, Show, Read, Eq, Typeable, Data)
+
+instance Binary BuildType
knownBuildTypes :: [BuildType]
knownBuildTypes = [Simple, Configure, Make, Custom]
@@ -294,23 +309,116 @@ instance Text BuildType where
_ -> UnknownBuildType name
-- ---------------------------------------------------------------------------
+-- The SetupBuildInfo type
+
+-- One can see this as a very cut-down version of BuildInfo below.
+-- To keep things simple for tools that compile Setup.hs we limit the
+-- options authors can specify to just Haskell package dependencies.
+
+data SetupBuildInfo = SetupBuildInfo {
+ setupDepends :: [Dependency]
+ }
+ deriving (Generic, Show, Eq, Read, Typeable, Data)
+
+instance Binary SetupBuildInfo
+
+instance Monoid SetupBuildInfo where
+ mempty = SetupBuildInfo {
+ setupDepends = mempty
+ }
+ mappend a b = SetupBuildInfo {
+ setupDepends = combine setupDepends
+ }
+ where combine field = field a `mappend` field b
+
+-- ---------------------------------------------------------------------------
+-- Module renaming
+
+-- | Renaming applied to the modules provided by a package.
+-- The boolean indicates whether or not to also include all of the
+-- original names of modules. Thus, @ModuleRenaming False []@ is
+-- "don't expose any modules, and @ModuleRenaming True [("Data.Bool", "Bool")]@
+-- is, "expose all modules, but also expose @Data.Bool@ as @Bool@".
+--
+data ModuleRenaming = ModuleRenaming Bool [(ModuleName, ModuleName)]
+ deriving (Show, Read, Eq, Ord, Typeable, Data, Generic)
+
+defaultRenaming :: ModuleRenaming
+defaultRenaming = ModuleRenaming True []
+
+lookupRenaming :: Package pkg => pkg -> Map PackageName ModuleRenaming -> ModuleRenaming
+lookupRenaming = Map.findWithDefault defaultRenaming . packageName
+
+instance Binary ModuleRenaming where
+
+instance Monoid ModuleRenaming where
+ ModuleRenaming b rns `mappend` ModuleRenaming b' rns'
+ = ModuleRenaming (b || b') (rns ++ rns') -- ToDo: dedupe?
+ mempty = ModuleRenaming False []
+
+-- NB: parentheses are mandatory, because later we may extend this syntax
+-- to allow "hiding (A, B)" or other modifier words.
+instance Text ModuleRenaming where
+ disp (ModuleRenaming True []) = Disp.empty
+ disp (ModuleRenaming b vs) = (if b then text "with" else Disp.empty) <+> dispRns
+ where dispRns = Disp.parens
+ (Disp.hsep
+ (Disp.punctuate Disp.comma (map dispEntry vs)))
+ dispEntry (orig, new)
+ | orig == new = disp orig
+ | otherwise = disp orig <+> text "as" <+> disp new
+
+ parse = do Parse.string "with" >> Parse.skipSpaces
+ fmap (ModuleRenaming True) parseRns
+ <++ fmap (ModuleRenaming False) parseRns
+ <++ return (ModuleRenaming True [])
+ where parseRns = do
+ rns <- Parse.between (Parse.char '(') (Parse.char ')') parseList
+ Parse.skipSpaces
+ return rns
+ parseList =
+ Parse.sepBy parseEntry (Parse.char ',' >> Parse.skipSpaces)
+ parseEntry :: Parse.ReadP r (ModuleName, ModuleName)
+ parseEntry = do
+ orig <- parse
+ Parse.skipSpaces
+ (do _ <- Parse.string "as"
+ Parse.skipSpaces
+ new <- parse
+ Parse.skipSpaces
+ return (orig, new)
+ <++
+ return (orig, orig))
+
+-- ---------------------------------------------------------------------------
-- The Library type
data Library = Library {
exposedModules :: [ModuleName],
+ reexportedModules :: [ModuleReexport],
+ requiredSignatures:: [ModuleName], -- ^ What sigs need implementations?
+ exposedSignatures:: [ModuleName], -- ^ What sigs are visible to users?
libExposed :: Bool, -- ^ Is the lib to be exposed by default?
libBuildInfo :: BuildInfo
}
- deriving (Show, Eq, Read, Typeable, Data)
+ deriving (Generic, Show, Eq, Read, Typeable, Data)
+
+instance Binary Library
instance Monoid Library where
mempty = Library {
exposedModules = mempty,
+ reexportedModules = mempty,
+ requiredSignatures = mempty,
+ exposedSignatures = mempty,
libExposed = True,
libBuildInfo = mempty
}
mappend a b = Library {
exposedModules = combine exposedModules,
+ reexportedModules = combine reexportedModules,
+ requiredSignatures = combine requiredSignatures,
+ exposedSignatures = combine exposedSignatures,
libExposed = libExposed a && libExposed b, -- so False propagates
libBuildInfo = combine libBuildInfo
}
@@ -334,12 +442,49 @@ maybeHasLibs p =
-- function with the library build info as argument.
withLib :: PackageDescription -> (Library -> IO ()) -> IO ()
withLib pkg_descr f =
- maybe (return ()) f (maybeHasLibs pkg_descr)
+ traverse_ f (maybeHasLibs pkg_descr)
-- | Get all the module names from the library (exposed and internal modules)
+-- which need to be compiled. (This does not include reexports, which
+-- do not need to be compiled.)
libModules :: Library -> [ModuleName]
libModules lib = exposedModules lib
++ otherModules (libBuildInfo lib)
+ ++ exposedSignatures lib
+ ++ requiredSignatures lib
+
+-- -----------------------------------------------------------------------------
+-- Module re-exports
+
+data ModuleReexport = ModuleReexport {
+ moduleReexportOriginalPackage :: Maybe PackageName,
+ moduleReexportOriginalName :: ModuleName,
+ moduleReexportName :: ModuleName
+ }
+ deriving (Eq, Generic, Read, Show, Typeable, Data)
+
+instance Binary ModuleReexport
+
+instance Text ModuleReexport where
+ disp (ModuleReexport mpkgname origname newname) =
+ maybe Disp.empty (\pkgname -> disp pkgname <> Disp.char ':') mpkgname
+ <> disp origname
+ <+> if newname == origname
+ then Disp.empty
+ else Disp.text "as" <+> disp newname
+
+ parse = do
+ mpkgname <- Parse.option Nothing $ do
+ pkgname <- parse
+ _ <- Parse.char ':'
+ return (Just pkgname)
+ origname <- parse
+ newname <- Parse.option origname $ do
+ Parse.skipSpaces
+ _ <- Parse.string "as"
+ Parse.skipSpaces
+ parse
+ return (ModuleReexport mpkgname origname newname)
-- ---------------------------------------------------------------------------
-- The Executable type
@@ -349,7 +494,9 @@ data Executable = Executable {
modulePath :: FilePath,
buildInfo :: BuildInfo
}
- deriving (Show, Read, Eq, Typeable, Data)
+ deriving (Generic, Show, Read, Eq, Typeable, Data)
+
+instance Binary Executable
instance Monoid Executable where
mempty = Executable {
@@ -403,7 +550,9 @@ data TestSuite = TestSuite {
-- a better solution is waiting on the next overhaul to the
-- GenericPackageDescription -> PackageDescription resolution process.
}
- deriving (Show, Read, Eq, Typeable, Data)
+ deriving (Generic, Show, Read, Eq, Typeable, Data)
+
+instance Binary TestSuite
-- | The test suite interfaces that are currently defined. Each test suite must
-- specify which interface it supports.
@@ -429,7 +578,9 @@ data TestSuiteInterface =
-- the given reason (e.g. unknown test type).
--
| TestSuiteUnsupported TestType
- deriving (Eq, Read, Show, Typeable, Data)
+ deriving (Eq, Generic, Read, Show, Typeable, Data)
+
+instance Binary TestSuiteInterface
instance Monoid TestSuite where
mempty = TestSuite {
@@ -485,7 +636,9 @@ testModules test = (case testInterface test of
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, Typeable, Data)
+ deriving (Generic, Show, Read, Eq, Typeable, Data)
+
+instance Binary TestType
knownTestTypes :: [TestType]
knownTestTypes = [ TestTypeExe (Version [1,0] [])
@@ -534,7 +687,9 @@ data Benchmark = Benchmark {
benchmarkEnabled :: Bool
-- TODO: See TODO for 'testEnabled'.
}
- deriving (Show, Read, Eq, Typeable, Data)
+ deriving (Generic, Show, Read, Eq, Typeable, Data)
+
+instance Binary Benchmark
-- | The benchmark interfaces that are currently defined. Each
-- benchmark must specify which interface it supports.
@@ -556,7 +711,9 @@ data BenchmarkInterface =
-- interfaces for the given reason (e.g. unknown benchmark type).
--
| BenchmarkUnsupported BenchmarkType
- deriving (Eq, Read, Show, Typeable, Data)
+ deriving (Eq, Generic, Read, Show, Typeable, Data)
+
+instance Binary BenchmarkInterface
instance Monoid Benchmark where
mempty = Benchmark {
@@ -610,7 +767,9 @@ data BenchmarkType = BenchmarkTypeExe Version
-- ^ \"type: exitcode-stdio-x.y\"
| BenchmarkTypeUnknown String Version
-- ^ Some unknown benchmark type e.g. \"type: foo\"
- deriving (Show, Read, Eq, Typeable, Data)
+ deriving (Generic, Show, Read, Eq, Typeable, Data)
+
+instance Binary BenchmarkType
knownBenchmarkTypes :: [BenchmarkType]
knownBenchmarkTypes = [ BenchmarkTypeExe (Version [1,0] []) ]
@@ -642,7 +801,8 @@ data BuildInfo = BuildInfo {
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
+ jsSources :: [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
@@ -652,19 +812,23 @@ data BuildInfo = BuildInfo {
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
+ extraGHCiLibs :: [String], -- ^ if present, overrides extraLibs when package is loaded with GHCi.
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],
+ profOptions :: [(CompilerFlavor,[String])],
+ sharedOptions :: [(CompilerFlavor,[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
+ targetBuildDepends :: [Dependency], -- ^ Dependencies specific to a library or executable target
+ targetBuildRenaming :: Map PackageName ModuleRenaming
}
- deriving (Show,Read,Eq,Typeable,Data)
+ deriving (Generic, Show, Read, Eq, Typeable, Data)
+
+instance Binary BuildInfo
instance Monoid BuildInfo where
mempty = BuildInfo {
@@ -676,6 +840,7 @@ instance Monoid BuildInfo where
pkgconfigDepends = [],
frameworks = [],
cSources = [],
+ jsSources = [],
hsSourceDirs = [],
otherModules = [],
defaultLanguage = Nothing,
@@ -684,15 +849,17 @@ instance Monoid BuildInfo where
otherExtensions = [],
oldExtensions = [],
extraLibs = [],
+ extraGHCiLibs = [],
extraLibDirs = [],
includeDirs = [],
includes = [],
installIncludes = [],
options = [],
- ghcProfOptions = [],
- ghcSharedOptions = [],
+ profOptions = [],
+ sharedOptions = [],
customFieldsBI = [],
- targetBuildDepends = []
+ targetBuildDepends = [],
+ targetBuildRenaming = Map.empty
}
mappend a b = BuildInfo {
buildable = buildable a && buildable b,
@@ -703,6 +870,7 @@ instance Monoid BuildInfo where
pkgconfigDepends = combine pkgconfigDepends,
frameworks = combineNub frameworks,
cSources = combineNub cSources,
+ jsSources = combineNub jsSources,
hsSourceDirs = combineNub hsSourceDirs,
otherModules = combineNub otherModules,
defaultLanguage = combineMby defaultLanguage,
@@ -711,20 +879,23 @@ instance Monoid BuildInfo where
otherExtensions = combineNub otherExtensions,
oldExtensions = combineNub oldExtensions,
extraLibs = combine extraLibs,
+ extraGHCiLibs = combine extraGHCiLibs,
extraLibDirs = combineNub extraLibDirs,
includeDirs = combineNub includeDirs,
includes = combineNub includes,
installIncludes = combineNub installIncludes,
options = combine options,
- ghcProfOptions = combine ghcProfOptions,
- ghcSharedOptions = combine ghcSharedOptions,
+ profOptions = combine profOptions,
+ sharedOptions = combine sharedOptions,
customFieldsBI = combine customFieldsBI,
- targetBuildDepends = combineNub targetBuildDepends
+ targetBuildDepends = combineNub targetBuildDepends,
+ targetBuildRenaming = combineMap targetBuildRenaming
}
where
combine field = field a `mappend` field b
combineNub field = nub (combine field)
combineMby field = field b `mplus` field a
+ combineMap field = Map.unionWith mappend (field a) (field b)
emptyBuildInfo :: BuildInfo
emptyBuildInfo = mempty
@@ -775,9 +946,19 @@ 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 ]
+hcOptions = lookupHcOptions options
+
+hcProfOptions :: CompilerFlavor -> BuildInfo -> [String]
+hcProfOptions = lookupHcOptions profOptions
+
+hcSharedOptions :: CompilerFlavor -> BuildInfo -> [String]
+hcSharedOptions = lookupHcOptions sharedOptions
+
+lookupHcOptions :: (BuildInfo -> [(CompilerFlavor,[String])])
+ -> CompilerFlavor -> BuildInfo -> [String]
+lookupHcOptions f hc bi = [ opt | (hc',opts) <- f bi
+ , hc' == hc
+ , opt <- opts ]
-- ------------------------------------------------------------
-- * Source repos
@@ -838,7 +1019,9 @@ data SourceRepo = SourceRepo {
-- given the default is \".\" ie no subdirectory.
repoSubdir :: Maybe FilePath
}
- deriving (Eq, Read, Show, Typeable, Data)
+ deriving (Eq, Generic, Read, Show, Typeable, Data)
+
+instance Binary SourceRepo
-- | What this repo info is for, what it represents.
--
@@ -854,7 +1037,9 @@ data RepoKind =
| RepoThis
| RepoKindUnknown String
- deriving (Eq, Ord, Read, Show, Typeable, Data)
+ deriving (Eq, Generic, Ord, Read, Show, Typeable, Data)
+
+instance Binary RepoKind
-- | 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
@@ -863,7 +1048,9 @@ data RepoKind =
data RepoType = Darcs | Git | SVN | CVS
| Mercurial | GnuArch | Bazaar | Monotone
| OtherRepoType String
- deriving (Eq, Ord, Read, Show, Typeable, Data)
+ deriving (Eq, Generic, Ord, Read, Show, Typeable, Data)
+
+instance Binary RepoType
knownRepoTypes :: [RepoType]
knownRepoTypes = [Darcs, Git, SVN, CVS
@@ -928,7 +1115,7 @@ updatePackageDescription (mb_lib_bi, exe_bi) p
updateExecutable :: (String, BuildInfo) -- ^(exeName, new buildinfo)
-> [Executable] -- ^list of executables to update
- -> [Executable] -- ^libst with exeName updated
+ -> [Executable] -- ^list with exeName updated
updateExecutable _ [] = []
updateExecutable exe_bi'@(name,bi) (exe:exes)
| exeName exe == name = exe{buildInfo = bi `mappend` buildInfo exe} : exes
@@ -965,7 +1152,9 @@ data Flag = MkFlag
-- | A 'FlagName' is the name of a user-defined configuration flag
newtype FlagName = FlagName String
- deriving (Eq, Ord, Show, Read, Typeable, Data)
+ deriving (Eq, Generic, Ord, Show, Read, Typeable, Data)
+
+instance Binary FlagName
-- | A 'FlagAssignment' is a total or partial mapping of 'FlagName's to
-- 'Bool' flag values. It represents the flags chosen by the user or
@@ -981,13 +1170,6 @@ data ConfVar = OS OS
| Impl CompilerFlavor VersionRange
deriving (Eq, Show, Typeable, Data)
---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
@@ -996,12 +1178,57 @@ data Condition c = Var c
| CAnd (Condition c) (Condition c)
deriving (Show, Eq, Typeable, Data)
---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]
+cNot :: Condition a -> Condition a
+cNot (Lit b) = Lit (not b)
+cNot (CNot c) = c
+cNot c = CNot c
+
+instance Functor Condition where
+ f `fmap` Var c = Var (f c)
+ _ `fmap` Lit c = Lit c
+ f `fmap` CNot c = CNot (fmap f c)
+ f `fmap` COr c d = COr (fmap f c) (fmap f d)
+ f `fmap` CAnd c d = CAnd (fmap f c) (fmap f d)
+
+instance Foldable Condition where
+ f `foldMap` Var c = f c
+ _ `foldMap` Lit _ = mempty
+ f `foldMap` CNot c = foldMap f c
+ f `foldMap` COr c d = foldMap f c `mappend` foldMap f d
+ f `foldMap` CAnd c d = foldMap f c `mappend` foldMap f d
+
+instance Traversable Condition where
+ f `traverse` Var c = Var `fmap` f c
+ _ `traverse` Lit c = pure $ Lit c
+ f `traverse` CNot c = CNot `fmap` traverse f c
+ f `traverse` COr c d = COr `fmap` traverse f c <*> traverse f d
+ f `traverse` CAnd c d = CAnd `fmap` traverse f c <*> traverse f d
+
+instance Applicative Condition where
+ pure = return
+ (<*>) = ap
+
+instance Monad Condition where
+ return = Var
+ -- Terminating cases
+ (>>=) (Lit x) _ = Lit x
+ (>>=) (Var x) f = f x
+ -- Recursing cases
+ (>>=) (CNot x ) f = CNot (x >>= f)
+ (>>=) (COr x y) f = COr (x >>= f) (y >>= f)
+ (>>=) (CAnd x y) f = CAnd (x >>= f) (y >>= f)
+
+instance Monoid (Condition a) where
+ mempty = Lit False
+ mappend = COr
+
+instance Alternative Condition where
+ empty = mempty
+ (<|>) = mappend
+
+instance MonadPlus Condition where
+ mzero = mempty
+ mplus = mappend
data CondTree v c a = CondNode
{ condTreeData :: a
@@ -1011,16 +1238,3 @@ data CondTree v c a = CondNode
, Maybe (CondTree v c a))]
}
deriving (Show, Eq, Typeable, Data)
-
---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
index bc5dbe5..283c93c 100644
--- a/cabal/Cabal/Distribution/PackageDescription/Check.hs
+++ b/cabal/Cabal/Distribution/PackageDescription/Check.hs
@@ -2,6 +2,7 @@
-- |
-- Module : Distribution.PackageDescription.Check
-- Copyright : Lennart Kolmodin 2008
+-- License : BSD3
--
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
@@ -14,41 +15,11 @@
-- 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
+-- 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(..),
@@ -69,12 +40,14 @@ import Control.Monad
( filterM, liftM )
import qualified System.Directory as System
( doesFileExist, doesDirectoryExist )
+import qualified Data.Map as Map
import Distribution.PackageDescription
import Distribution.PackageDescription.Configuration
( flattenPackageDescription, finalizePackageDescription )
import Distribution.Compiler
- ( CompilerFlavor(..), buildCompilerFlavor, CompilerId(..) )
+ ( CompilerFlavor(..), buildCompilerFlavor, CompilerId(..)
+ , unknownCompilerInfo, AbiTag(..) )
import Distribution.System
( OS(..), Arch(..), buildPlatform )
import Distribution.License
@@ -82,7 +55,7 @@ import Distribution.License
import Distribution.Simple.CCompiler
( filenameCDialect )
import Distribution.Simple.Utils
- ( cabalVersion, intercalate, parseFileGlob, FileGlob(..), lowercase )
+ ( cabalVersion, intercalate, parseFileGlob, FileGlob(..), lowercase, startsWithBOM, fromUTF8 )
import Distribution.Version
( Version(..)
@@ -102,10 +75,13 @@ import Text.PrettyPrint ((<>), (<+>))
import qualified Language.Haskell.Extension as Extension (deprecatedExtensions)
import Language.Haskell.Extension
- ( Language(UnknownLanguage), knownLanguages, Extension(..), KnownExtension(..) )
+ ( Language(UnknownLanguage), knownLanguages
+ , Extension(..), KnownExtension(..) )
+import qualified System.Directory (getDirectoryContents)
+import System.IO (openBinaryFile, IOMode(ReadMode), hGetContents)
import System.FilePath
( (</>), takeExtension, isRelative, isAbsolute
- , splitDirectories, splitPath )
+ , splitDirectories, splitPath, splitExtension )
import System.FilePath.Windows as FilePath.Windows
( isValid )
@@ -128,13 +104,17 @@ data PackageCheck =
| 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
+ -- might be annoying or detrimental 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
+ -- | Like PackageDistSuspicious but will only display warnings
+ -- rather than causing abnormal exit.
+ | PackageDistSuspiciousWarn { 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.
@@ -148,19 +128,19 @@ check :: Bool -> PackageCheck -> Maybe PackageCheck
check False _ = Nothing
check True pc = Just pc
-checkSpecVersion :: PackageDescription -> [Int] -> Bool -> PackageCheck -> Maybe PackageCheck
+checkSpecVersion :: PackageDescription -> [Int] -> Bool -> PackageCheck
+ -> Maybe PackageCheck
checkSpecVersion pkg specver cond pc
| specVersion pkg >= Version specver [] = Nothing
| otherwise = check cond pc
-
-- ------------------------------------------------------------
-- * Standard checks
-- ------------------------------------------------------------
-- | Check for common mistakes and problems in package descriptions.
--
--- This is the standard collection of checks covering all apsects except
+-- This is the standard collection of checks covering all aspects except
-- for checks that require looking at files within the package. For those
-- see 'checkPackageFiles'.
--
@@ -175,6 +155,7 @@ checkPackage gpkg mpkg =
checkConfiguredPackage pkg
++ checkConditionals gpkg
++ checkPackageVersions gpkg
+ ++ checkDevelopmentOnlyFlags gpkg
where
pkg = fromMaybe (flattenPackageDescription gpkg) mpkg
@@ -209,16 +190,20 @@ checkSanity pkg =
, check (null . versionBranch . packageVersion $ pkg) $
PackageBuildImpossible "No 'version' field."
- , check (null (executables pkg) && isNothing (library pkg)) $
+ , check (all ($ pkg) [ null . executables
+ , null . testSuites
+ , null . benchmarks
+ , isNothing . library ]) $
PackageBuildImpossible
- "No executables and no library found. Nothing to do."
+ "No executables, libraries, tests, or benchmarks 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.
+ --TODO: check for name clashes case insensitively: windows file systems cannot
+ --cope.
++ maybe [] (checkLibrary pkg) (library pkg)
++ concatMap (checkExecutable pkg) (executables pkg)
@@ -240,17 +225,34 @@ checkSanity pkg =
duplicateNames = dups $ exeNames ++ testNames ++ bmNames
checkLibrary :: PackageDescription -> Library -> [PackageCheck]
-checkLibrary _pkg lib =
+checkLibrary pkg lib =
catMaybes [
check (not (null moduleDuplicates)) $
PackageBuildImpossible $
"Duplicate modules in library: "
++ commaSep (map display moduleDuplicates)
+
+ -- check use of required-signatures/exposed-signatures sections
+ , checkVersion [1,21] (not (null (requiredSignatures lib))) $
+ PackageDistInexcusable $
+ "To use the 'required-signatures' field the package needs to specify "
+ ++ "at least 'cabal-version: >= 1.21'."
+
+ , checkVersion [1,21] (not (null (exposedSignatures lib))) $
+ PackageDistInexcusable $
+ "To use the 'exposed-signatures' field the package needs to specify "
+ ++ "at least 'cabal-version: >= 1.21'."
]
where
- moduleDuplicates = dups (libModules lib)
+ checkVersion :: [Int] -> Bool -> PackageCheck -> Maybe PackageCheck
+ checkVersion ver cond pc
+ | specVersion pkg >= Version ver [] = Nothing
+ | otherwise = check cond pc
+
+ moduleDuplicates = dups (libModules lib ++
+ map moduleReexportName (reexportedModules lib))
checkExecutable :: PackageDescription -> Executable -> [PackageCheck]
checkExecutable pkg exe =
@@ -414,6 +416,12 @@ checkFields pkg =
++ commaSep (map display knownBuildTypes)
_ -> Nothing
+ , check (isJust (setupBuildInfo pkg) && buildType pkg /= Just Custom) $
+ PackageBuildWarning $
+ "Ignoring the 'custom-setup' section because the 'build-type' is "
+ ++ "not 'Custom'. Use 'build-type: Custom' if you need to use a "
+ ++ "custom Setup.hs script."
+
, check (not (null unknownCompilers)) $
PackageBuildWarning $
"Unknown compiler " ++ commaSep (map quote unknownCompilers)
@@ -458,7 +466,7 @@ checkFields pkg =
, check (null (synopsis pkg) && not (null (description pkg))) $
PackageDistSuspicious "No 'synopsis' field."
- --TODO: recommend the bug reports url, author and homepage fields
+ --TODO: recommend the bug reports URL, author and homepage fields
--TODO: recommend not using the stability field
--TODO: recommend specifying a source repo
@@ -502,10 +510,13 @@ checkLicense :: PackageDescription -> [PackageCheck]
checkLicense pkg =
catMaybes [
- check (license pkg == AllRightsReserved) $
+ check (license pkg == UnspecifiedLicense) $
PackageDistInexcusable
- "The 'license' field is missing or specified as AllRightsReserved."
+ "The 'license' field is missing."
+ , check (license pkg == AllRightsReserved) $
+ PackageDistSuspicious
+ "The 'license' is AllRightsReserved. Is that really what you want?"
, case license pkg of
UnknownLicense l -> Just $
PackageBuildWarning $
@@ -530,10 +541,11 @@ checkLicense pkg =
++ "version then please file a ticket."
_ -> Nothing
- , check (license pkg `notElem` [AllRightsReserved, PublicDomain]
+ , check (license pkg `notElem` [ AllRightsReserved
+ , UnspecifiedLicense, PublicDomain]
-- AllRightsReserved and PublicDomain are not strictly
-- licenses so don't need license files.
- && null (licenseFile pkg)) $
+ && null (licenseFiles pkg)) $
PackageDistSuspicious "A 'license-file' is not specified."
]
where
@@ -591,19 +603,7 @@ 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"] $
+ checkFlags ["-fasm"] $
PackageDistInexcusable $
"'ghc-options: -fasm' is unnecessary and will not work on CPU "
++ "architectures other than x86, x86-64, ppc or sparc."
@@ -615,18 +615,10 @@ checkGhcOptions pkg =
++ "is using the FFI incorrectly and will probably not work with GHC "
++ "6.10 or later."
- , checkFlags ["-fdefer-type-errors"] $
- PackageDistInexcusable $
- "'ghc-options: -fdefer-type-errors' is fine during development but "
- ++ "is not appropriate for a distributed package."
-
, checkFlags ["-fhpc"] $
PackageDistInexcusable $
- "'ghc-options: -fhpc' is not appropriate for a distributed package."
-
- , check (any ("-d" `isPrefixOf`) all_ghc_options) $
- PackageDistInexcusable $
- "'ghc-options: -d*' debug flags are not appropriate for a distributed package."
+ "'ghc-options: -fhpc' is not not necessary. Use the configure flag "
+ ++ " --enable-coverage instead."
, checkFlags ["-prof"] $
PackageBuildWarning $
@@ -636,37 +628,43 @@ checkGhcOptions pkg =
, checkFlags ["-o"] $
PackageBuildWarning $
- "'ghc-options: -o' is not needed. The output files are named automatically."
+ "'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."
+ "'ghc-options: -hide-package' is never needed. "
+ ++ "Cabal hides all packages."
, checkFlags ["--make"] $
PackageBuildWarning $
- "'ghc-options: --make' is never needed. Cabal uses this automatically."
+ "'ghc-options: --make' is never needed. Cabal uses this automatically."
, checkFlags ["-main-is"] $
PackageDistSuspicious $
- "'ghc-options: -main-is' is not portable."
+ "'ghc-options: -main-is' is not portable."
, checkFlags ["-O0", "-Onot"] $
PackageDistSuspicious $
- "'ghc-options: -O0' is not needed. Use the --disable-optimization configure flag."
+ "'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."
+ "'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."
+ PackageDistSuspiciousWarn $
+ "'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."
+ "'ghc-options: -split-objs' is not needed. "
+ ++ "Use the --enable-split-objs configure flag."
, checkFlags ["-optl-Wl,-s", "-optl-s"] $
PackageDistInexcusable $
@@ -678,13 +676,24 @@ checkGhcOptions pkg =
, checkFlags ["-fglasgow-exts"] $
PackageDistSuspicious $
- "Instead of 'ghc-options: -fglasgow-exts' it is preferable to use the 'extensions' field."
+ "Instead of 'ghc-options: -fglasgow-exts' it is preferable to use "
+ ++ "the 'extensions' field."
, check ("-threaded" `elem` lib_ghc_options) $
- PackageDistSuspicious $
+ PackageBuildWarning $
"'ghc-options: -threaded' has no effect for libraries. It should "
++ "only be used for executables."
+ , check ("-rtsopts" `elem` lib_ghc_options) $
+ PackageBuildWarning $
+ "'ghc-options: -rtsopts' has no effect for libraries. It should "
+ ++ "only be used for executables."
+
+ , check (any (\opt -> "-with-rtsopts" `isPrefixOf` opt) lib_ghc_options) $
+ PackageBuildWarning $
+ "'ghc-options: -with-rtsopts' 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] ]
@@ -707,54 +716,51 @@ checkGhcOptions pkg =
]
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)
+ all_ghc_options = concatMap get_ghc_options (allBuildInfo pkg)
+ lib_ghc_options = maybe [] (get_ghc_options . libBuildInfo) (library pkg)
+ get_ghc_options bi = hcOptions GHC bi ++ hcProfOptions GHC bi
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)
+ "allow-overlapping-instances" -> enable OverlappingInstances
+ "no-allow-overlapping-instances" -> disable OverlappingInstances
+ "th" -> enable TemplateHaskell
+ "no-th" -> disable TemplateHaskell
+ "ffi" -> enable ForeignFunctionInterface
+ "no-ffi" -> disable ForeignFunctionInterface
+ "fi" -> enable ForeignFunctionInterface
+ "no-fi" -> disable ForeignFunctionInterface
+ "monomorphism-restriction" -> enable MonomorphismRestriction
+ "no-monomorphism-restriction" -> disable MonomorphismRestriction
+ "mono-pat-binds" -> enable MonoPatBinds
+ "no-mono-pat-binds" -> disable MonoPatBinds
+ "allow-undecidable-instances" -> enable UndecidableInstances
+ "no-allow-undecidable-instances" -> disable UndecidableInstances
+ "allow-incoherent-instances" -> enable IncoherentInstances
+ "no-allow-incoherent-instances" -> disable IncoherentInstances
+ "arrows" -> enable Arrows
+ "no-arrows" -> disable Arrows
+ "generics" -> enable Generics
+ "no-generics" -> disable Generics
+ "implicit-prelude" -> enable ImplicitPrelude
+ "no-implicit-prelude" -> disable ImplicitPrelude
+ "implicit-params" -> enable ImplicitParams
+ "no-implicit-params" -> disable ImplicitParams
+ "bang-patterns" -> enable BangPatterns
+ "no-bang-patterns" -> disable BangPatterns
+ "scoped-type-variables" -> enable ScopedTypeVariables
+ "no-scoped-type-variables" -> disable ScopedTypeVariables
+ "extended-default-rules" -> enable ExtendedDefaultRules
+ "no-extended-default-rules" -> disable ExtendedDefaultRules
_ -> Nothing
- ghcExtension "-cpp" = Just (EnableExtension CPP)
+ ghcExtension "-cpp" = enable CPP
ghcExtension _ = Nothing
+ enable e = Just (EnableExtension e)
+ disable e = Just (DisableExtension e)
+
checkCCOptions :: PackageDescription -> [PackageCheck]
checkCCOptions pkg =
catMaybes [
@@ -818,7 +824,7 @@ checkPaths pkg =
, isOutsideTree path ]
++
[ PackageDistInexcusable $
- quote (kind ++ ": " ++ path) ++ " is an absolute directory."
+ quote (kind ++ ": " ++ path) ++ " is an absolute path."
| (path, kind) <- relPaths
, isAbsolute path ]
++
@@ -857,8 +863,10 @@ checkPaths pkg =
++ [ (path, "extra-doc-files") | path <- extraDocFiles pkg ]
++ [ (path, "data-files") | path <- dataFiles pkg ]
++ [ (path, "data-dir") | path <- [dataDir pkg]]
+ ++ [ (path, "license-file") | path <- licenseFiles pkg ]
++ concat
[ [ (path, "c-sources") | path <- cSources bi ]
+ ++ [ (path, "js-sources") | path <- jsSources bi ]
++ [ (path, "install-includes") | path <- installIncludes bi ]
++ [ (path, "hs-source-dirs") | path <- hsSourceDirs bi ]
| bi <- allBuildInfo pkg ]
@@ -869,7 +877,7 @@ checkPaths pkg =
++ [ (path, "extra-lib-dirs") | path <- extraLibDirs bi ]
| bi <- allBuildInfo pkg ]
---TODO: check sets of paths that would be interpreted differently between unix
+--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.
@@ -931,6 +939,22 @@ checkCabalVersion pkg =
++ "different modules then list the other ones in the "
++ "'other-languages' field."
+ -- check use of reexported-modules sections
+ , checkVersion [1,21]
+ (maybe False (not.null.reexportedModules) (library pkg)) $
+ PackageDistInexcusable $
+ "To use the 'reexported-module' field the package needs to specify "
+ ++ "at least 'cabal-version: >= 1.21'."
+
+ -- check use of thinning and renaming
+ , checkVersion [1,21] (not (null depsUsingThinningRenamingSyntax)) $
+ PackageDistInexcusable $
+ "The package uses "
+ ++ "thinning and renaming in the 'build-depends' field: "
+ ++ commaSep (map display depsUsingThinningRenamingSyntax)
+ ++ ". To use this new syntax, the package needs to specify at least"
+ ++ "'cabal-version: >= 1.21'."
+
-- 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)) $
@@ -965,7 +989,7 @@ checkCabalVersion pkg =
"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 "
+ ++ "'cabal-version: >= 1.6'. Alternatively, if broader compatibility "
++ "is important then use: " ++ commaSep
[ display (Dependency name (eliminateWildcardSyntax versionRange))
| Dependency name versionRange <- depsUsingWildcardSyntax ]
@@ -985,7 +1009,7 @@ checkCabalVersion pkg =
"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 "
+ ++ "'cabal-version: >= 1.6'. Alternatively, if broader compatibility "
++ "is important then use: " ++ commaSep
[ display (Dependency name (eliminateWildcardSyntax versionRange))
| Dependency name versionRange <- testedWithUsingWildcardSyntax ]
@@ -996,7 +1020,7 @@ checkCabalVersion pkg =
"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 "
+ ++ "Alternatively if you require compatibility with earlier Cabal "
++ "versions then list all the files explicitly."
-- check use of "extra-source-files: mk/*.in" syntax
@@ -1006,7 +1030,7 @@ checkCabalVersion pkg =
++ 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 "
+ ++ "compatibility with earlier Cabal versions then list all the files "
++ "explicitly."
-- check use of "source-repository" section
@@ -1022,7 +1046,7 @@ checkCabalVersion pkg =
"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'."
+ ++ "compatibility with earlier Cabal versions then use 'OtherLicense'."
-- check for new language extensions
, checkVersion [1,2,3] (not (null mentionedExtensionsThatNeedCabal12)) $
@@ -1031,7 +1055,7 @@ checkCabalVersion pkg =
++ 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 "
+ ++ "compatibility with earlier Cabal versions then you may be able to "
++ "use an equivalent compiler-specific flag."
, checkVersion [1,4] (not (null mentionedExtensionsThatNeedCabal14)) $
@@ -1040,8 +1064,29 @@ checkCabalVersion pkg =
++ 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 "
+ ++ "compatibility with earlier Cabal versions then you may be able to "
++ "use an equivalent compiler-specific flag."
+
+ , check (specVersion pkg >= Version [1,23] []
+ && isNothing (setupBuildInfo pkg)
+ && buildType pkg == Just Custom) $
+ PackageBuildWarning $
+ "Packages using 'cabal-version: >= 1.23' with 'build-type: Custom' "
+ ++ "must use a 'custom-setup' section with a 'setup-depends' field "
+ ++ "that specifies the dependencies of the Setup.hs script itself. "
+ ++ "The 'setup-depends' field uses the same syntax as 'build-depends', "
+ ++ "so a simple example would be 'setup-depends: base, Cabal'."
+
+ , check (specVersion pkg < Version [1,23] []
+ && isNothing (setupBuildInfo pkg)
+ && buildType pkg == Just Custom) $
+ PackageDistSuspicious $
+ "From version 1.23 cabal supports specifiying explicit dependencies "
+ ++ "for Custom setup scripts. Consider using cabal-version >= 1.23 and "
+ ++ "adding a 'custom-setup' section with a 'setup-depends' field "
+ ++ "that specifies the dependencies of the Setup.hs script itself. "
+ ++ "The 'setup-depends' field uses the same syntax as 'build-depends', "
+ ++ "so a simple example would be 'setup-depends: base, Cabal'."
]
where
-- Perform a check on packages that use a version of the spec less than
@@ -1101,9 +1146,19 @@ checkCabalVersion pkg =
depsUsingWildcardSyntax = [ dep | dep@(Dependency _ vr) <- buildDepends pkg
, usesWildcardSyntax vr ]
- testedWithUsingWildcardSyntax = [ Dependency (PackageName (display compiler)) vr
- | (compiler, vr) <- testedWith pkg
- , usesWildcardSyntax vr ]
+ -- TODO: If the user writes build-depends: foo with (), this is
+ -- indistinguishable from build-depends: foo, so there won't be an
+ -- error even though there should be
+ depsUsingThinningRenamingSyntax =
+ [ name
+ | bi <- allBuildInfo pkg
+ , (name, rns) <- Map.toList (targetBuildRenaming bi)
+ , rns /= ModuleRenaming True [] ]
+
+ testedWithUsingWildcardSyntax =
+ [ Dependency (PackageName (display compiler)) vr
+ | (compiler, vr) <- testedWith pkg
+ , usesWildcardSyntax vr ]
usesWildcardSyntax :: VersionRange -> Bool
usesWildcardSyntax =
@@ -1123,7 +1178,8 @@ checkCabalVersion pkg =
intersectVersionRanges unionVersionRanges id
compatLicenses = [ GPL Nothing, LGPL Nothing, AGPL Nothing, BSD3, BSD4
- , PublicDomain, AllRightsReserved, OtherLicense ]
+ , PublicDomain, AllRightsReserved
+ , UnspecifiedLicense, OtherLicense ]
mentionedExtensions = [ ext | bi <- allBuildInfo pkg
, ext <- allExtensions bi ]
@@ -1168,7 +1224,7 @@ checkCabalVersion pkg =
-- | 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!
+-- we complain of their presence but do not pretty print them!
--
displayRawVersionRange :: VersionRange -> String
displayRawVersionRange =
@@ -1183,8 +1239,10 @@ displayRawVersionRange =
(\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))
+ (\(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
@@ -1224,7 +1282,7 @@ checkPackageVersions pkg =
++ "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'."
+ ++ "version 4.5 and 4.6 then use 'build-depends: base >= 4.5 && < 4.7'."
]
where
@@ -1237,7 +1295,8 @@ checkPackageVersions pkg =
-- using no package index and the current platform.
finalised = finalizePackageDescription
[] (const True) buildPlatform
- (CompilerId buildCompilerFlavor (Version [] []))
+ (unknownCompilerInfo
+ (CompilerId buildCompilerFlavor (Version [] [])) NoAbiTag)
[] pkg
baseDependency = case finalised of
Right (pkg', _) | not (null baseDeps) ->
@@ -1293,19 +1352,145 @@ checkConditionals pkg =
COr c1 c2 -> condfv c1 ++ condfv c2
CAnd c1 c2 -> condfv c1 ++ condfv c2
+checkDevelopmentOnlyFlagsBuildInfo :: BuildInfo -> [PackageCheck]
+checkDevelopmentOnlyFlagsBuildInfo bi =
+ 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."
+ ++ extraExplanation
+
+ , check (not has_WerrorWall && has_Werror) $
+ PackageDistInexcusable $
+ "'ghc-options: -Werror' makes the package easy to "
+ ++ "break with future GHC versions because new GHC versions often "
+ ++ "add new warnings. "
+ ++ extraExplanation
+
+ , checkFlags ["-fdefer-type-errors"] $
+ PackageDistInexcusable $
+ "'ghc-options: -fdefer-type-errors' is fine during development but "
+ ++ "is not appropriate for a distributed package. "
+ ++ extraExplanation
+
+ -- -dynamic is not a debug flag
+ , check (any (\opt -> "-d" `isPrefixOf` opt && opt /= "-dynamic")
+ ghc_options) $
+ PackageDistInexcusable $
+ "'ghc-options: -d*' debug flags are not appropriate "
+ ++ "for a distributed package. "
+ ++ extraExplanation
+
+ , checkFlags ["-fprof-auto", "-fprof-auto-top", "-fprof-auto-calls",
+ "-fprof-cafs", "-fno-prof-count-entries",
+ "-auto-all", "-auto", "-caf-all"] $
+ PackageDistSuspicious $
+ "'ghc-options: -fprof*' profiling flags are typically not "
+ ++ "appropriate for a distributed library package. These flags are "
+ ++ "useful to profile this package, but when profiling other packages "
+ ++ "that use this one these flags clutter the profile output with "
+ ++ "excessive detail. If you think other packages really want to see "
+ ++ "cost centres from this package then use '-fprof-auto-exported' "
+ ++ "which puts cost centres only on exported functions. "
+ ++ extraExplanation
+ ]
+ where
+ extraExplanation =
+ " Alternatively, if you want to use this, make it conditional based "
+ ++ "on a Cabal configuration flag (with 'manual: True' and 'default: "
+ ++ "False') and enable that flag during development."
+
+ has_WerrorWall = has_Werror && ( has_Wall || has_W )
+ has_Werror = "-Werror" `elem` ghc_options
+ has_Wall = "-Wall" `elem` ghc_options
+ has_W = "-W" `elem` ghc_options
+ ghc_options = hcOptions GHC bi ++ hcProfOptions GHC bi
+
+ checkFlags :: [String] -> PackageCheck -> Maybe PackageCheck
+ checkFlags flags = check (any (`elem` flags) ghc_options)
+
+checkDevelopmentOnlyFlags :: GenericPackageDescription -> [PackageCheck]
+checkDevelopmentOnlyFlags pkg =
+ concatMap checkDevelopmentOnlyFlagsBuildInfo
+ [ bi
+ | (conditions, bi) <- allConditionalBuildInfo
+ , not (any guardedByManualFlag conditions) ]
+ where
+ guardedByManualFlag = definitelyFalse
+
+ -- We've basically got three-values logic here: True, False or unknown
+ -- hence this pattern to propagate the unknown cases properly.
+ definitelyFalse (Var (Flag n)) = maybe False not (Map.lookup n manualFlags)
+ definitelyFalse (Var _) = False
+ definitelyFalse (Lit b) = not b
+ definitelyFalse (CNot c) = definitelyTrue c
+ definitelyFalse (COr c1 c2) = definitelyFalse c1 && definitelyFalse c2
+ definitelyFalse (CAnd c1 c2) = definitelyFalse c1 || definitelyFalse c2
+
+ definitelyTrue (Var (Flag n)) = fromMaybe False (Map.lookup n manualFlags)
+ definitelyTrue (Var _) = False
+ definitelyTrue (Lit b) = b
+ definitelyTrue (CNot c) = definitelyFalse c
+ definitelyTrue (COr c1 c2) = definitelyTrue c1 || definitelyTrue c2
+ definitelyTrue (CAnd c1 c2) = definitelyTrue c1 && definitelyTrue c2
+
+ manualFlags = Map.fromList
+ [ (flagName flag, flagDefault flag)
+ | flag <- genPackageFlags pkg
+ , flagManual flag ]
+
+ allConditionalBuildInfo :: [([Condition ConfVar], BuildInfo)]
+ allConditionalBuildInfo =
+ concatMap (collectCondTreePaths libBuildInfo)
+ (maybeToList (condLibrary pkg))
+
+ ++ concatMap (collectCondTreePaths buildInfo . snd)
+ (condExecutables pkg)
+
+ ++ concatMap (collectCondTreePaths testBuildInfo . snd)
+ (condTestSuites pkg)
+
+ ++ concatMap (collectCondTreePaths benchmarkBuildInfo . snd)
+ (condBenchmarks pkg)
+
+ -- get all the leaf BuildInfo, paired up with the path (in the tree sense)
+ -- of if-conditions that guard it
+ collectCondTreePaths :: (a -> b)
+ -> CondTree v c a
+ -> [([Condition v], b)]
+ collectCondTreePaths mapData = go []
+ where
+ go conditions condNode =
+ -- the data at this level in the tree:
+ (reverse conditions, mapData (condTreeData condNode))
+
+ : concat
+ [ go (condition:conditions) ifThen
+ | (condition, ifThen, _) <- condTreeComponents condNode ]
+
+ ++ concat
+ [ go (condition:conditions) elseThen
+ | (condition, _, Just elseThen) <- condTreeComponents condNode ]
+
+
-- ------------------------------------------------------------
-- * 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.
+-- package and expects to find the package unpacked in at the given file path.
--
checkPackageFiles :: PackageDescription -> FilePath -> IO [PackageCheck]
checkPackageFiles pkg root = checkPackageContent checkFilesIO pkg
where
checkFilesIO = CheckPackageContentOps {
- doesFileExist = System.doesFileExist . relative,
- doesDirectoryExist = System.doesDirectoryExist . relative
+ doesFileExist = System.doesFileExist . relative,
+ doesDirectoryExist = System.doesDirectoryExist . relative,
+ getDirectoryContents = System.Directory.getDirectoryContents . relative,
+ getFileContents = \f -> openBinaryFile (relative f) ReadMode >>= hGetContents
}
relative path = root </> path
@@ -1313,8 +1498,10 @@ checkPackageFiles pkg root = checkPackageContent checkFilesIO pkg
-- Used by 'checkPackageContent'.
--
data CheckPackageContentOps m = CheckPackageContentOps {
- doesFileExist :: FilePath -> m Bool,
- doesDirectoryExist :: FilePath -> m Bool
+ doesFileExist :: FilePath -> m Bool,
+ doesDirectoryExist :: FilePath -> m Bool,
+ getDirectoryContents :: FilePath -> m [FilePath],
+ getFileContents :: FilePath -> m String
}
-- | Sanity check things that requires looking at files in the package.
@@ -1328,38 +1515,79 @@ checkPackageContent :: Monad m => CheckPackageContentOps m
-> PackageDescription
-> m [PackageCheck]
checkPackageContent ops pkg = do
- licenseError <- checkLicenseExists ops pkg
+ cabalBomError <- checkCabalFileBOM ops
+ licenseErrors <- checkLicensesExist ops pkg
setupError <- checkSetupExists ops pkg
configureError <- checkConfigureExists ops pkg
localPathErrors <- checkLocalPathsExist ops pkg
vcsLocation <- checkMissingVcsInfo ops pkg
- return $ catMaybes [licenseError, setupError, configureError]
+ return $ licenseErrors
+ ++ catMaybes [cabalBomError, 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."
+checkCabalFileBOM :: Monad m => CheckPackageContentOps m
+ -> m (Maybe PackageCheck)
+checkCabalFileBOM ops = do
+ epdfile <- findPackageDesc ops
+ case epdfile of
+ Left pc -> return $ Just pc
+ Right pdfile -> (flip check pc . startsWithBOM . fromUTF8) `liftM` (getFileContents ops pdfile)
+ where pc = PackageDistInexcusable $
+ pdfile ++ " starts with an Unicode byte order mark (BOM). This may cause problems with older cabal versions."
+
+-- |Find a package description file in the given directory. Looks for
+-- @.cabal@ files.
+findPackageDesc :: Monad m => CheckPackageContentOps m
+ -> m (Either PackageCheck FilePath) -- ^<pkgname>.cabal
+findPackageDesc ops
+ = do let dir = "."
+ files <- getDirectoryContents ops dir
+ -- to make sure we do not mistake a ~/.cabal/ dir for a <pkgname>.cabal
+ -- file we filter to exclude dirs and null base file names:
+ cabalFiles <- filterM (doesFileExist ops)
+ [ dir </> file
+ | file <- files
+ , let (name, ext) = splitExtension file
+ , not (null name) && ext == ".cabal" ]
+ case cabalFiles of
+ [] -> return (Left $ PackageBuildImpossible noDesc)
+ [cabalFile] -> return (Right cabalFile)
+ multiple -> return (Left $ PackageBuildImpossible $ multiDesc multiple)
+
+ where
+ noDesc :: String
+ noDesc = "No cabal file found.\n"
+ ++ "Please create a package description file <pkgname>.cabal"
+ multiDesc :: [String] -> String
+ multiDesc l = "Multiple cabal files found.\n"
+ ++ "Please use only one of: "
+ ++ intercalate ", " l
+
+checkLicensesExist :: Monad m => CheckPackageContentOps m
+ -> PackageDescription
+ -> m [PackageCheck]
+checkLicensesExist ops pkg = do
+ exists <- mapM (doesFileExist ops) (licenseFiles pkg)
+ return
+ [ PackageBuildWarning $
+ "The '" ++ fieldname ++ "' field refers to the file "
+ ++ quote file ++ " which does not exist."
+ | (file, False) <- zip (licenseFiles pkg) exists ]
where
- file = licenseFile pkg
+ fieldname | length (licenseFiles pkg) == 1 = "license-file"
+ | otherwise = "license-files"
checkSetupExists :: Monad m => CheckPackageContentOps m
-> PackageDescription
-> m (Maybe PackageCheck)
-checkSetupExists ops _ = do
+checkSetupExists ops pkg = do
+ let simpleBuild = buildType pkg == Just Simple
hsexists <- doesFileExist ops "Setup.hs"
lhsexists <- doesFileExist ops "Setup.lhs"
- return $ check (not hsexists && not lhsexists) $
+ return $ check (not simpleBuild && not hsexists && not lhsexists) $
PackageDistInexcusable $
"The package is missing a Setup.hs or Setup.lhs script."
@@ -1370,7 +1598,8 @@ 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."
+ "The 'build-type' is 'Configure' but there is no 'configure' script. "
+ ++ "You probably need to run 'autoreconf -i' to generate it."
checkConfigureExists _ _ = return Nothing
checkLocalPathsExist :: Monad m => CheckPackageContentOps m
diff --git a/cabal/Cabal/Distribution/PackageDescription/Configuration.hs b/cabal/Cabal/Distribution/PackageDescription/Configuration.hs
index 496d701..3e18aba 100644
--- a/cabal/Cabal/Distribution/PackageDescription/Configuration.hs
+++ b/cabal/Cabal/Distribution/PackageDescription/Configuration.hs
@@ -1,9 +1,11 @@
+{-# LANGUAGE CPP #-}
-- -fno-warn-deprecations for use of Map.foldWithKey
{-# OPTIONS_GHC -fno-warn-deprecations #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.PackageDescription.Configuration
-- Copyright : Thomas Schilling, 2007
+-- License : BSD3
--
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
@@ -14,36 +16,6 @@
-- '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,
@@ -75,6 +47,8 @@ import Distribution.System
( Platform(..), OS, Arch )
import Distribution.Simple.Utils
( currentDir, lowercase )
+import Distribution.Simple.Compiler
+ ( CompilerInfo(..) )
import Distribution.Text
( Text(parse) )
@@ -86,7 +60,9 @@ import Data.Char ( isAlphaNum )
import Data.Maybe ( catMaybes, maybeToList )
import Data.Map ( Map, fromListWith, toList )
import qualified Data.Map as Map
+#if __GLASGOW_HASKELL__ < 710
import Data.Monoid
+#endif
------------------------------------------------------------------------------
@@ -124,18 +100,25 @@ simplifyCondition cond i = fv . walk $ cond
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
+-- | 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
+simplifyWithSysParams :: OS -> Arch -> CompilerInfo -> Condition ConfVar
-> (Condition FlagName, [FlagName])
-simplifyWithSysParams os arch (CompilerId comp compVer) cond = (cond', flags)
+simplifyWithSysParams os arch cinfo 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
+ interp (Impl comp vr)
+ | matchImpl (compilerInfoId cinfo) = Right True
+ | otherwise = case compilerInfoCompat cinfo of
+ -- fixme: treat Nothing as unknown, rather than empty list once we
+ -- support partial resolution of system parameters
+ Nothing -> Right False
+ Just compat -> Right (any matchImpl compat)
+ where
+ matchImpl (CompilerId c v) = comp == c && v `withinRange` vr
+ interp (Flag f) = Left f
-- TODO: Add instances and check
--
@@ -237,7 +220,7 @@ resolveWithFlags ::
-- ^ 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
+ -> CompilerInfo -- ^ Compiler information
-> [Dependency] -- ^ Additional constraints
-> [CondTree ConfVar [Dependency] PDTagged]
-> ([Dependency] -> DepTestRslt [Dependency]) -- ^ Dependency test function.
@@ -488,11 +471,11 @@ instance Monoid PDTagged where
--
finalizePackageDescription ::
FlagAssignment -- ^ Explicitly specified flag assignments
- -> (Dependency -> Bool) -- ^ Is a given depenency satisfiable from the set of
+ -> (Dependency -> Bool) -- ^ Is a given dependency satisfiable from the set of
-- available packages? If this is unknown then use
-- True.
-> Platform -- ^ The 'Arch' and 'OS'
- -> CompilerId -- ^ Compiler + Version
+ -> CompilerInfo -- ^ Compiler information
-> [Dependency] -- ^ Additional constraints
-> GenericPackageDescription
-> Either [Dependency]
diff --git a/cabal/Cabal/Distribution/PackageDescription/Parse.hs b/cabal/Cabal/Distribution/PackageDescription/Parse.hs
index 9c2d2e4..d32548c 100644
--- a/cabal/Cabal/Distribution/PackageDescription/Parse.hs
+++ b/cabal/Cabal/Distribution/PackageDescription/Parse.hs
@@ -1,7 +1,10 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.PackageDescription.Parse
-- Copyright : Isaac Jones 2003-2005
+-- License : BSD3
--
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
@@ -11,36 +14,6 @@
-- 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,
@@ -68,20 +41,27 @@ module Distribution.PackageDescription.Parse (
flagFieldDescrs
) where
-import Data.Char (isSpace)
-import Data.Maybe (listToMaybe, isJust)
-import Data.Monoid ( Monoid(..) )
-import Data.List (nub, unfoldr, partition, (\\))
+import Data.Char (isSpace)
+import Data.Foldable (traverse_)
+import Data.Maybe (listToMaybe, isJust)
+import Data.List (nub, unfoldr, partition, (\\))
import Control.Monad (liftM, foldM, when, unless, ap)
+#if __GLASGOW_HASKELL__ < 710
+import Data.Monoid (Monoid(..))
import Control.Applicative (Applicative(..))
-import Control.Arrow (first)
+#endif
+import Control.Arrow (first)
import System.Directory (doesFileExist)
import qualified Data.ByteString.Lazy.Char8 as BS.Char8
+import Data.Typeable
+import Data.Data
+import qualified Data.Map as Map
import Distribution.Text
( Text(disp, parse), display, simpleParse )
import Distribution.Compat.ReadP
((+++), option)
+import qualified Distribution.Compat.ReadP as Parse
import Text.PrettyPrint
import Distribution.ParseUtils hiding (parseFields)
@@ -123,18 +103,30 @@ pkgDescrFieldDescrs =
, simpleField "license"
disp parseLicenseQ
license (\l pkg -> pkg{license=l})
+ -- We have both 'license-file' and 'license-files' fields.
+ -- Rather than declaring license-file to be deprecated, we will continue
+ -- to allow both. The 'license-file' will continue to only allow single
+ -- tokens, while 'license-files' allows multiple. On pretty-printing, we
+ -- will use 'license-file' if there's just one, and use 'license-files'
+ -- otherwise.
, simpleField "license-file"
showFilePath parseFilePathQ
- licenseFile (\l pkg -> pkg{licenseFile=l})
+ (\pkg -> case licenseFiles pkg of
+ [x] -> x
+ _ -> "")
+ (\l pkg -> pkg{licenseFiles=licenseFiles pkg ++ [l]})
+ , listField "license-files"
+ showFilePath parseFilePathQ
+ (\pkg -> case licenseFiles pkg of
+ [_] -> []
+ xs -> xs)
+ (\ls pkg -> pkg{licenseFiles=ls})
, 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})
@@ -162,19 +154,19 @@ pkgDescrFieldDescrs =
, listField "tested-with"
showTestedWith parseTestedWithQ
testedWith (\val pkg -> pkg{testedWith=val})
- , listField "data-files"
+ , listFieldWithSep vcat "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"
+ , listFieldWithSep vcat "extra-source-files"
showFilePath parseFilePathQ
extraSrcFiles (\val pkg -> pkg{extraSrcFiles=val})
- , listField "extra-tmp-files"
+ , listFieldWithSep vcat "extra-tmp-files"
showFilePath parseFilePathQ
extraTmpFiles (\val pkg -> pkg{extraTmpFiles=val})
- , listField "extra-doc-files"
+ , listFieldWithSep vcat "extra-doc-files"
showFilePath parseFilePathQ
extraDocFiles (\val pkg -> pkg{extraDocFiles=val})
]
@@ -192,9 +184,18 @@ storeXFieldsPD _ _ = Nothing
libFieldDescrs :: [FieldDescr Library]
libFieldDescrs =
- [ listField "exposed-modules" disp parseModuleNameQ
+ [ listFieldWithSep vcat "exposed-modules" disp parseModuleNameQ
exposedModules (\mods lib -> lib{exposedModules=mods})
+ , commaListFieldWithSep vcat "reexported-modules" disp parse
+ reexportedModules (\mods lib -> lib{reexportedModules=mods})
+
+ , listFieldWithSep vcat "required-signatures" disp parseModuleNameQ
+ requiredSignatures (\mods lib -> lib{requiredSignatures=mods})
+
+ , listFieldWithSep vcat "exposed-signatures" disp parseModuleNameQ
+ exposedSignatures (\mods lib -> lib{exposedSignatures=mods})
+
, boolField "exposed"
libExposed (\val lib -> lib{libExposed=val})
] ++ map biToLib binfoFieldDescrs
@@ -399,6 +400,10 @@ binfoFieldDescrs =
, commaListField "build-tools"
disp parseBuildTool
buildTools (\xs binfo -> binfo{buildTools=xs})
+ , commaListFieldWithSep vcat "build-depends"
+ disp parse
+ buildDependsWithRenaming
+ setBuildDependsWithRenaming
, spaceListField "cpp-options"
showToken parseTokenQ'
cppOptions (\val binfo -> binfo{cppOptions=val})
@@ -414,10 +419,12 @@ binfoFieldDescrs =
, listField "frameworks"
showToken parseTokenQ
frameworks (\val binfo -> binfo{frameworks=val})
- , listField "c-sources"
+ , listFieldWithSep vcat "c-sources"
showFilePath parseFilePathQ
cSources (\paths binfo -> binfo{cSources=paths})
-
+ , listFieldWithSep vcat "js-sources"
+ showFilePath parseFilePathQ
+ jsSources (\paths binfo -> binfo{jsSources=paths})
, simpleField "default-language"
(maybe empty disp) (option Nothing (fmap Just parseLanguageQ))
defaultLanguage (\lang binfo -> binfo{defaultLanguage=lang})
@@ -434,16 +441,19 @@ binfoFieldDescrs =
disp parseExtensionQ
oldExtensions (\exts binfo -> binfo{oldExtensions=exts})
- , listField "extra-libraries"
+ , listFieldWithSep vcat "extra-libraries"
showToken parseTokenQ
extraLibs (\xs binfo -> binfo{extraLibs=xs})
+ , listFieldWithSep vcat "extra-ghci-libraries"
+ showToken parseTokenQ
+ extraGHCiLibs (\xs binfo -> binfo{extraGHCiLibs=xs})
, listField "extra-lib-dirs"
showFilePath parseFilePathQ
extraLibDirs (\xs binfo -> binfo{extraLibDirs=xs})
- , listField "includes"
+ , listFieldWithSep vcat "includes"
showFilePath parseFilePathQ
includes (\paths binfo -> binfo{includes=paths})
- , listField "install-includes"
+ , listFieldWithSep vcat "install-includes"
showFilePath parseFilePathQ
installIncludes (\paths binfo -> binfo{installIncludes=paths})
, listField "include-dirs"
@@ -452,23 +462,30 @@ binfoFieldDescrs =
, listField "hs-source-dirs"
showFilePath parseFilePathQ
hsSourceDirs (\paths binfo -> binfo{hsSourceDirs=paths})
- , listField "other-modules"
+ , listFieldWithSep vcat "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-prof-options" GHC
+ profOptions (\val binfo -> binfo{profOptions=val})
+ , optsField "ghcjs-prof-options" GHCJS
+ profOptions (\val binfo -> binfo{profOptions=val})
+ , optsField "ghc-shared-options" GHC
+ sharedOptions (\val binfo -> binfo{sharedOptions=val})
+ , optsField "ghcjs-shared-options" GHCJS
+ sharedOptions (\val binfo -> binfo{sharedOptions=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
+ , optsField "ghcjs-options" GHCJS
options (\path binfo -> binfo{options=path})
, optsField "jhc-options" JHC
options (\path binfo -> binfo{options=path})
+
+ -- NOTE: Hugs and NHC are not supported anymore, but these fields are kept
+ -- around for backwards compatibility.
+ , optsField "hugs-options" Hugs
+ options (const id)
+ , optsField "nhc98-options" NHC
+ options (const id)
]
storeXFieldsBI :: UnrecFieldParser BuildInfo
@@ -512,6 +529,15 @@ sourceRepoFieldDescrs =
repoSubdir (\val repo -> repo { repoSubdir = val })
]
+------------------------------------------------------------------------------
+
+setupBInfoFieldDescrs :: [FieldDescr SetupBuildInfo]
+setupBInfoFieldDescrs =
+ [ commaListFieldWithSep vcat "setup-depends"
+ disp parse
+ setupDepends (\xs binfo -> binfo{setupDepends=xs})
+ ]
+
-- ---------------------------------------------------------------
-- Parsing
@@ -579,7 +605,7 @@ constraintFieldNames = ["build-depends"]
-- 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 :: Field -> ParseResult [DependencyWithRenaming]
parseConstraint (F l n v)
| n == "build-depends" = runP l n (parseCommaList parse) v
parseConstraint f = userBug $ "Constraint was expected (got: " ++ show f ++ ")"
@@ -609,10 +635,15 @@ newtype StT s m a = StT { runStT :: s -> m (a,s) }
instance Functor f => Functor (StT s f) where
fmap g (StT f) = StT $ fmap (first g) . f
+#if __GLASGOW_HASKELL__ >= 710
+instance (Monad m) => Applicative (StT s m) where
+#else
instance (Monad m, Functor m) => Applicative (StT s m) where
+#endif
pure = return
(<*>) = ap
+
instance Monad m => Monad (StT s m) where
return a = StT (\s -> return (a,s))
StT f >>= g = StT $ \s -> do
@@ -718,13 +749,13 @@ parsePackageDescription file = do
-- 'getBody' assumes that the remaining fields only consist of
-- flags, lib and exe sections.
- (repos, flags, mlib, exes, tests, bms) <- getBody
+ (repos, flags, mcsetup, 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 }
+ pkg { sourceRepos = repos, setupBuildInfo = mcsetup }
flags mlib exes tests bms
where
@@ -775,7 +806,7 @@ parsePackageDescription file = do
-- * an optional library section, and an arbitrary number of executable
-- sections (in any order).
--
- -- The current implementatition just gathers all library-specific fields
+ -- The current implementation just gathers all library-specific fields
-- in a library section and wraps all executable stanzas in an executable
-- section.
sectionizeFields :: [Field] -> [Field]
@@ -830,6 +861,7 @@ parsePackageDescription file = do
-- 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 SetupBuildInfo
,Maybe (CondTree ConfVar [Dependency] Library)
,[(String, CondTree ConfVar [Dependency] Executable)]
,[(String, CondTree ConfVar [Dependency] TestSuite)]
@@ -842,8 +874,8 @@ parsePackageDescription file = do
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)
+ (repos, flags, csetup, lib, exes, tests, bms) <- getBody
+ return (repos, flags, csetup, lib, (exename, flds): exes, tests, bms)
| sec_type == "test-suite" -> do
when (null sec_label) $ lift $ syntaxError line_no
@@ -884,8 +916,9 @@ parsePackageDescription file = do
if checkTestType emptyTestSuite flds
then do
skipField
- (repos, flags, lib, exes, tests, bms) <- getBody
- return (repos, flags, lib, exes, (testname, flds) : tests, bms)
+ (repos, flags, csetup, lib, exes, tests, bms) <- getBody
+ return (repos, flags, csetup, lib, exes,
+ (testname, flds) : tests, bms)
else lift $ syntaxError line_no $
"Test suite \"" ++ testname
++ "\" is missing required field \"type\" or the field "
@@ -932,8 +965,9 @@ parsePackageDescription file = do
if checkBenchmarkType emptyBenchmark flds
then do
skipField
- (repos, flags, lib, exes, tests, bms) <- getBody
- return (repos, flags, lib, exes, tests, (benchname, flds) : bms)
+ (repos, flags, csetup, lib, exes, tests, bms) <- getBody
+ return (repos, flags, csetup, lib, exes,
+ tests, (benchname, flds) : bms)
else lift $ syntaxError line_no $
"Benchmark \"" ++ benchname
++ "\" is missing required field \"type\" or the field "
@@ -946,10 +980,10 @@ parsePackageDescription file = do
syntaxError line_no "'library' expects no argument"
flds <- collectFields parseLibFields sec_fields
skipField
- (repos, flags, lib, exes, tests, bms) <- getBody
+ (repos, flags, csetup, 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)
+ return (repos, flags, csetup, Just flds, exes, tests, bms)
| sec_type == "flag" -> do
when (null sec_label) $ lift $
@@ -960,8 +994,8 @@ parsePackageDescription file = do
(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)
+ (repos, flags, csetup, lib, exes, tests, bms) <- getBody
+ return (repos, flag:flags, csetup, lib, exes, tests, bms)
| sec_type == "source-repository" -> do
when (null sec_label) $ lift $ syntaxError line_no $
@@ -985,8 +1019,22 @@ parsePackageDescription file = do
}
sec_fields
skipField
- (repos, flags, lib, exes, tests, bms) <- getBody
- return (repo:repos, flags, lib, exes, tests, bms)
+ (repos, flags, csetup, lib, exes, tests, bms) <- getBody
+ return (repo:repos, flags, csetup, lib, exes, tests, bms)
+
+ | sec_type == "custom-setup" -> do
+ unless (null sec_label) $ lift $
+ syntaxError line_no "'setup' expects no argument"
+ flds <- lift $ parseFields
+ setupBInfoFieldDescrs
+ warnUnrec
+ mempty
+ sec_fields
+ skipField
+ (repos, flags, csetup0, lib, exes, tests, bms) <- getBody
+ when (isJust csetup0) $ lift $ syntaxError line_no
+ "There can only be one 'custom-setup' section in a package description."
+ return (repos, flags, Just flds, lib, exes, tests, bms)
| otherwise -> do
lift $ warning $ "Ignoring unknown section type: " ++ sec_type
@@ -1002,7 +1050,7 @@ parsePackageDescription file = do
"If-blocks are not allowed in between stanzas: " ++ show f
skipField
getBody
- Nothing -> return ([], [], Nothing, [], [], [])
+ Nothing -> return ([], [], Nothing, Nothing, [], [], [])
-- Extracts all fields in a block and returns a 'CondTree'.
--
@@ -1014,11 +1062,19 @@ parsePackageDescription file = do
let simplFlds = [ F l n v | F l n v <- allflds ]
condFlds = [ f | f@IfBlock{} <- allflds ]
+ sections = [ s | s@Section{} <- allflds ]
- let (depFlds, dataFlds) = partition isConstraint simplFlds
+ -- Put these through the normal parsing pass too, so that we
+ -- collect the ModRenamings
+ let depFlds = filter isConstraint simplFlds
+
+ mapM_
+ (\(Section l n _ _) -> lift . warning $
+ "Unexpected section '" ++ n ++ "' on line " ++ show l)
+ sections
- a <- parser dataFlds
- deps <- liftM concat . mapM (lift . parseConstraint) $ depFlds
+ a <- parser simplFlds
+ deps <- liftM concat . mapM (lift . fmap (map dependency) . parseConstraint) $ depFlds
ifs <- mapM processIfs condFlds
@@ -1065,7 +1121,7 @@ parsePackageDescription file = do
PM ()
checkForUndefinedFlags flags mlib exes tests = do
let definedFlags = map flagName flags
- maybe (return ()) (checkCondTreeFlags definedFlags) mlib
+ traverse_ (checkCondTreeFlags definedFlags) mlib
mapM_ (checkCondTreeFlags definedFlags . snd) exes
mapM_ (checkCondTreeFlags definedFlags . snd) tests
@@ -1222,3 +1278,32 @@ findIndentTabs = concatMap checkLine
--test_findIndentTabs = findIndentTabs $ unlines $
-- [ "foo", " bar", " \t baz", "\t biz\t", "\t\t \t mib" ]
+
+-- | Dependencies plus module renamings. This is what users specify; however,
+-- renaming information is not used for dependency resolution.
+data DependencyWithRenaming = DependencyWithRenaming Dependency ModuleRenaming
+ deriving (Read, Show, Eq, Typeable, Data)
+
+dependency :: DependencyWithRenaming -> Dependency
+dependency (DependencyWithRenaming dep _) = dep
+
+instance Text DependencyWithRenaming where
+ disp (DependencyWithRenaming d rns) = disp d <+> disp rns
+ parse = do d <- parse
+ Parse.skipSpaces
+ rns <- parse
+ Parse.skipSpaces
+ return (DependencyWithRenaming d rns)
+
+buildDependsWithRenaming :: BuildInfo -> [DependencyWithRenaming]
+buildDependsWithRenaming pkg =
+ map (\dep@(Dependency n _) ->
+ DependencyWithRenaming dep
+ (Map.findWithDefault defaultRenaming n (targetBuildRenaming pkg)))
+ (targetBuildDepends pkg)
+
+setBuildDependsWithRenaming :: [DependencyWithRenaming] -> BuildInfo -> BuildInfo
+setBuildDependsWithRenaming deps pkg = pkg {
+ targetBuildDepends = map dependency deps,
+ targetBuildRenaming = Map.fromList (map (\(DependencyWithRenaming (Dependency n _) rns) -> (n, rns)) deps)
+ }
diff --git a/cabal/Cabal/Distribution/PackageDescription/PrettyPrint.hs b/cabal/Cabal/Distribution/PackageDescription/PrettyPrint.hs
index 281d515..bca9cc3 100644
--- a/cabal/Cabal/Distribution/PackageDescription/PrettyPrint.hs
+++ b/cabal/Cabal/Distribution/PackageDescription/PrettyPrint.hs
@@ -1,73 +1,44 @@
+{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
---
+-- |
-- Module : Distribution.PackageDescription.PrettyPrint
-- Copyright : Jürgen Nicklisch-Franken 2010
--- License : AllRightsReserved
+-- License : BSD3
--
-- Maintainer : cabal-devel@haskell.org
-- Stability : provisional
-- Portability : portable
--
--- | Pretty printing for cabal files
+-- 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
+#if __GLASGOW_HASKELL__ < 710
import Data.Monoid (Monoid(mempty))
+#endif
import Distribution.PackageDescription
( Benchmark(..), BenchmarkInterface(..), benchmarkType
, TestSuite(..), TestSuiteInterface(..), testType
, SourceRepo(..),
- customFieldsBI, CondTree(..), Condition(..),
+ customFieldsBI, CondTree(..), Condition(..), cNot,
FlagName(..), ConfVar(..), Executable(..), Library(..),
Flag(..), PackageDescription(..),
GenericPackageDescription(..))
import Text.PrettyPrint
- (hsep, comma, punctuate, fsep, parens, char, nest, empty,
- isEmpty, ($$), (<+>), colon, (<>), text, vcat, ($+$), Doc, render)
+ (hsep, parens, char, nest, empty, isEmpty, ($$), (<+>),
+ colon, (<>), text, vcat, ($+$), Doc, render)
import Distribution.Simple.Utils (writeUTF8File)
-import Distribution.ParseUtils (showFreeText, FieldDescr(..))
+import Distribution.ParseUtils (showFreeText, FieldDescr(..), indentWith, ppField, ppFields)
import Distribution.PackageDescription.Parse (pkgDescrFieldDescrs,binfoFieldDescrs,libFieldDescrs,
- sourceRepoFieldDescrs)
+ sourceRepoFieldDescrs,flagFieldDescrs)
import Distribution.Package (Dependency(..))
import Distribution.Text (Text(..))
-import Data.Maybe (isJust, fromJust, isNothing)
-
-indentWith :: Int
-indentWith = 4
+import Data.Maybe (isJust)
-- | Recompile with false for regression testing
simplifiedPrinting :: Bool
@@ -106,20 +77,29 @@ ppSourceRepo 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]
+-- TODO: this is a temporary hack. Ideally, fields containing default values
+-- would be filtered out when the @FieldDescr a@ list is generated.
+ppFieldsFiltered :: [(String, String)] -> [FieldDescr a] -> a -> Doc
+ppFieldsFiltered removable fields x = ppFields (filter nondefault fields) x
+ where
+ nondefault (FieldDescr name getter _) =
+ maybe True (render (getter x) /=) (lookup name removable)
+
+binfoDefaults :: [(String, String)]
+binfoDefaults = [("buildable", "True")]
-ppField :: String -> Doc -> Doc
-ppField name fielddoc | isEmpty fielddoc = empty
- | otherwise = text name <> colon <+> fielddoc
+libDefaults :: [(String, String)]
+libDefaults = ("exposed", "True") : binfoDefaults
+
+flagDefaults :: [(String, String)]
+flagDefaults = [("default", "True"), ("manual", "False")]
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)]
+ 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]
@@ -131,20 +111,17 @@ 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)))
+ppFlag flag@(MkFlag name _ _ _) =
+ emptyLine $ text "flag" <+> ppFlagName name $+$ nest indentWith fields
+ where
+ fields = ppFieldsFiltered flagDefaults flagFieldDescrs flag
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
+ ppLib lib Nothing = ppFieldsFiltered libDefaults libFieldDescrs lib
$$ ppCustomFields (customFieldsBI (libBuildInfo lib))
ppLib lib (Just plib) = ppDiffFields libFieldDescrs lib plib
$$ ppCustomFields (customFieldsBI (libBuildInfo lib))
@@ -156,7 +133,7 @@ ppExecutables exes =
where
ppExe (Executable _ modulePath' buildInfo') Nothing =
(if modulePath' == "" then empty else text "main-is:" <+> text modulePath')
- $+$ ppFields binfoFieldDescrs buildInfo'
+ $+$ ppFieldsFiltered binfoDefaults binfoFieldDescrs buildInfo'
$+$ ppCustomFields (customFieldsBI buildInfo')
ppExe (Executable _ modulePath' buildInfo')
(Just (Executable _ modulePath2 buildInfo2)) =
@@ -178,7 +155,7 @@ ppTestSuites suites =
(testSuiteMainIs testsuite)
$+$ maybe empty (\m -> text "test-module:" <+> disp m)
(testSuiteModule testsuite)
- $+$ ppFields binfoFieldDescrs (testBuildInfo testsuite)
+ $+$ ppFieldsFiltered binfoDefaults binfoFieldDescrs (testBuildInfo testsuite)
$+$ ppCustomFields (customFieldsBI (testBuildInfo testsuite))
where
maybeTestType | testInterface testsuite == mempty = Nothing
@@ -208,7 +185,7 @@ ppBenchmarks suites =
maybeBenchmarkType
$+$ maybe empty (\f -> text "main-is:" <+> text f)
(benchmarkMainIs benchmark)
- $+$ ppFields binfoFieldDescrs (benchmarkBuildInfo benchmark)
+ $+$ ppFieldsFiltered binfoDefaults binfoFieldDescrs (benchmarkBuildInfo benchmark)
$+$ ppCustomFields (customFieldsBI (benchmarkBuildInfo benchmark))
where
maybeBenchmarkType | benchmarkInterface benchmark == mempty = Nothing
@@ -241,31 +218,45 @@ 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)
+ppCondTree ct@(CondNode it _ ifs) mbIt ppIt =
+ let res = (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))
+ -- TODO: this ends up printing trailing spaces when combined with nest.
+ ppIf (c, thenTree, Just elseTree) = ppIfElse it ppIt c thenTree elseTree
+ ppIf (c, thenTree, Nothing) = ppIf' it ppIt c thenTree
+
+ppIfCondition :: (Condition ConfVar) -> Doc
+ppIfCondition c = (emptyLine $ text "if" <+> ppCondition c)
+
+ppIf' :: a -> (a -> Maybe a -> Doc)
+ -> Condition ConfVar
+ -> CondTree ConfVar [Dependency] a
+ -> Doc
+ppIf' it ppIt c thenTree =
+ if isEmpty thenDoc
+ then mempty
+ else ppIfCondition c $$ nest indentWith thenDoc
+ where thenDoc = ppCondTree thenTree (if simplifiedPrinting then (Just it) else Nothing) ppIt
+
+ppIfElse :: a -> (a -> Maybe a -> Doc)
+ -> Condition ConfVar
+ -> CondTree ConfVar [Dependency] a
+ -> CondTree ConfVar [Dependency] a
+ -> Doc
+ppIfElse it ppIt c thenTree elseTree =
+ case (isEmpty thenDoc, isEmpty elseDoc) of
+ (True, True) -> mempty
+ (False, True) -> ppIfCondition c $$ nest indentWith thenDoc
+ (True, False) -> ppIfCondition (cNot c) $$ nest indentWith elseDoc
+ (False, False) -> (ppIfCondition c $$ nest indentWith thenDoc)
+ $+$ (text "else" $$ nest indentWith elseDoc)
+ where thenDoc = ppCondTree thenTree (if simplifiedPrinting then (Just it) else Nothing) ppIt
+ elseDoc = ppCondTree elseTree (if simplifiedPrinting then (Just it) else Nothing) ppIt
emptyLine :: Doc -> Doc
-emptyLine d = text " " $+$ d
-
-
+emptyLine d = text "" $+$ d
diff --git a/cabal/Cabal/Distribution/ParseUtils.hs b/cabal/Cabal/Distribution/ParseUtils.hs
index 2f2bc84..62011f4 100644
--- a/cabal/Cabal/Distribution/ParseUtils.hs
+++ b/cabal/Cabal/Distribution/ParseUtils.hs
@@ -1,7 +1,9 @@
+{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.ParseUtils
-- Copyright : (c) The University of Glasgow 2004
+-- License : BSD3
--
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
@@ -15,36 +17,6 @@
-- 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...
{-# OPTIONS_HADDOCK hide #-}
@@ -61,8 +33,9 @@ module Distribution.ParseUtils (
parseTestedWithQ, parseLicenseQ, parseLanguageQ, parseExtensionQ,
parseSepList, parseCommaList, parseOptCommaList,
showFilePath, showToken, showTestedWith, showFreeText, parseFreeText,
- field, simpleField, listField, spaceListField, commaListField,
- optsField, liftField, boolField, parseQuoted,
+ field, simpleField, listField, listFieldWithSep, spaceListField,
+ commaListField, commaListFieldWithSep, commaNewLineListField,
+ optsField, liftField, boolField, parseQuoted, indentWith,
UnrecFieldParser, warnUnrec, ignoreUnrec,
) where
@@ -78,7 +51,8 @@ import Distribution.ReadE
import Distribution.Text
( Text(..) )
import Distribution.Simple.Utils
- ( comparing, intercalate, lowercase, normaliseLineEndings )
+ ( comparing, dropWhileEndLE, intercalate, lowercase
+ , normaliseLineEndings )
import Language.Haskell.Extension
( Language, Extension )
@@ -88,13 +62,16 @@ import Data.Maybe (fromMaybe)
import Data.Tree as Tree (Tree(..), flatten)
import qualified Data.Map as Map
import Control.Monad (foldM, ap)
+#if __GLASGOW_HASKELL__ < 710
import Control.Applicative (Applicative(..))
+#endif
import System.FilePath (normalise)
import Data.List (sortBy)
-- -----------------------------------------------------------------------------
-type LineNo = Int
+type LineNo = Int
+type Separator = ([Doc] -> Doc)
data PError = AmbiguousParse String LineNo
| NoParse String LineNo
@@ -217,37 +194,51 @@ simpleField :: String -> (a -> Doc) -> ReadP a a
simpleField name showF readF get set
= liftField get set $ field name showF readF
+commaListFieldWithSep :: Separator -> String -> (a -> Doc) -> ReadP [a] a
+ -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
+commaListFieldWithSep separator name showF readF get set =
+ liftField get set' $
+ field name showF' (parseCommaList readF)
+ where
+ set' xs b = set (get b ++ xs) b
+ showF' = separator . punctuate comma . map showF
+
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
+commaListField = commaListFieldWithSep fsep
+
+commaNewLineListField :: String -> (a -> Doc) -> ReadP [a] a
+ -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
+commaNewLineListField = commaListFieldWithSep sep
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)
+ field name showF' (parseSpaceList readF)
where
set' xs b = set (get b ++ xs) b
+ showF' = fsep . map showF
-listField :: String -> (a -> Doc) -> ReadP [a] a
+listFieldWithSep :: Separator -> String -> (a -> Doc) -> ReadP [a] a
-> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
-listField name showF readF get set =
+listFieldWithSep separator name showF readF get set =
liftField get set' $
- field name (fsep . map showF) (parseOptCommaList readF)
+ field name showF' (parseOptCommaList readF)
where
set' xs b = set (get b ++ xs) b
+ showF' = separator . map showF
+
+listField :: String -> (a -> Doc) -> ReadP [a] a
+ -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
+listField = listFieldWithSep fsep
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))
+ field name showF (sepBy parseTokenQ' (munch1 isSpace))
where
update _ opts l | all null opts = l --empty opts as if no opts
update f opts [] = [(f,opts)]
@@ -255,6 +246,7 @@ optsField name flavor get set =
| f == f' = (f, opts' ++ opts) : rest
| otherwise = (f',opts') : update f opts rest
reorder = sortBy (comparing fst)
+ showF = hsep . map text
-- 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
@@ -275,11 +267,30 @@ boolField name get set = liftField get set (FieldDescr name showF readF)
"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]
+ppFields fields x =
+ vcat [ ppField name (getter x) | FieldDescr name getter _ <- fields ]
ppField :: String -> Doc -> Doc
-ppField name fielddoc = text name <> colon <+> fielddoc
+ppField name fielddoc
+ | isEmpty fielddoc = empty
+ | name `elem` nestedFields = text name <> colon $+$ nest indentWith fielddoc
+ | otherwise = text name <> colon <+> fielddoc
+ where
+ nestedFields =
+ [ "description"
+ , "build-depends"
+ , "data-files"
+ , "extra-source-files"
+ , "extra-tmp-files"
+ , "exposed-modules"
+ , "c-sources"
+ , "js-sources"
+ , "extra-libraries"
+ , "includes"
+ , "install-includes"
+ , "other-modules"
+ , "depends"
+ ]
showFields :: [FieldDescr a] -> a -> String
showFields fields = render . ($+$ text "") . ppFields fields
@@ -436,7 +447,7 @@ data Token =
-- > else
-- > other
--
- -- this is ok
+ -- this is OK
Line LineNo Indent HasTabs String
| Span LineNo String -- ^ span in a line, following brackets
| OpenBracket LineNo | CloseBracket LineNo
@@ -444,7 +455,7 @@ data Token =
type Indent = Int
type HasTabs = Bool
--- | Tokenise a single line, splitting on '{' '}' and the spans inbetween.
+-- | Tokenise a single line, splitting on '{' '}' and the spans in between.
-- 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
@@ -471,7 +482,7 @@ tokeniseLineFlat (n0, i, t, l)
trimLeading, trimTrailing :: String -> String
trimLeading = dropWhile isSpace
-trimTrailing = reverse . dropWhile isSpace . reverse
+trimTrailing = dropWhileEndLE isSpace
type SyntaxTree = Tree (LineNo, HasTabs, String)
@@ -481,8 +492,8 @@ 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 }"
+ OpenBracket n:_ -> syntaxError n "mismatched brackets, unexpected {"
+ CloseBracket n:_ -> syntaxError n "mismatched brackets, 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
@@ -650,7 +661,7 @@ parseOptVersion :: ReadP r Version
parseOptVersion = parseQuoted ver <++ ver
where ver :: ReadP r Version
ver = parse <++ return noVersion
- noVersion = Version{ versionBranch=[], versionTags=[] }
+ noVersion = Version [] []
parseTestedWithQ :: ReadP r (CompilerFlavor,VersionRange)
parseTestedWithQ = parseQuoted tw <++ tw
@@ -711,7 +722,8 @@ parseFreeText = ReadP.munch (const True)
-- ** Pretty printing
showFilePath :: FilePath -> Doc
-showFilePath = showToken
+showFilePath "" = empty
+showFilePath x = showToken x
showToken :: String -> Doc
showToken str
@@ -727,7 +739,6 @@ showTestedWith (compiler, version) = text (show compiler) <+> disp version
-- 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
@@ -738,3 +749,7 @@ lines_ s = let (l, s') = break (== '\n') s
in l : case s' of
[] -> []
(_:s'') -> lines_ s''
+
+-- | the indentation used for pretty printing
+indentWith :: Int
+indentWith = 4
diff --git a/cabal/Cabal/Distribution/ReadE.hs b/cabal/Cabal/Distribution/ReadE.hs
index 07b2568..b639f81 100644
--- a/cabal/Cabal/Distribution/ReadE.hs
+++ b/cabal/Cabal/Distribution/ReadE.hs
@@ -2,43 +2,13 @@
-- |
-- Module : Distribution.ReadE
-- Copyright : Jose Iborra 2008
+-- License : BSD3
--
-- 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,
diff --git a/cabal/Cabal/Distribution/Simple.hs b/cabal/Cabal/Distribution/Simple.hs
index 9d8a65b..68eec9b 100644
--- a/cabal/Cabal/Distribution/Simple.hs
+++ b/cabal/Cabal/Distribution/Simple.hs
@@ -2,6 +2,7 @@
-- |
-- Module : Distribution.Simple
-- Copyright : Isaac Jones 2003-2005
+-- License : BSD3
--
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
@@ -24,36 +25,6 @@
-- 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:
@@ -85,7 +56,7 @@ module Distribution.Simple (
-- 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.Package --must not specify imports, since we're exporting module.
import Distribution.PackageDescription
( PackageDescription(..), GenericPackageDescription, Executable(..)
, updatePackageDescription, hasLibs
@@ -109,7 +80,7 @@ import Distribution.Simple.Register
import Distribution.Simple.Configure
( getPersistBuildConfig, maybeGetPersistBuildConfig
, writePersistBuildConfig, checkPersistBuildConfigOutdated
- , configure, checkForeignDeps )
+ , configure, checkForeignDeps, findDistPrefOrDefault )
import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) )
import Distribution.Simple.Bench (bench)
@@ -134,13 +105,14 @@ import Distribution.Text
import System.Environment(getArgs, getProgName)
import System.Directory(removeFile, doesFileExist,
doesDirectoryExist, removeDirectoryRecursive)
-import System.Exit
+import System.Exit (exitWith,ExitCode(..))
import System.IO.Error (isDoesNotExistError)
import Control.Exception (throwIO)
import Distribution.Compat.Environment (getEnvironment)
import Distribution.Compat.Exception (catchIO)
import Control.Monad (when)
+import Data.Foldable (traverse_)
import Data.List (intercalate, unionBy, nub, (\\))
-- | A simple implementation of @main@ for a Cabal setup script.
@@ -172,7 +144,7 @@ defaultMainNoRead pkg_descr =
defaultMainHelper :: UserHooks -> Args -> IO ()
defaultMainHelper hooks args = topHandler $
- case commandsRun globalCommand commands args of
+ case commandsRun (globalCommand commands) commands args of
CommandHelp help -> printHelp help
CommandList opts -> printOptionsList opts
CommandErrors errs -> printErrors errs
@@ -225,187 +197,202 @@ allSuffixHandlers hooks
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)
+ distPref <- findDistPrefOrDefault (configDistPref flags)
+ let flags' = flags { configDistPref = toFlag distPref }
+ 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
+ distPref <- findDistPrefOrDefault (buildDistPref flags)
+ let verbosity = fromFlag $ buildVerbosity flags
+ flags' = flags { buildDistPref = toFlag distPref }
lbi <- getBuildConfig hooks verbosity distPref
progs <- reconfigurePrograms verbosity
- (buildProgramPaths flags)
- (buildProgramArgs flags)
+ (buildProgramPaths flags')
+ (buildProgramArgs flags')
(withPrograms lbi)
hookedAction preBuild buildHook postBuild
(return lbi { withPrograms = progs })
- hooks flags { buildArgs = args } args
+ hooks flags' { buildArgs = args } args
replAction :: UserHooks -> ReplFlags -> Args -> IO ()
replAction hooks flags args = do
- let distPref = fromFlag $ replDistPref flags
- verbosity = fromFlag $ replVerbosity flags
+ distPref <- findDistPrefOrDefault (replDistPref flags)
+ let verbosity = fromFlag $ replVerbosity flags
+ flags' = flags { replDistPref = toFlag distPref }
lbi <- getBuildConfig hooks verbosity distPref
progs <- reconfigurePrograms verbosity
- (replProgramPaths flags)
- (replProgramArgs flags)
+ (replProgramPaths flags')
+ (replProgramArgs flags')
(withPrograms lbi)
- pbi <- preRepl hooks args flags
+ pbi <- preRepl hooks args flags'
let lbi' = lbi { withPrograms = progs }
pkg_descr0 = localPkgDescr lbi'
pkg_descr = updatePackageDescription pbi pkg_descr0
- replHook hooks pkg_descr lbi' hooks flags args
- postRepl hooks args flags pkg_descr lbi'
+ replHook hooks pkg_descr lbi' hooks flags' args
+ postRepl hooks args flags' pkg_descr lbi'
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
+hscolourAction hooks flags args = do
+ distPref <- findDistPrefOrDefault (hscolourDistPref flags)
+ let verbosity = fromFlag $ hscolourVerbosity flags
+ flags' = flags { hscolourDistPref = toFlag distPref }
+ 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
+ distPref <- findDistPrefOrDefault (haddockDistPref flags)
+ let verbosity = fromFlag $ haddockVerbosity flags
+ flags' = flags { haddockDistPref = toFlag distPref }
lbi <- getBuildConfig hooks verbosity distPref
progs <- reconfigurePrograms verbosity
- (haddockProgramPaths flags)
- (haddockProgramArgs flags)
+ (haddockProgramPaths flags')
+ (haddockProgramArgs flags')
(withPrograms lbi)
hookedAction preHaddock haddockHook postHaddock
(return lbi { withPrograms = progs })
- hooks flags args
+ hooks flags' args
cleanAction :: UserHooks -> CleanFlags -> Args -> IO ()
cleanAction hooks flags args = do
- pbi <- preClean hooks args flags
+ distPref <- findDistPrefOrDefault (cleanDistPref flags)
+ let flags' = flags { cleanDistPref = toFlag distPref }
- 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
+ pbi <- preClean hooks args flags'
- cleanHook hooks pkg_descr () hooks flags
- postClean hooks args flags pkg_descr ()
- where verbosity = fromFlag (cleanVerbosity 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
+copyAction hooks flags args = do
+ distPref <- findDistPrefOrDefault (copyDistPref flags)
+ let verbosity = fromFlag $ copyVerbosity flags
+ flags' = flags { copyDistPref = toFlag distPref }
+ 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
+installAction hooks flags args = do
+ distPref <- findDistPrefOrDefault (installDistPref flags)
+ let verbosity = fromFlag $ installVerbosity flags
+ flags' = flags { installDistPref = toFlag distPref }
+ 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)
+ distPref <- findDistPrefOrDefault (sDistDistPref flags)
+ let flags' = flags { sDistDistPref = toFlag distPref }
+ 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
+ distPref <- findDistPrefOrDefault (testDistPref flags)
+ let verbosity = fromFlag $ testVerbosity flags
+ flags' = flags { testDistPref = toFlag distPref }
+
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
+ hookedActionWithArgs 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
+ distPref <- findDistPrefOrDefault (benchmarkDistPref flags)
+ let verbosity = fromFlag $ benchmarkVerbosity flags
+ flags' = flags { benchmarkDistPref = toFlag distPref }
hookedActionWithArgs preBench benchHook postBench
(getBuildConfig hooks verbosity distPref)
- hooks flags args
+ 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
+registerAction hooks flags args = do
+ distPref <- findDistPrefOrDefault (regDistPref flags)
+ let verbosity = fromFlag $ regVerbosity flags
+ flags' = flags { regDistPref = toFlag distPref }
+ 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
+unregisterAction hooks flags args = do
+ distPref <- findDistPrefOrDefault (regDistPref flags)
+ let verbosity = fromFlag $ regVerbosity flags
+ flags' = flags { regDistPref = toFlag distPref }
+ hookedAction preUnreg unregHook postUnreg
+ (getBuildConfig hooks verbosity distPref)
+ hooks flags' args
hookedAction :: (UserHooks -> Args -> flags -> IO HookedBuildInfo)
-> (UserHooks -> PackageDescription -> LocalBuildInfo
@@ -482,7 +469,7 @@ getBuildConfig hooks verbosity distPref = do
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:
+ -- of a configure run:
configPrograms = restoreProgramConfiguration
(builtinPrograms ++ hookedPrograms hooks)
(configPrograms cFlags),
@@ -498,7 +485,7 @@ getBuildConfig hooks verbosity distPref = do
clean :: PackageDescription -> CleanFlags -> IO ()
clean pkg_descr flags = do
- let distPref = fromFlag $ cleanDistPref flags
+ let distPref = fromFlagOrDefault defaultDistPref $ cleanDistPref flags
notice verbosity "cleaning..."
maybeConfig <- if fromFlag (cleanSaveConf flags)
@@ -515,7 +502,7 @@ clean pkg_descr flags = do
mapM_ removeFileOrDirectory (extraTmpFiles pkg_descr)
-- If the user wanted to save the config, write it back
- maybe (return ()) (writePersistBuildConfig distPref) maybeConfig
+ traverse_ (writePersistBuildConfig distPref) maybeConfig
where
removeFileOrDirectory :: FilePath -> IO ()
@@ -539,7 +526,7 @@ simpleUserHooks =
buildHook = defaultBuildHook,
replHook = defaultReplHook,
copyHook = \desc lbi _ f -> install desc lbi f, -- has correct 'copy' behavior with params
- testHook = defaultTestHook,
+ testHook = defaultTestHook,
benchHook = defaultBenchHook,
instHook = defaultInstallHook,
sDistHook = \p l h f -> sdist p l f srcPref (allSuffixHandlers h),
@@ -600,7 +587,10 @@ autoconfUserHooks
= simpleUserHooks
{
postConf = defaultPostConf,
- preBuild = readHook buildVerbosity,
+ preBuild = \_ flags ->
+ -- not using 'readHook' here because 'build' takes
+ -- extra args
+ getHookedBuildInfo $ fromFlag $ buildVerbosity flags,
preClean = readHook cleanVerbosity,
preCopy = readHook copyVerbosity,
preInst = readHook installVerbosity,
@@ -682,10 +672,10 @@ getHookedBuildInfo verbosity = do
info verbosity $ "Reading parameters from " ++ infoFile
readHookedBuildInfo verbosity infoFile
-defaultTestHook :: PackageDescription -> LocalBuildInfo
+defaultTestHook :: Args -> PackageDescription -> LocalBuildInfo
-> UserHooks -> TestFlags -> IO ()
-defaultTestHook pkg_descr localbuildinfo _ flags =
- test pkg_descr localbuildinfo flags
+defaultTestHook args pkg_descr localbuildinfo _ flags =
+ test args pkg_descr localbuildinfo flags
defaultBenchHook :: Args -> PackageDescription -> LocalBuildInfo
-> UserHooks -> BenchmarkFlags -> IO ()
diff --git a/cabal/Cabal/Distribution/Simple/Bench.hs b/cabal/Cabal/Distribution/Simple/Bench.hs
index ad801ff..aceb238 100644
--- a/cabal/Cabal/Distribution/Simple/Bench.hs
+++ b/cabal/Cabal/Distribution/Simple/Bench.hs
@@ -2,6 +2,7 @@
-- |
-- Module : Distribution.Simple.Bench
-- Copyright : Johan Tibell 2011
+-- License : BSD3
--
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
@@ -10,36 +11,6 @@
-- 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
@@ -48,12 +19,12 @@ 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.Compiler ( compilerInfo )
import Distribution.Simple.InstallDirs
( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..)
, substPathTemplate , toPathTemplate, PathTemplate )
import qualified Distribution.Simple.LocalBuildInfo as LBI
- ( LocalBuildInfo(..) )
+ ( LocalBuildInfo(..), localLibraryName )
import Distribution.Simple.Setup ( BenchmarkFlags(..), fromFlag )
import Distribution.Simple.UserHooks ( Args )
import Distribution.Simple.Utils ( die, notice, rawSystemExitCode )
@@ -141,8 +112,8 @@ bench args pkg_descr lbi flags = do
ExitFailure _ -> "ERROR")
--- TODO: This is abusing the notion of a 'PathTemplate'. The result
--- isn't neccesarily a path.
+-- TODO: This is abusing the notion of a 'PathTemplate'. The result isn't
+-- necessarily a path.
benchOption :: PD.PackageDescription
-> LBI.LocalBuildInfo
-> PD.Benchmark
@@ -152,6 +123,6 @@ benchOption pkg_descr lbi bm template =
fromPathTemplate $ substPathTemplate env template
where
env = initialPathTemplateEnv
- (PD.package pkg_descr) (compilerId $ LBI.compiler lbi)
- (LBI.hostPlatform lbi) ++
+ (PD.package pkg_descr) (LBI.localLibraryName lbi)
+ (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++
[(BenchmarkNameVar, toPathTemplate $ PD.benchmarkName bm)]
diff --git a/cabal/Cabal/Distribution/Simple/Build.hs b/cabal/Cabal/Distribution/Simple/Build.hs
index 627848b..61d73b8 100644
--- a/cabal/Cabal/Distribution/Simple/Build.hs
+++ b/cabal/Cabal/Distribution/Simple/Build.hs
@@ -4,6 +4,7 @@
-- Copyright : Isaac Jones 2003-2005,
-- Ross Paterson 2006,
-- Duncan Coutts 2007-2008, 2012
+-- License : BSD3
--
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
@@ -14,37 +15,6 @@
-- 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, repl,
startInterpreter,
@@ -53,12 +23,11 @@ module Distribution.Simple.Build (
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.GHC as GHC
+import qualified Distribution.Simple.GHCJS as GHCJS
+import qualified Distribution.Simple.JHC as JHC
+import qualified Distribution.Simple.LHC as LHC
+import qualified Distribution.Simple.UHC as UHC
import qualified Distribution.Simple.HaskellSuite as HaskellSuite
import qualified Distribution.Simple.Build.Macros as Build.Macros
@@ -66,14 +35,15 @@ import qualified Distribution.Simple.Build.PathsModule as Build.PathsModule
import Distribution.Package
( Package(..), PackageName(..), PackageIdentifier(..)
- , Dependency(..), thisPackageVersion )
+ , Dependency(..), thisPackageVersion, PackageKey(..), packageName
+ , LibraryName(..) )
import Distribution.Simple.Compiler
( Compiler, CompilerFlavor(..), compilerFlavor
, PackageDB(..), PackageDBStack )
import Distribution.PackageDescription
( PackageDescription(..), BuildInfo(..), Library(..), Executable(..)
, TestSuite(..), TestSuiteInterface(..), Benchmark(..)
- , BenchmarkInterface(..) )
+ , BenchmarkInterface(..), allBuildInfo, defaultRenaming )
import qualified Distribution.InstalledPackageInfo as IPI
import qualified Distribution.ModuleName as ModuleName
import Distribution.ModuleName (ModuleName)
@@ -83,7 +53,7 @@ import Distribution.Simple.Setup
import Distribution.Simple.BuildTarget
( BuildTarget(..), readBuildTargets )
import Distribution.Simple.PreProcess
- ( preprocessComponent, PPSuffixHandler )
+ ( preprocessComponent, preprocessExtras, PPSuffixHandler )
import Distribution.Simple.LocalBuildInfo
( LocalBuildInfo(compiler, buildDir, withPackageDB, withPrograms)
, Component(..), componentName, getComponent, componentBuildInfo
@@ -91,14 +61,15 @@ import Distribution.Simple.LocalBuildInfo
, withComponentsInBuildOrder, componentsInBuildOrder
, ComponentName(..), showComponentName
, ComponentDisabledReason(..), componentDisabledReason
- , inplacePackageId, LibraryName(..) )
+ , inplacePackageId )
import Distribution.Simple.Program.Types
import Distribution.Simple.Program.Db
+import qualified Distribution.Simple.Program.HcPkg as HcPkg
import Distribution.Simple.BuildPaths
( autogenModulesDir, autogenModuleName, cppHeaderName, exeExtension )
import Distribution.Simple.Register
( registerPackage, inplaceInstalledPackageInfo )
-import Distribution.Simple.Test ( stubFilePath, stubName )
+import Distribution.Simple.Test.LibV09 ( stubFilePath, stubName )
import Distribution.Simple.Utils
( createDirectoryIfMissingVerbose, rewriteFile
, die, info, debug, warn, setupMessage )
@@ -108,8 +79,8 @@ import Distribution.Verbosity
import Distribution.Text
( display )
-import Data.Maybe
- ( maybeToList )
+import qualified Data.Map as Map
+import qualified Data.Set as Set
import Data.Either
( partitionEithers )
import Data.List
@@ -119,7 +90,8 @@ import Control.Monad
import System.FilePath
( (</>), (<.>) )
import System.Directory
- ( getCurrentDirectory )
+ ( getCurrentDirectory, removeDirectoryRecursive, removeFile
+ , doesDirectoryExist, doesFileExist )
-- -----------------------------------------------------------------------------
-- |Build the libraries and executables in this package.
@@ -144,7 +116,7 @@ build pkg_descr lbi flags suffixes = do
-- Only bother with this message if we're building the whole package
setupMessage verbosity "Building" (packageId pkg_descr)
- internalPackageDB <- createInternalPackageDB distPref
+ internalPackageDB <- createInternalPackageDB verbosity lbi distPref
withComponentsInBuildOrder pkg_descr lbi componentsToBuild $ \comp clbi ->
let bi = componentBuildInfo comp
@@ -181,7 +153,8 @@ repl pkg_descr lbi flags suffixes args = do
initialBuildSteps distPref pkg_descr lbi verbosity
- internalPackageDB <- createInternalPackageDB distPref
+ internalPackageDB <- createInternalPackageDB verbosity lbi distPref
+
let lbiForComponent comp lbi' =
lbi' {
withPackageDB = withPackageDB lbi ++ [internalPackageDB],
@@ -197,7 +170,7 @@ repl pkg_descr lbi flags suffixes args = do
pkg_descr lbi' suffixes comp clbi distPref
| (cname, clbi) <- init componentsToBuild ]
- -- repl for target components
+ -- REPL for target components
let (cname, clbi) = componentForRepl
comp = getComponent pkg_descr cname
lbi' = lbiForComponent comp lbi
@@ -208,8 +181,9 @@ repl pkg_descr lbi flags suffixes args = do
startInterpreter :: Verbosity -> ProgramDb -> Compiler -> PackageDBStack -> IO ()
startInterpreter verbosity programDb comp packageDBs =
case compilerFlavor comp of
- GHC -> GHC.startInterpreter verbosity programDb comp packageDBs
- _ -> die "A REPL is not supported with this compiler."
+ GHC -> GHC.startInterpreter verbosity programDb comp packageDBs
+ GHCJS -> GHCJS.startInterpreter verbosity programDb comp packageDBs
+ _ -> die "A REPL is not supported with this compiler."
buildComponent :: Verbosity
-> Flag (Maybe Int)
@@ -223,28 +197,32 @@ buildComponent :: Verbosity
buildComponent verbosity numJobs pkg_descr lbi suffixes
comp@(CLib lib) clbi distPref = do
preprocessComponent pkg_descr comp lbi False verbosity suffixes
+ extras <- preprocessExtras comp lbi
info verbosity "Building library..."
- buildLib verbosity numJobs pkg_descr lbi lib clbi
+ let libbi = libBuildInfo lib
+ lib' = lib { libBuildInfo = addExtraCSources libbi extras }
+ buildLib verbosity numJobs 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)
- }
+ let -- The in place registration uses the "-inplace" suffix, not an ABI hash
+ ipkgid = inplacePackageId (packageId installedPkgInfo)
+ installedPkgInfo = inplaceInstalledPackageInfo pwd distPref pkg_descr
+ ipkgid lib' lbi clbi
+
registerPackage verbosity
- installedPkgInfo pkg_descr lbi True -- True meaning inplace
+ installedPkgInfo pkg_descr lbi True -- True meaning in place
(withPackageDB lbi)
-
buildComponent verbosity numJobs pkg_descr lbi suffixes
comp@(CExe exe) clbi _ = do
preprocessComponent pkg_descr comp lbi False verbosity suffixes
+ extras <- preprocessExtras comp lbi
info verbosity $ "Building executable " ++ exeName exe ++ "..."
- buildExe verbosity numJobs pkg_descr lbi exe clbi
+ let ebi = buildInfo exe
+ exe' = exe { buildInfo = addExtraCSources ebi extras }
+ buildExe verbosity numJobs pkg_descr lbi exe' clbi
buildComponent verbosity numJobs pkg_descr lbi suffixes
@@ -252,11 +230,14 @@ buildComponent verbosity numJobs pkg_descr lbi suffixes
clbi _distPref = do
let exe = testSuiteExeV10AsExe test
preprocessComponent pkg_descr comp lbi False verbosity suffixes
+ extras <- preprocessExtras comp lbi
info verbosity $ "Building test suite " ++ testName test ++ "..."
- buildExe verbosity numJobs pkg_descr lbi exe clbi
+ let ebi = buildInfo exe
+ exe' = exe { buildInfo = addExtraCSources ebi extras }
+ buildExe verbosity numJobs pkg_descr lbi exe' clbi
-buildComponent verbosity numJobs pkg_descr lbi suffixes
+buildComponent verbosity numJobs pkg_descr lbi0 suffixes
comp@(CTest
test@TestSuite { testInterface = TestSuiteLibV09{} })
clbi -- This ComponentLocalBuildInfo corresponds to a detailed
@@ -266,13 +247,16 @@ buildComponent verbosity numJobs pkg_descr lbi suffixes
-- built.
distPref = do
pwd <- getCurrentDirectory
- let (pkg, lib, libClbi, ipi, exe, exeClbi) =
- testSuiteLibV09AsLibAndExe pkg_descr lbi test clbi distPref pwd
+ let (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) =
+ testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd
preprocessComponent pkg_descr comp lbi False verbosity suffixes
+ extras <- preprocessExtras comp lbi
info verbosity $ "Building test suite " ++ testName test ++ "..."
buildLib verbosity numJobs pkg lbi lib libClbi
registerPackage verbosity ipi pkg lbi True $ withPackageDB lbi
- buildExe verbosity numJobs pkg_descr lbi exe exeClbi
+ let ebi = buildInfo exe
+ exe' = exe { buildInfo = addExtraCSources ebi extras }
+ buildExe verbosity numJobs pkg_descr lbi exe' exeClbi
buildComponent _ _ _ _ _
@@ -286,8 +270,11 @@ buildComponent verbosity numJobs pkg_descr lbi suffixes
clbi _ = do
let (exe, exeClbi) = benchmarkExeV10asExe bm clbi
preprocessComponent pkg_descr comp lbi False verbosity suffixes
+ extras <- preprocessExtras comp lbi
info verbosity $ "Building benchmark " ++ benchmarkName bm ++ "..."
- buildExe verbosity numJobs pkg_descr lbi exe exeClbi
+ let ebi = buildInfo exe
+ exe' = exe { buildInfo = addExtraCSources ebi extras }
+ buildExe verbosity numJobs pkg_descr lbi exe' exeClbi
buildComponent _ _ _ _ _
@@ -296,6 +283,15 @@ buildComponent _ _ _ _ _
die $ "No support for building benchmark type " ++ display tt
+-- | Add extra C sources generated by preprocessing to build
+-- information.
+addExtraCSources :: BuildInfo -> [FilePath] -> BuildInfo
+addExtraCSources bi extras = bi { cSources = new }
+ where new = Set.toList $ old `Set.union` exs
+ old = Set.fromList $ cSources bi
+ exs = Set.fromList extras
+
+
replComponent :: Verbosity
-> PackageDescription
-> LocalBuildInfo
@@ -307,12 +303,18 @@ replComponent :: Verbosity
replComponent verbosity pkg_descr lbi suffixes
comp@(CLib lib) clbi _ = do
preprocessComponent pkg_descr comp lbi False verbosity suffixes
- replLib verbosity pkg_descr lbi lib clbi
+ extras <- preprocessExtras comp lbi
+ let libbi = libBuildInfo lib
+ lib' = lib { libBuildInfo = libbi { cSources = cSources libbi ++ extras } }
+ replLib verbosity pkg_descr lbi lib' clbi
replComponent verbosity pkg_descr lbi suffixes
comp@(CExe exe) clbi _ = do
preprocessComponent pkg_descr comp lbi False verbosity suffixes
- replExe verbosity pkg_descr lbi exe clbi
+ extras <- preprocessExtras comp lbi
+ let ebi = buildInfo exe
+ exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } }
+ replExe verbosity pkg_descr lbi exe' clbi
replComponent verbosity pkg_descr lbi suffixes
@@ -320,18 +322,24 @@ replComponent verbosity pkg_descr lbi suffixes
clbi _distPref = do
let exe = testSuiteExeV10AsExe test
preprocessComponent pkg_descr comp lbi False verbosity suffixes
- replExe verbosity pkg_descr lbi exe clbi
+ extras <- preprocessExtras comp lbi
+ let ebi = buildInfo exe
+ exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } }
+ replExe verbosity pkg_descr lbi exe' clbi
-replComponent verbosity pkg_descr lbi suffixes
+replComponent verbosity pkg_descr lbi0 suffixes
comp@(CTest
test@TestSuite { testInterface = TestSuiteLibV09{} })
clbi distPref = do
pwd <- getCurrentDirectory
- let (pkg, lib, libClbi, _, _, _) =
- testSuiteLibV09AsLibAndExe pkg_descr lbi test clbi distPref pwd
+ let (pkg, lib, libClbi, lbi, _, _, _) =
+ testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd
preprocessComponent pkg_descr comp lbi False verbosity suffixes
- replLib verbosity pkg lbi lib libClbi
+ extras <- preprocessExtras comp lbi
+ let libbi = libBuildInfo lib
+ lib' = lib { libBuildInfo = libbi { cSources = cSources libbi ++ extras } }
+ replLib verbosity pkg lbi lib' libClbi
replComponent _ _ _ _
@@ -345,7 +353,10 @@ replComponent verbosity pkg_descr lbi suffixes
clbi _ = do
let (exe, exeClbi) = benchmarkExeV10asExe bm clbi
preprocessComponent pkg_descr comp lbi False verbosity suffixes
- replExe verbosity pkg_descr lbi exe exeClbi
+ extras <- preprocessExtras comp lbi
+ let ebi = buildInfo exe
+ exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } }
+ replExe verbosity pkg_descr lbi exe' exeClbi
replComponent _ _ _ _
@@ -369,29 +380,36 @@ testSuiteExeV10AsExe TestSuite{} = error "testSuiteExeV10AsExe: wrong kind"
-- | Translate a lib-style 'TestSuite' component into a lib + exe for building
testSuiteLibV09AsLibAndExe :: PackageDescription
- -> LocalBuildInfo
-> TestSuite
-> ComponentLocalBuildInfo
+ -> LocalBuildInfo
-> FilePath
-> FilePath
-> (PackageDescription,
Library, ComponentLocalBuildInfo,
- IPI.InstalledPackageInfo_ ModuleName,
+ LocalBuildInfo,
+ IPI.InstalledPackageInfo,
Executable, ComponentLocalBuildInfo)
-testSuiteLibV09AsLibAndExe pkg_descr lbi
+testSuiteLibV09AsLibAndExe pkg_descr
test@TestSuite { testInterface = TestSuiteLibV09 _ m }
- clbi distPref pwd =
- (pkg, lib, libClbi, ipi, exe, exeClbi)
+ clbi lbi distPref pwd =
+ (pkg, lib, libClbi, lbi, ipi, exe, exeClbi)
where
bi = testBuildInfo test
lib = Library {
exposedModules = [ m ],
+ reexportedModules = [],
+ requiredSignatures = [],
+ exposedSignatures = [],
libExposed = True,
libBuildInfo = bi
}
libClbi = LibComponentLocalBuildInfo
{ componentPackageDeps = componentPackageDeps clbi
- , componentLibraries = [LibraryName (testName test)]
+ , componentPackageRenaming = componentPackageRenaming clbi
+ , componentLibraryName = LibraryName (testName test)
+ , componentExposedModules = [IPI.ExposedModule m Nothing Nothing]
+ , componentPackageKey = OldPackageKey (PackageIdentifier (PackageName (testName test)) (pkgVersion (package pkg_descr)))
}
pkg = pkg_descr {
package = (package pkg_descr) {
@@ -402,9 +420,8 @@ testSuiteLibV09AsLibAndExe pkg_descr lbi
, testSuites = []
, library = Just lib
}
- ipi = (inplaceInstalledPackageInfo pwd distPref pkg lib lbi libClbi) {
- IPI.installedPackageId = inplacePackageId $ packageId ipi
- }
+ ipkgid = inplacePackageId (packageId pkg)
+ ipi = inplaceInstalledPackageInfo pwd distPref pkg ipkgid lib lbi libClbi
testDir = buildDir lbi </> stubName test
</> stubName test ++ "-tmp"
testLibDep = thisPackageVersion $ package pkg
@@ -414,7 +431,10 @@ testSuiteLibV09AsLibAndExe pkg_descr lbi
buildInfo = (testBuildInfo test) {
hsSourceDirs = [ testDir ],
targetBuildDepends = testLibDep
- : (targetBuildDepends $ testBuildInfo test)
+ : (targetBuildDepends $ testBuildInfo test),
+ targetBuildRenaming =
+ Map.insert (packageName pkg) defaultRenaming
+ (targetBuildRenaming $ testBuildInfo test)
}
}
-- | The stub executable needs a new 'ComponentLocalBuildInfo'
@@ -424,9 +444,12 @@ testSuiteLibV09AsLibAndExe pkg_descr lbi
(IPI.installedPackageId ipi, packageId ipi)
: (filter (\(_, x) -> let PackageName name = pkgName x
in name == "Cabal" || name == "base")
- (componentPackageDeps clbi))
+ (componentPackageDeps clbi)),
+ componentPackageRenaming =
+ Map.insert (packageName ipi) defaultRenaming
+ (componentPackageRenaming clbi)
}
-testSuiteLibV09AsLibAndExe _ _ TestSuite{} _ _ _ = error "testSuiteLibV09AsLibAndExe: wrong kind"
+testSuiteLibV09AsLibAndExe _ TestSuite{} _ _ _ _ = error "testSuiteLibV09AsLibAndExe: wrong kind"
-- | Translate a exe-style 'Benchmark' component into an exe for building
@@ -442,18 +465,34 @@ benchmarkExeV10asExe bm@Benchmark { benchmarkInterface = BenchmarkExeV10 _ f }
buildInfo = benchmarkBuildInfo bm
}
exeClbi = ExeComponentLocalBuildInfo {
- componentPackageDeps = componentPackageDeps clbi
+ componentPackageDeps = componentPackageDeps clbi,
+ componentPackageRenaming = componentPackageRenaming clbi
}
benchmarkExeV10asExe Benchmark{} _ = error "benchmarkExeV10asExe: wrong kind"
-- | 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
+createInternalPackageDB :: Verbosity -> LocalBuildInfo -> FilePath
+ -> IO PackageDB
+createInternalPackageDB verbosity lbi distPref = do
+ case compilerFlavor (compiler lbi) of
+ GHC -> createWith $ GHC.hcPkgInfo (withPrograms lbi)
+ GHCJS -> createWith $ GHCJS.hcPkgInfo (withPrograms lbi)
+ LHC -> createWith $ LHC.hcPkgInfo (withPrograms lbi)
+ _ -> return packageDB
+ where
+ dbPath = distPref </> "package.conf.inplace"
+ packageDB = SpecificPackageDB dbPath
+ createWith hpi = do
+ dir_exists <- doesDirectoryExist dbPath
+ if dir_exists
+ then removeDirectoryRecursive dbPath
+ else do file_exists <- doesFileExist dbPath
+ when file_exists $ removeFile dbPath
+ if HcPkg.useSingleFileDb hpi
+ then writeFile dbPath "[]"
+ else HcPkg.init hpi verbosity dbPath
+ return packageDB
addInternalBuildTools :: PackageDescription -> LocalBuildInfo -> BuildInfo
-> ProgramDb -> ProgramDb
@@ -472,18 +511,17 @@ addInternalBuildTools pkg lbi bi progs =
-- TODO: build separate libs in separate dirs so that we can build
--- multiple libs, e.g. for 'LibTest' library-style testsuites
+-- multiple libs, e.g. for 'LibTest' library-style test suites
buildLib :: Verbosity -> Flag (Maybe Int)
-> PackageDescription -> LocalBuildInfo
-> Library -> ComponentLocalBuildInfo -> IO ()
buildLib verbosity numJobs pkg_descr lbi lib clbi =
case compilerFlavor (compiler lbi) of
- GHC -> GHC.buildLib verbosity numJobs 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
+ GHC -> GHC.buildLib verbosity numJobs pkg_descr lbi lib clbi
+ GHCJS -> GHCJS.buildLib verbosity numJobs pkg_descr lbi lib clbi
+ JHC -> JHC.buildLib verbosity pkg_descr lbi lib clbi
+ LHC -> LHC.buildLib verbosity pkg_descr lbi lib clbi
+ UHC -> UHC.buildLib verbosity pkg_descr lbi lib clbi
HaskellSuite {} -> HaskellSuite.buildLib verbosity pkg_descr lbi lib clbi
_ -> die "Building is not supported with this compiler."
@@ -492,14 +530,12 @@ buildExe :: Verbosity -> Flag (Maybe Int)
-> Executable -> ComponentLocalBuildInfo -> IO ()
buildExe verbosity numJobs pkg_descr lbi exe clbi =
case compilerFlavor (compiler lbi) of
- GHC -> GHC.buildExe verbosity numJobs 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."
-
+ GHC -> GHC.buildExe verbosity numJobs pkg_descr lbi exe clbi
+ GHCJS -> GHCJS.buildExe verbosity numJobs pkg_descr lbi exe clbi
+ JHC -> JHC.buildExe verbosity pkg_descr lbi exe clbi
+ LHC -> LHC.buildExe verbosity pkg_descr lbi exe clbi
+ UHC -> UHC.buildExe verbosity pkg_descr lbi exe clbi
+ _ -> die "Building is not supported with this compiler."
replLib :: Verbosity -> PackageDescription -> LocalBuildInfo
-> Library -> ComponentLocalBuildInfo -> IO ()
@@ -507,15 +543,17 @@ replLib verbosity pkg_descr lbi lib clbi =
case compilerFlavor (compiler lbi) of
-- 'cabal repl' doesn't need to support 'ghc --make -j', so we just pass
-- NoFlag as the numJobs parameter.
- GHC -> GHC.replLib verbosity NoFlag pkg_descr lbi lib clbi
- _ -> die "A REPL is not supported for this compiler."
+ GHC -> GHC.replLib verbosity NoFlag pkg_descr lbi lib clbi
+ GHCJS -> GHCJS.replLib verbosity NoFlag pkg_descr lbi lib clbi
+ _ -> die "A REPL is not supported for this compiler."
replExe :: Verbosity -> PackageDescription -> LocalBuildInfo
-> Executable -> ComponentLocalBuildInfo -> IO ()
replExe verbosity pkg_descr lbi exe clbi =
case compilerFlavor (compiler lbi) of
- GHC -> GHC.replExe verbosity NoFlag pkg_descr lbi exe clbi
- _ -> die "A REPL is not supported for this compiler."
+ GHC -> GHC.replExe verbosity NoFlag pkg_descr lbi exe clbi
+ GHCJS -> GHCJS.replExe verbosity NoFlag pkg_descr lbi exe clbi
+ _ -> die "A REPL is not supported for this compiler."
initialBuildSteps :: FilePath -- ^"dist" prefix
@@ -525,12 +563,10 @@ initialBuildSteps :: FilePath -- ^"dist" prefix
-> 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
+ unless (not . null $ allBuildInfo pkg_descr) $ do
let name = display (packageId pkg_descr)
- die ("Package " ++ name ++ " can't be built on this system.")
+ die $ "No libraries, executables, tests, or benchmarks "
+ ++ "are enabled for package " ++ name ++ "."
createDirectoryIfMissingVerbose verbosity True (buildDir lbi)
diff --git a/cabal/Cabal/Distribution/Simple/Build/Macros.hs b/cabal/Cabal/Distribution/Simple/Build/Macros.hs
index 5a801e5..f0429cd 100644
--- a/cabal/Cabal/Distribution/Simple/Build/Macros.hs
+++ b/cabal/Cabal/Distribution/Simple/Build/Macros.hs
@@ -30,8 +30,10 @@ import Distribution.Version
( Version(versionBranch) )
import Distribution.PackageDescription
( PackageDescription )
+import Distribution.Simple.Compiler
+ ( packageKeySupported )
import Distribution.Simple.LocalBuildInfo
- ( LocalBuildInfo(withPrograms), externalPackageDeps )
+ ( LocalBuildInfo(compiler, withPrograms), externalPackageDeps, localPackageKey )
import Distribution.Simple.Program.Db
( configuredPrograms )
import Distribution.Simple.Program.Types
@@ -49,7 +51,8 @@ generate :: PackageDescription -> LocalBuildInfo -> String
generate _pkg_descr lbi =
"/* DO NOT EDIT: This file is automatically generated by Cabal */\n\n" ++
generatePackageVersionMacros (map snd (externalPackageDeps lbi)) ++
- generateToolVersionMacros (configuredPrograms . withPrograms $ lbi)
+ generateToolVersionMacros (configuredPrograms . withPrograms $ lbi) ++
+ generatePackageKeyMacro lbi
-- | Helper function that generates just the @VERSION_pkg@ and @MIN_VERSION_pkg@
-- macros for a list of package ids (usually used with the specific deps of
@@ -93,6 +96,15 @@ generateMacros prefix name version =
where
(major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)
+-- | Generate the @CURRENT_PACKAGE_KEY@ definition for the package key
+-- of the current package, if supported by the compiler.
+-- NB: this only makes sense for definite packages.
+generatePackageKeyMacro :: LocalBuildInfo -> String
+generatePackageKeyMacro lbi
+ | packageKeySupported (compiler lbi) =
+ "#define CURRENT_PACKAGE_KEY \"" ++ display (localPackageKey lbi) ++ "\"\n\n"
+ | otherwise = ""
+
fixchar :: Char -> Char
fixchar '-' = '_'
fixchar c = c
diff --git a/cabal/Cabal/Distribution/Simple/Build/PathsModule.hs b/cabal/Cabal/Distribution/Simple/Build/PathsModule.hs
index af81396..20ed4f1 100644
--- a/cabal/Cabal/Distribution/Simple/Build/PathsModule.hs
+++ b/cabal/Cabal/Distribution/Simple/Build/PathsModule.hs
@@ -32,6 +32,8 @@ import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Setup ( CopyDest(NoCopyDest) )
import Distribution.Simple.BuildPaths
( autogenModuleName )
+import Distribution.Simple.Utils
+ ( shortRelativePath )
import Distribution.Text
( display )
import Distribution.Version
@@ -48,21 +50,33 @@ import Data.Maybe
generate :: PackageDescription -> LocalBuildInfo -> String
generate pkg_descr lbi =
- let pragmas
- | absolute || isHugs = ""
+ let pragmas = cpp_pragma ++ ffi_pragmas ++ warning_pragmas
+
+ cpp_pragma | supports_cpp = "{-# LANGUAGE CPP #-}"
+ | otherwise = ""
+
+ ffi_pragmas
+ | absolute = ""
| supports_language_pragma =
"{-# LANGUAGE ForeignFunctionInterface #-}\n"
| otherwise =
"{-# OPTIONS_GHC -fffi #-}\n"++
"{-# OPTIONS_JHC -fffi #-}\n"
+ warning_pragmas =
+ "{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}\n"
+
foreign_imports
| absolute = ""
- | isHugs = "import System.Environment\n"
| otherwise =
"import Foreign\n"++
"import Foreign.C\n"
+ reloc_imports
+ | reloc =
+ "import System.Environment (getExecutablePath)\n"
+ | otherwise = ""
+
header =
pragmas++
"module " ++ display paths_modulename ++ " (\n"++
@@ -75,15 +89,50 @@ generate pkg_descr lbi =
"import qualified Control.Exception as Exception\n"++
"import Data.Version (Version(..))\n"++
"import System.Environment (getEnv)\n"++
+ reloc_imports ++
"import Prelude\n"++
"\n"++
- "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"++
+ (if supports_cpp
+ then
+ ("#if defined(VERSION_base)\n"++
+ "\n"++
+ "#if MIN_VERSION_base(4,0,0)\n"++
+ "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"++
+ "#else\n"++
+ "catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a\n"++
+ "#endif\n"++
+ "\n"++
+ "#else\n"++
+ "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"++
+ "#endif\n")
+ else
+ "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n")++
"catchIO = Exception.catch\n" ++
"\n"++
- "\nversion :: Version"++
- "\nversion = " ++ show (packageVersion pkg_descr)
+ "version :: Version"++
+ "\nversion = Version " ++ show branch ++ " " ++ show tags
+ where Version branch tags = packageVersion pkg_descr
body
+ | reloc =
+ "\n\nbindirrel :: FilePath\n" ++
+ "bindirrel = " ++ show flat_bindirreloc ++
+ "\n"++
+ "\ngetBinDir, getLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath\n"++
+ "getBinDir = "++mkGetEnvOrReloc "bindir" flat_bindirreloc++"\n"++
+ "getLibDir = "++mkGetEnvOrReloc "libdir" flat_libdirreloc++"\n"++
+ "getDataDir = "++mkGetEnvOrReloc "datadir" flat_datadirreloc++"\n"++
+ "getLibexecDir = "++mkGetEnvOrReloc "libexecdir" flat_libexecdirreloc++"\n"++
+ "getSysconfDir = "++mkGetEnvOrReloc "sysconfdir" flat_sysconfdirreloc++"\n"++
+ "\n"++
+ "getDataFileName :: FilePath -> IO FilePath\n"++
+ "getDataFileName name = do\n"++
+ " dir <- getDataDir\n"++
+ " return (dir `joinFileName` name)\n"++
+ "\n"++
+ get_prefix_reloc_stuff++
+ "\n"++
+ filename_stuff
| absolute =
"\nbindir, libdir, datadir, libexecdir, sysconfdir :: FilePath\n"++
"\nbindir = " ++ show flat_bindir ++
@@ -143,13 +192,23 @@ generate pkg_descr lbi =
libdir = flat_libdirrel,
datadir = flat_datadirrel,
libexecdir = flat_libexecdirrel,
- sysconfdir = flat_sysconfdirrel,
- progdir = flat_progdirrel
+ sysconfdir = flat_sysconfdirrel
} = prefixRelativeInstallDirs (packageId pkg_descr) lbi
+ flat_bindirreloc = shortRelativePath flat_prefix flat_bindir
+ flat_libdirreloc = shortRelativePath flat_prefix flat_libdir
+ flat_datadirreloc = shortRelativePath flat_prefix flat_datadir
+ flat_libexecdirreloc = shortRelativePath flat_prefix flat_libexecdir
+ flat_sysconfdirreloc = shortRelativePath flat_prefix flat_sysconfdir
+
mkGetDir _ (Just dirrel) = "getPrefixDirRel " ++ show dirrel
mkGetDir dir Nothing = "return " ++ show dir
+ mkGetEnvOrReloc var dirrel = "catchIO (getEnv \""++var'++"\")" ++
+ " (\\_ -> getPrefixDirReloc \"" ++ dirrel ++
+ "\")"
+ where var' = pkgPathEnvVar pkg_descr var
+
mkGetEnvOr var expr = "catchIO (getEnv \""++var'++"\")"++
" (\\_ -> "++expr++")"
where var' = pkgPathEnvVar pkg_descr var
@@ -158,30 +217,31 @@ generate pkg_descr lbi =
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
+ reloc = relocatable lbi
+
supportsRelocatableProgs GHC = case buildOS of
Windows -> True
_ -> False
+ supportsRelocatableProgs GHCJS = 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
+ get_prefix_stuff = get_prefix_win32 buildArch
path_sep = show [pathSeparator]
+ supports_cpp = compilerFlavor (compiler lbi) == GHC
+
supports_language_pragma =
- compilerFlavor (compiler lbi) == GHC &&
+ (compilerFlavor (compiler lbi) == GHC &&
(compilerVersion (compiler lbi)
- `withinRange` orLaterVersion (Version [6,6,1] []))
+ `withinRange` orLaterVersion (Version [6,6,1] []))) ||
+ compilerFlavor (compiler lbi) == GHCJS
-- | Generates the name of the environment variable controlling the path
-- component of interest.
@@ -196,6 +256,14 @@ pkgPathEnvVar pkg_descr var =
fixchar '-' = '_'
fixchar c = c
+get_prefix_reloc_stuff :: String
+get_prefix_reloc_stuff =
+ "getPrefixDirReloc :: FilePath -> IO FilePath\n"++
+ "getPrefixDirReloc dirRel = do\n"++
+ " exePath <- getExecutablePath\n"++
+ " let (bindir,_) = splitFileName exePath\n"++
+ " return ((bindir `minusFileName` bindirrel) `joinFileName` dirRel)\n"
+
get_prefix_win32 :: Arch -> String
get_prefix_win32 arch =
"getPrefixDirRel :: FilePath -> IO FilePath\n"++
@@ -218,15 +286,6 @@ get_prefix_win32 arch =
X86_64 -> "ccall"
_ -> error "win32 supported only with I386, X86_64"
-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"++
diff --git a/cabal/Cabal/Distribution/Simple/BuildPaths.hs b/cabal/Cabal/Distribution/Simple/BuildPaths.hs
index d7b35ba..4ed5790 100644
--- a/cabal/Cabal/Distribution/Simple/BuildPaths.hs
+++ b/cabal/Cabal/Distribution/Simple/BuildPaths.hs
@@ -3,6 +3,7 @@
-- Module : Distribution.Simple.BuildPaths
-- Copyright : Isaac Jones 2003-2004,
-- Duncan Coutts 2008
+-- License : BSD3
--
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
@@ -10,36 +11,6 @@
-- A bunch of dirs, paths and file names used for intermediate build steps.
--
-{- 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.BuildPaths (
defaultDistPref, srcPref,
hscolourPref, haddockPref,
@@ -63,14 +34,14 @@ module Distribution.Simple.BuildPaths (
import System.FilePath ((</>), (<.>))
import Distribution.Package
- ( packageName )
+ ( packageName, LibraryName, getHSLibraryName )
import Distribution.ModuleName (ModuleName)
import qualified Distribution.ModuleName as ModuleName
import Distribution.Compiler
( CompilerId(..) )
import Distribution.PackageDescription (PackageDescription)
import Distribution.Simple.LocalBuildInfo
- ( LocalBuildInfo(buildDir), LibraryName(..) )
+ ( LocalBuildInfo(buildDir) )
import Distribution.Simple.Setup (defaultDistPref)
import Distribution.Text
( display )
@@ -111,17 +82,17 @@ haddockName pkg_descr = display (packageName pkg_descr) <.> "haddock"
-- Library file names
mkLibName :: LibraryName -> String
-mkLibName (LibraryName lib) = "lib" ++ lib <.> "a"
+mkLibName lib = "lib" ++ getHSLibraryName lib <.> "a"
mkProfLibName :: LibraryName -> String
-mkProfLibName (LibraryName lib) = "lib" ++ lib ++ "_p" <.> "a"
+mkProfLibName lib = "lib" ++ getHSLibraryName lib ++ "_p" <.> "a"
-- Implement proper name mangling for dynamical shared objects
-- libHS<packagename>-<compilerFlavour><compilerVersion>
-- e.g. libHSbase-2.1-ghc6.6.1.so
mkSharedLibName :: CompilerId -> LibraryName -> String
-mkSharedLibName (CompilerId compilerFlavor compilerVersion) (LibraryName lib)
- = "lib" ++ lib ++ "-" ++ comp <.> dllExtension
+mkSharedLibName (CompilerId compilerFlavor compilerVersion) lib
+ = "lib" ++ getHSLibraryName lib ++ "-" ++ comp <.> dllExtension
where comp = display compilerFlavor ++ display compilerVersion
-- ------------------------------------------------------------
@@ -136,9 +107,8 @@ exeExtension = case buildOS of
Windows -> "exe"
_ -> ""
--- ToDo: This should be determined via autoconf (AC_OBJEXT)
--- | Extension for object files. For GHC and NHC the extension is @\"o\"@.
--- Hugs uses either @\"o\"@ or @\"obj\"@ depending on the used C compiler.
+-- TODO: This should be determined via autoconf (AC_OBJEXT)
+-- | Extension for object files. For GHC the extension is @\"o\"@.
objExtension :: String
objExtension = "o"
diff --git a/cabal/Cabal/Distribution/Simple/BuildTarget.hs b/cabal/Cabal/Distribution/Simple/BuildTarget.hs
index b584288..821a1d2 100644
--- a/cabal/Cabal/Distribution/Simple/BuildTarget.hs
+++ b/cabal/Cabal/Distribution/Simple/BuildTarget.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.BuildTargets
@@ -55,7 +56,10 @@ import Data.Either
( partitionEithers )
import qualified Data.Map as Map
import Control.Monad
-import Control.Applicative (Applicative(..), Alternative(..))
+#if __GLASGOW_HASKELL__ < 710
+import Control.Applicative (Applicative(..))
+#endif
+import Control.Applicative (Alternative(..))
import qualified Distribution.Compat.ReadP as Parse
import Distribution.Compat.ReadP
( (+++), (<++) )
@@ -261,7 +265,7 @@ resolveBuildTarget :: PackageDescription -> UserBuildTarget -> Bool
resolveBuildTarget pkg userTarget fexists =
case findMatch (matchBuildTarget pkg userTarget fexists) of
Unambiguous target -> Right target
- Ambiguous targets -> Left (BuildTargetAmbigious userTarget targets')
+ Ambiguous targets -> Left (BuildTargetAmbiguous userTarget targets')
where targets' = disambiguateBuildTargets
(packageId pkg) userTarget
targets
@@ -283,7 +287,7 @@ data BuildTargetProblem
-- ^ [expected thing] (actually got)
| BuildTargetNoSuch UserBuildTarget [(String, String)]
-- ^ [(no such thing, actually got)]
- | BuildTargetAmbigious UserBuildTarget [(UserBuildTarget, BuildTarget)]
+ | BuildTargetAmbiguous UserBuildTarget [(UserBuildTarget, BuildTarget)]
deriving Show
@@ -362,7 +366,7 @@ reportBuildTargetProblems problems = do
mungeThing "file" = "file target"
mungeThing thing = thing
- case [ (t, ts) | BuildTargetAmbigious t ts <- problems ] of
+ case [ (t, ts) | BuildTargetAmbiguous t ts <- problems ] of
[] -> return ()
targets ->
die $ unlines
@@ -426,7 +430,8 @@ data ComponentInfo = ComponentInfo {
cinfoSrcDirs :: [FilePath],
cinfoModules :: [ModuleName],
cinfoHsFiles :: [FilePath], -- other hs files (like main.hs)
- cinfoCFiles :: [FilePath]
+ cinfoCFiles :: [FilePath],
+ cinfoJsFiles :: [FilePath]
}
type ComponentStringName = String
@@ -439,7 +444,8 @@ pkgComponentInfo pkg =
cinfoSrcDirs = hsSourceDirs bi,
cinfoModules = componentModules c,
cinfoHsFiles = componentHsFiles c,
- cinfoCFiles = cSources bi
+ cinfoCFiles = cSources bi,
+ cinfoJsFiles = jsSources bi
}
| c <- pkgComponents pkg
, let bi = componentBuildInfo c ]
@@ -658,12 +664,14 @@ matchComponentFile c str fexists =
, matchOtherFileRooted dirs hsFiles str ])
(msum [ matchModuleFileUnrooted ms str
, matchOtherFileUnrooted hsFiles str
- , matchOtherFileUnrooted cFiles str ]))
+ , matchOtherFileUnrooted cFiles str
+ , matchOtherFileUnrooted jsFiles str ]))
where
dirs = cinfoSrcDirs c
ms = cinfoModules c
hsFiles = cinfoHsFiles c
cFiles = cinfoCFiles c
+ jsFiles = cinfoJsFiles c
-- utils
@@ -726,10 +734,10 @@ matchDirectoryPrefix dirs filepath =
--
-- | A matcher embodies a way to match some input as being some recognised
--- value. In particular it deals with multiple and ambigious matches.
+-- value. In particular it deals with multiple and ambiguous matches.
--
-- There are various matcher primitives ('matchExactly', 'matchInexactly'),
--- ways to combine matchers ('ambigiousWith', 'shadows') and finally we can
+-- ways to combine matchers ('ambiguousWith', 'shadows') and finally we can
-- run a matcher against an input using 'findMatch'.
--
@@ -758,7 +766,7 @@ matchZero = NoMatch 0 []
-- | Combine two matchers. Exact matches are used over inexact matches
-- but if we have multiple exact, or inexact then the we collect all the
--- ambigious matches.
+-- ambiguous matches.
--
matchPlus :: Match a -> Match a -> Match a
matchPlus (ExactMatch d1 xs) (ExactMatch d2 xs') =
@@ -776,7 +784,7 @@ matchPlus a@(NoMatch d1 ms) b@(NoMatch d2 ms')
| d1 < d2 = b
| otherwise = NoMatch d1 (ms ++ ms')
--- | Combine two matchers. This is similar to 'ambigiousWith' with the
+-- | Combine two matchers. This is similar to 'ambiguousWith' with the
-- difference that an exact match from the left matcher shadows any exact
-- match on the right. Inexact matches are still collected however.
--
@@ -864,18 +872,18 @@ tryEach = exactMatches
-- possible matches. There may be 'None', a single 'Unambiguous' match or
-- you may have an 'Ambiguous' match with several possibilities.
--
-findMatch :: Eq b => Match b -> MaybeAmbigious b
+findMatch :: Eq b => Match b -> MaybeAmbiguous b
findMatch match =
case match of
NoMatch _ msgs -> None (nub msgs)
- ExactMatch _ xs -> checkAmbigious xs
- InexactMatch _ xs -> checkAmbigious xs
+ ExactMatch _ xs -> checkAmbiguous xs
+ InexactMatch _ xs -> checkAmbiguous xs
where
- checkAmbigious xs = case nub xs of
+ checkAmbiguous xs = case nub xs of
[x] -> Unambiguous x
xs' -> Ambiguous xs'
-data MaybeAmbigious a = None [MatchError] | Unambiguous a | Ambiguous [a]
+data MaybeAmbiguous a = None [MatchError] | Unambiguous a | Ambiguous [a]
deriving Show
diff --git a/cabal/Cabal/Distribution/Simple/CCompiler.hs b/cabal/Cabal/Distribution/Simple/CCompiler.hs
index 8294d9b..b33417a 100644
--- a/cabal/Cabal/Distribution/Simple/CCompiler.hs
+++ b/cabal/Cabal/Distribution/Simple/CCompiler.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Simple.CCompiler
@@ -46,8 +47,10 @@ module Distribution.Simple.CCompiler (
filenameCDialect
) where
+#if __GLASGOW_HASKELL__ < 710
import Data.Monoid
( Monoid(..) )
+#endif
import System.FilePath
( takeExtension )
@@ -59,7 +62,7 @@ data CDialect = C
| ObjectiveC
| CPlusPlus
| ObjectiveCPlusPlus
- deriving (Show)
+ deriving (Eq, Show)
instance Monoid CDialect where
mempty = C
diff --git a/cabal/Cabal/Distribution/Simple/Command.hs b/cabal/Cabal/Distribution/Simple/Command.hs
index bf81d7b..0ae2753 100644
--- a/cabal/Cabal/Distribution/Simple/Command.hs
+++ b/cabal/Cabal/Distribution/Simple/Command.hs
@@ -1,7 +1,9 @@
+{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Simple.Command
-- Copyright : Duncan Coutts 2007
+-- License : BSD3
--
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
@@ -14,36 +16,6 @@
-- command line completion flags. It is designed to allow other tools make
-- derived commands. This feature is used heavily in @cabal-install@.
-{- 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.Command (
-- * Command interface
@@ -51,10 +23,14 @@ module Distribution.Simple.Command (
commandShowOptions,
CommandParse(..),
commandParseArgs,
+ getNormalCommandDescriptions,
+ helpCommandUI,
-- ** Constructing commands
ShowOrParseArgs(..),
- makeCommand,
+ usageDefault,
+ usageAlternatives,
+ mkCommandUI,
hiddenCommand,
-- ** Associating actions with commands
@@ -88,14 +64,17 @@ import Control.Monad
import Data.Char (isAlpha, toLower)
import Data.List (sortBy)
import Data.Maybe
+#if __GLASGOW_HASKELL__ < 710
import Data.Monoid
+#endif
import qualified Distribution.GetOpt as GetOpt
import Distribution.Text
( Text(disp, parse) )
import Distribution.ParseUtils
import Distribution.ReadE
import Distribution.Simple.Utils (die, intercalate)
-import Text.PrettyPrint ( punctuate, cat, comma, text, empty)
+import Text.PrettyPrint ( punctuate, cat, comma, text )
+import Text.PrettyPrint as PP ( empty )
data CommandUI flags = CommandUI {
-- | The name of the command as it would be entered on the command line.
@@ -108,6 +87,8 @@ data CommandUI flags = CommandUI {
commandUsage :: String -> String,
-- | Additional explanation of the command to use in help texts.
commandDescription :: Maybe (String -> String),
+ -- | Post-Usage notes and examples in help texts
+ commandNotes :: Maybe (String -> String),
-- | Initial \/ empty flags
commandDefaultFlags :: flags,
-- | All the Option fields for this command
@@ -118,11 +99,11 @@ data ShowOrParseArgs = ShowArgs | ParseArgs
type Name = String
type Description = String
--- | We usually have a datatype for storing configuration values, where
+-- | We usually have a data type for storing configuration values, where
-- every field stores a configuration option, and the user sets
-- the value either via command line flags or a configuration file.
-- An individual OptionField models such a field, and we usually
--- build a list of options associated to a configuration datatype.
+-- build a list of options associated to a configuration data type.
data OptionField a = OptionField {
optionName :: Name,
optionDescr :: [OptDescr a] }
@@ -197,7 +178,7 @@ optArg' ad mkflag showflag =
optArg ad (succeedReadE (mkflag . Just)) def showflag
where def = mkflag Nothing
-noArg :: (Eq b, Monoid b) => b -> MkOptDescr (a -> b) (b -> a -> a) a
+noArg :: (Eq b) => b -> MkOptDescr (a -> b) (b -> a -> a) a
noArg flag sf lf d = choiceOpt [(flag, (sf,lf), d)] sf lf d
boolOpt :: (b -> Maybe Bool) -> (Bool -> b) -> SFlags -> SFlags
@@ -251,7 +232,11 @@ viewAsGetOpt (OptionField _n aa) = concatMap optDescrToGetOpt aa
set' (Just txt) = readEOrFail set txt
optDescrToGetOpt (ChoiceOpt alts) =
[GetOpt.Option sf lf (GetOpt.NoArg set) d | (d,(sf,lf),set,_) <- alts ]
- optDescrToGetOpt (BoolOpt d (sfT,lfT) (sfF, lfF) set _) =
+ optDescrToGetOpt (BoolOpt d (sfT, lfT) ([], []) set _) =
+ [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) d ]
+ optDescrToGetOpt (BoolOpt d ([], []) (sfF, lfF) set _) =
+ [ GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) d ]
+ optDescrToGetOpt (BoolOpt d (sfT,lfT) (sfF, lfF) set _) =
[ GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) ("Enable " ++ d)
, GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) ("Disable " ++ d) ]
@@ -283,15 +268,15 @@ viewAsFieldDescr (OptionField n dd) = FieldDescr n get set
(cat . punctuate comma . map text . ppr) t
OptArg _ _ _ _ _ ppr ->
- case ppr t of [] -> empty
+ case ppr t of [] -> PP.empty
(Nothing : _) -> text "True"
(Just a : _) -> text a
ChoiceOpt alts ->
- fromMaybe empty $ listToMaybe
+ fromMaybe PP.empty $ listToMaybe
[ text lf | (_,(_,lf:_), _,enabled) <- alts, enabled t]
- BoolOpt _ _ _ _ enabled -> (maybe empty disp . enabled) t
+ BoolOpt _ _ _ _ enabled -> (maybe PP.empty disp . enabled) t
-- set :: LineNo -> String -> a -> ParseResult a
set line val a =
@@ -358,12 +343,15 @@ commandShowOptions command v = concat
[ showOptDescr v od | o <- commandOptions command ParseArgs
, od <- optionDescr o]
where
+ maybePrefix [] = []
+ maybePrefix (lOpt:_) = ["--" ++ lOpt]
+
showOptDescr :: a -> OptDescr a -> [String]
- showOptDescr x (BoolOpt _ (_,lfT:_) (_,lfF:_) _ enabled)
+ showOptDescr x (BoolOpt _ (_,lfTs) (_,lfFs) _ enabled)
= case enabled x of
Nothing -> []
- Just True -> ["--" ++ lfT]
- Just False -> ["--" ++ lfF]
+ Just True -> maybePrefix lfTs
+ Just False -> maybePrefix lfFs
showOptDescr x c@ChoiceOpt{}
= ["--" ++ val | val <- getCurrentChoice c x]
showOptDescr x (ReqArg _ (_ssff,lf:_) _ _ showflag)
@@ -393,32 +381,55 @@ commandListOptions command =
-- | The help text for this command with descriptions of all the options.
commandHelp :: CommandUI flags -> String -> String
commandHelp command pname =
- commandUsage command pname
- ++ (GetOpt.usageInfo ""
- . addCommonFlags ShowArgs
- $ commandGetOpts ShowArgs command)
- ++ case commandDescription command of
- Nothing -> ""
- Just desc -> '\n': desc pname
+ commandSynopsis command
+ ++ "\n\n"
+ ++ commandUsage command pname
+ ++ ( case commandDescription command of
+ Nothing -> ""
+ Just desc -> '\n': desc pname)
+ ++ "\n"
+ ++ ( if cname == ""
+ then "Global flags:"
+ else "Flags for " ++ cname ++ ":" )
+ ++ ( GetOpt.usageInfo ""
+ . addCommonFlags ShowArgs
+ $ commandGetOpts ShowArgs command )
+ ++ ( case commandNotes command of
+ Nothing -> ""
+ Just notes -> '\n': notes pname)
+ where cname = commandName command
+
+-- | Default "usage" documentation text for commands.
+usageDefault :: String -> String -> String
+usageDefault name pname =
+ "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n\n"
+ ++ "Flags for " ++ name ++ ":"
+
+-- | Create "usage" documentation from a list of parameter
+-- configurations.
+usageAlternatives :: String -> [String] -> String -> String
+usageAlternatives name strs pname = unlines
+ [ start ++ pname ++ " " ++ name ++ " " ++ s
+ | let starts = "Usage: " : repeat " or: "
+ , (start, s) <- zip starts strs
+ ]
-- | Make a Command from standard 'GetOpt' options.
-makeCommand :: String -- ^ name
- -> String -- ^ short description
- -> Maybe (String -> String) -- ^ long description
- -> flags -- ^ initial\/empty flags
+mkCommandUI :: String -- ^ name
+ -> String -- ^ synopsis
+ -> [String] -- ^ usage alternatives
+ -> flags -- ^ initial\/empty flags
-> (ShowOrParseArgs -> [OptionField flags]) -- ^ options
-> CommandUI flags
-makeCommand name shortDesc longDesc defaultFlags options =
- CommandUI {
- commandName = name,
- commandSynopsis = shortDesc,
- commandDescription = longDesc,
- commandUsage = usage,
- commandDefaultFlags = defaultFlags,
- commandOptions = options
+mkCommandUI name synopsis usages flags options = CommandUI
+ { commandName = name
+ , commandSynopsis = synopsis
+ , commandDescription = Nothing
+ , commandNotes = Nothing
+ , commandUsage = usageAlternatives name usages
+ , commandDefaultFlags = flags
+ , commandOptions = options
}
- where usage pname = "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n\n"
- ++ "Flags for " ++ name ++ ":"
-- | Common flags that apply to every command
data CommonFlag = HelpFlag | ListOptionsFlag
@@ -472,9 +483,11 @@ commandParseArgs command global args =
where -- Note: It is crucial to use reverse function composition here or to
-- reverse the flags here as we want to process the flags left to right
- -- but data flow in function compsition is right to left.
+ -- but data flow in function composition is right to left.
accum flags = foldr (flip (.)) id [ f | Right f <- flags ]
- unrecognised opts = [ "unrecognized option `" ++ opt ++ "'\n"
+ unrecognised opts = [ "unrecognized "
+ ++ "'" ++ (commandName command) ++ "'"
+ ++ " option `" ++ opt ++ "'\n"
| opt <- opts ]
-- For unrecognised global flags we put them in the position just after
-- the command, if there is one. This gives us a chance to parse them
@@ -521,7 +534,7 @@ commandsRun :: CommandUI a
-> [String]
-> CommandParse (a, CommandParse action)
commandsRun globalCommand commands args =
- case commandParseArgs globalCommand' True args of
+ case commandParseArgs globalCommand True args of
CommandHelp help -> CommandHelp help
CommandList opts -> CommandList (opts ++ commandNames)
CommandErrors errs -> CommandErrors errs
@@ -542,25 +555,6 @@ commandsRun globalCommand commands args =
++ " (try --help)\n"]
commands' = commands ++ [commandAddAction helpCommandUI undefined]
commandNames = [ name | (Command name _ _ NormalCommand) <- commands' ]
- globalCommand' = globalCommand {
- commandUsage = \pname ->
- (case commandUsage globalCommand pname of
- "" -> ""
- original -> original ++ "\n")
- ++ "Usage: " ++ pname ++ " COMMAND [FLAGS]\n"
- ++ " or: " ++ pname ++ " [GLOBAL FLAGS]\n\n"
- ++ "Global flags:",
- commandDescription = Just $ \pname ->
- "Commands:\n"
- ++ unlines [ " " ++ align name ++ " " ++ description
- | Command name description _ NormalCommand <- commands' ]
- ++ case commandDescription globalCommand of
- Nothing -> ""
- Just desc -> '\n': desc pname
- }
- where maxlen = maximum
- [ length name | Command name _ _ NormalCommand <- commands' ]
- align str = str ++ replicate (maxlen - length str) ' '
-- A bit of a hack: support "prog help" as a synonym of "prog --help"
-- furthermore, support "prog help command" as "prog command --help"
@@ -579,14 +573,7 @@ commandsRun globalCommand commands args =
_ -> CommandHelp globalHelp
_ -> badCommand name
- where globalHelp = commandHelp globalCommand'
- helpCommandUI =
- (makeCommand "help" "Help about commands." Nothing () (const [])) {
- commandUsage = \pname ->
- "Usage: " ++ pname ++ " help [FLAGS]\n"
- ++ " or: " ++ pname ++ " help COMMAND [FLAGS]\n\n"
- ++ "Flags for help:"
- }
+ where globalHelp = commandHelp globalCommand
-- | Utility function, many commands do not accept additional flags. This
-- action fails with a helpful error message if the user supplies any extra.
@@ -597,3 +584,24 @@ noExtraFlags extraFlags =
die $ "Unrecognised flags: " ++ intercalate ", " extraFlags
--TODO: eliminate this function and turn it into a variant on commandAddAction
-- instead like commandAddActionNoArgs that doesn't supply the [String]
+
+-- | Helper function for creating globalCommand description
+getNormalCommandDescriptions :: [Command action] -> [(String, String)]
+getNormalCommandDescriptions cmds =
+ [ (name, description)
+ | Command name description _ NormalCommand <- cmds ]
+
+helpCommandUI :: CommandUI ()
+helpCommandUI =
+ (mkCommandUI
+ "help"
+ "Help about commands."
+ ["[FLAGS]", "COMMAND [FLAGS]"]
+ ()
+ (const []))
+ {
+ commandNotes = Just $ \pname ->
+ "Examples:\n"
+ ++ " " ++ pname ++ " help help\n"
+ ++ " Oh, appararently you already know this.\n"
+ }
diff --git a/cabal/Cabal/Distribution/Simple/Compiler.hs b/cabal/Cabal/Distribution/Simple/Compiler.hs
index d053da3..f217d73 100644
--- a/cabal/Cabal/Distribution/Simple/Compiler.hs
+++ b/cabal/Cabal/Distribution/Simple/Compiler.hs
@@ -1,7 +1,10 @@
+{-# LANGUAGE DeriveGeneric #-}
+
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Simple.Compiler
-- Copyright : Isaac Jones 2003-2004
+-- License : BSD3
--
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
@@ -17,41 +20,14 @@
-- per-user one and it lets you create arbitrary other package databases. We do
-- not yet fully support this latter feature.
-{- 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.Compiler (
-- * Haskell implementations
module Distribution.Compiler,
Compiler(..),
- showCompilerId, compilerFlavor, compilerVersion,
+ showCompilerId, showCompilerIdWithAbi,
+ compilerFlavor, compilerVersion,
+ compilerCompatVersion,
+ compilerInfo,
-- * Support for package databases
PackageDB(..),
@@ -64,29 +40,48 @@ module Distribution.Simple.Compiler (
OptimisationLevel(..),
flagToOptimisationLevel,
+ -- * Support for debug info levels
+ DebugInfoLevel(..),
+ flagToDebugInfoLevel,
+
-- * Support for language extensions
Flag,
languageToFlags,
unsupportedLanguages,
extensionsToFlags,
unsupportedExtensions,
- parmakeSupported
+ parmakeSupported,
+ reexportedModulesSupported,
+ renamingPackageFlagsSupported,
+ packageKeySupported,
+
+ -- * Support for profiling detail levels
+ ProfDetailLevel(..),
+ knownProfDetailLevels,
+ flagToProfDetailLevel,
) where
import Distribution.Compiler
import Distribution.Version (Version(..))
import Distribution.Text (display)
import Language.Haskell.Extension (Language(Haskell98), Extension)
+import Distribution.Simple.Utils (lowercase)
import Control.Monad (liftM)
+import Distribution.Compat.Binary (Binary)
import Data.List (nub)
import qualified Data.Map as M (Map, lookup)
-import Data.Maybe (catMaybes, isNothing)
+import Data.Maybe (catMaybes, isNothing, listToMaybe)
+import GHC.Generics (Generic)
import System.Directory (canonicalizePath)
data Compiler = Compiler {
compilerId :: CompilerId,
-- ^ Compiler flavour and version.
+ compilerAbiTag :: AbiTag,
+ -- ^ Tag for distinguishing incompatible ABI's on the same architecture/os.
+ compilerCompat :: [CompilerId],
+ -- ^ Other implementations that this compiler claims to be compatible with.
compilerLanguages :: [(Language, Flag)],
-- ^ Supported language standards.
compilerExtensions :: [(Extension, Flag)],
@@ -94,17 +89,39 @@ data Compiler = Compiler {
compilerProperties :: M.Map String String
-- ^ A key-value map for properties not covered by the above fields.
}
- deriving (Show, Read)
+ deriving (Generic, Show, Read)
+
+instance Binary Compiler
showCompilerId :: Compiler -> String
showCompilerId = display . compilerId
+showCompilerIdWithAbi :: Compiler -> String
+showCompilerIdWithAbi comp =
+ display (compilerId comp) ++
+ case compilerAbiTag comp of
+ NoAbiTag -> []
+ AbiTag xs -> '-':xs
+
compilerFlavor :: Compiler -> CompilerFlavor
compilerFlavor = (\(CompilerId f _) -> f) . compilerId
compilerVersion :: Compiler -> Version
compilerVersion = (\(CompilerId _ v) -> v) . compilerId
+compilerCompatVersion :: CompilerFlavor -> Compiler -> Maybe Version
+compilerCompatVersion flavor comp
+ | compilerFlavor comp == flavor = Just (compilerVersion comp)
+ | otherwise =
+ listToMaybe [ v | CompilerId fl v <- compilerCompat comp, fl == flavor ]
+
+compilerInfo :: Compiler -> CompilerInfo
+compilerInfo c = CompilerInfo (compilerId c)
+ (compilerAbiTag c)
+ (Just . compilerCompat $ c)
+ (Just . map fst . compilerLanguages $ c)
+ (Just . map fst . compilerExtensions $ c)
+
-- ------------------------------------------------------------
-- * Package databases
-- ------------------------------------------------------------
@@ -119,7 +136,9 @@ compilerVersion = (\(CompilerId _ v) -> v) . compilerId
data PackageDB = GlobalPackageDB
| UserPackageDB
| SpecificPackageDB FilePath
- deriving (Eq, Ord, Show, Read)
+ deriving (Eq, Generic, Ord, Show, Read)
+
+instance Binary PackageDB
-- | We typically get packages from several databases, and stack them
-- together. This type lets us be explicit about that stacking. For example
@@ -163,13 +182,15 @@ absolutePackageDBPath (SpecificPackageDB db) =
-- ------------------------------------------------------------
-- | Some compilers support optimising. Some have different levels.
--- For compliers that do not the level is just capped to the level
+-- For compilers that do not the level is just capped to the level
-- they do support.
--
data OptimisationLevel = NoOptimisation
| NormalOptimisation
| MaximumOptimisation
- deriving (Eq, Show, Read, Enum, Bounded)
+ deriving (Bounded, Enum, Eq, Generic, Read, Show)
+
+instance Binary OptimisationLevel
flagToOptimisationLevel :: Maybe String -> OptimisationLevel
flagToOptimisationLevel Nothing = NormalOptimisation
@@ -183,6 +204,33 @@ flagToOptimisationLevel (Just s) = case reads s of
_ -> error $ "Can't parse optimisation level " ++ s
-- ------------------------------------------------------------
+-- * Debug info levels
+-- ------------------------------------------------------------
+
+-- | Some compilers support emitting debug info. Some have different
+-- levels. For compilers that do not the level is just capped to the
+-- level they do support.
+--
+data DebugInfoLevel = NoDebugInfo
+ | MinimalDebugInfo
+ | NormalDebugInfo
+ | MaximalDebugInfo
+ deriving (Bounded, Enum, Eq, Generic, Read, Show)
+
+instance Binary DebugInfoLevel
+
+flagToDebugInfoLevel :: Maybe String -> DebugInfoLevel
+flagToDebugInfoLevel Nothing = NormalDebugInfo
+flagToDebugInfoLevel (Just s) = case reads s of
+ [(i, "")]
+ | i >= fromEnum (minBound :: DebugInfoLevel)
+ && i <= fromEnum (maxBound :: DebugInfoLevel)
+ -> toEnum i
+ | otherwise -> error $ "Bad debug info level: " ++ show i
+ ++ ". Valid values are 0..3"
+ _ -> error $ "Can't parse debug info level " ++ s
+
+-- ------------------------------------------------------------
-- * Languages and Extensions
-- ------------------------------------------------------------
@@ -218,9 +266,69 @@ extensionToFlag comp ext = lookup ext (compilerExtensions comp)
-- | Does this compiler support parallel --make mode?
parmakeSupported :: Compiler -> Bool
-parmakeSupported comp =
+parmakeSupported = ghcSupported "Support parallel --make"
+
+-- | Does this compiler support reexported-modules?
+reexportedModulesSupported :: Compiler -> Bool
+reexportedModulesSupported = ghcSupported "Support reexported-modules"
+
+-- | Does this compiler support thinning/renaming on package flags?
+renamingPackageFlagsSupported :: Compiler -> Bool
+renamingPackageFlagsSupported = ghcSupported "Support thinning and renaming package flags"
+
+-- | Does this compiler support package keys?
+packageKeySupported :: Compiler -> Bool
+packageKeySupported = ghcSupported "Uses package keys"
+
+-- | Utility function for GHC only features
+ghcSupported :: String -> Compiler -> Bool
+ghcSupported key comp =
case compilerFlavor comp of
- GHC -> case M.lookup "Support parallel --make" (compilerProperties comp) of
- Just "YES" -> True
- _ -> False
- _ -> False
+ GHC -> checkProp
+ GHCJS -> checkProp
+ _ -> False
+ where checkProp =
+ case M.lookup key (compilerProperties comp) of
+ Just "YES" -> True
+ _ -> False
+
+-- ------------------------------------------------------------
+-- * Profiling detail level
+-- ------------------------------------------------------------
+
+-- | Some compilers (notably GHC) support profiling and can instrument
+-- programs so the system can account costs to different functions. There are
+-- different levels of detail that can be used for this accounting.
+-- For compilers that do not support this notion or the particular detail
+-- levels, this is either ignored or just capped to some similar level
+-- they do support.
+--
+data ProfDetailLevel = ProfDetailNone
+ | ProfDetailDefault
+ | ProfDetailExportedFunctions
+ | ProfDetailToplevelFunctions
+ | ProfDetailAllFunctions
+ | ProfDetailOther String
+ deriving (Eq, Generic, Read, Show)
+
+instance Binary ProfDetailLevel
+
+flagToProfDetailLevel :: String -> ProfDetailLevel
+flagToProfDetailLevel "" = ProfDetailDefault
+flagToProfDetailLevel s =
+ case lookup (lowercase s)
+ [ (name, value)
+ | (primary, aliases, value) <- knownProfDetailLevels
+ , name <- primary : aliases ]
+ of Just value -> value
+ Nothing -> ProfDetailOther s
+
+knownProfDetailLevels :: [(String, [String], ProfDetailLevel)]
+knownProfDetailLevels =
+ [ ("default", [], ProfDetailDefault)
+ , ("none", [], ProfDetailNone)
+ , ("exported-functions", ["exported"], ProfDetailExportedFunctions)
+ , ("toplevel-functions", ["toplevel", "top"], ProfDetailToplevelFunctions)
+ , ("all-functions", ["all"], ProfDetailAllFunctions)
+ ]
+
diff --git a/cabal/Cabal/Distribution/Simple/Configure.hs b/cabal/Cabal/Distribution/Simple/Configure.hs
index f1024dd..644a019 100644
--- a/cabal/Cabal/Distribution/Simple/Configure.hs
+++ b/cabal/Cabal/Distribution/Simple/Configure.hs
@@ -1,7 +1,16 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+#if __GLASGOW_HASKELL__ >= 711
+{-# LANGUAGE PatternSynonyms #-}
+#endif
+
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Simple.Configure
-- Copyright : Isaac Jones 2003-2005
+-- License : BSD3
--
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
@@ -20,42 +29,14 @@
-- the user, the amount of information displayed depending on the verbosity
-- level.
-{- 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.Configure (configure,
writePersistBuildConfig,
+ getConfigStateFile,
getPersistBuildConfig,
checkPersistBuildConfigOutdated,
tryGetPersistBuildConfig,
maybeGetPersistBuildConfig,
+ findDistPref, findDistPrefOrDefault,
localBuildInfoFile,
getInstalledPackages, getPackageDBContents,
configCompiler, configCompilerAux,
@@ -63,9 +44,7 @@ module Distribution.Simple.Configure (configure,
ccLdOptionsBuildInfo,
checkForeignDeps,
interpretPackageDbFlags,
-
- ConfigStateFileErrorType(..),
- ConfigStateFileError,
+ ConfigStateFileError(..),
tryGetConfigStateFile,
platformDefines,
)
@@ -73,46 +52,51 @@ module Distribution.Simple.Configure (configure,
import Distribution.Compiler
( CompilerId(..) )
+import Distribution.Utils.NubList
import Distribution.Simple.Compiler
- ( CompilerFlavor(..), Compiler(compilerId), compilerFlavor, compilerVersion
+ ( CompilerFlavor(..), Compiler(..), compilerFlavor, compilerVersion
+ , compilerInfo, ProfDetailLevel(..), knownProfDetailLevels
, showCompilerId, unsupportedLanguages, unsupportedExtensions
- , PackageDB(..), PackageDBStack )
+ , PackageDB(..), PackageDBStack, reexportedModulesSupported
+ , packageKeySupported, renamingPackageFlagsSupported )
import Distribution.Simple.PreProcess ( platformDefines )
import Distribution.Package
( PackageName(PackageName), PackageIdentifier(..), PackageId
, packageName, packageVersion, Package(..)
, Dependency(Dependency), simplifyDependency
- , InstalledPackageId(..), thisPackageVersion )
-import Distribution.InstalledPackageInfo as Installed
- ( InstalledPackageInfo, InstalledPackageInfo_(..)
- , emptyInstalledPackageInfo )
+ , InstalledPackageId(..), thisPackageVersion
+ , mkPackageKey, packageKeyLibraryName )
+import qualified Distribution.InstalledPackageInfo as Installed
+import Distribution.InstalledPackageInfo (InstalledPackageInfo, emptyInstalledPackageInfo)
import qualified Distribution.Simple.PackageIndex as PackageIndex
-import Distribution.Simple.PackageIndex (PackageIndex)
+import Distribution.Simple.PackageIndex (InstalledPackageIndex)
import Distribution.PackageDescription as PD
( PackageDescription(..), specVersion, GenericPackageDescription(..)
, Library(..), hasLibs, Executable(..), BuildInfo(..), allExtensions
, HookedBuildInfo, updatePackageDescription, allBuildInfo
- , Flag(flagName), FlagName(..), TestSuite(..), Benchmark(..) )
+ , Flag(flagName), FlagName(..), TestSuite(..), Benchmark(..)
+ , ModuleReexport(..) , defaultRenaming )
+import Distribution.ModuleName
+ ( ModuleName )
import Distribution.PackageDescription.Configuration
( finalizePackageDescription, mapTreeData )
import Distribution.PackageDescription.Check
( PackageCheck(..), checkPackage, checkPackageFiles )
-import Distribution.Simple.Hpc ( enableCoverage )
import Distribution.Simple.Program
( Program(..), ProgramLocation(..), ConfiguredProgram(..)
, ProgramConfiguration, defaultProgramConfiguration
, ProgramSearchPathEntry(..), getProgramSearchPath, setProgramSearchPath
, configureAllKnownPrograms, knownPrograms, lookupKnownProgram
, userSpecifyArgss, userSpecifyPaths
- , requireProgram, requireProgramVersion
+ , lookupProgram, requireProgram, requireProgramVersion
, pkgConfigProgram, gccProgram, rawSystemProgramStdoutConf )
-import Distribution.Simple.Setup
- ( ConfigFlags(..), CopyDest(..), fromFlag, fromFlagOrDefault, flagToMaybe )
+import Distribution.Simple.Setup as Setup
+ ( ConfigFlags(..), CopyDest(..), Flag(..), defaultDistPref
+ , fromFlag, fromFlagOrDefault, flagToMaybe, toFlag )
import Distribution.Simple.InstallDirs
( InstallDirs(..), defaultInstallDirs, combineInstallDirs )
import Distribution.Simple.LocalBuildInfo
( LocalBuildInfo(..), Component(..), ComponentLocalBuildInfo(..)
- , LibraryName(..)
, absoluteInstallDirs, prefixRelativeInstallDirs, inplacePackageId
, ComponentName(..), showComponentName, pkgEnabledComponents
, componentBuildInfo, componentName, checkComponentsCyclic )
@@ -122,33 +106,53 @@ import Distribution.Simple.Utils
( die, warn, info, setupMessage
, createDirectoryIfMissingVerbose, moreRecentFile
, intercalate, cabalVersion
- , withFileContents, writeFileAtomic
+ , writeFileAtomic
, withTempFile )
import Distribution.System
- ( OS(..), buildOS, Platform, buildPlatform )
+ ( OS(..), buildOS, Platform (..), buildPlatform )
import Distribution.Version
( Version(..), anyVersion, orLaterVersion, withinRange, isAnyVersion )
import Distribution.Verbosity
( Verbosity, lessVerbose )
-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.GHC as GHC
+import qualified Distribution.Simple.GHCJS as GHCJS
+import qualified Distribution.Simple.JHC as JHC
+import qualified Distribution.Simple.LHC as LHC
+import qualified Distribution.Simple.UHC as UHC
import qualified Distribution.Simple.HaskellSuite as HaskellSuite
+-- Prefer the more generic Data.Traversable.mapM to Prelude.mapM
+import Prelude hiding ( mapM )
+import Control.Exception
+ ( Exception, evaluate, throw, throwIO, try )
+#if __GLASGOW_HASKELL__ >= 711
+import Control.Exception ( pattern ErrorCall )
+#else
+import Control.Exception ( ErrorCall(..) )
+#endif
import Control.Monad
- ( when, unless, foldM, filterM )
+ ( liftM, when, unless, foldM, filterM )
+import Distribution.Compat.Binary ( decodeOrFailIO, encode )
+import Data.ByteString.Lazy (ByteString)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy.Char8 as BLC8
import Data.List
- ( (\\), nub, partition, isPrefixOf, inits )
+ ( (\\), nub, partition, isPrefixOf, inits, stripPrefix )
import Data.Maybe
- ( isNothing, catMaybes, fromMaybe )
+ ( isNothing, catMaybes, fromMaybe, isJust )
+import Data.Either
+ ( partitionEithers )
+import qualified Data.Set as Set
+#if __GLASGOW_HASKELL__ < 710
import Data.Monoid
( Monoid(..) )
+#endif
import qualified Data.Map as Map
import Data.Map (Map)
+import Data.Traversable
+ ( mapM )
+import Data.Typeable
import System.Directory
( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory )
import System.FilePath
@@ -162,128 +166,185 @@ import Distribution.Text
import Text.PrettyPrint
( render, (<>), ($+$), char, text, comma
, quotes, punctuate, nest, sep, hsep )
+import Distribution.Compat.Environment ( lookupEnv )
import Distribution.Compat.Exception ( catchExit, catchIO )
-import qualified Data.ByteString.Lazy.Char8 as BS.Char8
-
-data ConfigStateFileErrorType = ConfigStateFileCantParse
- | ConfigStateFileMissing
- | ConfigStateFileBadVersion
- deriving Eq
-type ConfigStateFileError = (String, ConfigStateFileErrorType)
-
-tryGetConfigStateFile :: (Read a) => FilePath
- -> IO (Either ConfigStateFileError a)
-tryGetConfigStateFile filename = do
- exists <- doesFileExist filename
- if not exists
- then return (Left (missing, ConfigStateFileMissing))
- else withFileContents filename $ \str ->
- case lines str of
- [header, rest] -> case checkHeader header of
- Just err -> return (Left err)
- Nothing -> case reads rest of
- [(bi,_)] -> return (Right bi)
- _ -> return (Left (cantParse, ConfigStateFileCantParse))
- _ -> return (Left (cantParse, ConfigStateFileCantParse))
- where
- checkHeader :: String -> Maybe ConfigStateFileError
- checkHeader header = case parseHeader header of
- Just (cabalId, compId)
- | cabalId
- == currentCabalId -> Nothing
- | otherwise -> Just (badVersion cabalId compId
- ,ConfigStateFileBadVersion)
- Nothing -> Just (cantParse
- ,ConfigStateFileCantParse)
-
- missing = "Run the 'configure' command first."
- cantParse = "Saved package config file seems to be corrupt. "
- ++ "Try re-running the 'configure' command."
- badVersion cabalId compId
- = "You need to re-run the 'configure' command. "
- ++ "The version of Cabal being used has changed (was "
- ++ display cabalId ++ ", now "
- ++ display currentCabalId ++ ")."
- ++ badcompiler compId
- badcompiler compId | compId == currentCompilerId = ""
- | otherwise
- = " Additionally the compiler is different (was "
- ++ display compId ++ ", now "
- ++ display currentCompilerId
- ++ ") which is probably the cause of the problem."
-
--- |Try to read the 'localBuildInfoFile'.
-tryGetPersistBuildConfig :: FilePath
- -> IO (Either ConfigStateFileError LocalBuildInfo)
-tryGetPersistBuildConfig distPref
- = tryGetConfigStateFile (localBuildInfoFile distPref)
-
--- |Read the 'localBuildInfoFile'. Error if it doesn't exist. Also
--- fail if the file containing LocalBuildInfo is older than the .cabal
--- file, indicating that a re-configure is required.
-getPersistBuildConfig :: FilePath -> IO LocalBuildInfo
-getPersistBuildConfig distPref = do
- lbi <- tryGetPersistBuildConfig distPref
- either (die . fst) return lbi
-
--- |Try to read the 'localBuildInfoFile'.
-maybeGetPersistBuildConfig :: FilePath -> IO (Maybe LocalBuildInfo)
-maybeGetPersistBuildConfig distPref = do
- lbi <- tryGetPersistBuildConfig distPref
- return $ either (const Nothing) Just lbi
-
--- |After running configure, output the 'LocalBuildInfo' to the
+-- | The errors that can be thrown when reading the @setup-config@ file.
+data ConfigStateFileError
+ = ConfigStateFileNoHeader -- ^ No header found.
+ | ConfigStateFileBadHeader -- ^ Incorrect header.
+ | ConfigStateFileNoParse -- ^ Cannot parse file contents.
+ | ConfigStateFileMissing -- ^ No file!
+ | ConfigStateFileBadVersion PackageIdentifier PackageIdentifier (Either ConfigStateFileError LocalBuildInfo) -- ^ Mismatched version.
+ deriving (Typeable)
+
+instance Show ConfigStateFileError where
+ show ConfigStateFileNoHeader =
+ "Saved package config file header is missing. "
+ ++ "Try re-running the 'configure' command."
+ show ConfigStateFileBadHeader =
+ "Saved package config file header is corrupt. "
+ ++ "Try re-running the 'configure' command."
+ show ConfigStateFileNoParse =
+ "Saved package config file body is corrupt. "
+ ++ "Try re-running the 'configure' command."
+ show ConfigStateFileMissing = "Run the 'configure' command first."
+ show (ConfigStateFileBadVersion oldCabal oldCompiler _) =
+ "You need to re-run the 'configure' command. "
+ ++ "The version of Cabal being used has changed (was "
+ ++ display oldCabal ++ ", now "
+ ++ display currentCabalId ++ ")."
+ ++ badCompiler
+ where
+ badCompiler
+ | oldCompiler == currentCompilerId = ""
+ | otherwise =
+ " Additionally the compiler is different (was "
+ ++ display oldCompiler ++ ", now "
+ ++ display currentCompilerId
+ ++ ") which is probably the cause of the problem."
+
+instance Exception ConfigStateFileError
+
+-- | Read the 'localBuildInfoFile'. Throw an exception if the file is
+-- missing, if the file cannot be read, or if the file was created by an older
+-- version of Cabal.
+getConfigStateFile :: FilePath -- ^ The file path of the @setup-config@ file.
+ -> IO LocalBuildInfo
+getConfigStateFile filename = do
+ exists <- doesFileExist filename
+ unless exists $ throwIO ConfigStateFileMissing
+ -- Read the config file into a strict ByteString to avoid problems with
+ -- lazy I/O, then convert to lazy because the binary package needs that.
+ contents <- BS.readFile filename
+ let (header, body) = BLC8.span (/='\n') (BLC8.fromChunks [contents])
+
+ headerParseResult <- try $ evaluate $ parseHeader header
+ let (cabalId, compId) =
+ case headerParseResult of
+ Left (ErrorCall _) -> throw ConfigStateFileBadHeader
+ Right x -> x
+
+ let getStoredValue = do
+ result <- decodeOrFailIO (BLC8.tail body)
+ case result of
+ Left _ -> throw ConfigStateFileNoParse
+ Right x -> return x
+ deferErrorIfBadVersion act
+ | cabalId /= currentCabalId = do
+ eResult <- try act
+ throw $ ConfigStateFileBadVersion cabalId compId eResult
+ | otherwise = act
+ deferErrorIfBadVersion getStoredValue
+
+-- | Read the 'localBuildInfoFile', returning either an error or the local build info.
+tryGetConfigStateFile :: FilePath -- ^ The file path of the @setup-config@ file.
+ -> IO (Either ConfigStateFileError LocalBuildInfo)
+tryGetConfigStateFile = try . getConfigStateFile
+
+-- | Try to read the 'localBuildInfoFile'.
+tryGetPersistBuildConfig :: FilePath -- ^ The @dist@ directory path.
+ -> IO (Either ConfigStateFileError LocalBuildInfo)
+tryGetPersistBuildConfig = try . getPersistBuildConfig
+
+-- | Read the 'localBuildInfoFile'. Throw an exception if the file is
+-- missing, if the file cannot be read, or if the file was created by an older
+-- version of Cabal.
+getPersistBuildConfig :: FilePath -- ^ The @dist@ directory path.
+ -> IO LocalBuildInfo
+getPersistBuildConfig = getConfigStateFile . localBuildInfoFile
+
+-- | Try to read the 'localBuildInfoFile'.
+maybeGetPersistBuildConfig :: FilePath -- ^ The @dist@ directory path.
+ -> IO (Maybe LocalBuildInfo)
+maybeGetPersistBuildConfig =
+ liftM (either (const Nothing) Just) . tryGetPersistBuildConfig
+
+-- | After running configure, output the 'LocalBuildInfo' to the
-- 'localBuildInfoFile'.
-writePersistBuildConfig :: FilePath -> LocalBuildInfo -> IO ()
+writePersistBuildConfig :: FilePath -- ^ The @dist@ directory path.
+ -> LocalBuildInfo -- ^ The 'LocalBuildInfo' to write.
+ -> IO ()
writePersistBuildConfig distPref lbi = do
- createDirectoryIfMissing False distPref
- writeFileAtomic (localBuildInfoFile distPref)
- (BS.Char8.pack $ showHeader pkgid ++ '\n' : show lbi)
- where
- pkgid = packageId (localPkgDescr lbi)
-
-showHeader :: PackageIdentifier -> String
-showHeader pkgid =
- "Saved package config for " ++ display pkgid
- ++ " written by " ++ display currentCabalId
- ++ " using " ++ display currentCompilerId
+ createDirectoryIfMissing False distPref
+ writeFileAtomic (localBuildInfoFile distPref) $
+ BLC8.unlines [showHeader pkgId, encode lbi]
where
+ pkgId = packageId $ localPkgDescr lbi
+-- | Identifier of the current Cabal package.
currentCabalId :: PackageIdentifier
currentCabalId = PackageIdentifier (PackageName "Cabal") cabalVersion
+-- | Identifier of the current compiler package.
currentCompilerId :: PackageIdentifier
currentCompilerId = PackageIdentifier (PackageName System.Info.compilerName)
System.Info.compilerVersion
-parseHeader :: String -> Maybe (PackageIdentifier, PackageIdentifier)
-parseHeader header = case words header of
- ["Saved", "package", "config", "for", pkgid,
- "written", "by", cabalid, "using", compilerid]
- -> case (simpleParse pkgid :: Maybe PackageIdentifier,
- simpleParse cabalid,
- simpleParse compilerid) of
- (Just _,
- Just cabalid',
- Just compilerid') -> Just (cabalid', compilerid')
- _ -> Nothing
- _ -> Nothing
-
--- |Check that localBuildInfoFile is up-to-date with respect to the
+-- | Parse the @setup-config@ file header, returning the package identifiers
+-- for Cabal and the compiler.
+parseHeader :: ByteString -- ^ The file contents.
+ -> (PackageIdentifier, PackageIdentifier)
+parseHeader header = case BLC8.words header of
+ ["Saved", "package", "config", "for", pkgId, "written", "by", cabalId, "using", compId] ->
+ fromMaybe (throw ConfigStateFileBadHeader) $ do
+ _ <- simpleParse (BLC8.unpack pkgId) :: Maybe PackageIdentifier
+ cabalId' <- simpleParse (BLC8.unpack cabalId)
+ compId' <- simpleParse (BLC8.unpack compId)
+ return (cabalId', compId')
+ _ -> throw ConfigStateFileNoHeader
+
+-- | Generate the @setup-config@ file header.
+showHeader :: PackageIdentifier -- ^ The processed package.
+ -> ByteString
+showHeader pkgId = BLC8.unwords
+ [ "Saved", "package", "config", "for"
+ , BLC8.pack $ display pkgId
+ , "written", "by"
+ , BLC8.pack $ display currentCabalId
+ , "using"
+ , BLC8.pack $ display currentCompilerId
+ ]
+
+-- | Check that localBuildInfoFile is up-to-date with respect to the
-- .cabal file.
checkPersistBuildConfigOutdated :: FilePath -> FilePath -> IO Bool
checkPersistBuildConfigOutdated distPref pkg_descr_file = do
pkg_descr_file `moreRecentFile` (localBuildInfoFile distPref)
--- |@dist\/setup-config@
-localBuildInfoFile :: FilePath -> FilePath
+-- | Get the path of @dist\/setup-config@.
+localBuildInfoFile :: FilePath -- ^ The @dist@ directory path.
+ -> FilePath
localBuildInfoFile distPref = distPref </> "setup-config"
-- -----------------------------------------------------------------------------
-- * Configuration
-- -----------------------------------------------------------------------------
+-- | Return the \"dist/\" prefix, or the default prefix. The prefix is taken from
+-- (in order of highest to lowest preference) the override prefix, the \"CABAL_BUILDDIR\"
+-- environment variable, or the default prefix.
+findDistPref :: FilePath -- ^ default \"dist\" prefix
+ -> Setup.Flag FilePath -- ^ override \"dist\" prefix
+ -> IO FilePath
+findDistPref defDistPref overrideDistPref = do
+ envDistPref <- liftM parseEnvDistPref (lookupEnv "CABAL_BUILDDIR")
+ return $ fromFlagOrDefault defDistPref (mappend envDistPref overrideDistPref)
+ where
+ parseEnvDistPref env =
+ case env of
+ Just distPref | not (null distPref) -> toFlag distPref
+ _ -> NoFlag
+
+-- | Return the \"dist/\" prefix, or the default prefix. The prefix is taken from
+-- (in order of highest to lowest preference) the override prefix, the \"CABAL_BUILDDIR\"
+-- environment variable, or 'defaultDistPref' is used. Call this function to resolve a
+-- @*DistPref@ flag whenever it is not known to be set. (The @*DistPref@ flags are always
+-- set to a definite value before invoking 'UserHooks'.)
+findDistPrefOrDefault :: Setup.Flag FilePath -- ^ override \"dist\" prefix
+ -> IO FilePath
+findDistPrefOrDefault = findDistPref defaultDistPref
+
-- |Perform the \"@.\/setup configure@\" action.
-- Returns the @.setup-config@ file.
configure :: (GenericPackageDescription, HookedBuildInfo)
@@ -291,10 +352,23 @@ configure :: (GenericPackageDescription, HookedBuildInfo)
configure (pkg_descr0, pbi) cfg
= do let distPref = fromFlag (configDistPref cfg)
buildDir' = distPref </> "build"
- verbosity = fromFlag (configVerbosity cfg)
setupMessage verbosity "Configuring" (packageId pkg_descr0)
+ unless (configProfExe cfg == NoFlag) $ do
+ let enable | fromFlag (configProfExe cfg) = "enable"
+ | otherwise = "disable"
+ warn verbosity
+ ("The flag --" ++ enable ++ "-executable-profiling is deprecated. "
+ ++ "Please use --" ++ enable ++ "-profiling instead.")
+
+ unless (configLibCoverage cfg == NoFlag) $ do
+ let enable | fromFlag (configLibCoverage cfg) = "enable"
+ | otherwise = "disable"
+ warn verbosity
+ ("The flag --" ++ enable ++ "-library-coverage is deprecated. "
+ ++ "Please use --" ++ enable ++ "-coverage instead.")
+
createDirectoryIfMissingVerbose (lessVerbose verbosity) True distPref
let programsConfig = mkProgramsConfig cfg (configPrograms cfg)
@@ -383,7 +457,7 @@ configure (pkg_descr0, pbi) cfg
(configConfigurationsFlags cfg)
dependencySatisfiable
compPlatform
- (compilerId comp)
+ (compilerInfo comp)
allConstraints
pkg_descr0''
of Right r -> return r
@@ -406,18 +480,32 @@ configure (pkg_descr0, pbi) cfg
-- add extra include/lib dirs as specified in cfg
-- we do it here so that those get checked too
- let pkg_descr =
- enableCoverage (fromFlag (configLibCoverage cfg)) distPref
- $ addExtraIncludeLibDirs pkg_descr0'
+ let pkg_descr = addExtraIncludeLibDirs pkg_descr0'
+
+ unless (renamingPackageFlagsSupported comp ||
+ and [ rn == defaultRenaming
+ | bi <- allBuildInfo pkg_descr
+ , rn <- Map.elems (targetBuildRenaming bi)]) $
+ die $ "Your compiler does not support thinning and renaming on "
+ ++ "package flags. To use this feature you probably must use "
+ ++ "GHC 7.9 or later."
when (not (null flags)) $
info verbosity $ "Flags chosen: "
++ intercalate ", " [ name ++ "=" ++ display value
| (FlagName name, value) <- flags ]
+ when (maybe False (not.null.PD.reexportedModules) (PD.library pkg_descr)
+ && not (reexportedModulesSupported comp)) $ do
+ die $ "Your compiler does not support module re-exports. To use "
+ ++ "this feature you probably must use GHC 7.9 or later."
+
checkPackageProblems verbosity pkg_descr0
(updatePackageDescription pbi pkg_descr)
+ -- Handle hole instantiation
+ (holeDeps, hole_insts) <- configureInstantiateWith pkg_descr cfg installedPackageSet
+
let selectDependencies :: [Dependency] ->
([FailedDependency], [ResolvedDependency])
selectDependencies =
@@ -444,9 +532,14 @@ configure (pkg_descr0, pbi) cfg
reportFailedDependencies failedDeps
reportSelectedDependencies verbosity allPkgDeps
+ let installDeps = Map.elems
+ . Map.fromList
+ . map (\v -> (Installed.installedPackageId v, v))
+ $ externalPkgDeps ++ holeDeps
+
packageDependsIndex <-
case PackageIndex.dependencyClosure installedPackageSet
- (map Installed.installedPackageId externalPkgDeps) of
+ (map Installed.installedPackageId installDeps) of
Left packageDependsIndex -> return packageDependsIndex
Right broken ->
die $ "The following installed packages are broken because other"
@@ -463,7 +556,7 @@ configure (pkg_descr0, pbi) cfg
InstalledPackageId (display (packageId pkg_descr)),
Installed.sourcePackageId = packageId pkg_descr,
Installed.depends =
- map Installed.installedPackageId externalPkgDeps
+ map Installed.installedPackageId installDeps
}
case PackageIndex.dependencyInconsistencies
. PackageIndex.insert pseudoTopPkg
@@ -478,13 +571,6 @@ configure (pkg_descr0, pbi) cfg
| (name, uses) <- inconsistencies
, (pkg, ver) <- uses ]
- -- internal component graph
- buildComponents <-
- case mkComponentsLocalBuildInfo pkg_descr
- internalPkgDeps externalPkgDeps of
- Left componentCycle -> reportComponentCycle componentCycle
- Right components -> return components
-
-- installation directories
defaultDirs <- defaultInstallDirs flavor userInstall (hasLibs pkg_descr)
let installDirs = combineInstallDirs fromFlagOrDefault
@@ -529,26 +615,102 @@ configure (pkg_descr0, pbi) cfg
(pkg_descr', programsConfig''') <-
configurePkgconfigPackages verbosity pkg_descr programsConfig''
+ -- internal component graph
+ buildComponents <-
+ case mkComponentsGraph pkg_descr internalPkgDeps of
+ Left componentCycle -> reportComponentCycle componentCycle
+ Right components ->
+ mkComponentsLocalBuildInfo comp packageDependsIndex pkg_descr
+ internalPkgDeps externalPkgDeps holeDeps
+ (Map.fromList hole_insts)
+ components
+
split_objs <-
if not (fromFlag $ configSplitObjs cfg)
then return False
else case flavor of
GHC | version >= Version [6,5] [] -> return True
+ GHCJS -> return True
_ -> do warn verbosity
("this compiler does not support " ++
"--enable-split-objs; ignoring")
return False
- let sharedLibsByDefault =
+ let ghciLibByDefault =
case compilerId comp of
CompilerId GHC _ ->
+ -- If ghc is non-dynamic, then ghci needs object files,
+ -- so we build one by default.
+ --
+ -- Technically, archive files should be sufficient for ghci,
+ -- but because of GHC bug #8942, it has never been safe to
+ -- rely on them. By the time that bug was fixed, ghci had
+ -- been changed to read shared libraries instead of archive
+ -- files (see next code block).
+ not (GHC.isDynamic comp)
+ CompilerId GHCJS _ ->
+ not (GHCJS.isDynamic comp)
+ _ -> False
+
+ let sharedLibsByDefault
+ | fromFlag (configDynExe cfg) =
+ -- build a shared library if dynamically-linked
+ -- executables are requested
+ True
+ | otherwise = case compilerId comp of
+ CompilerId GHC _ ->
-- if ghc is dynamic, then ghci needs a shared
-- library, so we build one by default.
- GHC.ghcDynamic comp
+ GHC.isDynamic comp
+ CompilerId GHCJS _ ->
+ GHCJS.isDynamic comp
_ -> False
+ withSharedLib_ =
+ -- build shared libraries if required by GHC or by the
+ -- executable linking mode, but allow the user to force
+ -- building only static library archives with
+ -- --disable-shared.
+ fromFlagOrDefault sharedLibsByDefault $ configSharedLib cfg
+ withDynExe_ = fromFlag $ configDynExe cfg
+ when (withDynExe_ && not withSharedLib_) $ warn verbosity $
+ "Executables will use dynamic linking, but a shared library "
+ ++ "is not being built. Linking will fail if any executables "
+ ++ "depend on the library."
+
+ -- The --profiling flag sets the default for both libs and exes,
+ -- but can be overidden by --library-profiling, or the old deprecated
+ -- --executable-profiling flag.
+ let profEnabledLibOnly = configProfLib cfg
+ profEnabledBoth = fromFlagOrDefault False (configProf cfg)
+ profEnabledLib = fromFlagOrDefault profEnabledBoth profEnabledLibOnly
+ profEnabledExe = fromFlagOrDefault profEnabledBoth (configProfExe cfg)
+
+ -- The --profiling-detail and --library-profiling-detail flags behave
+ -- similarly
+ profDetailLibOnly <- checkProfDetail (configProfLibDetail cfg)
+ profDetailBoth <- liftM (fromFlagOrDefault ProfDetailDefault)
+ (checkProfDetail (configProfDetail cfg))
+ let profDetailLib = fromFlagOrDefault profDetailBoth profDetailLibOnly
+ profDetailExe = profDetailBoth
+
+ when (profEnabledExe && not profEnabledLib) $
+ warn verbosity $
+ "Executables will be built with profiling, but library "
+ ++ "profiling is disabled. Linking will fail if any executables "
+ ++ "depend on the library."
+
+ let configCoverage_ =
+ mappend (configCoverage cfg) (configLibCoverage cfg)
+
+ cfg' = cfg { configCoverage = configCoverage_ }
+
+ reloc <-
+ if not (fromFlag $ configRelocatable cfg)
+ then return False
+ else return True
let lbi = LocalBuildInfo {
- configFlags = cfg,
+ configFlags = cfg',
extraConfigArgs = [], -- Currently configure does not
-- take extra args, but if it
-- did they would go here.
@@ -556,30 +718,34 @@ configure (pkg_descr0, pbi) cfg
compiler = comp,
hostPlatform = compPlatform,
buildDir = buildDir',
- scratchDir = fromFlagOrDefault
- (distPref </> "scratch")
- (configScratchDir cfg),
componentsConfigs = buildComponents,
installedPkgs = packageDependsIndex,
pkgDescrFile = Nothing,
localPkgDescr = pkg_descr',
+ instantiatedWith = hole_insts,
withPrograms = programsConfig''',
withVanillaLib = fromFlag $ configVanillaLib cfg,
- withProfLib = fromFlag $ configProfLib cfg,
- withSharedLib = fromFlagOrDefault sharedLibsByDefault $
- configSharedLib cfg,
- withDynExe = fromFlag $ configDynExe cfg,
- withProfExe = fromFlag $ configProfExe cfg,
+ withProfLib = profEnabledLib,
+ withSharedLib = withSharedLib_,
+ withDynExe = withDynExe_,
+ withProfExe = profEnabledExe,
+ withProfLibDetail = profDetailLib,
+ withProfExeDetail = profDetailExe,
withOptimization = fromFlag $ configOptimization cfg,
- withGHCiLib = fromFlag $ configGHCiLib cfg,
+ withDebugInfo = fromFlag $ configDebugInfo cfg,
+ withGHCiLib = fromFlagOrDefault ghciLibByDefault $
+ configGHCiLib cfg,
splitObjs = split_objs,
stripExes = fromFlag $ configStripExes cfg,
stripLibs = fromFlag $ configStripLibs cfg,
withPackageDB = packageDbs,
progPrefix = fromFlag $ configProgPrefix cfg,
- progSuffix = fromFlag $ configProgSuffix cfg
+ progSuffix = fromFlag $ configProgSuffix cfg,
+ relocatable = reloc
}
+ when reloc (checkRelocatable verbosity pkg_descr lbi)
+
let dirs = absoluteInstallDirs pkg_descr lbi NoCopyDest
relative = prefixRelativeInstallDirs (packageId pkg_descr) lbi
@@ -612,6 +778,8 @@ configure (pkg_descr0, pbi) cfg
return lbi
where
+ verbosity = fromFlag (configVerbosity cfg)
+
addExtraIncludeLibDirs pkg_descr =
let extraBi = mempty { extraLibDirs = configExtraLibDirs cfg
, PD.includeDirs = configExtraIncludeDirs cfg}
@@ -623,6 +791,15 @@ configure (pkg_descr0, pbi) cfg
, executables = modifyExecutable `map`
executables pkg_descr}
+ checkProfDetail (Flag (ProfDetailOther other)) = do
+ warn verbosity $
+ "Unknown profiling detail level '" ++ other
+ ++ "', using default.\n"
+ ++ "The profiling detail levels are: " ++ intercalate ", "
+ [ name | (name, _, _) <- knownProfDetailLevels ]
+ return (Flag ProfDetailDefault)
+ checkProfDetail other = return other
+
mkProgramsConfig :: ConfigFlags -> ProgramConfiguration -> ProgramConfiguration
mkProgramsConfig cfg initialProgramsConfig = programsConfig
where
@@ -631,7 +808,7 @@ mkProgramsConfig cfg initialProgramsConfig = programsConfig
. setProgramSearchPath searchpath
$ initialProgramsConfig
searchpath = getProgramSearchPath (initialProgramsConfig)
- ++ map ProgramSearchPathDir (configProgramPathExtra cfg)
+ ++ map ProgramSearchPathDir (fromNubList $ configProgramPathExtra cfg)
-- -----------------------------------------------------------------------------
-- Configuring package dependencies
@@ -653,14 +830,14 @@ hackageUrl = "http://hackage.haskell.org/package/"
data ResolvedDependency = ExternalDependency Dependency InstalledPackageInfo
| InternalDependency Dependency PackageId -- should be a
- -- lib name
+ -- lib name
data FailedDependency = DependencyNotExists PackageName
| DependencyNoVersion Dependency
-- | Test for a package dependency and record the version we have installed.
-selectDependency :: PackageIndex -- ^ Internally defined packages
- -> PackageIndex -- ^ Installed packages
+selectDependency :: InstalledPackageIndex -- ^ Internally defined packages
+ -> InstalledPackageIndex -- ^ Installed packages
-> Map PackageName InstalledPackageInfo
-- ^ Packages for which we have been given specific deps to use
-> Dependency
@@ -720,9 +897,11 @@ reportFailedDependencies failed =
reportFailedDependency (DependencyNoVersion dep) =
"cannot satisfy dependency " ++ display (simplifyDependency dep) ++ "\n"
+-- | List all installed packages in the given package databases.
getInstalledPackages :: Verbosity -> Compiler
- -> PackageDBStack -> ProgramConfiguration
- -> IO PackageIndex
+ -> PackageDBStack -- ^ The stack of package databases.
+ -> ProgramConfiguration
+ -> IO InstalledPackageIndex
getInstalledPackages verbosity comp packageDBs progconf = do
when (null packageDBs) $
die $ "No package databases have been specified. If you use "
@@ -731,12 +910,11 @@ getInstalledPackages verbosity comp packageDBs progconf = do
info verbosity "Reading installed packages..."
case compilerFlavor comp of
- GHC -> GHC.getInstalledPackages verbosity packageDBs progconf
- Hugs->Hugs.getInstalledPackages verbosity packageDBs progconf
- JHC -> JHC.getInstalledPackages verbosity packageDBs progconf
- LHC -> LHC.getInstalledPackages verbosity packageDBs progconf
- NHC -> NHC.getInstalledPackages verbosity packageDBs progconf
- UHC -> UHC.getInstalledPackages verbosity comp packageDBs progconf
+ GHC -> GHC.getInstalledPackages verbosity comp packageDBs progconf
+ GHCJS -> GHCJS.getInstalledPackages verbosity packageDBs progconf
+ JHC -> JHC.getInstalledPackages verbosity packageDBs progconf
+ LHC -> LHC.getInstalledPackages verbosity packageDBs progconf
+ UHC -> UHC.getInstalledPackages verbosity comp packageDBs progconf
HaskellSuite {} ->
HaskellSuite.getInstalledPackages verbosity packageDBs progconf
flv -> die $ "don't know how to find the installed packages for "
@@ -745,12 +923,12 @@ getInstalledPackages verbosity comp packageDBs progconf = do
-- | Like 'getInstalledPackages', but for a single package DB.
getPackageDBContents :: Verbosity -> Compiler
-> PackageDB -> ProgramConfiguration
- -> IO PackageIndex
+ -> IO InstalledPackageIndex
getPackageDBContents verbosity comp packageDB progconf = do
info verbosity "Reading installed packages..."
case compilerFlavor comp of
GHC -> GHC.getPackageDBContents verbosity packageDB progconf
-
+ GHCJS -> GHCJS.getPackageDBContents verbosity packageDB progconf
-- For other compilers, try to fall back on 'getInstalledPackages'.
_ -> getInstalledPackages verbosity comp [packageDB] progconf
@@ -772,8 +950,7 @@ interpretPackageDbFlags userInstall specificDBs =
extra dbs' (Just db:dbs) = extra (dbs' ++ [db]) dbs
newPackageDepsBehaviourMinVersion :: Version
-newPackageDepsBehaviourMinVersion = Version { versionBranch = [1,7,1],
- versionTags = [] }
+newPackageDepsBehaviourMinVersion = Version [1,7,1] []
-- In older cabal versions, there was only one set of package dependencies for
-- the whole package. In this version, we can have separate dependencies per
@@ -796,7 +973,7 @@ newPackageDepsBehaviour pkg =
-- pick.
combinedConstraints :: [Dependency] ->
[(PackageName, InstalledPackageId)] ->
- PackageIndex ->
+ InstalledPackageIndex ->
Either String ([Dependency],
Map PackageName InstalledPackageInfo)
combinedConstraints constraints dependencies installedPackages = do
@@ -858,6 +1035,58 @@ combinedConstraints constraints dependencies installedPackages = do
| (pkgname, ipkgid) <- deps ]
-- -----------------------------------------------------------------------------
+-- Configuring hole instantiation
+
+configureInstantiateWith :: PackageDescription
+ -> ConfigFlags
+ -> InstalledPackageIndex -- ^ installed packages
+ -> IO ([InstalledPackageInfo],
+ [(ModuleName, (InstalledPackageInfo, ModuleName))])
+configureInstantiateWith pkg_descr cfg installedPackageSet = do
+ -- Holes: First, check and make sure the provided instantiation covers
+ -- all the holes we know about. Indefinite package installation is
+ -- not handled at all at this point.
+ -- NB: We union together /all/ of the requirements when calculating
+ -- the package key.
+ -- NB: For now, we assume that dependencies don't contribute signatures.
+ -- This will be handled by cabal-install; as far as ./Setup is
+ -- concerned, the most important thing is to be provided correctly
+ -- built dependencies.
+ let signatures =
+ maybe [] (\lib -> requiredSignatures lib ++ exposedSignatures lib)
+ (PD.library pkg_descr)
+ signatureSet = Set.fromList signatures
+ instantiateMap = Map.fromList (configInstantiateWith cfg)
+ missing_impls = filter (not . flip Map.member instantiateMap) signatures
+ hole_insts0 = filter (\(k,_) -> Set.member k signatureSet) (configInstantiateWith cfg)
+
+ when (not (null missing_impls)) $
+ die $ "Missing signature implementations for these modules: "
+ ++ intercalate ", " (map display missing_impls)
+
+ -- Holes: Next, we need to make sure we have packages to actually
+ -- provide the implementations we're talking about. This is on top
+ -- of the normal dependency resolution process.
+ -- TODO: internal dependencies (e.g. the test package depending on the
+ -- main library) is not currently supported
+ let selectHoleDependency (k,(i,m)) =
+ case PackageIndex.lookupInstalledPackageId installedPackageSet i of
+ Just pkginst -> Right (k,(pkginst, m))
+ Nothing -> Left i
+ (failed_hmap, hole_insts) = partitionEithers (map selectHoleDependency hole_insts0)
+ holeDeps = map (fst.snd) hole_insts -- could have dups
+
+ -- Holes: Finally, any dependencies selected this way have to be
+ -- included in the allPkgs index, as well as the buildComponents.
+ -- But don't report these as potential inconsistencies!
+
+ when (not (null failed_hmap)) $
+ die $ "Could not resolve these package IDs (from signature implementations): "
+ ++ intercalate ", " (map display failed_hmap)
+
+ return (holeDeps, hole_insts)
+
+-- -----------------------------------------------------------------------------
-- Configuring program dependencies
configureRequiredPrograms :: Verbosity -> [Dependency] -> ProgramConfiguration
@@ -895,9 +1124,12 @@ configurePkgconfigPackages verbosity pkg_descr conf
(lessVerbose verbosity) pkgConfigProgram
(orLaterVersion $ Version [0,9,0] []) conf
mapM_ requirePkg allpkgs
- lib' <- updateLibrary (library pkg_descr)
- exes' <- mapM updateExecutable (executables pkg_descr)
- let pkg_descr' = pkg_descr { library = lib', executables = exes' }
+ lib' <- mapM addPkgConfigBILib (library pkg_descr)
+ exes' <- mapM addPkgConfigBIExe (executables pkg_descr)
+ tests' <- mapM addPkgConfigBITest (testSuites pkg_descr)
+ benches' <- mapM addPkgConfigBIBench (benchmarks pkg_descr)
+ let pkg_descr' = pkg_descr { library = lib', executables = exes',
+ testSuites = tests', benchmarks = benches' }
return (pkg_descr', conf')
where
@@ -914,9 +1146,11 @@ configurePkgconfigPackages verbosity pkg_descr conf
Just v | not (withinRange v range) -> die (badVersion v)
| otherwise -> info verbosity (depSatisfied v)
where
- notFound = "The pkg-config package " ++ pkg ++ versionRequirement
+ notFound = "The pkg-config package '" ++ pkg ++ "'"
+ ++ versionRequirement
++ " is required but it could not be found."
- badVersion v = "The pkg-config package " ++ pkg ++ versionRequirement
+ badVersion v = "The pkg-config package '" ++ pkg ++ "'"
+ ++ versionRequirement
++ " is required but the version installed on the"
++ " system is version " ++ display v
depSatisfied v = "Dependency " ++ display dep
@@ -926,14 +1160,26 @@ configurePkgconfigPackages verbosity pkg_descr conf
| isAnyVersion range = ""
| otherwise = " version " ++ display range
- updateLibrary Nothing = return Nothing
- updateLibrary (Just lib) = do
- bi <- pkgconfigBuildInfo (pkgconfigDepends (libBuildInfo lib))
- return $ Just lib { libBuildInfo = libBuildInfo lib `mappend` bi }
+ -- Adds pkgconfig dependencies to the build info for a component
+ addPkgConfigBI compBI setCompBI comp = do
+ bi <- pkgconfigBuildInfo (pkgconfigDepends (compBI comp))
+ return $ setCompBI comp (compBI comp `mappend` bi)
+
+ -- Adds pkgconfig dependencies to the build info for a library
+ addPkgConfigBILib = addPkgConfigBI libBuildInfo $
+ \lib bi -> lib { libBuildInfo = bi }
+
+ -- Adds pkgconfig dependencies to the build info for an executable
+ addPkgConfigBIExe = addPkgConfigBI buildInfo $
+ \exe bi -> exe { buildInfo = bi }
+
+ -- Adds pkgconfig dependencies to the build info for a test suite
+ addPkgConfigBITest = addPkgConfigBI testBuildInfo $
+ \test bi -> test { testBuildInfo = bi }
- updateExecutable exe = do
- bi <- pkgconfigBuildInfo (pkgconfigDepends (buildInfo exe))
- return exe { buildInfo = buildInfo exe `mappend` bi }
+ -- Adds pkgconfig dependencies to the build info for a benchmark
+ addPkgConfigBIBench = addPkgConfigBI benchmarkBuildInfo $
+ \bench bi -> bench { benchmarkBuildInfo = bi }
pkgconfigBuildInfo :: [Dependency] -> IO BuildInfo
pkgconfigBuildInfo [] = return mempty
@@ -985,13 +1231,12 @@ configCompilerEx :: Maybe CompilerFlavor -> Maybe FilePath -> Maybe FilePath
configCompilerEx Nothing _ _ _ _ = die "Unknown compiler"
configCompilerEx (Just hcFlavor) hcPath hcPkg conf verbosity = do
(comp, maybePlatform, programsConfig) <- case hcFlavor of
- GHC -> GHC.configure verbosity hcPath hcPkg conf
- JHC -> JHC.configure verbosity hcPath hcPkg conf
- LHC -> do (_, _, ghcConf) <- GHC.configure verbosity Nothing hcPkg conf
- LHC.configure verbosity hcPath Nothing ghcConf
- Hugs -> Hugs.configure verbosity hcPath hcPkg conf
- NHC -> NHC.configure verbosity hcPath hcPkg conf
- UHC -> UHC.configure verbosity hcPath hcPkg conf
+ GHC -> GHC.configure verbosity hcPath hcPkg conf
+ GHCJS -> GHCJS.configure verbosity hcPath hcPkg conf
+ JHC -> JHC.configure verbosity hcPath hcPkg conf
+ LHC -> do (_, _, ghcConf) <- GHC.configure verbosity Nothing hcPkg conf
+ LHC.configure verbosity hcPath Nothing ghcConf
+ UHC -> UHC.configure verbosity hcPath hcPkg conf
HaskellSuite {} -> HaskellSuite.configure verbosity hcPath hcPkg conf
_ -> die "Unknown compiler"
return (comp, fromMaybe buildPlatform maybePlatform, programsConfig)
@@ -1019,19 +1264,16 @@ configCompilerAux = fmap (\(a,_,b) -> (a,b)) . configCompilerAuxEx
-- Making the internal component graph
-mkComponentsLocalBuildInfo :: PackageDescription
- -> [PackageId] -> [InstalledPackageInfo]
- -> Either [ComponentName]
- [(ComponentName,
- ComponentLocalBuildInfo, [ComponentName])]
-mkComponentsLocalBuildInfo pkg_descr internalPkgDeps externalPkgDeps =
+mkComponentsGraph :: PackageDescription
+ -> [PackageId]
+ -> Either [ComponentName]
+ [(Component, [ComponentName])]
+mkComponentsGraph pkg_descr internalPkgDeps =
let graph = [ (c, componentName c, componentDeps c)
| c <- pkgEnabledComponents pkg_descr ]
in case checkComponentsCyclic graph of
Just ccycle -> Left [ cname | (_,cname,_) <- ccycle ]
- Nothing -> Right [ (cname, clbi, cdeps)
- | (c, cname, cdeps) <- graph
- , let clbi = componentLocalBuildInfo c ]
+ Nothing -> Right [ (c, cdeps) | (c, _, cdeps) <- graph ]
where
-- The dependencies for the given component
componentDeps component =
@@ -1045,6 +1287,31 @@ mkComponentsLocalBuildInfo pkg_descr internalPkgDeps externalPkgDeps =
where
bi = componentBuildInfo component
+reportComponentCycle :: [ComponentName] -> IO a
+reportComponentCycle cnames =
+ die $ "Components in the package depend on each other in a cyclic way:\n "
+ ++ intercalate " depends on "
+ [ "'" ++ showComponentName cname ++ "'"
+ | cname <- cnames ++ [head cnames] ]
+
+mkComponentsLocalBuildInfo :: Compiler
+ -> InstalledPackageIndex
+ -> PackageDescription
+ -> [PackageId] -- internal package deps
+ -> [InstalledPackageInfo] -- external package deps
+ -> [InstalledPackageInfo] -- hole package deps
+ -> Map ModuleName (InstalledPackageInfo, ModuleName)
+ -> [(Component, [ComponentName])]
+ -> IO [(ComponentName, ComponentLocalBuildInfo,
+ [ComponentName])]
+mkComponentsLocalBuildInfo comp installedPackages pkg_descr
+ internalPkgDeps externalPkgDeps holePkgDeps hole_insts
+ graph =
+ sequence
+ [ do clbi <- componentLocalBuildInfo c
+ return (componentName c, clbi, cdeps)
+ | (c, cdeps) <- graph ]
+ where
-- The allPkgDeps contains all the package deps for the whole package
-- but we need to select the subset for this specific component.
-- we just take the subset for the package names this component
@@ -1052,47 +1319,206 @@ mkComponentsLocalBuildInfo pkg_descr internalPkgDeps externalPkgDeps =
-- versions of the same package.
componentLocalBuildInfo component =
case component of
- CLib _ ->
- LibComponentLocalBuildInfo {
+ CLib lib -> do
+ let exports = map (\n -> Installed.ExposedModule n Nothing Nothing)
+ (PD.exposedModules lib)
+ esigs = map (\n -> Installed.ExposedModule n Nothing
+ (fmap (\(pkg,m) -> Installed.OriginalModule
+ (Installed.installedPackageId pkg) m)
+ (Map.lookup n hole_insts)))
+ (PD.exposedSignatures lib)
+ let mb_reexports = resolveModuleReexports installedPackages
+ (packageId pkg_descr)
+ externalPkgDeps lib
+ reexports <- case mb_reexports of
+ Left problems -> reportModuleReexportProblems problems
+ Right r -> return r
+
+ -- Calculate the version hash and package key.
+ let externalPkgs = selectSubset bi externalPkgDeps
+ pkg_key = mkPackageKey (packageKeySupported comp)
+ (package pkg_descr)
+ (map Installed.libraryName externalPkgs)
+ version_hash = packageKeyLibraryName (package pkg_descr) pkg_key
+
+ return LibComponentLocalBuildInfo {
componentPackageDeps = cpds,
- componentLibraries = [LibraryName
- ("HS" ++ display (package pkg_descr))]
+ componentPackageKey = pkg_key,
+ componentLibraryName = version_hash,
+ componentPackageRenaming = cprns,
+ componentExposedModules = exports ++ reexports ++ esigs
}
CExe _ ->
- ExeComponentLocalBuildInfo {
- componentPackageDeps = cpds
+ return ExeComponentLocalBuildInfo {
+ componentPackageDeps = cpds,
+ componentPackageRenaming = cprns
}
CTest _ ->
- TestComponentLocalBuildInfo {
- componentPackageDeps = cpds
+ return TestComponentLocalBuildInfo {
+ componentPackageDeps = cpds,
+ componentPackageRenaming = cprns
}
CBench _ ->
- BenchComponentLocalBuildInfo {
- componentPackageDeps = cpds
+ return BenchComponentLocalBuildInfo {
+ componentPackageDeps = cpds,
+ componentPackageRenaming = cprns
}
where
bi = componentBuildInfo component
+ dedup = Map.toList . Map.fromList
cpds = if newPackageDepsBehaviour pkg_descr
- then [ (installedPackageId pkg, packageId pkg)
+ then dedup $
+ [ (Installed.installedPackageId pkg, packageId pkg)
| pkg <- selectSubset bi externalPkgDeps ]
++ [ (inplacePackageId pkgid, pkgid)
| pkgid <- selectSubset bi internalPkgDeps ]
- else [ (installedPackageId pkg, packageId pkg)
+ else [ (Installed.installedPackageId pkg, packageId pkg)
| pkg <- externalPkgDeps ]
+ cprns = if newPackageDepsBehaviour pkg_descr
+ then Map.unionWith mappend
+ -- We need hole dependencies passed to GHC, so add them here
+ -- (but note that they're fully thinned out. If they
+ -- appeared legitimately the monoid instance will
+ -- fill them out.
+ (Map.fromList [(packageName pkg, mempty) | pkg <- holePkgDeps])
+ (targetBuildRenaming bi)
+ -- Hack: if we have old package-deps behavior, it's impossible
+ -- for non-default renamings to be used, because the Cabal
+ -- version is too early. This is a good, because while all the
+ -- deps were bundled up in buildDepends, we didn't do this for
+ -- renamings, so it's not even clear how to get the merged
+ -- version. So just assume that all of them are the default..
+ else Map.fromList (map (\(_,pid) -> (packageName pid, defaultRenaming)) cpds)
selectSubset :: Package pkg => BuildInfo -> [pkg] -> [pkg]
selectSubset bi pkgs =
- [ pkg | pkg <- pkgs, packageName pkg `elem` names ]
- where
- names = [ name | Dependency name _ <- targetBuildDepends bi ]
+ [ pkg | pkg <- pkgs, packageName pkg `elem` names bi ]
-reportComponentCycle :: [ComponentName] -> IO a
-reportComponentCycle cnames =
- die $ "Components in the package depend on each other in a cyclic way:\n "
- ++ intercalate " depends on "
- [ "'" ++ showComponentName cname ++ "'"
- | cname <- cnames ++ [head cnames] ]
+ names bi = [ name | Dependency name _ <- targetBuildDepends bi ]
+-- | Given the author-specified re-export declarations from the .cabal file,
+-- resolve them to the form that we need for the package database.
+--
+-- An invariant of the package database is that we always link the re-export
+-- directly to its original defining location (rather than indirectly via a
+-- chain of re-exporting packages).
+--
+resolveModuleReexports :: InstalledPackageIndex
+ -> PackageId
+ -> [InstalledPackageInfo]
+ -> Library
+ -> Either [(ModuleReexport, String)] -- errors
+ [Installed.ExposedModule] -- ok
+resolveModuleReexports installedPackages srcpkgid externalPkgDeps lib =
+ case partitionEithers (map resolveModuleReexport (PD.reexportedModules lib)) of
+ ([], ok) -> Right ok
+ (errs, _) -> Left errs
+ where
+ -- A mapping from visible module names to their original defining
+ -- module name. We also record the package name of the package which
+ -- *immediately* provided the module (not the original) to handle if the
+ -- user explicitly says which build-depends they want to reexport from.
+ visibleModules :: Map ModuleName [(PackageName, Installed.ExposedModule)]
+ visibleModules =
+ Map.fromListWith (++) $
+ [ (Installed.exposedName exposedModule, [(exportingPackageName,
+ exposedModule)])
+ -- The package index here contains all the indirect deps of the
+ -- package we're configuring, but we want just the direct deps
+ | let directDeps = Set.fromList (map Installed.installedPackageId externalPkgDeps)
+ , pkg <- PackageIndex.allPackages installedPackages
+ , Installed.installedPackageId pkg `Set.member` directDeps
+ , let exportingPackageName = packageName pkg
+ , exposedModule <- visibleModuleDetails pkg
+ ]
+ ++ [ (visibleModuleName, [(exportingPackageName, exposedModule)])
+ | visibleModuleName <- PD.exposedModules lib
+ ++ otherModules (libBuildInfo lib)
+ , let exportingPackageName = packageName srcpkgid
+ definingModuleName = visibleModuleName
+ -- we don't know the InstalledPackageId of this package yet
+ -- we will fill it in later, before registration.
+ definingPackageId = InstalledPackageId ""
+ originalModule = Installed.OriginalModule definingPackageId
+ definingModuleName
+ exposedModule = Installed.ExposedModule visibleModuleName
+ (Just originalModule)
+ Nothing
+ ]
+
+ -- All the modules exported from this package and their defining name and
+ -- package (either defined here in this package or re-exported from some
+ -- other package). Return an ExposedModule because we want to hold onto
+ -- signature information.
+ visibleModuleDetails :: InstalledPackageInfo -> [Installed.ExposedModule]
+ visibleModuleDetails pkg = do
+ exposedModule <- Installed.exposedModules pkg
+ case Installed.exposedReexport exposedModule of
+ -- The first case is the modules actually defined in this package.
+ -- In this case the reexport will point to this package.
+ Nothing -> return exposedModule { Installed.exposedReexport =
+ Just (Installed.OriginalModule (Installed.installedPackageId pkg)
+ (Installed.exposedName exposedModule)) }
+ -- On the other hand, a visible module might actually be itself
+ -- a re-export! In this case, the re-export info for the package
+ -- doing the re-export will point us to the original defining
+ -- module name and package, so we can reuse the entry.
+ Just _ -> return exposedModule
+
+ resolveModuleReexport reexport@ModuleReexport {
+ moduleReexportOriginalPackage = moriginalPackageName,
+ moduleReexportOriginalName = originalName,
+ moduleReexportName = newName
+ } =
+
+ let filterForSpecificPackage =
+ case moriginalPackageName of
+ Nothing -> id
+ Just originalPackageName ->
+ filter (\(pkgname, _) -> pkgname == originalPackageName)
+
+ matches = filterForSpecificPackage
+ (Map.findWithDefault [] originalName visibleModules)
+ in
+ case (matches, moriginalPackageName) of
+ ((_, exposedModule):rest, _)
+ -- TODO: Refine this check for signatures
+ | all (\(_, exposedModule') -> Installed.exposedReexport exposedModule
+ == Installed.exposedReexport exposedModule') rest
+ -> Right exposedModule { Installed.exposedName = newName }
+
+ ([], Just originalPackageName)
+ -> Left $ (,) reexport
+ $ "The package " ++ display originalPackageName
+ ++ " does not export a module " ++ display originalName
+
+ ([], Nothing)
+ -> Left $ (,) reexport
+ $ "The module " ++ display originalName
+ ++ " is not exported by any suitable package (this package "
+ ++ "itself nor any of its 'build-depends' dependencies)."
+
+ (ms, _)
+ -> Left $ (,) reexport
+ $ "The module " ++ display originalName ++ " is exported "
+ ++ "by more than one package ("
+ ++ intercalate ", " [ display pkgname | (pkgname,_) <- ms ]
+ ++ ") and so the re-export is ambiguous. The ambiguity can "
+ ++ "be resolved by qualifying by the package name. The "
+ ++ "syntax is 'packagename:moduleName [as newname]'."
+
+ -- Note: if in future Cabal allows directly depending on multiple
+ -- instances of the same package (e.g. backpack) then an additional
+ -- ambiguity case is possible here: (_, Just originalPackageName)
+ -- with the module being ambiguous despite being qualified by a
+ -- package name. Presumably by that time we'll have a mechanism to
+ -- qualify the instance we're referring to.
+
+reportModuleReexportProblems :: [(ModuleReexport, String)] -> IO a
+reportModuleReexportProblems reexportProblems =
+ die $ unlines
+ [ "Problem with the module re-export '" ++ display reexport ++ "': " ++ msg
+ | (reexport, msg) <- reexportProblems ]
-- -----------------------------------------------------------------------------
-- Testing C lib and header dependencies
@@ -1191,6 +1617,16 @@ checkForeignDeps pkg lbi verbosity = do
`catchExit` (\_ -> return False)
explainErrors Nothing [] = return () -- should be impossible!
+ explainErrors _ _
+ | isNothing . lookupProgram gccProgram . withPrograms $ lbi
+
+ = die $ unlines $
+ [ "No working gcc",
+ "This package depends on foreign library but we cannot "
+ ++ "find a working C compiler. If you have it in a "
+ ++ "non-standard location you can use the --with-gcc "
+ ++ "flag to specify it." ]
+
explainErrors hdr libs = die $ unlines $
[ if plural
then "Missing dependencies on foreign libraries:"
@@ -1254,3 +1690,69 @@ checkPackageProblems verbosity gpkg pkg = do
if null errors
then mapM_ (warn verbosity) warnings
else die (intercalate "\n\n" errors)
+
+-- | Preform checks if a relocatable build is allowed
+checkRelocatable :: Verbosity
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> IO ()
+checkRelocatable verbosity pkg lbi
+ = sequence_ [ checkOS
+ , checkCompiler
+ , packagePrefixRelative
+ , depsPrefixRelative
+ ]
+ where
+ -- Check if the OS support relocatable builds.
+ --
+ -- If you add new OS' to this list, and your OS supports dynamic libraries
+ -- and RPATH, make sure you add your OS to RPATH-support list of:
+ -- Distribution.Simple.GHC.getRPaths
+ checkOS
+ = unless (os `elem` [ OSX, Linux ])
+ $ die $ "Operating system: " ++ display os ++
+ ", does not support relocatable builds"
+ where
+ (Platform _ os) = hostPlatform lbi
+
+ -- Check if the Compiler support relocatable builds
+ checkCompiler
+ = unless (compilerFlavor comp `elem` [ GHC ])
+ $ die $ "Compiler: " ++ show comp ++
+ ", does not support relocatable builds"
+ where
+ comp = compiler lbi
+
+ -- Check if all the install dirs are relative to same prefix
+ packagePrefixRelative
+ = unless (relativeInstallDirs installDirs)
+ $ die $ "Installation directories are not prefix_relative:\n" ++
+ show installDirs
+ where
+ installDirs = absoluteInstallDirs pkg lbi NoCopyDest
+ p = prefix installDirs
+ relativeInstallDirs (InstallDirs {..}) =
+ all isJust
+ (fmap (stripPrefix p)
+ [ bindir, libdir, dynlibdir, libexecdir, includedir, datadir
+ , docdir, mandir, htmldir, haddockdir, sysconfdir] )
+
+ -- Check if the library dirs of the dependencies that are in the package
+ -- database to which the package is installed are relative to the
+ -- prefix of the package
+ depsPrefixRelative = do
+ pkgr <- GHC.pkgRoot verbosity lbi (last (withPackageDB lbi))
+ mapM_ (doCheck pkgr) ipkgs
+ where
+ doCheck pkgr ipkg
+ | maybe False (== pkgr) (Installed.pkgRoot ipkg)
+ = mapM_ (\l -> when (isNothing $ stripPrefix p l) (die (msg l)))
+ (Installed.libraryDirs ipkg)
+ | otherwise
+ = return ()
+ installDirs = absoluteInstallDirs pkg lbi NoCopyDest
+ p = prefix installDirs
+ ipkgs = PackageIndex.allPackages (installedPkgs lbi)
+ msg l = "Library directory of a dependency: " ++ show l ++
+ "\nis not relative to the installation prefix:\n" ++
+ show p
diff --git a/cabal/Cabal/Distribution/Simple/GHC.hs b/cabal/Cabal/Distribution/Simple/GHC.hs
index cb3c661..ee3df77 100644
--- a/cabal/Cabal/Distribution/Simple/GHC.hs
+++ b/cabal/Cabal/Distribution/Simple/GHC.hs
@@ -1,7 +1,9 @@
+{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Simple.GHC
-- Copyright : Isaac Jones 2003-2007
+-- License : BSD3
--
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
@@ -29,37 +31,6 @@
-- explicitly documented) and thus what search dirs are used for various kinds
-- of files.
-{- Copyright (c) 2003-2005, Isaac Jones
-All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modiication, 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.GHC (
getGhcInfo,
configure, getInstalledPackages, getPackageDBContents,
@@ -68,85 +39,85 @@ module Distribution.Simple.GHC (
startInterpreter,
installLib, installExe,
libAbiHash,
- initPackageDB,
- invokeHcPkg,
+ hcPkgInfo,
registerPackage,
componentGhcOptions,
- ghcLibDir,
- ghcDynamic,
+ componentCcGhcOptions,
+ getLibDir,
+ isDynamic,
+ getGlobalPackageDB,
+ pkgRoot
) where
import qualified Distribution.Simple.GHC.IPI641 as IPI641
import qualified Distribution.Simple.GHC.IPI642 as IPI642
+import qualified Distribution.Simple.GHC.Internal as Internal
+import Distribution.Simple.GHC.ImplInfo
import Distribution.PackageDescription as PD
- ( PackageDescription(..), BuildInfo(..), Executable(..)
- , Library(..), libModules, exeModules, hcOptions
- , usedExtensions, allExtensions )
+ ( PackageDescription(..), BuildInfo(..), Executable(..), Library(..)
+ , allExtensions, libModules, exeModules
+ , hcOptions, hcSharedOptions, hcProfOptions )
import Distribution.InstalledPackageInfo
( InstalledPackageInfo )
import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
- ( InstalledPackageInfo_(..) )
-import Distribution.Simple.PackageIndex (PackageIndex)
+ ( InstalledPackageInfo(..) )
+import Distribution.Simple.PackageIndex (InstalledPackageIndex)
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.LocalBuildInfo
( LocalBuildInfo(..), ComponentLocalBuildInfo(..)
- , LibraryName(..), absoluteInstallDirs )
+ , absoluteInstallDirs, depLibraryPaths )
+import qualified Distribution.Simple.Hpc as Hpc
import Distribution.Simple.InstallDirs hiding ( absoluteInstallDirs )
import Distribution.Simple.BuildPaths
import Distribution.Simple.Utils
import Distribution.Package
- ( Package(..), PackageName(..) )
+ ( PackageName(..) )
import qualified Distribution.ModuleName as ModuleName
import Distribution.Simple.Program
( Program(..), ConfiguredProgram(..), ProgramConfiguration
- , ProgramLocation(..), ProgramSearchPath, ProgramSearchPathEntry(..)
- , rawSystemProgram
+ , ProgramSearchPath
, rawSystemProgramStdout, rawSystemProgramStdoutConf
- , getProgramOutput, getProgramInvocationOutput, suppressOverrideArgs
- , requireProgramVersion, requireProgram
+ , getProgramInvocationOutput, requireProgramVersion, requireProgram
, userMaybeSpecifyPath, programPath, lookupProgram, addKnownProgram
- , ghcProgram, ghcPkgProgram, hsc2hsProgram
- , arProgram, ldProgram
- , gccProgram, stripProgram )
+ , ghcProgram, ghcPkgProgram, haddockProgram, hsc2hsProgram, ldProgram )
import qualified Distribution.Simple.Program.HcPkg as HcPkg
import qualified Distribution.Simple.Program.Ar as Ar
import qualified Distribution.Simple.Program.Ld as Ld
import qualified Distribution.Simple.Program.Strip as Strip
import Distribution.Simple.Program.GHC
import Distribution.Simple.Setup
- ( toFlag, fromFlag, fromFlagOrDefault )
+ ( toFlag, fromFlag, fromFlagOrDefault, configCoverage, configDistPref )
import qualified Distribution.Simple.Setup as Cabal
- ( Flag )
+ ( Flag(..) )
import Distribution.Simple.Compiler
( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion
- , OptimisationLevel(..), PackageDB(..), PackageDBStack
- , Flag )
+ , PackageDB(..), PackageDBStack, AbiTag(..) )
import Distribution.Version
( Version(..), anyVersion, orLaterVersion )
import Distribution.System
- ( OS(..), buildOS )
+ ( Platform(..), OS(..) )
import Distribution.Verbosity
import Distribution.Text
- ( display, simpleParse )
-import Language.Haskell.Extension (Language(..), Extension(..)
- ,KnownExtension(..))
+ ( display )
+import Distribution.Utils.NubList
+ ( NubListR, overNubListR, toNubListR )
+import Language.Haskell.Extension (Extension(..), KnownExtension(..))
import Control.Monad ( unless, when )
-import Data.Char ( isSpace )
+import Data.Char ( isDigit, isSpace )
import Data.List
-import qualified Data.Map as M ( Map, fromList, lookup )
-import Data.Maybe ( catMaybes, fromMaybe, maybeToList )
+import qualified Data.Map as M ( fromList )
+import Data.Maybe ( catMaybes )
+#if __GLASGOW_HASKELL__ < 710
import Data.Monoid ( Monoid(..) )
+#endif
+import Data.Version ( showVersion )
import System.Directory
- ( getDirectoryContents, doesFileExist, getTemporaryDirectory )
+ ( doesFileExist, getAppUserDataDirectory, createDirectoryIfMissing )
import System.FilePath ( (</>), (<.>), takeExtension,
takeDirectory, replaceExtension,
- splitExtension )
-import System.IO (hClose, hPutStrLn)
-import System.Environment (getEnv)
-import Distribution.Compat.Exception (catchExit, catchIO)
-import Distribution.System (Platform, platformFromTriple)
-
+ splitExtension, isRelative )
+import qualified System.Info
-- -----------------------------------------------------------------------------
-- Configuring
@@ -160,6 +131,7 @@ configure verbosity hcPath hcPkgPath conf0 = do
requireProgramVersion verbosity ghcProgram
(orLaterVersion (Version [6,4] []))
(userMaybeSpecifyPath "ghc" hcPath conf0)
+ let implInfo = ghcVersionImplInfo ghcVersion
-- This is slightly tricky, we have to configure ghc first, then we use the
-- location of ghc to help find ghc-pkg in the case that the user did not
@@ -175,31 +147,35 @@ configure verbosity hcPath hcPkgPath conf0 = do
++ programPath ghcProg ++ " is version " ++ display ghcVersion ++ " "
++ programPath ghcPkgProg ++ " is version " ++ display ghcPkgVersion
- -- Likewise we try to find the matching hsc2hs program.
+ -- Likewise we try to find the matching hsc2hs and haddock programs.
let hsc2hsProgram' = hsc2hsProgram {
programFindLocation = guessHsc2hsFromGhcPath ghcProg
}
- conf3 = addKnownProgram hsc2hsProgram' conf2
+ haddockProgram' = haddockProgram {
+ programFindLocation = guessHaddockFromGhcPath ghcProg
+ }
+ conf3 = addKnownProgram haddockProgram' $
+ addKnownProgram hsc2hsProgram' conf2
- languages <- getLanguages verbosity ghcProg
- extensions <- getExtensions verbosity ghcProg
+ languages <- Internal.getLanguages verbosity implInfo ghcProg
+ extensions <- Internal.getExtensions verbosity implInfo ghcProg
- ghcInfo <- getGhcInfo verbosity ghcProg
+ ghcInfo <- Internal.getGhcInfo verbosity implInfo ghcProg
let ghcInfoMap = M.fromList ghcInfo
let comp = Compiler {
compilerId = CompilerId GHC ghcVersion,
+ compilerAbiTag = NoAbiTag,
+ compilerCompat = [],
compilerLanguages = languages,
compilerExtensions = extensions,
compilerProperties = ghcInfoMap
}
- compPlatform = targetPlatform ghcInfo
- conf4 = configureToolchain ghcProg ghcInfoMap conf3 -- configure gcc and ld
+ compPlatform = Internal.targetPlatform ghcInfo
+ -- configure gcc and ld
+ conf4 = Internal.configureToolchain implInfo ghcProg ghcInfoMap conf3
return (comp, compPlatform, conf4)
-targetPlatform :: [(String, String)] -> Maybe Platform
-targetPlatform ghcInfo = platformFromTriple =<< lookup "Target platform" ghcInfo
-
-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find
-- the corresponding tool; e.g. if the tool is ghc-pkg, we try looking
-- for a versioned or unversioned ghc-pkg in the same dir, that is:
@@ -236,8 +212,10 @@ guessToolFromGhcPath tool ghcProg verbosity searchpath
return (Just fp)
where takeVersionSuffix :: FilePath -> String
- takeVersionSuffix = reverse . takeWhile (`elem ` "0123456789.-") .
- reverse
+ takeVersionSuffix = takeWhileEndLE isSuffixChar
+
+ isSuffixChar :: Char -> Bool
+ isSuffixChar c = isDigit c || c == '.' || c == '-'
dropExeExtension :: FilePath -> FilePath
dropExeExtension filepath =
@@ -269,275 +247,37 @@ guessHsc2hsFromGhcPath :: ConfiguredProgram
-> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath)
guessHsc2hsFromGhcPath = guessToolFromGhcPath hsc2hsProgram
--- | Adjust the way we find and configure gcc and ld
+-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a
+-- corresponding haddock, we try looking for both a versioned and unversioned
+-- haddock in the same dir, that is:
--
-configureToolchain :: ConfiguredProgram -> M.Map String String
- -> ProgramConfiguration
- -> ProgramConfiguration
-configureToolchain ghcProg ghcInfo =
- addKnownProgram gccProgram {
- programFindLocation = findProg gccProgram extraGccPath,
- programPostConf = configureGcc
- }
- . addKnownProgram ldProgram {
- programFindLocation = findProg ldProgram extraLdPath,
- programPostConf = configureLd
- }
- . addKnownProgram arProgram {
- programFindLocation = findProg arProgram extraArPath
- }
- . addKnownProgram stripProgram {
- programFindLocation = findProg stripProgram extraStripPath
- }
- where
- Just ghcVersion = programVersion ghcProg
- compilerDir = takeDirectory (programPath ghcProg)
- baseDir = takeDirectory compilerDir
- mingwBinDir = baseDir </> "mingw" </> "bin"
- libDir = baseDir </> "gcc-lib"
- includeDir = baseDir </> "include" </> "mingw"
- isWindows = case buildOS of Windows -> True; _ -> False
- binPrefix = ""
-
- mkExtraPath :: Maybe FilePath -> FilePath -> [FilePath]
- mkExtraPath mbPath mingwPath | isWindows = mbDir ++ [mingwPath]
- | otherwise = mbDir
- where
- mbDir = maybeToList . fmap takeDirectory $ mbPath
-
- extraGccPath = mkExtraPath mbGccLocation windowsExtraGccDir
- extraLdPath = mkExtraPath mbLdLocation windowsExtraLdDir
- extraArPath = mkExtraPath mbArLocation windowsExtraArDir
- extraStripPath = mkExtraPath mbStripLocation windowsExtraStripDir
-
- -- on Windows finding and configuring ghc's gcc & binutils is a bit special
- windowsExtraGccDir
- | ghcVersion >= Version [6,12] [] = mingwBinDir </> binPrefix
- | otherwise = baseDir
- windowsExtraLdDir
- | ghcVersion >= Version [6,12] [] = mingwBinDir </> binPrefix
- | otherwise = libDir
- windowsExtraArDir
- | ghcVersion >= Version [6,12] [] = mingwBinDir </> binPrefix
- | otherwise = libDir
- windowsExtraStripDir
- | ghcVersion >= Version [6,12] [] = mingwBinDir </> binPrefix
- | otherwise = libDir
-
- findProg :: Program -> [FilePath]
- -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath)
- findProg prog extraPath v searchpath =
- programFindLocation prog v searchpath'
- where
- searchpath' = (map ProgramSearchPathDir extraPath) ++ searchpath
-
- -- Read tool locations from the 'ghc --info' output. Useful when
- -- cross-compiling.
- mbGccLocation = M.lookup "C compiler command" ghcInfo
- mbLdLocation = M.lookup "ld command" ghcInfo
- mbArLocation = M.lookup "ar command" ghcInfo
- mbStripLocation = M.lookup "strip command" ghcInfo
-
- ccFlags = getFlags "C compiler flags"
- gccLinkerFlags = getFlags "Gcc Linker flags"
- ldLinkerFlags = getFlags "Ld Linker flags"
-
- getFlags key = case M.lookup key ghcInfo of
- Nothing -> []
- Just flags ->
- case reads flags of
- [(args, "")] -> args
- _ -> [] -- XXX Should should be an error really
-
- configureGcc :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
- configureGcc v gccProg = do
- gccProg' <- configureGcc' v gccProg
- return gccProg' {
- programDefaultArgs = programDefaultArgs gccProg'
- ++ ccFlags ++ gccLinkerFlags
- }
-
- configureGcc' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
- configureGcc'
- | isWindows = \_ gccProg -> case programLocation gccProg of
- -- if it's found on system then it means we're using the result
- -- of programFindLocation above rather than a user-supplied path
- -- Pre GHC 6.12, that meant we should add these flags to tell
- -- ghc's gcc where it lives and thus where gcc can find its
- -- various files:
- FoundOnSystem {}
- | ghcVersion < Version [6,11] [] ->
- return gccProg { programDefaultArgs = ["-B" ++ libDir,
- "-I" ++ includeDir] }
- _ -> return gccProg
- | otherwise = \_ gccProg -> return gccProg
-
- configureLd :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
- configureLd v ldProg = do
- ldProg' <- configureLd' v ldProg
- return ldProg' {
- programDefaultArgs = programDefaultArgs ldProg' ++ ldLinkerFlags
- }
-
- -- we need to find out if ld supports the -x flag
- configureLd' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
- configureLd' verbosity ldProg = do
- tempDir <- getTemporaryDirectory
- ldx <- withTempFile tempDir ".c" $ \testcfile testchnd ->
- withTempFile tempDir ".o" $ \testofile testohnd -> do
- hPutStrLn testchnd "int foo() { return 0; }"
- hClose testchnd; hClose testohnd
- rawSystemProgram verbosity ghcProg ["-c", testcfile,
- "-o", testofile]
- withTempFile tempDir ".o" $ \testofile' testohnd' ->
- do
- hClose testohnd'
- _ <- rawSystemProgramStdout verbosity ldProg
- ["-x", "-r", testofile, "-o", testofile']
- return True
- `catchIO` (\_ -> return False)
- `catchExit` (\_ -> return False)
- if ldx
- then return ldProg { programDefaultArgs = ["-x"] }
- else return ldProg
-
-getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, Flag)]
-getLanguages _ ghcProg
- -- TODO: should be using --supported-languages rather than hard coding
- | ghcVersion >= Version [7] [] = return [(Haskell98, "-XHaskell98")
- ,(Haskell2010, "-XHaskell2010")]
- | otherwise = return [(Haskell98, "")]
- where
- Just ghcVersion = programVersion ghcProg
+-- > /usr/local/bin/haddock-ghc-6.6.1(.exe)
+-- > /usr/local/bin/haddock-6.6.1(.exe)
+-- > /usr/local/bin/haddock(.exe)
+--
+guessHaddockFromGhcPath :: ConfiguredProgram
+ -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath)
+guessHaddockFromGhcPath = guessToolFromGhcPath haddockProgram
getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)]
-getGhcInfo verbosity ghcProg =
- case programVersion ghcProg of
- Just ghcVersion
- | ghcVersion >= Version [6,7] [] ->
- do xs <- getProgramOutput verbosity (suppressOverrideArgs ghcProg)
- ["--info"]
- case reads xs of
- [(i, ss)]
- | all isSpace ss ->
- return i
- _ ->
- die "Can't parse --info output of GHC"
- _ ->
- return []
-
-getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Flag)]
-getExtensions verbosity ghcProg
- | ghcVersion >= Version [6,7] [] = do
-
- str <- getProgramOutput verbosity (suppressOverrideArgs ghcProg)
- ["--supported-languages"]
- let extStrs = if ghcVersion >= Version [7] []
- then lines str
- else -- Older GHCs only gave us either Foo or NoFoo,
- -- so we have to work out the other one ourselves
- [ extStr''
- | extStr <- lines str
- , let extStr' = case extStr of
- 'N' : 'o' : xs -> xs
- _ -> "No" ++ extStr
- , extStr'' <- [extStr, extStr']
- ]
- let extensions0 = [ (ext, "-X" ++ display ext)
- | Just ext <- map simpleParse extStrs ]
- extensions1 = if ghcVersion >= Version [6,8] [] &&
- ghcVersion < Version [6,10] []
- then -- ghc-6.8 introduced RecordPuns however it
- -- should have been NamedFieldPuns. We now
- -- encourage packages to use NamedFieldPuns
- -- so for compatability we fake support for
- -- it in ghc-6.8 by making it an alias for
- -- the old RecordPuns extension.
- (EnableExtension NamedFieldPuns, "-XRecordPuns") :
- (DisableExtension NamedFieldPuns, "-XNoRecordPuns") :
- extensions0
- else extensions0
- extensions2 = if ghcVersion < Version [7,1] []
- then -- ghc-7.2 split NondecreasingIndentation off
- -- into a proper extension. Before that it
- -- was always on.
- (EnableExtension NondecreasingIndentation, "") :
- (DisableExtension NondecreasingIndentation, "") :
- extensions1
- else extensions1
- return extensions2
-
- | otherwise = return oldLanguageExtensions
-
+getGhcInfo verbosity ghcProg = Internal.getGhcInfo verbosity implInfo ghcProg
where
- Just ghcVersion = programVersion ghcProg
+ Just version = programVersion ghcProg
+ implInfo = ghcVersionImplInfo version
--- | For GHC 6.6.x and earlier, the mapping from supported extensions to flags
-oldLanguageExtensions :: [(Extension, Flag)]
-oldLanguageExtensions =
- let doFlag (f, (enable, disable)) = [(EnableExtension f, enable),
- (DisableExtension f, disable)]
- fglasgowExts = ("-fglasgow-exts",
- "") -- This is wrong, but we don't want to turn
- -- all the extensions off when asked to just
- -- turn one off
- fFlag flag = ("-f" ++ flag, "-fno-" ++ flag)
- in concatMap doFlag
- [(OverlappingInstances , fFlag "allow-overlapping-instances")
- ,(TypeSynonymInstances , fglasgowExts)
- ,(TemplateHaskell , fFlag "th")
- ,(ForeignFunctionInterface , fFlag "ffi")
- ,(MonomorphismRestriction , fFlag "monomorphism-restriction")
- ,(MonoPatBinds , fFlag "mono-pat-binds")
- ,(UndecidableInstances , fFlag "allow-undecidable-instances")
- ,(IncoherentInstances , fFlag "allow-incoherent-instances")
- ,(Arrows , fFlag "arrows")
- ,(Generics , fFlag "generics")
- ,(ImplicitPrelude , fFlag "implicit-prelude")
- ,(ImplicitParams , fFlag "implicit-params")
- ,(CPP , ("-cpp", ""{- Wrong -}))
- ,(BangPatterns , fFlag "bang-patterns")
- ,(KindSignatures , fglasgowExts)
- ,(RecursiveDo , fglasgowExts)
- ,(ParallelListComp , fglasgowExts)
- ,(MultiParamTypeClasses , fglasgowExts)
- ,(FunctionalDependencies , fglasgowExts)
- ,(Rank2Types , fglasgowExts)
- ,(RankNTypes , fglasgowExts)
- ,(PolymorphicComponents , fglasgowExts)
- ,(ExistentialQuantification , fglasgowExts)
- ,(ScopedTypeVariables , fFlag "scoped-type-variables")
- ,(FlexibleContexts , fglasgowExts)
- ,(FlexibleInstances , fglasgowExts)
- ,(EmptyDataDecls , fglasgowExts)
- ,(PatternGuards , fglasgowExts)
- ,(GeneralizedNewtypeDeriving , fglasgowExts)
- ,(MagicHash , fglasgowExts)
- ,(UnicodeSyntax , fglasgowExts)
- ,(PatternSignatures , fglasgowExts)
- ,(UnliftedFFITypes , fglasgowExts)
- ,(LiberalTypeSynonyms , fglasgowExts)
- ,(TypeOperators , fglasgowExts)
- ,(GADTs , fglasgowExts)
- ,(RelaxedPolyRec , fglasgowExts)
- ,(ExtendedDefaultRules , fFlag "extended-default-rules")
- ,(UnboxedTuples , fglasgowExts)
- ,(DeriveDataTypeable , fglasgowExts)
- ,(ConstrainedClassMethods , fglasgowExts)
- ]
-- | Given a single package DB, return all installed packages.
getPackageDBContents :: Verbosity -> PackageDB -> ProgramConfiguration
- -> IO PackageIndex
+ -> IO InstalledPackageIndex
getPackageDBContents verbosity packagedb conf = do
pkgss <- getInstalledPackages' verbosity [packagedb] conf
toPackageIndex verbosity pkgss conf
-- | Given a package DB stack, return all installed packages.
-getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration
- -> IO PackageIndex
-getInstalledPackages verbosity packagedbs conf = do
+getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack -> ProgramConfiguration
+ -> IO InstalledPackageIndex
+getInstalledPackages verbosity comp packagedbs conf = do
checkPackageDbEnvVar
- checkPackageDbStack packagedbs
+ checkPackageDbStack comp packagedbs
pkgss <- getInstalledPackages' verbosity packagedbs conf
index <- toPackageIndex verbosity pkgss conf
return $! hackRtsPackage index
@@ -548,7 +288,7 @@ getInstalledPackages verbosity packagedbs conf = do
[(_,[rts])]
-> PackageIndex.insert (removeMingwIncludeDir rts) index
_ -> index -- No (or multiple) ghc rts package is registered!!
- -- Feh, whatever, the ghc testsuite does some crazy stuff.
+ -- Feh, whatever, the ghc test suite does some crazy stuff.
-- | Given a list of @(PackageDB, InstalledPackageInfo)@ pairs, produce a
-- @PackageIndex@. Helper function used by 'getPackageDBContents' and
@@ -556,52 +296,65 @@ getInstalledPackages verbosity packagedbs conf = do
toPackageIndex :: Verbosity
-> [(PackageDB, [InstalledPackageInfo])]
-> ProgramConfiguration
- -> IO PackageIndex
+ -> IO InstalledPackageIndex
toPackageIndex verbosity pkgss conf = do
-- On Windows, various fields have $topdir/foo rather than full
-- paths. We need to substitute the right value in so that when
-- we, for example, call gcc, we have proper paths to give it.
- topDir <- ghcLibDir' verbosity ghcProg
- let indices = [ PackageIndex.fromList (map (substTopDir topDir) pkgs)
+ topDir <- getLibDir' verbosity ghcProg
+ let indices = [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs)
| (_, pkgs) <- pkgss ]
return $! (mconcat indices)
where
Just ghcProg = lookupProgram ghcProgram conf
-ghcLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath
-ghcLibDir verbosity lbi =
- (reverse . dropWhile isSpace . reverse) `fmap`
+getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath
+getLibDir verbosity lbi =
+ dropWhileEndLE isSpace `fmap`
rawSystemProgramStdoutConf verbosity ghcProgram
(withPrograms lbi) ["--print-libdir"]
-ghcLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath
-ghcLibDir' verbosity ghcProg =
- (reverse . dropWhile isSpace . reverse) `fmap`
+getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath
+getLibDir' verbosity ghcProg =
+ dropWhileEndLE isSpace `fmap`
rawSystemProgramStdout verbosity ghcProg ["--print-libdir"]
--- Cabal does not use the environment variable GHC_PACKAGE_PATH; let users
--- know that this is the case. See ticket #335. Simply ignoring it is not a
--- good idea, since then ghc and cabal are looking at different sets of
--- package dbs and chaos is likely to ensue.
+
+-- | Return the 'FilePath' to the global GHC package database.
+getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath
+getGlobalPackageDB verbosity ghcProg =
+ dropWhileEndLE isSpace `fmap`
+ rawSystemProgramStdout verbosity ghcProg ["--print-global-package-db"]
+
checkPackageDbEnvVar :: IO ()
-checkPackageDbEnvVar = do
- hasGPP <- (getEnv "GHC_PACKAGE_PATH" >> return True)
- `catchIO` (\_ -> return False)
- when hasGPP $
- die $ "Use of GHC's environment variable GHC_PACKAGE_PATH is "
- ++ "incompatible with Cabal. Use the flag --package-db to specify a "
- ++ "package database (it can be used multiple times)."
-
-checkPackageDbStack :: PackageDBStack -> IO ()
-checkPackageDbStack (GlobalPackageDB:rest)
+checkPackageDbEnvVar =
+ Internal.checkPackageDbEnvVar "GHC" "GHC_PACKAGE_PATH"
+
+checkPackageDbStack :: Compiler -> PackageDBStack -> IO ()
+checkPackageDbStack comp = if flagPackageConf implInfo
+ then checkPackageDbStackPre76
+ else checkPackageDbStackPost76
+ where implInfo = ghcVersionImplInfo (compilerVersion comp)
+
+checkPackageDbStackPost76 :: PackageDBStack -> IO ()
+checkPackageDbStackPost76 (GlobalPackageDB:rest)
+ | GlobalPackageDB `notElem` rest = return ()
+checkPackageDbStackPost76 rest
+ | GlobalPackageDB `elem` rest =
+ die $ "If the global package db is specified, it must be "
+ ++ "specified first and cannot be specified multiple times"
+checkPackageDbStackPost76 _ = return ()
+
+checkPackageDbStackPre76 :: PackageDBStack -> IO ()
+checkPackageDbStackPre76 (GlobalPackageDB:rest)
| GlobalPackageDB `notElem` rest = return ()
-checkPackageDbStack rest
+checkPackageDbStackPre76 rest
| GlobalPackageDB `notElem` rest =
die $ "With current ghc versions the global package db is always used "
- ++ "and must be listed first. This ghc limitation may be lifted in "
- ++ "future, see http://hackage.haskell.org/trac/ghc/ticket/5977"
-checkPackageDbStack _ =
+ ++ "and must be listed first. This ghc limitation is lifted in GHC 7.6,"
+ ++ "see http://hackage.haskell.org/trac/ghc/ticket/5977"
+checkPackageDbStackPre76 _ =
die $ "If the global package db is specified, it must be "
++ "specified first and cannot be specified multiple times"
@@ -621,12 +374,11 @@ getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramConfiguration
getInstalledPackages' verbosity packagedbs conf
| ghcVersion >= Version [6,9] [] =
sequence
- [ do pkgs <- HcPkg.dump verbosity ghcPkgProg packagedb
+ [ do pkgs <- HcPkg.dump (hcPkgInfo conf) verbosity packagedb
return (packagedb, pkgs)
| packagedb <- packagedbs ]
where
- Just ghcPkgProg = lookupProgram ghcPkgProgram conf
Just ghcProg = lookupProgram ghcProgram conf
Just ghcVersion = programVersion ghcProg
@@ -661,25 +413,6 @@ getInstalledPackages' verbosity packagedbs conf = do
Just ghcVersion = programVersion ghcProg
failToRead file = die $ "cannot read ghc package database " ++ file
-substTopDir :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo
-substTopDir topDir ipo
- = ipo {
- InstalledPackageInfo.importDirs
- = map f (InstalledPackageInfo.importDirs ipo),
- InstalledPackageInfo.libraryDirs
- = map f (InstalledPackageInfo.libraryDirs ipo),
- InstalledPackageInfo.includeDirs
- = map f (InstalledPackageInfo.includeDirs ipo),
- InstalledPackageInfo.frameworkDirs
- = map f (InstalledPackageInfo.frameworkDirs ipo),
- InstalledPackageInfo.haddockInterfaces
- = map f (InstalledPackageInfo.haddockInterfaces ipo),
- InstalledPackageInfo.haddockHTMLs
- = map f (InstalledPackageInfo.haddockHTMLs ipo)
- }
- where f ('$':'t':'o':'p':'d':'i':'r':rest) = topDir ++ rest
- f x = x
-
-- -----------------------------------------------------------------------------
-- Building
@@ -694,24 +427,20 @@ replLib = buildOrReplLib True
buildOrReplLib :: Bool -> Verbosity -> Cabal.Flag (Maybe Int)
-> PackageDescription -> LocalBuildInfo
-> Library -> ComponentLocalBuildInfo -> IO ()
-buildOrReplLib forRepl verbosity numJobsFlag pkg_descr lbi lib clbi = do
- libName <- case componentLibraries clbi of
- [libName] -> return libName
- [] -> die "No library name found when building library"
- _ -> die "Multiple library names found when building library"
-
- let libTargetDir = buildDir lbi
- numJobs = fromMaybe 1 $ fromFlagOrDefault Nothing numJobsFlag
- pkgid = packageId pkg_descr
+buildOrReplLib forRepl verbosity numJobs pkg_descr lbi lib clbi = do
+ let libName = componentLibraryName clbi
+ libTargetDir = buildDir lbi
whenVanillaLib forceVanilla =
- when (not forRepl && (forceVanilla || withVanillaLib lbi))
- whenProfLib = when (not forRepl && withProfLib lbi)
+ when (forceVanilla || withVanillaLib lbi)
+ whenProfLib = when (withProfLib lbi)
whenSharedLib forceShared =
- when (not forRepl && (forceShared || withSharedLib lbi))
- whenGHCiLib = when (not forRepl && withGHCiLib lbi && withVanillaLib lbi)
+ when (forceShared || withSharedLib lbi)
+ whenGHCiLib = when (withGHCiLib lbi && withVanillaLib lbi)
ifReplLib = when forRepl
comp = compiler lbi
ghcVersion = compilerVersion comp
+ implInfo = getImplInfo comp
+ (Platform _hostArch hostOS) = hostPlatform lbi
(ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi)
let runGhcProg = runGHC verbosity ghcProg comp
@@ -719,13 +448,25 @@ buildOrReplLib forRepl verbosity numJobsFlag pkg_descr lbi lib clbi = do
libBi <- hackThreadedFlag verbosity
comp (withProfLib lbi) (libBuildInfo lib)
- let isGhcDynamic = ghcDynamic comp
- dynamicTooSupported = ghcSupportsDynamicToo comp
+ let isGhcDynamic = isDynamic comp
+ dynamicTooSupported = supportsDynamicToo comp
doingTH = EnableExtension TemplateHaskell `elem` allExtensions libBi
forceVanillaLib = doingTH && not isGhcDynamic
forceSharedLib = doingTH && isGhcDynamic
-- TH always needs default libs, even when building for profiling
+ -- Determine if program coverage should be enabled and if so, what
+ -- '-hpcdir' should be.
+ let isCoverageEnabled = fromFlag $ configCoverage $ configFlags lbi
+ -- Component name. Not 'libName' because that has the "HS" prefix
+ -- that GHC gives Haskell libraries.
+ cname = display $ PD.package $ localPkgDescr lbi
+ distPref = fromFlag $ configDistPref $ configFlags lbi
+ hpcdir way
+ | forRepl = mempty -- HPC is not supported in ghci
+ | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way cname
+ | otherwise = mempty
+
createDirectoryIfMissingVerbose verbosity True libTargetDir
-- TODO: do we need to put hs-boot files into place for mutually recursive
-- modules?
@@ -733,16 +474,19 @@ buildOrReplLib forRepl verbosity numJobsFlag pkg_descr lbi lib clbi = do
baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir
vanillaOpts = baseOpts `mappend` mempty {
ghcOptMode = toFlag GhcModeMake,
- ghcOptNumJobs = toFlag numJobs,
- ghcOptPackageName = toFlag pkgid,
- ghcOptInputModules = libModules lib
+ ghcOptNumJobs = numJobs,
+ ghcOptInputModules = toNubListR $ libModules lib,
+ ghcOptHPCDir = hpcdir Hpc.Vanilla
}
profOpts = vanillaOpts `mappend` mempty {
ghcOptProfilingMode = toFlag True,
+ ghcOptProfilingAuto = Internal.profDetailLevelFlag True
+ (withProfLibDetail lbi),
ghcOptHiSuffix = toFlag "p_hi",
ghcOptObjSuffix = toFlag "p_o",
- ghcOptExtra = ghcProfOptions libBi
+ ghcOptExtra = toNubListR $ hcProfOptions GHC libBi,
+ ghcOptHPCDir = hpcdir Hpc.Prof
}
sharedOpts = vanillaOpts `mappend` mempty {
@@ -750,17 +494,20 @@ buildOrReplLib forRepl verbosity numJobsFlag pkg_descr lbi lib clbi = do
ghcOptFPic = toFlag True,
ghcOptHiSuffix = toFlag "dyn_hi",
ghcOptObjSuffix = toFlag "dyn_o",
- ghcOptExtra = ghcSharedOptions libBi
+ ghcOptExtra = toNubListR $ hcSharedOptions GHC libBi,
+ ghcOptHPCDir = hpcdir Hpc.Dyn
}
linkerOpts = mempty {
- ghcOptLinkOptions = PD.ldOptions libBi,
- ghcOptLinkLibs = extraLibs libBi,
- ghcOptLinkLibPath = extraLibDirs libBi,
- ghcOptLinkFrameworks = PD.frameworks libBi,
- ghcOptInputFiles = [libTargetDir </> x | x <- cObjs]
+ ghcOptLinkOptions = toNubListR $ PD.ldOptions libBi,
+ ghcOptLinkLibs = toNubListR $ extraLibs libBi,
+ ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi,
+ ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi,
+ ghcOptInputFiles = toNubListR
+ [libTargetDir </> x | x <- cObjs]
}
replOpts = vanillaOpts {
- ghcOptExtra = filterGhciFlags
+ ghcOptExtra = overNubListR
+ Internal.filterGhciFlags $
(ghcOptExtra vanillaOpts),
ghcOptNumJobs = mempty
}
@@ -773,149 +520,177 @@ buildOrReplLib forRepl verbosity numJobsFlag pkg_descr lbi lib clbi = do
vanillaSharedOpts = vanillaOpts `mappend` mempty {
ghcOptDynLinkMode = toFlag GhcStaticAndDynamic,
ghcOptDynHiSuffix = toFlag "dyn_hi",
- ghcOptDynObjSuffix = toFlag "dyn_o"
+ ghcOptDynObjSuffix = toFlag "dyn_o",
+ ghcOptHPCDir = hpcdir Hpc.Dyn
}
- unless (null (libModules lib)) $
+ unless (forRepl || null (libModules lib)) $
do let vanilla = whenVanillaLib forceVanillaLib (runGhcProg vanillaOpts)
shared = whenSharedLib forceSharedLib (runGhcProg sharedOpts)
useDynToo = dynamicTooSupported &&
(forceVanillaLib || withVanillaLib lbi) &&
(forceSharedLib || withSharedLib lbi) &&
- null (ghcSharedOptions libBi)
+ null (hcSharedOptions GHC libBi)
if useDynToo
- then runGhcProg vanillaSharedOpts
- else if isGhcDynamic then do shared; vanilla
- else do vanilla; shared
+ then do
+ runGhcProg vanillaSharedOpts
+ case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of
+ (Cabal.Flag dynDir, Cabal.Flag vanillaDir) -> do
+ -- When the vanilla and shared library builds are done
+ -- in one pass, only one set of HPC module interfaces
+ -- are generated. This set should suffice for both
+ -- static and dynamically linked executables. We copy
+ -- the modules interfaces so they are available under
+ -- both ways.
+ copyDirectoryRecursive verbosity dynDir vanillaDir
+ _ -> return ()
+ else if isGhcDynamic
+ then do shared; vanilla
+ else do vanilla; shared
whenProfLib (runGhcProg profOpts)
-- build any C sources
unless (null (cSources libBi)) $ do
- info verbosity "Building C Sources..."
- sequence_
- [ do let vanillaCcOpts = (componentCcGhcOptions verbosity lbi
- libBi clbi libTargetDir filename)
- profCcOpts = vanillaCcOpts `mappend` mempty {
- ghcOptProfilingMode = toFlag True,
- ghcOptObjSuffix = toFlag "p_o"
- }
- sharedCcOpts = vanillaCcOpts `mappend` mempty {
- ghcOptFPic = toFlag True,
- ghcOptDynLinkMode = toFlag GhcDynamicOnly,
- ghcOptObjSuffix = toFlag "dyn_o"
- }
- odir = fromFlag (ghcOptObjDir vanillaCcOpts)
- createDirectoryIfMissingVerbose verbosity True odir
- runGhcProg vanillaCcOpts
- whenSharedLib forceSharedLib (runGhcProg sharedCcOpts)
- whenProfLib (runGhcProg profCcOpts)
- | filename <- cSources libBi]
+ info verbosity "Building C Sources..."
+ sequence_
+ [ do let baseCcOpts = Internal.componentCcGhcOptions verbosity implInfo
+ lbi libBi clbi libTargetDir filename
+ vanillaCcOpts = if isGhcDynamic
+ -- Dynamic GHC requires C sources to be built
+ -- with -fPIC for REPL to work. See #2207.
+ then baseCcOpts { ghcOptFPic = toFlag True }
+ else baseCcOpts
+ profCcOpts = vanillaCcOpts `mappend` mempty {
+ ghcOptProfilingMode = toFlag True,
+ ghcOptObjSuffix = toFlag "p_o"
+ }
+ sharedCcOpts = vanillaCcOpts `mappend` mempty {
+ ghcOptFPic = toFlag True,
+ ghcOptDynLinkMode = toFlag GhcDynamicOnly,
+ ghcOptObjSuffix = toFlag "dyn_o"
+ }
+ odir = fromFlag (ghcOptObjDir vanillaCcOpts)
+ createDirectoryIfMissingVerbose verbosity True odir
+ needsRecomp <- checkNeedsRecompilation filename vanillaCcOpts
+ when needsRecomp $ do
+ runGhcProg vanillaCcOpts
+ unless forRepl $
+ whenSharedLib forceSharedLib (runGhcProg sharedCcOpts)
+ unless forRepl $ whenProfLib (runGhcProg profCcOpts)
+ | filename <- cSources libBi]
-- TODO: problem here is we need the .c files built first, so we can load them
-- with ghci, but .c files can depend on .h files generated by ghc by ffi
-- exports.
- unless (null (libModules lib)) $
- ifReplLib (runGhcProg replOpts)
+ ifReplLib $ do
+ when (null (libModules lib)) $ warn verbosity "No exposed modules"
+ ifReplLib (runGhcProg replOpts)
-- link:
- info verbosity "Linking..."
- let cProfObjs = map (`replaceExtension` ("p_" ++ objExtension))
- (cSources libBi)
- cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension))
- (cSources libBi)
- cid = compilerId (compiler lbi)
- vanillaLibFilePath = libTargetDir </> mkLibName libName
- profileLibFilePath = libTargetDir </> mkProfLibName libName
- sharedLibFilePath = libTargetDir </> mkSharedLibName cid libName
- ghciLibFilePath = libTargetDir </> mkGHCiLibName libName
- libInstallPath = libdir $ absoluteInstallDirs pkg_descr lbi NoCopyDest
- sharedLibInstallPath = libInstallPath </> mkSharedLibName cid libName
-
- stubObjs <- fmap catMaybes $ sequence
- [ findFileWithExtension [objExtension] [libTargetDir]
- (ModuleName.toFilePath x ++"_stub")
- | ghcVersion < Version [7,2] [] -- ghc-7.2+ does not make _stub.o files
- , x <- libModules lib ]
- stubProfObjs <- fmap catMaybes $ sequence
- [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir]
- (ModuleName.toFilePath x ++"_stub")
- | ghcVersion < Version [7,2] [] -- ghc-7.2+ does not make _stub.o files
- , x <- libModules lib ]
- stubSharedObjs <- fmap catMaybes $ sequence
- [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir]
- (ModuleName.toFilePath x ++"_stub")
- | ghcVersion < Version [7,2] [] -- ghc-7.2+ does not make _stub.o files
- , x <- libModules lib ]
-
- hObjs <- getHaskellObjects lib lbi
- libTargetDir objExtension True
- hProfObjs <-
- if (withProfLib lbi)
- then getHaskellObjects lib lbi
- libTargetDir ("p_" ++ objExtension) True
- else return []
- hSharedObjs <-
- if (withSharedLib lbi)
- then getHaskellObjects lib lbi
- libTargetDir ("dyn_" ++ objExtension) False
- else return []
-
- unless (null hObjs && null cObjs && null stubObjs) $ do
-
- let staticObjectFiles =
- hObjs
- ++ map (libTargetDir </>) cObjs
- ++ stubObjs
- profObjectFiles =
- hProfObjs
- ++ map (libTargetDir </>) cProfObjs
- ++ stubProfObjs
- ghciObjFiles =
- hObjs
- ++ map (libTargetDir </>) cObjs
- ++ stubObjs
- dynamicObjectFiles =
- hSharedObjs
- ++ map (libTargetDir </>) cSharedObjs
- ++ stubSharedObjs
- -- After the relocation lib is created we invoke ghc -shared
- -- with the dependencies spelled out as -package arguments
- -- and ghc invokes the linker with the proper library paths
- ghcSharedLinkArgs =
- mempty {
- ghcOptShared = toFlag True,
- ghcOptDynLinkMode = toFlag GhcDynamicOnly,
- ghcOptInputFiles = dynamicObjectFiles,
- ghcOptOutputFile = toFlag sharedLibFilePath,
- -- For dynamic libs, Mac OS/X needs to know the install location
- -- at build time.
- ghcOptDylibName = if buildOS == OSX
- then toFlag sharedLibInstallPath
- else mempty,
- ghcOptPackageName = toFlag pkgid,
- ghcOptNoAutoLinkPackages = toFlag True,
- ghcOptPackageDBs = withPackageDB lbi,
- ghcOptPackages = componentPackageDeps clbi,
- ghcOptLinkLibs = extraLibs libBi,
- ghcOptLinkLibPath = extraLibDirs libBi
- }
-
- whenVanillaLib False $ do
- Ar.createArLibArchive verbosity (withPrograms lbi) (stripLibs lbi)
- vanillaLibFilePath staticObjectFiles
-
- whenProfLib $ do
- Ar.createArLibArchive verbosity (withPrograms lbi) (stripLibs lbi)
- profileLibFilePath profObjectFiles
-
- whenGHCiLib $ do
- (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi)
- Ld.combineObjectFiles verbosity ldProg
- ghciLibFilePath ghciObjFiles
-
- whenSharedLib False $
- runGhcProg ghcSharedLinkArgs
+ unless forRepl $ do
+ info verbosity "Linking..."
+ let cProfObjs = map (`replaceExtension` ("p_" ++ objExtension))
+ (cSources libBi)
+ cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension))
+ (cSources libBi)
+ cid = compilerId (compiler lbi)
+ vanillaLibFilePath = libTargetDir </> mkLibName libName
+ profileLibFilePath = libTargetDir </> mkProfLibName libName
+ sharedLibFilePath = libTargetDir </> mkSharedLibName cid libName
+ ghciLibFilePath = libTargetDir </> Internal.mkGHCiLibName libName
+ libInstallPath = libdir $ absoluteInstallDirs pkg_descr lbi NoCopyDest
+ sharedLibInstallPath = libInstallPath </> mkSharedLibName cid libName
+
+ stubObjs <- fmap catMaybes $ sequence
+ [ findFileWithExtension [objExtension] [libTargetDir]
+ (ModuleName.toFilePath x ++"_stub")
+ | ghcVersion < Version [7,2] [] -- ghc-7.2+ does not make _stub.o files
+ , x <- libModules lib ]
+ stubProfObjs <- fmap catMaybes $ sequence
+ [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir]
+ (ModuleName.toFilePath x ++"_stub")
+ | ghcVersion < Version [7,2] [] -- ghc-7.2+ does not make _stub.o files
+ , x <- libModules lib ]
+ stubSharedObjs <- fmap catMaybes $ sequence
+ [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir]
+ (ModuleName.toFilePath x ++"_stub")
+ | ghcVersion < Version [7,2] [] -- ghc-7.2+ does not make _stub.o files
+ , x <- libModules lib ]
+
+ hObjs <- Internal.getHaskellObjects implInfo lib lbi
+ libTargetDir objExtension True
+ hProfObjs <-
+ if (withProfLib lbi)
+ then Internal.getHaskellObjects implInfo lib lbi
+ libTargetDir ("p_" ++ objExtension) True
+ else return []
+ hSharedObjs <-
+ if (withSharedLib lbi)
+ then Internal.getHaskellObjects implInfo lib lbi
+ libTargetDir ("dyn_" ++ objExtension) False
+ else return []
+
+ unless (null hObjs && null cObjs && null stubObjs) $ do
+ rpaths <- getRPaths lbi clbi
+
+ let staticObjectFiles =
+ hObjs
+ ++ map (libTargetDir </>) cObjs
+ ++ stubObjs
+ profObjectFiles =
+ hProfObjs
+ ++ map (libTargetDir </>) cProfObjs
+ ++ stubProfObjs
+ ghciObjFiles =
+ hObjs
+ ++ map (libTargetDir </>) cObjs
+ ++ stubObjs
+ dynamicObjectFiles =
+ hSharedObjs
+ ++ map (libTargetDir </>) cSharedObjs
+ ++ stubSharedObjs
+ -- After the relocation lib is created we invoke ghc -shared
+ -- with the dependencies spelled out as -package arguments
+ -- and ghc invokes the linker with the proper library paths
+ ghcSharedLinkArgs =
+ mempty {
+ ghcOptShared = toFlag True,
+ ghcOptDynLinkMode = toFlag GhcDynamicOnly,
+ ghcOptInputFiles = toNubListR dynamicObjectFiles,
+ ghcOptOutputFile = toFlag sharedLibFilePath,
+ -- For dynamic libs, Mac OS/X needs to know the install location
+ -- at build time. This only applies to GHC < 7.8 - see the
+ -- discussion in #1660.
+ ghcOptDylibName = if (hostOS == OSX
+ && ghcVersion < Version [7,8] [])
+ then toFlag sharedLibInstallPath
+ else mempty,
+ ghcOptNoAutoLinkPackages = toFlag True,
+ ghcOptPackageDBs = withPackageDB lbi,
+ ghcOptPackages = toNubListR $
+ Internal.mkGhcOptPackages clbi ,
+ ghcOptLinkLibs = toNubListR $ extraLibs libBi,
+ ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi,
+ ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi,
+ ghcOptRPaths = rpaths
+ }
+
+ info verbosity (show (ghcOptPackages ghcSharedLinkArgs))
+
+ whenVanillaLib False $ do
+ Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles
+
+ whenProfLib $ do
+ Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles
+
+ whenGHCiLib $ do
+ (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi)
+ Ld.combineObjectFiles verbosity ldProg
+ ghciLibFilePath ghciObjFiles
+
+ whenSharedLib False $
+ runGhcProg ghcSharedLinkArgs
-- | Start a REPL without loading any source files.
startInterpreter :: Verbosity -> ProgramConfiguration -> Compiler
@@ -925,7 +700,7 @@ startInterpreter verbosity conf comp packageDBs = do
ghcOptMode = toFlag GhcModeInteractive,
ghcOptPackageDBs = packageDBs
}
- checkPackageDbStack packageDBs
+ checkPackageDbStack comp packageDBs
(ghcProg, _) <- requireProgram verbosity ghcProgram conf
runGHC verbosity ghcProg comp replOpts
@@ -940,13 +715,12 @@ replExe = buildOrReplExe True
buildOrReplExe :: Bool -> Verbosity -> Cabal.Flag (Maybe Int)
-> PackageDescription -> LocalBuildInfo
-> Executable -> ComponentLocalBuildInfo -> IO ()
-buildOrReplExe forRepl verbosity numJobsFlag _pkg_descr lbi
+buildOrReplExe forRepl verbosity numJobs _pkg_descr lbi
exe@Executable { exeName = exeName', modulePath = modPath } clbi = do
(ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi)
let comp = compiler lbi
- numJobs = fromMaybe 1 $
- fromFlagOrDefault Nothing numJobsFlag
+ implInfo = getImplInfo comp
runGhcProg = runGHC verbosity ghcProg comp
exeBi <- hackThreadedFlag verbosity
@@ -965,51 +739,74 @@ buildOrReplExe forRepl verbosity numJobsFlag _pkg_descr lbi
-- TODO: do we need to put hs-boot files into place for mutually recursive
-- modules? FIX: what about exeName.hi-boot?
+ -- Determine if program coverage should be enabled and if so, what
+ -- '-hpcdir' should be.
+ let isCoverageEnabled = fromFlag $ configCoverage $ configFlags lbi
+ distPref = fromFlag $ configDistPref $ configFlags lbi
+ hpcdir way
+ | forRepl = mempty -- HPC is not supported in ghci
+ | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way exeName'
+ | otherwise = mempty
+
-- build executables
srcMainFile <- findFile (exeDir : hsSourceDirs exeBi) modPath
- let isGhcDynamic = ghcDynamic comp
- dynamicTooSupported = ghcSupportsDynamicToo comp
+ rpaths <- getRPaths lbi clbi
+
+ let isGhcDynamic = isDynamic comp
+ dynamicTooSupported = supportsDynamicToo comp
isHaskellMain = elem (takeExtension srcMainFile) [".hs", ".lhs"]
cSrcs = cSources exeBi ++ [srcMainFile | not isHaskellMain]
cObjs = map (`replaceExtension` objExtension) cSrcs
baseOpts = (componentGhcOptions verbosity lbi exeBi clbi exeDir)
`mappend` mempty {
ghcOptMode = toFlag GhcModeMake,
- ghcOptInputFiles =
+ ghcOptInputFiles = toNubListR
[ srcMainFile | isHaskellMain],
- ghcOptInputModules =
+ ghcOptInputModules = toNubListR
[ m | not isHaskellMain, m <- exeModules exe]
}
staticOpts = baseOpts `mappend` mempty {
- ghcOptDynLinkMode = toFlag GhcStaticOnly
+ ghcOptDynLinkMode = toFlag GhcStaticOnly,
+ ghcOptHPCDir = hpcdir Hpc.Vanilla
}
profOpts = baseOpts `mappend` mempty {
ghcOptProfilingMode = toFlag True,
+ ghcOptProfilingAuto = Internal.profDetailLevelFlag False
+ (withProfExeDetail lbi),
ghcOptHiSuffix = toFlag "p_hi",
ghcOptObjSuffix = toFlag "p_o",
- ghcOptExtra = ghcProfOptions exeBi
+ ghcOptExtra = toNubListR (hcProfOptions GHC exeBi),
+ ghcOptHPCDir = hpcdir Hpc.Prof
}
dynOpts = baseOpts `mappend` mempty {
ghcOptDynLinkMode = toFlag GhcDynamicOnly,
ghcOptHiSuffix = toFlag "dyn_hi",
ghcOptObjSuffix = toFlag "dyn_o",
- ghcOptExtra = ghcSharedOptions exeBi
+ ghcOptExtra = toNubListR $
+ hcSharedOptions GHC exeBi,
+ ghcOptHPCDir = hpcdir Hpc.Dyn
}
dynTooOpts = staticOpts `mappend` mempty {
ghcOptDynLinkMode = toFlag GhcStaticAndDynamic,
ghcOptDynHiSuffix = toFlag "dyn_hi",
- ghcOptDynObjSuffix = toFlag "dyn_o"
+ ghcOptDynObjSuffix = toFlag "dyn_o",
+ ghcOptHPCDir = hpcdir Hpc.Dyn
}
linkerOpts = mempty {
- ghcOptLinkOptions = PD.ldOptions exeBi,
- ghcOptLinkLibs = extraLibs exeBi,
- ghcOptLinkLibPath = extraLibDirs exeBi,
- ghcOptLinkFrameworks = PD.frameworks exeBi,
- ghcOptInputFiles = [exeDir </> x | x <- cObjs]
+ ghcOptLinkOptions = toNubListR $ PD.ldOptions exeBi,
+ ghcOptLinkLibs = toNubListR $ extraLibs exeBi,
+ ghcOptLinkLibPath = toNubListR $ extraLibDirs exeBi,
+ ghcOptLinkFrameworks = toNubListR $ PD.frameworks exeBi,
+ ghcOptInputFiles = toNubListR
+ [exeDir </> x | x <- cObjs]
+ }
+ dynLinkerOpts = mempty {
+ ghcOptRPaths = rpaths
}
replOpts = baseOpts {
- ghcOptExtra = filterGhciFlags
+ ghcOptExtra = overNubListR
+ Internal.filterGhciFlags
(ghcOptExtra baseOpts)
}
-- For a normal compile we do separate invocations of ghc for
@@ -1037,9 +834,10 @@ buildOrReplExe forRepl verbosity numJobsFlag _pkg_descr lbi
-- With dynamic-by-default GHC the TH object files loaded at compile-time
-- need to be .dyn_o instead of .o.
doingTH = EnableExtension TemplateHaskell `elem` allExtensions exeBi
- -- Should we use -dynamic-too instead of compilng twice?
+ -- Should we use -dynamic-too instead of compiling twice?
useDynToo = dynamicTooSupported && isGhcDynamic
- && doingTH && withStaticExe && null (ghcSharedOptions exeBi)
+ && doingTH && withStaticExe
+ && null (hcSharedOptions GHC exeBi)
compileTHOpts | isGhcDynamic = dynOpts
| otherwise = staticOpts
compileForTH
@@ -1049,33 +847,35 @@ buildOrReplExe forRepl verbosity numJobsFlag _pkg_descr lbi
| otherwise = doingTH && (withProfExe lbi || withDynExe lbi)
linkOpts = commonOpts `mappend`
- linkerOpts `mappend` mempty {
- ghcOptLinkNoHsMain = toFlag (not isHaskellMain)
- }
+ linkerOpts `mappend`
+ mempty { ghcOptLinkNoHsMain = toFlag (not isHaskellMain) } `mappend`
+ (if withDynExe lbi then dynLinkerOpts else mempty)
-- Build static/dynamic object files for TH, if needed.
when compileForTH $
runGhcProg compileTHOpts { ghcOptNoLink = toFlag True
- , ghcOptNumJobs = toFlag numJobs }
+ , ghcOptNumJobs = numJobs }
unless forRepl $
runGhcProg compileOpts { ghcOptNoLink = toFlag True
- , ghcOptNumJobs = toFlag numJobs }
+ , ghcOptNumJobs = numJobs }
-- build any C sources
unless (null cSrcs) $ do
info verbosity "Building C Sources..."
sequence_
- [ do let opts = (componentCcGhcOptions verbosity lbi exeBi clbi
- exeDir filename) `mappend` mempty {
+ [ do let opts = (Internal.componentCcGhcOptions verbosity implInfo lbi exeBi
+ clbi exeDir filename) `mappend` mempty {
ghcOptDynLinkMode = toFlag (if withDynExe lbi
then GhcDynamicOnly
else GhcStaticOnly),
ghcOptProfilingMode = toFlag (withProfExe lbi)
}
- odir = fromFlag (ghcOptObjDir opts)
+ odir = fromFlag (ghcOptObjDir opts)
createDirectoryIfMissingVerbose verbosity True odir
- runGhcProg opts
+ needsRecomp <- checkNeedsRecompilation filename opts
+ when needsRecomp $
+ runGhcProg opts
| filename <- cSrcs ]
-- TODO: problem here is we need the .c files built first, so we can load them
@@ -1088,6 +888,64 @@ buildOrReplExe forRepl verbosity numJobsFlag _pkg_descr lbi
info verbosity "Linking..."
runGhcProg linkOpts { ghcOptOutputFile = toFlag (targetDir </> exeNameReal) }
+-- | Returns True if the modification date of the given source file is newer than
+-- the object file we last compiled for it, or if no object file exists yet.
+checkNeedsRecompilation :: FilePath -> GhcOptions -> IO Bool
+checkNeedsRecompilation filename opts = filename `moreRecentFile` oname
+ where oname = getObjectFileName filename opts
+
+-- | Finds the object file name of the given source file
+getObjectFileName :: FilePath -> GhcOptions -> FilePath
+getObjectFileName filename opts = oname
+ where odir = fromFlag (ghcOptObjDir opts)
+ oext = fromFlagOrDefault "o" (ghcOptObjSuffix opts)
+ oname = odir </> replaceExtension filename oext
+
+-- | Calculate the RPATHs for the component we are building.
+--
+-- Calculates relative RPATHs when 'relocatable' is set.
+getRPaths :: LocalBuildInfo
+ -> ComponentLocalBuildInfo -- ^ Component we are building
+ -> IO (NubListR FilePath)
+getRPaths lbi clbi | supportRPaths hostOS = do
+ libraryPaths <- depLibraryPaths False (relocatable lbi) lbi clbi
+ let hostPref = case hostOS of
+ OSX -> "@loader_path"
+ _ -> "$ORIGIN"
+ relPath p = if isRelative p then hostPref </> p else p
+ rpaths = toNubListR (map relPath libraryPaths)
+ return rpaths
+ where
+ (Platform _ hostOS) = hostPlatform lbi
+
+ -- The list of RPath-supported operating systems below reflects the
+ -- platforms on which Cabal's RPATH handling is tested. It does _NOT_
+ -- reflect whether the OS supports RPATH.
+
+ -- E.g. when this comment was written, the *BSD operating systems were
+ -- untested with regards to Cabal RPATH handling, and were hence set to
+ -- 'False', while those operating systems themselves do support RPATH.
+ supportRPaths Linux   = True
+ supportRPaths Windows = False
+ supportRPaths OSX   = True
+ supportRPaths FreeBSD   = False
+ supportRPaths OpenBSD   = False
+ supportRPaths NetBSD   = False
+ supportRPaths DragonFly = False
+ supportRPaths Solaris = False
+ supportRPaths AIX = False
+ supportRPaths HPUX = False
+ supportRPaths IRIX = False
+ supportRPaths HaLVM = False
+ supportRPaths IOS = False
+ supportRPaths Android = False
+ supportRPaths Ghcjs = False
+ supportRPaths Hurd = False
+ supportRPaths (OtherOS _) = False
+ -- Do _not_ add a default case so that we get a warning here when a new OS
+ -- is added.
+
+getRPaths _ _ = return mempty
-- | Filter the "-threaded" flag when profiling as it does not
-- work with ghc-6.8 and older.
@@ -1105,47 +963,13 @@ hackThreadedFlag verbosity comp prof bi
[ (hc, if hc == GHC then filter p opts else opts)
| (hc, opts) <- hcoptss ]
--- | Strip out flags that are not supported in ghci
-filterGhciFlags :: [String] -> [String]
-filterGhciFlags = filter supported
- where
- supported ('-':'O':_) = False
- supported "-debug" = False
- supported "-threaded" = False
- supported "-ticky" = False
- supported "-eventlog" = False
- supported "-prof" = False
- supported "-unreg" = False
- supported _ = True
-
--- when using -split-objs, we need to search for object files in the
--- Module_split directory for each module.
-getHaskellObjects :: Library -> LocalBuildInfo
- -> FilePath -> String -> Bool -> IO [FilePath]
-getHaskellObjects lib lbi pref wanted_obj_ext allow_split_objs
- | splitObjs lbi && allow_split_objs = do
- let splitSuffix = if compilerVersion (compiler lbi) <
- Version [6, 11] []
- then "_split"
- else "_" ++ wanted_obj_ext ++ "_split"
- dirs = [ pref </> (ModuleName.toFilePath x ++ splitSuffix)
- | x <- libModules lib ]
- objss <- mapM getDirectoryContents dirs
- let objs = [ dir </> obj
- | (objs',dir) <- zip objss dirs, obj <- objs',
- let obj_ext = takeExtension obj,
- '.':wanted_obj_ext == obj_ext ]
- return objs
- | otherwise =
- return [ pref </> ModuleName.toFilePath x <.> wanted_obj_ext
- | x <- libModules lib ]
-- | Extracts a String representing a hash of the ABI of a built
-- library. It can fail if the library has not yet been built.
--
libAbiHash :: Verbosity -> PackageDescription -> LocalBuildInfo
-> Library -> ComponentLocalBuildInfo -> IO String
-libAbiHash verbosity pkg_descr lbi lib clbi = do
+libAbiHash verbosity _pkg_descr lbi lib clbi = do
libBi <- hackThreadedFlag verbosity
(compiler lbi) (withProfLib lbi) (libBuildInfo lib)
let
@@ -1154,94 +978,47 @@ libAbiHash verbosity pkg_descr lbi lib clbi = do
(componentGhcOptions verbosity lbi libBi clbi (buildDir lbi))
`mappend` mempty {
ghcOptMode = toFlag GhcModeAbiHash,
- ghcOptPackageName = toFlag (packageId pkg_descr),
- ghcOptInputModules = exposedModules lib
+ ghcOptInputModules = toNubListR $ exposedModules lib
}
sharedArgs = vanillaArgs `mappend` mempty {
ghcOptDynLinkMode = toFlag GhcDynamicOnly,
ghcOptFPic = toFlag True,
ghcOptHiSuffix = toFlag "dyn_hi",
ghcOptObjSuffix = toFlag "dyn_o",
- ghcOptExtra = ghcSharedOptions libBi
+ ghcOptExtra = toNubListR $ hcSharedOptions GHC libBi
}
- profArgs = vanillaArgs `mappend` mempty {
+ profArgs = vanillaArgs `mappend` mempty {
ghcOptProfilingMode = toFlag True,
+ ghcOptProfilingAuto = Internal.profDetailLevelFlag True
+ (withProfLibDetail lbi),
ghcOptHiSuffix = toFlag "p_hi",
ghcOptObjSuffix = toFlag "p_o",
- ghcOptExtra = ghcProfOptions libBi
- }
+ ghcOptExtra = toNubListR $ hcProfOptions GHC libBi
+ }
ghcArgs = if withVanillaLib lbi then vanillaArgs
else if withSharedLib lbi then sharedArgs
else if withProfLib lbi then profArgs
else error "libAbiHash: Can't find an enabled library way"
--
(ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi)
- getProgramInvocationOutput verbosity (ghcInvocation ghcProg comp ghcArgs)
-
+ hash <- getProgramInvocationOutput verbosity
+ (ghcInvocation ghcProg comp ghcArgs)
+ return (takeWhile (not . isSpace) hash)
componentGhcOptions :: Verbosity -> LocalBuildInfo
-> BuildInfo -> ComponentLocalBuildInfo -> FilePath
-> GhcOptions
-componentGhcOptions verbosity lbi bi clbi odir =
- mempty {
- ghcOptVerbosity = toFlag verbosity,
- ghcOptHideAllPackages = toFlag True,
- ghcOptCabal = toFlag True,
- ghcOptPackageDBs = withPackageDB lbi,
- ghcOptPackages = componentPackageDeps clbi,
- ghcOptSplitObjs = toFlag (splitObjs lbi),
- ghcOptSourcePathClear = toFlag True,
- ghcOptSourcePath = [odir] ++ nub (hsSourceDirs bi)
- ++ [autogenModulesDir lbi],
- ghcOptCppIncludePath = [autogenModulesDir lbi, odir]
- ++ PD.includeDirs bi,
- ghcOptCppOptions = cppOptions bi,
- ghcOptCppIncludes = [autogenModulesDir lbi </> cppHeaderName],
- ghcOptFfiIncludes = PD.includes bi,
- ghcOptObjDir = toFlag odir,
- ghcOptHiDir = toFlag odir,
- ghcOptStubDir = toFlag odir,
- ghcOptOutputDir = toFlag odir,
- ghcOptOptimisation = toGhcOptimisation (withOptimization lbi),
- ghcOptExtra = hcOptions GHC bi,
- ghcOptLanguage = toFlag (fromMaybe Haskell98 (defaultLanguage bi)),
- -- Unsupported extensions have already been checked by configure
- ghcOptExtensions = usedExtensions bi,
- ghcOptExtensionMap = compilerExtensions (compiler lbi)
- }
- where
- toGhcOptimisation NoOptimisation = mempty --TODO perhaps override?
- toGhcOptimisation NormalOptimisation = toFlag GhcNormalOptimisation
- toGhcOptimisation MaximumOptimisation = toFlag GhcMaximumOptimisation
-
+componentGhcOptions = Internal.componentGhcOptions
componentCcGhcOptions :: Verbosity -> LocalBuildInfo
-> BuildInfo -> ComponentLocalBuildInfo
-> FilePath -> FilePath
-> GhcOptions
-componentCcGhcOptions verbosity lbi bi clbi pref filename =
- mempty {
- ghcOptVerbosity = toFlag verbosity,
- ghcOptMode = toFlag GhcModeCompile,
- ghcOptInputFiles = [filename],
-
- ghcOptCppIncludePath = [autogenModulesDir lbi, odir]
- ++ PD.includeDirs bi,
- ghcOptPackageDBs = withPackageDB lbi,
- ghcOptPackages = componentPackageDeps clbi,
- ghcOptCcOptions = PD.ccOptions bi
- ++ case withOptimization lbi of
- NoOptimisation -> []
- _ -> ["-O2"],
- ghcOptObjDir = toFlag odir
- }
+componentCcGhcOptions verbosity lbi =
+ Internal.componentCcGhcOptions verbosity implInfo lbi
where
- odir | compilerVersion (compiler lbi) >= Version [6,4,1] [] = pref
- | otherwise = pref </> takeDirectory filename
- -- ghc 6.4.0 had a bug in -odir handling for C compilations.
-
-mkGHCiLibName :: LibraryName -> String
-mkGHCiLibName (LibraryName lib) = lib <.> "o"
+ comp = compiler lbi
+ implInfo = getImplInfo comp
-- -----------------------------------------------------------------------------
-- Installing
@@ -1266,14 +1043,15 @@ installExe verbosity lbi installDirs buildPref
(buildPref </> exeName exe </> exeFileName)
(dest <.> exeExtension)
when (stripExes lbi) $
- Strip.stripExe verbosity (withPrograms lbi) (dest <.> exeExtension)
+ Strip.stripExe verbosity (hostPlatform lbi) (withPrograms lbi)
+ (dest <.> exeExtension)
installBinary (binDir </> fixedExeBaseName)
-- |Install for ghc, .hi, .a and, if --with-ghci given, .o
installLib :: Verbosity
-> LocalBuildInfo
-> FilePath -- ^install location
- -> FilePath -- ^install location for dynamic librarys
+ -> FilePath -- ^install location for dynamic libraries
-> FilePath -- ^Build location
-> PackageDescription
-> Library
@@ -1286,22 +1064,24 @@ installLib verbosity lbi targetDir dynlibTargetDir builtDir _pkg lib clbi = do
whenShared $ copyModuleFiles "dyn_hi"
-- copy the built library files over:
- whenVanilla $ mapM_ (installOrdinary builtDir targetDir) vanillaLibNames
- whenProf $ mapM_ (installOrdinary builtDir targetDir) profileLibNames
- whenGHCi $ mapM_ (installOrdinary builtDir targetDir) ghciLibNames
- whenShared $ mapM_ (installShared builtDir dynlibTargetDir) sharedLibNames
+ whenVanilla $ installOrdinary builtDir targetDir vanillaLibName
+ whenProf $ installOrdinary builtDir targetDir profileLibName
+ whenGHCi $ installOrdinary builtDir targetDir ghciLibName
+ whenShared $ installShared builtDir dynlibTargetDir sharedLibName
where
install isShared srcDir dstDir name = do
let src = srcDir </> name
dst = dstDir </> name
createDirectoryIfMissingVerbose verbosity True dstDir
+
if isShared
- then do when (stripLibs lbi) $
- Strip.stripLib verbosity (withPrograms lbi) src
- installExecutableFile verbosity src dst
+ then installExecutableFile verbosity src dst
else installOrdinaryFile verbosity src dst
+ when (stripLibs lbi) $ Strip.stripLib verbosity
+ (hostPlatform lbi) (withPrograms lbi) dst
+
installOrdinary = install False
installShared = install True
@@ -1310,11 +1090,11 @@ installLib verbosity lbi targetDir dynlibTargetDir builtDir _pkg lib clbi = do
>>= installOrdinaryFiles verbosity targetDir
cid = compilerId (compiler lbi)
- libNames = componentLibraries clbi
- vanillaLibNames = map mkLibName libNames
- profileLibNames = map mkProfLibName libNames
- ghciLibNames = map mkGHCiLibName libNames
- sharedLibNames = map (mkSharedLibName cid) libNames
+ libName = componentLibraryName clbi
+ vanillaLibName = mkLibName libName
+ profileLibName = mkProfLibName libName
+ ghciLibName = Internal.mkGHCiLibName libName
+ sharedLibName = (mkSharedLibName cid) libName
hasLib = not $ null (libModules lib)
&& null (cSources (libBuildInfo lib))
@@ -1326,20 +1106,17 @@ installLib verbosity lbi targetDir dynlibTargetDir builtDir _pkg lib clbi = do
-- -----------------------------------------------------------------------------
-- Registering
--- | Create an empty package DB at the specified location.
-initPackageDB :: Verbosity -> ProgramConfiguration -> FilePath -> IO ()
-initPackageDB verbosity conf dbPath = HcPkg.init verbosity ghcPkgProg dbPath
- where
- Just ghcPkgProg = lookupProgram ghcPkgProgram conf
-
--- | Run 'ghc-pkg' using a given package DB stack, directly forwarding the
--- provided command-line arguments to it.
-invokeHcPkg :: Verbosity -> ProgramConfiguration -> PackageDBStack -> [String]
- -> IO ()
-invokeHcPkg verbosity conf dbStack extraArgs =
- HcPkg.invoke verbosity ghcPkgProg dbStack extraArgs
+hcPkgInfo :: ProgramConfiguration -> HcPkg.HcPkgInfo
+hcPkgInfo conf = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram = ghcPkgProg
+ , HcPkg.noPkgDbStack = v < [6,9]
+ , HcPkg.noVerboseFlag = v < [6,11]
+ , HcPkg.flagPackageConf = v < [7,5]
+ , HcPkg.useSingleFileDb = v < [7,9]
+ }
where
+ v = versionBranch ver
Just ghcPkgProg = lookupProgram ghcPkgProgram conf
+ Just ver = programVersion ghcPkgProg
registerPackage
:: Verbosity
@@ -1349,21 +1126,35 @@ registerPackage
-> Bool
-> PackageDBStack
-> IO ()
-registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs = do
- let Just ghcPkg = lookupProgram ghcPkgProgram (withPrograms lbi)
- HcPkg.reregister verbosity ghcPkg packageDbs (Right installedPkgInfo)
+registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs =
+ HcPkg.reregister (hcPkgInfo $ withPrograms lbi) verbosity
+ packageDbs (Right installedPkgInfo)
+
+pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO FilePath
+pkgRoot verbosity lbi = pkgRoot'
+ where
+ pkgRoot' GlobalPackageDB =
+ let Just ghcProg = lookupProgram ghcProgram (withPrograms lbi)
+ in fmap takeDirectory (getGlobalPackageDB verbosity ghcProg)
+ pkgRoot' UserPackageDB = do
+ appDir <- getAppUserDataDirectory "ghc"
+ let ver = compilerVersion (compiler lbi)
+ subdir = System.Info.arch ++ '-':System.Info.os
+ ++ '-':showVersion ver
+ rootDir = appDir </> subdir
+ -- We must create the root directory for the user package database if it
+ -- does not yet exists. Otherwise '${pkgroot}' will resolve to a
+ -- directory at the time of 'ghc-pkg register', and registration will
+ -- fail.
+ createDirectoryIfMissing True rootDir
+ return rootDir
+ pkgRoot' (SpecificPackageDB fp) = return (takeDirectory fp)
-- -----------------------------------------------------------------------------
-- Utils
-ghcLookupProperty :: String -> Compiler -> Bool
-ghcLookupProperty prop comp =
- case M.lookup prop (compilerProperties comp) of
- Just "YES" -> True
- _ -> False
-
-ghcDynamic :: Compiler -> Bool
-ghcDynamic = ghcLookupProperty "GHC Dynamic"
+isDynamic :: Compiler -> Bool
+isDynamic = Internal.ghcLookupProperty "GHC Dynamic"
-ghcSupportsDynamicToo :: Compiler -> Bool
-ghcSupportsDynamicToo = ghcLookupProperty "Support dynamic-too"
+supportsDynamicToo :: Compiler -> Bool
+supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too"
diff --git a/cabal/Cabal/Distribution/Simple/GHC/IPI641.hs b/cabal/Cabal/Distribution/Simple/GHC/IPI641.hs
index 222af1a..4bb995d 100644
--- a/cabal/Cabal/Distribution/Simple/GHC/IPI641.hs
+++ b/cabal/Cabal/Distribution/Simple/GHC/IPI641.hs
@@ -2,48 +2,19 @@
-- |
-- Module : Distribution.Simple.GHC.IPI641
-- Copyright : (c) The University of Glasgow 2004
+-- License : BSD3
--
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
--
-{- 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. -}
-
module Distribution.Simple.GHC.IPI641 (
- InstalledPackageInfo,
+ InstalledPackageInfo(..),
toCurrent,
) where
import qualified Distribution.InstalledPackageInfo as Current
-import qualified Distribution.Package as Current hiding (depends)
+import qualified Distribution.Package as Current hiding (installedPackageId)
import Distribution.Text (display)
import Distribution.Simple.GHC.IPI642
@@ -94,9 +65,13 @@ mkInstalledPackageId :: Current.PackageIdentifier -> Current.InstalledPackageId
mkInstalledPackageId = Current.InstalledPackageId . display
toCurrent :: InstalledPackageInfo -> Current.InstalledPackageInfo
-toCurrent ipi@InstalledPackageInfo{} = Current.InstalledPackageInfo {
+toCurrent ipi@InstalledPackageInfo{} =
+ let pid = convertPackageId (package ipi)
+ mkExposedModule m = Current.ExposedModule m Nothing Nothing
+ in Current.InstalledPackageInfo {
Current.installedPackageId = mkInstalledPackageId (convertPackageId (package ipi)),
- Current.sourcePackageId = convertPackageId (package ipi),
+ Current.sourcePackageId = pid,
+ Current.packageKey = Current.OldPackageKey pid,
Current.license = convertLicense (license ipi),
Current.copyright = copyright ipi,
Current.maintainer = maintainer ipi,
@@ -108,22 +83,24 @@ toCurrent ipi@InstalledPackageInfo{} = Current.InstalledPackageInfo {
Current.description = description ipi,
Current.category = category ipi,
Current.exposed = exposed ipi,
- Current.exposedModules = map convertModuleName (exposedModules ipi),
+ Current.exposedModules = map (mkExposedModule . convertModuleName) (exposedModules ipi),
+ Current.instantiatedWith = [],
Current.hiddenModules = map convertModuleName (hiddenModules ipi),
Current.trusted = Current.trusted Current.emptyInstalledPackageInfo,
Current.importDirs = importDirs ipi,
Current.libraryDirs = libraryDirs ipi,
+ Current.dataDir = "",
Current.hsLibraries = hsLibraries ipi,
Current.extraLibraries = extraLibraries ipi,
Current.extraGHCiLibraries = [],
Current.includeDirs = includeDirs ipi,
Current.includes = includes ipi,
Current.depends = map (mkInstalledPackageId.convertPackageId) (depends ipi),
- Current.hugsOptions = hugsOptions ipi,
Current.ccOptions = ccOptions ipi,
Current.ldOptions = ldOptions ipi,
Current.frameworkDirs = frameworkDirs ipi,
Current.frameworks = frameworks ipi,
Current.haddockInterfaces = haddockInterfaces ipi,
- Current.haddockHTMLs = haddockHTMLs ipi
+ Current.haddockHTMLs = haddockHTMLs ipi,
+ Current.pkgRoot = Nothing
}
diff --git a/cabal/Cabal/Distribution/Simple/GHC/IPI642.hs b/cabal/Cabal/Distribution/Simple/GHC/IPI642.hs
index b1b8bb7..25145f1 100644
--- a/cabal/Cabal/Distribution/Simple/GHC/IPI642.hs
+++ b/cabal/Cabal/Distribution/Simple/GHC/IPI642.hs
@@ -2,43 +2,14 @@
-- |
-- Module : Distribution.Simple.GHC.IPI642
-- Copyright : (c) The University of Glasgow 2004
+-- License : BSD3
--
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
--
-{- 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. -}
-
module Distribution.Simple.GHC.IPI642 (
- InstalledPackageInfo,
+ InstalledPackageInfo(..),
toCurrent,
-- Don't use these, they're only for conversion purposes
@@ -48,7 +19,7 @@ module Distribution.Simple.GHC.IPI642 (
) where
import qualified Distribution.InstalledPackageInfo as Current
-import qualified Distribution.Package as Current hiding (depends)
+import qualified Distribution.Package as Current hiding (installedPackageId)
import qualified Distribution.License as Current
import Distribution.Version (Version)
@@ -129,9 +100,13 @@ convertLicense AllRightsReserved = Current.AllRightsReserved
convertLicense OtherLicense = Current.OtherLicense
toCurrent :: InstalledPackageInfo -> Current.InstalledPackageInfo
-toCurrent ipi@InstalledPackageInfo{} = Current.InstalledPackageInfo {
+toCurrent ipi@InstalledPackageInfo{} =
+ let pid = convertPackageId (package ipi)
+ mkExposedModule m = Current.ExposedModule m Nothing Nothing
+ in Current.InstalledPackageInfo {
Current.installedPackageId = mkInstalledPackageId (convertPackageId (package ipi)),
- Current.sourcePackageId = convertPackageId (package ipi),
+ Current.sourcePackageId = pid,
+ Current.packageKey = Current.OldPackageKey pid,
Current.license = convertLicense (license ipi),
Current.copyright = copyright ipi,
Current.maintainer = maintainer ipi,
@@ -143,22 +118,24 @@ toCurrent ipi@InstalledPackageInfo{} = Current.InstalledPackageInfo {
Current.description = description ipi,
Current.category = category ipi,
Current.exposed = exposed ipi,
- Current.exposedModules = map convertModuleName (exposedModules ipi),
+ Current.exposedModules = map (mkExposedModule . convertModuleName) (exposedModules ipi),
Current.hiddenModules = map convertModuleName (hiddenModules ipi),
+ Current.instantiatedWith = [],
Current.trusted = Current.trusted Current.emptyInstalledPackageInfo,
Current.importDirs = importDirs ipi,
Current.libraryDirs = libraryDirs ipi,
+ Current.dataDir = "",
Current.hsLibraries = hsLibraries ipi,
Current.extraLibraries = extraLibraries ipi,
Current.extraGHCiLibraries = extraGHCiLibraries ipi,
Current.includeDirs = includeDirs ipi,
Current.includes = includes ipi,
Current.depends = map (mkInstalledPackageId.convertPackageId) (depends ipi),
- Current.hugsOptions = hugsOptions ipi,
Current.ccOptions = ccOptions ipi,
Current.ldOptions = ldOptions ipi,
Current.frameworkDirs = frameworkDirs ipi,
Current.frameworks = frameworks ipi,
Current.haddockInterfaces = haddockInterfaces ipi,
- Current.haddockHTMLs = haddockHTMLs ipi
+ Current.haddockHTMLs = haddockHTMLs ipi,
+ Current.pkgRoot = Nothing
}
diff --git a/cabal/Cabal/Distribution/Simple/GHC/ImplInfo.hs b/cabal/Cabal/Distribution/Simple/GHC/ImplInfo.hs
new file mode 100644
index 0000000..46e1c43
--- /dev/null
+++ b/cabal/Cabal/Distribution/Simple/GHC/ImplInfo.hs
@@ -0,0 +1,111 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Simple.GHC.ImplInfo
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Portability : portable
+--
+-- This module contains the data structure describing invocation
+-- details for a GHC or GHC-derived compiler, such as supported flags
+-- and workarounds for bugs.
+
+module Distribution.Simple.GHC.ImplInfo (
+ GhcImplInfo(..), getImplInfo,
+ ghcVersionImplInfo, ghcjsVersionImplInfo, lhcVersionImplInfo
+ ) where
+
+import Distribution.Simple.Compiler
+ ( Compiler(..), CompilerFlavor(..)
+ , compilerFlavor, compilerVersion, compilerCompatVersion )
+import Distribution.Version ( Version(..) )
+
+{- |
+ Information about features and quirks of a GHC-based implementation.
+
+ Compiler flavors based on GHC behave similarly enough that some of
+ the support code for them is shared. Every implementation has its
+ own peculiarities, that may or may not be a direct result of the
+ underlying GHC version. This record keeps track of these differences.
+
+ All shared code (i.e. everything not in the Distribution.Simple.FLAVOR
+ module) should use implementation info rather than version numbers
+ to test for supported features.
+-}
+
+data GhcImplInfo = GhcImplInfo
+ { hasCcOdirBug :: Bool -- ^ bug in -odir handling for C compilations.
+ , flagInfoLanguages :: Bool -- ^ --info and --supported-languages flags
+ , fakeRecordPuns :: Bool -- ^ use -XRecordPuns for NamedFieldPuns
+ , flagStubdir :: Bool -- ^ -stubdir flag supported
+ , flagOutputDir :: Bool -- ^ -outputdir flag supported
+ , noExtInSplitSuffix :: Bool -- ^ split-obj suffix does not contain p_o ext
+ , flagFfiIncludes :: Bool -- ^ -#include on command line for FFI includes
+ , flagBuildingCabalPkg :: Bool -- ^ -fbuilding-cabal-package flag supported
+ , flagPackageId :: Bool -- ^ -package-id / -package flags supported
+ , separateGccMingw :: Bool -- ^ mingw and gcc are in separate directories
+ , supportsHaskell2010 :: Bool -- ^ -XHaskell2010 and -XHaskell98 flags
+ , reportsNoExt :: Bool -- ^ --supported-languages gives Ext and NoExt
+ , alwaysNondecIndent :: Bool -- ^ NondecreasingIndentation is always on
+ , flagGhciScript :: Bool -- ^ -ghci-script flag supported
+ , flagProfAuto :: Bool -- ^ new style -fprof-auto* flags
+ , flagPackageConf :: Bool -- ^ use package-conf instead of package-db
+ , flagDebugInfo :: Bool -- ^ -g flag supported
+ }
+
+getImplInfo :: Compiler -> GhcImplInfo
+getImplInfo comp =
+ case compilerFlavor comp of
+ GHC -> ghcVersionImplInfo (compilerVersion comp)
+ LHC -> lhcVersionImplInfo (compilerVersion comp)
+ GHCJS -> case compilerCompatVersion GHC comp of
+ Just ghcVer -> ghcjsVersionImplInfo (compilerVersion comp) ghcVer
+ _ -> error ("Distribution.Simple.GHC.Props.getImplProps: " ++
+ "could not find GHC version for GHCJS compiler")
+ x -> error ("Distribution.Simple.GHC.Props.getImplProps only works" ++
+ "for GHC-like compilers (GHC, GHCJS, LHC)" ++
+ ", but found " ++ show x)
+
+ghcVersionImplInfo :: Version -> GhcImplInfo
+ghcVersionImplInfo (Version v _) = GhcImplInfo
+ { hasCcOdirBug = v < [6,4,1]
+ , flagInfoLanguages = v >= [6,7]
+ , fakeRecordPuns = v >= [6,8] && v < [6,10]
+ , flagStubdir = v >= [6,8]
+ , flagOutputDir = v >= [6,10]
+ , noExtInSplitSuffix = v < [6,11]
+ , flagFfiIncludes = v < [6,11]
+ , flagBuildingCabalPkg = v >= [6,11]
+ , flagPackageId = v > [6,11]
+ , separateGccMingw = v < [6,12]
+ , supportsHaskell2010 = v >= [7]
+ , reportsNoExt = v >= [7]
+ , alwaysNondecIndent = v < [7,1]
+ , flagGhciScript = v >= [7,2]
+ , flagProfAuto = v >= [7,4]
+ , flagPackageConf = v < [7,5]
+ , flagDebugInfo = v >= [7,10]
+ }
+
+ghcjsVersionImplInfo :: Version -> Version -> GhcImplInfo
+ghcjsVersionImplInfo _ghcjsVer _ghcVer = GhcImplInfo
+ { hasCcOdirBug = False
+ , flagInfoLanguages = True
+ , fakeRecordPuns = False
+ , flagStubdir = True
+ , flagOutputDir = True
+ , noExtInSplitSuffix = False
+ , flagFfiIncludes = False
+ , flagBuildingCabalPkg = True
+ , flagPackageId = True
+ , separateGccMingw = False
+ , supportsHaskell2010 = True
+ , reportsNoExt = True
+ , alwaysNondecIndent = False
+ , flagGhciScript = True
+ , flagProfAuto = True
+ , flagPackageConf = False
+ , flagDebugInfo = False
+ }
+
+lhcVersionImplInfo :: Version -> GhcImplInfo
+lhcVersionImplInfo = ghcVersionImplInfo
diff --git a/cabal/Cabal/Distribution/Simple/GHC/Internal.hs b/cabal/Cabal/Distribution/Simple/GHC/Internal.hs
new file mode 100644
index 0000000..5c412e6
--- /dev/null
+++ b/cabal/Cabal/Distribution/Simple/GHC/Internal.hs
@@ -0,0 +1,521 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE PatternGuards #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Simple.GHC.Internal
+-- Copyright : Isaac Jones 2003-2007
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Portability : portable
+--
+-- This module contains functions shared by GHC (Distribution.Simple.GHC)
+-- and GHC-derived compilers.
+
+module Distribution.Simple.GHC.Internal (
+ configureToolchain,
+ getLanguages,
+ getExtensions,
+ targetPlatform,
+ getGhcInfo,
+ componentCcGhcOptions,
+ componentGhcOptions,
+ mkGHCiLibName,
+ filterGhciFlags,
+ ghcLookupProperty,
+ getHaskellObjects,
+ mkGhcOptPackages,
+ substTopDir,
+ checkPackageDbEnvVar,
+ profDetailLevelFlag,
+ ) where
+
+import Distribution.Simple.GHC.ImplInfo ( GhcImplInfo (..) )
+import Distribution.Package
+ ( InstalledPackageId, PackageId, LibraryName
+ , getHSLibraryName )
+import Distribution.InstalledPackageInfo
+ ( InstalledPackageInfo )
+import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
+ ( InstalledPackageInfo(..) )
+import Distribution.PackageDescription as PD
+ ( BuildInfo(..), Library(..), libModules
+ , hcOptions, usedExtensions, ModuleRenaming, lookupRenaming )
+import Distribution.Compat.Exception ( catchExit, catchIO )
+import Distribution.Lex (tokenizeQuotedWords)
+import Distribution.Simple.Compiler
+ ( CompilerFlavor(..), Compiler(..), DebugInfoLevel(..)
+ , OptimisationLevel(..), ProfDetailLevel(..) )
+import Distribution.Simple.Program.GHC
+import Distribution.Simple.Setup
+ ( Flag, toFlag )
+import qualified Distribution.ModuleName as ModuleName
+import Distribution.Simple.Program
+ ( Program(..), ConfiguredProgram(..), ProgramConfiguration
+ , ProgramLocation(..), ProgramSearchPath, ProgramSearchPathEntry(..)
+ , rawSystemProgram, rawSystemProgramStdout, programPath
+ , addKnownProgram, arProgram, ldProgram, gccProgram, stripProgram
+ , getProgramOutput )
+import Distribution.Simple.Program.Types ( suppressOverrideArgs )
+import Distribution.Simple.LocalBuildInfo
+ ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) )
+import Distribution.Simple.Utils
+import Distribution.Simple.BuildPaths
+import Distribution.System ( buildOS, OS(..), Platform, platformFromTriple )
+import Distribution.Text ( display, simpleParse )
+import Distribution.Utils.NubList ( toNubListR )
+import Distribution.Verbosity
+import Language.Haskell.Extension
+ ( Language(..), Extension(..), KnownExtension(..) )
+
+import qualified Data.Map as M
+import Data.Char ( isSpace )
+import Data.Maybe ( fromMaybe, maybeToList, isJust )
+import Control.Monad ( unless, when )
+#if __GLASGOW_HASKELL__ < 710
+import Data.Monoid ( Monoid(..) )
+#endif
+import System.Directory ( getDirectoryContents, getTemporaryDirectory )
+import System.Environment ( getEnv )
+import System.FilePath ( (</>), (<.>), takeExtension, takeDirectory )
+import System.IO ( hClose, hPutStrLn )
+
+targetPlatform :: [(String, String)] -> Maybe Platform
+targetPlatform ghcInfo = platformFromTriple =<< lookup "Target platform" ghcInfo
+
+-- | Adjust the way we find and configure gcc and ld
+--
+configureToolchain :: GhcImplInfo
+ -> ConfiguredProgram
+ -> M.Map String String
+ -> ProgramConfiguration
+ -> ProgramConfiguration
+configureToolchain implInfo ghcProg ghcInfo =
+ addKnownProgram gccProgram {
+ programFindLocation = findProg gccProgram extraGccPath,
+ programPostConf = configureGcc
+ }
+ . addKnownProgram ldProgram {
+ programFindLocation = findProg ldProgram extraLdPath,
+ programPostConf = configureLd
+ }
+ . addKnownProgram arProgram {
+ programFindLocation = findProg arProgram extraArPath
+ }
+ . addKnownProgram stripProgram {
+ programFindLocation = findProg stripProgram extraStripPath
+ }
+ where
+ compilerDir = takeDirectory (programPath ghcProg)
+ baseDir = takeDirectory compilerDir
+ mingwBinDir = baseDir </> "mingw" </> "bin"
+ libDir = baseDir </> "gcc-lib"
+ includeDir = baseDir </> "include" </> "mingw"
+ isWindows = case buildOS of Windows -> True; _ -> False
+ binPrefix = ""
+
+ mkExtraPath :: Maybe FilePath -> FilePath -> [FilePath]
+ mkExtraPath mbPath mingwPath | isWindows = mbDir ++ [mingwPath]
+ | otherwise = mbDir
+ where
+ mbDir = maybeToList . fmap takeDirectory $ mbPath
+
+ extraGccPath = mkExtraPath mbGccLocation windowsExtraGccDir
+ extraLdPath = mkExtraPath mbLdLocation windowsExtraLdDir
+ extraArPath = mkExtraPath mbArLocation windowsExtraArDir
+ extraStripPath = mkExtraPath mbStripLocation windowsExtraStripDir
+
+ -- on Windows finding and configuring ghc's gcc & binutils is a bit special
+ (windowsExtraGccDir, windowsExtraLdDir,
+ windowsExtraArDir, windowsExtraStripDir)
+ | separateGccMingw implInfo = (baseDir, libDir, libDir, libDir)
+ | otherwise = -- GHC >= 6.12
+ let b = mingwBinDir </> binPrefix
+ in (b, b, b, b)
+
+ findProg :: Program -> [FilePath]
+ -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath)
+ findProg prog extraPath v searchpath =
+ programFindLocation prog v searchpath'
+ where
+ searchpath' = (map ProgramSearchPathDir extraPath) ++ searchpath
+
+ -- Read tool locations from the 'ghc --info' output. Useful when
+ -- cross-compiling.
+ mbGccLocation = M.lookup "C compiler command" ghcInfo
+ mbLdLocation = M.lookup "ld command" ghcInfo
+ mbArLocation = M.lookup "ar command" ghcInfo
+ mbStripLocation = M.lookup "strip command" ghcInfo
+
+ ccFlags = getFlags "C compiler flags"
+ gccLinkerFlags = getFlags "Gcc Linker flags"
+ ldLinkerFlags = getFlags "Ld Linker flags"
+
+ -- It appears that GHC 7.6 and earlier encode the tokenized flags as a
+ -- [String] in these settings whereas later versions just encode the flags as
+ -- String.
+ --
+ -- We first try to parse as a [String] and if this fails then tokenize the
+ -- flags ourself.
+ getFlags :: String -> [String]
+ getFlags key =
+ case M.lookup key ghcInfo of
+ Nothing -> []
+ Just flags
+ | (flags', ""):_ <- reads flags -> flags'
+ | otherwise -> tokenizeQuotedWords flags
+
+ configureGcc :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
+ configureGcc v gccProg = do
+ gccProg' <- configureGcc' v gccProg
+ return gccProg' {
+ programDefaultArgs = programDefaultArgs gccProg'
+ ++ ccFlags ++ gccLinkerFlags
+ }
+
+ configureGcc' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
+ configureGcc'
+ | isWindows = \_ gccProg -> case programLocation gccProg of
+ -- if it's found on system then it means we're using the result
+ -- of programFindLocation above rather than a user-supplied path
+ -- Pre GHC 6.12, that meant we should add these flags to tell
+ -- ghc's gcc where it lives and thus where gcc can find its
+ -- various files:
+ FoundOnSystem {}
+ | separateGccMingw implInfo ->
+ return gccProg { programDefaultArgs = ["-B" ++ libDir,
+ "-I" ++ includeDir] }
+ _ -> return gccProg
+ | otherwise = \_ gccProg -> return gccProg
+
+ configureLd :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
+ configureLd v ldProg = do
+ ldProg' <- configureLd' v ldProg
+ return ldProg' {
+ programDefaultArgs = programDefaultArgs ldProg' ++ ldLinkerFlags
+ }
+
+ -- we need to find out if ld supports the -x flag
+ configureLd' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
+ configureLd' verbosity ldProg = do
+ tempDir <- getTemporaryDirectory
+ ldx <- withTempFile tempDir ".c" $ \testcfile testchnd ->
+ withTempFile tempDir ".o" $ \testofile testohnd -> do
+ hPutStrLn testchnd "int foo() { return 0; }"
+ hClose testchnd; hClose testohnd
+ rawSystemProgram verbosity ghcProg ["-c", testcfile,
+ "-o", testofile]
+ withTempFile tempDir ".o" $ \testofile' testohnd' ->
+ do
+ hClose testohnd'
+ _ <- rawSystemProgramStdout verbosity ldProg
+ ["-x", "-r", testofile, "-o", testofile']
+ return True
+ `catchIO` (\_ -> return False)
+ `catchExit` (\_ -> return False)
+ if ldx
+ then return ldProg { programDefaultArgs = ["-x"] }
+ else return ldProg
+
+getLanguages :: Verbosity -> GhcImplInfo -> ConfiguredProgram
+ -> IO [(Language, String)]
+getLanguages _ implInfo _
+ -- TODO: should be using --supported-languages rather than hard coding
+ | supportsHaskell2010 implInfo = return [(Haskell98, "-XHaskell98")
+ ,(Haskell2010, "-XHaskell2010")]
+ | otherwise = return [(Haskell98, "")]
+
+getGhcInfo :: Verbosity -> GhcImplInfo -> ConfiguredProgram
+ -> IO [(String, String)]
+getGhcInfo verbosity implInfo ghcProg
+ | flagInfoLanguages implInfo = do
+ xs <- getProgramOutput verbosity (suppressOverrideArgs ghcProg)
+ ["--info"]
+ case reads xs of
+ [(i, ss)]
+ | all isSpace ss ->
+ return i
+ _ ->
+ die "Can't parse --info output of GHC"
+ | otherwise =
+ return []
+
+getExtensions :: Verbosity -> GhcImplInfo -> ConfiguredProgram
+ -> IO [(Extension, String)]
+getExtensions verbosity implInfo ghcProg
+ | flagInfoLanguages implInfo = do
+ str <- getProgramOutput verbosity (suppressOverrideArgs ghcProg)
+ ["--supported-languages"]
+ let extStrs = if reportsNoExt implInfo
+ then lines str
+ else -- Older GHCs only gave us either Foo or NoFoo,
+ -- so we have to work out the other one ourselves
+ [ extStr''
+ | extStr <- lines str
+ , let extStr' = case extStr of
+ 'N' : 'o' : xs -> xs
+ _ -> "No" ++ extStr
+ , extStr'' <- [extStr, extStr']
+ ]
+ let extensions0 = [ (ext, "-X" ++ display ext)
+ | Just ext <- map simpleParse extStrs ]
+ extensions1 = if fakeRecordPuns implInfo
+ then -- ghc-6.8 introduced RecordPuns however it
+ -- should have been NamedFieldPuns. We now
+ -- encourage packages to use NamedFieldPuns
+ -- so for compatibility we fake support for
+ -- it in ghc-6.8 by making it an alias for
+ -- the old RecordPuns extension.
+ (EnableExtension NamedFieldPuns, "-XRecordPuns") :
+ (DisableExtension NamedFieldPuns, "-XNoRecordPuns") :
+ extensions0
+ else extensions0
+ extensions2 = if alwaysNondecIndent implInfo
+ then -- ghc-7.2 split NondecreasingIndentation off
+ -- into a proper extension. Before that it
+ -- was always on.
+ (EnableExtension NondecreasingIndentation, "") :
+ (DisableExtension NondecreasingIndentation, "") :
+ extensions1
+ else extensions1
+ return extensions2
+
+ | otherwise = return oldLanguageExtensions
+
+-- | For GHC 6.6.x and earlier, the mapping from supported extensions to flags
+oldLanguageExtensions :: [(Extension, String)]
+oldLanguageExtensions =
+ let doFlag (f, (enable, disable)) = [(EnableExtension f, enable),
+ (DisableExtension f, disable)]
+ fglasgowExts = ("-fglasgow-exts",
+ "") -- This is wrong, but we don't want to turn
+ -- all the extensions off when asked to just
+ -- turn one off
+ fFlag flag = ("-f" ++ flag, "-fno-" ++ flag)
+ in concatMap doFlag
+ [(OverlappingInstances , fFlag "allow-overlapping-instances")
+ ,(TypeSynonymInstances , fglasgowExts)
+ ,(TemplateHaskell , fFlag "th")
+ ,(ForeignFunctionInterface , fFlag "ffi")
+ ,(MonomorphismRestriction , fFlag "monomorphism-restriction")
+ ,(MonoPatBinds , fFlag "mono-pat-binds")
+ ,(UndecidableInstances , fFlag "allow-undecidable-instances")
+ ,(IncoherentInstances , fFlag "allow-incoherent-instances")
+ ,(Arrows , fFlag "arrows")
+ ,(Generics , fFlag "generics")
+ ,(ImplicitPrelude , fFlag "implicit-prelude")
+ ,(ImplicitParams , fFlag "implicit-params")
+ ,(CPP , ("-cpp", ""{- Wrong -}))
+ ,(BangPatterns , fFlag "bang-patterns")
+ ,(KindSignatures , fglasgowExts)
+ ,(RecursiveDo , fglasgowExts)
+ ,(ParallelListComp , fglasgowExts)
+ ,(MultiParamTypeClasses , fglasgowExts)
+ ,(FunctionalDependencies , fglasgowExts)
+ ,(Rank2Types , fglasgowExts)
+ ,(RankNTypes , fglasgowExts)
+ ,(PolymorphicComponents , fglasgowExts)
+ ,(ExistentialQuantification , fglasgowExts)
+ ,(ScopedTypeVariables , fFlag "scoped-type-variables")
+ ,(FlexibleContexts , fglasgowExts)
+ ,(FlexibleInstances , fglasgowExts)
+ ,(EmptyDataDecls , fglasgowExts)
+ ,(PatternGuards , fglasgowExts)
+ ,(GeneralizedNewtypeDeriving , fglasgowExts)
+ ,(MagicHash , fglasgowExts)
+ ,(UnicodeSyntax , fglasgowExts)
+ ,(PatternSignatures , fglasgowExts)
+ ,(UnliftedFFITypes , fglasgowExts)
+ ,(LiberalTypeSynonyms , fglasgowExts)
+ ,(TypeOperators , fglasgowExts)
+ ,(GADTs , fglasgowExts)
+ ,(RelaxedPolyRec , fglasgowExts)
+ ,(ExtendedDefaultRules , fFlag "extended-default-rules")
+ ,(UnboxedTuples , fglasgowExts)
+ ,(DeriveDataTypeable , fglasgowExts)
+ ,(ConstrainedClassMethods , fglasgowExts)
+ ]
+
+componentCcGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo
+ -> BuildInfo -> ComponentLocalBuildInfo
+ -> FilePath -> FilePath
+ -> GhcOptions
+componentCcGhcOptions verbosity implInfo lbi bi clbi pref filename =
+ mempty {
+ ghcOptVerbosity = toFlag verbosity,
+ ghcOptMode = toFlag GhcModeCompile,
+ ghcOptInputFiles = toNubListR [filename],
+
+ ghcOptCppIncludePath = toNubListR $ [autogenModulesDir lbi, odir]
+ ++ PD.includeDirs bi,
+ ghcOptPackageDBs = withPackageDB lbi,
+ ghcOptPackages = toNubListR $ mkGhcOptPackages clbi,
+ ghcOptCcOptions = toNubListR $
+ (case withOptimization lbi of
+ NoOptimisation -> []
+ _ -> ["-O2"]) ++
+ (case withDebugInfo lbi of
+ NoDebugInfo -> []
+ MinimalDebugInfo -> ["-g1"]
+ NormalDebugInfo -> ["-g"]
+ MaximalDebugInfo -> ["-g3"]) ++
+ PD.ccOptions bi,
+ ghcOptObjDir = toFlag odir
+ }
+ where
+ odir | hasCcOdirBug implInfo = pref </> takeDirectory filename
+ | otherwise = pref
+ -- ghc 6.4.0 had a bug in -odir handling for C compilations.
+
+componentGhcOptions :: Verbosity -> LocalBuildInfo
+ -> BuildInfo -> ComponentLocalBuildInfo -> FilePath
+ -> GhcOptions
+componentGhcOptions verbosity lbi bi clbi odir =
+ mempty {
+ ghcOptVerbosity = toFlag verbosity,
+ ghcOptHideAllPackages = toFlag True,
+ ghcOptCabal = toFlag True,
+ ghcOptPackageKey = case clbi of
+ LibComponentLocalBuildInfo { componentPackageKey = pk } -> toFlag pk
+ _ -> mempty,
+ ghcOptSigOf = hole_insts,
+ ghcOptPackageDBs = withPackageDB lbi,
+ ghcOptPackages = toNubListR $ mkGhcOptPackages clbi,
+ ghcOptSplitObjs = toFlag (splitObjs lbi),
+ ghcOptSourcePathClear = toFlag True,
+ ghcOptSourcePath = toNubListR $ [odir] ++ (hsSourceDirs bi)
+ ++ [autogenModulesDir lbi],
+ ghcOptCppIncludePath = toNubListR $ [autogenModulesDir lbi, odir]
+ ++ PD.includeDirs bi,
+ ghcOptCppOptions = toNubListR $ cppOptions bi,
+ ghcOptCppIncludes = toNubListR $
+ [autogenModulesDir lbi </> cppHeaderName],
+ ghcOptFfiIncludes = toNubListR $ PD.includes bi,
+ ghcOptObjDir = toFlag odir,
+ ghcOptHiDir = toFlag odir,
+ ghcOptStubDir = toFlag odir,
+ ghcOptOutputDir = toFlag odir,
+ ghcOptOptimisation = toGhcOptimisation (withOptimization lbi),
+ ghcOptDebugInfo = toGhcDebugInfo (withDebugInfo lbi),
+ ghcOptExtra = toNubListR $ hcOptions GHC bi,
+ ghcOptLanguage = toFlag (fromMaybe Haskell98 (defaultLanguage bi)),
+ -- Unsupported extensions have already been checked by configure
+ ghcOptExtensions = toNubListR $ usedExtensions bi,
+ ghcOptExtensionMap = M.fromList . compilerExtensions $ (compiler lbi)
+ }
+ where
+ toGhcOptimisation NoOptimisation = mempty --TODO perhaps override?
+ toGhcOptimisation NormalOptimisation = toFlag GhcNormalOptimisation
+ toGhcOptimisation MaximumOptimisation = toFlag GhcMaximumOptimisation
+
+ -- GHC doesn't support debug info levels yet.
+ toGhcDebugInfo NoDebugInfo = mempty
+ toGhcDebugInfo MinimalDebugInfo = toFlag True
+ toGhcDebugInfo NormalDebugInfo = toFlag True
+ toGhcDebugInfo MaximalDebugInfo = toFlag True
+
+ hole_insts = map (\(k,(p,n)) -> (k, (InstalledPackageInfo.packageKey p,n)))
+ (instantiatedWith lbi)
+
+-- | Strip out flags that are not supported in ghci
+filterGhciFlags :: [String] -> [String]
+filterGhciFlags = filter supported
+ where
+ supported ('-':'O':_) = False
+ supported "-debug" = False
+ supported "-threaded" = False
+ supported "-ticky" = False
+ supported "-eventlog" = False
+ supported "-prof" = False
+ supported "-unreg" = False
+ supported _ = True
+
+mkGHCiLibName :: LibraryName -> String
+mkGHCiLibName lib = getHSLibraryName lib <.> "o"
+
+ghcLookupProperty :: String -> Compiler -> Bool
+ghcLookupProperty prop comp =
+ case M.lookup prop (compilerProperties comp) of
+ Just "YES" -> True
+ _ -> False
+
+-- when using -split-objs, we need to search for object files in the
+-- Module_split directory for each module.
+getHaskellObjects :: GhcImplInfo -> Library -> LocalBuildInfo
+ -> FilePath -> String -> Bool -> IO [FilePath]
+getHaskellObjects implInfo lib lbi pref wanted_obj_ext allow_split_objs
+ | splitObjs lbi && allow_split_objs = do
+ let splitSuffix = if noExtInSplitSuffix implInfo
+ then "_split"
+ else "_" ++ wanted_obj_ext ++ "_split"
+ dirs = [ pref </> (ModuleName.toFilePath x ++ splitSuffix)
+ | x <- libModules lib ]
+ objss <- mapM getDirectoryContents dirs
+ let objs = [ dir </> obj
+ | (objs',dir) <- zip objss dirs, obj <- objs',
+ let obj_ext = takeExtension obj,
+ '.':wanted_obj_ext == obj_ext ]
+ return objs
+ | otherwise =
+ return [ pref </> ModuleName.toFilePath x <.> wanted_obj_ext
+ | x <- libModules lib ]
+
+mkGhcOptPackages :: ComponentLocalBuildInfo
+ -> [(InstalledPackageId, PackageId, ModuleRenaming)]
+mkGhcOptPackages clbi =
+ map (\(i,p) -> (i,p,lookupRenaming p (componentPackageRenaming clbi)))
+ (componentPackageDeps clbi)
+
+substTopDir :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo
+substTopDir topDir ipo
+ = ipo {
+ InstalledPackageInfo.importDirs
+ = map f (InstalledPackageInfo.importDirs ipo),
+ InstalledPackageInfo.libraryDirs
+ = map f (InstalledPackageInfo.libraryDirs ipo),
+ InstalledPackageInfo.includeDirs
+ = map f (InstalledPackageInfo.includeDirs ipo),
+ InstalledPackageInfo.frameworkDirs
+ = map f (InstalledPackageInfo.frameworkDirs ipo),
+ InstalledPackageInfo.haddockInterfaces
+ = map f (InstalledPackageInfo.haddockInterfaces ipo),
+ InstalledPackageInfo.haddockHTMLs
+ = map f (InstalledPackageInfo.haddockHTMLs ipo)
+ }
+ where f ('$':'t':'o':'p':'d':'i':'r':rest) = topDir ++ rest
+ f x = x
+
+-- Cabal does not use the environment variable GHC{,JS}_PACKAGE_PATH; let
+-- users know that this is the case. See ticket #335. Simply ignoring it is
+-- not a good idea, since then ghc and cabal are looking at different sets
+-- of package DBs and chaos is likely to ensue.
+--
+-- An exception to this is when running cabal from within a `cabal exec`
+-- environment. In this case, `cabal exec` will set the
+-- CABAL_SANDBOX_PACKAGE_PATH to the same value that it set
+-- GHC{,JS}_PACKAGE_PATH to. If that is the case it is OK to allow
+-- GHC{,JS}_PACKAGE_PATH.
+checkPackageDbEnvVar :: String -> String -> IO ()
+checkPackageDbEnvVar compilerName packagePathEnvVar = do
+ mPP <- lookupEnv packagePathEnvVar
+ when (isJust mPP) $ do
+ mcsPP <- lookupEnv "CABAL_SANDBOX_PACKAGE_PATH"
+ unless (mPP == mcsPP) abort
+ where
+ lookupEnv :: String -> IO (Maybe String)
+ lookupEnv name = (Just `fmap` getEnv name) `catchIO` const (return Nothing)
+ abort =
+ die $ "Use of " ++ compilerName ++ "'s environment variable "
+ ++ packagePathEnvVar ++ " is incompatible with Cabal. Use the "
+ ++ "flag --package-db to specify a package database (it can be "
+ ++ "used multiple times)."
+
+profDetailLevelFlag :: Bool -> ProfDetailLevel -> Flag GhcProfAuto
+profDetailLevelFlag forLib mpl =
+ case mpl of
+ ProfDetailNone -> mempty
+ ProfDetailDefault | forLib -> toFlag GhcProfAutoExported
+ | otherwise -> toFlag GhcProfAutoToplevel
+ ProfDetailExportedFunctions -> toFlag GhcProfAutoExported
+ ProfDetailToplevelFunctions -> toFlag GhcProfAutoToplevel
+ ProfDetailAllFunctions -> toFlag GhcProfAutoAll
+ ProfDetailOther _ -> mempty
diff --git a/cabal/Cabal/Distribution/Simple/GHCJS.hs b/cabal/Cabal/Distribution/Simple/GHCJS.hs
new file mode 100644
index 0000000..6b3157d
--- /dev/null
+++ b/cabal/Cabal/Distribution/Simple/GHCJS.hs
@@ -0,0 +1,896 @@
+{-# LANGUAGE CPP #-}
+module Distribution.Simple.GHCJS (
+ configure, getInstalledPackages, getPackageDBContents,
+ buildLib, buildExe,
+ replLib, replExe,
+ startInterpreter,
+ installLib, installExe,
+ libAbiHash,
+ hcPkgInfo,
+ registerPackage,
+ componentGhcOptions,
+ getLibDir,
+ isDynamic,
+ getGlobalPackageDB,
+ runCmd
+ ) where
+
+import Distribution.Simple.GHC.ImplInfo ( getImplInfo, ghcjsVersionImplInfo )
+import qualified Distribution.Simple.GHC.Internal as Internal
+import Distribution.PackageDescription as PD
+ ( PackageDescription(..), BuildInfo(..), Executable(..)
+ , Library(..), libModules, exeModules
+ , hcOptions, hcProfOptions, hcSharedOptions
+ , allExtensions )
+import Distribution.InstalledPackageInfo
+ ( InstalledPackageInfo )
+import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
+ ( InstalledPackageInfo(..) )
+import Distribution.Package ( LibraryName(..), getHSLibraryName )
+import Distribution.Simple.PackageIndex ( InstalledPackageIndex )
+import qualified Distribution.Simple.PackageIndex as PackageIndex
+import Distribution.Simple.LocalBuildInfo
+ ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) )
+import qualified Distribution.Simple.Hpc as Hpc
+import Distribution.Simple.InstallDirs hiding ( absoluteInstallDirs )
+import Distribution.Simple.BuildPaths
+import Distribution.Simple.Utils
+import Distribution.Simple.Program
+ ( Program(..), ConfiguredProgram(..), ProgramConfiguration
+ , ProgramSearchPath
+ , rawSystemProgramConf
+ , rawSystemProgramStdout, rawSystemProgramStdoutConf
+ , getProgramInvocationOutput
+ , requireProgramVersion, requireProgram
+ , userMaybeSpecifyPath, programPath
+ , lookupProgram, addKnownPrograms
+ , ghcjsProgram, ghcjsPkgProgram, c2hsProgram, hsc2hsProgram
+ , ldProgram, haddockProgram, stripProgram )
+import qualified Distribution.Simple.Program.HcPkg as HcPkg
+import qualified Distribution.Simple.Program.Ar as Ar
+import qualified Distribution.Simple.Program.Ld as Ld
+import qualified Distribution.Simple.Program.Strip as Strip
+import Distribution.Simple.Program.GHC
+import Distribution.Simple.Setup
+ ( toFlag, fromFlag, configCoverage, configDistPref )
+import qualified Distribution.Simple.Setup as Cabal
+ ( Flag(..) )
+import Distribution.Simple.Compiler
+ ( CompilerFlavor(..), CompilerId(..), Compiler(..)
+ , PackageDB(..), PackageDBStack, AbiTag(..) )
+import Distribution.Version
+ ( Version(..), anyVersion, orLaterVersion )
+import Distribution.System
+ ( Platform(..) )
+import Distribution.Verbosity
+import Distribution.Utils.NubList
+ ( overNubListR, toNubListR )
+import Distribution.Text ( display )
+import Language.Haskell.Extension ( Extension(..)
+ , KnownExtension(..))
+
+import Control.Monad ( unless, when )
+import Data.Char ( isSpace )
+import qualified Data.Map as M ( fromList )
+#if __GLASGOW_HASKELL__ < 710
+import Data.Monoid ( Monoid(..) )
+#endif
+import System.Directory ( doesFileExist )
+import System.FilePath ( (</>), (<.>), takeExtension,
+ takeDirectory, replaceExtension,
+ splitExtension )
+
+configure :: Verbosity -> Maybe FilePath -> Maybe FilePath
+ -> ProgramConfiguration
+ -> IO (Compiler, Maybe Platform, ProgramConfiguration)
+configure verbosity hcPath hcPkgPath conf0 = do
+ (ghcjsProg, ghcjsVersion, conf1) <-
+ requireProgramVersion verbosity ghcjsProgram
+ (orLaterVersion (Version [0,1] []))
+ (userMaybeSpecifyPath "ghcjs" hcPath conf0)
+ Just ghcjsGhcVersion <- findGhcjsGhcVersion verbosity (programPath ghcjsProg)
+ let implInfo = ghcjsVersionImplInfo ghcjsVersion ghcjsGhcVersion
+
+ -- This is slightly tricky, we have to configure ghcjs first, then we use the
+ -- location of ghcjs to help find ghcjs-pkg in the case that the user did not
+ -- specify the location of ghc-pkg directly:
+ (ghcjsPkgProg, ghcjsPkgVersion, conf2) <-
+ requireProgramVersion verbosity ghcjsPkgProgram {
+ programFindLocation = guessGhcjsPkgFromGhcjsPath ghcjsProg
+ }
+ anyVersion (userMaybeSpecifyPath "ghcjs-pkg" hcPkgPath conf1)
+
+ Just ghcjsPkgGhcjsVersion <- findGhcjsPkgGhcjsVersion
+ verbosity (programPath ghcjsPkgProg)
+
+ when (ghcjsVersion /= ghcjsPkgGhcjsVersion) $ die $
+ "Version mismatch between ghcjs and ghcjs-pkg: "
+ ++ programPath ghcjsProg ++ " is version " ++ display ghcjsVersion ++ " "
+ ++ programPath ghcjsPkgProg ++ " is version " ++ display ghcjsPkgGhcjsVersion
+
+ when (ghcjsGhcVersion /= ghcjsPkgVersion) $ die $
+ "Version mismatch between ghcjs and ghcjs-pkg: "
+ ++ programPath ghcjsProg
+ ++ " was built with GHC version " ++ display ghcjsGhcVersion ++ " "
+ ++ programPath ghcjsPkgProg
+ ++ " was built with GHC version " ++ display ghcjsPkgVersion
+
+ -- be sure to use our versions of hsc2hs, c2hs, haddock and ghc
+ let hsc2hsProgram' =
+ hsc2hsProgram { programFindLocation =
+ guessHsc2hsFromGhcjsPath ghcjsProg }
+ c2hsProgram' =
+ c2hsProgram { programFindLocation =
+ guessC2hsFromGhcjsPath ghcjsProg }
+
+ haddockProgram' =
+ haddockProgram { programFindLocation =
+ guessHaddockFromGhcjsPath ghcjsProg }
+ conf3 = addKnownPrograms [ hsc2hsProgram', c2hsProgram', haddockProgram' ] conf2
+
+ languages <- Internal.getLanguages verbosity implInfo ghcjsProg
+ extensions <- Internal.getExtensions verbosity implInfo ghcjsProg
+
+ ghcInfo <- Internal.getGhcInfo verbosity implInfo ghcjsProg
+ let ghcInfoMap = M.fromList ghcInfo
+
+ let comp = Compiler {
+ compilerId = CompilerId GHCJS ghcjsVersion,
+ compilerAbiTag = AbiTag $
+ "ghc" ++ intercalate "_" (map show . versionBranch $ ghcjsGhcVersion),
+ compilerCompat = [CompilerId GHC ghcjsGhcVersion],
+ compilerLanguages = languages,
+ compilerExtensions = extensions,
+ compilerProperties = ghcInfoMap
+ }
+ compPlatform = Internal.targetPlatform ghcInfo
+ -- configure gcc and ld
+ let conf4 = if ghcjsNativeToo comp
+ then Internal.configureToolchain implInfo
+ ghcjsProg ghcInfoMap conf3
+ else conf3
+ return (comp, compPlatform, conf4)
+
+ghcjsNativeToo :: Compiler -> Bool
+ghcjsNativeToo = Internal.ghcLookupProperty "Native Too"
+
+guessGhcjsPkgFromGhcjsPath :: ConfiguredProgram -> Verbosity
+ -> ProgramSearchPath -> IO (Maybe FilePath)
+guessGhcjsPkgFromGhcjsPath = guessToolFromGhcjsPath ghcjsPkgProgram
+
+guessHsc2hsFromGhcjsPath :: ConfiguredProgram -> Verbosity
+ -> ProgramSearchPath -> IO (Maybe FilePath)
+guessHsc2hsFromGhcjsPath = guessToolFromGhcjsPath hsc2hsProgram
+
+guessC2hsFromGhcjsPath :: ConfiguredProgram -> Verbosity
+ -> ProgramSearchPath -> IO (Maybe FilePath)
+guessC2hsFromGhcjsPath = guessToolFromGhcjsPath c2hsProgram
+
+guessHaddockFromGhcjsPath :: ConfiguredProgram -> Verbosity
+ -> ProgramSearchPath -> IO (Maybe FilePath)
+guessHaddockFromGhcjsPath = guessToolFromGhcjsPath haddockProgram
+
+guessToolFromGhcjsPath :: Program -> ConfiguredProgram
+ -> Verbosity -> ProgramSearchPath
+ -> IO (Maybe FilePath)
+guessToolFromGhcjsPath tool ghcjsProg verbosity searchpath
+ = do let toolname = programName tool
+ path = programPath ghcjsProg
+ dir = takeDirectory path
+ versionSuffix = takeVersionSuffix (dropExeExtension path)
+ guessNormal = dir </> toolname <.> exeExtension
+ guessGhcjsVersioned = dir </> (toolname ++ "-ghcjs" ++ versionSuffix)
+ <.> exeExtension
+ guessGhcjs = dir </> (toolname ++ "-ghcjs")
+ <.> exeExtension
+ guessVersioned = dir </> (toolname ++ versionSuffix) <.> exeExtension
+ guesses | null versionSuffix = [guessGhcjs, guessNormal]
+ | otherwise = [guessGhcjsVersioned,
+ guessGhcjs,
+ guessVersioned,
+ guessNormal]
+ info verbosity $ "looking for tool " ++ toolname
+ ++ " near compiler in " ++ dir
+ exists <- mapM doesFileExist guesses
+ case [ file | (file, True) <- zip guesses exists ] of
+ -- If we can't find it near ghc, fall back to the usual
+ -- method.
+ [] -> programFindLocation tool verbosity searchpath
+ (fp:_) -> do info verbosity $ "found " ++ toolname ++ " in " ++ fp
+ return (Just fp)
+
+ where takeVersionSuffix :: FilePath -> String
+ takeVersionSuffix = reverse . takeWhile (`elem ` "0123456789.-") .
+ reverse
+
+ dropExeExtension :: FilePath -> FilePath
+ dropExeExtension filepath =
+ case splitExtension filepath of
+ (filepath', extension) | extension == exeExtension -> filepath'
+ | otherwise -> filepath
+
+
+-- | Given a single package DB, return all installed packages.
+getPackageDBContents :: Verbosity -> PackageDB -> ProgramConfiguration
+ -> IO InstalledPackageIndex
+getPackageDBContents verbosity packagedb conf = do
+ pkgss <- getInstalledPackages' verbosity [packagedb] conf
+ toPackageIndex verbosity pkgss conf
+
+-- | Given a package DB stack, return all installed packages.
+getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration
+ -> IO InstalledPackageIndex
+getInstalledPackages verbosity packagedbs conf = do
+ checkPackageDbEnvVar
+ checkPackageDbStack packagedbs
+ pkgss <- getInstalledPackages' verbosity packagedbs conf
+ index <- toPackageIndex verbosity pkgss conf
+ return $! index
+
+toPackageIndex :: Verbosity
+ -> [(PackageDB, [InstalledPackageInfo])]
+ -> ProgramConfiguration
+ -> IO InstalledPackageIndex
+toPackageIndex verbosity pkgss conf = do
+ -- On Windows, various fields have $topdir/foo rather than full
+ -- paths. We need to substitute the right value in so that when
+ -- we, for example, call gcc, we have proper paths to give it.
+ topDir <- getLibDir' verbosity ghcjsProg
+ let indices = [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs)
+ | (_, pkgs) <- pkgss ]
+ return $! (mconcat indices)
+
+ where
+ Just ghcjsProg = lookupProgram ghcjsProgram conf
+
+checkPackageDbEnvVar :: IO ()
+checkPackageDbEnvVar =
+ Internal.checkPackageDbEnvVar "GHCJS" "GHCJS_PACKAGE_PATH"
+
+checkPackageDbStack :: PackageDBStack -> IO ()
+checkPackageDbStack (GlobalPackageDB:rest)
+ | GlobalPackageDB `notElem` rest = return ()
+checkPackageDbStack rest
+ | GlobalPackageDB `notElem` rest =
+ die $ "With current ghc versions the global package db is always used "
+ ++ "and must be listed first. This ghc limitation may be lifted in "
+ ++ "future, see http://hackage.haskell.org/trac/ghc/ticket/5977"
+checkPackageDbStack _ =
+ die $ "If the global package db is specified, it must be "
+ ++ "specified first and cannot be specified multiple times"
+
+getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramConfiguration
+ -> IO [(PackageDB, [InstalledPackageInfo])]
+getInstalledPackages' verbosity packagedbs conf =
+ sequence
+ [ do pkgs <- HcPkg.dump (hcPkgInfo conf) verbosity packagedb
+ return (packagedb, pkgs)
+ | packagedb <- packagedbs ]
+
+getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath
+getLibDir verbosity lbi =
+ (reverse . dropWhile isSpace . reverse) `fmap`
+ rawSystemProgramStdoutConf verbosity ghcjsProgram
+ (withPrograms lbi) ["--print-libdir"]
+
+getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath
+getLibDir' verbosity ghcjsProg =
+ (reverse . dropWhile isSpace . reverse) `fmap`
+ rawSystemProgramStdout verbosity ghcjsProg ["--print-libdir"]
+
+-- | Return the 'FilePath' to the global GHC package database.
+getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath
+getGlobalPackageDB verbosity ghcjsProg =
+ (reverse . dropWhile isSpace . reverse) `fmap`
+ rawSystemProgramStdout verbosity ghcjsProg ["--print-global-package-db"]
+
+toJSLibName :: String -> String
+toJSLibName lib
+ | takeExtension lib `elem` [".dll",".dylib",".so"]
+ = replaceExtension lib "js_so"
+ | takeExtension lib == ".a" = replaceExtension lib "js_a"
+ | otherwise = lib <.> "js_a"
+
+buildLib, replLib :: Verbosity -> Cabal.Flag (Maybe Int) -> PackageDescription
+ -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo
+ -> IO ()
+buildLib = buildOrReplLib False
+replLib = buildOrReplLib True
+
+buildOrReplLib :: Bool -> Verbosity -> Cabal.Flag (Maybe Int)
+ -> PackageDescription -> LocalBuildInfo
+ -> Library -> ComponentLocalBuildInfo -> IO ()
+buildOrReplLib forRepl verbosity numJobs _pkg_descr lbi lib clbi = do
+ let libName@(LibraryName cname) = componentLibraryName clbi
+ libTargetDir = buildDir lbi
+ whenVanillaLib forceVanilla =
+ when (not forRepl && (forceVanilla || withVanillaLib lbi))
+ whenProfLib = when (not forRepl && withProfLib lbi)
+ whenSharedLib forceShared =
+ when (not forRepl && (forceShared || withSharedLib lbi))
+ whenGHCiLib = when (not forRepl && withGHCiLib lbi && withVanillaLib lbi)
+ ifReplLib = when forRepl
+ comp = compiler lbi
+ implInfo = getImplInfo comp
+ hole_insts = map (\(k,(p,n)) -> (k,(InstalledPackageInfo.packageKey p,n)))
+ (instantiatedWith lbi)
+ nativeToo = ghcjsNativeToo comp
+
+ (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi)
+ let runGhcjsProg = runGHC verbosity ghcjsProg comp
+ libBi = libBuildInfo lib
+ isGhcjsDynamic = isDynamic comp
+ dynamicTooSupported = supportsDynamicToo comp
+ doingTH = EnableExtension TemplateHaskell `elem` allExtensions libBi
+ forceVanillaLib = doingTH && not isGhcjsDynamic
+ forceSharedLib = doingTH && isGhcjsDynamic
+ -- TH always needs default libs, even when building for profiling
+
+ -- Determine if program coverage should be enabled and if so, what
+ -- '-hpcdir' should be.
+ let isCoverageEnabled = fromFlag $ configCoverage $ configFlags lbi
+ distPref = fromFlag $ configDistPref $ configFlags lbi
+ hpcdir way
+ | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way cname
+ | otherwise = mempty
+
+ createDirectoryIfMissingVerbose verbosity True libTargetDir
+ -- TODO: do we need to put hs-boot files into place for mutually recursive
+ -- modules?
+ let cObjs = map (`replaceExtension` objExtension) (cSources libBi)
+ jsSrcs = jsSources libBi
+ baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir
+ linkJsLibOpts = mempty {
+ ghcOptExtra = toNubListR $
+ [ "-link-js-lib" , getHSLibraryName libName
+ , "-js-lib-outputdir", libTargetDir ] ++
+ concatMap (\x -> ["-js-lib-src",x]) jsSrcs
+ }
+ vanillaOptsNoJsLib = baseOpts `mappend` mempty {
+ ghcOptMode = toFlag GhcModeMake,
+ ghcOptNumJobs = numJobs,
+ ghcOptSigOf = hole_insts,
+ ghcOptInputModules = toNubListR $ libModules lib,
+ ghcOptHPCDir = hpcdir Hpc.Vanilla
+ }
+ vanillaOpts = vanillaOptsNoJsLib `mappend` linkJsLibOpts
+
+ profOpts = adjustExts "p_hi" "p_o" vanillaOpts `mappend` mempty {
+ ghcOptProfilingMode = toFlag True,
+ ghcOptExtra = toNubListR $
+ ghcjsProfOptions libBi,
+ ghcOptHPCDir = hpcdir Hpc.Prof
+ }
+ sharedOpts = adjustExts "dyn_hi" "dyn_o" vanillaOpts `mappend` mempty {
+ ghcOptDynLinkMode = toFlag GhcDynamicOnly,
+ ghcOptFPic = toFlag True,
+ ghcOptExtra = toNubListR $
+ ghcjsSharedOptions libBi,
+ ghcOptHPCDir = hpcdir Hpc.Dyn
+ }
+ linkerOpts = mempty {
+ ghcOptLinkOptions = toNubListR $ PD.ldOptions libBi,
+ ghcOptLinkLibs = toNubListR $ extraLibs libBi,
+ ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi,
+ ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi,
+ ghcOptInputFiles =
+ toNubListR $ [libTargetDir </> x | x <- cObjs] ++ jsSrcs
+ }
+ replOpts = vanillaOptsNoJsLib {
+ ghcOptExtra = overNubListR
+ Internal.filterGhciFlags
+ (ghcOptExtra vanillaOpts),
+ ghcOptNumJobs = mempty
+ }
+ `mappend` linkerOpts
+ `mappend` mempty {
+ ghcOptMode = toFlag GhcModeInteractive,
+ ghcOptOptimisation = toFlag GhcNoOptimisation
+ }
+
+ vanillaSharedOpts = vanillaOpts `mappend`
+ mempty {
+ ghcOptDynLinkMode = toFlag GhcStaticAndDynamic,
+ ghcOptDynHiSuffix = toFlag "dyn_hi",
+ ghcOptDynObjSuffix = toFlag "dyn_o",
+ ghcOptHPCDir = hpcdir Hpc.Dyn
+ }
+
+ unless (forRepl || (null (libModules lib) && null jsSrcs && null cObjs)) $
+ do let vanilla = whenVanillaLib forceVanillaLib (runGhcjsProg vanillaOpts)
+ shared = whenSharedLib forceSharedLib (runGhcjsProg sharedOpts)
+ useDynToo = dynamicTooSupported &&
+ (forceVanillaLib || withVanillaLib lbi) &&
+ (forceSharedLib || withSharedLib lbi) &&
+ null (ghcjsSharedOptions libBi)
+ if useDynToo
+ then do
+ runGhcjsProg vanillaSharedOpts
+ case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of
+ (Cabal.Flag dynDir, Cabal.Flag vanillaDir) -> do
+ -- When the vanilla and shared library builds are done
+ -- in one pass, only one set of HPC module interfaces
+ -- are generated. This set should suffice for both
+ -- static and dynamically linked executables. We copy
+ -- the modules interfaces so they are available under
+ -- both ways.
+ copyDirectoryRecursive verbosity dynDir vanillaDir
+ _ -> return ()
+ else if isGhcjsDynamic
+ then do shared; vanilla
+ else do vanilla; shared
+ whenProfLib (runGhcjsProg profOpts)
+
+ -- build any C sources
+ unless (null (cSources libBi) || not nativeToo) $ do
+ info verbosity "Building C Sources..."
+ sequence_
+ [ do let vanillaCcOpts =
+ (Internal.componentCcGhcOptions verbosity implInfo
+ lbi libBi clbi libTargetDir filename)
+ profCcOpts = vanillaCcOpts `mappend` mempty {
+ ghcOptProfilingMode = toFlag True,
+ ghcOptObjSuffix = toFlag "p_o"
+ }
+ sharedCcOpts = vanillaCcOpts `mappend` mempty {
+ ghcOptFPic = toFlag True,
+ ghcOptDynLinkMode = toFlag GhcDynamicOnly,
+ ghcOptObjSuffix = toFlag "dyn_o"
+ }
+ odir = fromFlag (ghcOptObjDir vanillaCcOpts)
+ createDirectoryIfMissingVerbose verbosity True odir
+ runGhcjsProg vanillaCcOpts
+ whenSharedLib forceSharedLib (runGhcjsProg sharedCcOpts)
+ whenProfLib (runGhcjsProg profCcOpts)
+ | filename <- cSources libBi]
+
+ -- TODO: problem here is we need the .c files built first, so we can load them
+ -- with ghci, but .c files can depend on .h files generated by ghc by ffi
+ -- exports.
+ unless (null (libModules lib)) $
+ ifReplLib (runGhcjsProg replOpts)
+
+ -- link:
+ when (nativeToo && not forRepl) $ do
+ info verbosity "Linking..."
+ let cProfObjs = map (`replaceExtension` ("p_" ++ objExtension))
+ (cSources libBi)
+ cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension))
+ (cSources libBi)
+ cid = compilerId (compiler lbi)
+ vanillaLibFilePath = libTargetDir </> mkLibName libName
+ profileLibFilePath = libTargetDir </> mkProfLibName libName
+ sharedLibFilePath = libTargetDir </> mkSharedLibName cid libName
+ ghciLibFilePath = libTargetDir </> Internal.mkGHCiLibName libName
+
+ hObjs <- Internal.getHaskellObjects implInfo lib lbi
+ libTargetDir objExtension True
+ hProfObjs <-
+ if (withProfLib lbi)
+ then Internal.getHaskellObjects implInfo lib lbi
+ libTargetDir ("p_" ++ objExtension) True
+ else return []
+ hSharedObjs <-
+ if (withSharedLib lbi)
+ then Internal.getHaskellObjects implInfo lib lbi
+ libTargetDir ("dyn_" ++ objExtension) False
+ else return []
+
+ unless (null hObjs && null cObjs) $ do
+
+ let staticObjectFiles =
+ hObjs
+ ++ map (libTargetDir </>) cObjs
+ profObjectFiles =
+ hProfObjs
+ ++ map (libTargetDir </>) cProfObjs
+ ghciObjFiles =
+ hObjs
+ ++ map (libTargetDir </>) cObjs
+ dynamicObjectFiles =
+ hSharedObjs
+ ++ map (libTargetDir </>) cSharedObjs
+ -- After the relocation lib is created we invoke ghc -shared
+ -- with the dependencies spelled out as -package arguments
+ -- and ghc invokes the linker with the proper library paths
+ ghcSharedLinkArgs =
+ mempty {
+ ghcOptShared = toFlag True,
+ ghcOptDynLinkMode = toFlag GhcDynamicOnly,
+ ghcOptInputFiles = toNubListR dynamicObjectFiles,
+ ghcOptOutputFile = toFlag sharedLibFilePath,
+ ghcOptNoAutoLinkPackages = toFlag True,
+ ghcOptPackageDBs = withPackageDB lbi,
+ ghcOptPackages = toNubListR $
+ Internal.mkGhcOptPackages clbi,
+ ghcOptLinkLibs = toNubListR $ extraLibs libBi,
+ ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi
+ }
+
+ whenVanillaLib False $ do
+ Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles
+
+ whenProfLib $ do
+ Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles
+
+ whenGHCiLib $ do
+ (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi)
+ Ld.combineObjectFiles verbosity ldProg
+ ghciLibFilePath ghciObjFiles
+
+ whenSharedLib False $
+ runGhcjsProg ghcSharedLinkArgs
+
+-- | Start a REPL without loading any source files.
+startInterpreter :: Verbosity -> ProgramConfiguration -> Compiler
+ -> PackageDBStack -> IO ()
+startInterpreter verbosity conf comp packageDBs = do
+ let replOpts = mempty {
+ ghcOptMode = toFlag GhcModeInteractive,
+ ghcOptPackageDBs = packageDBs
+ }
+ checkPackageDbStack packageDBs
+ (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram conf
+ runGHC verbosity ghcjsProg comp replOpts
+
+buildExe, replExe :: Verbosity -> Cabal.Flag (Maybe Int)
+ -> PackageDescription -> LocalBuildInfo
+ -> Executable -> ComponentLocalBuildInfo -> IO ()
+buildExe = buildOrReplExe False
+replExe = buildOrReplExe True
+
+buildOrReplExe :: Bool -> Verbosity -> Cabal.Flag (Maybe Int)
+ -> PackageDescription -> LocalBuildInfo
+ -> Executable -> ComponentLocalBuildInfo -> IO ()
+buildOrReplExe forRepl verbosity numJobs _pkg_descr lbi
+ exe@Executable { exeName = exeName', modulePath = modPath } clbi = do
+
+ (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi)
+ let comp = compiler lbi
+ implInfo = getImplInfo comp
+ runGhcjsProg = runGHC verbosity ghcjsProg comp
+ exeBi = buildInfo exe
+
+ -- exeNameReal, the name that GHC really uses (with .exe on Windows)
+ let exeNameReal = exeName' <.>
+ (if takeExtension exeName' /= ('.':exeExtension)
+ then exeExtension
+ else "")
+
+ let targetDir = (buildDir lbi) </> exeName'
+ let exeDir = targetDir </> (exeName' ++ "-tmp")
+ createDirectoryIfMissingVerbose verbosity True targetDir
+ createDirectoryIfMissingVerbose verbosity True exeDir
+ -- TODO: do we need to put hs-boot files into place for mutually recursive
+ -- modules? FIX: what about exeName.hi-boot?
+
+ -- Determine if program coverage should be enabled and if so, what
+ -- '-hpcdir' should be.
+ let isCoverageEnabled = fromFlag $ configCoverage $ configFlags lbi
+ distPref = fromFlag $ configDistPref $ configFlags lbi
+ hpcdir way
+ | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way exeName'
+ | otherwise = mempty
+
+ -- build executables
+
+ srcMainFile <- findFile (exeDir : hsSourceDirs exeBi) modPath
+ let isGhcjsDynamic = isDynamic comp
+ dynamicTooSupported = supportsDynamicToo comp
+ buildRunner = case clbi of
+ ExeComponentLocalBuildInfo {} -> False
+ _ -> True
+ isHaskellMain = elem (takeExtension srcMainFile) [".hs", ".lhs"]
+ jsSrcs = jsSources exeBi
+ cSrcs = cSources exeBi ++ [srcMainFile | not isHaskellMain]
+ cObjs = map (`replaceExtension` objExtension) cSrcs
+ nativeToo = ghcjsNativeToo comp
+ baseOpts = (componentGhcOptions verbosity lbi exeBi clbi exeDir)
+ `mappend` mempty {
+ ghcOptMode = toFlag GhcModeMake,
+ ghcOptInputFiles = toNubListR $
+ [ srcMainFile | isHaskellMain],
+ ghcOptInputModules = toNubListR $
+ [ m | not isHaskellMain, m <- exeModules exe],
+ ghcOptExtra =
+ if buildRunner then toNubListR ["-build-runner"]
+ else mempty
+ }
+ staticOpts = baseOpts `mappend` mempty {
+ ghcOptDynLinkMode = toFlag GhcStaticOnly,
+ ghcOptHPCDir = hpcdir Hpc.Vanilla
+ }
+ profOpts = adjustExts "p_hi" "p_o" baseOpts `mappend` mempty {
+ ghcOptProfilingMode = toFlag True,
+ ghcOptExtra = toNubListR $ ghcjsProfOptions exeBi,
+ ghcOptHPCDir = hpcdir Hpc.Prof
+ }
+ dynOpts = adjustExts "dyn_hi" "dyn_o" baseOpts `mappend` mempty {
+ ghcOptDynLinkMode = toFlag GhcDynamicOnly,
+ ghcOptExtra = toNubListR $
+ ghcjsSharedOptions exeBi,
+ ghcOptHPCDir = hpcdir Hpc.Dyn
+ }
+ dynTooOpts = adjustExts "dyn_hi" "dyn_o" staticOpts `mappend` mempty {
+ ghcOptDynLinkMode = toFlag GhcStaticAndDynamic,
+ ghcOptHPCDir = hpcdir Hpc.Dyn
+ }
+ linkerOpts = mempty {
+ ghcOptLinkOptions = toNubListR $ PD.ldOptions exeBi,
+ ghcOptLinkLibs = toNubListR $ extraLibs exeBi,
+ ghcOptLinkLibPath = toNubListR $ extraLibDirs exeBi,
+ ghcOptLinkFrameworks = toNubListR $ PD.frameworks exeBi,
+ ghcOptInputFiles = toNubListR $
+ [exeDir </> x | x <- cObjs] ++ jsSrcs
+ }
+ replOpts = baseOpts {
+ ghcOptExtra = overNubListR
+ Internal.filterGhciFlags
+ (ghcOptExtra baseOpts)
+ }
+ -- For a normal compile we do separate invocations of ghc for
+ -- compiling as for linking. But for repl we have to do just
+ -- the one invocation, so that one has to include all the
+ -- linker stuff too, like -l flags and any .o files from C
+ -- files etc.
+ `mappend` linkerOpts
+ `mappend` mempty {
+ ghcOptMode = toFlag GhcModeInteractive,
+ ghcOptOptimisation = toFlag GhcNoOptimisation
+ }
+ commonOpts | withProfExe lbi = profOpts
+ | withDynExe lbi = dynOpts
+ | otherwise = staticOpts
+ compileOpts | useDynToo = dynTooOpts
+ | otherwise = commonOpts
+ withStaticExe = (not $ withProfExe lbi) && (not $ withDynExe lbi)
+
+ -- For building exe's that use TH with -prof or -dynamic we actually have
+ -- to build twice, once without -prof/-dynamic and then again with
+ -- -prof/-dynamic. This is because the code that TH needs to run at
+ -- compile time needs to be the vanilla ABI so it can be loaded up and run
+ -- by the compiler.
+ -- With dynamic-by-default GHC the TH object files loaded at compile-time
+ -- need to be .dyn_o instead of .o.
+ doingTH = EnableExtension TemplateHaskell `elem` allExtensions exeBi
+ -- Should we use -dynamic-too instead of compiling twice?
+ useDynToo = dynamicTooSupported && isGhcjsDynamic
+ && doingTH && withStaticExe && null (ghcjsSharedOptions exeBi)
+ compileTHOpts | isGhcjsDynamic = dynOpts
+ | otherwise = staticOpts
+ compileForTH
+ | forRepl = False
+ | useDynToo = False
+ | isGhcjsDynamic = doingTH && (withProfExe lbi || withStaticExe)
+ | otherwise = doingTH && (withProfExe lbi || withDynExe lbi)
+
+ linkOpts = commonOpts `mappend`
+ linkerOpts `mappend` mempty {
+ ghcOptLinkNoHsMain = toFlag (not isHaskellMain)
+ }
+
+ -- Build static/dynamic object files for TH, if needed.
+ when compileForTH $
+ runGhcjsProg compileTHOpts { ghcOptNoLink = toFlag True
+ , ghcOptNumJobs = numJobs }
+
+ unless forRepl $
+ runGhcjsProg compileOpts { ghcOptNoLink = toFlag True
+ , ghcOptNumJobs = numJobs }
+
+ -- build any C sources
+ unless (null cSrcs || not nativeToo) $ do
+ info verbosity "Building C Sources..."
+ sequence_
+ [ do let opts = (Internal.componentCcGhcOptions verbosity implInfo lbi exeBi
+ clbi exeDir filename) `mappend` mempty {
+ ghcOptDynLinkMode = toFlag (if withDynExe lbi
+ then GhcDynamicOnly
+ else GhcStaticOnly),
+ ghcOptProfilingMode = toFlag (withProfExe lbi)
+ }
+ odir = fromFlag (ghcOptObjDir opts)
+ createDirectoryIfMissingVerbose verbosity True odir
+ runGhcjsProg opts
+ | filename <- cSrcs ]
+
+ -- TODO: problem here is we need the .c files built first, so we can load them
+ -- with ghci, but .c files can depend on .h files generated by ghc by ffi
+ -- exports.
+ when forRepl $ runGhcjsProg replOpts
+
+ -- link:
+ unless forRepl $ do
+ info verbosity "Linking..."
+ runGhcjsProg linkOpts { ghcOptOutputFile = toFlag (targetDir </> exeNameReal) }
+
+-- |Install for ghc, .hi, .a and, if --with-ghci given, .o
+installLib :: Verbosity
+ -> LocalBuildInfo
+ -> FilePath -- ^install location
+ -> FilePath -- ^install location for dynamic libraries
+ -> FilePath -- ^Build location
+ -> PackageDescription
+ -> Library
+ -> ComponentLocalBuildInfo
+ -> IO ()
+installLib verbosity lbi targetDir dynlibTargetDir builtDir _pkg lib clbi = do
+ whenVanilla $ copyModuleFiles "js_hi"
+ whenProf $ copyModuleFiles "js_p_hi"
+ whenShared $ copyModuleFiles "js_dyn_hi"
+
+ whenVanilla $ installOrdinary builtDir targetDir $ toJSLibName vanillaLibName
+ whenProf $ installOrdinary builtDir targetDir $ toJSLibName profileLibName
+ whenShared $ installShared builtDir dynlibTargetDir $ toJSLibName sharedLibName
+
+ when (ghcjsNativeToo $ compiler lbi) $ do
+ -- copy .hi files over:
+ whenVanilla $ copyModuleFiles "hi"
+ whenProf $ copyModuleFiles "p_hi"
+ whenShared $ copyModuleFiles "dyn_hi"
+
+ -- copy the built library files over:
+ whenVanilla $ installOrdinary builtDir targetDir vanillaLibName
+ whenProf $ installOrdinary builtDir targetDir profileLibName
+ whenGHCi $ installOrdinary builtDir targetDir ghciLibName
+ whenShared $ installShared builtDir dynlibTargetDir sharedLibName
+
+ where
+ install isShared srcDir dstDir name = do
+ let src = srcDir </> name
+ dst = dstDir </> name
+ createDirectoryIfMissingVerbose verbosity True dstDir
+
+ if isShared
+ then installExecutableFile verbosity src dst
+ else installOrdinaryFile verbosity src dst
+
+ when (stripLibs lbi) $ Strip.stripLib verbosity
+ (hostPlatform lbi) (withPrograms lbi) dst
+
+ installOrdinary = install False
+ installShared = install True
+
+ copyModuleFiles ext =
+ findModuleFiles [builtDir] [ext] (libModules lib)
+ >>= installOrdinaryFiles verbosity targetDir
+
+ cid = compilerId (compiler lbi)
+ libName = componentLibraryName clbi
+ vanillaLibName = mkLibName libName
+ profileLibName = mkProfLibName libName
+ ghciLibName = Internal.mkGHCiLibName libName
+ sharedLibName = (mkSharedLibName cid) libName
+
+ hasLib = not $ null (libModules lib)
+ && null (cSources (libBuildInfo lib))
+ whenVanilla = when (hasLib && withVanillaLib lbi)
+ whenProf = when (hasLib && withProfLib lbi)
+ whenGHCi = when (hasLib && withGHCiLib lbi)
+ whenShared = when (hasLib && withSharedLib lbi)
+
+installExe :: Verbosity
+ -> LocalBuildInfo
+ -> InstallDirs FilePath -- ^Where to copy the files to
+ -> FilePath -- ^Build location
+ -> (FilePath, FilePath) -- ^Executable (prefix,suffix)
+ -> PackageDescription
+ -> Executable
+ -> IO ()
+installExe verbosity lbi installDirs buildPref
+ (progprefix, progsuffix) _pkg exe = do
+ let binDir = bindir installDirs
+ createDirectoryIfMissingVerbose verbosity True binDir
+ let exeFileName = exeName exe
+ fixedExeBaseName = progprefix ++ exeName exe ++ progsuffix
+ installBinary dest = do
+ rawSystemProgramConf verbosity ghcjsProgram (withPrograms lbi) $
+ [ "--install-executable"
+ , buildPref </> exeName exe </> exeFileName
+ , "-o", dest
+ ] ++
+ case (stripExes lbi, lookupProgram stripProgram $ withPrograms lbi) of
+ (True, Just strip) -> ["-strip-program", programPath strip]
+ _ -> []
+ installBinary (binDir </> fixedExeBaseName)
+
+libAbiHash :: Verbosity -> PackageDescription -> LocalBuildInfo
+ -> Library -> ComponentLocalBuildInfo -> IO String
+libAbiHash verbosity _pkg_descr lbi lib clbi = do
+ let
+ libBi = libBuildInfo lib
+ comp = compiler lbi
+ vanillaArgs =
+ (componentGhcOptions verbosity lbi libBi clbi (buildDir lbi))
+ `mappend` mempty {
+ ghcOptMode = toFlag GhcModeAbiHash,
+ ghcOptInputModules = toNubListR $ exposedModules lib
+ }
+ profArgs = adjustExts "js_p_hi" "js_p_o" vanillaArgs `mappend` mempty {
+ ghcOptProfilingMode = toFlag True,
+ ghcOptExtra = toNubListR (ghcjsProfOptions libBi)
+ }
+ ghcArgs = if withVanillaLib lbi then vanillaArgs
+ else if withProfLib lbi then profArgs
+ else error "libAbiHash: Can't find an enabled library way"
+ --
+ (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi)
+ getProgramInvocationOutput verbosity (ghcInvocation ghcjsProg comp ghcArgs)
+
+adjustExts :: String -> String -> GhcOptions -> GhcOptions
+adjustExts hiSuf objSuf opts =
+ opts `mappend` mempty {
+ ghcOptHiSuffix = toFlag hiSuf,
+ ghcOptObjSuffix = toFlag objSuf
+ }
+
+registerPackage :: Verbosity
+ -> InstalledPackageInfo
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> Bool
+ -> PackageDBStack
+ -> IO ()
+registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs =
+ HcPkg.reregister (hcPkgInfo $ withPrograms lbi) verbosity packageDbs
+ (Right installedPkgInfo)
+
+componentGhcOptions :: Verbosity -> LocalBuildInfo
+ -> BuildInfo -> ComponentLocalBuildInfo -> FilePath
+ -> GhcOptions
+componentGhcOptions verbosity lbi bi clbi odir =
+ let opts = Internal.componentGhcOptions verbosity lbi bi clbi odir
+ in opts { ghcOptExtra = ghcOptExtra opts `mappend` toNubListR
+ (hcOptions GHCJS bi)
+ }
+
+ghcjsProfOptions :: BuildInfo -> [String]
+ghcjsProfOptions bi =
+ hcProfOptions GHC bi `mappend` hcProfOptions GHCJS bi
+
+ghcjsSharedOptions :: BuildInfo -> [String]
+ghcjsSharedOptions bi =
+ hcSharedOptions GHC bi `mappend` hcSharedOptions GHCJS bi
+
+isDynamic :: Compiler -> Bool
+isDynamic = Internal.ghcLookupProperty "GHC Dynamic"
+
+supportsDynamicToo :: Compiler -> Bool
+supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too"
+
+findGhcjsGhcVersion :: Verbosity -> FilePath -> IO (Maybe Version)
+findGhcjsGhcVersion verbosity pgm =
+ findProgramVersion "--numeric-ghc-version" id verbosity pgm
+
+findGhcjsPkgGhcjsVersion :: Verbosity -> FilePath -> IO (Maybe Version)
+findGhcjsPkgGhcjsVersion verbosity pgm =
+ findProgramVersion "--numeric-ghcjs-version" id verbosity pgm
+
+-- -----------------------------------------------------------------------------
+-- Registering
+
+hcPkgInfo :: ProgramConfiguration -> HcPkg.HcPkgInfo
+hcPkgInfo conf = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram = ghcjsPkgProg
+ , HcPkg.noPkgDbStack = False
+ , HcPkg.noVerboseFlag = False
+ , HcPkg.flagPackageConf = False
+ , HcPkg.useSingleFileDb = v < [7,9]
+ }
+ where
+ v = versionBranch ver
+ Just ghcjsPkgProg = lookupProgram ghcjsPkgProgram conf
+ Just ver = programVersion ghcjsPkgProg
+
+-- | Get the JavaScript file name and command and arguments to run a
+-- program compiled by GHCJS
+-- the exe should be the base program name without exe extension
+runCmd :: ProgramConfiguration -> FilePath
+ -> (FilePath, FilePath, [String])
+runCmd conf exe =
+ ( script
+ , programPath ghcjsProg
+ , programDefaultArgs ghcjsProg ++ programOverrideArgs ghcjsProg ++ ["--run"]
+ )
+ where
+ script = exe <.> "jsexe" </> "all" <.> "js"
+ Just ghcjsProg = lookupProgram ghcjsProgram conf
diff --git a/cabal/Cabal/Distribution/Simple/Haddock.hs b/cabal/Cabal/Distribution/Simple/Haddock.hs
index 7ad86a1..3746395 100644
--- a/cabal/Cabal/Distribution/Simple/Haddock.hs
+++ b/cabal/Cabal/Distribution/Simple/Haddock.hs
@@ -2,95 +2,69 @@
-- |
-- Module : Distribution.Simple.Haddock
-- Copyright : Isaac Jones 2003-2005
+-- License : BSD3
--
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
--
--- This module deals with the @haddock@ and @hscolour@ commands. Sadly this is a
--- rather complicated module. It deals with two versions of haddock (0.x and
--- 2.x). It has to do pre-processing which involves \'unlit\'ing and using
--- @-D__HADDOCK__@ for any source code that uses @cpp@. It uses information
--- about installed packages (from @ghc-pkg@) to find the locations of
--- documentation for dependent packages, so it can create links.
+-- This module deals with the @haddock@ and @hscolour@ commands.
+-- It uses information about installed packages (from @ghc-pkg@) to find the
+-- locations of documentation for dependent packages, so it can create links.
--
--- The @hscolour@ support allows generating html versions of the original
+-- The @hscolour@ support allows generating HTML versions of the original
-- source, with coloured syntax highlighting.
-{- 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.Haddock (
- haddock, hscolour
+ haddock, hscolour,
+
+ haddockPackagePaths
) where
+import qualified Distribution.Simple.GHC as GHC
+import qualified Distribution.Simple.GHCJS as GHCJS
+
-- local
import Distribution.Package
( PackageIdentifier(..)
, Package(..)
- , PackageName(..), packageName )
+ , PackageName(..), packageName, LibraryName(..) )
import qualified Distribution.ModuleName as ModuleName
import Distribution.PackageDescription as PD
- ( PackageDescription(..), BuildInfo(..), allExtensions
+ ( PackageDescription(..), BuildInfo(..), usedExtensions
+ , hcSharedOptions
, Library(..), hasLibs, Executable(..)
, TestSuite(..), TestSuiteInterface(..)
, Benchmark(..), BenchmarkInterface(..) )
import Distribution.Simple.Compiler
- ( Compiler(..), compilerVersion )
-import Distribution.Simple.GHC ( componentGhcOptions, ghcLibDir )
+ ( Compiler, compilerInfo, CompilerFlavor(..)
+ , compilerFlavor, compilerCompatVersion )
import Distribution.Simple.Program.GHC
( GhcOptions(..), GhcDynLinkMode(..), renderGhcOptions )
import Distribution.Simple.Program
- ( ConfiguredProgram(..), requireProgramVersion
+ ( ConfiguredProgram(..), lookupProgramVersion, requireProgramVersion
, rawSystemProgram, rawSystemProgramStdout
, hscolourProgram, haddockProgram )
-import Distribution.Simple.PreProcess (ppCpp', ppUnlit
- , PPSuffixHandler, runSimplePreProcessor
- , preprocessComponent)
+import Distribution.Simple.PreProcess
+ ( PPSuffixHandler, preprocessComponent)
import Distribution.Simple.Setup
- ( defaultHscolourFlags, Flag(..), toFlag, flagToMaybe, flagToList, fromFlag
- , HaddockFlags(..), HscolourFlags(..) )
+ ( defaultHscolourFlags
+ , Flag(..), toFlag, flagToMaybe, flagToList, fromFlag
+ , HaddockFlags(..), HscolourFlags(..) )
import Distribution.Simple.Build (initialBuildSteps)
-import Distribution.Simple.InstallDirs (InstallDirs(..), PathTemplateEnv, PathTemplate,
- PathTemplateVariable(..),
- toPathTemplate, fromPathTemplate,
- substPathTemplate, initialPathTemplateEnv)
+import Distribution.Simple.InstallDirs
+ ( InstallDirs(..)
+ , PathTemplateEnv, PathTemplate, PathTemplateVariable(..)
+ , toPathTemplate, fromPathTemplate
+ , substPathTemplate, initialPathTemplateEnv )
import Distribution.Simple.LocalBuildInfo
( LocalBuildInfo(..), Component(..), ComponentLocalBuildInfo(..)
, withAllComponentsInBuildOrder )
-import Distribution.Simple.BuildPaths ( haddockName,
- hscolourPref, autogenModulesDir,
- )
+import Distribution.Simple.BuildPaths
+ ( haddockName, hscolourPref, autogenModulesDir)
import Distribution.Simple.PackageIndex (dependencyClosure)
import qualified Distribution.Simple.PackageIndex as PackageIndex
import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
- ( InstalledPackageInfo_(..) )
+ ( InstalledPackageInfo(..) )
import Distribution.InstalledPackageInfo
( InstalledPackageInfo )
import Distribution.Simple.Utils
@@ -102,45 +76,65 @@ import Distribution.Simple.Utils
, findFileWithExtension, findFile )
import Distribution.Text
( display, simpleParse )
+import Distribution.Utils.NubList
+ ( toNubListR )
import Distribution.Verbosity
import Language.Haskell.Extension
--- Base
-import System.Directory(removeFile, doesFileExist, createDirectoryIfMissing)
-import Control.Monad ( when, guard, forM_ )
-import Control.Exception (assert)
+
+import Control.Monad ( when, forM_ )
+import Data.Either ( rights )
+import Data.Foldable ( traverse_ )
import Data.Monoid
-import Data.Maybe ( fromMaybe, listToMaybe )
+import Data.Maybe ( fromMaybe, listToMaybe )
-import System.FilePath((</>), (<.>), splitFileName, splitExtension,
- normalise, splitPath, joinPath, isAbsolute )
-import System.IO (hClose, hPutStrLn)
+import System.Directory (doesFileExist)
+import System.FilePath ( (</>), (<.>)
+ , normalise, splitPath, joinPath, isAbsolute )
+import System.IO (hClose, hPutStrLn, hSetEncoding, utf8)
import Distribution.Version
+-- ------------------------------------------------------------------------------
-- Types
--- | record that represents the arguments to the haddock executable, a product monoid.
+-- | A record that represents the arguments to the haddock executable, a product
+-- monoid.
data HaddockArgs = HaddockArgs {
- argInterfaceFile :: Flag FilePath, -- ^ path of the interface file, relative to argOutputDir, required.
- argPackageName :: Flag PackageIdentifier, -- ^ package name, required.
- argHideModules :: (All,[ModuleName.ModuleName]), -- ^ (hide modules ?, modules to hide)
- argIgnoreExports :: Any, -- ^ ingore export lists in modules?
- argLinkSource :: Flag (Template,Template), -- ^ (template for modules, template for symbols)
- argCssFile :: Flag FilePath, -- ^ optinal custom css file.
- argContents :: Flag String, -- ^ optional url to contents page
+ argInterfaceFile :: Flag FilePath,
+ -- ^ Path to the interface file, relative to argOutputDir, required.
+ argPackageName :: Flag PackageIdentifier,
+ -- ^ Package name, required.
+ argHideModules :: (All,[ModuleName.ModuleName]),
+ -- ^ (Hide modules ?, modules to hide)
+ argIgnoreExports :: Any,
+ -- ^ Ignore export lists in modules?
+ argLinkSource :: Flag (Template,Template,Template),
+ -- ^ (Template for modules, template for symbols, template for lines).
+ argCssFile :: Flag FilePath,
+ -- ^ Optional custom CSS file.
+ argContents :: Flag String,
+ -- ^ Optional URL to contents page.
argVerbose :: Any,
- argOutput :: Flag [Output], -- ^ Html or Hoogle doc or both? required.
- argInterfaces :: [(FilePath, Maybe String)], -- ^ [(interface file, URL to the html docs for links)]
- argOutputDir :: Directory, -- ^ where to generate the documentation.
- argTitle :: Flag String, -- ^ page's title, required.
- argPrologue :: Flag String, -- ^ prologue text, required.
- argGhcOptions :: Flag (GhcOptions, Version), -- ^ additional flags to pass to ghc for haddock-2
- argGhcLibDir :: Flag FilePath, -- ^ to find the correct ghc, required by haddock-2.
- argTargets :: [FilePath] -- ^ modules to process.
+ argOutput :: Flag [Output],
+ -- ^ HTML or Hoogle doc or both? Required.
+ argInterfaces :: [(FilePath, Maybe String)],
+ -- ^ [(Interface file, URL to the HTML docs for links)].
+ argOutputDir :: Directory,
+ -- ^ Where to generate the documentation.
+ argTitle :: Flag String,
+ -- ^ Page title, required.
+ argPrologue :: Flag String,
+ -- ^ Prologue text, required.
+ argGhcOptions :: Flag (GhcOptions, Version),
+ -- ^ Additional flags to pass to GHC.
+ argGhcLibDir :: Flag FilePath,
+ -- ^ To find the correct GHC, required.
+ argTargets :: [FilePath]
+ -- ^ Modules to process.
}
--- | the FilePath of a directory, it's a monoid under (</>)
+-- | The FilePath of a directory, it's a monoid under '(</>)'.
newtype Directory = Dir { unDir' :: FilePath } deriving (Read,Show,Eq,Ord)
unDir :: Directory -> FilePath
@@ -150,10 +144,14 @@ type Template = String
data Output = Html | Hoogle
--- --------------------------------------------------------------------------
+-- ------------------------------------------------------------------------------
-- Haddock support
-haddock :: PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HaddockFlags -> IO ()
+haddock :: PackageDescription
+ -> LocalBuildInfo
+ -> [PPSuffixHandler]
+ -> HaddockFlags
+ -> IO ()
haddock pkg_descr _ _ haddockFlags
| not (hasLibs pkg_descr)
&& not (fromFlag $ haddockExecutables haddockFlags)
@@ -165,45 +163,38 @@ haddock pkg_descr _ _ haddockFlags
++ " --benchmarks flags."
haddock pkg_descr lbi suffixes flags = do
-
setupMessage verbosity "Running Haddock for" (packageId pkg_descr)
(confHaddock, version, _) <-
requireProgramVersion verbosity haddockProgram
- (orLaterVersion (Version [0,6] [])) (withPrograms lbi)
+ (orLaterVersion (Version [2,0] [])) (withPrograms lbi)
-- various sanity checks
- let isVersion2 = version >= Version [2,0] []
-
when ( flag haddockHoogle
- && version > Version [2] []
&& version < Version [2,2] []) $
die "haddock 2.0 and 2.1 do not support the --hoogle flag."
- when (flag haddockHscolour && version < Version [0,8] []) $
- die "haddock --hyperlink-source requires Haddock version 0.8 or later"
-
- when isVersion2 $ do
- haddockGhcVersionStr <- rawSystemProgramStdout verbosity confHaddock
- ["--ghc-version"]
- case simpleParse haddockGhcVersionStr of
- Nothing -> die "Could not get GHC version from Haddock"
- Just haddockGhcVersion
- | haddockGhcVersion == ghcVersion -> return ()
- | otherwise -> die $
- "Haddock's internal GHC version must match the configured "
- ++ "GHC version.\n"
- ++ "The GHC version is " ++ display ghcVersion ++ " but "
- ++ "haddock is using GHC version " ++ display haddockGhcVersion
- where ghcVersion = compilerVersion comp
+ haddockGhcVersionStr <- rawSystemProgramStdout verbosity confHaddock
+ ["--ghc-version"]
+ case (simpleParse haddockGhcVersionStr, compilerCompatVersion GHC comp) of
+ (Nothing, _) -> die "Could not get GHC version from Haddock"
+ (_, Nothing) -> die "Could not get GHC version from compiler"
+ (Just haddockGhcVersion, Just ghcVersion)
+ | haddockGhcVersion == ghcVersion -> return ()
+ | otherwise -> die $
+ "Haddock's internal GHC version must match the configured "
+ ++ "GHC version.\n"
+ ++ "The GHC version is " ++ display ghcVersion ++ " but "
+ ++ "haddock is using GHC version " ++ display haddockGhcVersion
-- the tools match the requests, we can proceed
initialBuildSteps (flag haddockDistPref) pkg_descr lbi verbosity
- when (flag haddockHscolour) $ hscolour' pkg_descr lbi suffixes $
- defaultHscolourFlags `mappend` haddockToHscolour flags
+ when (flag haddockHscolour) $
+ hscolour' (warn verbosity) pkg_descr lbi suffixes
+ (defaultHscolourFlags `mappend` haddockToHscolour flags)
- libdirArgs <- getGhcLibDir verbosity lbi isVersion2
+ libdirArgs <- getGhcLibDir verbosity lbi
let commonArgs = mconcat
[ libdirArgs
, fromFlags (haddockTemplateEnv lbi (packageId pkg_descr)) flags
@@ -215,24 +206,24 @@ haddock pkg_descr lbi suffixes flags = do
let
doExe com = case (compToExe com) of
Just exe -> do
- withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $ \tmp -> do
- let bi = buildInfo exe
- exeArgs <- fromExecutable verbosity tmp lbi exe clbi htmlTemplate
- exeArgs' <- prepareSources verbosity tmp
- lbi version bi (commonArgs `mappend` exeArgs)
- runHaddock verbosity tmpFileOpts comp confHaddock exeArgs'
+ withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $
+ \tmp -> do
+ exeArgs <- fromExecutable verbosity tmp lbi exe clbi htmlTemplate
+ version
+ let exeArgs' = commonArgs `mappend` exeArgs
+ runHaddock verbosity tmpFileOpts comp confHaddock exeArgs'
Nothing -> do
warn (fromFlag $ haddockVerbosity flags)
"Unsupported component, skipping..."
return ()
case component of
CLib lib -> do
- withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $ \tmp -> do
- let bi = libBuildInfo lib
- libArgs <- fromLibrary verbosity tmp lbi lib clbi htmlTemplate
- libArgs' <- prepareSources verbosity tmp
- lbi version bi (commonArgs `mappend` libArgs)
- runHaddock verbosity tmpFileOpts comp confHaddock libArgs'
+ withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $
+ \tmp -> do
+ libArgs <- fromLibrary verbosity tmp lbi lib clbi htmlTemplate
+ version
+ let libArgs' = commonArgs `mappend` libArgs
+ runHaddock verbosity tmpFileOpts comp confHaddock libArgs'
CExe _ -> when (flag haddockExecutables) $ doExe component
CTest _ -> when (flag haddockTestSuites) $ doExe component
CBench _ -> when (flag haddockBenchmarks) $ doExe component
@@ -246,66 +237,27 @@ haddock pkg_descr lbi suffixes flags = do
comp = compiler lbi
tmpFileOpts = defaultTempFileOptions { optKeepTempFiles = keepTempFiles }
flag f = fromFlag $ f flags
- htmlTemplate = fmap toPathTemplate . flagToMaybe . haddockHtmlLocation $ flags
-
--- | performs cpp and unlit preprocessing where needed on the files in
--- | argTargets, which must have an .hs or .lhs extension.
-prepareSources :: Verbosity
- -> FilePath
- -> LocalBuildInfo
- -> Version
- -> BuildInfo
- -> HaddockArgs
- -> IO HaddockArgs
-prepareSources verbosity tmp lbi haddockVersion bi args@HaddockArgs{argTargets=files} =
- mapM (mockPP tmp) files >>= \targets -> return args {argTargets=targets}
- where
- mockPP pref file = do
- let (filePref, fileName) = splitFileName file
- targetDir = pref </> filePref
- targetFile = targetDir </> fileName
- (targetFileNoext, targetFileExt) = splitExtension $ targetFile
- hsFile = targetFileNoext <.> "hs"
-
- assert (targetFileExt `elem` [".lhs",".hs"]) $ return ()
-
- createDirectoryIfMissing True targetDir
-
- if needsCpp
- then do
- runSimplePreProcessor (ppCpp' defines bi lbi)
- file targetFile verbosity
- else
- copyFileVerbose verbosity file targetFile
-
- when (targetFileExt == ".lhs") $ do
- runSimplePreProcessor ppUnlit targetFile hsFile verbosity
- removeFile targetFile
-
- return hsFile
- needsCpp = EnableExtension CPP `elem` allExtensions bi
- isVersion2 = haddockVersion >= Version [2,0] []
- defines | isVersion2 = [haddockVersionMacro]
- | otherwise = ["-D__HADDOCK__", haddockVersionMacro]
- haddockVersionMacro = "-D__HADDOCK_VERSION__="
- ++ show (v1 * 1000 + v2 * 10 + v3)
- where
- [v1, v2, v3] = take 3 $ versionBranch haddockVersion ++ [0,0]
-
---------------------------------------------------------------------------------------------------
--- constributions to HaddockArgs
+ htmlTemplate = fmap toPathTemplate . flagToMaybe . haddockHtmlLocation
+ $ flags
+
+-- ------------------------------------------------------------------------------
+-- Contributions to HaddockArgs.
fromFlags :: PathTemplateEnv -> HaddockFlags -> HaddockArgs
fromFlags env flags =
mempty {
- argHideModules = (maybe mempty (All . not) $ flagToMaybe (haddockInternal flags), mempty),
+ argHideModules = (maybe mempty (All . not)
+ $ flagToMaybe (haddockInternal flags), mempty),
argLinkSource = if fromFlag (haddockHscolour flags)
then Flag ("src/%{MODULE/./-}.html"
- ,"src/%{MODULE/./-}.html#%{NAME}")
+ ,"src/%{MODULE/./-}.html#%{NAME}"
+ ,"src/%{MODULE/./-}.html#line-%{LINE}")
else NoFlag,
argCssFile = haddockCss flags,
- argContents = fmap (fromPathTemplate . substPathTemplate env) (haddockContents flags),
- argVerbose = maybe mempty (Any . (>= deafening)) . flagToMaybe $ haddockVerbosity flags,
+ argContents = fmap (fromPathTemplate . substPathTemplate env)
+ (haddockContents flags),
+ argVerbose = maybe mempty (Any . (>= deafening))
+ . flagToMaybe $ haddockVerbosity flags,
argOutput =
Flag $ case [ Html | Flag True <- [haddockHtml flags] ] ++
[ Hoogle | Flag True <- [haddockHoogle flags] ]
@@ -316,12 +268,13 @@ fromFlags env flags =
fromPackageDescription :: PackageDescription -> HaddockArgs
fromPackageDescription pkg_descr =
- mempty {
- argInterfaceFile = Flag $ haddockName pkg_descr,
- argPackageName = Flag $ packageId $ pkg_descr,
- argOutputDir = Dir $ "doc" </> "html" </> display (packageName pkg_descr),
- argPrologue = Flag $ if null desc then synopsis pkg_descr else desc,
- argTitle = Flag $ showPkg ++ subtitle
+ mempty { argInterfaceFile = Flag $ haddockName pkg_descr,
+ argPackageName = Flag $ packageId $ pkg_descr,
+ argOutputDir = Dir $ "doc" </> "html"
+ </> display (packageName pkg_descr),
+ argPrologue = Flag $ if null desc then synopsis pkg_descr
+ else desc,
+ argTitle = Flag $ showPkg ++ subtitle
}
where
desc = PD.description pkg_descr
@@ -329,12 +282,25 @@ fromPackageDescription pkg_descr =
subtitle | null (synopsis pkg_descr) = ""
| otherwise = ": " ++ synopsis pkg_descr
+componentGhcOptions :: Verbosity -> LocalBuildInfo
+ -> BuildInfo -> ComponentLocalBuildInfo -> FilePath
+ -> GhcOptions
+componentGhcOptions verbosity lbi bi clbi odir =
+ let f = case compilerFlavor (compiler lbi) of
+ GHC -> GHC.componentGhcOptions
+ GHCJS -> GHCJS.componentGhcOptions
+ _ -> error $
+ "Distribution.Simple.Haddock.componentGhcOptions:" ++
+ "haddock only supports GHC and GHCJS"
+ in f verbosity lbi bi clbi odir
+
fromLibrary :: Verbosity
-> FilePath
-> LocalBuildInfo -> Library -> ComponentLocalBuildInfo
- -> Maybe PathTemplate -- ^ template for html location
+ -> Maybe PathTemplate -- ^ template for HTML location
+ -> Version
-> IO HaddockArgs
-fromLibrary verbosity tmp lbi lib clbi htmlTemplate = do
+fromLibrary verbosity tmp lbi lib clbi htmlTemplate haddockVersion = do
inFiles <- map snd `fmap` getLibSourceFiles lbi lib
ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate
let vanillaOpts = (componentGhcOptions normal lbi bi clbi (buildDir lbi)) {
@@ -342,22 +308,29 @@ fromLibrary verbosity tmp lbi lib clbi htmlTemplate = do
-- haddock stomps on our precious .hi
-- and .o files. Workaround by telling
-- haddock to write them elsewhere.
- ghcOptObjDir = toFlag tmp,
- ghcOptHiDir = toFlag tmp,
- ghcOptStubDir = toFlag tmp
- }
+ ghcOptObjDir = toFlag tmp,
+ ghcOptHiDir = toFlag tmp,
+ ghcOptStubDir = toFlag tmp
+ } `mappend` getGhcCppOpts haddockVersion bi
sharedOpts = vanillaOpts {
ghcOptDynLinkMode = toFlag GhcDynamicOnly,
ghcOptFPic = toFlag True,
ghcOptHiSuffix = toFlag "dyn_hi",
ghcOptObjSuffix = toFlag "dyn_o",
- ghcOptExtra = ghcSharedOptions bi
+ ghcOptExtra =
+ toNubListR $ hcSharedOptions GHC bi
+
}
opts <- if withVanillaLib lbi
then return vanillaOpts
else if withSharedLib lbi
then return sharedOpts
- else die "Must have vanilla or shared libraries enabled in order to run haddock"
+ else die $ "Must have vanilla or shared libraries "
+ ++ "enabled in order to run haddock"
+ ghcVersion <- maybe (die "Compiler has no GHC version")
+ return
+ (compilerCompatVersion GHC (compiler lbi))
+
return ifaceArgs {
argHideModules = (mempty,otherModules $ bi),
argGhcOptions = toFlag (opts, ghcVersion),
@@ -365,14 +338,14 @@ fromLibrary verbosity tmp lbi lib clbi htmlTemplate = do
}
where
bi = libBuildInfo lib
- ghcVersion = compilerVersion (compiler lbi)
fromExecutable :: Verbosity
-> FilePath
-> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo
- -> Maybe PathTemplate -- ^ template for html location
+ -> Maybe PathTemplate -- ^ template for HTML location
+ -> Version
-> IO HaddockArgs
-fromExecutable verbosity tmp lbi exe clbi htmlTemplate = do
+fromExecutable verbosity tmp lbi exe clbi htmlTemplate haddockVersion = do
inFiles <- map snd `fmap` getExeSourceFiles lbi exe
ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate
let vanillaOpts = (componentGhcOptions normal lbi bi clbi (buildDir lbi)) {
@@ -383,19 +356,25 @@ fromExecutable verbosity tmp lbi exe clbi htmlTemplate = do
ghcOptObjDir = toFlag tmp,
ghcOptHiDir = toFlag tmp,
ghcOptStubDir = toFlag tmp
- }
+ } `mappend` getGhcCppOpts haddockVersion bi
sharedOpts = vanillaOpts {
ghcOptDynLinkMode = toFlag GhcDynamicOnly,
ghcOptFPic = toFlag True,
ghcOptHiSuffix = toFlag "dyn_hi",
ghcOptObjSuffix = toFlag "dyn_o",
- ghcOptExtra = ghcSharedOptions bi
+ ghcOptExtra =
+ toNubListR $ hcSharedOptions GHC bi
}
opts <- if withVanillaLib lbi
then return vanillaOpts
else if withSharedLib lbi
then return sharedOpts
- else die "Must have vanilla or shared libraries enabled in order to run haddock"
+ else die $ "Must have vanilla or shared libraries "
+ ++ "enabled in order to run haddock"
+ ghcVersion <- maybe (die "Compiler has no GHC version")
+ return
+ (compilerCompatVersion GHC (compiler lbi))
+
return ifaceArgs {
argGhcOptions = toFlag (opts, ghcVersion),
argOutputDir = Dir (exeName exe),
@@ -404,7 +383,6 @@ fromExecutable verbosity tmp lbi exe clbi htmlTemplate = do
}
where
bi = buildInfo exe
- ghcVersion = compilerVersion (compiler lbi)
compToExe :: Component -> Maybe Executable
compToExe comp =
@@ -427,27 +405,41 @@ compToExe comp =
getInterfaces :: Verbosity
-> LocalBuildInfo
-> ComponentLocalBuildInfo
- -> Maybe PathTemplate -- ^ template for html location
+ -> Maybe PathTemplate -- ^ template for HTML location
-> IO HaddockArgs
getInterfaces verbosity lbi clbi htmlTemplate = do
(packageFlags, warnings) <- haddockPackageFlags lbi clbi htmlTemplate
- maybe (return ()) (warn verbosity) warnings
+ traverse_ (warn verbosity) warnings
return $ mempty {
argInterfaces = packageFlags
}
+getGhcCppOpts :: Version
+ -> BuildInfo
+ -> GhcOptions
+getGhcCppOpts haddockVersion bi =
+ mempty {
+ ghcOptExtensions = toNubListR [EnableExtension CPP | needsCpp],
+ ghcOptCppOptions = toNubListR defines
+ }
+ where
+ needsCpp = EnableExtension CPP `elem` usedExtensions bi
+ defines = [haddockVersionMacro]
+ haddockVersionMacro = "-D__HADDOCK_VERSION__="
+ ++ show (v1 * 1000 + v2 * 10 + v3)
+ where
+ [v1, v2, v3] = take 3 $ versionBranch haddockVersion ++ [0,0]
+
getGhcLibDir :: Verbosity -> LocalBuildInfo
- -> Bool -- ^ are we using haddock-2.x ?
-> IO HaddockArgs
-getGhcLibDir verbosity lbi isVersion2
- | isVersion2 =
- do l <- ghcLibDir verbosity lbi
- return $ mempty { argGhcLibDir = Flag l }
- | otherwise =
- return mempty
-
-----------------------------------------------------------------------------------------------
-
+getGhcLibDir verbosity lbi = do
+ l <- case compilerFlavor (compiler lbi) of
+ GHC -> GHC.getLibDir verbosity lbi
+ GHCJS -> GHCJS.getLibDir verbosity lbi
+ _ -> error "haddock only supports GHC and GHCJS"
+ return $ mempty { argGhcLibDir = Flag l }
+
+-- ------------------------------------------------------------------------------
-- | Call haddock with the specified arguments.
runHaddock :: Verbosity
-> TempFileOptions
@@ -474,15 +466,29 @@ renderArgs :: Verbosity
-> (([String], FilePath) -> IO a)
-> IO a
renderArgs verbosity tmpFileOpts version comp args k = do
+ let haddockSupportsUTF8 = version >= Version [2,14,4] []
+ haddockSupportsResponseFiles = version > Version [2,16,1] []
createDirectoryIfMissingVerbose verbosity True outputDir
- withTempFileEx tmpFileOpts outputDir "haddock-prolog.txt" $ \prologFileName h -> do
+ withTempFileEx tmpFileOpts outputDir "haddock-prologue.txt" $
+ \prologueFileName h -> do
do
+ when haddockSupportsUTF8 (hSetEncoding h utf8)
hPutStrLn h $ fromFlag $ argPrologue args
hClose h
- let pflag = "--prologue=" ++ prologFileName
- k (pflag : renderPureArgs version comp args, result)
+ let pflag = "--prologue=" ++ prologueFileName
+ renderedArgs = pflag : renderPureArgs version comp args
+ if haddockSupportsResponseFiles
+ then
+ withTempFileEx tmpFileOpts outputDir "haddock-response.txt" $
+ \responseFileName hf -> do
+ when haddockSupportsUTF8 (hSetEncoding hf utf8)
+ mapM_ (hPutStrLn hf) renderedArgs
+ hClose hf
+ let respFile = "@" ++ responseFileName
+ k ([respFile], result)
+ else
+ k (renderedArgs, result)
where
- isVersion2 = version >= Version [2,0] []
outputDir = (unDir $ argOutputDir args)
result = intercalate ", "
. map (\o -> outputDir </>
@@ -491,61 +497,78 @@ renderArgs verbosity tmpFileOpts version comp args k = do
Hoogle -> pkgstr <.> "txt")
$ arg argOutput
where
- pkgstr | isVersion2 = display $ packageName pkgid
- | otherwise = display pkgid
+ pkgstr = display $ packageName pkgid
pkgid = arg argPackageName
arg f = fromFlag $ f args
renderPureArgs :: Version -> Compiler -> HaddockArgs -> [String]
renderPureArgs version comp args = concat
- [
- (:[]) . (\f -> "--dump-interface="++ unDir (argOutputDir args) </> f)
- . fromFlag . argInterfaceFile $ args,
- (\pname -> if isVersion2
- then ["--optghc=-package-name", "--optghc=" ++ pname]
- else ["--package=" ++ pname]) . display . fromFlag . argPackageName $ args,
- (\(All b,xs) -> bool (map (("--hide=" ++). display) xs) [] b) . argHideModules $ args,
- bool ["--ignore-all-exports"] [] . getAny . argIgnoreExports $ args,
- maybe [] (\(m,e) -> ["--source-module=" ++ m
- ,"--source-entity=" ++ e]) . flagToMaybe . argLinkSource $ args,
- maybe [] ((:[]).("--css="++)) . flagToMaybe . argCssFile $ args,
- maybe [] ((:[]).("--use-contents="++)) . flagToMaybe . argContents $ args,
- bool [] [verbosityFlag] . getAny . argVerbose $ args,
- map (\o -> case o of Hoogle -> "--hoogle"; Html -> "--html") . fromFlag . argOutput $ args,
- renderInterfaces . argInterfaces $ args,
- (:[]).("--odir="++) . unDir . argOutputDir $ args,
- (:[]).("--title="++) . (bool (++" (internal documentation)") id (getAny $ argIgnoreExports args))
- . fromFlag . argTitle $ args,
- [ "--optghc=" ++ opt | isVersion2
- , (opts, _ghcVer) <- flagToList (argGhcOptions args)
- , opt <- renderGhcOptions comp opts ],
- maybe [] (\l -> ["-B"++l]) $ guard isVersion2 >> flagToMaybe (argGhcLibDir args), -- error if isVersion2 and Nothing?
- argTargets $ args
+ [ (:[]) . (\f -> "--dump-interface="++ unDir (argOutputDir args) </> f)
+ . fromFlag . argInterfaceFile $ args
+
+ , if isVersion 2 16
+ then (\pkg -> [ "--package-name=" ++ display (pkgName pkg)
+ , "--package-version="++display (pkgVersion pkg)
+ ])
+ . fromFlag . argPackageName $ args
+ else []
+
+ , (\(All b,xs) -> bool (map (("--hide=" ++). display) xs) [] b)
+ . argHideModules $ args
+
+ , bool ["--ignore-all-exports"] [] . getAny . argIgnoreExports $ args
+
+ , maybe [] (\(m,e,l) ->
+ ["--source-module=" ++ m
+ ,"--source-entity=" ++ e]
+ ++ if isVersion 2 14 then ["--source-entity-line=" ++ l]
+ else []
+ ) . flagToMaybe . argLinkSource $ args
+
+ , maybe [] ((:[]) . ("--css="++)) . flagToMaybe . argCssFile $ args
+
+ , maybe [] ((:[]) . ("--use-contents="++)) . flagToMaybe . argContents $ args
+
+ , bool [] [verbosityFlag] . getAny . argVerbose $ args
+
+ , map (\o -> case o of Hoogle -> "--hoogle"; Html -> "--html")
+ . fromFlag . argOutput $ args
+
+ , renderInterfaces . argInterfaces $ args
+
+ , (:[]) . ("--odir="++) . unDir . argOutputDir $ args
+
+ , (:[]) . ("--title="++)
+ . (bool (++" (internal documentation)")
+ id (getAny $ argIgnoreExports args))
+ . fromFlag . argTitle $ args
+
+ , [ "--optghc=" ++ opt | (opts, _ghcVer) <- flagToList (argGhcOptions args)
+ , opt <- renderGhcOptions comp opts ]
+
+ , maybe [] (\l -> ["-B"++l]) $
+ flagToMaybe (argGhcLibDir args) -- error if Nothing?
+
+ , argTargets $ args
]
where
renderInterfaces =
map (\(i,mh) -> "--read-interface=" ++
maybe "" (++",") mh ++ i)
bool a b c = if c then a else b
- isVersion2 = version >= Version [2,0] []
- isVersion2_5 = version >= Version [2,5] []
+ isVersion major minor = version >= Version [major,minor] []
verbosityFlag
- | isVersion2_5 = "--verbosity=1"
- | otherwise = "--verbose"
+ | isVersion 2 5 = "--verbosity=1"
+ | otherwise = "--verbose"
------------------------------------------------------------------------------------------------------------
+---------------------------------------------------------------------------------
-haddockPackageFlags :: LocalBuildInfo
- -> ComponentLocalBuildInfo
- -> Maybe PathTemplate
- -> IO ([(FilePath,Maybe String)], Maybe String)
-haddockPackageFlags lbi clbi htmlTemplate = do
- let allPkgs = installedPkgs lbi
- directDeps = map fst (componentPackageDeps clbi)
- transitiveDeps <- case dependencyClosure allPkgs directDeps of
- Left x -> return x
- Right inf -> die $ "internal error when calculating transative "
- ++ "package dependencies.\nDebug info: " ++ show inf
+-- | Given a list of 'InstalledPackageInfo's, return a list of interfaces and
+-- HTML paths, and an optional warning for packages with missing documentation.
+haddockPackagePaths :: [InstalledPackageInfo]
+ -> Maybe (InstalledPackageInfo -> FilePath)
+ -> IO ([(FilePath, Maybe FilePath)], Maybe String)
+haddockPackagePaths ipkgs mkHtmlPath = do
interfaces <- sequence
[ case interfaceAndHtmlPath ipkg of
Nothing -> return (Left (packageId ipkg))
@@ -553,97 +576,123 @@ haddockPackageFlags lbi clbi htmlTemplate = do
exists <- doesFileExist interface
if exists
then return (Right (interface, html))
- else return (Left (packageId ipkg))
- | ipkg <- PackageIndex.allPackages transitiveDeps
- , pkgName (packageId ipkg) `notElem` noHaddockWhitelist
+ else return (Left pkgid)
+ | ipkg <- ipkgs, let pkgid = packageId ipkg
+ , pkgName pkgid `notElem` noHaddockWhitelist
]
let missing = [ pkgid | Left pkgid <- interfaces ]
warning = "The documentation for the following packages are not "
++ "installed. No links will be generated to these packages: "
++ intercalate ", " (map display missing)
- flags = [ (interface, if null html then Nothing else Just html)
- | Right (interface, html) <- interfaces ]
+ flags = rights interfaces
return (flags, if null missing then Nothing else Just warning)
where
+ -- Don't warn about missing documentation for these packages. See #1231.
noHaddockWhitelist = map PackageName [ "rts" ]
- interfaceAndHtmlPath :: InstalledPackageInfo -> Maybe (FilePath, FilePath)
+
+ -- Actually extract interface and HTML paths from an 'InstalledPackageInfo'.
+ interfaceAndHtmlPath :: InstalledPackageInfo
+ -> Maybe (FilePath, Maybe FilePath)
interfaceAndHtmlPath pkg = do
interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg)
- html <- case htmlTemplate of
+ html <- case mkHtmlPath of
Nothing -> fmap fixFileUrl
(listToMaybe (InstalledPackageInfo.haddockHTMLs pkg))
- Just htmlPathTemplate -> Just (expandTemplateVars htmlPathTemplate)
- return (interface, html)
-
+ Just mkPath -> Just (mkPath pkg)
+ return (interface, if null html then Nothing else Just html)
where
- expandTemplateVars = fromPathTemplate . substPathTemplate env
- env = haddockTemplateEnv lbi (packageId pkg)
-
- -- the 'haddock-html' field in the hc-pkg output is often set as a
- -- native path, but we need it as a URL.
- -- See https://github.com/haskell/cabal/issues/1064
+ -- The 'haddock-html' field in the hc-pkg output is often set as a
+ -- native path, but we need it as a URL. See #1064.
fixFileUrl f | isAbsolute f = "file://" ++ f
| otherwise = f
-haddockTemplateEnv :: LocalBuildInfo -> PackageIdentifier -> PathTemplateEnv
-haddockTemplateEnv lbi pkg_id = (PrefixVar, prefix (installDirTemplates lbi))
- : initialPathTemplateEnv pkg_id (compilerId (compiler lbi))
- (hostPlatform lbi)
+haddockPackageFlags :: LocalBuildInfo
+ -> ComponentLocalBuildInfo
+ -> Maybe PathTemplate
+ -> IO ([(FilePath, Maybe FilePath)], Maybe String)
+haddockPackageFlags lbi clbi htmlTemplate = do
+ let allPkgs = installedPkgs lbi
+ directDeps = map fst (componentPackageDeps clbi)
+ transitiveDeps <- case dependencyClosure allPkgs directDeps of
+ Left x -> return x
+ Right inf -> die $ "internal error when calculating transitive "
+ ++ "package dependencies.\nDebug info: " ++ show inf
+ haddockPackagePaths (PackageIndex.allPackages transitiveDeps) mkHtmlPath
+ where
+ mkHtmlPath = fmap expandTemplateVars htmlTemplate
+ expandTemplateVars tmpl pkg =
+ fromPathTemplate . substPathTemplate (env pkg) $ tmpl
+ env pkg = haddockTemplateEnv lbi (packageId pkg)
--- --------------------------------------------------------------------------
--- hscolour support
-hscolour :: PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HscolourFlags -> IO ()
+haddockTemplateEnv :: LocalBuildInfo -> PackageIdentifier -> PathTemplateEnv
+haddockTemplateEnv lbi pkg_id =
+ (PrefixVar, prefix (installDirTemplates lbi))
+ :