summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSergeiTrofimovich <>2014-01-07 00:01:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-01-07 00:01:00 (GMT)
commite1ae8d1031ad5b6553eda5c19aff4250197775a9 (patch)
tree259c3fe0095008b2c6ac7f800eff72cb297a1c47
parentba7011e86691e488773552a8d6b17cb5b168683d (diff)
version 0.3.60.3.6
-rw-r--r--Cabal2Ebuild.hs7
-rw-r--r--Main.hs37
-rw-r--r--Merge.hs386
-rw-r--r--Merge/Dependencies.hs4
-rw-r--r--Portage/Cabal.hs1
-rw-r--r--Portage/EBuild.hs26
-rw-r--r--Portage/EMeta.hs85
-rw-r--r--Portage/PackageId.hs7
-rw-r--r--Util.hs8
-rw-r--r--cabal/.travis.yml44
-rw-r--r--cabal/Cabal/Cabal.cabal418
-rw-r--r--cabal/Cabal/DefaultSetup.hs2
-rw-r--r--cabal/Cabal/Distribution/Compat/CopyFile.hs74
-rw-r--r--cabal/Cabal/Distribution/Compat/Environment.hs24
-rw-r--r--cabal/Cabal/Distribution/Compat/Exception.hs50
-rw-r--r--cabal/Cabal/Distribution/Compat/ReadP.hs21
-rw-r--r--cabal/Cabal/Distribution/Compat/TempFile.hs85
-rw-r--r--cabal/Cabal/Distribution/Compiler.hs23
-rw-r--r--cabal/Cabal/Distribution/GetOpt.hs12
-rw-r--r--cabal/Cabal/Distribution/InstalledPackageInfo.hs10
-rw-r--r--cabal/Cabal/Distribution/License.hs13
-rw-r--r--cabal/Cabal/Distribution/Make.hs4
-rw-r--r--cabal/Cabal/Distribution/ModuleName.hs9
-rw-r--r--cabal/Cabal/Distribution/Package.hs17
-rw-r--r--cabal/Cabal/Distribution/PackageDescription.hs110
-rw-r--r--cabal/Cabal/Distribution/PackageDescription/Check.hs94
-rw-r--r--cabal/Cabal/Distribution/PackageDescription/Configuration.hs102
-rw-r--r--cabal/Cabal/Distribution/PackageDescription/Parse.hs113
-rw-r--r--cabal/Cabal/Distribution/PackageDescription/PrettyPrint.hs37
-rw-r--r--cabal/Cabal/Distribution/PackageDescription/Utils.hs23
-rw-r--r--cabal/Cabal/Distribution/ParseUtils.hs105
-rw-r--r--cabal/Cabal/Distribution/ReadE.hs4
-rw-r--r--cabal/Cabal/Distribution/Simple.hs52
-rw-r--r--cabal/Cabal/Distribution/Simple/Bench.hs3
-rw-r--r--cabal/Cabal/Distribution/Simple/Build.hs445
-rw-r--r--cabal/Cabal/Distribution/Simple/Build/Macros.hs77
-rw-r--r--cabal/Cabal/Distribution/Simple/Build/PathsModule.hs18
-rw-r--r--cabal/Cabal/Distribution/Simple/BuildPaths.hs19
-rw-r--r--cabal/Cabal/Distribution/Simple/BuildTarget.hs931
-rw-r--r--cabal/Cabal/Distribution/Simple/CCompiler.hs121
-rw-r--r--cabal/Cabal/Distribution/Simple/Command.hs190
-rw-r--r--cabal/Cabal/Distribution/Simple/Compiler.hs36
-rw-r--r--cabal/Cabal/Distribution/Simple/Configure.hs619
-rw-r--r--cabal/Cabal/Distribution/Simple/GHC.hs836
-rw-r--r--cabal/Cabal/Distribution/Simple/Haddock.hs281
-rw-r--r--cabal/Cabal/Distribution/Simple/HaskellSuite.hs222
-rw-r--r--cabal/Cabal/Distribution/Simple/Hpc.hs31
-rw-r--r--cabal/Cabal/Distribution/Simple/Hugs.hs11
-rw-r--r--cabal/Cabal/Distribution/Simple/Install.hs24
-rw-r--r--cabal/Cabal/Distribution/Simple/InstallDirs.hs73
-rw-r--r--cabal/Cabal/Distribution/Simple/JHC.hs10
-rw-r--r--cabal/Cabal/Distribution/Simple/LHC.hs110
-rw-r--r--cabal/Cabal/Distribution/Simple/LocalBuildInfo.hs311
-rw-r--r--cabal/Cabal/Distribution/Simple/NHC.hs38
-rw-r--r--cabal/Cabal/Distribution/Simple/PackageIndex.hs2
-rw-r--r--cabal/Cabal/Distribution/Simple/PreProcess.hs125
-rw-r--r--cabal/Cabal/Distribution/Simple/Program.hs6
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Ar.hs107
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Builtin.hs48
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Db.hs53
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Find.hs125
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/GHC.hs90
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/HcPkg.hs58
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Hpc.hs41
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Run.hs91
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Script.hs11
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Strip.hs48
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Types.hs40
-rw-r--r--cabal/Cabal/Distribution/Simple/Register.hs29
-rw-r--r--cabal/Cabal/Distribution/Simple/Setup.hs617
-rw-r--r--cabal/Cabal/Distribution/Simple/SrcDist.hs496
-rw-r--r--cabal/Cabal/Distribution/Simple/Test.hs37
-rw-r--r--cabal/Cabal/Distribution/Simple/UHC.hs14
-rw-r--r--cabal/Cabal/Distribution/Simple/UserHooks.hs25
-rw-r--r--cabal/Cabal/Distribution/Simple/Utils.hs418
-rw-r--r--cabal/Cabal/Distribution/System.hs42
-rw-r--r--cabal/Cabal/Distribution/Version.hs30
-rw-r--r--cabal/Cabal/Language/Haskell/Extension.hs539
-rw-r--r--cabal/Cabal/Makefile14
-rw-r--r--cabal/Cabal/README6
-rw-r--r--cabal/Cabal/cabal.config1
-rw-r--r--cabal/Cabal/changelog2
-rw-r--r--cabal/Cabal/doc/Cabal.css10
-rw-r--r--cabal/Cabal/doc/developing-packages.markdown689
-rw-r--r--cabal/Cabal/doc/index.markdown238
-rw-r--r--cabal/Cabal/doc/installing-packages.markdown247
-rw-r--r--cabal/Cabal/doc/misc.markdown2
-rwxr-xr-xcabal/Cabal/misc/gen-extra-source-files.sh5
-rw-r--r--cabal/Cabal/runTests.sh21
-rw-r--r--cabal/HACKING19
-rw-r--r--cabal/README8
-rw-r--r--cabal/README.md12
-rw-r--r--cabal/cabal-install/.ghci1
-rw-r--r--cabal/cabal-install/Distribution/Client/BuildReports/Anonymous.hs12
-rw-r--r--cabal/cabal-install/Distribution/Client/BuildReports/Storage.hs10
-rw-r--r--cabal/cabal-install/Distribution/Client/BuildReports/Upload.hs6
-rw-r--r--cabal/cabal-install/Distribution/Client/Check.hs4
-rw-r--r--cabal/cabal-install/Distribution/Client/Compat/Environment.hs88
-rw-r--r--cabal/cabal-install/Distribution/Client/Compat/ExecutablePath.hs164
-rw-r--r--cabal/cabal-install/Distribution/Client/Compat/FilePerms.hs (renamed from cabal/cabal-install/Distribution/Compat/FilePerms.hs)20
-rw-r--r--cabal/cabal-install/Distribution/Client/Compat/Process.hs43
-rw-r--r--cabal/cabal-install/Distribution/Client/Compat/Semaphore.hs104
-rw-r--r--cabal/cabal-install/Distribution/Client/Compat/Time.hs132
-rw-r--r--cabal/cabal-install/Distribution/Client/Config.hs102
-rw-r--r--cabal/cabal-install/Distribution/Client/Configure.hs89
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency.hs161
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs11
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs19
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Explore.hs9
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs10
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Log.hs39
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Message.hs2
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/PSQ.hs9
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs11
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs14
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Version.hs1
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/TopDown.hs10
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs2
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Types.hs29
-rw-r--r--cabal/cabal-install/Distribution/Client/Fetch.hs17
-rw-r--r--cabal/cabal-install/Distribution/Client/FetchUtils.hs9
-rw-r--r--cabal/cabal-install/Distribution/Client/Freeze.hs172
-rw-r--r--cabal/cabal-install/Distribution/Client/GZipUtils.hs2
-rw-r--r--cabal/cabal-install/Distribution/Client/Get.hs352
-rw-r--r--cabal/cabal-install/Distribution/Client/Haddock.hs12
-rw-r--r--cabal/cabal-install/Distribution/Client/HttpUtils.hs214
-rw-r--r--cabal/cabal-install/Distribution/Client/IndexUtils.hs182
-rw-r--r--cabal/cabal-install/Distribution/Client/Init.hs145
-rw-r--r--cabal/cabal-install/Distribution/Client/Init/Heuristics.hs216
-rw-r--r--cabal/cabal-install/Distribution/Client/Init/Licenses.hs666
-rw-r--r--cabal/cabal-install/Distribution/Client/Init/Types.hs22
-rw-r--r--cabal/cabal-install/Distribution/Client/Install.hs763
-rw-r--r--cabal/cabal-install/Distribution/Client/InstallPlan.hs57
-rw-r--r--cabal/cabal-install/Distribution/Client/InstallSymlink.hs19
-rw-r--r--cabal/cabal-install/Distribution/Client/JobControl.hs6
-rw-r--r--cabal/cabal-install/Distribution/Client/List.hs72
-rw-r--r--cabal/cabal-install/Distribution/Client/PackageEnvironment.hs380
-rw-r--r--cabal/cabal-install/Distribution/Client/PackageIndex.hs18
-rw-r--r--cabal/cabal-install/Distribution/Client/ParseUtils.hs24
-rw-r--r--cabal/cabal-install/Distribution/Client/Run.hs64
-rw-r--r--cabal/cabal-install/Distribution/Client/Sandbox.hs883
-rw-r--r--cabal/cabal-install/Distribution/Client/Sandbox/Index.hs (renamed from cabal/cabal-install/Distribution/Client/Index.hs)197
-rw-r--r--cabal/cabal-install/Distribution/Client/Sandbox/PackageEnvironment.hs528
-rw-r--r--cabal/cabal-install/Distribution/Client/Sandbox/Timestamp.hs288
-rw-r--r--cabal/cabal-install/Distribution/Client/Sandbox/Types.hs61
-rw-r--r--cabal/cabal-install/Distribution/Client/Setup.hs773
-rw-r--r--cabal/cabal-install/Distribution/Client/SetupWrapper.hs410
-rw-r--r--cabal/cabal-install/Distribution/Client/SrcDist.hs180
-rw-r--r--cabal/cabal-install/Distribution/Client/Tar.hs58
-rw-r--r--cabal/cabal-install/Distribution/Client/Targets.hs40
-rw-r--r--cabal/cabal-install/Distribution/Client/Types.hs36
-rw-r--r--cabal/cabal-install/Distribution/Client/Unpack.hs123
-rw-r--r--cabal/cabal-install/Distribution/Client/Update.hs19
-rw-r--r--cabal/cabal-install/Distribution/Client/Upload.hs43
-rw-r--r--cabal/cabal-install/Distribution/Client/Utils.hs98
-rw-r--r--cabal/cabal-install/Distribution/Client/Win32SelfUpgrade.hs4
-rw-r--r--cabal/cabal-install/Distribution/Compat/ExceptionCI.hs56
-rw-r--r--cabal/cabal-install/Distribution/Compat/Time.hs37
-rw-r--r--cabal/cabal-install/Main.hs875
-rwxr-xr-x[-rw-r--r--]cabal/cabal-install/bootstrap.sh45
-rw-r--r--cabal/cabal-install/cabal-install.cabal144
-rw-r--r--cabal/cabal-install/cabal.config1
-rw-r--r--cabal/cabal-install/cbits/getnumcores.c2
-rw-r--r--cabal/cabal-install/tests/README1
-rw-r--r--cabal/cabal-install/tests/UnitTests.hs21
-rw-r--r--cabal/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/PSQ.hs22
-rw-r--r--cabal/cabal-install/tests/UnitTests/Distribution/Client/Sandbox.hs29
-rw-r--r--cabal/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs59
-rw-r--r--cabal/cabal-install/tests/test-cabal-install9
-rw-r--r--cabal/cabal-install/tests/test-cabal-install-user8
-rw-r--r--hackport.cabal4
-rwxr-xr-xmk_release_tarball.bash28
-rw-r--r--tests/normalize_deps.hs19
173 files changed, 14866 insertions, 5528 deletions
diff --git a/Cabal2Ebuild.hs b/Cabal2Ebuild.hs
index c0f2721..eef91b4 100644
--- a/Cabal2Ebuild.hs
+++ b/Cabal2Ebuild.hs
@@ -34,7 +34,7 @@ import qualified Distribution.Package as Cabal (PackageIdentifier(..)
import qualified Distribution.Version as Cabal (VersionRange, foldVersionRange')
import Distribution.Text (display)
-import Data.Char (toLower,isUpper)
+import Data.Char (isUpper)
import Portage.Dependency
import qualified Portage.Cabal as Portage
@@ -48,7 +48,7 @@ import Portage.Version
cabal2ebuild :: Cabal.PackageDescription -> Portage.EBuild
cabal2ebuild pkg = Portage.ebuildTemplate {
- E.name = map toLower cabalPkgName,
+ E.name = Portage.cabal_pn_to_PN cabal_pn,
E.hackage_name= cabalPkgName,
E.version = display (Cabal.pkgVersion (Cabal.package pkg)),
E.description = if null (Cabal.synopsis pkg) then Cabal.description pkg
@@ -66,7 +66,8 @@ cabal2ebuild pkg = Portage.ebuildTemplate {
) (Cabal.library pkg) -- hscolour can't colour its own sources
++ (if hasTests then ["test-suite"] else [])
} where
- cabalPkgName = display $ Cabal.pkgName (Cabal.package pkg)
+ cabal_pn = Cabal.pkgName $ Cabal.package pkg
+ cabalPkgName = display cabal_pn
hasExe = (not . null) (Cabal.executables pkg)
hasTests = (not . null) (Cabal.testSuites pkg)
thisHomepage = if (null $ Cabal.homepage pkg)
diff --git a/Main.hs b/Main.hs
index e6160a6..fec2480 100644
--- a/Main.hs
+++ b/Main.hs
@@ -125,20 +125,24 @@ listAction flags extraArgs globalFlags = do
data MakeEbuildFlags = MakeEbuildFlags {
makeEbuildVerbosity :: Flag Verbosity
+ , makeEbuildCabalFlags :: Flag (Maybe String)
}
instance Monoid MakeEbuildFlags where
mempty = MakeEbuildFlags {
makeEbuildVerbosity = mempty
+ , makeEbuildCabalFlags = mempty
}
mappend a b = MakeEbuildFlags {
makeEbuildVerbosity = combine makeEbuildVerbosity
+ , makeEbuildCabalFlags = makeEbuildCabalFlags b
}
where combine field = field a `mappend` field b
defaultMakeEbuildFlags :: MakeEbuildFlags
defaultMakeEbuildFlags = MakeEbuildFlags {
makeEbuildVerbosity = Flag normal
+ , makeEbuildCabalFlags = Flag Nothing
}
makeEbuildAction :: MakeEbuildFlags -> [String] -> GlobalFlags -> IO ()
@@ -153,7 +157,7 @@ makeEbuildAction flags args globalFlags = do
overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags)
forM_ cabals $ \cabalFileName -> do
pkg <- Cabal.readPackageDescription normal cabalFileName
- mergeGenericPackageDescription verbosity overlayPath cat pkg False
+ mergeGenericPackageDescription verbosity overlayPath cat pkg False (fromFlag $ makeEbuildCabalFlags flags)
makeEbuildCommand :: CommandUI MakeEbuildFlags
makeEbuildCommand = CommandUI {
@@ -165,6 +169,14 @@ makeEbuildCommand = CommandUI {
commandDefaultFlags = defaultMakeEbuildFlags,
commandOptions = \_showOrParseArgs ->
[ optionVerbosity makeEbuildVerbosity (\v flags -> flags { makeEbuildVerbosity = v })
+
+ , option "f" ["flags"]
+ (unlines [ "Set cabal flags to certain state."
+ , "Example: --flags=-all_extensions"
+ ])
+ makeEbuildCabalFlags
+ (\cabal_flags v -> v{ makeEbuildCabalFlags = cabal_flags })
+ (reqArg' "cabal_flags" (Flag . Just) (\(Flag ms) -> catMaybes [ms]))
]
}
@@ -341,24 +353,24 @@ statusAction flags args globalFlags = do
data MergeFlags = MergeFlags {
mergeVerbosity :: Flag Verbosity
- -- , mergeServerURI :: Flag String
+ , mergeCabalFlags :: Flag (Maybe String)
}
instance Monoid MergeFlags where
mempty = MergeFlags {
mergeVerbosity = mempty
- -- , mergeServerURI = mempty
+ , mergeCabalFlags = mempty
}
mappend a b = MergeFlags {
mergeVerbosity = combine mergeVerbosity
- -- , mergeServerURI = combine mergeServerURI
+ , mergeCabalFlags = mergeCabalFlags b
}
where combine field = field a `mappend` field b
defaultMergeFlags :: MergeFlags
defaultMergeFlags = MergeFlags {
mergeVerbosity = Flag normal
- -- , mergeServerURI = Flag defaultHackageServerURI
+ , mergeCabalFlags = Flag Nothing
}
mergeCommand :: CommandUI MergeFlags
@@ -372,12 +384,13 @@ mergeCommand = CommandUI {
commandOptions = \_showOrParseArgs ->
[ optionVerbosity mergeVerbosity (\v flags -> flags { mergeVerbosity = v })
- {-
- , option [] ["server"]
- "Set the server you'd like to update the cache from"
- mergeServerURI (\v flags -> flags { mergeServerURI = v} )
- (reqArgFlag "SERVER")
- -}
+ , option "f" ["flags"]
+ (unlines [ "Set cabal flags to certain state."
+ , "Example: --flags=-all_extensions"
+ ])
+ mergeCabalFlags
+ (\cabal_flags v -> v{ mergeCabalFlags = cabal_flags})
+ (reqArg' "cabal_flags" (Flag . Just) (\(Flag ms) -> catMaybes [ms]))
]
}
@@ -386,7 +399,7 @@ mergeAction flags extraArgs globalFlags = do
let verbosity = fromFlag (mergeVerbosity flags)
overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags)
let repo = defaultRepo overlayPath
- merge verbosity repo (defaultRepoURI overlayPath) extraArgs overlayPath
+ merge verbosity repo (defaultRepoURI overlayPath) extraArgs overlayPath (fromFlag $ mergeCabalFlags flags)
-----------------------------------------------------------------------
-- DistroMap
diff --git a/Merge.hs b/Merge.hs
index 3230876..4331626 100644
--- a/Merge.hs
+++ b/Merge.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE PatternGuards, BangPatterns #-}
module Merge
( merge
, mergeGenericPackageDescription
@@ -8,11 +7,12 @@ import Control.Arrow (first, second)
import Control.Monad.Error
import Control.Exception
import qualified Data.ByteString.Lazy.Char8 as BL
-import Data.Char (isSpace)
+import qualified Data.Map.Strict as M
import Data.Function (on)
import Data.Maybe
import Data.Monoid
-import Data.List as L
+import qualified Data.List as L
+import qualified Data.Time.Clock as TC
import Data.Version
-- cabal
@@ -37,7 +37,6 @@ import Distribution.Client.Types
-- others
import System.Directory ( getCurrentDirectory
- , getDirectoryContents
, setCurrentDirectory
, createDirectoryIfMissing
, doesFileExist
@@ -45,15 +44,14 @@ import System.Directory ( getCurrentDirectory
import System.Cmd (system)
import System.FilePath ((</>))
import System.Exit
-import Text.Printf
import qualified Cabal2Ebuild as C2E
import qualified Portage.EBuild as E
+import qualified Portage.EMeta as EM
import Error as E
import Network.URI
-
import qualified Portage.PackageId as Portage
import qualified Portage.Version as Portage
import qualified Portage.Metadata as Portage
@@ -65,6 +63,8 @@ import qualified Portage.GHCCore as GHCCore
import qualified Merge.Dependencies as Merge
+import qualified Util as U
+
(<.>) :: String -> String -> String
a <.> b = a ++ '.':b
@@ -97,13 +97,13 @@ readPackageString args = do
-- return the available package with that version. Latest version is chosen
-- if no preference.
resolveVersion :: [SourcePackage] -> Maybe Cabal.Version -> Maybe SourcePackage
-resolveVersion avails Nothing = Just $ maximumBy (comparing packageInfoId) avails
+resolveVersion avails Nothing = Just $ L.maximumBy (comparing packageInfoId) avails
resolveVersion avails (Just ver) = listToMaybe (filter match avails)
where
match avail = ver == Cabal.pkgVersion (packageInfoId avail)
-merge :: Verbosity -> Repo -> URI -> [String] -> FilePath -> IO ()
-merge verbosity repo _serverURI args overlayPath = do
+merge :: Verbosity -> Repo -> URI -> [String] -> FilePath -> Maybe String -> IO ()
+merge verbosity repo _serverURI args overlayPath users_cabal_flags = do
(m_category, user_pName, m_version) <-
case readPackageString args of
Left err -> throwEx err
@@ -160,92 +160,163 @@ merge verbosity repo _serverURI args overlayPath = do
let cabal_pkgId = packageInfoId selectedPkg
norm_pkgName = Cabal.packageName (Portage.normalizeCabalPackageId cabal_pkgId)
cat <- maybe (Portage.resolveCategory verbosity overlay norm_pkgName) return m_category
- mergeGenericPackageDescription verbosity overlayPath cat (packageDescription selectedPkg) True
+ mergeGenericPackageDescription verbosity overlayPath cat (packageDescription selectedPkg) True users_cabal_flags
+
+first_just_of :: [Maybe a] -> Maybe a
+first_just_of [] = Nothing
+first_just_of (m:ms) =
+ case m of
+ Nothing -> first_just_of ms
+ Just _ -> m
-mergeGenericPackageDescription :: Verbosity -> FilePath -> Portage.Category -> Cabal.GenericPackageDescription -> Bool -> IO ()
-mergeGenericPackageDescription verbosity overlayPath cat pkgGenericDesc fetch = do
+mergeGenericPackageDescription :: Verbosity -> FilePath -> Portage.Category -> Cabal.GenericPackageDescription -> Bool -> Maybe String -> IO ()
+mergeGenericPackageDescription verbosity overlayPath cat pkgGenericDesc fetch users_cabal_flags = do
overlay <- Overlay.loadLazy overlayPath
let merged_cabal_pkg_name = Cabal.pkgName (Cabal.package (Cabal.packageDescription pkgGenericDesc))
+ merged_PN = Portage.cabal_pn_to_PN merged_cabal_pkg_name
+ pkgdir = overlayPath </> Portage.unCategory cat </> merged_PN
+ existing_meta <- EM.findExistingMeta pkgdir
+ let requested_cabal_flags = first_just_of [users_cabal_flags, EM.cabal_flags existing_meta]
+ debug verbosity "searching for minimal suitable ghc version"
(compilerId, ghc_packages, pkgDesc0, _flags, pix) <- case GHCCore.minimumGHCVersionToBuildPackage pkgGenericDesc of
Just v -> return v
- Nothing -> let cpn = display merged_cabal_pkg_name
- in error $ unlines [ "mergeGenericPackageDescription: failed to find suitable GHC for " ++ cpn
+ Nothing -> let pn = display merged_cabal_pkg_name
+ cn = display cat
+ in error $ unlines [ "mergeGenericPackageDescription: failed to find suitable GHC for " ++ pn
, " You can try to merge the package manually:"
- , " $ cabal unpack " ++ cpn
- , " $ cd " ++ cpn ++ "*/"
- , " # fix " ++ cpn ++ ".cabal"
- , " $ hackport make-ebuild dev-haskell " ++ cpn ++ ".cabal"
+ , " $ cabal unpack " ++ pn
+ , " $ cd " ++ pn ++ "*/"
+ , " # fix " ++ pn ++ ".cabal"
+ , " $ hackport make-ebuild " ++ cn ++ " " ++ pn ++ ".cabal"
]
-- , Right (pkg_desc, picked_flags) <- return (packageBuildableWithGHCVersion gpd g)]
- let (accepted_deps, skipped_deps, dropped_deps) = genSimple (Cabal.buildDepends pkgDesc0)
+ let (accepted_deps, skipped_deps, dropped_deps) = partition_depends (Cabal.buildDepends pkgDesc0)
pkgDesc = pkgDesc0 { Cabal.buildDepends = accepted_deps }
- aflags = map Cabal.flagName (Cabal.genPackageFlags pkgGenericDesc)
- lflags :: [Cabal.Flag] -> [Cabal.FlagAssignment]
- lflags [] = [[]]
- lflags (x:xs) = let tp = lflags xs
- in (map ((Cabal.flagName x,False) :) tp)
- ++ (map ((Cabal.flagName x,True):) tp)
+ cabal_flag_descs = Cabal.genPackageFlags pkgGenericDesc
+ all_flags = map Cabal.flagName cabal_flag_descs
+ (user_specified_fas, cf_to_iuse_rename) = read_fas requested_cabal_flags
+ make_fas :: [Cabal.Flag] -> [Cabal.FlagAssignment]
+ make_fas [] = [[]]
+ make_fas (f:rest) = [ (fn, is_enabled) : fas
+ | fas <- make_fas rest
+ , let fn = Cabal.flagName f
+ users_choice = lookup fn user_specified_fas
+ , is_enabled <- maybe [False, True]
+ (\b -> [b])
+ users_choice
+ ]
+ all_possible_flag_assignments :: [Cabal.FlagAssignment]
+ all_possible_flag_assignments = make_fas cabal_flag_descs
+
+ pp_fa :: Cabal.FlagAssignment -> String
+ pp_fa fa = L.intercalate ", " [ (if b then '+' else '-') : f
+ | (Cabal.FlagName f, b) <- fa
+ ]
+
+ -- accepts things, like: "cabal_flag:iuse_name", "+cabal_flag", "-cabal_flag"
+ read_fas :: Maybe String -> (Cabal.FlagAssignment, [(String, String)])
+ read_fas Nothing = ([], [])
+ read_fas (Just user_fas_s) = (user_fas, user_renames)
+ where user_fas = [ (cf, b)
+ | ((cf, _), Just b) <- cn_in_mb
+ ]
+ user_renames = [ (cfn, ein)
+ | ((Cabal.FlagName cfn, ein), Nothing) <- cn_in_mb
+ ]
+ cn_in_mb = map read_fa $ U.split (== ',') user_fas_s
+ read_fa :: String -> ((Cabal.FlagName, String), Maybe Bool)
+ read_fa [] = error $ "read_fas: empty flag?"
+ read_fa (op:flag) =
+ case op of
+ '+' -> (get_rename flag, Just True)
+ '-' -> (get_rename flag, Just False)
+ _ -> (get_rename (op:flag), Nothing)
+ where get_rename :: String -> (Cabal.FlagName, String)
+ get_rename s =
+ case U.split (== ':') s of
+ [cabal_flag_name] -> (Cabal.FlagName cabal_flag_name, cabal_flag_name)
+ [cabal_flag_name, iuse_name] -> (Cabal.FlagName cabal_flag_name, iuse_name)
+ _ -> error $ "get_rename: too many components" ++ show (s)
+
+ cfn_to_iuse :: String -> String
+ cfn_to_iuse cfn =
+ case lookup cfn cf_to_iuse_rename of
+ Nothing -> cfn
+ Just ein -> ein
+
-- key idea is to generate all possible list of flags
deps1 :: [(Cabal.FlagAssignment, Merge.EDep)]
- deps1 = [ (f `updateFa` fr, genDeps pkgDesc_filtered_bdeps)
- | f <- lflags (Cabal.genPackageFlags pkgGenericDesc)
+ deps1 = [ (f `updateFa` fr, cabal_to_emerge_dep pkgDesc_filtered_bdeps)
+ | f <- all_possible_flag_assignments
, Right (pkgDesc1,fr) <- [GHCCore.finalizePackageDescription f
(GHCCore.dependencySatisfiable pix)
- (GHCCore.platform)
+ GHCCore.platform
compilerId
[]
pkgGenericDesc]
-- drop circular deps and shipped deps
- , let (ad, _sd, _rd) = genSimple (Cabal.buildDepends pkgDesc1)
+ , let (ad, _sd, _rd) = partition_depends (Cabal.buildDepends pkgDesc1)
+ -- TODO: drop ghc libraries from tests depends as well
+ -- (see deepseq in hackport-0.3.5 as an example)
, let pkgDesc_filtered_bdeps = pkgDesc1 { Cabal.buildDepends = ad }
]
- where
+ where
updateFa :: Cabal.FlagAssignment -> Cabal.FlagAssignment -> Cabal.FlagAssignment
updateFa [] _ = []
updateFa (x:xs) y = case lookup (fst x) y of
- Nothing -> x:(updateFa xs y)
- Just y' -> (fst x,y'):(updateFa xs y)
+ -- TODO: when does this code get triggered?
+ Nothing -> x : updateFa xs y
+ Just y' -> (fst x,y') : updateFa xs y
-- then remove all flags that can't be changed
- commonFlags = foldl1 intersect $ map fst deps1
- aflags' | null commonFlags = aflags
- | otherwise = filter (\a -> all (a/=) $ map fst commonFlags) aflags
- aflags'' = filter (\x -> Cabal.flagName x `elem` aflags') $ Cabal.genPackageFlags pkgGenericDesc
- -- flags that are faild to build
- deadFlags = filter (\x -> all (x/=) $ map fst deps1) (lflags (Cabal.genPackageFlags pkgGenericDesc))
- -- and finaly prettify all deps:
- tdeps = (foldl (\x y -> x `mappend` (snd y)) mempty deps1){
- Merge.dep = Portage.sortDeps . simplify $ map (\x -> (x,[])) $ map (first (filter (\x -> all (x/=) commonFlags))) $ map (second Merge.dep) deps1
- , Merge.rdep = Portage.sortDeps . simplify $ map (\x -> (x,[])) $ map (first (filter (\x -> all (x/=) commonFlags))) $ map (second Merge.rdep) deps1
+ successfully_resolved_flag_assignments = map fst deps1
+ common_fa = L.foldl1' L.intersect successfully_resolved_flag_assignments
+ common_flags = map fst common_fa
+ active_flags = all_flags L.\\ common_flags
+ active_flag_descs = filter (\x -> Cabal.flagName x `elem` active_flags) cabal_flag_descs
+ irresolvable_flag_assignments = all_possible_flag_assignments L.\\ successfully_resolved_flag_assignments
+ -- and finally prettify all deps:
+ leave_only_dynamic_fa :: Cabal.FlagAssignment -> Cabal.FlagAssignment
+ leave_only_dynamic_fa fa = fa L.\\ common_fa
+
+ optimize_fa_depends :: [([(Cabal.FlagName, Bool)], [Portage.Dependency])] -> [Portage.Dependency]
+ optimize_fa_depends deps = Portage.sortDeps
+ . simplify
+ . map ( (\fdep -> (fdep, []))
+ . first leave_only_dynamic_fa) $ deps
+
+ tdeps :: Merge.EDep
+ tdeps = (L.foldl' (\x y -> x `mappend` snd y) mempty deps1){
+ Merge.dep = optimize_fa_depends $ map (second Merge.dep) deps1
+ , Merge.rdep = optimize_fa_depends $ map (second Merge.rdep) deps1
}
- common :: [FlagDepH] -> FlagDepH
- common xs =
- let n = go xs
- k m = case m of
- [] -> error "impossible"
- [x] -> x
- _ -> k (go m)
- in k n
- where
- go [] = []
- go [y] = [y]
- go (y1:y2:ys) = y1 `merge1` y2 : go ys
-
- merge1 :: FlagDepH -> FlagDepH -> FlagDepH
- merge1 ((f1, d1),x1) ((f2, d2),x2) = ((f1 `intersect` f2, Portage.simplify_deps $ d1 `intersect` d2)
- , (f1, filter (`notElem` d2) d1)
- : (f2, filter (`notElem` d1) d2)
- : x1
- ++ x2
- )
+ pop_common_deps :: [FlagDepH] -> FlagDepH
+ pop_common_deps xs =
+ case pop_from_pairs xs of
+ [] -> error "impossible"
+ [x] -> x
+ r -> pop_common_deps r
+ where
+ pop_from_pairs :: [FlagDepH] -> [FlagDepH]
+ pop_from_pairs [] = []
+ pop_from_pairs [y] = [y]
+ pop_from_pairs (y1:y2:rest) = y1 `pop_from_pair` y2 : pop_from_pairs rest
+
+ pop_from_pair :: FlagDepH -> FlagDepH -> FlagDepH
+ pop_from_pair ((lfa, ld), lx) ((rfa, rd), rx) = ((fa, d), x)
+ where fa = lfa `L.intersect` rfa
+ d = Portage.simplify_deps $ ld `L.intersect` rd
+ x = (lfa, ld L.\\ rd)
+ : (rfa, rd L.\\ ld)
+ : lx ++ rx
simplify :: [FlagDepH] -> [Portage.Dependency]
- simplify xs =
+ simplify fdephs =
let -- extract common part of the depends
-- filtering out empty groups
- ((fl,c), zs) = second (filter (not.null.snd)) $ common xs
+ ((common_fas, common_fdeps), all_fdeps) = second (filter (not . null . snd)) $ pop_common_deps fdephs
-- Regroup flags according to packages, i.e.
-- if 2 groups of flagged deps containg same package, then
-- extract common flags, but if common flags will be empty
@@ -255,66 +326,68 @@ mergeGenericPackageDescription verbosity overlayPath cat pkgGenericDesc fetch =
mergeD :: (Cabal.FlagAssignment, Portage.Dependency)
-> [(Cabal.FlagAssignment, Portage.Dependency)]
-> [(Cabal.FlagAssignment, Portage.Dependency)]
- mergeD x [] = [x]
- mergeD x@(f1,d1) (t@(f2,d2):ts) =
- let is = f1 `intersect` f2
- in if d1 == d2
- then if null is
- then ts
- else (is,d1):ts
- else t:mergeD x ts
+ mergeD fdep [] = [fdep]
+ mergeD lfdep@(lfa, ld) (rfdep@(rfa, rd):rest) =
+ case (ld == rd, lfa `L.intersect` rfa) of
+ (True, []) -> rest
+ (True, c_fa) -> (c_fa, ld):rest
+ (False, _) -> rfdep:mergeD lfdep rest
+
sd :: [(Cabal.FlagAssignment, [Portage.Dependency])]
- sd = foldl (\o (f,d) -> case lookup f o of
- Just ds -> (f,d:ds):filter ((f/=).fst) o
- Nothing -> (f,[d]):o
- ) [] $ foldl (\o n -> n `mergeD` o)
- []
- (concatMap (\(f,d) -> map ((,) f) d) zs)
- -- filter out splitted packages from common cgroup
- ys = filter (not.null.snd) $ map (second (filter (\d -> all (d/=)
- (concatMap snd sd))
- )) zs
- -- Now we need to find noniteracting use flags if they are then we
+ sd = M.toList $!
+ L.foldl' (\fadeps (fa, new_deps) -> let push_front old_val = Just $!
+ case old_val of
+ Nothing -> new_deps:[]
+ Just ds -> new_deps:ds
+ in M.alter push_front fa fadeps
+ ) M.empty $ L.foldl' (\fadeps fadep -> fadep `mergeD` fadeps)
+ []
+ (concatMap (\(fa, deps) -> map (\one_dep -> (fa, one_dep)) deps) all_fdeps)
+ -- filter out splitted packages from common group
+ ys = filter (not.null.snd) $ map (second (filter (\d -> d `notElem` concatMap snd sd)
+ )) all_fdeps
+ -- Now we need to find noniteracting use flags if they are then we
-- don't need to simplify them more, and output as-is
simplifyMore :: [(Cabal.FlagAssignment,[Portage.Dependency])] -> [Portage.Dependency]
simplifyMore [] = []
- simplifyMore ws =
- let us = getMultiFlags ws
- (u,_) = maximumBy (compare `on` snd) $ getMultiFlags ws
- (xs', ls) = (hasFlag u) `partition` ws
- in if null us
- then concatMap (\(a, b) -> liftFlags a b) ws
- else liftFlags [u] (simplify $ map (\x -> (x,[])) $ dropFlag u xs')++simplifyMore ls
- in (liftFlags fl c) ++ simplifyMore (sd ++ ys)
-
+ simplifyMore fdeps =
+ let fa_hist = get_fa_hist fdeps
+ (u,_) = L.maximumBy (compare `on` snd) fa_hist
+ (fdeps_u, fdeps_nu) = hasFlag u `L.partition` fdeps
+ in if null fa_hist
+ then concatMap (\(a, b) -> liftFlags a b) fdeps
+ else liftFlags [u] (simplify $ map (\x -> (x,[])) $ dropFlag u fdeps_u) ++ simplifyMore fdeps_nu
+ in liftFlags common_fas common_fdeps ++ simplifyMore (sd ++ ys)
+
+ get_fa_hist :: [FlagDep] -> [((Cabal.FlagName,Bool),Int)]
+ get_fa_hist fdeps = reverse $! L.sortBy (compare `on` snd) $!
+ M.toList $!
+ go M.empty (concatMap fst fdeps)
+ where go hist [] = hist
+ go hist (fd:fds) = go (M.insertWith (+) fd 1 hist) fds
-- drop selected use flag from a list
- getMultiFlags :: [FlagDep] -> [((Cabal.FlagName,Bool),Int)]
- getMultiFlags ys = go [] (concatMap fst ys)
- where go a [] = a
- go a (x:xs) = case lookup x a of
- Nothing -> go ((x,1):a) xs
- Just n -> go ((x,n+1):filter ((x/=).fst) a) xs
dropFlag :: (Cabal.FlagName,Bool) -> [FlagDep] -> [FlagDep]
dropFlag f = map (first (filter (f /=)))
hasFlag :: (Cabal.FlagName,Bool) -> FlagDep -> Bool
- hasFlag u = any ((u ==)) . fst
+ hasFlag u = elem u . fst
liftFlags :: Cabal.FlagAssignment -> [Portage.Dependency] -> [Portage.Dependency]
- liftFlags fs e = let k = foldr (\(y,b) x -> Portage.DependIfUse (Portage.DUse (b, unFlagName y)) . x)
- (id::Portage.Dependency->Portage.Dependency) fs
+ liftFlags fs e = let k = foldr (\(y,b) x -> Portage.DependIfUse (Portage.DUse (b, cfn_to_iuse $ unFlagName y)) . x)
+ id fs
in Portage.simplify_deps [k $! Portage.DependAllOf e]
-
- genSimple =
- foldl (\(ad, sd, rd) (Cabal.Dependency pn vr) ->
- let dep = (Cabal.Dependency pn (Cabal.simplifyVersionRange vr))
+ partition_depends :: [Cabal.Dependency] -> ([Cabal.Dependency], [Cabal.Dependency], [Cabal.Dependency])
+ partition_depends =
+ L.foldl' (\(ad, sd, rd) (Cabal.Dependency pn vr) ->
+ let dep = Cabal.Dependency pn (Cabal.simplifyVersionRange vr)
in case () of
_ | pn `elem` ghc_packages -> ( ad, dep:sd, rd)
_ | pn == merged_cabal_pkg_name -> ( ad, sd, dep:rd)
_ -> (dep:ad, sd, rd)
)
([],[],[])
- genDeps pkg = Merge.resolveDependencies overlay pkg (Just compilerId)
+ cabal_to_emerge_dep :: Cabal.PackageDescription -> Merge.EDep
+ cabal_to_emerge_dep cabal_pkg = Merge.resolveDependencies overlay cabal_pkg (Just compilerId)
debug verbosity $ "buildDepends pkgDesc0 raw: " ++ Cabal.showPackageDescription pkgDesc0
debug verbosity $ "buildDepends pkgDesc0: " ++ show (map display (Cabal.buildDepends pkgDesc0))
@@ -323,16 +396,15 @@ mergeGenericPackageDescription verbosity overlayPath cat pkgGenericDesc fetch =
notice verbosity $ "Accepted depends: " ++ show (map display accepted_deps)
notice verbosity $ "Skipped depends: " ++ show (map display skipped_deps)
notice verbosity $ "Dropped depends: " ++ show (map display dropped_deps)
- notice verbosity $ "Dead flags: " ++ show deadFlags
- notice verbosity $ "Dropped flags: " ++ show (map (unFlagName.fst) commonFlags)
+ notice verbosity $ "Dead flags: " ++ show (map pp_fa irresolvable_flag_assignments)
+ notice verbosity $ "Dropped flags: " ++ show (map (unFlagName.fst) common_fa)
-- mapM_ print tdeps
forM_ ghc_packages $
\(Cabal.PackageName name) -> info verbosity $ "Excluded packages (comes with ghc): " ++ name
- let -- p_flag (Cabal.FlagName fn, True) = fn
- -- p_flag (Cabal.FlagName fn, False) = '-':fn
-
+ let pp_fn (Cabal.FlagName fn, True) = fn
+ pp_fn (Cabal.FlagName fn, False) = '-':fn
-- appends 's' to each line except the last one
-- handy to build multiline shell expressions
@@ -340,23 +412,29 @@ mergeGenericPackageDescription verbosity overlayPath cat pkgGenericDesc fetch =
icalate _s [x] = [x]
icalate s (x:xs) = (x ++ s) : icalate s xs
- selected_flags :: [String] -> [String]
- selected_flags [] = []
- selected_flags fs = icalate " \\" $ "haskell-cabal_src_configure"
- : map (\p -> "\t$(cabal_flag "++ p ++" "++ p ++")") fs
+ selected_flags :: ([Cabal.FlagName], Cabal.FlagAssignment) -> [String]
+ selected_flags ([], []) = []
+ selected_flags (active_fns, users_fas) = icalate " \\" $ "haskell-cabal_src_configure" : map snd (L.sortBy (compare `on` fst) flag_pairs)
+ where flag_pairs :: [(String, String)]
+ flag_pairs = active_pairs ++ users_pairs
+ active_pairs = map (\fn -> (fn, "\t$(cabal_flag " ++ cfn_to_iuse fn ++ " " ++ fn ++ ")")) $ map unFlagName active_fns
+ users_pairs = map (\fa -> ((unFlagName . fst) fa, "\t--flag=" ++ pp_fn fa)) users_fas
to_iuse x = let fn = unFlagName $ Cabal.flagName x
p = if Cabal.flagDefault x then "+" else ""
- in p++fn
+ in p ++ cfn_to_iuse fn
ebuild = (\e -> e { E.depend = Merge.dep tdeps} )
. (\e -> e { E.depend_extra = Merge.dep_e tdeps } )
. (\e -> e { E.rdepend = Merge.rdep tdeps} )
. (\e -> e { E.rdepend_extra = Merge.rdep_e tdeps } )
- . (\e -> e { E.src_configure = selected_flags $ sort $ map unFlagName aflags' } )
- . (\e -> e { E.iuse = E.iuse e ++ map to_iuse aflags'' })
+ . (\e -> e { E.src_configure = selected_flags (active_flags, user_specified_fas) } )
+ . (\e -> e { E.iuse = E.iuse e ++ map to_iuse active_flag_descs })
+ . ( case requested_cabal_flags of
+ Nothing -> id
+ Just ucf -> (\e -> e { E.used_options = E.used_options e ++ [("flags", ucf)] }))
$ C2E.cabal2ebuild pkgDesc
- mergeEbuild verbosity overlayPath (Portage.unCategory cat) ebuild
+ mergeEbuild verbosity existing_meta pkgdir ebuild
when fetch $ do
let cabal_pkgId = Cabal.packageId pkgDesc
norm_pkgName = Cabal.packageName (Portage.normalizeCabalPackageId cabal_pkgId)
@@ -386,56 +464,6 @@ withWorkingDirectory newDir action = do
(\_ -> setCurrentDirectory oldDir)
(\_ -> action)
--- tries to extract value of variable in var="val" format
--- There should be exactly one variable assignment in ebuild
--- It's a bit artificial limitation, but it's common for 'if / else' blocks
-extract_quoted_string :: FilePath -> String -> String -> Maybe String
-extract_quoted_string ebuild_path s_ebuild var_name =
- case filter (isPrefixOf var_prefix . ltrim) $ lines s_ebuild of
- [] -> Nothing
- [kw_line] -> up_to_quote $ skip_prefix $ ltrim kw_line
- other -> bail_out $ printf "strange '%s' assignmets:\n%s" var_name (unlines other)
-
- where ltrim :: String -> String
- ltrim = dropWhile isSpace
- var_prefix = var_name ++ "=\""
- skip_prefix = drop (length var_prefix)
- up_to_quote l = case break (== '"') l of
- ("", _) -> Nothing -- empty line
- (_, "") -> bail_out $ printf "failed to find closing quote for '%s'" l
- (val, _) -> Just val
- bail_out :: String -> e
- bail_out msg = error $ printf "%s:extract_quoted_string %s" ebuild_path msg
-
-extractKeywords :: FilePath -> String -> Maybe [String]
-extractKeywords ebuild_path s_ebuild =
- words `fmap ` extract_quoted_string ebuild_path s_ebuild "KEYWORDS"
-
-extractLicense :: FilePath -> String -> Maybe String
-extractLicense ebuild_path s_ebuild =
- extract_quoted_string ebuild_path s_ebuild "LICENSE"
-
--- aggregated (best inferred) metadata for a new ebuild of package
-data EMeta = EMeta { keywords :: Maybe [String]
- , license :: Maybe String
- }
-
-findExistingMeta :: FilePath -> IO EMeta
-findExistingMeta edir =
- do ebuilds <- filter (isPrefixOf (reverse ".ebuild") . reverse) `fmap` getDirectoryContents edir
- -- TODO: version sort
- e_metas <- forM ebuilds $ \e ->
- do let e_path = edir </> e
- e_conts <- readFile e_path
- return EMeta { keywords = extractKeywords e e_conts
- , license = extractLicense e e_conts
- }
- let get_latest candidates = last (Nothing : filter (/= Nothing) candidates)
- aggregated_meta = EMeta { keywords = get_latest $ map keywords e_metas
- , license = get_latest $ map license e_metas
- }
- return $ aggregated_meta
-
-- "amd64" -> "~amd64"
to_unstable :: String -> String
to_unstable kw =
@@ -444,18 +472,18 @@ to_unstable kw =
'-':_ -> kw
_ -> '~':kw
-mergeEbuild :: Verbosity -> FilePath -> String -> E.EBuild -> IO ()
-mergeEbuild verbosity target cat ebuild = do
- let edir = target </> cat </> E.name ebuild
+mergeEbuild :: Verbosity -> EM.EMeta -> FilePath -> E.EBuild -> IO ()
+mergeEbuild verbosity existing_meta pkgdir ebuild = do
+ let edir = pkgdir
elocal = E.name ebuild ++"-"++ E.version ebuild <.> "ebuild"
epath = edir </> elocal
emeta = "metadata.xml"
mpath = edir </> emeta
default_meta = BL.pack $ Portage.makeDefaultMetadata (E.long_desc ebuild)
createDirectoryIfMissing True edir
- existing_meta <- findExistingMeta edir
+ now <- TC.getCurrentTime
- let (existing_keywords, existing_license) = (keywords existing_meta, license existing_meta)
+ let (existing_keywords, existing_license) = (EM.keywords existing_meta, EM.license existing_meta)
new_keywords = maybe (E.keywords ebuild) (map to_unstable) existing_keywords
new_license = either (\err -> maybe (Left err)
Right
@@ -465,16 +493,16 @@ mergeEbuild verbosity target cat ebuild = do
ebuild' = ebuild { E.keywords = new_keywords
, E.license = new_license
}
- s_ebuild' = display ebuild'
+ s_ebuild' = E.showEBuild now ebuild'
notice verbosity $ "Current keywords: " ++ show existing_keywords ++ " -> " ++ show new_keywords
notice verbosity $ "Current license: " ++ show existing_license ++ " -> " ++ show new_license
notice verbosity $ "Writing " ++ elocal
- (length s_ebuild') `seq` BL.writeFile epath (BL.pack s_ebuild')
+ length s_ebuild' `seq` BL.writeFile epath (BL.pack s_ebuild')
yet_meta <- doesFileExist mpath
- if (not yet_meta) -- TODO: add --force-meta-rewrite to opts
+ if not yet_meta -- TODO: add --force-meta-rewrite to opts
then do notice verbosity $ "Writing " ++ emeta
BL.writeFile mpath default_meta
else do current_meta <- BL.readFile mpath
@@ -482,9 +510,7 @@ mergeEbuild verbosity target cat ebuild = do
notice verbosity $ "Default and current " ++ emeta ++ " differ."
unFlagName :: Cabal.FlagName -> String
-unFlagName f =
- let Cabal.FlagName y = f
- in y
+unFlagName (Cabal.FlagName fname) = fname
type FlagDep = (Cabal.FlagAssignment,[Portage.Dependency])
type FlagDepH = (FlagDep,[FlagDep])
diff --git a/Merge/Dependencies.hs b/Merge/Dependencies.hs
index 031c4f2..fda6cf6 100644
--- a/Merge/Dependencies.hs
+++ b/Merge/Dependencies.hs
@@ -332,6 +332,9 @@ staticTranslateExtraLib lib = lookup lib m
, ("icui18n", any_c_p "dev-libs" "icu")
, ("icuuc", any_c_p "dev-libs" "icu")
, ("chipmunk", any_c_p "sci-physics" "chipmunk")
+ , ("alut", any_c_p "media-libs" "freealut")
+ , ("openal", any_c_p "media-libs" "openal")
+ , ("iw", any_c_p "net-wireless" "wireless-tools")
]
---------------------------------------------------------------
@@ -365,6 +368,7 @@ buildToolsTable =
, ("cabal", any_c_p "dev-haskell" "cabal-install")
, ("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
diff --git a/Portage/Cabal.hs b/Portage/Cabal.hs
index e23e2c7..fa9a21c 100644
--- a/Portage/Cabal.hs
+++ b/Portage/Cabal.hs
@@ -23,6 +23,7 @@ convertLicense :: Cabal.License -> Either String String
convertLicense l =
case l of
-- good ones
+ 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.BSD3 -> Right "BSD"
diff --git a/Portage/EBuild.hs b/Portage/EBuild.hs
index 8168eac..cba43e5 100644
--- a/Portage/EBuild.hs
+++ b/Portage/EBuild.hs
@@ -1,20 +1,22 @@
module Portage.EBuild
( EBuild(..)
, ebuildTemplate
+ , showEBuild
, src_uri
) where
-import Distribution.Text ( Text(..) )
-import qualified Text.PrettyPrint as Disp
-
import Portage.Dependency
import Data.String.Utils
+import qualified Data.Time.Clock as TC
+import qualified Data.Time.Format as TC
import qualified Data.Function as F
import qualified Data.List as L
import Data.Version(Version(..))
import qualified Paths_hackport(version)
+import qualified System.Locale as TC
+
data EBuild = EBuild {
name :: String,
hackage_name :: String, -- might differ a bit (we mangle case)
@@ -35,6 +37,8 @@ data EBuild = EBuild {
my_pn :: Maybe String -- ^ Just 'myOldName' if the package name contains upper characters
, src_prepare :: [String] -- ^ raw block for src_prepare() contents
, src_configure :: [String] -- ^ raw block for src_configure() contents
+ , used_options :: [(String, String)] -- ^ hints to ebuild writers/readers
+ -- on what hackport options were used to produce an ebuild
}
getHackportVersion :: Version -> String
@@ -62,11 +66,9 @@ ebuildTemplate = EBuild {
my_pn = Nothing
, src_prepare = []
, src_configure = []
+ , used_options = []
}
-instance Text EBuild where
- disp = Disp.text . showEBuild
-
-- | Given an EBuild, give the URI to the tarball of the source code.
-- Assumes that the server is always hackage.haskell.org.
src_uri :: EBuild -> String
@@ -79,15 +81,16 @@ src_uri e =
-- package
Just _ -> "http://hackage.haskell.org/packages/archive/${MY_PN}/${PV}/${MY_P}.tar.gz"
-showEBuild :: EBuild -> String
-showEBuild ebuild =
- ss "# Copyright 1999-2013 Gentoo Foundation". nl.
+showEBuild :: TC.UTCTime -> EBuild -> String
+showEBuild now ebuild =
+ ss ("# Copyright 1999-" ++ this_year ++ " Gentoo Foundation"). nl.
ss "# Distributed under the terms of the GNU General Public License v2". nl.
ss "# $Header: $". nl.
nl.
ss "EAPI=5". nl.
nl.
ss ("# ebuild generated by hackport " ++ hackportVersion ebuild). nl.
+ sconcat (map (\(k, v) -> ss "#hackport: " . ss k . ss ": " . ss v . nl) $ used_options ebuild).
nl.
ss "CABAL_FEATURES=". quote' (sepBy " " $ features ebuild). nl.
ss "inherit haskell-cabal". nl.
@@ -124,6 +127,8 @@ showEBuild ebuild =
, (hackage_name ebuild, "${HACKAGE_N}")
]
toMirror = replace "http://hackage.haskell.org/" "mirror://hackage/"
+ this_year :: String
+ this_year = TC.formatTime TC.defaultTimeLocale "%Y" now
-- "+a" -> "a"
-- "b" -> "b"
@@ -149,6 +154,9 @@ verbatim pre s post =
(foldl (\acc v -> acc . ss "\t" . ss v . nl) id s) .
post
+sconcat :: [DString] -> DString
+sconcat = L.foldl' (.) id
+
-- takes string and substitutes tabs to spaces
-- ebuild's convention is 4 spaces for one tab,
-- BUT! nested USE flags get moved too much to
diff --git a/Portage/EMeta.hs b/Portage/EMeta.hs
new file mode 100644
index 0000000..adf2260
--- /dev/null
+++ b/Portage/EMeta.hs
@@ -0,0 +1,85 @@
+module Portage.EMeta
+ ( EMeta(..)
+ , findExistingMeta
+ ) where
+
+import Control.Monad.Error
+import Data.Char (isSpace)
+import qualified Data.List as L
+
+import System.Directory (doesDirectoryExist, getDirectoryContents)
+import System.FilePath ((</>))
+import Text.Printf
+
+-- tries to extract value of variable in 'var="val"' format
+-- There should be exactly one variable assignment in ebuild
+-- It's a bit artificial limitation, but it's common for 'if / else' blocks
+extract_quoted_string :: FilePath -> String -> String -> Maybe String
+extract_quoted_string ebuild_path s_ebuild var_name =
+ case filter (L.isPrefixOf var_prefix . ltrim) $ lines s_ebuild of
+ [] -> Nothing
+ [kw_line] -> up_to_quote $ skip_prefix $ ltrim kw_line
+ other -> bail_out $ printf "strange '%s' assignmets:\n%s" var_name (unlines other)
+
+ where ltrim :: String -> String
+ ltrim = dropWhile isSpace
+ var_prefix = var_name ++ "=\""
+ skip_prefix = drop (length var_prefix)
+ up_to_quote l = case break (== '"') l of
+ ("", _) -> Nothing -- empty line
+ (_, "") -> bail_out $ printf "failed to find closing quote for '%s'" l
+ (val, _) -> Just val
+ bail_out :: String -> e
+ bail_out msg = error $ printf "%s:extract_quoted_string %s" ebuild_path msg
+
+-- tries to extract value of variable in '#hackport: var: val' format
+-- There should be exactly one variable assignment in ebuild.
+extract_hackport_var :: FilePath -> String -> String -> Maybe String
+extract_hackport_var ebuild_path s_ebuild var_name =
+ case filter (L.isPrefixOf var_prefix) $ lines s_ebuild of
+ [] -> Nothing
+ [var_line] -> Just $ skip_prefix var_line
+ other -> bail_out $ printf "strange '%s' assignmets:\n%s" var_name (unlines other)
+
+ where var_prefix = "#hackport: " ++ var_name ++ ": "
+ skip_prefix = drop (length var_prefix)
+ bail_out :: String -> e
+ bail_out msg = error $ printf "%s:extract_hackport_var %s" ebuild_path msg
+
+extractKeywords :: FilePath -> String -> Maybe [String]
+extractKeywords ebuild_path s_ebuild =
+ words `fmap ` extract_quoted_string ebuild_path s_ebuild "KEYWORDS"
+
+extractLicense :: FilePath -> String -> Maybe String
+extractLicense ebuild_path s_ebuild =
+ extract_quoted_string ebuild_path s_ebuild "LICENSE"
+
+extractCabalFlags :: FilePath -> String -> Maybe String
+extractCabalFlags ebuild_path s_ebuild =
+ extract_hackport_var ebuild_path s_ebuild "flags"
+
+-- aggregated (best inferred) metadata for a new ebuild of package
+data EMeta = EMeta { keywords :: Maybe [String]
+ , license :: Maybe String
+ , cabal_flags :: Maybe String
+ }
+
+findExistingMeta :: FilePath -> IO EMeta
+findExistingMeta pkgdir =
+ do ebuilds <- filter (L.isSuffixOf ".ebuild") `fmap` do b <- doesDirectoryExist pkgdir
+ if b then getDirectoryContents pkgdir
+ else return []
+ -- TODO: version sort
+ e_metas <- forM ebuilds $ \e ->
+ do let e_path = pkgdir </> e
+ e_conts <- readFile e_path
+ return EMeta { keywords = extractKeywords e e_conts
+ , license = extractLicense e e_conts
+ , cabal_flags = extractCabalFlags e e_conts
+ }
+ let get_latest candidates = last (Nothing : filter (/= Nothing) candidates)
+ aggregated_meta = EMeta { keywords = get_latest $ map keywords e_metas
+ , license = get_latest $ map license e_metas
+ , cabal_flags = get_latest $ map cabal_flags e_metas
+ }
+ return aggregated_meta
diff --git a/Portage/PackageId.hs b/Portage/PackageId.hs
index ec81733..a337b17 100644
--- a/Portage/PackageId.hs
+++ b/Portage/PackageId.hs
@@ -11,9 +11,12 @@ module Portage.PackageId (
parseFriendlyPackage,
normalizeCabalPackageName,
normalizeCabalPackageId,
- packageIdToFilePath
+ packageIdToFilePath,
+ cabal_pn_to_PN
) where
+import Data.Char
+
import qualified Distribution.Package as Cabal
import Distribution.Text (Text(..))
@@ -124,3 +127,5 @@ parseFriendlyPackage str =
return (Just v)
return (mc, p, mv)
+cabal_pn_to_PN :: Cabal.PackageName -> String
+cabal_pn_to_PN = map toLower . display
diff --git a/Util.hs b/Util.hs
index 95f5d88..209eace 100644
--- a/Util.hs
+++ b/Util.hs
@@ -8,6 +8,7 @@
module Util
( run_cmd -- :: String -> IO (Maybe String)
+ , split -- :: (a -> Bool) -> [a] -> [[a]]
) where
import System.IO
@@ -29,3 +30,10 @@ run_cmd cmd = do (hI, hO, hE, hProcess) <- runInteractiveCommand cmd
return $ if (output == "" || exitCode /= ExitSuccess)
then Nothing
else Just output
+
+split :: Eq a => (a -> Bool) -> [a] -> [[a]]
+split _ [] = []
+split p xs =
+ case break p xs of
+ (l, []) -> [l]
+ (l, _:r) -> l: split p r
diff --git a/cabal/.travis.yml b/cabal/.travis.yml
new file mode 100644
index 0000000..1464254
--- /dev/null
+++ b/cabal/.travis.yml
@@ -0,0 +1,44 @@
+# NB: don't set `language: haskell` here
+
+# 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=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
+
+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
+
+# 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.
+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
+
+# 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";
+ else
+ echo "expected '$SRC_TGZ' not found";
+ exit 1;
+ fi
+
+matrix:
+ allow_failures:
+ - env: GHCVER=head
diff --git a/cabal/Cabal/Cabal.cabal b/cabal/Cabal/Cabal.cabal
index a80e13b..d01caf5 100644
--- a/cabal/Cabal/Cabal.cabal
+++ b/cabal/Cabal/Cabal.cabal
@@ -1,193 +1,289 @@
-Name: Cabal
-Version: 1.17.0
-Copyright: 2003-2006, Isaac Jones
+name: Cabal
+version: 1.19.2
+copyright: 2003-2006, Isaac Jones
2005-2011, Duncan Coutts
-License: BSD3
-License-File: LICENSE
-Author: Isaac Jones <ijones@syntaxpolice.org>
+license: BSD3
+license-file: LICENSE
+author: Isaac Jones <ijones@syntaxpolice.org>
Duncan Coutts <duncan@community.haskell.org>
-Maintainer: cabal-devel@haskell.org
-Homepage: http://www.haskell.org/cabal/
+maintainer: cabal-devel@haskell.org
+homepage: http://www.haskell.org/cabal/
bug-reports: https://github.com/haskell/cabal/issues
-Synopsis: A framework for packaging Haskell software
-Description:
- The Haskell Common Architecture for Building Applications and
- Libraries: a framework defining a common interface for authors to more
- easily build their Haskell applications in a portable way.
- .
- The Haskell Cabal is part of a larger infrastructure for distributing,
- organizing, and cataloging Haskell libraries and tools.
-Category: Distribution
+synopsis: A framework for packaging Haskell software
+description:
+ The Haskell Common Architecture for Building Applications and
+ Libraries: a framework defining a common interface for authors to more
+ easily build their Haskell applications in a portable way.
+ .
+ The Haskell Cabal is part of a larger infrastructure for distributing,
+ organizing, and cataloging Haskell libraries and tools.
+category: Distribution
cabal-version: >=1.10
-Build-Type: Custom
+build-type: Custom
-- Even though we do use the default Setup.lhs it's vital to bootstrapping
-- that we build Setup.lhs using our own local Cabal source code.
-Extra-Source-Files:
- README changelog
+extra-source-files:
+ README tests/README changelog
+
+ -- Generated with 'misc/gen-extra-source-files.sh' & 'M-x sort-lines':
+ tests/PackageTests/BenchmarkExeV10/Foo.hs
+ tests/PackageTests/BenchmarkExeV10/benchmarks/bench-Foo.hs
+ tests/PackageTests/BenchmarkExeV10/my.cabal
+ tests/PackageTests/BenchmarkOptions/BenchmarkOptions.cabal
+ tests/PackageTests/BenchmarkOptions/test-BenchmarkOptions.hs
+ tests/PackageTests/BenchmarkStanza/my.cabal
+ tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal
+ tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs
+ tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal
+ tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs
+ tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs
+ tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal
+ tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs
+ tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs
+ tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal
+ tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs
+ tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs
+ tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal
+ tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs
+ tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs
+ tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal
+ tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs
+ tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal
+ tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs
+ tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs
+ tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal
+ tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs
+ tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal
+ tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs
+ tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs
+ tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal
+ tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs
+ tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal
+ tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs
+ tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs
+ tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs
+ tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs
+ tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal
+ tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs
+ tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs
+ tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal
+ 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
+ tests/PackageTests/CMain/my.cabal
+ tests/PackageTests/DeterministicAr/Lib.hs
+ tests/PackageTests/DeterministicAr/my.cabal
+ tests/PackageTests/EmptyLib/empty/empty.cabal
+ tests/PackageTests/OrderFlags/Foo.hs
+ tests/PackageTests/OrderFlags/my.cabal
+ tests/PackageTests/PathsModule/Executable/Main.hs
+ tests/PackageTests/PathsModule/Executable/my.cabal
+ tests/PackageTests/PathsModule/Library/my.cabal
+ tests/PackageTests/PreProcess/Foo.hsc
+ tests/PackageTests/PreProcess/Main.hs
+ tests/PackageTests/PreProcess/my.cabal
+ tests/PackageTests/TemplateHaskell/dynamic/Exe.hs
+ tests/PackageTests/TemplateHaskell/dynamic/Lib.hs
+ tests/PackageTests/TemplateHaskell/dynamic/TH.hs
+ tests/PackageTests/TemplateHaskell/dynamic/my.cabal
+ tests/PackageTests/TemplateHaskell/profiling/Exe.hs
+ tests/PackageTests/TemplateHaskell/profiling/Lib.hs
+ tests/PackageTests/TemplateHaskell/profiling/TH.hs
+ tests/PackageTests/TemplateHaskell/profiling/my.cabal
+ tests/PackageTests/TemplateHaskell/vanilla/Exe.hs
+ tests/PackageTests/TemplateHaskell/vanilla/Lib.hs
+ tests/PackageTests/TemplateHaskell/vanilla/TH.hs
+ tests/PackageTests/TemplateHaskell/vanilla/my.cabal
+ 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/Setup.hs
+ tests/hackage/check.sh
+ tests/hackage/download.sh
+ tests/hackage/unpack.sh
+ tests/misc/ghc-supported-languages.hs
source-repository head
type: git
location: https://github.com/haskell/cabal/
subdir: Cabal
-Flag base4
- Description: Choose the even newer, even smaller, split-up base package.
-
-Flag base3
- Description: Choose the new smaller, split-up base package.
-
-Flag bytestring-in-base
-
-Library
- build-depends: base >= 2 && < 5,
- deepseq >= 1.3 && < 1.4,
- filepath >= 1 && < 1.4
- if flag(base4) { build-depends: base >= 4 } else { build-depends: base < 4 }
- if flag(base3) { build-depends: base >= 3 } else { build-depends: base < 3 }
- if flag(base3)
- Build-Depends: directory >= 1 && < 1.3,
- process >= 1 && < 1.2,
- old-time >= 1 && < 1.2,
- containers >= 0.1 && < 0.6,
- array >= 0.1 && < 0.5,
- pretty >= 1 && < 1.2
- if flag(bytestring-in-base)
- Build-Depends: base >= 2.0 && < 2.2
- else
- Build-Depends: base < 2.0 || >= 3.0, bytestring >= 0.9
+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,
+ bytestring >= 0.9
if !os(windows)
- Build-Depends: unix >= 2.0 && < 2.7
+ build-depends:
+ unix >= 2.0 && < 2.8
- ghc-options: -Wall -fno-ignore-asserts
- if impl(ghc >= 6.8)
- ghc-options: -fwarn-tabs
- nhc98-Options: -K4M
+ ghc-options: -Wall -fno-ignore-asserts -fwarn-tabs
- Exposed-Modules:
- Distribution.Compiler,
- Distribution.InstalledPackageInfo,
- Distribution.License,
- Distribution.Make,
- Distribution.ModuleName,
- Distribution.Package,
- Distribution.PackageDescription,
- Distribution.PackageDescription.Configuration,
- Distribution.PackageDescription.Parse,
- Distribution.PackageDescription.Check,
- Distribution.PackageDescription.PrettyPrint,
- Distribution.ParseUtils,
- Distribution.ReadE,
- Distribution.Simple,
- Distribution.Simple.Build,
- Distribution.Simple.Build.Macros,
- Distribution.Simple.Build.PathsModule,
- Distribution.Simple.BuildPaths,
- Distribution.Simple.Bench,
- Distribution.Simple.Command,
- Distribution.Simple.Compiler,
- Distribution.Simple.Configure,
- Distribution.Simple.GHC,
- Distribution.Simple.LHC,
- Distribution.Simple.Haddock,
- Distribution.Simple.Hpc,
- Distribution.Simple.Hugs,
- Distribution.Simple.Install,
- Distribution.Simple.InstallDirs,
- Distribution.Simple.JHC,
- Distribution.Simple.LocalBuildInfo,
- Distribution.Simple.NHC,
- Distribution.Simple.PackageIndex,
- Distribution.Simple.PreProcess,
- Distribution.Simple.PreProcess.Unlit,
- Distribution.Simple.Program,
- Distribution.Simple.Program.Ar,
- Distribution.Simple.Program.Builtin,
- Distribution.Simple.Program.Db,
- Distribution.Simple.Program.GHC,
- Distribution.Simple.Program.HcPkg,
- Distribution.Simple.Program.Hpc,
- Distribution.Simple.Program.Ld,
- Distribution.Simple.Program.Run,
- Distribution.Simple.Program.Script,
- Distribution.Simple.Program.Types,
- Distribution.Simple.Register,
- Distribution.Simple.Setup,
- Distribution.Simple.SrcDist,
- Distribution.Simple.Test,
- Distribution.Simple.UHC,
- Distribution.Simple.UserHooks,
- Distribution.Simple.Utils,
- Distribution.System,
- Distribution.TestSuite,
- Distribution.Text,
- Distribution.Verbosity,
- Distribution.Version,
- Distribution.Compat.ReadP,
- Language.Haskell.Extension
+ exposed-modules:
+ Distribution.Compat.Environment
+ Distribution.Compat.Exception
+ Distribution.Compat.ReadP
+ Distribution.Compiler
+ Distribution.InstalledPackageInfo
+ Distribution.License
+ Distribution.Make
+ Distribution.ModuleName
+ Distribution.Package
+ Distribution.PackageDescription
+ Distribution.PackageDescription.Check
+ Distribution.PackageDescription.Configuration
+ Distribution.PackageDescription.Parse
+ Distribution.PackageDescription.PrettyPrint
+ Distribution.PackageDescription.Utils
+ Distribution.ParseUtils
+ Distribution.ReadE
+ Distribution.Simple
+ Distribution.Simple.Bench
+ Distribution.Simple.Build
+ Distribution.Simple.Build.Macros
+ Distribution.Simple.Build.PathsModule
+ Distribution.Simple.BuildPaths
+ Distribution.Simple.BuildTarget
+ Distribution.Simple.CCompiler
+ Distribution.Simple.Command
+ Distribution.Simple.Compiler
+ Distribution.Simple.Configure
+ Distribution.Simple.GHC
+ 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
+ Distribution.Simple.Program
+ Distribution.Simple.Program.Ar
+ Distribution.Simple.Program.Builtin
+ Distribution.Simple.Program.Db
+ Distribution.Simple.Program.Find
+ Distribution.Simple.Program.GHC
+ Distribution.Simple.Program.HcPkg
+ Distribution.Simple.Program.Hpc
+ Distribution.Simple.Program.Ld
+ Distribution.Simple.Program.Run
+ Distribution.Simple.Program.Script
+ Distribution.Simple.Program.Strip
+ Distribution.Simple.Program.Types
+ Distribution.Simple.Register
+ Distribution.Simple.Setup
+ Distribution.Simple.SrcDist
+ Distribution.Simple.Test
+ Distribution.Simple.UHC
+ Distribution.Simple.UserHooks
+ Distribution.Simple.Utils
+ Distribution.System
+ Distribution.TestSuite
+ Distribution.Text
+ Distribution.Verbosity
+ Distribution.Version
+ Language.Haskell.Extension
- Other-Modules:
- Distribution.GetOpt,
- Distribution.Compat.Exception,
- Distribution.Compat.CopyFile,
- Distribution.Compat.TempFile,
- Distribution.Simple.GHC.IPI641,
- Distribution.Simple.GHC.IPI642,
- Paths_Cabal
+ other-modules:
+ Distribution.Compat.CopyFile
+ Distribution.Compat.TempFile
+ Distribution.GetOpt
+ Distribution.Simple.GHC.IPI641
+ Distribution.Simple.GHC.IPI642
+ Paths_Cabal
- Default-Language: Haskell98
- Default-Extensions: CPP
+ default-language: Haskell98
+ default-extensions: CPP
-- Small, fast running tests.
test-suite unit-tests
type: exitcode-stdio-1.0
- main-is: UnitTests.hs
hs-source-dirs: tests
+ other-modules: UnitTests.Distribution.Compat.ReadP
+ main-is: UnitTests.hs
build-depends:
- base,
- test-framework,
- test-framework-hunit,
- test-framework-quickcheck2,
- HUnit,
- QuickCheck,
- Cabal
- Default-Language: Haskell98
+ base,
+ test-framework,
+ test-framework-hunit,
+ test-framework-quickcheck2,
+ HUnit,
+ QuickCheck,
+ Cabal
+ ghc-options: -Wall
+ default-language: Haskell98
-- Large, system tests that build packages.
test-suite package-tests
type: exitcode-stdio-1.0
main-is: PackageTests.hs
- other-modules: PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check,
- PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check,
- PackageTests.BuildDeps.InternalLibrary0.Check,
- PackageTests.BuildDeps.InternalLibrary1.Check,
- PackageTests.BuildDeps.InternalLibrary2.Check,
- PackageTests.BuildDeps.InternalLibrary3.Check,
- PackageTests.BuildDeps.InternalLibrary4.Check,
- PackageTests.BuildDeps.TargetSpecificDeps1.Check,
- PackageTests.BuildDeps.TargetSpecificDeps2.Check,
- PackageTests.BuildDeps.TargetSpecificDeps3.Check,
- PackageTests.BuildDeps.SameDepsAllRound.Check,
- PackageTests.TestOptions.Check,
- PackageTests.TestStanza.Check,
- PackageTests.TestSuiteExeV10.Check,
- PackageTests.BenchmarkStanza.Check,
- PackageTests.TemplateHaskell.Check,
- PackageTests.PackageTester
+ other-modules:
+ Distribution.Compat.CreatePipe
+ PackageTests.BenchmarkExeV10.Check
+ PackageTests.BenchmarkOptions.Check
+ PackageTests.BenchmarkStanza.Check
+ PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check
+ PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check
+ PackageTests.BuildDeps.InternalLibrary0.Check
+ PackageTests.BuildDeps.InternalLibrary1.Check
+ PackageTests.BuildDeps.InternalLibrary2.Check
+ PackageTests.BuildDeps.InternalLibrary3.Check
+ PackageTests.BuildDeps.InternalLibrary4.Check
+ PackageTests.BuildDeps.SameDepsAllRound.Check
+ 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.OrderFlags.Check
+ PackageTests.PackageTester
+ PackageTests.PathsModule.Executable.Check
+ PackageTests.PathsModule.Library.Check
+ PackageTests.PreProcess.Check
+ PackageTests.TemplateHaskell.Check
+ PackageTests.TestOptions.Check
+ PackageTests.TestStanza.Check
+ PackageTests.TestSuiteExeV10.Check
hs-source-dirs: tests
build-depends:
- base,
- test-framework,
- test-framework-quickcheck2 >= 0.2.12,
- test-framework-hunit,
- HUnit,
- QuickCheck >= 2.1.0.1,
- Cabal,
- process,
- directory,
- filepath,
- extensible-exceptions,
- bytestring,
- unix
- Default-Language: Haskell98
+ base,
+ test-framework,
+ test-framework-quickcheck2 >= 0.2.12,
+ test-framework-hunit,
+ HUnit,
+ QuickCheck >= 2.1.0.1,
+ Cabal,
+ process,
+ directory,
+ filepath,
+ extensible-exceptions,
+ bytestring,
+ regex-posix
+ if !os(windows)
+ build-depends: unix
+ ghc-options: -Wall
+ default-extensions: CPP
+ default-language: Haskell98
diff --git a/cabal/Cabal/DefaultSetup.hs b/cabal/Cabal/DefaultSetup.hs
deleted file mode 100644
index 9a994af..0000000
--- a/cabal/Cabal/DefaultSetup.hs
+++ /dev/null
@@ -1,2 +0,0 @@
-import Distribution.Simple
-main = defaultMain
diff --git a/cabal/Cabal/Distribution/Compat/CopyFile.hs b/cabal/Cabal/Distribution/Compat/CopyFile.hs
index 3d96d72..f8a183b 100644
--- a/cabal/Cabal/Distribution/Compat/CopyFile.hs
+++ b/cabal/Cabal/Distribution/Compat/CopyFile.hs
@@ -1,12 +1,9 @@
-{-# OPTIONS -cpp #-}
--- OPTIONS required for ghc-6.4.x compat, and must appear first
{-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -cpp #-}
-{-# OPTIONS_NHC98 -cpp #-}
-{-# OPTIONS_JHC -fcpp #-}
--- #hide
+{-# OPTIONS_HADDOCK hide #-}
module Distribution.Compat.CopyFile (
copyFile,
+ copyFileChanged,
+ filesEqual,
copyOrdinaryFile,
copyExecutableFile,
setFileOrdinary,
@@ -14,49 +11,36 @@ module Distribution.Compat.CopyFile (
setDirOrdinary,
) where
-#ifdef __GLASGOW_HASKELL__
import Control.Monad
- ( when )
+ ( when, unless )
import Control.Exception
- ( bracket, bracketOnError )
+ ( bracket, bracketOnError, throwIO )
+import qualified Data.ByteString.Lazy as BSL
import Distribution.Compat.Exception
( catchIO )
-#if __GLASGOW_HASKELL__ >= 608
-import Distribution.Compat.Exception
- ( throwIOIO )
import System.IO.Error
( ioeSetLocation )
-#endif
import System.Directory
- ( renameFile, removeFile )
+ ( doesFileExist, renameFile, removeFile )
import Distribution.Compat.TempFile
( openBinaryTempFile )
import System.FilePath
( takeDirectory )
import System.IO
- ( openBinaryFile, IOMode(ReadMode), hClose, hGetBuf, hPutBuf )
+ ( openBinaryFile, IOMode(ReadMode), hClose, hGetBuf, hPutBuf
+ , withBinaryFile )
import Foreign
( allocaBytes )
-#endif /* __GLASGOW_HASKELL__ */
#ifndef mingw32_HOST_OS
-#if __GLASGOW_HASKELL__ >= 611
import System.Posix.Internals (withFilePath)
-#else
-import Foreign.C (withCString)
-#endif
import System.Posix.Types
( FileMode )
import System.Posix.Internals
( c_chmod )
-#if __GLASGOW_HASKELL__ >= 608
import Foreign.C
( throwErrnoPathIfMinus1_ )
-#else
-import Foreign.C
- ( throwErrnoIfMinus1_ )
-#endif
#endif /* mingw32_HOST_OS */
copyOrdinaryFile, copyExecutableFile :: FilePath -> FilePath -> IO ()
@@ -70,30 +54,21 @@ setFileExecutable path = setFileMode path 0o755 -- file perms -rwxr-xr-x
setFileMode :: FilePath -> FileMode -> IO ()
setFileMode name m =
-#if __GLASGOW_HASKELL__ >= 611
withFilePath name $ \s -> do
-#else
- withCString name $ \s -> do
-#endif
-#if __GLASGOW_HASKELL__ >= 608
throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m)
#else
- throwErrnoIfMinus1_ name (c_chmod s m)
-#endif
-#else
setFileOrdinary _ = return ()
setFileExecutable _ = return ()
#endif
-- This happens to be true on Unix and currently on Windows too:
setDirOrdinary = setFileExecutable
+-- | Copies a file to a new destination.
+-- Often you should use `copyFileChanged` instead.
copyFile :: FilePath -> FilePath -> IO ()
-#ifdef __GLASGOW_HASKELL__
copyFile fromFPath toFPath =
copy
-#if __GLASGOW_HASKELL__ >= 608
- `catchIO` (\ioe -> throwIOIO (ioeSetLocation ioe "copyFile"))
-#endif
+ `catchIO` (\ioe -> throwIO (ioeSetLocation ioe "copyFile"))
where copy = bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom ->
bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) ->
do allocaBytes bufferSize $ copyContents hFrom hTmp
@@ -110,6 +85,25 @@ copyFile fromFPath toFPath =
when (count > 0) $ do
hPutBuf hTo buffer count
copyContents hFrom hTo buffer
-#else
-copyFile fromFPath toFPath = readFile fromFPath >>= writeFile toFPath
-#endif
+
+-- | Like `copyFile`, but does not touch the target if source and destination
+-- are already byte-identical. This is recommended as it is useful for
+-- time-stamp based recompilation avoidance.
+copyFileChanged :: FilePath -> FilePath -> IO ()
+copyFileChanged src dest = do
+ equal <- filesEqual src dest
+ unless equal $ copyFile src dest
+
+-- | Checks if two files are byte-identical.
+-- Returns False if either of the files do not exist.
+filesEqual :: FilePath -> FilePath -> IO Bool
+filesEqual f1 f2 = do
+ ex1 <- doesFileExist f1
+ ex2 <- doesFileExist f2
+ if not (ex1 && ex2) then return False else do
+
+ withBinaryFile f1 ReadMode $ \h1 ->
+ withBinaryFile f2 ReadMode $ \h2 -> do
+ c1 <- BSL.hGetContents h1
+ c2 <- BSL.hGetContents h2
+ return $! c1 == c2
diff --git a/cabal/Cabal/Distribution/Compat/Environment.hs b/cabal/Cabal/Distribution/Compat/Environment.hs
new file mode 100644
index 0000000..6430767
--- /dev/null
+++ b/cabal/Cabal/Distribution/Compat/Environment.hs
@@ -0,0 +1,24 @@
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_HADDOCK hide #-}
+
+module Distribution.Compat.Environment (getEnvironment)
+ where
+
+import qualified System.Environment as System
+
+#ifdef mingw32_HOST_OS
+import qualified Data.Char as Char (toUpper)
+#endif
+
+getEnvironment :: IO [(String, String)]
+#ifdef mingw32_HOST_OS
+-- On Windows, the names of environment variables are case-insensitive, but are
+-- often given in mixed-case (e.g. "PATH" is "Path"), so we have to normalise
+-- them.
+getEnvironment = fmap upcaseVars System.getEnvironment
+ where
+ upcaseVars = map upcaseVar
+ upcaseVar (var, val) = (map Char.toUpper var, val)
+#else
+getEnvironment = System.getEnvironment
+#endif
diff --git a/cabal/Cabal/Distribution/Compat/Exception.hs b/cabal/Cabal/Distribution/Compat/Exception.hs
index ae8d9d5..453d8b0 100644
--- a/cabal/Cabal/Distribution/Compat/Exception.hs
+++ b/cabal/Cabal/Distribution/Compat/Exception.hs
@@ -1,61 +1,17 @@
-{-# OPTIONS -cpp #-}
--- OPTIONS required for ghc-6.4.x compat, and must appear first
-{-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -cpp #-}
-{-# OPTIONS_NHC98 -cpp #-}
-{-# OPTIONS_JHC -fcpp #-}
-
-#if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 610))
-#define NEW_EXCEPTION
-#endif
-
module Distribution.Compat.Exception (
- Exception.IOException,
- onException,
- catchIO,
- catchExit,
- throwIOIO,
- tryIO,
+ catchIO,
+ catchExit,
+ tryIO,
) where
import System.Exit
import qualified Control.Exception as Exception
-onException :: IO a -> IO b -> IO a
-#ifdef NEW_EXCEPTION
-onException = Exception.onException
-#else
-onException io what = io `Exception.catch` \e -> do what
- Exception.throw e
-#endif
-
-throwIOIO :: Exception.IOException -> IO a
-#ifdef NEW_EXCEPTION
-throwIOIO = Exception.throwIO
-#else
-throwIOIO = Exception.throwIO . Exception.IOException
-#endif
-
tryIO :: IO a -> IO (Either Exception.IOException a)
-#ifdef NEW_EXCEPTION
tryIO = Exception.try
-#else
-tryIO = Exception.tryJust Exception.ioErrors
-#endif
catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
-#ifdef NEW_EXCEPTION
catchIO = Exception.catch
-#else
-catchIO = Exception.catchJust Exception.ioErrors
-#endif
catchExit :: IO a -> (ExitCode -> IO a) -> IO a
-#ifdef NEW_EXCEPTION
catchExit = Exception.catch
-#else
-catchExit = Exception.catchJust exitExceptions
- where exitExceptions (Exception.ExitException ee) = Just ee
- exitExceptions _ = Nothing
-#endif
-
diff --git a/cabal/Cabal/Distribution/Compat/ReadP.hs b/cabal/Cabal/Distribution/Compat/ReadP.hs
index e087ed2..c4fc7b1 100644
--- a/cabal/Cabal/Distribution/Compat/ReadP.hs
+++ b/cabal/Cabal/Distribution/Compat/ReadP.hs
@@ -69,8 +69,9 @@ module Distribution.Compat.ReadP
)
where
-import Control.Monad( MonadPlus(..), liftM2 )
+import Control.Monad( MonadPlus(..), liftM, liftM2, ap )
import Data.Char (isSpace)
+import Control.Applicative (Applicative(..), Alternative(empty, (<|>)))
infixr 5 +++, <++
@@ -87,6 +88,13 @@ data P s a
-- Monad, MonadPlus
+instance Functor (P s) where
+ fmap = liftM
+
+instance Applicative (P s) where
+ pure = return
+ (<*>) = ap
+
instance Monad (P s) where
return x = Result x Fail
@@ -98,6 +106,10 @@ instance Monad (P s) where
fail _ = Fail
+instance Alternative (P s) where
+ empty = mzero
+ (<|>) = mplus
+
instance MonadPlus (P s) where
mzero = Fail
@@ -138,6 +150,10 @@ type ReadP r a = Parser r Char a
instance Functor (Parser r s) where
fmap h (R f) = R (\k -> f (k . h))
+instance Applicative (Parser r s) where
+ pure = return
+ (<*>) = ap
+
instance Monad (Parser r s) where
return x = R (\k -> k x)
fail _ = R (\_ -> Fail)
@@ -376,6 +392,3 @@ readS_to_P :: ReadS a -> ReadP r a
-- parser, and therefore a possible inefficiency.
readS_to_P r =
R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s']))
-
-
-
diff --git a/cabal/Cabal/Distribution/Compat/TempFile.hs b/cabal/Cabal/Distribution/Compat/TempFile.hs
index 9feddeb..fe01c29 100644
--- a/cabal/Cabal/Distribution/Compat/TempFile.hs
+++ b/cabal/Cabal/Distribution/Compat/TempFile.hs
@@ -1,10 +1,5 @@
-{-# OPTIONS -cpp #-}
--- OPTIONS required for ghc-6.4.x compat, and must appear first
{-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -cpp #-}
-{-# OPTIONS_NHC98 -cpp #-}
-{-# OPTIONS_JHC -fcpp #-}
--- #hide
+{-# OPTIONS_HADDOCK hide #-}
module Distribution.Compat.TempFile (
openTempFile,
openBinaryTempFile,
@@ -16,39 +11,19 @@ module Distribution.Compat.TempFile (
import System.FilePath ((</>))
import Foreign.C (eEXIST)
-#if __NHC__ || __HUGS__
-import System.IO (openFile, openBinaryFile,
- Handle, IOMode(ReadWriteMode))
-import System.Directory (doesFileExist)
-import System.FilePath ((<.>), splitExtension)
-import System.IO.Error (try, isAlreadyExistsError)
-#else
import System.IO (Handle, openTempFile, openBinaryTempFile)
import Data.Bits ((.|.))
import System.Posix.Internals (c_open, c_close, o_CREAT, o_EXCL, o_RDWR,
o_BINARY, o_NONBLOCK, o_NOCTTY)
import System.IO.Error (isAlreadyExistsError)
-#if __GLASGOW_HASKELL__ >= 611
import System.Posix.Internals (withFilePath)
-#else
-import Foreign.C (withCString)
-#endif
import Foreign.C (CInt)
-#if __GLASGOW_HASKELL__ >= 611
import GHC.IO.Handle.FD (fdToHandle)
-#else
-import GHC.Handle (fdToHandle)
-#endif
-import Distribution.Compat.Exception (onException, tryIO)
-#endif
+import Distribution.Compat.Exception (tryIO)
+import Control.Exception (onException)
import Foreign.C (getErrno, errnoToIOError)
-#if __NHC__
-import System.Posix.Types (CPid(..))
-foreign import ccall unsafe "getpid" c_getpid :: IO CPid
-#else
import System.Posix.Internals (c_getpid)
-#endif
#ifdef mingw32_HOST_OS
import System.Directory ( createDirectory )
@@ -64,43 +39,6 @@ import qualified System.Posix
-- System.IO.openTempFile. This includes nhc-1.20, hugs-2006.9.
-- TODO: Not sure about jhc
-#if __NHC__ || __HUGS__
--- use a temporary filename that doesn't already exist.
--- NB. *not* secure (we don't atomically lock the tmp file we get)
-openTempFile :: FilePath -> String -> IO (FilePath, Handle)
-openTempFile tmp_dir template
- = do x <- getProcessID
- findTempName x
- where
- (templateBase, templateExt) = splitExtension template
- findTempName :: Int -> IO (FilePath, Handle)
- findTempName x
- = do let path = tmp_dir </> (templateBase ++ "-" ++ show x) <.> templateExt
- b <- doesFileExist path
- if b then findTempName (x+1)
- else do hnd <- openFile path ReadWriteMode
- return (path, hnd)
-
-openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle)
-openBinaryTempFile tmp_dir template
- = do x <- getProcessID
- findTempName x
- where
- (templateBase, templateExt) = splitExtension template
- findTempName :: Int -> IO (FilePath, Handle)
- findTempName x
- = do let path = tmp_dir </> (templateBase ++ "-" ++ show x) <.> templateExt
- b <- doesFileExist path
- if b then findTempName (x+1)
- else do hnd <- openBinaryFile path ReadWriteMode
- return (path, hnd)
-
-openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle)
-openNewBinaryFile = openBinaryTempFile
-
-getProcessID :: IO Int
-getProcessID = fmap fromIntegral c_getpid
-#else
-- This is a copy/paste of the openBinaryTempFile definition, but
-- if uses 666 rather than 600 for the permissions. The base library
-- needs to be changed to make this better.
@@ -128,10 +66,6 @@ openNewBinaryFile dir template = do
oflags = rw_flags .|. o_EXCL .|. o_BINARY
-#if __GLASGOW_HASKELL__ < 611
- withFilePath = withCString
-#endif
-
findTempName x = do
fd <- withFilePath filepath $ \ f ->
c_open f oflags 0o666
@@ -145,17 +79,7 @@ openNewBinaryFile dir template = do
-- TODO: We want to tell fdToHandle what the filepath is,
-- as any exceptions etc will only be able to report the
-- fd currently
- h <-
-#if __GLASGOW_HASKELL__ >= 609
- fdToHandle fd
-#elif __GLASGOW_HASKELL__ <= 606 && defined(mingw32_HOST_OS)
- -- fdToHandle is borked on Windows with ghc-6.6.x
- openFd (fromIntegral fd) Nothing False filepath
- ReadWriteMode True
-#else
- fdToHandle (fromIntegral fd)
-#endif
- `onException` c_close fd
+ h <- fdToHandle fd `onException` c_close fd
return (filepath, h)
where
filename = prefix ++ show x ++ suffix
@@ -181,7 +105,6 @@ std_flags, output_flags, rw_flags :: CInt
std_flags = o_NONBLOCK .|. o_NOCTTY
output_flags = std_flags .|. o_CREAT
rw_flags = output_flags .|. o_RDWR
-#endif
createTempDirectory :: FilePath -> String -> IO FilePath
createTempDirectory dir template = do
diff --git a/cabal/Cabal/Distribution/Compiler.hs b/cabal/Cabal/Distribution/Compiler.hs
index 82abd46..b2f07eb 100644
--- a/cabal/Cabal/Distribution/Compiler.hs
+++ b/cabal/Cabal/Distribution/Compiler.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveDataTypeable #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Compiler
@@ -19,7 +20,7 @@
-- Unfortunately we cannot make this change yet without breaking the
-- 'UserHooks' api, which would break all custom @Setup.hs@ files, so for the
-- moment we just have to live with this deficiency. If you're interested, see
--- ticket #50.
+-- ticket #57.
{- All rights reserved.
@@ -54,6 +55,7 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
module Distribution.Compiler (
-- * Compiler flavor
CompilerFlavor(..),
+ buildCompilerId,
buildCompilerFlavor,
defaultCompilerFlavor,
parseCompilerFlavorCompat,
@@ -62,9 +64,12 @@ module Distribution.Compiler (
CompilerId(..),
) where
+import Data.Data (Data)
+import Data.Typeable (Typeable)
+import Data.Maybe (fromMaybe)
import Distribution.Version (Version(..))
-import qualified System.Info (compilerName)
+import qualified System.Info (compilerName, compilerVersion)
import Distribution.Text (Text(..), display)
import qualified Distribution.Compat.ReadP as Parse
import qualified Text.PrettyPrint as Disp
@@ -74,14 +79,16 @@ import qualified Data.Char as Char (toLower, isDigit, isAlphaNum)
import Control.Monad (when)
data CompilerFlavor = GHC | 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)
+ deriving (Show, Read, Eq, Ord, Typeable, Data)
knownCompilerFlavors :: [CompilerFlavor]
knownCompilerFlavors = [GHC, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC]
instance Text CompilerFlavor where
disp (OtherCompiler name) = Disp.text name
+ disp (HaskellSuite name) = Disp.text name
disp NHC = Disp.text "nhc98"
disp other = Disp.text (lowercase (show other))
@@ -92,9 +99,7 @@ instance Text CompilerFlavor where
classifyCompilerFlavor :: String -> CompilerFlavor
classifyCompilerFlavor s =
- case lookup (lowercase s) compilerMap of
- Just compiler -> compiler
- Nothing -> OtherCompiler s
+ fromMaybe (OtherCompiler s) $ lookup (lowercase s) compilerMap
where
compilerMap = [ (display compiler, compiler)
| compiler <- knownCompilerFlavors ]
@@ -127,6 +132,12 @@ parseCompilerFlavorCompat = do
buildCompilerFlavor :: CompilerFlavor
buildCompilerFlavor = classifyCompilerFlavor System.Info.compilerName
+buildCompilerVersion :: Version
+buildCompilerVersion = System.Info.compilerVersion
+
+buildCompilerId :: CompilerId
+buildCompilerId = CompilerId buildCompilerFlavor buildCompilerVersion
+
-- | The default compiler flavour to pick when compiling stuff. This defaults
-- to the compiler used to build the Cabal lib.
--
diff --git a/cabal/Cabal/Distribution/GetOpt.hs b/cabal/Cabal/Distribution/GetOpt.hs
index 14725d3..6ba8076 100644
--- a/cabal/Cabal/Distribution/GetOpt.hs
+++ b/cabal/Cabal/Distribution/GetOpt.hs
@@ -36,7 +36,7 @@ over 1100 lines, we need only 195 here, including a 46 line example!
:-)
-}
--- #hide
+{-# OPTIONS_HADDOCK hide #-}
module Distribution.GetOpt (
-- * GetOpt
getOpt, getOpt',
@@ -50,7 +50,8 @@ module Distribution.GetOpt (
-- $example
) where
-import Data.List ( isPrefixOf, intersperse, find )
+import Data.List ( isPrefixOf, intercalate, find )
+import Data.Maybe ( isJust )
-- |What to do with options following non-options
data ArgOrder a
@@ -98,7 +99,7 @@ usageInfo :: String -- header
-> [OptDescr a] -- option descriptors
-> String -- nicely formatted decription of options
usageInfo header optDescr = unlines (header:table)
- where (ss,ls,ds) = unzip3 [ (sepBy ", " (map (fmtShort ad) sos)
+ where (ss,ls,ds) = unzip3 [ (intercalate ", " (map (fmtShort ad) sos)
,concatMap (fmtLong ad) (take 1 los)
,d)
| Option sos los ad d <- optDescr ]
@@ -111,7 +112,6 @@ usageInfo header optDescr = unlines (header:table)
| (so,lo,d) <- zip3 ss ls ds
, (so',lo',d') <- fmtOpt dsWidth so lo d ]
padTo n x = take n (x ++ repeat ' ')
- sepBy s = concat . intersperse s
fmtOpt :: Int -> String -> String -> String -> [(String, String, String)]
fmtOpt descrWidth so lo descr =
@@ -201,11 +201,11 @@ longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])
longOpt ls rs optDescr = long ads arg rs
where (opt,arg) = break (=='=') ls
getWith p = [ o | o@(Option _ xs _ _) <- optDescr
- , find (p opt) xs /= Nothing]
+ , isJust (find (p opt) xs)]
exact = getWith (==)
options = if null exact then getWith isPrefixOf else exact
ads = [ ad | Option _ _ ad _ <- options ]
- optStr = ("--"++opt)
+ optStr = "--" ++ opt
long (_:_:_) _ rest = (errAmbig options optStr,rest)
long [NoArg a ] [] rest = (Opt a,rest)
diff --git a/cabal/Cabal/Distribution/InstalledPackageInfo.hs b/cabal/Cabal/Distribution/InstalledPackageInfo.hs
index db3a3e6..dfccb1d 100644
--- a/cabal/Cabal/Distribution/InstalledPackageInfo.hs
+++ b/cabal/Cabal/Distribution/InstalledPackageInfo.hs
@@ -61,19 +61,22 @@ module Distribution.InstalledPackageInfo (
parseInstalledPackageInfo,
showInstalledPackageInfo,
showInstalledPackageInfoField,
+ showSimpleInstalledPackageInfoField,
fieldsInstalledPackageInfo,
) where
import Distribution.ParseUtils
( FieldDescr(..), ParseResult(..), PError(..), PWarning
, simpleField, listField, parseLicenseQ
- , showFields, showSingleNamedField, parseFieldsFlat
+ , showFields, showSingleNamedField, showSimpleSingleNamedField
+ , parseFieldsFlat
, parseFilePathQ, parseTokenQ, parseModuleNameQ, parsePackageNameQ
, showFilePath, showToken, boolField, parseOptVersion
, parseFreeText, showFreeText )
import Distribution.License ( License(..) )
import Distribution.Package
- ( PackageName(..), PackageIdentifier(..), PackageId, InstalledPackageId(..)
+ ( PackageName(..), PackageIdentifier(..)
+ , PackageId, InstalledPackageId(..)
, packageName, packageVersion )
import qualified Distribution.Package as Package
( Package(..) )
@@ -185,6 +188,9 @@ showInstalledPackageInfo = showFields fieldsInstalledPackageInfo
showInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String)
showInstalledPackageInfoField = showSingleNamedField fieldsInstalledPackageInfo
+showSimpleInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String)
+showSimpleInstalledPackageInfoField = showSimpleSingleNamedField fieldsInstalledPackageInfo
+
-- -----------------------------------------------------------------------------
-- Description of the fields, for parsing/printing
diff --git a/cabal/Cabal/Distribution/License.hs b/cabal/Cabal/Distribution/License.hs
index 19b54c3..9078297 100644
--- a/cabal/Cabal/Distribution/License.hs
+++ b/cabal/Cabal/Distribution/License.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveDataTypeable #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.License
@@ -15,7 +16,7 @@
-- and it's useful if we can automatically recognise that (eg so we can display
-- it on the hackage web pages). So you can also specify the license itself in
-- the @.cabal@ file from a short enumeration defined in this module. It
--- includes 'GPL', 'LGPL' and 'BSD3' licenses.
+-- includes 'GPL', 'AGPL', 'LGPL', 'Apache 2.0', 'MIT' and 'BSD3' licenses.
{- All rights reserved.
@@ -59,6 +60,8 @@ import qualified Distribution.Compat.ReadP as Parse
import qualified Text.PrettyPrint as Disp
import Text.PrettyPrint ((<>))
import qualified Data.Char as Char (isAlphaNum)
+import Data.Data (Data)
+import Data.Typeable (Typeable)
-- |This datatype indicates the license under which your package is
-- released. It is also wise to add your license to each source file
@@ -76,6 +79,9 @@ data License =
-- | GNU Public License. Source code must accompany alterations.
GPL (Maybe Version)
+ -- | GNU Affero General Public License
+ | AGPL (Maybe Version)
+
-- | Lesser GPL, Less restrictive than GPL, useful for libraries.
| LGPL (Maybe Version)
@@ -106,11 +112,12 @@ data License =
-- | Not a recognised license.
-- Allows us to deal with future extensions more gracefully.
| UnknownLicense String
- deriving (Read, Show, Eq)
+ deriving (Read, Show, Eq, Typeable, Data)
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
, Apache unversioned, Apache (version [2, 0])
, PublicDomain, AllRightsReserved, OtherLicense]
@@ -121,6 +128,7 @@ knownLicenses = [ GPL unversioned, GPL (version [2]), GPL (version [3])
instance Text License where
disp (GPL version) = Disp.text "GPL" <> dispOptVersion version
disp (LGPL version) = Disp.text "LGPL" <> dispOptVersion version
+ disp (AGPL version) = Disp.text "AGPL" <> dispOptVersion version
disp (Apache version) = Disp.text "Apache" <> dispOptVersion version
disp (UnknownLicense other) = Disp.text other
disp other = Disp.text (show other)
@@ -131,6 +139,7 @@ instance Text License where
return $! case (name, version :: Maybe Version) of
("GPL", _ ) -> GPL version
("LGPL", _ ) -> LGPL version
+ ("AGPL", _ ) -> AGPL version
("BSD3", Nothing) -> BSD3
("BSD4", Nothing) -> BSD4
("MIT", Nothing) -> MIT
diff --git a/cabal/Cabal/Distribution/Make.hs b/cabal/Cabal/Distribution/Make.hs
index d085ce3..1bab509 100644
--- a/cabal/Cabal/Distribution/Make.hs
+++ b/cabal/Cabal/Distribution/Make.hs
@@ -106,7 +106,7 @@ import Distribution.Text
( display )
import System.Environment (getArgs, getProgName)
-import Data.List (intersperse)
+import Data.List (intercalate)
import System.Exit
defaultMain :: IO ()
@@ -138,7 +138,7 @@ defaultMainHelper args =
printHelp help = getProgName >>= putStr . help
printOptionsList = putStr . unlines
printErrors errs = do
- putStr (concat (intersperse "\n" errs))
+ putStr (intercalate "\n" errs)
exitWith (ExitFailure 1)
printNumericVersion = putStrLn $ display cabalVersion
printVersion = putStrLn $ "Cabal library version "
diff --git a/cabal/Cabal/Distribution/ModuleName.hs b/cabal/Cabal/Distribution/ModuleName.hs
index 5fe0cc1..45babda 100644
--- a/cabal/Cabal/Distribution/ModuleName.hs
+++ b/cabal/Cabal/Distribution/ModuleName.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveDataTypeable #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.ModuleName
@@ -50,6 +51,8 @@ module Distribution.ModuleName (
import Distribution.Text
( Text(..) )
+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
@@ -57,12 +60,12 @@ import qualified Data.Char as Char
import System.FilePath
( pathSeparator )
import Data.List
- ( intersperse )
+ ( intercalate, intersperse )
-- | A valid Haskell module name.
--
newtype ModuleName = ModuleName [String]
- deriving (Eq, Ord, Read, Show)
+ deriving (Eq, Ord, Read, Show, Typeable, Data)
instance Text ModuleName where
disp (ModuleName ms) =
@@ -127,4 +130,4 @@ components (ModuleName ms) = ms
-- > toFilePath (fromString "A.B.C") = "A/B/C"
--
toFilePath :: ModuleName -> FilePath
-toFilePath = concat . intersperse [pathSeparator] . components
+toFilePath = intercalate [pathSeparator] . components
diff --git a/cabal/Cabal/Distribution/Package.hs b/cabal/Cabal/Distribution/Package.hs
index 0017b8c..b561bf5 100644
--- a/cabal/Cabal/Distribution/Package.hs
+++ b/cabal/Cabal/Distribution/Package.hs
@@ -73,17 +73,18 @@ import qualified Text.PrettyPrint as Disp
import Text.PrettyPrint ((<>), (<+>), text)
import Control.DeepSeq (NFData(..))
import qualified Data.Char as Char ( isDigit, isAlphaNum )
-import Data.List ( intersperse )
+import Data.List ( intercalate )
+import Data.Data ( Data )
import Data.Typeable ( Typeable )
newtype PackageName = PackageName String
- deriving (Read, Show, Eq, Ord, Typeable)
+ deriving (Read, Show, Eq, Ord, Typeable, Data)
instance Text PackageName where
disp (PackageName n) = Disp.text n
parse = do
ns <- Parse.sepBy1 component (Parse.char '-')
- return (PackageName (concat (intersperse "-" ns)))
+ return (PackageName (intercalate "-" ns))
where
component = do
cs <- Parse.munch1 Char.isAlphaNum
@@ -103,7 +104,7 @@ data PackageIdentifier
pkgName :: PackageName, -- ^The name of this package, eg. foo
pkgVersion :: Version -- ^the version of this package, eg 1.2
}
- deriving (Read, Show, Eq, Ord, Typeable)
+ deriving (Read, Show, Eq, Ord, Typeable, Data)
instance Text PackageIdentifier where
disp (PackageIdentifier n v) = case v of
@@ -122,12 +123,12 @@ instance NFData PackageIdentifier where
-- * Installed Package Ids
-- ------------------------------------------------------------
--- | An InstalledPackageId uniquely identifies an instance of an installed package.
--- There can be at most one package with a given 'InstalledPackageId'
+-- | An InstalledPackageId uniquely identifies an instance of an installed
+-- package. There can be at most one package with a given 'InstalledPackageId'
-- in a package database, or overlay of databases.
--
newtype InstalledPackageId = InstalledPackageId String
- deriving (Read,Show,Eq,Ord)
+ deriving (Read,Show,Eq,Ord,Typeable,Data)
instance Text InstalledPackageId where
disp (InstalledPackageId str) = text str
@@ -142,7 +143,7 @@ instance Text InstalledPackageId where
-- | Describes a dependency on a source package (API)
--
data Dependency = Dependency PackageName VersionRange
- deriving (Read, Show, Eq)
+ deriving (Read, Show, Eq, Typeable, Data)
instance Text Dependency where
disp (Dependency name ver) =
diff --git a/cabal/Cabal/Distribution/PackageDescription.hs b/cabal/Cabal/Distribution/PackageDescription.hs
index 034479b..585506b 100644
--- a/cabal/Cabal/Distribution/PackageDescription.hs
+++ b/cabal/Cabal/Distribution/PackageDescription.hs
@@ -124,8 +124,9 @@ module Distribution.PackageDescription (
knownRepoTypes,
) where
-import Data.List (nub, intersperse)
-import Data.Maybe (maybeToList)
+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))
@@ -193,9 +194,10 @@ data PackageDescription
dataFiles :: [FilePath],
dataDir :: FilePath,
extraSrcFiles :: [FilePath],
- extraTmpFiles :: [FilePath]
+ extraTmpFiles :: [FilePath],
+ extraDocFiles :: [FilePath]
}
- deriving (Show, Read, Eq)
+ deriving (Show, Read, Eq, Typeable, Data)
instance Package PackageDescription where
packageId = package
@@ -256,7 +258,8 @@ emptyPackageDescription
dataFiles = [],
dataDir = "",
extraSrcFiles = [],
- extraTmpFiles = []
+ extraTmpFiles = [],
+ extraDocFiles = []
}
-- | The type of build system used by this package.
@@ -272,7 +275,7 @@ 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)
+ deriving (Show, Read, Eq, Typeable, Data)
knownBuildTypes :: [BuildType]
knownBuildTypes = [Simple, Configure, Make, Custom]
@@ -298,7 +301,7 @@ data Library = Library {
libExposed :: Bool, -- ^ Is the lib to be exposed by default?
libBuildInfo :: BuildInfo
}
- deriving (Show, Eq, Read)
+ deriving (Show, Eq, Read, Typeable, Data)
instance Monoid Library where
mempty = Library {
@@ -346,7 +349,7 @@ data Executable = Executable {
modulePath :: FilePath,
buildInfo :: BuildInfo
}
- deriving (Show, Read, Eq)
+ deriving (Show, Read, Eq, Typeable, Data)
instance Monoid Executable where
mempty = Executable {
@@ -400,7 +403,7 @@ data TestSuite = TestSuite {
-- a better solution is waiting on the next overhaul to the
-- GenericPackageDescription -> PackageDescription resolution process.
}
- deriving (Show, Read, Eq)
+ deriving (Show, Read, Eq, Typeable, Data)
-- | The test suite interfaces that are currently defined. Each test suite must
-- specify which interface it supports.
@@ -426,7 +429,7 @@ data TestSuiteInterface =
-- the given reason (e.g. unknown test type).
--
| TestSuiteUnsupported TestType
- deriving (Eq, Read, Show)
+ deriving (Eq, Read, Show, Typeable, Data)
instance Monoid TestSuite where
mempty = TestSuite {
@@ -440,7 +443,7 @@ instance Monoid TestSuite where
testName = combine' testName,
testInterface = combine testInterface,
testBuildInfo = combine testBuildInfo,
- testEnabled = if testEnabled a then True else testEnabled b
+ testEnabled = testEnabled a || testEnabled b
}
where combine field = field a `mappend` field b
combine' f = case (f a, f b) of
@@ -482,33 +485,36 @@ 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)
+ deriving (Show, Read, Eq, Typeable, Data)
knownTestTypes :: [TestType]
knownTestTypes = [ TestTypeExe (Version [1,0] [])
, TestTypeLib (Version [0,9] []) ]
+stdParse :: Text ver => (ver -> String -> res) -> Parse.ReadP r res
+stdParse f = do
+ cs <- Parse.sepBy1 component (Parse.char '-')
+ _ <- Parse.char '-'
+ ver <- parse
+ let name = intercalate "-" cs
+ return $! f ver (lowercase name)
+ where
+ component = do
+ cs <- Parse.munch1 Char.isAlphaNum
+ if all Char.isDigit cs then Parse.pfail else return cs
+ -- each component must contain an alphabetic character, to avoid
+ -- ambiguity in identifiers like foo-1 (the 1 is the version number).
+
instance Text TestType where
disp (TestTypeExe ver) = text "exitcode-stdio-" <> disp ver
disp (TestTypeLib ver) = text "detailed-" <> disp ver
disp (TestTypeUnknown name ver) = text name <> char '-' <> disp ver
- parse = do
- cs <- Parse.sepBy1 component (Parse.char '-')
- _ <- Parse.char '-'
- ver <- parse
- let name = concat (intersperse "-" cs)
- return $! case lowercase name of
- "exitcode-stdio" -> TestTypeExe ver
- "detailed" -> TestTypeLib ver
- _ -> TestTypeUnknown name ver
+ parse = stdParse $ \ver name -> case name of
+ "exitcode-stdio" -> TestTypeExe ver
+ "detailed" -> TestTypeLib ver
+ _ -> TestTypeUnknown name ver
- where
- component = do
- cs <- Parse.munch1 Char.isAlphaNum
- if all Char.isDigit cs then Parse.pfail else return cs
- -- each component must contain an alphabetic character, to avoid
- -- ambiguity in identifiers like foo-1 (the 1 is the version number).
testType :: TestSuite -> TestType
testType test = case testInterface test of
@@ -528,7 +534,7 @@ data Benchmark = Benchmark {
benchmarkEnabled :: Bool
-- TODO: See TODO for 'testEnabled'.
}
- deriving (Show, Read, Eq)
+ deriving (Show, Read, Eq, Typeable, Data)
-- | The benchmark interfaces that are currently defined. Each
-- benchmark must specify which interface it supports.
@@ -550,7 +556,7 @@ data BenchmarkInterface =
-- interfaces for the given reason (e.g. unknown benchmark type).
--
| BenchmarkUnsupported BenchmarkType
- deriving (Eq, Read, Show)
+ deriving (Eq, Read, Show, Typeable, Data)
instance Monoid Benchmark where
mempty = Benchmark {
@@ -564,8 +570,7 @@ instance Monoid Benchmark where
benchmarkName = combine' benchmarkName,
benchmarkInterface = combine benchmarkInterface,
benchmarkBuildInfo = combine benchmarkBuildInfo,
- benchmarkEnabled = if benchmarkEnabled a then True
- else benchmarkEnabled b
+ benchmarkEnabled = benchmarkEnabled a || benchmarkEnabled b
}
where combine field = field a `mappend` field b
combine' f = case (f a, f b) of
@@ -605,7 +610,7 @@ data BenchmarkType = BenchmarkTypeExe Version
-- ^ \"type: exitcode-stdio-x.y\"
| BenchmarkTypeUnknown String Version
-- ^ Some unknown benchmark type e.g. \"type: foo\"
- deriving (Show, Read, Eq)
+ deriving (Show, Read, Eq, Typeable, Data)
knownBenchmarkTypes :: [BenchmarkType]
knownBenchmarkTypes = [ BenchmarkTypeExe (Version [1,0] []) ]
@@ -614,21 +619,10 @@ instance Text BenchmarkType where
disp (BenchmarkTypeExe ver) = text "exitcode-stdio-" <> disp ver
disp (BenchmarkTypeUnknown name ver) = text name <> char '-' <> disp ver
- parse = do
- cs <- Parse.sepBy1 component (Parse.char '-')
- _ <- Parse.char '-'
- ver <- parse
- let name = concat (intersperse "-" cs)
- return $! case lowercase name of
- "exitcode-stdio" -> BenchmarkTypeExe ver
- _ -> BenchmarkTypeUnknown name ver
+ parse = stdParse $ \ver name -> case name of
+ "exitcode-stdio" -> BenchmarkTypeExe ver
+ _ -> BenchmarkTypeUnknown name ver
- where
- component = do
- cs <- Parse.munch1 Char.isAlphaNum
- if all Char.isDigit cs then Parse.pfail else return cs
- -- each component must contain an alphabetic character, to avoid
- -- ambiguity in identifiers like foo-1 (the 1 is the version number).
benchmarkType :: Benchmark -> BenchmarkType
benchmarkType benchmark = case benchmarkInterface benchmark of
@@ -670,7 +664,7 @@ data BuildInfo = BuildInfo {
-- simple assoc-list.
targetBuildDepends :: [Dependency] -- ^ Dependencies specific to a library or executable target
}
- deriving (Show,Read,Eq)
+ deriving (Show,Read,Eq,Typeable,Data)
instance Monoid BuildInfo where
mempty = BuildInfo {
@@ -844,7 +838,7 @@ data SourceRepo = SourceRepo {
-- given the default is \".\" ie no subdirectory.
repoSubdir :: Maybe FilePath
}
- deriving (Eq, Read, Show)
+ deriving (Eq, Read, Show, Typeable, Data)
-- | What this repo info is for, what it represents.
--
@@ -860,7 +854,7 @@ data RepoKind =
| RepoThis
| RepoKindUnknown String
- deriving (Eq, Ord, Read, Show)
+ deriving (Eq, Ord, Read, Show, Typeable, Data)
-- | 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
@@ -869,7 +863,7 @@ data RepoKind =
data RepoType = Darcs | Git | SVN | CVS
| Mercurial | GnuArch | Bazaar | Monotone
| OtherRepoType String
- deriving (Eq, Ord, Read, Show)
+ deriving (Eq, Ord, Read, Show, Typeable, Data)
knownRepoTypes :: [RepoType]
knownRepoTypes = [Darcs, Git, SVN, CVS
@@ -900,9 +894,7 @@ instance Text RepoType where
classifyRepoType :: String -> RepoType
classifyRepoType s =
- case lookup (lowercase s) repoTypeMap of
- Just repoType' -> repoType'
- Nothing -> OtherRepoType s
+ fromMaybe (OtherRepoType s) $ lookup (lowercase s) repoTypeMap
where
repoTypeMap = [ (name, repoType')
| repoType' <- knownRepoTypes
@@ -954,7 +946,7 @@ data GenericPackageDescription =
condTestSuites :: [(String, CondTree ConfVar [Dependency] TestSuite)],
condBenchmarks :: [(String, CondTree ConfVar [Dependency] Benchmark)]
}
- deriving (Show, Eq, Typeable)
+ deriving (Show, Eq, Typeable, Data)
instance Package GenericPackageDescription where
packageId = packageId . packageDescription
@@ -969,11 +961,11 @@ data Flag = MkFlag
, flagDefault :: Bool
, flagManual :: Bool
}
- deriving (Show, Eq)
+ deriving (Show, Eq, Typeable, Data)
-- | A 'FlagName' is the name of a user-defined configuration flag
newtype FlagName = FlagName String
- deriving (Eq, Ord, Show, Read)
+ deriving (Eq, Ord, Show, Read, Typeable, Data)
-- | A 'FlagAssignment' is a total or partial mapping of 'FlagName's to
-- 'Bool' flag values. It represents the flags chosen by the user or
@@ -987,7 +979,7 @@ data ConfVar = OS OS
| Arch Arch
| Flag FlagName
| Impl CompilerFlavor VersionRange
- deriving (Eq, Show)
+ deriving (Eq, Show, Typeable, Data)
--instance Text ConfVar where
-- disp (OS os) = "os(" ++ display os ++ ")"
@@ -1002,7 +994,7 @@ data Condition c = Var c
| CNot (Condition c)
| COr (Condition c) (Condition c)
| CAnd (Condition c) (Condition c)
- deriving (Show, Eq)
+ deriving (Show, Eq, Typeable, Data)
--instance Text c => Text (Condition c) where
-- disp (Var x) = text (show x)
@@ -1018,7 +1010,7 @@ data CondTree v c a = CondNode
, CondTree v c a
, Maybe (CondTree v c a))]
}
- deriving (Show, Eq)
+ deriving (Show, Eq, Typeable, Data)
--instance (Text v, Text c) => Text (CondTree v c a) where
-- disp (CondNode _dat cs ifs) =
diff --git a/cabal/Cabal/Distribution/PackageDescription/Check.hs b/cabal/Cabal/Distribution/PackageDescription/Check.hs
index 56afa83..bc5dbe5 100644
--- a/cabal/Cabal/Distribution/PackageDescription/Check.hs
+++ b/cabal/Cabal/Distribution/PackageDescription/Check.hs
@@ -70,7 +70,6 @@ import Control.Monad
import qualified System.Directory as System
( doesFileExist, doesDirectoryExist )
-import Distribution.Package ( pkgName )
import Distribution.PackageDescription
import Distribution.PackageDescription.Configuration
( flattenPackageDescription, finalizePackageDescription )
@@ -80,6 +79,8 @@ import Distribution.System
( OS(..), Arch(..), buildPlatform )
import Distribution.License
( License(..), knownLicenses )
+import Distribution.Simple.CCompiler
+ ( filenameCDialect )
import Distribution.Simple.Utils
( cabalVersion, intercalate, parseFileGlob, FileGlob(..), lowercase )
@@ -92,7 +93,7 @@ import Distribution.Version
, asVersionIntervals, UpperBound(..), isNoVersion )
import Distribution.Package
( PackageName(PackageName), packageName, packageVersion
- , Dependency(..) )
+ , Dependency(..), pkgName )
import Distribution.Text
( display, disp )
@@ -138,6 +139,7 @@ data PackageCheck =
-- quite legitimately refuse to publicly distribute packages with these
-- problems.
| PackageDistInexcusable { explanation :: String }
+ deriving (Eq)
instance Show PackageCheck where
show notice = explanation notice
@@ -146,6 +148,12 @@ check :: Bool -> PackageCheck -> Maybe PackageCheck
check False _ = Nothing
check True pc = Just pc
+checkSpecVersion :: PackageDescription -> [Int] -> Bool -> PackageCheck -> Maybe PackageCheck
+checkSpecVersion pkg specver cond pc
+ | specVersion pkg >= Version specver [] = Nothing
+ | otherwise = check cond pc
+
+
-- ------------------------------------------------------------
-- * Standard checks
-- ------------------------------------------------------------
@@ -171,7 +179,7 @@ checkPackage gpkg mpkg =
pkg = fromMaybe (flattenPackageDescription gpkg) mpkg
--TODO: make this variant go away
--- we should alwaws know the GenericPackageDescription
+-- we should always know the GenericPackageDescription
checkConfiguredPackage :: PackageDescription -> [PackageCheck]
checkConfiguredPackage pkg =
checkSanity pkg
@@ -212,10 +220,10 @@ checkSanity pkg =
]
--TODO: check for name clashes case insensitively: windows file systems cannot cope.
- ++ maybe [] checkLibrary (library pkg)
- ++ concatMap checkExecutable (executables pkg)
- ++ concatMap (checkTestSuite pkg) (testSuites pkg)
- ++ concatMap (checkBenchmark pkg) (benchmarks pkg)
+ ++ maybe [] (checkLibrary pkg) (library pkg)
+ ++ concatMap (checkExecutable pkg) (executables pkg)
+ ++ concatMap (checkTestSuite pkg) (testSuites pkg)
+ ++ concatMap (checkBenchmark pkg) (benchmarks pkg)
++ catMaybes [
@@ -231,12 +239,12 @@ checkSanity pkg =
bmNames = map benchmarkName $ benchmarks pkg
duplicateNames = dups $ exeNames ++ testNames ++ bmNames
-checkLibrary :: Library -> [PackageCheck]
-checkLibrary lib =
+checkLibrary :: PackageDescription -> Library -> [PackageCheck]
+checkLibrary _pkg lib =
catMaybes [
check (not (null moduleDuplicates)) $
- PackageBuildWarning $
+ PackageBuildImpossible $
"Duplicate modules in library: "
++ commaSep (map display moduleDuplicates)
]
@@ -244,22 +252,30 @@ checkLibrary lib =
where
moduleDuplicates = dups (libModules lib)
-checkExecutable :: Executable -> [PackageCheck]
-checkExecutable exe =
+checkExecutable :: PackageDescription -> Executable -> [PackageCheck]
+checkExecutable pkg exe =
catMaybes [
check (null (modulePath exe)) $
PackageBuildImpossible $
- "No 'Main-Is' field found for executable " ++ exeName exe
+ "No 'main-is' field found for executable " ++ exeName exe
, check (not (null (modulePath exe))
- && takeExtension (modulePath exe) `notElem` [".hs", ".lhs"]) $
+ && (not $ fileExtensionSupportedLanguage $ modulePath exe)) $
PackageBuildImpossible $
- "The 'Main-Is' field must specify a '.hs' or '.lhs' file "
- ++ "(even if it is generated by a preprocessor)."
+ "The 'main-is' field must specify a '.hs' or '.lhs' file "
+ ++ "(even if it is generated by a preprocessor), "
+ ++ "or it may specify a C/C++/obj-C source file."
+
+ , checkSpecVersion pkg [1,17]
+ (fileExtensionSupportedLanguage (modulePath exe)
+ && takeExtension (modulePath exe) `notElem` [".hs", ".lhs"]) $
+ PackageDistInexcusable $
+ "The package uses a C/C++/obj-C source file for the 'main-is' field. "
+ ++ "To use this feature you must specify 'cabal-version: >= 1.18'."
, check (not (null moduleDuplicates)) $
- PackageBuildWarning $
+ PackageBuildImpossible $
"Duplicate modules in executable '" ++ exeName exe ++ "': "
++ commaSep (map display moduleDuplicates)
]
@@ -285,14 +301,20 @@ checkTestSuite pkg test =
_ -> Nothing
, check (not $ null moduleDuplicates) $
- PackageBuildWarning $
+ PackageBuildImpossible $
"Duplicate modules in test suite '" ++ testName test ++ "': "
++ commaSep (map display moduleDuplicates)
, check mainIsWrongExt $
PackageBuildImpossible $
"The 'main-is' field must specify a '.hs' or '.lhs' file "
- ++ "(even if it is generated by a preprocessor)."
+ ++ "(even if it is generated by a preprocessor), "
+ ++ "or it may specify a C/C++/obj-C source file."
+
+ , checkSpecVersion pkg [1,17] (mainIsNotHsExt && not mainIsWrongExt) $
+ PackageDistInexcusable $
+ "The package uses a C/C++/obj-C source file for the 'main-is' field. "
+ ++ "To use this feature you must specify 'cabal-version: >= 1.18'."
-- Test suites might be built as (internal) libraries named after
-- the test suite and thus their names must not clash with the
@@ -306,6 +328,10 @@ checkTestSuite pkg test =
moduleDuplicates = dups $ testModules test
mainIsWrongExt = case testInterface test of
+ TestSuiteExeV10 _ f -> not $ fileExtensionSupportedLanguage f
+ _ -> False
+
+ mainIsNotHsExt = case testInterface test of
TestSuiteExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"]
_ -> False
@@ -333,7 +359,7 @@ checkBenchmark pkg bm =
_ -> Nothing
, check (not $ null moduleDuplicates) $
- PackageBuildWarning $
+ PackageBuildImpossible $
"Duplicate modules in benchmark '" ++ benchmarkName bm ++ "': "
++ commaSep (map display moduleDuplicates)
@@ -412,7 +438,7 @@ checkFields pkg =
PackageDistSuspicious $
"Deprecated extensions: "
++ commaSep (map (quote . display . fst) deprecatedExtensions)
- ++ ". " ++ intercalate " "
+ ++ ". " ++ unwords
[ "Instead of '" ++ display ext
++ "' use '" ++ display replacement ++ "'."
| (ext, Just replacement) <- deprecatedExtensions ]
@@ -424,7 +450,7 @@ checkFields pkg =
PackageDistSuspicious "No 'maintainer' field."
, check (null (synopsis pkg) && null (description pkg)) $
- PackageDistInexcusable $ "No 'synopsis' or 'description' field."
+ PackageDistInexcusable "No 'synopsis' or 'description' field."
, check (null (description pkg) && not (null (synopsis pkg))) $
PackageDistSuspicious "No 'description' field."
@@ -517,6 +543,9 @@ checkLicense pkg =
unknownLicenseVersion (LGPL (Just v))
| v `notElem` knownVersions = Just knownVersions
where knownVersions = [ v' | LGPL (Just v') <- knownLicenses ]
+ unknownLicenseVersion (AGPL (Just v))
+ | v `notElem` knownVersions = Just knownVersions
+ where knownVersions = [ v' | AGPL (Just v') <- knownLicenses ]
unknownLicenseVersion (Apache (Just v))
| v `notElem` knownVersions = Just knownVersions
where knownVersions = [ v' | Apache (Just v') <- knownLicenses ]
@@ -532,19 +561,19 @@ checkSourceRepos pkg =
++ "The repo kind is usually 'head' or 'this'"
_ -> Nothing
- , check (repoType repo == Nothing) $
+ , check (isNothing (repoType repo)) $
PackageDistInexcusable
"The source-repository 'type' is a required field."
- , check (repoLocation repo == Nothing) $
+ , check (isNothing (repoLocation repo)) $
PackageDistInexcusable
"The source-repository 'location' is a required field."
- , check (repoType repo == Just CVS && repoModule repo == Nothing) $
+ , check (repoType repo == Just CVS && isNothing (repoModule repo)) $
PackageDistInexcusable
"For a CVS source-repository, the 'module' is a required field."
- , check (repoKind repo == RepoThis && repoTag repo == Nothing) $
+ , check (repoKind repo == RepoThis && isNothing (repoTag repo)) $
PackageDistInexcusable $
"For the 'this' kind of source-repository, the 'tag' is a required "
++ "field. It should specify the tag corresponding to this version "
@@ -825,6 +854,7 @@ checkPaths pkg =
relPaths =
[ (path, "extra-src-files") | path <- extraSrcFiles pkg ]
++ [ (path, "extra-tmp-files") | path <- extraTmpFiles pkg ]
+ ++ [ (path, "extra-doc-files") | path <- extraDocFiles pkg ]
++ [ (path, "data-files") | path <- dataFiles pkg ]
++ [ (path, "data-dir") | path <- [dataDir pkg]]
++ concat
@@ -1092,7 +1122,7 @@ checkCabalVersion pkg =
(\v v' -> intersectVersionRanges (orLaterVersion v) (earlierVersion v'))
intersectVersionRanges unionVersionRanges id
- compatLicenses = [ GPL Nothing, LGPL Nothing, BSD3, BSD4
+ compatLicenses = [ GPL Nothing, LGPL Nothing, AGPL Nothing, BSD3, BSD4
, PublicDomain, AllRightsReserved, OtherLicense ]
mentionedExtensions = [ ext | bi <- allBuildInfo pkg
@@ -1199,7 +1229,7 @@ checkPackageVersions pkg =
]
where
-- TODO: What we really want to do is test if there exists any
- -- configuration in which the base version is unboudned above.
+ -- configuration in which the base version is unbounded above.
-- However that's a bit tricky because there are many possible
-- configurations. As a cheap easy and safe approximation we will
-- pick a single "typical" configuration and check if that has an
@@ -1493,3 +1523,11 @@ commaSep = intercalate ", "
dups :: Ord a => [a] -> [a]
dups xs = [ x | (x:_:_) <- group (sort xs) ]
+
+fileExtensionSupportedLanguage :: FilePath -> Bool
+fileExtensionSupportedLanguage path =
+ isHaskell || isC
+ where
+ extension = takeExtension path
+ isHaskell = extension `elem` [".hs", ".lhs"]
+ isC = isJust (filenameCDialect extension)
diff --git a/cabal/Cabal/Distribution/PackageDescription/Configuration.hs b/cabal/Cabal/Distribution/PackageDescription/Configuration.hs
index 19d5fda..496d701 100644
--- a/cabal/Cabal/Distribution/PackageDescription/Configuration.hs
+++ b/cabal/Cabal/Distribution/PackageDescription/Configuration.hs
@@ -1,13 +1,8 @@
-{-# OPTIONS -cpp #-}
--- OPTIONS required for ghc-6.4.x compat, and must appear first
-{-# LANGUAGE CPP #-}
-- -fno-warn-deprecations for use of Map.foldWithKey
-{-# OPTIONS_GHC -cpp -fno-warn-deprecations #-}
-{-# OPTIONS_NHC98 -cpp #-}
-{-# OPTIONS_JHC -fcpp #-}
+{-# OPTIONS_GHC -fno-warn-deprecations #-}
-----------------------------------------------------------------------------
-- |
--- Module : Distribution.Configuration
+-- Module : Distribution.PackageDescription.Configuration
-- Copyright : Thomas Schilling, 2007
--
-- Maintainer : cabal-devel@haskell.org
@@ -70,6 +65,8 @@ import Distribution.PackageDescription
, Flag(..), FlagName(..), FlagAssignment
, Benchmark(..), CondTree(..), ConfVar(..), Condition(..)
, TestSuite(..) )
+import Distribution.PackageDescription.Utils
+ ( cabalBug, userBug )
import Distribution.Version
( VersionRange, anyVersion, intersectVersionRanges, withinRange )
import Distribution.Compiler
@@ -91,11 +88,6 @@ import Data.Map ( Map, fromListWith, toList )
import qualified Data.Map as Map
import Data.Monoid
-#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 606)
-import qualified Text.Read as R
-import qualified Text.Read.Lex as L
-#endif
-
------------------------------------------------------------------------------
-- | Simplify the condition and return its free variables.
@@ -220,7 +212,7 @@ instance Monoid d => Monoid (DepTestRslt d) where
data BT a = BTN a | BTB (BT a) (BT a) -- very simple binary tree
--- | Try to find a flag assignment that satisfies the constaints of all trees.
+-- | Try to find a flag assignment that satisfies the constraints of all trees.
--
-- Returns either the missing dependencies, or a tuple containing the
-- resulting data, the associated dependencies, and the chosen flag
@@ -315,34 +307,7 @@ resolveWithFlags dom os arch impl constrs trees checkDeps =
-- | A map of dependencies. Newtyped since the default monoid instance is not
-- appropriate. The monoid instance uses 'intersectVersionRanges'.
newtype DependencyMap = DependencyMap { unDependencyMap :: Map PackageName VersionRange }
-#if !defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ >= 606)
deriving (Show, Read)
-#else
--- The Show/Read instance for Data.Map in ghc-6.4 is useless
--- so we have to re-implement it here:
-instance Show DependencyMap where
- showsPrec d (DependencyMap m) =
- showParen (d > 10) (showString "DependencyMap" . shows (M.toList m))
-
-instance Read DependencyMap where
- readPrec = parens $ R.prec 10 $ do
- R.Ident "DependencyMap" <- R.lexP
- xs <- R.readPrec
- return (DependencyMap (M.fromList xs))
- where parens :: R.ReadPrec a -> R.ReadPrec a
- parens p = optional
- where
- optional = p R.+++ mandatory
- mandatory = paren optional
-
- paren :: R.ReadPrec a -> R.ReadPrec a
- paren p = do L.Punc "(" <- R.lexP
- x <- R.reset p
- L.Punc ")" <- R.lexP
- return x
-
- readListPrec = R.readListPrecDefault
-#endif
instance Monoid DependencyMap where
mempty = DependencyMap Map.empty
@@ -361,7 +326,7 @@ simplifyCondTree :: (Monoid a, Monoid d) =>
-> CondTree v d a
-> (d, a)
simplifyCondTree env (CondNode a d ifs) =
- foldr mappend (d, a) $ catMaybes $ map simplifyIf ifs
+ mconcat $ (d, a) : catMaybes (map simplifyIf ifs)
where
simplifyIf (cnd, t, me) =
case simplifyCondition cnd env of
@@ -431,7 +396,7 @@ flattenTaggedTargets :: TargetSet PDTagged ->
, [(String, Benchmark)])
flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, [], [], []) targets
where
- untag (_, Lib _) (Just _, _, _, _) = bug "Only one library expected"
+ untag (_, Lib _) (Just _, _, _, _) = userBug "Only one library expected"
untag (deps, Lib l) (Nothing, exes, tests, bms) =
(Just l', exes, tests, bms)
where
@@ -439,29 +404,38 @@ flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, [], [], []) tar
libBuildInfo = (libBuildInfo l) { targetBuildDepends = fromDepMap deps }
}
untag (deps, Exe n e) (mlib, exes, tests, bms)
- | any ((== n) . fst) exes = bug "Exe with same name found"
- | any ((== n) . fst) tests = bug "Test sharing name of exe found"
- | any ((== n) . fst) bms = bug "Benchmark sharing name of exe found"
- | otherwise = (mlib, exes ++ [(n, e')], tests, bms)
+ | any ((== n) . fst) exes =
+ userBug $ "There exist several exes with the same name: '" ++ n ++ "'"
+ | any ((== n) . fst) tests =
+ userBug $ "There exists a test with the same name as an exe: '" ++ n ++ "'"
+ | any ((== n) . fst) bms =
+ userBug $ "There exists a benchmark with the same name as an exe: '" ++ n ++ "'"
+ | otherwise = (mlib, (n, e'):exes, tests, bms)
where
e' = e {
buildInfo = (buildInfo e) { targetBuildDepends = fromDepMap deps }
}
untag (deps, Test n t) (mlib, exes, tests, bms)
- | any ((== n) . fst) tests = bug "Test with same name found"
- | any ((== n) . fst) exes = bug "Test sharing name of exe found"
- | any ((== n) . fst) bms = bug "Test sharing name of benchmark found"
- | otherwise = (mlib, exes, tests ++ [(n, t')], bms)
+ | any ((== n) . fst) tests =
+ userBug $ "There exist several tests with the same name: '" ++ n ++ "'"
+ | any ((== n) . fst) exes =
+ userBug $ "There exists an exe with the same name as the test: '" ++ n ++ "'"
+ | any ((== n) . fst) bms =
+ userBug $ "There exists a benchmark with the same name as the test: '" ++ n ++ "'"
+ | otherwise = (mlib, exes, (n, t'):tests, bms)
where
t' = t {
testBuildInfo = (testBuildInfo t)
{ targetBuildDepends = fromDepMap deps }
}
untag (deps, Bench n b) (mlib, exes, tests, bms)
- | any ((== n) . fst) bms = bug "Benchmark with same name found"
- | any ((== n) . fst) exes = bug "Benchmark sharing name of exe found"
- | any ((== n) . fst) tests = bug "Benchmark sharing name of test found"
- | otherwise = (mlib, exes, tests, bms ++ [(n, b')])
+ | any ((== n) . fst) bms =
+ userBug $ "There exist several benchmarks with the same name: '" ++ n ++ "'"
+ | any ((== n) . fst) exes =
+ userBug $ "There exists an exe with the same name as the benchmark: '" ++ n ++ "'"
+ | any ((== n) . fst) tests =
+ userBug $ "There exists a test with the same name as the benchmark: '" ++ n ++ "'"
+ | otherwise = (mlib, exes, tests, (n, b'):bms)
where
b' = b {
benchmarkBuildInfo = (benchmarkBuildInfo b)
@@ -489,7 +463,7 @@ instance Monoid PDTagged where
Exe n e `mappend` Exe n' e' | n == n' = Exe n (e `mappend` e')
Test n t `mappend` Test n' t' | n == n' = Test n (t `mappend` t')
Bench n b `mappend` Bench n' b' | n == n' = Bench n (b `mappend` b')
- _ `mappend` _ = bug "Cannot combine incompatible tags"
+ _ `mappend` _ = cabalBug "Cannot combine incompatible tags"
-- | Create a package description with all configurations resolved.
--
@@ -514,8 +488,9 @@ instance Monoid PDTagged where
--
finalizePackageDescription ::
FlagAssignment -- ^ Explicitly specified flag assignments
- -> (Dependency -> Bool) -- ^ Is a given depenency satisfiable from the set of available packages?
- -- If this is unknown then use True.
+ -> (Dependency -> Bool) -- ^ Is a given depenency satisfiable from the set of
+ -- available packages? If this is unknown then use
+ -- True.
-> Platform -- ^ The 'Arch' and 'OS'
-> CompilerId -- ^ Compiler + Version
-> [Dependency] -- ^ Additional constraints
@@ -524,7 +499,8 @@ finalizePackageDescription ::
(PackageDescription, FlagAssignment)
-- ^ Either missing dependencies or the resolved package
-- description along with the flag assignments chosen.
-finalizePackageDescription userflags satisfyDep (Platform arch os) impl constraints
+finalizePackageDescription userflags satisfyDep
+ (Platform arch os) impl constraints
(GenericPackageDescription pkg flags mlib0 exes0 tests0 bms0) =
case resolveFlags of
Right ((mlib, exes', tests', bms'), targetSet, flagVals) ->
@@ -566,9 +542,10 @@ finalizePackageDescription userflags satisfyDep (Platform arch os) impl constrai
| manual -> [b]
| otherwise -> [b, not b]
--flagDefaults = map (\(n,x:_) -> (n,x)) flagChoices
- check ds = if all satisfyDep ds
- then DepOk
- else MissingDeps $ filter (not . satisfyDep) ds
+ check ds = let missingDeps = filter (not . satisfyDep) ds
+ in if null missingDeps
+ then DepOk
+ else MissingDeps missingDeps
{-
let tst_p = (CondNode [1::Int] [Distribution.Package.Dependency "a" AnyVersion] [])
@@ -647,6 +624,3 @@ biFillInDefaults bi =
if null (hsSourceDirs bi)
then bi { hsSourceDirs = [currentDir] }
else bi
-
-bug :: String -> a
-bug msg = error $ msg ++ ". Consider this a bug."
diff --git a/cabal/Cabal/Distribution/PackageDescription/Parse.hs b/cabal/Cabal/Distribution/PackageDescription/Parse.hs
index fe85990..9c2d2e4 100644
--- a/cabal/Cabal/Distribution/PackageDescription/Parse.hs
+++ b/cabal/Cabal/Distribution/PackageDescription/Parse.hs
@@ -72,7 +72,9 @@ import Data.Char (isSpace)
import Data.Maybe (listToMaybe, isJust)
import Data.Monoid ( Monoid(..) )
import Data.List (nub, unfoldr, partition, (\\))
-import Control.Monad (liftM, foldM, when, unless)
+import Control.Monad (liftM, foldM, when, unless, ap)
+import Control.Applicative (Applicative(..))
+import Control.Arrow (first)
import System.Directory (doesFileExist)
import qualified Data.ByteString.Lazy.Char8 as BS.Char8
@@ -84,6 +86,8 @@ import Text.PrettyPrint
import Distribution.ParseUtils hiding (parseFields)
import Distribution.PackageDescription
+import Distribution.PackageDescription.Utils
+ ( cabalBug, userBug )
import Distribution.Package
( PackageIdentifier(..), Dependency(..), packageName, packageVersion )
import Distribution.ModuleName ( ModuleName )
@@ -170,13 +174,17 @@ pkgDescrFieldDescrs =
, listField "extra-tmp-files"
showFilePath parseFilePathQ
extraTmpFiles (\val pkg -> pkg{extraTmpFiles=val})
+ , listField "extra-doc-files"
+ showFilePath parseFilePathQ
+ extraDocFiles (\val pkg -> pkg{extraDocFiles=val})
]
-- | Store any fields beginning with "x-" in the customFields field of
-- a PackageDescription. All other fields will generate a warning.
storeXFieldsPD :: UnrecFieldParser PackageDescription
-storeXFieldsPD (f@('x':'-':_),val) pkg = Just pkg{ customFieldsPD =
- (customFieldsPD pkg) ++ [(f,val)]}
+storeXFieldsPD (f@('x':'-':_),val) pkg =
+ Just pkg{ customFieldsPD =
+ customFieldsPD pkg ++ [(f,val)]}
storeXFieldsPD _ _ = Nothing
-- ---------------------------------------------------------------------------
@@ -194,7 +202,8 @@ libFieldDescrs =
storeXFieldsLib :: UnrecFieldParser Library
storeXFieldsLib (f@('x':'-':_), val) l@(Library { libBuildInfo = bi }) =
- Just $ l {libBuildInfo = bi{ customFieldsBI = (customFieldsBI bi) ++ [(f,val)]}}
+ Just $ l {libBuildInfo =
+ bi{ customFieldsBI = customFieldsBI bi ++ [(f,val)]}}
storeXFieldsLib _ _ = Nothing
-- ---------------------------------------------------------------------------
@@ -217,7 +226,7 @@ executableFieldDescrs =
storeXFieldsExe :: UnrecFieldParser Executable
storeXFieldsExe (f@('x':'-':_), val) e@(Executable { buildInfo = bi }) =
- Just $ e {buildInfo = bi{ customFieldsBI = (f,val):(customFieldsBI bi)}}
+ Just $ e {buildInfo = bi{ customFieldsBI = (f,val):customFieldsBI bi}}
storeXFieldsExe _ _ = Nothing
-- ---------------------------------------------------------------------------
@@ -254,7 +263,7 @@ testSuiteFieldDescrs =
storeXFieldsTest :: UnrecFieldParser TestSuiteStanza
storeXFieldsTest (f@('x':'-':_), val) t@(TestSuiteStanza { testStanzaBuildInfo = bi }) =
- Just $ t {testStanzaBuildInfo = bi{ customFieldsBI = (f,val):(customFieldsBI bi)}}
+ Just $ t {testStanzaBuildInfo = bi{ customFieldsBI = (f,val):customFieldsBI bi}}
storeXFieldsTest _ _ = Nothing
validateTestSuite :: LineNo -> TestSuiteStanza -> ParseResult TestSuite
@@ -340,7 +349,7 @@ storeXFieldsBenchmark :: UnrecFieldParser BenchmarkStanza
storeXFieldsBenchmark (f@('x':'-':_), val)
t@(BenchmarkStanza { benchmarkStanzaBuildInfo = bi }) =
Just $ t {benchmarkStanzaBuildInfo =
- bi{ customFieldsBI = (f,val):(customFieldsBI bi)}}
+ bi{ customFieldsBI = (f,val):customFieldsBI bi}}
storeXFieldsBenchmark _ _ = Nothing
validateBenchmark :: LineNo -> BenchmarkStanza -> ParseResult Benchmark
@@ -463,7 +472,7 @@ binfoFieldDescrs =
]
storeXFieldsBI :: UnrecFieldParser BuildInfo
-storeXFieldsBI (f@('x':'-':_),val) bi = Just bi{ customFieldsBI = (f,val):(customFieldsBI bi) }
+storeXFieldsBI (f@('x':'-':_),val) bi = Just bi{ customFieldsBI = (f,val):customFieldsBI bi }
storeXFieldsBI _ _ = Nothing
------------------------------------------------------------------------------
@@ -514,7 +523,8 @@ readAndParseFile :: (FilePath -> (String -> IO a) -> IO a)
-> FilePath -> IO a
readAndParseFile withFileContents' parser verbosity fpath = do
exists <- doesFileExist fpath
- when (not exists) (die $ "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue.")
+ unless exists
+ (die $ "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue.")
withFileContents' fpath $ \str -> case parser str of
ParseFailed e -> do
let (line, message) = locatedErrorMsg e
@@ -547,9 +557,9 @@ isStanzaHeader _ = False
mapSimpleFields :: (Field -> ParseResult Field) -> [Field]
-> ParseResult [Field]
-mapSimpleFields f fs = mapM walk fs
+mapSimpleFields f = mapM walk
where
- walk fld@(F _ _ _) = f fld
+ walk fld@F{} = f fld
walk (IfBlock l c fs1 fs2) = do
fs1' <- mapM walk fs1
fs2' <- mapM walk fs2
@@ -572,7 +582,7 @@ constraintFieldNames = ["build-depends"]
parseConstraint :: Field -> ParseResult [Dependency]
parseConstraint (F l n v)
| n == "build-depends" = runP l n (parseCommaList parse) v
-parseConstraint f = bug $ "Constraint was expected (got: " ++ show f ++ ")"
+parseConstraint f = userBug $ "Constraint was expected (got: " ++ show f ++ ")"
{-
headerFieldNames :: [String]
@@ -596,6 +606,13 @@ buildInfoNames = map fieldName binfoFieldDescrs
-- on the 'mtl' package.
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
+
+instance (Monad m, Functor m) => Applicative (StT s m) where
+ pure = return
+ (<*>) = ap
+
instance Monad m => Monad (StT s m) where
return a = StT (\s -> return (a,s))
StT f >>= g = StT $ \s -> do
@@ -612,7 +629,7 @@ lift :: Monad m => m a -> StT s m a
lift m = StT $ \s -> m >>= \a -> return (a,s)
evalStT :: Monad m => StT s m a -> s -> m a
-evalStT st s = runStT st s >>= return . fst
+evalStT st s = liftM fst $ runStT st s
-- Our monad for parsing a list/tree of fields.
--
@@ -623,7 +640,7 @@ type PM a = StT [Field] ParseResult a
-- return look-ahead field or nothing if we're at the end of the file
peekField :: PM (Maybe Field)
-peekField = get >>= return . listToMaybe
+peekField = liftM listToMaybe get
-- Unconditionally discard the first field in our state. Will error when it
-- reaches end of file. (Yes, that's evil.)
@@ -711,7 +728,7 @@ parsePackageDescription file = do
flags mlib exes tests bms
where
- oldSyntax flds = all isSimpleField flds
+ oldSyntax = all isSimpleField
reportTabsError tabs =
syntaxError (fst (head tabs)) $
"Do not use tabs for indentation (use spaces instead)\n"
@@ -781,7 +798,7 @@ parsePackageDescription file = do
| e == "executable" =
let (efs, r') = break ((=="executable") . fName) r
in Just (Section l "executable" n (deps ++ efs), r')
- toExe _ = bug "unexpeced input to 'toExe'"
+ toExe _ = cabalBug "unexpected input to 'toExe'"
in
hdr ++
(if null libfs then []
@@ -789,7 +806,7 @@ parsePackageDescription file = do
++ exes
| otherwise = fs
- isSimpleField (F _ _ _) = True
+ isSimpleField F{} = True
isSimpleField _ = False
-- warn if there's something at the end of the file
@@ -804,7 +821,7 @@ parsePackageDescription file = do
-- fields
getHeader :: [Field] -> PM [Field]
getHeader acc = peekField >>= \mf -> case mf of
- Just f@(F _ _ _) -> skipField >> getHeader (f:acc)
+ Just f@F{} -> skipField >> getHeader (f:acc)
_ -> return (reverse acc)
--
@@ -863,7 +880,7 @@ parsePackageDescription file = do
-- only one need one to specify a type because the
-- configure step uses 'mappend' to join together the
-- results of flag resolution.
- in hasTestType || (any checkComponent components)
+ in hasTestType || any checkComponent components
if checkTestType emptyTestSuite flds
then do
skipField
@@ -911,7 +928,7 @@ parsePackageDescription file = do
-- only one need one to specify a type because the
-- configure step uses 'mappend' to join together the
-- results of flag resolution.
- in hasBenchmarkType || (any checkComponent components)
+ in hasBenchmarkType || any checkComponent components
if checkBenchmarkType emptyBenchmark flds
then do
skipField
@@ -925,7 +942,7 @@ parsePackageDescription file = do
++ intercalate ", " (map display knownBenchmarkTypes)
| sec_type == "library" -> do
- when (not (null sec_label)) $ lift $
+ unless (null sec_label) $ lift $
syntaxError line_no "'library' expects no argument"
flds <- collectFields parseLibFields sec_fields
skipField
@@ -957,7 +974,7 @@ parsePackageDescription file = do
repo <- lift $ parseFields
sourceRepoFieldDescrs
warnUnrec
- (SourceRepo {
+ SourceRepo {
repoKind = kind,
repoType = Nothing,
repoLocation = Nothing,
@@ -965,7 +982,7 @@ parsePackageDescription file = do
repoBranch = Nothing,
repoTag = Nothing,
repoSubdir = Nothing
- })
+ }
sec_fields
skipField
(repos, flags, lib, exes, tests, bms) <- getBody
@@ -975,9 +992,14 @@ parsePackageDescription file = do
lift $ warning $ "Ignoring unknown section type: " ++ sec_type
skipField
getBody
- Just f -> do
+ Just f@(F {}) -> do
_ <- lift $ syntaxError (lineNo f) $
- "Construct not supported at this position: " ++ show f
+ "Plain fields are not allowed in between stanzas: " ++ show f
+ skipField
+ getBody
+ Just f@(IfBlock {}) -> do
+ _ <- lift $ syntaxError (lineNo f) $
+ "If-blocks are not allowed in between stanzas: " ++ show f
skipField
getBody
Nothing -> return ([], [], Nothing, [], [], [])
@@ -991,7 +1013,7 @@ parsePackageDescription file = do
collectFields parser allflds = do
let simplFlds = [ F l n v | F l n v <- allflds ]
- condFlds = [ f | f@(IfBlock _ _ _ _) <- allflds ]
+ condFlds = [ f | f@IfBlock{} <- allflds ]
let (depFlds, dataFlds) = partition isConstraint simplFlds
@@ -1013,14 +1035,15 @@ parsePackageDescription file = do
es -> do fs <- collectFields parser es
return (Just fs)
return (cnd, t', e')
- processIfs _ = bug "processIfs called with wrong field type"
+ processIfs _ = cabalBug "processIfs called with wrong field type"
parseLibFields :: [Field] -> PM Library
parseLibFields = lift . parseFields libFieldDescrs storeXFieldsLib emptyLibrary
-- Note: we don't parse the "executable" field here, hence the tail hack.
parseExeFields :: [Field] -> PM Executable
- parseExeFields = lift . parseFields (tail executableFieldDescrs) storeXFieldsExe emptyExecutable
+ parseExeFields = lift . parseFields (tail executableFieldDescrs)
+ storeXFieldsExe emptyExecutable
parseTestFields :: LineNo -> [Field] -> PM TestSuite
parseTestFields line fields = do
@@ -1049,7 +1072,7 @@ parsePackageDescription file = do
checkCondTreeFlags :: [FlagName] -> CondTree ConfVar c a -> PM ()
checkCondTreeFlags definedFlags ct = do
let fv = nub $ freeVars ct
- when (not . all (`elem` definedFlags) $ fv) $
+ unless (all (`elem` definedFlags) fv) $
fail $ "These flags are used without having been defined: "
++ intercalate ", " [ n | FlagName n <- fv \\ definedFlags ]
@@ -1067,14 +1090,13 @@ parseFields :: [FieldDescr a] -- ^ descriptions of fields we know how to
-> ParseResult a
parseFields descrs unrec ini fields =
do (a, unknowns) <- foldM (parseField descrs unrec) (ini, []) fields
- when (not (null unknowns)) $ do
- warning $ render $
- text "Unknown fields:" <+>
- commaSep (map (\(l,u) -> u ++ " (line " ++ show l ++ ")")
- (reverse unknowns))
- $+$
- text "Fields allowed in this section:" $$
- nest 4 (commaSep $ map fieldName descrs)
+ unless (null unknowns) $ warning $ render $
+ text "Unknown fields:" <+>
+ commaSep (map (\(l,u) -> u ++ " (line " ++ show l ++ ")")
+ (reverse unknowns))
+ $+$
+ text "Fields allowed in this section:" $$
+ nest 4 (commaSep $ map fieldName descrs)
return a
where
commaSep = fsep . punctuate comma . map text
@@ -1085,14 +1107,14 @@ parseField :: [FieldDescr a] -- ^ list of parseable fields
-> (a,[(Int,String)]) -- ^ accumulated result and warnings
-> Field -- ^ the field to be parsed
-> ParseResult (a, [(Int,String)])
-parseField ((FieldDescr name _ parser):fields) unrec (a, us) (F line f val)
+parseField (FieldDescr name _ parser : fields) unrec (a, us) (F line f val)
| name == f = parser line val a >>= \a' -> return (a',us)
| otherwise = parseField fields unrec (a,us) (F line f val)
parseField [] unrec (a,us) (F l f val) = return $
case unrec (f,val) a of -- no fields matched, see if the 'unrec'
Just a' -> (a',us) -- function wants to do anything with it
- Nothing -> (a, ((l,f):us))
-parseField _ _ _ _ = bug "'parseField' called on a non-field"
+ Nothing -> (a, (l,f):us)
+parseField _ _ _ _ = cabalBug "'parseField' called on a non-field"
deprecatedFields :: [(String,String)]
deprecatedFields =
@@ -1114,7 +1136,7 @@ deprecField (F line fld val) = do
++ "\" is deprecated, please use \"" ++ newName ++ "\""
return newName
return (F line fld' val)
-deprecField _ = bug "'deprecField' called on a non-field"
+deprecField _ = cabalBug "'deprecField' called on a non-field"
parseHookedBuildInfo :: String -> ParseResult HookedBuildInfo
@@ -1126,17 +1148,17 @@ parseHookedBuildInfo inp = do
return (mLib, biExes)
where
parseLib :: [Field] -> ParseResult (Maybe BuildInfo)
- parseLib (bi@((F _ inFieldName _):_))
+ parseLib (bi@(F _ inFieldName _:_))
| lowercase inFieldName /= "executable" = liftM Just (parseBI bi)
parseLib _ = return Nothing
parseExe :: [Field] -> ParseResult (String, BuildInfo)
- parseExe ((F line inFieldName mName):bi)
+ parseExe (F line inFieldName mName:bi)
| lowercase inFieldName == "executable"
= do bis <- parseBI bi
return (mName, bis)
| otherwise = syntaxError line "expecting 'executable' at top of stanza"
- parseExe (_:_) = bug "`parseExe' called on a non-field"
+ parseExe (_:_) = cabalBug "`parseExe' called on a non-field"
parseExe [] = syntaxError 0 "error in parsing buildinfo file. Expected executable stanza"
parseBI st = parseFields binfoFieldDescrs storeXFieldsBI emptyBuildInfo st
@@ -1200,6 +1222,3 @@ findIndentTabs = concatMap checkLine
--test_findIndentTabs = findIndentTabs $ unlines $
-- [ "foo", " bar", " \t baz", "\t biz\t", "\t\t \t mib" ]
-
-bug :: String -> a
-bug msg = error $ msg ++ ". Consider this a bug."
diff --git a/cabal/Cabal/Distribution/PackageDescription/PrettyPrint.hs b/cabal/Cabal/Distribution/PackageDescription/PrettyPrint.hs
index b4b8d1d..281d515 100644
--- a/cabal/Cabal/Distribution/PackageDescription/PrettyPrint.hs
+++ b/cabal/Cabal/Distribution/PackageDescription/PrettyPrint.hs
@@ -46,8 +46,10 @@ module Distribution.PackageDescription.PrettyPrint (
showGenericPackageDescription,
) where
+import Data.Monoid (Monoid(mempty))
import Distribution.PackageDescription
- ( TestSuite(..), TestSuiteInterface(..), testType
+ ( Benchmark(..), BenchmarkInterface(..), benchmarkType
+ , TestSuite(..), TestSuiteInterface(..), testType
, SourceRepo(..),
customFieldsBI, CondTree(..), Condition(..),
FlagName(..), ConfVar(..), Executable(..), Library(..),
@@ -86,6 +88,7 @@ ppGenericPackageDescription gpd =
$+$ ppLibrary (condLibrary gpd)
$+$ ppExecutables (condExecutables gpd)
$+$ ppTestSuites (condTestSuites gpd)
+ $+$ ppBenchmarks (condBenchmarks gpd)
ppPackageDescription :: PackageDescription -> Doc
ppPackageDescription pd = ppFields pkgDescrFieldDescrs pd
@@ -169,13 +172,17 @@ ppTestSuites suites =
| (n,condTree) <- suites]
where
ppTestSuite testsuite Nothing =
- text "type:" <+> disp (testType testsuite)
+ maybe empty (\t -> text "type:" <+> disp t)
+ maybeTestType
$+$ maybe empty (\f -> text "main-is:" <+> text f)
(testSuiteMainIs testsuite)
$+$ maybe empty (\m -> text "test-module:" <+> disp m)
(testSuiteModule testsuite)
$+$ ppFields binfoFieldDescrs (testBuildInfo testsuite)
$+$ ppCustomFields (customFieldsBI (testBuildInfo testsuite))
+ where
+ maybeTestType | testInterface testsuite == mempty = Nothing
+ | otherwise = Just (testType testsuite)
ppTestSuite (TestSuite _ _ buildInfo' _)
(Just (TestSuite _ _ buildInfo2 _)) =
@@ -190,6 +197,32 @@ ppTestSuites suites =
TestSuiteLibV09 _ m -> Just m
_ -> Nothing
+ppBenchmarks :: [(String, CondTree ConfVar [Dependency] Benchmark)] -> Doc
+ppBenchmarks suites =
+ emptyLine $ vcat [ text ("benchmark " ++ n)
+ $+$ nest indentWith (ppCondTree condTree Nothing ppBenchmark)
+ | (n,condTree) <- suites]
+ where
+ ppBenchmark benchmark Nothing =
+ maybe empty (\t -> text "type:" <+> disp t)
+ maybeBenchmarkType
+ $+$ maybe empty (\f -> text "main-is:" <+> text f)
+ (benchmarkMainIs benchmark)
+ $+$ ppFields binfoFieldDescrs (benchmarkBuildInfo benchmark)
+ $+$ ppCustomFields (customFieldsBI (benchmarkBuildInfo benchmark))
+ where
+ maybeBenchmarkType | benchmarkInterface benchmark == mempty = Nothing
+ | otherwise = Just (benchmarkType benchmark)
+
+ ppBenchmark (Benchmark _ _ buildInfo' _)
+ (Just (Benchmark _ _ buildInfo2 _)) =
+ ppDiffFields binfoFieldDescrs buildInfo' buildInfo2
+ $+$ ppCustomFields (customFieldsBI buildInfo')
+
+ benchmarkMainIs benchmark = case benchmarkInterface benchmark of
+ BenchmarkExeV10 _ f -> Just f
+ _ -> Nothing
+
ppCondition :: Condition ConfVar -> Doc
ppCondition (Var x) = ppConfVar x
ppCondition (Lit b) = text (show b)
diff --git a/cabal/Cabal/Distribution/PackageDescription/Utils.hs b/cabal/Cabal/Distribution/PackageDescription/Utils.hs
new file mode 100644
index 0000000..d814c87
--- /dev/null
+++ b/cabal/Cabal/Distribution/PackageDescription/Utils.hs
@@ -0,0 +1,23 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.PackageDescription.Utils
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Portability : portable
+--
+-- Common utils used by modules under Distribution.PackageDescription.*.
+
+module Distribution.PackageDescription.Utils (
+ cabalBug, userBug
+ ) where
+
+-- ----------------------------------------------------------------------------
+-- Exception and logging utils
+
+userBug :: String -> a
+userBug msg = error $ msg ++ ". This is a bug in your .cabal file."
+
+cabalBug :: String -> a
+cabalBug msg = error $ msg ++ ". This is possibly a bug in Cabal.\n"
+ ++ "Please report it to the developers: "
+ ++ "https://github.com/haskell/cabal/issues/new"
diff --git a/cabal/Cabal/Distribution/ParseUtils.hs b/cabal/Cabal/Distribution/ParseUtils.hs
index d390458..2f2bc84 100644
--- a/cabal/Cabal/Distribution/ParseUtils.hs
+++ b/cabal/Cabal/Distribution/ParseUtils.hs
@@ -47,13 +47,14 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
-- This module is meant to be local-only to Distribution...
--- #hide
+{-# OPTIONS_HADDOCK hide #-}
module Distribution.ParseUtils (
LineNo, PError(..), PWarning(..), locatedErrorMsg, syntaxError, warning,
runP, runE, ParseResult(..), catchParseError, parseFail, showPWarning,
Field(..), fName, lineNo,
FieldDescr(..), ppField, ppFields, readFields, readFieldsFlat,
- showFields, showSingleNamedField, parseFields, parseFieldsFlat,
+ showFields, showSingleNamedField, showSimpleSingleNamedField,
+ parseFields, parseFieldsFlat,
parseFilePathQ, parseTokenQ, parseTokenQ',
parseModuleNameQ, parseBuildTool, parsePkgconfigDependency,
parseOptVersion, parsePackageNameQ, parseVersionRangeQ,
@@ -86,7 +87,8 @@ import Data.Char (isSpace, toLower, isAlphaNum, isDigit)
import Data.Maybe (fromMaybe)
import Data.Tree as Tree (Tree(..), flatten)
import qualified Data.Map as Map
-import Control.Monad (foldM)
+import Control.Monad (foldM, ap)
+import Control.Applicative (Applicative(..))
import System.FilePath (normalise)
import Data.List (sortBy)
@@ -94,15 +96,15 @@ import Data.List (sortBy)
type LineNo = Int
-data PError = AmbigousParse String LineNo
+data PError = AmbiguousParse String LineNo
| NoParse String LineNo
| TabsError LineNo
| FromString String (Maybe LineNo)
- deriving Show
+ deriving (Eq, Show)
data PWarning = PWarning String
| UTFWarning LineNo String
- deriving Show
+ deriving (Eq, Show)
showPWarning :: FilePath -> PWarning -> String
showPWarning fpath (PWarning msg) =
@@ -114,8 +116,17 @@ showPWarning fpath (UTFWarning line fname) =
data ParseResult a = ParseFailed PError | ParseOk [PWarning] a
deriving Show
+instance Functor ParseResult where
+ fmap _ (ParseFailed err) = ParseFailed err
+ fmap f (ParseOk ws x) = ParseOk ws $ f x
+
+instance Applicative ParseResult where
+ pure = return
+ (<*>) = ap
+
+
instance Monad ParseResult where
- return x = ParseOk [] x
+ return = ParseOk []
ParseFailed err >>= _ = ParseFailed err
ParseOk ws x >>= f = case f x of
ParseFailed err -> ParseFailed err
@@ -139,8 +150,8 @@ runP line fieldname p s =
[] -> case [ x | (x,ys) <- results, all isSpace ys ] of
[a] -> ParseOk (utf8Warnings line fieldname s) a
[] -> ParseFailed (NoParse fieldname line)
- _ -> ParseFailed (AmbigousParse fieldname line)
- _ -> ParseFailed (AmbigousParse fieldname line)
+ _ -> ParseFailed (AmbiguousParse fieldname line)
+ _ -> ParseFailed (AmbiguousParse fieldname line)
where results = readP_to_S p s
runE :: LineNo -> String -> ReadE a -> String -> ParseResult a
@@ -157,10 +168,12 @@ utf8Warnings line fieldname s =
, '\xfffd' `elem` l ]
locatedErrorMsg :: PError -> (Maybe LineNo, String)
-locatedErrorMsg (AmbigousParse f n) = (Just n, "Ambiguous parse in field '"++f++"'.")
-locatedErrorMsg (NoParse f n) = (Just n, "Parse of field '"++f++"' failed.")
-locatedErrorMsg (TabsError n) = (Just n, "Tab used as indentation.")
-locatedErrorMsg (FromString s n) = (n, s)
+locatedErrorMsg (AmbiguousParse f n) = (Just n,
+ "Ambiguous parse in field '"++f++"'.")
+locatedErrorMsg (NoParse f n) = (Just n,
+ "Parse of field '"++f++"' failed.")
+locatedErrorMsg (TabsError n) = (Just n, "Tab used as indentation.")
+locatedErrorMsg (FromString s n) = (n, s)
syntaxError :: LineNo -> String -> ParseResult a
syntaxError n s = ParseFailed $ FromString s (Just n)
@@ -183,7 +196,7 @@ data FieldDescr a
-- successful. Otherwise, reports an error on line number @n@.
}
-field :: String -> (a -> Doc) -> (ReadP a a) -> FieldDescr a
+field :: String -> (a -> Doc) -> ReadP a a -> FieldDescr a
field name showF readF =
FieldDescr name showF (\line val _st -> runP line name readF val)
@@ -191,7 +204,7 @@ field name showF readF =
-- into a 'b'.
liftField :: (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
liftField get set (FieldDescr name showF parseF)
- = FieldDescr name (\b -> showF (get b))
+ = FieldDescr name (showF . get)
(\line str b -> do
a <- parseF line str (get b)
return (set a b))
@@ -199,12 +212,12 @@ liftField get set (FieldDescr name showF parseF)
-- Parser combinator for simple fields. Takes a field name, a pretty printer,
-- a parser function, an accessor, and a setter, returns a FieldDescr over the
-- compoid structure.
-simpleField :: String -> (a -> Doc) -> (ReadP a a)
+simpleField :: String -> (a -> Doc) -> ReadP a a
-> (b -> a) -> (a -> b -> b) -> FieldDescr b
simpleField name showF readF get set
= liftField get set $ field name showF readF
-commaListField :: String -> (a -> Doc) -> (ReadP [a] a)
+commaListField :: String -> (a -> Doc) -> ReadP [a] a
-> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
commaListField name showF readF get set =
liftField get set' $
@@ -212,7 +225,7 @@ commaListField name showF readF get set =
where
set' xs b = set (get b ++ xs) b
-spaceListField :: String -> (a -> Doc) -> (ReadP [a] a)
+spaceListField :: String -> (a -> Doc) -> ReadP [a] a
-> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
spaceListField name showF readF get set =
liftField get set' $
@@ -220,7 +233,7 @@ spaceListField name showF readF get set =
where
set' xs b = set (get b ++ xs) b
-listField :: String -> (a -> Doc) -> (ReadP [a] a)
+listField :: String -> (a -> Doc) -> ReadP [a] a
-> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
listField name showF readF get set =
liftField get set' $
@@ -228,7 +241,8 @@ listField name showF readF get set =
where
set' xs b = set (get b ++ xs) b
-optsField :: String -> CompilerFlavor -> (b -> [(CompilerFlavor,[String])]) -> ([(CompilerFlavor,[String])] -> b -> b) -> FieldDescr b
+optsField :: String -> CompilerFlavor -> (b -> [(CompilerFlavor,[String])])
+ -> ([(CompilerFlavor,[String])] -> b -> b) -> FieldDescr b
optsField name flavor get set =
liftField (fromMaybe [] . lookup flavor . get)
(\opts b -> set (reorder (update flavor opts (get b))) b) $
@@ -244,7 +258,7 @@ optsField name flavor get set =
-- TODO: this is a bit smelly hack. It's because we want to parse bool fields
-- liberally but not accept new parses. We cannot do that with ReadP
--- because it does not support warnings. We need a new parser framwork!
+-- because it does not support warnings. We need a new parser framework!
boolField :: String -> (b -> Bool) -> (Bool -> b -> b) -> FieldDescr b
boolField name get set = liftField get set (FieldDescr name showF readF)
where
@@ -276,12 +290,19 @@ showSingleNamedField fields f =
[] -> Nothing
(get:_) -> Just (render . ppField f . get)
+showSimpleSingleNamedField :: [FieldDescr a] -> String -> Maybe (a -> String)
+showSimpleSingleNamedField fields f =
+ case [ get | (FieldDescr f' get _) <- fields, f' == f ] of
+ [] -> Nothing
+ (get:_) -> Just (renderStyle myStyle . get)
+ where myStyle = style { mode = LeftMode }
+
parseFields :: [FieldDescr a] -> a -> String -> ParseResult a
-parseFields fields initial = \str ->
+parseFields fields initial str =
readFields str >>= accumFields fields initial
parseFieldsFlat :: [FieldDescr a] -> a -> String -> ParseResult a
-parseFieldsFlat fields initial = \str ->
+parseFieldsFlat fields initial str =
readFieldsFlat str >>= accumFields fields initial
accumFields :: [FieldDescr a] -> a -> [Field] -> ParseResult a
@@ -314,7 +335,7 @@ warnUnrec _ _ = Nothing
-- warnings will be generated) ignores unrecognized fields, by
-- returning the structure being built unmodified.
ignoreUnrec :: UnrecFieldParser a
-ignoreUnrec _ x = Just x
+ignoreUnrec _ = Just
------------------------------------------------------------------------------
@@ -370,7 +391,7 @@ readFieldsFlat input = mapM (mkField 0)
-- attach line number and determine indentation
trimLines :: [String] -> [(LineNo, Indent, HasTabs, String)]
-trimLines ls = [ (lineno, indent, hastabs, (trimTrailing l'))
+trimLines ls = [ (lineno, indent, hastabs, trimTrailing l')
| (lineno, l) <- zip [1..] ls
, let (sps, l') = span isSpace l
indent = length sps
@@ -492,7 +513,7 @@ layout i a (Line n i' t l:ss) = do
([], _) -> layout i (Node (n,t,l) [] :a) ss
(ts, ss') -> layout i (Node (n,t,l) ts :a) ss'
-layout _ _ ( OpenBracket n :_) = syntaxError n $ "unexpected '{'"
+layout _ _ ( OpenBracket n :_) = syntaxError n "unexpected '{'"
layout _ a (s@(CloseBracket _):ss) = return (reverse a, s:ss)
layout _ _ ( Span n l : _) = syntaxError n $ "unexpected span: "
++ show l
@@ -567,7 +588,8 @@ ifelse (Section n "if" cond thenpart:fs)
| otherwise = do tp <- ifelse thenpart
fs' <- ifelse fs
return (IfBlock n cond tp []:fs')
-ifelse (Section n "else" _ _:_) = syntaxError n "stray 'else' with no preceding 'if'"
+ifelse (Section n "else" _ _:_) = syntaxError n
+ "stray 'else' with no preceding 'if'"
ifelse (Section n s a fs':fs) = do fs'' <- ifelse fs'
fs''' <- ifelse fs
return (Section n s a fs'' : fs''')
@@ -585,11 +607,16 @@ parseFilePathQ = parseTokenQ
-- removed until normalise is no longer broken, was:
-- liftM normalise parseTokenQ
+betweenSpaces :: ReadP r a -> ReadP r a
+betweenSpaces act = do skipSpaces
+ res <- act
+ skipSpaces
+ return res
+
parseBuildTool :: ReadP r Dependency
parseBuildTool = do name <- parseBuildToolNameQ
- skipSpaces
- ver <- parseVersionRangeQ <++ return anyVersion
- skipSpaces
+ ver <- betweenSpaces $
+ parseVersionRangeQ <++ return anyVersion
return $ Dependency name ver
parseBuildToolNameQ :: ReadP r PackageName
@@ -607,10 +634,10 @@ parseBuildToolName = do ns <- sepBy1 component (ReadP.char '-')
-- eg "gtk+-2.0" is a valid pkg-config package _name_.
-- It then has a package version number like 2.10.13
parsePkgconfigDependency :: ReadP r Dependency
-parsePkgconfigDependency = do name <- munch1 (\c -> isAlphaNum c || c `elem` "+-._")
- skipSpaces
- ver <- parseVersionRangeQ <++ return anyVersion
- skipSpaces
+parsePkgconfigDependency = do name <- munch1
+ (\c -> isAlphaNum c || c `elem` "+-._")
+ ver <- betweenSpaces $
+ parseVersionRangeQ <++ return anyVersion
return $ Dependency (PackageName name) ver
parsePackageNameQ :: ReadP r PackageName
@@ -630,9 +657,7 @@ parseTestedWithQ = parseQuoted tw <++ tw
where
tw :: ReadP r (CompilerFlavor,VersionRange)
tw = do compiler <- parseCompilerFlavorCompat
- skipSpaces
- version <- parse <++ return anyVersion
- skipSpaces
+ version <- betweenSpaces $ parse <++ return anyVersion
return (compiler,version)
parseLicenseQ :: ReadP r License
@@ -656,13 +681,13 @@ parseTokenQ :: ReadP r String
parseTokenQ = parseHaskellString <++ munch1 (\x -> not (isSpace x) && x /= ',')
parseTokenQ' :: ReadP r String
-parseTokenQ' = parseHaskellString <++ munch1 (\x -> not (isSpace x))
+parseTokenQ' = parseHaskellString <++ munch1 (not . isSpace)
parseSepList :: ReadP r b
-> ReadP r a -- ^The parser for the stuff between commas
-> ReadP r [a]
parseSepList sepr p = sepBy p separator
- where separator = skipSpaces >> sepr >> skipSpaces
+ where separator = betweenSpaces sepr
parseSpaceList :: ReadP r a -- ^The parser for the stuff between commas
-> ReadP r [a]
@@ -677,7 +702,7 @@ parseOptCommaList :: ReadP r a -- ^The parser for the stuff between commas
parseOptCommaList = parseSepList (optional (ReadP.char ','))
parseQuoted :: ReadP r a -> ReadP r a
-parseQuoted p = between (ReadP.char '"') (ReadP.char '"') p
+parseQuoted = between (ReadP.char '"') (ReadP.char '"')
parseFreeText :: ReadP.ReadP s String
parseFreeText = ReadP.munch (const True)
diff --git a/cabal/Cabal/Distribution/ReadE.hs b/cabal/Cabal/Distribution/ReadE.hs
index ce165e2..07b2568 100644
--- a/cabal/Cabal/Distribution/ReadE.hs
+++ b/cabal/Cabal/Distribution/ReadE.hs
@@ -63,14 +63,14 @@ succeedReadE :: (String -> a) -> ReadE a
succeedReadE f = ReadE (Right . f)
failReadE :: ErrorMsg -> ReadE a
-failReadE = ReadE . const Left
+failReadE = ReadE . const . Left
parseReadE :: ReadE a -> ReadP r a
parseReadE (ReadE p) = do
txt <- look
either fail return (p txt)
-readEOrFail :: ReadE a -> (String -> a)
+readEOrFail :: ReadE a -> String -> a
readEOrFail r = either error id . runReadE r
readP_to_E :: (String -> ErrorMsg) -> ReadP a a -> ReadE a
diff --git a/cabal/Cabal/Distribution/Simple.hs b/cabal/Cabal/Distribution/Simple.hs
index fef0523..9d8a65b 100644
--- a/cabal/Cabal/Distribution/Simple.hs
+++ b/cabal/Cabal/Distribution/Simple.hs
@@ -101,7 +101,7 @@ import Distribution.Simple.PreProcess (knownSuffixHandlers, PPSuffixHandler)
import Distribution.Simple.Setup
import Distribution.Simple.Command
-import Distribution.Simple.Build ( build )
+import Distribution.Simple.Build ( build, repl )
import Distribution.Simple.SrcDist ( sdist )
import Distribution.Simple.Register
( register, unregister )
@@ -131,15 +131,17 @@ import Distribution.Text
( display )
-- Base
-import System.Environment(getArgs, getProgName, getEnvironment)
+import System.Environment(getArgs, getProgName)
import System.Directory(removeFile, doesFileExist,
doesDirectoryExist, removeDirectoryRecursive)
import System.Exit
import System.IO.Error (isDoesNotExistError)
-import Distribution.Compat.Exception (catchIO, throwIOIO)
+import Control.Exception (throwIO)
+import Distribution.Compat.Environment (getEnvironment)
+import Distribution.Compat.Exception (catchIO)
import Control.Monad (when)
-import Data.List (intersperse, unionBy, nub, (\\))
+import Data.List (intercalate, unionBy, nub, (\\))
-- | A simple implementation of @main@ for a Cabal setup script.
-- It reads the package description file using IO, and performs the
@@ -187,7 +189,7 @@ defaultMainHelper hooks args = topHandler $
printHelp help = getProgName >>= putStr . help
printOptionsList = putStr . unlines
printErrors errs = do
- putStr (concat (intersperse "\n" errs))
+ putStr (intercalate "\n" errs)
exitWith (ExitFailure 1)
printNumericVersion = putStrLn $ display cabalVersion
printVersion = putStrLn $ "Cabal library version "
@@ -198,6 +200,7 @@ defaultMainHelper hooks args = topHandler $
[configureCommand progs `commandAddAction` \fs as ->
configureAction hooks fs as >> return ()
,buildCommand progs `commandAddAction` buildAction hooks
+ ,replCommand progs `commandAddAction` replAction hooks
,installCommand `commandAddAction` installAction hooks
,copyCommand `commandAddAction` copyAction hooks
,haddockCommand `commandAddAction` haddockAction hooks
@@ -272,7 +275,25 @@ buildAction hooks flags args = do
hookedAction preBuild buildHook postBuild
(return lbi { withPrograms = progs })
- hooks flags 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
+
+ lbi <- getBuildConfig hooks verbosity distPref
+ progs <- reconfigurePrograms verbosity
+ (replProgramPaths flags)
+ (replProgramArgs flags)
+ (withPrograms lbi)
+
+ 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'
hscolourAction :: UserHooks -> HscolourFlags -> Args -> IO ()
hscolourAction hooks flags args
@@ -455,7 +476,7 @@ getBuildConfig hooks verbosity distPref = do
reconfigure :: FilePath -> LocalBuildInfo -> IO LocalBuildInfo
reconfigure pkg_descr_file lbi = do
notice verbosity $ pkg_descr_file ++ " has been changed. "
- ++ "Re-configuring with most recently used options. "
+ ++ "Re-configuring with most recently used options. "
++ "If this fails, please run configure manually.\n"
let cFlags = configFlags lbi
let cFlags' = cFlags {
@@ -502,8 +523,7 @@ clean pkg_descr flags = do
isDir <- doesDirectoryExist fname
isFile <- doesFileExist fname
if isDir then removeDirectoryRecursive fname
- else if isFile then removeFile fname
- else return ()
+ else when isFile $ removeFile fname
verbosity = fromFlag (cleanVerbosity flags)
-- --------------------------------------------------------------------------
@@ -517,6 +537,7 @@ simpleUserHooks =
confHook = configure,
postConf = finalChecks,
buildHook = defaultBuildHook,
+ replHook = defaultReplHook,
copyHook = \desc lbi _ f -> install desc lbi f, -- has correct 'copy' behavior with params
testHook = defaultTestHook,
benchHook = defaultBenchHook,
@@ -551,14 +572,14 @@ defaultUserHooks :: UserHooks
defaultUserHooks = autoconfUserHooks {
confHook = \pkg flags -> do
let verbosity = fromFlag (configVerbosity flags)
- warn verbosity $
+ warn verbosity
"defaultUserHooks in Setup script is deprecated."
confHook autoconfUserHooks pkg flags,
postConf = oldCompatPostConf
}
-- This is the annoying old version that only runs configure if it exists.
-- It's here for compatibility with existing Setup.hs scripts. See:
- -- http://hackage.haskell.org/trac/hackage/ticket/165
+ -- https://github.com/haskell/cabal/issues/158
where oldCompatPostConf args flags pkg_descr lbi
= do let verbosity = fromFlag (configVerbosity flags)
noExtraFlags args
@@ -632,7 +653,7 @@ runConfigureScript verbosity backwardsCompatHack flags lbi = do
rawSystemExitWithEnv verbosity "sh" args' env'
where
- args = "configure" : configureArgs backwardsCompatHack flags
+ args = "./configure" : configureArgs backwardsCompatHack flags
appendToEnvironment (key, val) [] = [(key, val)]
appendToEnvironment (key, val) (kv@(k, v) : rest)
@@ -647,7 +668,7 @@ runConfigureScript verbosity backwardsCompatHack flags lbi = do
= action
`catchIO` \ioe -> if isDoesNotExistError ioe
then die notFoundMsg
- else throwIOIO ioe
+ else throwIO ioe
notFoundMsg = "The package has a './configure' script. This requires a "
++ "Unix compatibility toolchain such as MinGW+MSYS or Cygwin."
@@ -693,6 +714,11 @@ defaultBuildHook :: PackageDescription -> LocalBuildInfo
defaultBuildHook pkg_descr localbuildinfo hooks flags =
build pkg_descr localbuildinfo flags (allSuffixHandlers hooks)
+defaultReplHook :: PackageDescription -> LocalBuildInfo
+ -> UserHooks -> ReplFlags -> [String] -> IO ()
+defaultReplHook pkg_descr localbuildinfo hooks flags args =
+ repl pkg_descr localbuildinfo flags (allSuffixHandlers hooks) args
+
defaultRegHook :: PackageDescription -> LocalBuildInfo
-> UserHooks -> RegisterFlags -> IO ()
defaultRegHook pkg_descr localbuildinfo _ flags =
diff --git a/cabal/Cabal/Distribution/Simple/Bench.hs b/cabal/Cabal/Distribution/Simple/Bench.hs
index f34c888..ad801ff 100644
--- a/cabal/Cabal/Distribution/Simple/Bench.hs
+++ b/cabal/Cabal/Distribution/Simple/Bench.hs
@@ -152,5 +152,6 @@ benchOption pkg_descr lbi bm template =
fromPathTemplate $ substPathTemplate env template
where
env = initialPathTemplateEnv
- (PD.package pkg_descr) (compilerId $ LBI.compiler lbi) ++
+ (PD.package pkg_descr) (compilerId $ 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 6fbcfb1..627848b 100644
--- a/cabal/Cabal/Distribution/Simple/Build.hs
+++ b/cabal/Cabal/Distribution/Simple/Build.hs
@@ -3,7 +3,7 @@
-- Module : Distribution.Simple.Build
-- Copyright : Isaac Jones 2003-2005,
-- Ross Paterson 2006,
--- Duncan Coutts 2007-2008
+-- Duncan Coutts 2007-2008, 2012
--
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
@@ -46,7 +46,8 @@ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
module Distribution.Simple.Build (
- build,
+ build, repl,
+ startInterpreter,
initialBuildSteps,
writeAutogenFiles,
@@ -58,6 +59,7 @@ 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.HaskellSuite as HaskellSuite
import qualified Distribution.Simple.Build.Macros as Build.Macros
import qualified Distribution.Simple.Build.PathsModule as Build.PathsModule
@@ -66,22 +68,30 @@ import Distribution.Package
( Package(..), PackageName(..), PackageIdentifier(..)
, Dependency(..), thisPackageVersion )
import Distribution.Simple.Compiler
- ( CompilerFlavor(..), compilerFlavor, PackageDB(..) )
+ ( Compiler, CompilerFlavor(..), compilerFlavor
+ , PackageDB(..), PackageDBStack )
import Distribution.PackageDescription
( PackageDescription(..), BuildInfo(..), Library(..), Executable(..)
, TestSuite(..), TestSuiteInterface(..), Benchmark(..)
, BenchmarkInterface(..) )
import qualified Distribution.InstalledPackageInfo as IPI
import qualified Distribution.ModuleName as ModuleName
+import Distribution.ModuleName (ModuleName)
import Distribution.Simple.Setup
- ( BuildFlags(..), fromFlag )
+ ( Flag(..), BuildFlags(..), ReplFlags(..), fromFlag )
+import Distribution.Simple.BuildTarget
+ ( BuildTarget(..), readBuildTargets )
import Distribution.Simple.PreProcess
( preprocessComponent, PPSuffixHandler )
import Distribution.Simple.LocalBuildInfo
( LocalBuildInfo(compiler, buildDir, withPackageDB, withPrograms)
- , Component(..), ComponentLocalBuildInfo(..), withComponentsLBI
- , componentBuildInfo, inplacePackageId )
+ , Component(..), componentName, getComponent, componentBuildInfo
+ , ComponentLocalBuildInfo(..), pkgEnabledComponents
+ , withComponentsInBuildOrder, componentsInBuildOrder
+ , ComponentName(..), showComponentName
+ , ComponentDisabledReason(..), componentDisabledReason
+ , inplacePackageId, LibraryName(..) )
import Distribution.Simple.Program.Types
import Distribution.Simple.Program.Db
import Distribution.Simple.BuildPaths
@@ -91,7 +101,7 @@ import Distribution.Simple.Register
import Distribution.Simple.Test ( stubFilePath, stubName )
import Distribution.Simple.Utils
( createDirectoryIfMissingVerbose, rewriteFile
- , die, info, setupMessage )
+ , die, info, debug, warn, setupMessage )
import Distribution.Verbosity
( Verbosity )
@@ -100,10 +110,12 @@ import Distribution.Text
import Data.Maybe
( maybeToList )
+import Data.Either
+ ( partitionEithers )
import Data.List
- ( intersect )
+ ( intersect, intercalate )
import Control.Monad
- ( unless )
+ ( when, unless, forM_ )
import System.FilePath
( (</>), (<.>) )
import System.Directory
@@ -120,22 +132,87 @@ build :: PackageDescription -- ^ Mostly information from the .cabal file
build pkg_descr lbi flags suffixes = do
let distPref = fromFlag (buildDistPref flags)
verbosity = fromFlag (buildVerbosity flags)
+
+ targets <- readBuildTargets pkg_descr (buildArgs flags)
+ targets' <- checkBuildTargets verbosity pkg_descr targets
+ let componentsToBuild = map fst (componentsInBuildOrder lbi (map fst targets'))
+ info verbosity $ "Component build order: "
+ ++ intercalate ", " (map showComponentName componentsToBuild)
+
initialBuildSteps distPref pkg_descr lbi verbosity
- setupMessage verbosity "Building" (packageId pkg_descr)
+ when (null targets) $
+ -- Only bother with this message if we're building the whole package
+ setupMessage verbosity "Building" (packageId pkg_descr)
internalPackageDB <- createInternalPackageDB distPref
- withComponentsLBI pkg_descr lbi $ \comp clbi ->
+ withComponentsInBuildOrder pkg_descr lbi componentsToBuild $ \comp clbi ->
let bi = componentBuildInfo comp
progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi)
lbi' = lbi {
withPrograms = progs',
withPackageDB = withPackageDB lbi ++ [internalPackageDB]
}
- in buildComponent verbosity pkg_descr lbi' suffixes comp clbi distPref
+ in buildComponent verbosity (buildNumJobs flags) pkg_descr
+ lbi' suffixes comp clbi distPref
+
+
+repl :: PackageDescription -- ^ Mostly information from the .cabal file
+ -> LocalBuildInfo -- ^ Configuration information
+ -> ReplFlags -- ^ Flags that the user passed to build
+ -> [ PPSuffixHandler ] -- ^ preprocessors to run before compiling
+ -> [String]
+ -> IO ()
+repl pkg_descr lbi flags suffixes args = do
+ let distPref = fromFlag (replDistPref flags)
+ verbosity = fromFlag (replVerbosity flags)
+
+ targets <- readBuildTargets pkg_descr args
+ targets' <- case targets of
+ [] -> return $ take 1 [ componentName c
+ | c <- pkgEnabledComponents pkg_descr ]
+ [target] -> fmap (map fst) (checkBuildTargets verbosity pkg_descr [target])
+ _ -> die $ "The 'repl' command does not support multiple targets at once."
+ let componentsToBuild = componentsInBuildOrder lbi targets'
+ componentForRepl = last componentsToBuild
+ debug verbosity $ "Component build order: "
+ ++ intercalate ", "
+ [ showComponentName c | (c,_) <- componentsToBuild ]
+
+ initialBuildSteps distPref pkg_descr lbi verbosity
+ internalPackageDB <- createInternalPackageDB distPref
+ let lbiForComponent comp lbi' =
+ lbi' {
+ withPackageDB = withPackageDB lbi ++ [internalPackageDB],
+ withPrograms = addInternalBuildTools pkg_descr lbi'
+ (componentBuildInfo comp) (withPrograms lbi')
+ }
+
+ -- build any dependent components
+ sequence_
+ [ let comp = getComponent pkg_descr cname
+ lbi' = lbiForComponent comp lbi
+ in buildComponent verbosity NoFlag
+ pkg_descr lbi' suffixes comp clbi distPref
+ | (cname, clbi) <- init componentsToBuild ]
+
+ -- repl for target components
+ let (cname, clbi) = componentForRepl
+ comp = getComponent pkg_descr cname
+ lbi' = lbiForComponent comp lbi
+ in replComponent verbosity pkg_descr lbi' suffixes comp clbi distPref
+
+
+-- | Start an interpreter without loading any package files.
+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."
buildComponent :: Verbosity
+ -> Flag (Maybe Int)
-> PackageDescription
-> LocalBuildInfo
-> [PPSuffixHandler]
@@ -143,11 +220,11 @@ buildComponent :: Verbosity
-> ComponentLocalBuildInfo
-> FilePath
-> IO ()
-buildComponent verbosity pkg_descr lbi suffixes
+buildComponent verbosity numJobs pkg_descr lbi suffixes
comp@(CLib lib) clbi distPref = do
preprocessComponent pkg_descr comp lbi False verbosity suffixes
info verbosity "Building library..."
- buildLib verbosity pkg_descr lbi lib clbi
+ buildLib verbosity numJobs pkg_descr lbi lib clbi
-- Register the library in-place, so exes can depend
-- on internally defined libraries.
@@ -163,106 +240,212 @@ buildComponent verbosity pkg_descr lbi suffixes
(withPackageDB lbi)
-buildComponent verbosity pkg_descr lbi suffixes
+buildComponent verbosity numJobs pkg_descr lbi suffixes
comp@(CExe exe) clbi _ = do
preprocessComponent pkg_descr comp lbi False verbosity suffixes
info verbosity $ "Building executable " ++ exeName exe ++ "..."
- buildExe verbosity pkg_descr lbi exe clbi
+ buildExe verbosity numJobs pkg_descr lbi exe clbi
-buildComponent verbosity pkg_descr lbi suffixes
- comp@(CTest
- test@TestSuite { testInterface = TestSuiteExeV10 _ f })
+buildComponent verbosity numJobs pkg_descr lbi suffixes
+ comp@(CTest test@TestSuite { testInterface = TestSuiteExeV10{} })
clbi _distPref = do
- let bi = testBuildInfo test
- exe = Executable {
- exeName = testName test,
- modulePath = f,
- buildInfo = bi
- }
+ let exe = testSuiteExeV10AsExe test
preprocessComponent pkg_descr comp lbi False verbosity suffixes
info verbosity $ "Building test suite " ++ testName test ++ "..."
- buildExe verbosity pkg_descr lbi exe clbi
+ buildExe verbosity numJobs pkg_descr lbi exe clbi
-buildComponent verbosity pkg_descr lbi suffixes
+buildComponent verbosity numJobs pkg_descr lbi suffixes
comp@(CTest
- test@TestSuite { testInterface = TestSuiteLibV09 _ m })
- clbi distPref = do
+ test@TestSuite { testInterface = TestSuiteLibV09{} })
+ clbi -- This ComponentLocalBuildInfo corresponds to a detailed
+ -- test suite and not a real component. It should not
+ -- be used, except to construct the CLBIs for the
+ -- library and stub executable that will actually be
+ -- built.
+ distPref = do
pwd <- getCurrentDirectory
- let bi = testBuildInfo test
- lib = Library {
- exposedModules = [ m ],
- libExposed = True,
- libBuildInfo = bi
- }
- pkg = pkg_descr {
- package = (package pkg_descr) {
- pkgName = PackageName (testName test)
- }
- , buildDepends = targetBuildDepends $ testBuildInfo test
- , executables = []
- , testSuites = []
- , library = Just lib
- }
- ipi = (inplaceInstalledPackageInfo pwd distPref pkg lib lbi clbi) {
- IPI.installedPackageId = inplacePackageId $ packageId ipi
- }
- testDir = buildDir lbi </> stubName test
- </> stubName test ++ "-tmp"
- testLibDep = thisPackageVersion $ package pkg
- exe = Executable {
- exeName = stubName test,
- modulePath = stubFilePath test,
- buildInfo = (testBuildInfo test) {
- hsSourceDirs = [ testDir ],
- targetBuildDepends = testLibDep
- : (targetBuildDepends $ testBuildInfo test)
- }
- }
- -- | The stub executable needs a new 'ComponentLocalBuildInfo'
- -- that exposes the relevant test suite library.
- exeClbi = clbi {
- componentPackageDeps =
- (IPI.installedPackageId ipi, packageId ipi)
- : (filter (\(_, x) -> let PackageName name = pkgName x
- in name == "Cabal" || name == "base")
- (componentPackageDeps clbi))
- }
+ let (pkg, lib, libClbi, ipi, exe, exeClbi) =
+ testSuiteLibV09AsLibAndExe pkg_descr lbi test clbi distPref pwd
preprocessComponent pkg_descr comp lbi False verbosity suffixes
info verbosity $ "Building test suite " ++ testName test ++ "..."
- buildLib verbosity pkg lbi lib clbi
+ buildLib verbosity numJobs pkg lbi lib libClbi
registerPackage verbosity ipi pkg lbi True $ withPackageDB lbi
- buildExe verbosity pkg_descr lbi exe exeClbi
+ buildExe verbosity numJobs pkg_descr lbi exe exeClbi
-buildComponent _ _ _ _
+buildComponent _ _ _ _ _
(CTest TestSuite { testInterface = TestSuiteUnsupported tt })
_ _ =
die $ "No support for building test suite type " ++ display tt
-buildComponent verbosity pkg_descr lbi suffixes
- comp@(CBench
- bm@Benchmark { benchmarkInterface = BenchmarkExeV10 _ f })
+buildComponent verbosity numJobs pkg_descr lbi suffixes
+ comp@(CBench bm@Benchmark { benchmarkInterface = BenchmarkExeV10 {} })
clbi _ = do
- let bi = benchmarkBuildInfo bm
- exe = Executable
- { exeName = benchmarkName bm
- , modulePath = f
- , buildInfo = bi
- }
+ let (exe, exeClbi) = benchmarkExeV10asExe bm clbi
preprocessComponent pkg_descr comp lbi False verbosity suffixes
info verbosity $ "Building benchmark " ++ benchmarkName bm ++ "..."
- buildExe verbosity pkg_descr lbi exe clbi
+ buildExe verbosity numJobs pkg_descr lbi exe exeClbi
-buildComponent _ _ _ _
+buildComponent _ _ _ _ _
(CBench Benchmark { benchmarkInterface = BenchmarkUnsupported tt })
_ _ =
die $ "No support for building benchmark type " ++ display tt
+replComponent :: Verbosity
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> [PPSuffixHandler]
+ -> Component
+ -> ComponentLocalBuildInfo
+ -> FilePath
+ -> IO ()
+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
+
+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
+
+
+replComponent verbosity pkg_descr lbi suffixes
+ comp@(CTest test@TestSuite { testInterface = TestSuiteExeV10{} })
+ clbi _distPref = do
+ let exe = testSuiteExeV10AsExe test
+ preprocessComponent pkg_descr comp lbi False verbosity suffixes
+ replExe verbosity pkg_descr lbi exe clbi
+
+
+replComponent verbosity pkg_descr lbi suffixes
+ comp@(CTest
+ test@TestSuite { testInterface = TestSuiteLibV09{} })
+ clbi distPref = do
+ pwd <- getCurrentDirectory
+ let (pkg, lib, libClbi, _, _, _) =
+ testSuiteLibV09AsLibAndExe pkg_descr lbi test clbi distPref pwd
+ preprocessComponent pkg_descr comp lbi False verbosity suffixes
+ replLib verbosity pkg lbi lib libClbi
+
+
+replComponent _ _ _ _
+ (CTest TestSuite { testInterface = TestSuiteUnsupported tt })
+ _ _ =
+ die $ "No support for building test suite type " ++ display tt
+
+
+replComponent verbosity pkg_descr lbi suffixes
+ comp@(CBench bm@Benchmark { benchmarkInterface = BenchmarkExeV10 {} })
+ clbi _ = do
+ let (exe, exeClbi) = benchmarkExeV10asExe bm clbi
+ preprocessComponent pkg_descr comp lbi False verbosity suffixes
+ replExe verbosity pkg_descr lbi exe exeClbi
+
+
+replComponent _ _ _ _
+ (CBench Benchmark { benchmarkInterface = BenchmarkUnsupported tt })
+ _ _ =
+ die $ "No support for building benchmark type " ++ display tt
+
+----------------------------------------------------
+-- Shared code for buildComponent and replComponent
+--
+
+-- | Translate a exe-style 'TestSuite' component into an exe for building
+testSuiteExeV10AsExe :: TestSuite -> Executable
+testSuiteExeV10AsExe test@TestSuite { testInterface = TestSuiteExeV10 _ mainFile } =
+ Executable {
+ exeName = testName test,
+ modulePath = mainFile,
+ buildInfo = testBuildInfo test
+ }
+testSuiteExeV10AsExe TestSuite{} = error "testSuiteExeV10AsExe: wrong kind"
+
+-- | Translate a lib-style 'TestSuite' component into a lib + exe for building
+testSuiteLibV09AsLibAndExe :: PackageDescription
+ -> LocalBuildInfo
+ -> TestSuite
+ -> ComponentLocalBuildInfo
+ -> FilePath
+ -> FilePath
+ -> (PackageDescription,
+ Library, ComponentLocalBuildInfo,
+ IPI.InstalledPackageInfo_ ModuleName,
+ Executable, ComponentLocalBuildInfo)
+testSuiteLibV09AsLibAndExe pkg_descr lbi
+ test@TestSuite { testInterface = TestSuiteLibV09 _ m }
+ clbi distPref pwd =
+ (pkg, lib, libClbi, ipi, exe, exeClbi)
+ where
+ bi = testBuildInfo test
+ lib = Library {
+ exposedModules = [ m ],
+ libExposed = True,
+ libBuildInfo = bi
+ }
+ libClbi = LibComponentLocalBuildInfo
+ { componentPackageDeps = componentPackageDeps clbi
+ , componentLibraries = [LibraryName (testName test)]
+ }
+ pkg = pkg_descr {
+ package = (package pkg_descr) {
+ pkgName = PackageName (testName test)
+ }
+ , buildDepends = targetBuildDepends $ testBuildInfo test
+ , executables = []
+ , testSuites = []
+ , library = Just lib
+ }
+ ipi = (inplaceInstalledPackageInfo pwd distPref pkg lib lbi libClbi) {
+ IPI.installedPackageId = inplacePackageId $ packageId ipi
+ }
+ testDir = buildDir lbi </> stubName test
+ </> stubName test ++ "-tmp"
+ testLibDep = thisPackageVersion $ package pkg
+ exe = Executable {
+ exeName = stubName test,
+ modulePath = stubFilePath test,
+ buildInfo = (testBuildInfo test) {
+ hsSourceDirs = [ testDir ],
+ targetBuildDepends = testLibDep
+ : (targetBuildDepends $ testBuildInfo test)
+ }
+ }
+ -- | The stub executable needs a new 'ComponentLocalBuildInfo'
+ -- that exposes the relevant test suite library.
+ exeClbi = ExeComponentLocalBuildInfo {
+ componentPackageDeps =
+ (IPI.installedPackageId ipi, packageId ipi)
+ : (filter (\(_, x) -> let PackageName name = pkgName x
+ in name == "Cabal" || name == "base")
+ (componentPackageDeps clbi))
+ }
+testSuiteLibV09AsLibAndExe _ _ TestSuite{} _ _ _ = error "testSuiteLibV09AsLibAndExe: wrong kind"
+
+
+-- | Translate a exe-style 'Benchmark' component into an exe for building
+benchmarkExeV10asExe :: Benchmark -> ComponentLocalBuildInfo
+ -> (Executable, ComponentLocalBuildInfo)
+benchmarkExeV10asExe bm@Benchmark { benchmarkInterface = BenchmarkExeV10 _ f }
+ clbi =
+ (exe, exeClbi)
+ where
+ exe = Executable {
+ exeName = benchmarkName bm,
+ modulePath = f,
+ buildInfo = benchmarkBuildInfo bm
+ }
+ exeClbi = ExeComponentLocalBuildInfo {
+ componentPackageDeps = componentPackageDeps clbi
+ }
+benchmarkExeV10asExe Benchmark{} _ = error "benchmarkExeV10asExe: wrong kind"
+
-- | Initialize a new package db file for libraries defined
-- internally to the package.
createInternalPackageDB :: FilePath -> IO PackageDB
@@ -290,30 +473,51 @@ 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
-buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo
+buildLib :: Verbosity -> Flag (Maybe Int)
+ -> PackageDescription -> LocalBuildInfo
-> Library -> ComponentLocalBuildInfo -> IO ()
-buildLib verbosity pkg_descr lbi lib clbi =
+buildLib verbosity numJobs pkg_descr lbi lib clbi =
case compilerFlavor (compiler lbi) of
- GHC -> GHC.buildLib verbosity pkg_descr lbi lib clbi
- JHC -> JHC.buildLib verbosity pkg_descr lbi lib clbi
- LHC -> LHC.buildLib verbosity pkg_descr lbi lib clbi
- Hugs -> Hugs.buildLib verbosity pkg_descr lbi lib clbi
- NHC -> NHC.buildLib verbosity pkg_descr lbi lib clbi
- UHC -> UHC.buildLib verbosity pkg_descr lbi lib clbi
+ 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
+ HaskellSuite {} -> HaskellSuite.buildLib verbosity pkg_descr lbi lib clbi
_ -> die "Building is not supported with this compiler."
-buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo
+buildExe :: Verbosity -> Flag (Maybe Int)
+ -> PackageDescription -> LocalBuildInfo
-> Executable -> ComponentLocalBuildInfo -> IO ()
-buildExe verbosity pkg_descr lbi exe clbi =
+buildExe verbosity numJobs pkg_descr lbi exe clbi =
case compilerFlavor (compiler lbi) of
- GHC -> GHC.buildExe verbosity pkg_descr lbi exe clbi
- JHC -> JHC.buildExe verbosity pkg_descr lbi exe clbi
- LHC -> LHC.buildExe verbosity pkg_descr lbi exe clbi
- Hugs -> Hugs.buildExe verbosity pkg_descr lbi exe clbi
- NHC -> NHC.buildExe verbosity pkg_descr lbi exe clbi
- UHC -> UHC.buildExe verbosity pkg_descr lbi exe clbi
+ 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."
+
+replLib :: Verbosity -> PackageDescription -> LocalBuildInfo
+ -> Library -> ComponentLocalBuildInfo -> IO ()
+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."
+
+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."
+
+
initialBuildSteps :: FilePath -- ^"dist" prefix
-> PackageDescription -- ^mostly information from the .cabal file
-> LocalBuildInfo -- ^Configuration information
@@ -347,3 +551,48 @@ writeAutogenFiles verbosity pkg lbi = do
let cppHeaderPath = autogenModulesDir lbi </> cppHeaderName
rewriteFile cppHeaderPath (Build.Macros.generate pkg lbi)
+
+-- | Check that the given build targets are valid in the current context.
+--
+-- Also swizzle into a more convenient form.
+--
+checkBuildTargets :: Verbosity -> PackageDescription -> [BuildTarget]
+ -> IO [(ComponentName, Maybe (Either ModuleName FilePath))]
+checkBuildTargets _ pkg [] =
+ return [ (componentName c, Nothing) | c <- pkgEnabledComponents pkg ]
+
+checkBuildTargets verbosity pkg targets = do
+
+ let (enabled, disabled) =
+ partitionEithers
+ [ case componentDisabledReason (getComponent pkg cname) of
+ Nothing -> Left target'
+ Just reason -> Right (cname, reason)
+ | target <- targets
+ , let target'@(cname,_) = swizzleTarget target ]
+
+ case disabled of
+ [] -> return ()
+ ((cname,reason):_) -> die $ formatReason (showComponentName cname) reason
+
+ forM_ [ (c, t) | (c, Just t) <- enabled ] $ \(c, t) ->
+ warn verbosity $ "Ignoring '" ++ either display id t ++ ". The whole "
+ ++ showComponentName c ++ " will be built. (Support for "
+ ++ "module and file targets has not been implemented yet.)"
+
+ return enabled
+
+ where
+ swizzleTarget (BuildTargetComponent c) = (c, Nothing)
+ swizzleTarget (BuildTargetModule c m) = (c, Just (Left m))
+ swizzleTarget (BuildTargetFile c f) = (c, Just (Right f))
+
+ formatReason cn DisabledComponent =
+ "Cannot build the " ++ cn ++ " because the component is marked "
+ ++ "as disabled in the .cabal file."
+ formatReason cn DisabledAllTests =
+ "Cannot build the " ++ cn ++ " because test suites are not "
+ ++ "enabled. Run configure with the flag --enable-tests"
+ formatReason cn DisabledAllBenchmarks =
+ "Cannot build the " ++ cn ++ " because benchmarks are not "
+ ++ "enabled. Re-run configure with the flag --enable-benchmarks"
diff --git a/cabal/Cabal/Distribution/Simple/Build/Macros.hs b/cabal/Cabal/Distribution/Simple/Build/Macros.hs
index 58e2ed4..5a801e5 100644
--- a/cabal/Cabal/Distribution/Simple/Build/Macros.hs
+++ b/cabal/Cabal/Distribution/Simple/Build/Macros.hs
@@ -18,9 +18,12 @@
-- numbers.
--
module Distribution.Simple.Build.Macros (
- generate
+ generate,
+ generatePackageVersionMacros,
) where
+import Data.Maybe
+ ( isJust )
import Distribution.Package
( PackageIdentifier(PackageIdentifier) )
import Distribution.Version
@@ -28,7 +31,11 @@ import Distribution.Version
import Distribution.PackageDescription
( PackageDescription )
import Distribution.Simple.LocalBuildInfo
- ( LocalBuildInfo, externalPackageDeps )
+ ( LocalBuildInfo(withPrograms), externalPackageDeps )
+import Distribution.Simple.Program.Db
+ ( configuredPrograms )
+import Distribution.Simple.Program.Types
+ ( ConfiguredProgram(programId, programVersion) )
import Distribution.Text
( display )
@@ -36,22 +43,56 @@ import Distribution.Text
-- * Generate cabal_macros.h
-- ------------------------------------------------------------
+-- | The contents of the @cabal_macros.h@ for the given configured package.
+--
generate :: PackageDescription -> LocalBuildInfo -> String
-generate _pkg_descr lbi = concat $
- "/* DO NOT EDIT: This file is automatically generated by Cabal */\n\n" :
- [ concat
- ["/* package ",display pkgid," */\n"
- ,"#define VERSION_",pkgname," ",show (display version),"\n"
- ,"#define MIN_VERSION_",pkgname,"(major1,major2,minor) (\\\n"
- ," (major1) < ",major1," || \\\n"
- ," (major1) == ",major1," && (major2) < ",major2," || \\\n"
- ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"
- ,"\n\n"
- ]
- | (_, pkgid@(PackageIdentifier name version)) <- externalPackageDeps lbi
- , let (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)
- pkgname = map fixchar (display name)
+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)
+
+-- | 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
+-- a configured package).
+--
+generatePackageVersionMacros :: [PackageIdentifier] -> String
+generatePackageVersionMacros pkgids = concat
+ [ "/* package " ++ display pkgid ++ " */\n"
+ ++ generateMacros "" pkgname version
+ | pkgid@(PackageIdentifier name version) <- pkgids
+ , let pkgname = map fixchar (display name)
+ ]
+
+-- | Helper function that generates just the @TOOL_VERSION_pkg@ and
+-- @MIN_TOOL_VERSION_pkg@ macros for a list of configured programs.
+--
+generateToolVersionMacros :: [ConfiguredProgram] -> String
+generateToolVersionMacros progs = concat
+ [ "/* tool " ++ progid ++ " */\n"
+ ++ generateMacros "TOOL_" progname version
+ | prog <- progs
+ , isJust . programVersion $ prog
+ , let progid = programId prog ++ "-" ++ display version
+ progname = map fixchar (programId prog)
+ Just version = programVersion prog
+ ]
+
+-- | Common implementation of 'generatePackageVersionMacros' and
+-- 'generateToolVersionMacros'.
+--
+generateMacros :: String -> String -> Version -> String
+generateMacros prefix name version =
+ concat
+ ["#define ", prefix, "VERSION_",name," ",show (display version),"\n"
+ ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n"
+ ," (major1) < ",major1," || \\\n"
+ ," (major1) == ",major1," && (major2) < ",major2," || \\\n"
+ ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"
+ ,"\n\n"
]
- where fixchar '-' = '_'
- fixchar c = c
+ where
+ (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)
+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 5980ba0..af81396 100644
--- a/cabal/Cabal/Distribution/Simple/Build/PathsModule.hs
+++ b/cabal/Cabal/Distribution/Simple/Build/PathsModule.hs
@@ -68,7 +68,7 @@ generate pkg_descr lbi =
"module " ++ display paths_modulename ++ " (\n"++
" version,\n"++
" getBinDir, getLibDir, getDataDir, getLibexecDir,\n"++
- " getDataFileName\n"++
+ " getDataFileName, getSysconfDir\n"++
" ) where\n"++
"\n"++
foreign_imports++
@@ -85,17 +85,19 @@ generate pkg_descr lbi =
body
| absolute =
- "\nbindir, libdir, datadir, libexecdir :: FilePath\n"++
+ "\nbindir, libdir, datadir, libexecdir, sysconfdir :: FilePath\n"++
"\nbindir = " ++ show flat_bindir ++
"\nlibdir = " ++ show flat_libdir ++
"\ndatadir = " ++ show flat_datadir ++
"\nlibexecdir = " ++ show flat_libexecdir ++
+ "\nsysconfdir = " ++ show flat_sysconfdir ++
"\n"++
- "\ngetBinDir, getLibDir, getDataDir, getLibexecDir :: IO FilePath\n"++
+ "\ngetBinDir, getLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath\n"++
"getBinDir = "++mkGetEnvOr "bindir" "return bindir"++"\n"++
"getLibDir = "++mkGetEnvOr "libdir" "return libdir"++"\n"++
"getDataDir = "++mkGetEnvOr "datadir" "return datadir"++"\n"++
"getLibexecDir = "++mkGetEnvOr "libexecdir" "return libexecdir"++"\n"++
+ "getSysconfDir = "++mkGetEnvOr "sysconfdir" "return sysconfdir"++"\n"++
"\n"++
"getDataFileName :: FilePath -> IO FilePath\n"++
"getDataFileName name = do\n"++
@@ -115,6 +117,8 @@ generate pkg_descr lbi =
(mkGetDir flat_datadir flat_datadirrel)++"\n\n"++
"getLibexecDir :: IO FilePath\n"++
"getLibexecDir = "++mkGetDir flat_libexecdir flat_libexecdirrel++"\n\n"++
+ "getSysconfDir :: IO FilePath\n"++
+ "getSysconfDir = "++mkGetDir flat_sysconfdir flat_sysconfdirrel++"\n\n"++
"getDataFileName :: FilePath -> IO FilePath\n"++
"getDataFileName name = do\n"++
" dir <- getDataDir\n"++
@@ -131,13 +135,15 @@ generate pkg_descr lbi =
bindir = flat_bindir,
libdir = flat_libdir,
datadir = flat_datadir,
- libexecdir = flat_libexecdir
+ libexecdir = flat_libexecdir,
+ sysconfdir = flat_sysconfdir
} = absoluteInstallDirs pkg_descr lbi NoCopyDest
InstallDirs {
bindir = flat_bindirrel,
libdir = flat_libdirrel,
datadir = flat_datadirrel,
libexecdir = flat_libexecdirrel,
+ sysconfdir = flat_sysconfdirrel,
progdir = flat_progdirrel
} = prefixRelativeInstallDirs (packageId pkg_descr) lbi
@@ -181,7 +187,7 @@ generate pkg_descr lbi =
-- component of interest.
pkgPathEnvVar :: PackageDescription
-> String -- ^ path component; one of \"bindir\", \"libdir\",
- -- \"datadir\" or \"libexecdir\"
+ -- \"datadir\", \"libexecdir\", or \"sysconfdir\"
-> String -- ^ environment variable name
pkgPathEnvVar pkg_descr var =
showPkgName (packageName pkg_descr) ++ "_" ++ var
@@ -210,7 +216,7 @@ get_prefix_win32 arch =
where cconv = case arch of
I386 -> "stdcall"
X86_64 -> "ccall"
-
+ _ -> error "win32 supported only with I386, X86_64"
get_prefix_hugs :: String
get_prefix_hugs =
diff --git a/cabal/Cabal/Distribution/Simple/BuildPaths.hs b/cabal/Cabal/Distribution/Simple/BuildPaths.hs
index 575545f..d7b35ba 100644
--- a/cabal/Cabal/Distribution/Simple/BuildPaths.hs
+++ b/cabal/Cabal/Distribution/Simple/BuildPaths.hs
@@ -63,13 +63,14 @@ module Distribution.Simple.BuildPaths (
import System.FilePath ((</>), (<.>))
import Distribution.Package
- ( PackageIdentifier, packageName )
+ ( packageName )
import Distribution.ModuleName (ModuleName)
import qualified Distribution.ModuleName as ModuleName
import Distribution.Compiler
( CompilerId(..) )
import Distribution.PackageDescription (PackageDescription)
-import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(buildDir))
+import Distribution.Simple.LocalBuildInfo
+ ( LocalBuildInfo(buildDir), LibraryName(..) )
import Distribution.Simple.Setup (defaultDistPref)
import Distribution.Text
( display )
@@ -109,18 +110,18 @@ haddockName pkg_descr = display (packageName pkg_descr) <.> "haddock"
-- ---------------------------------------------------------------------------
-- Library file names
-mkLibName :: PackageIdentifier -> String
-mkLibName lib = "libHS" ++ display lib <.> "a"
+mkLibName :: LibraryName -> String
+mkLibName (LibraryName lib) = "lib" ++ lib <.> "a"
-mkProfLibName :: PackageIdentifier -> String
-mkProfLibName lib = "libHS" ++ display lib ++ "_p" <.> "a"
+mkProfLibName :: LibraryName -> String
+mkProfLibName (LibraryName lib) = "lib" ++ 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 :: PackageIdentifier -> CompilerId -> String
-mkSharedLibName lib (CompilerId compilerFlavor compilerVersion)
- = "libHS" ++ display lib ++ "-" ++ comp <.> dllExtension
+mkSharedLibName :: CompilerId -> LibraryName -> String
+mkSharedLibName (CompilerId compilerFlavor compilerVersion) (LibraryName lib)
+ = "lib" ++ lib ++ "-" ++ comp <.> dllExtension
where comp = display compilerFlavor ++ display compilerVersion
-- ------------------------------------------------------------
diff --git a/cabal/Cabal/Distribution/Simple/BuildTarget.hs b/cabal/Cabal/Distribution/Simple/BuildTarget.hs
new file mode 100644
index 0000000..b584288
--- /dev/null
+++ b/cabal/Cabal/Distribution/Simple/BuildTarget.hs
@@ -0,0 +1,931 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Client.BuildTargets
+-- Copyright : (c) Duncan Coutts 2012
+-- License : BSD-like
+--
+-- Maintainer : duncan@community.haskell.org
+--
+-- Handling for user-specified build targets
+-----------------------------------------------------------------------------
+module Distribution.Simple.BuildTarget (
+
+ -- * Build targets
+ BuildTarget(..),
+ readBuildTargets,
+
+ -- * Parsing user build targets
+ UserBuildTarget,
+ readUserBuildTargets,
+ UserBuildTargetProblem(..),
+ reportUserBuildTargetProblems,
+
+ -- * Resolving build targets
+ resolveBuildTargets,
+ BuildTargetProblem(..),
+ reportBuildTargetProblems,
+ ) where
+
+import Distribution.Package
+ ( Package(..), PackageId, packageName )
+
+import Distribution.PackageDescription
+ ( PackageDescription
+ , Executable(..)
+ , TestSuite(..), TestSuiteInterface(..), testModules
+ , Benchmark(..), BenchmarkInterface(..), benchmarkModules
+ , BuildInfo(..), libModules, exeModules )
+import Distribution.ModuleName
+ ( ModuleName, toFilePath )
+import Distribution.Simple.LocalBuildInfo
+ ( Component(..), ComponentName(..)
+ , pkgComponents, componentName, componentBuildInfo )
+
+import Distribution.Text
+ ( display )
+import Distribution.Simple.Utils
+ ( die, lowercase, equating )
+
+import Data.List
+ ( nub, stripPrefix, sortBy, groupBy, partition, intercalate )
+import Data.Ord
+import Data.Maybe
+ ( listToMaybe, catMaybes )
+import Data.Either
+ ( partitionEithers )
+import qualified Data.Map as Map
+import Control.Monad
+import Control.Applicative (Applicative(..), Alternative(..))
+import qualified Distribution.Compat.ReadP as Parse
+import Distribution.Compat.ReadP
+ ( (+++), (<++) )
+import Data.Char
+ ( isSpace, isAlphaNum )
+import System.FilePath as FilePath
+ ( dropExtension, normalise, splitDirectories, joinPath, splitPath
+ , hasTrailingPathSeparator )
+import System.Directory
+ ( doesFileExist, doesDirectoryExist )
+
+-- ------------------------------------------------------------
+-- * User build targets
+-- ------------------------------------------------------------
+
+-- | Various ways that a user may specify a build target.
+--
+data UserBuildTarget =
+
+ -- | A target specified by a single name. This could be a component
+ -- module or file.
+ --
+ -- > cabal build foo
+ -- > cabal build Data.Foo
+ -- > cabal build Data/Foo.hs Data/Foo.hsc
+ --
+ UserBuildTargetSingle String
+
+ -- | A target specified by a qualifier and name. This could be a component
+ -- name qualified by the component namespace kind, or a module or file
+ -- qualified by the component name.
+ --
+ -- > cabal build lib:foo exe:foo
+ -- > cabal build foo:Data.Foo
+ -- > cabal build foo:Data/Foo.hs
+ --
+ | UserBuildTargetDouble String String
+
+ -- A fully qualified target, either a module or file qualified by a
+ -- component name with the component namespace kind.
+ --
+ -- > cabal build lib:foo:Data/Foo.hs exe:foo:Data/Foo.hs
+ -- > cabal build lib:foo:Data.Foo exe:foo:Data.Foo
+ --
+ | UserBuildTargetTriple String String String
+ deriving (Show, Eq, Ord)
+
+
+-- ------------------------------------------------------------
+-- * Resolved build targets
+-- ------------------------------------------------------------
+
+-- | A fully resolved build target.
+--
+data BuildTarget =
+
+ -- | A specific component
+ --
+ BuildTargetComponent ComponentName
+
+ -- | A specific module within a specific component.
+ --
+ | BuildTargetModule ComponentName ModuleName
+
+ -- | A specific file within a specific component.
+ --
+ | BuildTargetFile ComponentName FilePath
+ deriving (Show,Eq)
+
+
+-- ------------------------------------------------------------
+-- * Do everything
+-- ------------------------------------------------------------
+
+readBuildTargets :: PackageDescription -> [String] -> IO [BuildTarget]
+readBuildTargets pkg targetStrs = do
+ let (uproblems, utargets) = readUserBuildTargets targetStrs
+ reportUserBuildTargetProblems uproblems
+
+ utargets' <- mapM checkTargetExistsAsFile utargets
+
+ let (bproblems, btargets) = resolveBuildTargets pkg utargets'
+ reportBuildTargetProblems bproblems
+
+ return btargets
+
+checkTargetExistsAsFile :: UserBuildTarget -> IO (UserBuildTarget, Bool)
+checkTargetExistsAsFile t = do
+ fexists <- existsAsFile (fileComponentOfTarget t)
+ return (t, fexists)
+
+ where
+ existsAsFile f = do
+ exists <- doesFileExist f
+ case splitPath f of
+ (d:_) | hasTrailingPathSeparator d -> doesDirectoryExist d
+ (d:_:_) | not exists -> doesDirectoryExist d
+ _ -> return exists
+
+ fileComponentOfTarget (UserBuildTargetSingle s1) = s1
+ fileComponentOfTarget (UserBuildTargetDouble _ s2) = s2
+ fileComponentOfTarget (UserBuildTargetTriple _ _ s3) = s3
+
+
+-- ------------------------------------------------------------
+-- * Parsing user targets
+-- ------------------------------------------------------------
+
+readUserBuildTargets :: [String] -> ([UserBuildTargetProblem]
+ ,[UserBuildTarget])
+readUserBuildTargets = partitionEithers . map readUserBuildTarget
+
+readUserBuildTarget :: String -> Either UserBuildTargetProblem
+ UserBuildTarget
+readUserBuildTarget targetstr =
+ case readPToMaybe parseTargetApprox targetstr of
+ Nothing -> Left (UserBuildTargetUnrecognised targetstr)
+ Just tgt -> Right tgt
+
+ where
+ parseTargetApprox :: Parse.ReadP r UserBuildTarget
+ parseTargetApprox =
+ (do a <- tokenQ
+ return (UserBuildTargetSingle a))
+ +++ (do a <- token
+ _ <- Parse.char ':'
+ b <- tokenQ
+ return (UserBuildTargetDouble a b))
+ +++ (do a <- token
+ _ <- Parse.char ':'
+ b <- token
+ _ <- Parse.char ':'
+ c <- tokenQ
+ return (UserBuildTargetTriple a b c))
+
+ token = Parse.munch1 (\x -> not (isSpace x) && x /= ':')
+ tokenQ = parseHaskellString <++ token
+ parseHaskellString :: Parse.ReadP r String
+ parseHaskellString = Parse.readS_to_P reads
+
+ readPToMaybe :: Parse.ReadP a a -> String -> Maybe a
+ readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str
+ , all isSpace s ]
+
+data UserBuildTargetProblem
+ = UserBuildTargetUnrecognised String
+ deriving Show
+
+reportUserBuildTargetProblems :: [UserBuildTargetProblem] -> IO ()
+reportUserBuildTargetProblems problems = do
+ case [ target | UserBuildTargetUnrecognised target <- problems ] of
+ [] -> return ()
+ target ->
+ die $ unlines
+ [ "Unrecognised build target '" ++ name ++ "'."
+ | name <- target ]
+ ++ "Examples:\n"
+ ++ " - build foo -- component name "
+ ++ "(library, executable, test-suite or benchmark)\n"
+ ++ " - build Data.Foo -- module name\n"
+ ++ " - build Data/Foo.hsc -- file name\n"
+ ++ " - build lib:foo exe:foo -- component qualified by kind\n"
+ ++ " - build foo:Data.Foo -- module qualified by component\n"
+ ++ " - build foo:Data/Foo.hsc -- file qualified by component"
+
+showUserBuildTarget :: UserBuildTarget -> String
+showUserBuildTarget = intercalate ":" . components
+ where
+ components (UserBuildTargetSingle s1) = [s1]
+ components (UserBuildTargetDouble s1 s2) = [s1,s2]
+ components (UserBuildTargetTriple s1 s2 s3) = [s1,s2,s3]
+
+
+-- ------------------------------------------------------------
+-- * Resolving user targets to build targets
+-- ------------------------------------------------------------
+
+{-
+stargets =
+ [ BuildTargetComponent (CExeName "foo")
+ , BuildTargetModule (CExeName "foo") (mkMn "Foo")
+ , BuildTargetModule (CExeName "tst") (mkMn "Foo")
+ ]
+ where
+ mkMn :: String -> ModuleName
+ mkMn = fromJust . simpleParse
+
+ex_pkgid :: PackageIdentifier
+Just ex_pkgid = simpleParse "thelib"
+-}
+
+-- | Given a bunch of user-specified targets, try to resolve what it is they
+-- refer to.
+--
+resolveBuildTargets :: PackageDescription
+ -> [(UserBuildTarget, Bool)]
+ -> ([BuildTargetProblem], [BuildTarget])
+resolveBuildTargets pkg = partitionEithers
+ . map (uncurry (resolveBuildTarget pkg))
+
+resolveBuildTarget :: PackageDescription -> UserBuildTarget -> Bool
+ -> Either BuildTargetProblem BuildTarget
+resolveBuildTarget pkg userTarget fexists =
+ case findMatch (matchBuildTarget pkg userTarget fexists) of
+ Unambiguous target -> Right target
+ Ambiguous targets -> Left (BuildTargetAmbigious userTarget targets')
+ where targets' = disambiguateBuildTargets
+ (packageId pkg) userTarget
+ targets
+ None errs -> Left (classifyMatchErrors errs)
+
+ where
+ classifyMatchErrors errs
+ | not (null expected) = let (things, got:_) = unzip expected in
+ BuildTargetExpected userTarget things got
+ | not (null nosuch) = BuildTargetNoSuch userTarget nosuch
+ | otherwise = error $ "resolveBuildTarget: internal error in matching"
+ where
+ expected = [ (thing, got) | MatchErrorExpected thing got <- errs ]
+ nosuch = [ (thing, got) | MatchErrorNoSuch thing got <- errs ]
+
+
+data BuildTargetProblem
+ = BuildTargetExpected UserBuildTarget [String] String
+ -- ^ [expected thing] (actually got)
+ | BuildTargetNoSuch UserBuildTarget [(String, String)]
+ -- ^ [(no such thing, actually got)]
+ | BuildTargetAmbigious UserBuildTarget [(UserBuildTarget, BuildTarget)]
+ deriving Show
+
+
+disambiguateBuildTargets :: PackageId -> UserBuildTarget -> [BuildTarget]
+ -> [(UserBuildTarget, BuildTarget)]
+disambiguateBuildTargets pkgid original =
+ disambiguate (userTargetQualLevel original)
+ where
+ disambiguate ql ts
+ | null amb = unamb
+ | otherwise = unamb ++ disambiguate (succ ql) amb
+ where
+ (amb, unamb) = step ql ts
+
+ userTargetQualLevel (UserBuildTargetSingle _ ) = QL1
+ userTargetQualLevel (UserBuildTargetDouble _ _ ) = QL2
+ userTargetQualLevel (UserBuildTargetTriple _ _ _) = QL3
+
+ step :: QualLevel -> [BuildTarget]
+ -> ([BuildTarget], [(UserBuildTarget, BuildTarget)])
+ step ql = (\(amb, unamb) -> (map snd $ concat amb, concat unamb))
+ . partition (\g -> length g > 1)
+ . groupBy (equating fst)
+ . sortBy (comparing fst)
+ . map (\t -> (renderBuildTarget ql t pkgid, t))
+
+data QualLevel = QL1 | QL2 | QL3
+ deriving (Enum, Show)
+
+renderBuildTarget :: QualLevel -> BuildTarget -> PackageId -> UserBuildTarget
+renderBuildTarget ql target pkgid =
+ case ql of
+ QL1 -> UserBuildTargetSingle s1 where s1 = single target
+ QL2 -> UserBuildTargetDouble s1 s2 where (s1, s2) = double target
+ QL3 -> UserBuildTargetTriple s1 s2 s3 where (s1, s2, s3) = triple target
+
+ where
+ single (BuildTargetComponent cn ) = dispCName cn
+ single (BuildTargetModule _ m) = display m
+ single (BuildTargetFile _ f) = f
+
+ double (BuildTargetComponent cn ) = (dispKind cn, dispCName cn)
+ double (BuildTargetModule cn m) = (dispCName cn, display m)
+ double (BuildTargetFile cn f) = (dispCName cn, f)
+
+ triple (BuildTargetComponent _ ) = error "triple BuildTargetComponent"
+ triple (BuildTargetModule cn m) = (dispKind cn, dispCName cn, display m)
+ triple (BuildTargetFile cn f) = (dispKind cn, dispCName cn, f)
+
+ dispCName = componentStringName pkgid
+ dispKind = showComponentKindShort . componentKind
+
+reportBuildTargetProblems :: [BuildTargetProblem] -> IO ()
+reportBuildTargetProblems problems = do
+
+ case [ (t, e, g) | BuildTargetExpected t e g <- problems ] of
+ [] -> return ()
+ targets ->
+ die $ unlines
+ [ "Unrecognised build target '" ++ showUserBuildTarget target
+ ++ "'.\n"
+ ++ "Expected a " ++ intercalate " or " expected
+ ++ ", rather than '" ++ got ++ "'."
+ | (target, expected, got) <- targets ]
+
+ case [ (t, e) | BuildTargetNoSuch t e <- problems ] of
+ [] -> return ()
+ targets ->
+ die $ unlines
+ [ "Unknown build target '" ++ showUserBuildTarget target
+ ++ "'.\nThere is no "
+ ++ intercalate " or " [ mungeThing thing ++ " '" ++ got ++ "'"
+ | (thing, got) <- nosuch ] ++ "."
+ | (target, nosuch) <- targets ]
+ where
+ mungeThing "file" = "file target"
+ mungeThing thing = thing
+
+ case [ (t, ts) | BuildTargetAmbigious t ts <- problems ] of
+ [] -> return ()
+ targets ->
+ die $ unlines
+ [ "Ambiguous build target '" ++ showUserBuildTarget target
+ ++ "'. It could be:\n "
+ ++ unlines [ " "++ showUserBuildTarget ut ++
+ " (" ++ showBuildTargetKind bt ++ ")"
+ | (ut, bt) <- amb ]
+ | (target, amb) <- targets ]
+
+ where
+ showBuildTargetKind (BuildTargetComponent _ ) = "component"
+ showBuildTargetKind (BuildTargetModule _ _) = "module"
+ showBuildTargetKind (BuildTargetFile _ _) = "file"
+
+
+----------------------------------
+-- Top level BuildTarget matcher
+--
+
+matchBuildTarget :: PackageDescription
+ -> UserBuildTarget -> Bool -> Match BuildTarget
+matchBuildTarget pkg = \utarget fexists ->
+ case utarget of
+ UserBuildTargetSingle str1 ->
+ matchBuildTarget1 cinfo str1 fexists
+
+ UserBuildTargetDouble str1 str2 ->
+ matchBuildTarget2 cinfo str1 str2 fexists
+
+ UserBuildTargetTriple str1 str2 str3 ->
+ matchBuildTarget3 cinfo str1 str2 str3 fexists
+ where
+ cinfo = pkgComponentInfo pkg
+
+matchBuildTarget1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget
+matchBuildTarget1 cinfo str1 fexists =
+ matchComponent1 cinfo str1
+ `matchPlusShadowing` matchModule1 cinfo str1
+ `matchPlusShadowing` matchFile1 cinfo str1 fexists
+
+
+matchBuildTarget2 :: [ComponentInfo] -> String -> String -> Bool
+ -> Match BuildTarget
+matchBuildTarget2 cinfo str1 str2 fexists =
+ matchComponent2 cinfo str1 str2
+ `matchPlusShadowing` matchModule2 cinfo str1 str2
+ `matchPlusShadowing` matchFile2 cinfo str1 str2 fexists
+
+
+matchBuildTarget3 :: [ComponentInfo] -> String -> String -> String -> Bool
+ -> Match BuildTarget
+matchBuildTarget3 cinfo str1 str2 str3 fexists =
+ matchModule3 cinfo str1 str2 str3
+ `matchPlusShadowing` matchFile3 cinfo str1 str2 str3 fexists
+
+
+data ComponentInfo = ComponentInfo {
+ cinfoName :: ComponentName,
+ cinfoStrName :: ComponentStringName,
+ cinfoSrcDirs :: [FilePath],
+ cinfoModules :: [ModuleName],
+ cinfoHsFiles :: [FilePath], -- other hs files (like main.hs)
+ cinfoCFiles :: [FilePath]
+ }
+
+type ComponentStringName = String
+
+pkgComponentInfo :: PackageDescription -> [ComponentInfo]
+pkgComponentInfo pkg =
+ [ ComponentInfo {
+ cinfoName = componentName c,
+ cinfoStrName = componentStringName pkg (componentName c),
+ cinfoSrcDirs = hsSourceDirs bi,
+ cinfoModules = componentModules c,
+ cinfoHsFiles = componentHsFiles c,
+ cinfoCFiles = cSources bi
+ }
+ | c <- pkgComponents pkg
+ , let bi = componentBuildInfo c ]
+
+componentStringName :: Package pkg => pkg -> ComponentName -> ComponentStringName
+componentStringName pkg CLibName = display (packageName pkg)
+componentStringName _ (CExeName name) = name
+componentStringName _ (CTestName name) = name
+componentStringName _ (CBenchName name) = name
+
+componentModules :: Component -> [ModuleName]
+componentModules (CLib lib) = libModules lib
+componentModules (CExe exe) = exeModules exe
+componentModules (CTest test) = testModules test
+componentModules (CBench bench) = benchmarkModules bench
+
+componentHsFiles :: Component -> [FilePath]
+componentHsFiles (CExe exe) = [modulePath exe]
+componentHsFiles (CTest TestSuite {
+ testInterface = TestSuiteExeV10 _ mainfile
+ }) = [mainfile]
+componentHsFiles (CBench Benchmark {
+ benchmarkInterface = BenchmarkExeV10 _ mainfile
+ }) = [mainfile]
+componentHsFiles _ = []
+
+{-
+ex_cs :: [ComponentInfo]
+ex_cs =
+ [ (mkC (CExeName "foo") ["src1", "src1/src2"] ["Foo", "Src2.Bar", "Bar"])
+ , (mkC (CExeName "tst") ["src1", "test"] ["Foo"])
+ ]
+ where
+ mkC n ds ms = ComponentInfo n (componentStringName pkgid n) ds (map mkMn ms)
+ mkMn :: String -> ModuleName
+ mkMn = fromJust . simpleParse
+ pkgid :: PackageIdentifier
+ Just pkgid = simpleParse "thelib"
+-}
+
+------------------------------
+-- Matching component kinds
+--
+
+data ComponentKind = LibKind | ExeKind | TestKind | BenchKind
+ deriving (Eq, Ord, Show)
+
+componentKind :: ComponentName -> ComponentKind
+componentKind CLibName = LibKind
+componentKind (CExeName _) = ExeKind
+componentKind (CTestName _) = TestKind
+componentKind (CBenchName _) = BenchKind
+
+cinfoKind :: ComponentInfo -> ComponentKind
+cinfoKind = componentKind . cinfoName
+
+matchComponentKind :: String -> Match ComponentKind
+matchComponentKind s
+ | s `elem` ["lib", "library"] = increaseConfidence >> return LibKind
+ | s `elem` ["exe", "executable"] = increaseConfidence >> return ExeKind
+ | s `elem` ["tst", "test", "test-suite"] = increaseConfidence
+ >> return TestKind
+ | s `elem` ["bench", "benchmark"] = increaseConfidence
+ >> return BenchKind
+ | otherwise = matchErrorExpected
+ "component kind" s
+
+showComponentKind :: ComponentKind -> String
+showComponentKind LibKind = "library"
+showComponentKind ExeKind = "executable"
+showComponentKind TestKind = "test-suite"
+showComponentKind BenchKind = "benchmark"
+
+showComponentKindShort :: ComponentKind -> String
+showComponentKindShort LibKind = "lib"
+showComponentKindShort ExeKind = "exe"
+showComponentKindShort TestKind = "test"
+showComponentKindShort BenchKind = "bench"
+
+------------------------------
+-- Matching component targets
+--
+
+matchComponent1 :: [ComponentInfo] -> String -> Match BuildTarget
+matchComponent1 cs = \str1 -> do
+ guardComponentName str1
+ c <- matchComponentName cs str1
+ return (BuildTargetComponent (cinfoName c))
+
+matchComponent2 :: [ComponentInfo] -> String -> String -> Match BuildTarget
+matchComponent2 cs = \str1 str2 -> do
+ ckind <- matchComponentKind str1
+ guardComponentName str2
+ c <- matchComponentKindAndName cs ckind str2
+ return (BuildTargetComponent (cinfoName c))
+
+-- utils:
+
+guardComponentName :: String -> Match ()
+guardComponentName s
+ | all validComponentChar s
+ && not (null s) = increaseConfidence
+ | otherwise = matchErrorExpected "component name" s
+ where
+ validComponentChar c = isAlphaNum c || c == '.'
+ || c == '_' || c == '-' || c == '\''
+
+matchComponentName :: [ComponentInfo] -> String -> Match ComponentInfo
+matchComponentName cs str =
+ orNoSuchThing "component" str
+ $ increaseConfidenceFor
+ $ matchInexactly caseFold
+ [ (cinfoStrName c, c) | c <- cs ]
+ str
+
+matchComponentKindAndName :: [ComponentInfo] -> ComponentKind -> String
+ -> Match ComponentInfo
+matchComponentKindAndName cs ckind str =
+ orNoSuchThing (showComponentKind ckind ++ " component") str
+ $ increaseConfidenceFor
+ $ matchInexactly (\(ck, cn) -> (ck, caseFold cn))
+ [ ((cinfoKind c, cinfoStrName c), c) | c <- cs ]
+ (ckind, str)
+
+
+------------------------------
+-- Matching module targets
+--
+
+matchModule1 :: [ComponentInfo] -> String -> Match BuildTarget
+matchModule1 cs = \str1 -> do
+ guardModuleName str1
+ nubMatchErrors $ do
+ c <- tryEach cs
+ let ms = cinfoModules c
+ m <- matchModuleName ms str1
+ return (BuildTargetModule (cinfoName c) m)
+
+matchModule2 :: [ComponentInfo] -> String -> String -> Match BuildTarget
+matchModule2 cs = \str1 str2 -> do
+ guardComponentName str1
+ guardModuleName str2
+ c <- matchComponentName cs str1
+ let ms = cinfoModules c
+ m <- matchModuleName ms str2
+ return (BuildTargetModule (cinfoName c) m)
+
+matchModule3 :: [ComponentInfo] -> String -> String -> String
+ -> Match BuildTarget
+matchModule3 cs str1 str2 str3 = do
+ ckind <- matchComponentKind str1
+ guardComponentName str2
+ c <- matchComponentKindAndName cs ckind str2
+ guardModuleName str3
+ let ms = cinfoModules c
+ m <- matchModuleName ms str3
+ return (BuildTargetModule (cinfoName c) m)
+
+-- utils:
+
+guardModuleName :: String -> Match ()
+guardModuleName s
+ | all validModuleChar s
+ && not (null s) = increaseConfidence
+ | otherwise = matchErrorExpected "module name" s
+ where
+ validModuleChar c = isAlphaNum c || c == '.' || c == '_' || c == '\''
+
+matchModuleName :: [ModuleName] -> String -> Match ModuleName
+matchModuleName ms str =
+ orNoSuchThing "module" str
+ $ increaseConfidenceFor
+ $ matchInexactly caseFold
+ [ (display m, m)
+ | m <- ms ]
+ str
+
+
+------------------------------
+-- Matching file targets
+--
+
+matchFile1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget
+matchFile1 cs str1 exists =
+ nubMatchErrors $ do
+ c <- tryEach cs
+ filepath <- matchComponentFile c str1 exists
+ return (BuildTargetFile (cinfoName c) filepath)
+
+
+matchFile2 :: [ComponentInfo] -> String -> String -> Bool -> Match BuildTarget
+matchFile2 cs str1 str2 exists = do
+ guardComponentName str1
+ c <- matchComponentName cs str1
+ filepath <- matchComponentFile c str2 exists
+ return (BuildTargetFile (cinfoName c) filepath)
+
+
+matchFile3 :: [ComponentInfo] -> String -> String -> String -> Bool
+ -> Match BuildTarget
+matchFile3 cs str1 str2 str3 exists = do
+ ckind <- matchComponentKind str1
+ guardComponentName str2
+ c <- matchComponentKindAndName cs ckind str2
+ filepath <- matchComponentFile c str3 exists
+ return (BuildTargetFile (cinfoName c) filepath)
+
+
+matchComponentFile :: ComponentInfo -> String -> Bool -> Match FilePath
+matchComponentFile c str fexists =
+ expecting "file" str $
+ matchPlus
+ (matchFileExists str fexists)
+ (matchPlusShadowing
+ (msum [ matchModuleFileRooted dirs ms str
+ , matchOtherFileRooted dirs hsFiles str ])
+ (msum [ matchModuleFileUnrooted ms str
+ , matchOtherFileUnrooted hsFiles str
+ , matchOtherFileUnrooted cFiles str ]))
+ where
+ dirs = cinfoSrcDirs c
+ ms = cinfoModules c
+ hsFiles = cinfoHsFiles c
+ cFiles = cinfoCFiles c
+
+
+-- utils
+
+matchFileExists :: FilePath -> Bool -> Match a
+matchFileExists _ False = mzero
+matchFileExists fname True = do increaseConfidence
+ matchErrorNoSuch "file" fname
+
+matchModuleFileUnrooted :: [ModuleName] -> String -> Match FilePath
+matchModuleFileUnrooted ms str = do
+ let filepath = normalise str
+ _ <- matchModuleFileStem ms filepath
+ return filepath
+
+matchModuleFileRooted :: [FilePath] -> [ModuleName] -> String -> Match FilePath
+matchModuleFileRooted dirs ms str = nubMatches $ do
+ let filepath = normalise str
+ filepath' <- matchDirectoryPrefix dirs filepath
+ _ <- matchModuleFileStem ms filepath'
+ return filepath
+
+matchModuleFileStem :: [ModuleName] -> FilePath -> Match ModuleName
+matchModuleFileStem ms =
+ increaseConfidenceFor
+ . matchInexactly caseFold
+ [ (toFilePath m, m) | m <- ms ]
+ . dropExtension
+
+matchOtherFileRooted :: [FilePath] -> [FilePath] -> FilePath -> Match FilePath
+matchOtherFileRooted dirs fs str = do
+ let filepath = normalise str
+ filepath' <- matchDirectoryPrefix dirs filepath
+ _ <- matchFile fs filepath'
+ return filepath
+
+matchOtherFileUnrooted :: [FilePath] -> FilePath -> Match FilePath
+matchOtherFileUnrooted fs str = do
+ let filepath = normalise str
+ _ <- matchFile fs filepath
+ return filepath
+
+matchFile :: [FilePath] -> FilePath -> Match FilePath
+matchFile fs = increaseConfidenceFor
+ . matchInexactly caseFold [ (f, f) | f <- fs ]
+
+matchDirectoryPrefix :: [FilePath] -> FilePath -> Match FilePath
+matchDirectoryPrefix dirs filepath =
+ exactMatches $
+ catMaybes
+ [ stripDirectory (normalise dir) filepath | dir <- dirs ]
+ where
+ stripDirectory :: FilePath -> FilePath -> Maybe FilePath
+ stripDirectory dir fp =
+ joinPath `fmap` stripPrefix (splitDirectories dir) (splitDirectories fp)
+
+
+------------------------------
+-- Matching monad
+--
+
+-- | A matcher embodies a way to match some input as being some recognised
+-- value. In particular it deals with multiple and ambigious matches.
+--
+-- There are various matcher primitives ('matchExactly', 'matchInexactly'),
+-- ways to combine matchers ('ambigiousWith', 'shadows') and finally we can
+-- run a matcher against an input using 'findMatch'.
+--
+
+data Match a = NoMatch Confidence [MatchError]
+ | ExactMatch Confidence [a]
+ | InexactMatch Confidence [a]
+ deriving Show
+
+type Confidence = Int
+
+data MatchError = MatchErrorExpected String String
+ | MatchErrorNoSuch String String
+ deriving (Show, Eq)
+
+
+instance Alternative Match where
+ empty = mzero
+ (<|>) = mplus
+
+instance MonadPlus Match where
+ mzero = matchZero
+ mplus = matchPlus
+
+matchZero :: Match a
+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.
+--
+matchPlus :: Match a -> Match a -> Match a
+matchPlus (ExactMatch d1 xs) (ExactMatch d2 xs') =
+ ExactMatch (max d1 d2) (xs ++ xs')
+matchPlus a@(ExactMatch _ _ ) (InexactMatch _ _ ) = a
+matchPlus a@(ExactMatch _ _ ) (NoMatch _ _ ) = a
+matchPlus (InexactMatch _ _ ) b@(ExactMatch _ _ ) = b
+matchPlus (InexactMatch d1 xs) (InexactMatch d2 xs') =
+ InexactMatch (max d1 d2) (xs ++ xs')
+matchPlus a@(InexactMatch _ _ ) (NoMatch _ _ ) = a
+matchPlus (NoMatch _ _ ) b@(ExactMatch _ _ ) = b
+matchPlus (NoMatch _ _ ) b@(InexactMatch _ _ ) = b
+matchPlus a@(NoMatch d1 ms) b@(NoMatch d2 ms')
+ | d1 > d2 = a
+ | d1 < d2 = b
+ | otherwise = NoMatch d1 (ms ++ ms')
+
+-- | Combine two matchers. This is similar to 'ambigiousWith' with the
+-- difference that an exact match from the left matcher shadows any exact
+-- match on the right. Inexact matches are still collected however.
+--
+matchPlusShadowing :: Match a -> Match a -> Match a
+matchPlusShadowing a@(ExactMatch _ _) (ExactMatch _ _) = a
+matchPlusShadowing a b = matchPlus a b
+
+instance Functor Match where
+ fmap _ (NoMatch d ms) = NoMatch d ms
+ fmap f (ExactMatch d xs) = ExactMatch d (fmap f xs)
+ fmap f (InexactMatch d xs) = InexactMatch d (fmap f xs)
+
+instance Applicative Match where
+ pure = return
+ (<*>) = ap
+
+instance Monad Match where
+ return a = ExactMatch 0 [a]
+ NoMatch d ms >>= _ = NoMatch d ms
+ ExactMatch d xs >>= f = addDepth d
+ $ foldr matchPlus matchZero (map f xs)
+ InexactMatch d xs >>= f = addDepth d . forceInexact
+ $ foldr matchPlus matchZero (map f xs)
+
+addDepth :: Confidence -> Match a -> Match a
+addDepth d' (NoMatch d msgs) = NoMatch (d'+d) msgs
+addDepth d' (ExactMatch d xs) = ExactMatch (d'+d) xs
+addDepth d' (InexactMatch d xs) = InexactMatch (d'+d) xs
+
+forceInexact :: Match a -> Match a
+forceInexact (ExactMatch d ys) = InexactMatch d ys
+forceInexact m = m
+
+------------------------------
+-- Various match primitives
+--
+
+matchErrorExpected, matchErrorNoSuch :: String -> String -> Match a
+matchErrorExpected thing got = NoMatch 0 [MatchErrorExpected thing got]
+matchErrorNoSuch thing got = NoMatch 0 [MatchErrorNoSuch thing got]
+
+expecting :: String -> String -> Match a -> Match a
+expecting thing got (NoMatch 0 _) = matchErrorExpected thing got
+expecting _ _ m = m
+
+orNoSuchThing :: String -> String -> Match a -> Match a
+orNoSuchThing thing got (NoMatch 0 _) = matchErrorNoSuch thing got
+orNoSuchThing _ _ m = m
+
+increaseConfidence :: Match ()
+increaseConfidence = ExactMatch 1 [()]
+
+increaseConfidenceFor :: Match a -> Match a
+increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r
+
+nubMatches :: Eq a => Match a -> Match a
+nubMatches (NoMatch d msgs) = NoMatch d msgs
+nubMatches (ExactMatch d xs) = ExactMatch d (nub xs)
+nubMatches (InexactMatch d xs) = InexactMatch d (nub xs)
+
+nubMatchErrors :: Match a -> Match a
+nubMatchErrors (NoMatch d msgs) = NoMatch d (nub msgs)
+nubMatchErrors (ExactMatch d xs) = ExactMatch d xs
+nubMatchErrors (InexactMatch d xs) = InexactMatch d xs
+
+-- | Lift a list of matches to an exact match.
+--
+exactMatches, inexactMatches :: [a] -> Match a
+
+exactMatches [] = matchZero
+exactMatches xs = ExactMatch 0 xs
+
+inexactMatches [] = matchZero
+inexactMatches xs = InexactMatch 0 xs
+
+tryEach :: [a] -> Match a
+tryEach = exactMatches
+
+
+------------------------------
+-- Top level match runner
+--
+
+-- | Given a matcher and a key to look up, use the matcher to find all the
+-- 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 match =
+ case match of
+ NoMatch _ msgs -> None (nub msgs)
+ ExactMatch _ xs -> checkAmbigious xs
+ InexactMatch _ xs -> checkAmbigious xs
+ where
+ checkAmbigious xs = case nub xs of
+ [x] -> Unambiguous x
+ xs' -> Ambiguous xs'
+
+data MaybeAmbigious a = None [MatchError] | Unambiguous a | Ambiguous [a]
+ deriving Show
+
+
+------------------------------
+-- Basic matchers
+--
+
+{-
+-- | A primitive matcher that looks up a value in a finite 'Map'. The
+-- value must match exactly.
+--
+matchExactly :: forall a b. Ord a => [(a, b)] -> (a -> Match b)
+matchExactly xs =
+ \x -> case Map.lookup x m of
+ Nothing -> matchZero
+ Just ys -> ExactMatch 0 ys
+ where
+ m :: Ord a => Map a [b]
+ m = Map.fromListWith (++) [ (k,[x]) | (k,x) <- xs ]
+-}
+
+-- | A primitive matcher that looks up a value in a finite 'Map'. It checks
+-- for an exact or inexact match. We get an inexact match if the match
+-- is not exact, but the canonical forms match. It takes a canonicalisation
+-- function for this purpose.
+--
+-- So for example if we used string case fold as the canonicalisation
+-- function, then we would get case insensitive matching (but it will still
+-- report an exact match when the case matches too).
+--
+matchInexactly :: (Ord a, Ord a') =>
+ (a -> a') ->
+ [(a, b)] -> (a -> Match b)
+matchInexactly cannonicalise xs =
+ \x -> case Map.lookup x m of
+ Just ys -> exactMatches ys
+ Nothing -> case Map.lookup (cannonicalise x) m' of
+ Just ys -> inexactMatches ys
+ Nothing -> matchZero
+ where
+ m = Map.fromListWith (++) [ (k,[x]) | (k,x) <- xs ]
+
+ -- the map of canonicalised keys to groups of inexact matches
+ m' = Map.mapKeysWith (++) cannonicalise m
+
+
+
+------------------------------
+-- Utils
+--
+
+caseFold :: String -> String
+caseFold = lowercase
diff --git a/cabal/Cabal/Distribution/Simple/CCompiler.hs b/cabal/Cabal/Distribution/Simple/CCompiler.hs
new file mode 100644
index 0000000..8294d9b
--- /dev/null
+++ b/cabal/Cabal/Distribution/Simple/CCompiler.hs
@@ -0,0 +1,121 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Simple.CCompiler
+-- Copyright : 2011, Dan Knapp
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Portability : portable
+--
+-- This simple package provides types and functions for interacting with
+-- C compilers. Currently it's just a type enumerating extant C-like
+-- languages, which we call dialects.
+
+{-
+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.CCompiler (
+ CDialect(..),
+ cSourceExtensions,
+ cDialectFilenameExtension,
+ filenameCDialect
+ ) where
+
+import Data.Monoid
+ ( Monoid(..) )
+import System.FilePath
+ ( takeExtension )
+
+
+-- | Represents a dialect of C. The Monoid instance expresses backward
+-- compatibility, in the sense that 'mappend a b' is the least inclusive
+-- dialect which both 'a' and 'b' can be correctly interpreted as.
+data CDialect = C
+ | ObjectiveC
+ | CPlusPlus
+ | ObjectiveCPlusPlus
+ deriving (Show)
+
+instance Monoid CDialect where
+ mempty = C
+
+ mappend C anything = anything
+ mappend ObjectiveC CPlusPlus = ObjectiveCPlusPlus
+ mappend CPlusPlus ObjectiveC = ObjectiveCPlusPlus
+ mappend _ ObjectiveCPlusPlus = ObjectiveCPlusPlus
+ mappend ObjectiveC _ = ObjectiveC
+ mappend CPlusPlus _ = CPlusPlus
+ mappend ObjectiveCPlusPlus _ = ObjectiveCPlusPlus
+
+
+-- | A list of all file extensions which are recognized as possibly containing
+-- some dialect of C code. Note that this list is only for source files,
+-- not for header files.
+cSourceExtensions :: [String]
+cSourceExtensions = ["c", "i", "ii", "m", "mi", "mm", "M", "mii", "cc", "cp",
+ "cxx", "cpp", "CPP", "c++", "C"]
+
+
+-- | Takes a dialect of C and whether code is intended to be passed through
+-- the preprocessor, and returns a filename extension for containing that
+-- code.
+cDialectFilenameExtension :: CDialect -> Bool -> String
+cDialectFilenameExtension C True = "c"
+cDialectFilenameExtension C False = "i"
+cDialectFilenameExtension ObjectiveC True = "m"
+cDialectFilenameExtension ObjectiveC False = "mi"
+cDialectFilenameExtension CPlusPlus True = "cpp"
+cDialectFilenameExtension CPlusPlus False = "ii"
+cDialectFilenameExtension ObjectiveCPlusPlus True = "mm"
+cDialectFilenameExtension ObjectiveCPlusPlus False = "mii"
+
+
+-- | Infers from a filename's extension the dialect of C which it contains,
+-- and whether it is intended to be passed through the preprocessor.
+filenameCDialect :: String -> Maybe (CDialect, Bool)
+filenameCDialect filename = do
+ extension <- case takeExtension filename of
+ '.':ext -> Just ext
+ _ -> Nothing
+ case extension of
+ "c" -> return (C, True)
+ "i" -> return (C, False)
+ "ii" -> return (CPlusPlus, False)
+ "m" -> return (ObjectiveC, True)
+ "mi" -> return (ObjectiveC, False)
+ "mm" -> return (ObjectiveCPlusPlus, True)
+ "M" -> return (ObjectiveCPlusPlus, True)
+ "mii" -> return (ObjectiveCPlusPlus, False)
+ "cc" -> return (CPlusPlus, True)
+ "cp" -> return (CPlusPlus, True)
+ "cxx" -> return (CPlusPlus, True)
+ "cpp" -> return (CPlusPlus, True)
+ "CPP" -> return (CPlusPlus, True)
+ "c++" -> return (CPlusPlus, True)
+ "C" -> return (CPlusPlus, True)
+ _ -> Nothing
diff --git a/cabal/Cabal/Distribution/Simple/Command.hs b/cabal/Cabal/Distribution/Simple/Command.hs
index 5a57a02..bf81d7b 100644
--- a/cabal/Cabal/Distribution/Simple/Command.hs
+++ b/cabal/Cabal/Distribution/Simple/Command.hs
@@ -103,7 +103,8 @@ data CommandUI flags = CommandUI {
commandName :: String,
-- | A short, one line description of the command to use in help texts.
commandSynopsis :: String,
- -- | The useage line summary for this command
+ -- | A function that maps a program name to a usage summary for this
+ -- command.
commandUsage :: String -> String,
-- | Additional explanation of the command to use in help texts.
commandDescription :: Maybe (String -> String),
@@ -126,11 +127,18 @@ data OptionField a = OptionField {
optionName :: Name,
optionDescr :: [OptDescr a] }
--- | An OptionField takes one or more OptDescrs, describing the command line interface for the field.
-data OptDescr a = ReqArg Description OptFlags ArgPlaceHolder (ReadE (a->a)) (a -> [String])
- | OptArg Description OptFlags ArgPlaceHolder (ReadE (a->a)) (a->a) (a -> [Maybe String])
+-- | An OptionField takes one or more OptDescrs, describing the command line
+-- interface for the field.
+data OptDescr a = ReqArg Description OptFlags ArgPlaceHolder
+ (ReadE (a->a)) (a -> [String])
+
+ | OptArg Description OptFlags ArgPlaceHolder
+ (ReadE (a->a)) (a->a) (a -> [Maybe String])
+
| ChoiceOpt [(Description, OptFlags, a->a, a -> Bool)]
- | BoolOpt Description OptFlags{-True-} OptFlags{-False-} (Bool -> a -> a) (a-> Maybe Bool)
+
+ | BoolOpt Description OptFlags{-True-} OptFlags{-False-}
+ (Bool -> a -> a) (a-> Maybe Bool)
-- | Short command line option strings
type SFlags = [Char]
@@ -142,24 +150,30 @@ type ArgPlaceHolder = String
-- | Create an option taking a single OptDescr.
-- No explicit Name is given for the Option, the name is the first LFlag given.
-option :: SFlags -> LFlags -> Description -> get -> set -> MkOptDescr get set a -> OptionField a
+option :: SFlags -> LFlags -> Description -> get -> set -> MkOptDescr get set a
+ -> OptionField a
option sf lf@(n:_) d get set arg = OptionField n [arg sf lf d get set]
-option _ _ _ _ _ _ = error "Distribution.command.option: An OptionField must have at least one LFlag"
+option _ _ _ _ _ _ = error $ "Distribution.command.option: "
+ ++ "An OptionField must have at least one LFlag"
-- | Create an option taking several OptDescrs.
--- You will have to give the flags and description individually to the OptDescr constructor.
+-- You will have to give the flags and description individually to the
+-- OptDescr constructor.
multiOption :: Name -> get -> set
- -> [get -> set -> OptDescr a] -- ^MkOptDescr constructors partially applied to flags and description.
+ -> [get -> set -> OptDescr a] -- ^MkOptDescr constructors partially
+ -- applied to flags and description.
-> OptionField a
multiOption n get set args = OptionField n [arg get set | arg <- args]
-type MkOptDescr get set a = SFlags -> LFlags -> Description -> get -> set -> OptDescr a
+type MkOptDescr get set a = SFlags -> LFlags -> Description -> get -> set
+ -> OptDescr a
-- | Create a string-valued command line interface.
reqArg :: Monoid b => ArgPlaceHolder -> ReadE b -> (b -> [String])
-> MkOptDescr (a -> b) (b -> a -> a) a
reqArg ad mkflag showflag sf lf d get set =
- ReqArg d (sf,lf) ad (fmap (\a b -> set (get b `mappend` a) b) mkflag) (showflag . get)
+ ReqArg d (sf,lf) ad (fmap (\a b -> set (get b `mappend` a) b) mkflag)
+ (showflag . get)
-- | Create a string-valued command line interface with a default value.
optArg :: Monoid b => ArgPlaceHolder -> ReadE b -> b -> (b -> [Maybe String])
@@ -176,8 +190,9 @@ reqArg' ad mkflag showflag =
reqArg ad (succeedReadE mkflag) showflag
-- | (String -> a) variant of "optArg"
-optArg' :: Monoid b => ArgPlaceHolder -> (Maybe String -> b) -> (b -> [Maybe String])
- -> MkOptDescr (a -> b) (b -> a -> a) a
+optArg' :: Monoid b => ArgPlaceHolder -> (Maybe String -> b)
+ -> (b -> [Maybe String])
+ -> MkOptDescr (a -> b) (b -> a -> a) a
optArg' ad mkflag showflag =
optArg ad (succeedReadE (mkflag . Just)) def showflag
where def = mkflag Nothing
@@ -185,34 +200,42 @@ optArg' ad mkflag showflag =
noArg :: (Eq b, Monoid 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 -> MkOptDescr (a -> b) (b -> a -> a) a
+boolOpt :: (b -> Maybe Bool) -> (Bool -> b) -> SFlags -> SFlags
+ -> MkOptDescr (a -> b) (b -> a -> a) a
boolOpt g s sfT sfF _sf _lf@(n:_) d get set =
BoolOpt d (sfT, ["enable-"++n]) (sfF, ["disable-"++n]) (set.s) (g.get)
-boolOpt _ _ _ _ _ _ _ _ _ = error "Distribution.Simple.Setup.boolOpt: unreachable"
+boolOpt _ _ _ _ _ _ _ _ _ = error
+ "Distribution.Simple.Setup.boolOpt: unreachable"
-boolOpt' :: (b -> Maybe Bool) -> (Bool -> b) -> OptFlags -> OptFlags -> MkOptDescr (a -> b) (b -> a -> a) a
+boolOpt' :: (b -> Maybe Bool) -> (Bool -> b) -> OptFlags -> OptFlags
+ -> MkOptDescr (a -> b) (b -> a -> a) a
boolOpt' g s ffT ffF _sf _lf d get set = BoolOpt d ffT ffF (set.s) (g . get)
-- | create a Choice option
-choiceOpt :: Eq b => [(b,OptFlags,Description)] -> MkOptDescr (a -> b) (b -> a -> a) a
+choiceOpt :: Eq b => [(b,OptFlags,Description)]
+ -> MkOptDescr (a -> b) (b -> a -> a) a
choiceOpt aa_ff _sf _lf _d get set = ChoiceOpt alts
where alts = [(d,flags, set alt, (==alt) . get) | (alt,flags,d) <- aa_ff]
-- | create a Choice option out of an enumeration type.
-- As long flags, the Show output is used. As short flags, the first character
-- which does not conflict with a previous one is used.
-choiceOptFromEnum :: (Bounded b, Enum b, Show b, Eq b) => MkOptDescr (a -> b) (b -> a -> a) a
-choiceOptFromEnum _sf _lf d get = choiceOpt [ (x, (sf, [map toLower $ show x]), d')
- | (x, sf) <- sflags'
- , let d' = d ++ show x]
- _sf _lf d get
- where sflags' = foldl f [] [firstOne..]
- f prev x = let prevflags = concatMap snd prev in
- prev ++ take 1 [(x, [toLower sf]) | sf <- show x, isAlpha sf
- , toLower sf `notElem` prevflags]
- firstOne = minBound `asTypeOf` get undefined
-
-commandGetOpts :: ShowOrParseArgs -> CommandUI flags -> [GetOpt.OptDescr (flags -> flags)]
+choiceOptFromEnum :: (Bounded b, Enum b, Show b, Eq b) =>
+ MkOptDescr (a -> b) (b -> a -> a) a
+choiceOptFromEnum _sf _lf d get =
+ choiceOpt [ (x, (sf, [map toLower $ show x]), d')
+ | (x, sf) <- sflags'
+ , let d' = d ++ show x]
+ _sf _lf d get
+ where sflags' = foldl f [] [firstOne..]
+ f prev x = let prevflags = concatMap snd prev in
+ prev ++ take 1 [(x, [toLower sf])
+ | sf <- show x, isAlpha sf
+ , toLower sf `notElem` prevflags]
+ firstOne = minBound `asTypeOf` get undefined
+
+commandGetOpts :: ShowOrParseArgs -> CommandUI flags
+ -> [GetOpt.OptDescr (flags -> flags)]
commandGetOpts showOrParse command =
concatMap viewAsGetOpt (commandOptions command showOrParse)
@@ -232,53 +255,72 @@ viewAsGetOpt (OptionField _n aa) = concatMap optDescrToGetOpt aa
[ GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) ("Enable " ++ d)
, GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) ("Disable " ++ d) ]
--- | to view as a FieldDescr, we sort the list of interfaces (Req > Bool > Choice > Opt) and consider only the first one.
+-- | to view as a FieldDescr, we sort the list of interfaces (Req > Bool >
+-- Choice > Opt) and consider only the first one.
viewAsFieldDescr :: OptionField a -> FieldDescr a
-viewAsFieldDescr (OptionField _n []) = error "Distribution.command.viewAsFieldDescr: unexpected"
+viewAsFieldDescr (OptionField _n []) =
+ error "Distribution.command.viewAsFieldDescr: unexpected"
viewAsFieldDescr (OptionField n dd) = FieldDescr n get set
- where optDescr = head $ sortBy cmp dd
- ReqArg{} `cmp` ReqArg{} = EQ
- ReqArg{} `cmp` _ = GT
- BoolOpt{} `cmp` ReqArg{} = LT
- BoolOpt{} `cmp` BoolOpt{} = EQ
- BoolOpt{} `cmp` _ = GT
- ChoiceOpt{} `cmp` ReqArg{} = LT
- ChoiceOpt{} `cmp` BoolOpt{} = LT
- ChoiceOpt{} `cmp` ChoiceOpt{} = EQ
- ChoiceOpt{} `cmp` _ = GT
- OptArg{} `cmp` OptArg{} = EQ
- OptArg{} `cmp` _ = LT
- get t = case optDescr of
- ReqArg _ _ _ _ ppr ->
- (cat . punctuate comma . map text . ppr) t
- OptArg _ _ _ _ _ ppr ->
- case ppr t of
- [] -> empty
+ where
+ optDescr = head $ sortBy cmp dd
+
+ cmp :: OptDescr a -> OptDescr a -> Ordering
+ ReqArg{} `cmp` ReqArg{} = EQ
+ ReqArg{} `cmp` _ = GT
+ BoolOpt{} `cmp` ReqArg{} = LT
+ BoolOpt{} `cmp` BoolOpt{} = EQ
+ BoolOpt{} `cmp` _ = GT
+ ChoiceOpt{} `cmp` ReqArg{} = LT
+ ChoiceOpt{} `cmp` BoolOpt{} = LT
+ ChoiceOpt{} `cmp` ChoiceOpt{} = EQ
+ ChoiceOpt{} `cmp` _ = GT
+ OptArg{} `cmp` OptArg{} = EQ
+ OptArg{} `cmp` _ = LT
+
+-- get :: a -> Doc
+ get t = case optDescr of
+ ReqArg _ _ _ _ ppr ->
+ (cat . punctuate comma . map text . ppr) t
+
+ OptArg _ _ _ _ _ ppr ->
+ case ppr t of [] -> empty
(Nothing : _) -> text "True"
(Just a : _) -> text a
- ChoiceOpt alts ->
- fromMaybe empty $ listToMaybe
- [ text lf | (_,(_,lf:_), _,enabled) <- alts, enabled t]
- BoolOpt _ _ _ _ enabled -> (maybe empty disp . enabled) t
- set line val a =
- case optDescr of
- ReqArg _ _ _ readE _ -> ($ a) `liftM` runE line n readE val
- -- We parse for a single value instead of a list,
- -- as one can't really implement parseList :: ReadE a -> ReadE [a]
- -- with the current ReadE definition
- ChoiceOpt{} -> case getChoiceByLongFlag optDescr val of
- Just f -> return (f a)
- _ -> syntaxError line val
- BoolOpt _ _ _ setV _ -> (`setV` a) `liftM` runP line n parse val
- OptArg _ _ _ readE _ _ -> ($ a) `liftM` runE line n readE val
- -- Optional arguments are parsed just like required arguments here;
- -- we don't provide a method to set an OptArg field to the default value.
+
+ ChoiceOpt alts ->
+ fromMaybe empty $ listToMaybe
+ [ text lf | (_,(_,lf:_), _,enabled) <- alts, enabled t]
+
+ BoolOpt _ _ _ _ enabled -> (maybe empty disp . enabled) t
+
+-- set :: LineNo -> String -> a -> ParseResult a
+ set line val a =
+ case optDescr of
+ ReqArg _ _ _ readE _ -> ($ a) `liftM` runE line n readE val
+ -- We parse for a single value instead of a
+ -- list, as one can't really implement
+ -- parseList :: ReadE a -> ReadE [a] with
+ -- the current ReadE definition
+ ChoiceOpt{} ->
+ case getChoiceByLongFlag optDescr val of
+ Just f -> return (f a)
+ _ -> syntaxError line val
+
+ BoolOpt _ _ _ setV _ -> (`setV` a) `liftM` runP line n parse val
+
+ OptArg _ _ _ readE _ _ -> ($ a) `liftM` runE line n readE val
+ -- Optional arguments are parsed just like
+ -- required arguments here; we don't
+ -- provide a method to set an OptArg field
+ -- to the default value.
getChoiceByLongFlag :: OptDescr b -> String -> Maybe (b->b)
-getChoiceByLongFlag (ChoiceOpt alts) val = listToMaybe [ set | (_,(_sf,lf:_), set, _) <- alts
- , lf == val]
+getChoiceByLongFlag (ChoiceOpt alts) val = listToMaybe
+ [ set | (_,(_sf,lf:_), set, _) <- alts
+ , lf == val]
-getChoiceByLongFlag _ _ = error "Distribution.command.getChoiceByLongFlag: expected a choice option"
+getChoiceByLongFlag _ _ =
+ error "Distribution.command.getChoiceByLongFlag: expected a choice option"
getCurrentChoice :: OptDescr a -> a -> [String]
getCurrentChoice (ChoiceOpt alts) a =
@@ -288,7 +330,8 @@ getCurrentChoice _ _ = error "Command.getChoice: expected a Choice OptDescr"
liftOption :: (b -> a) -> (a -> (b -> b)) -> OptionField a -> OptionField b
-liftOption get' set' opt = opt { optionDescr = liftOptDescr get' set' `map` optionDescr opt}
+liftOption get' set' opt =
+ opt { optionDescr = liftOptDescr get' set' `map` optionDescr opt}
liftOptDescr :: (b -> a) -> (a -> (b -> b)) -> OptDescr a -> OptDescr b
@@ -297,7 +340,8 @@ liftOptDescr get' set' (ChoiceOpt opts) =
| (d, ff, set, get) <- opts]
liftOptDescr get' set' (OptArg d ff ad set def get) =
- OptArg d ff ad (liftSet get' set' `fmap` set) (liftSet get' set' def) (get . get')
+ OptArg d ff ad (liftSet get' set' `fmap` set)
+ (liftSet get' set' def) (get . get')
liftOptDescr get' set' (ReqArg d ff ad set get) =
ReqArg d ff ad (liftSet get' set' `fmap` set) (get . get')
@@ -497,7 +541,7 @@ commandsRun globalCommand commands args =
badCommand cname = CommandErrors ["unrecognised command: " ++ cname
++ " (try --help)\n"]
commands' = commands ++ [commandAddAction helpCommandUI undefined]
- commandNames = [ name | (Command name _ _ _) <- commands' ]
+ commandNames = [ name | (Command name _ _ NormalCommand) <- commands' ]
globalCommand' = globalCommand {
commandUsage = \pname ->
(case commandUsage globalCommand pname of
@@ -537,7 +581,7 @@ commandsRun globalCommand commands args =
where globalHelp = commandHelp globalCommand'
helpCommandUI =
- (makeCommand "help" "Help about commands" Nothing () (const [])) {
+ (makeCommand "help" "Help about commands." Nothing () (const [])) {
commandUsage = \pname ->
"Usage: " ++ pname ++ " help [FLAGS]\n"
++ " or: " ++ pname ++ " help COMMAND [FLAGS]\n\n"
diff --git a/cabal/Cabal/Distribution/Simple/Compiler.hs b/cabal/Cabal/Distribution/Simple/Compiler.hs
index 09a9cf9..d053da3 100644
--- a/cabal/Cabal/Distribution/Simple/Compiler.hs
+++ b/cabal/Cabal/Distribution/Simple/Compiler.hs
@@ -57,6 +57,8 @@ module Distribution.Simple.Compiler (
PackageDB(..),
PackageDBStack,
registrationPackageDB,
+ absolutePackageDBPaths,
+ absolutePackageDBPath,
-- * Support for optimisation levels
OptimisationLevel(..),
@@ -67,7 +69,8 @@ module Distribution.Simple.Compiler (
languageToFlags,
unsupportedLanguages,
extensionsToFlags,
- unsupportedExtensions
+ unsupportedExtensions,
+ parmakeSupported
) where
import Distribution.Compiler
@@ -75,13 +78,21 @@ import Distribution.Version (Version(..))
import Distribution.Text (display)
import Language.Haskell.Extension (Language(Haskell98), Extension)
+import Control.Monad (liftM)
import Data.List (nub)
+import qualified Data.Map as M (Map, lookup)
import Data.Maybe (catMaybes, isNothing)
+import System.Directory (canonicalizePath)
data Compiler = Compiler {
compilerId :: CompilerId,
+ -- ^ Compiler flavour and version.
compilerLanguages :: [(Language, Flag)],
- compilerExtensions :: [(Extension, Flag)]
+ -- ^ Supported language standards.
+ compilerExtensions :: [(Extension, Flag)],
+ -- ^ Supported extensions.
+ compilerProperties :: M.Map String String
+ -- ^ A key-value map for properties not covered by the above fields.
}
deriving (Show, Read)
@@ -135,6 +146,18 @@ registrationPackageDB :: PackageDBStack -> PackageDB
registrationPackageDB [] = error "internal error: empty package db set"
registrationPackageDB dbs = last dbs
+-- | Make package paths absolute
+
+
+absolutePackageDBPaths :: PackageDBStack -> IO PackageDBStack
+absolutePackageDBPaths = mapM absolutePackageDBPath
+
+absolutePackageDBPath :: PackageDB -> IO PackageDB
+absolutePackageDBPath GlobalPackageDB = return GlobalPackageDB
+absolutePackageDBPath UserPackageDB = return UserPackageDB
+absolutePackageDBPath (SpecificPackageDB db) =
+ SpecificPackageDB `liftM` canonicalizePath db
+
-- ------------------------------------------------------------
-- * Optimisation levels
-- ------------------------------------------------------------
@@ -192,3 +215,12 @@ extensionsToFlags comp = nub . filter (not . null)
extensionToFlag :: Compiler -> Extension -> Maybe Flag
extensionToFlag comp ext = lookup ext (compilerExtensions comp)
+
+-- | Does this compiler support parallel --make mode?
+parmakeSupported :: Compiler -> Bool
+parmakeSupported comp =
+ case compilerFlavor comp of
+ GHC -> case M.lookup "Support parallel --make" (compilerProperties comp) of
+ Just "YES" -> True
+ _ -> False
+ _ -> False
diff --git a/cabal/Cabal/Distribution/Simple/Configure.hs b/cabal/Cabal/Distribution/Simple/Configure.hs
index e92887b..f1024dd 100644
--- a/cabal/Cabal/Distribution/Simple/Configure.hs
+++ b/cabal/Cabal/Distribution/Simple/Configure.hs
@@ -54,26 +54,35 @@ module Distribution.Simple.Configure (configure,
writePersistBuildConfig,
getPersistBuildConfig,
checkPersistBuildConfigOutdated,
+ tryGetPersistBuildConfig,
maybeGetPersistBuildConfig,
localBuildInfoFile,
- getInstalledPackages,
+ getInstalledPackages, getPackageDBContents,
configCompiler, configCompilerAux,
+ configCompilerEx, configCompilerAuxEx,
ccLdOptionsBuildInfo,
- tryGetConfigStateFile,
checkForeignDeps,
interpretPackageDbFlags,
+
+ ConfigStateFileErrorType(..),
+ ConfigStateFileError,
+ tryGetConfigStateFile,
+ platformDefines,
)
where
+import Distribution.Compiler
+ ( CompilerId(..) )
import Distribution.Simple.Compiler
( CompilerFlavor(..), Compiler(compilerId), compilerFlavor, compilerVersion
, showCompilerId, unsupportedLanguages, unsupportedExtensions
, PackageDB(..), PackageDBStack )
+import Distribution.Simple.PreProcess ( platformDefines )
import Distribution.Package
( PackageName(PackageName), PackageIdentifier(..), PackageId
, packageName, packageVersion, Package(..)
, Dependency(Dependency), simplifyDependency
- , InstalledPackageId(..) )
+ , InstalledPackageId(..), thisPackageVersion )
import Distribution.InstalledPackageInfo as Installed
( InstalledPackageInfo, InstalledPackageInfo_(..)
, emptyInstalledPackageInfo )
@@ -83,7 +92,7 @@ import Distribution.PackageDescription as PD
( PackageDescription(..), specVersion, GenericPackageDescription(..)
, Library(..), hasLibs, Executable(..), BuildInfo(..), allExtensions
, HookedBuildInfo, updatePackageDescription, allBuildInfo
- , FlagName(..), TestSuite(..), Benchmark(..) )
+ , Flag(flagName), FlagName(..), TestSuite(..), Benchmark(..) )
import Distribution.PackageDescription.Configuration
( finalizePackageDescription, mapTreeData )
import Distribution.PackageDescription.Check
@@ -92,6 +101,7 @@ import Distribution.Simple.Hpc ( enableCoverage )
import Distribution.Simple.Program
( Program(..), ProgramLocation(..), ConfiguredProgram(..)
, ProgramConfiguration, defaultProgramConfiguration
+ , ProgramSearchPathEntry(..), getProgramSearchPath, setProgramSearchPath
, configureAllKnownPrograms, knownPrograms, lookupKnownProgram
, userSpecifyArgss, userSpecifyPaths
, requireProgram, requireProgramVersion
@@ -101,18 +111,21 @@ import Distribution.Simple.Setup
import Distribution.Simple.InstallDirs
( InstallDirs(..), defaultInstallDirs, combineInstallDirs )
import Distribution.Simple.LocalBuildInfo
- ( LocalBuildInfo(..), ComponentLocalBuildInfo(..)
+ ( LocalBuildInfo(..), Component(..), ComponentLocalBuildInfo(..)
+ , LibraryName(..)
, absoluteInstallDirs, prefixRelativeInstallDirs, inplacePackageId
- , allComponentsBy, Component(..), foldComponent, ComponentName(..) )
+ , ComponentName(..), showComponentName, pkgEnabledComponents
+ , componentBuildInfo, componentName, checkComponentsCyclic )
import Distribution.Simple.BuildPaths
( autogenModulesDir )
import Distribution.Simple.Utils
- ( die, warn, info, setupMessage, createDirectoryIfMissingVerbose
+ ( die, warn, info, setupMessage
+ , createDirectoryIfMissingVerbose, moreRecentFile
, intercalate, cabalVersion
, withFileContents, writeFileAtomic
, withTempFile )
import Distribution.System
- ( OS(..), buildOS, Arch(..), buildArch, buildPlatform )
+ ( OS(..), buildOS, Platform, buildPlatform )
import Distribution.Version
( Version(..), anyVersion, orLaterVersion, withinRange, isAnyVersion )
import Distribution.Verbosity
@@ -124,56 +137,65 @@ 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.HaskellSuite as HaskellSuite
import Control.Monad
- ( when, unless, foldM, filterM, forM )
+ ( when, unless, foldM, filterM )
import Data.List
- ( nub, partition, isPrefixOf, inits, find )
+ ( (\\), nub, partition, isPrefixOf, inits )
import Data.Maybe
- ( isNothing, catMaybes, mapMaybe )
+ ( isNothing, catMaybes, fromMaybe )
import Data.Monoid
( Monoid(..) )
-import Data.Graph
- ( SCC(..), graphFromEdges, transposeG, vertices, stronglyConnCompR )
+import qualified Data.Map as Map
+import Data.Map (Map)
import System.Directory
- ( doesFileExist, getModificationTime, createDirectoryIfMissing, getTemporaryDirectory )
-import System.Exit
- ( ExitCode(..), exitWith )
+ ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory )
import System.FilePath
( (</>), isAbsolute )
import qualified System.Info
( compilerName, compilerVersion )
import System.IO
- ( hPutStrLn, stderr, hClose )
+ ( hPutStrLn, hClose )
import Distribution.Text
( Text(disp), display, simpleParse )
import Text.PrettyPrint
- ( comma, punctuate, render, nest, sep )
+ ( render, (<>), ($+$), char, text, comma
+ , quotes, punctuate, nest, sep, hsep )
import Distribution.Compat.Exception ( catchExit, catchIO )
import qualified Data.ByteString.Lazy.Char8 as BS.Char8
-tryGetConfigStateFile :: (Read a) => FilePath -> IO (Either String a)
+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)
+ then return (Left (missing, ConfigStateFileMissing))
else withFileContents filename $ \str ->
case lines str of
- [headder, rest] -> case checkHeader headder of
- Just msg -> return (Left msg)
+ [header, rest] -> case checkHeader header of
+ Just err -> return (Left err)
Nothing -> case reads rest of
[(bi,_)] -> return (Right bi)
- _ -> return (Left cantParse)
- _ -> return (Left cantParse)
+ _ -> return (Left (cantParse, ConfigStateFileCantParse))
+ _ -> return (Left (cantParse, ConfigStateFileCantParse))
where
- checkHeader :: String -> Maybe String
+ checkHeader :: String -> Maybe ConfigStateFileError
checkHeader header = case parseHeader header of
Just (cabalId, compId)
| cabalId
== currentCabalId -> Nothing
- | otherwise -> Just (badVersion cabalId compId)
- Nothing -> Just cantParse
+ | 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. "
@@ -191,8 +213,9 @@ tryGetConfigStateFile filename = do
++ display currentCompilerId
++ ") which is probably the cause of the problem."
--- internal function
-tryGetPersistBuildConfig :: FilePath -> IO (Either String LocalBuildInfo)
+-- |Try to read the 'localBuildInfoFile'.
+tryGetPersistBuildConfig :: FilePath
+ -> IO (Either ConfigStateFileError LocalBuildInfo)
tryGetPersistBuildConfig distPref
= tryGetConfigStateFile (localBuildInfoFile distPref)
@@ -202,7 +225,7 @@ tryGetPersistBuildConfig distPref
getPersistBuildConfig :: FilePath -> IO LocalBuildInfo
getPersistBuildConfig distPref = do
lbi <- tryGetPersistBuildConfig distPref
- either die return lbi
+ either (die . fst) return lbi
-- |Try to read the 'localBuildInfoFile'.
maybeGetPersistBuildConfig :: FilePath -> IO (Maybe LocalBuildInfo)
@@ -251,9 +274,7 @@ parseHeader header = case words header of
-- .cabal file.
checkPersistBuildConfigOutdated :: FilePath -> FilePath -> IO Bool
checkPersistBuildConfigOutdated distPref pkg_descr_file = do
- t0 <- getModificationTime pkg_descr_file
- t1 <- getModificationTime $ localBuildInfoFile distPref
- return (t0 > t1)
+ pkg_descr_file `moreRecentFile` (localBuildInfoFile distPref)
-- |@dist\/setup-config@
localBuildInfoFile :: FilePath -> FilePath
@@ -276,15 +297,13 @@ configure (pkg_descr0, pbi) cfg
createDirectoryIfMissingVerbose (lessVerbose verbosity) True distPref
- let programsConfig = userSpecifyArgss (configProgramArgs cfg)
- . userSpecifyPaths (configProgramPaths cfg)
- $ configPrograms cfg
- userInstall = fromFlag (configUserInstall cfg)
- packageDbs = interpretPackageDbFlags userInstall
- (configPackageDBs cfg)
+ let programsConfig = mkProgramsConfig cfg (configPrograms cfg)
+ userInstall = fromFlag (configUserInstall cfg)
+ packageDbs = interpretPackageDbFlags userInstall
+ (configPackageDBs cfg)
-- detect compiler
- (comp, programsConfig') <- configCompiler
+ (comp, compPlatform, programsConfig') <- configCompilerEx
(flagToMaybe $ configHcFlavor cfg)
(flagToMaybe $ configHcPath cfg) (flagToMaybe $ configHcPkg cfg)
programsConfig (lessVerbose verbosity)
@@ -312,23 +331,49 @@ configure (pkg_descr0, pbi) cfg
-- package ID into an installed package id we can use
-- for the internal package set. The open-codes use of
-- InstalledPackageId . display here is a hack.
- Installed.installedPackageId = InstalledPackageId $ display $ pid,
+ Installed.installedPackageId =
+ InstalledPackageId $ display $ pid,
Installed.sourcePackageId = pid
}
internalPackageSet = PackageIndex.fromList [internalPackage]
installedPackageSet <- getInstalledPackages (lessVerbose verbosity) comp
packageDbs programsConfig'
- let -- Constraint test function for the solver
- dependencySatisfiable =
- not . null . PackageIndex.lookupDependency pkgs'
+ (allConstraints, requiredDepsMap) <- either die return $
+ combinedConstraints (configConstraints cfg)
+ (configDependencies cfg)
+ installedPackageSet
+
+ let exactConf = fromFlagOrDefault False (configExactConfiguration cfg)
+ -- Constraint test function for the solver
+ dependencySatisfiable d@(Dependency depName verRange)
+ | exactConf =
+ -- When we're given '--exact-configuration', we assume that all
+ -- dependencies and flags are exactly specified on the command
+ -- line. Thus we only consult the 'requiredDepsMap'. Note that
+ -- we're not doing the version range check, so if there's some
+ -- dependency that wasn't specified on the command line,
+ -- 'finalizePackageDescription' will fail.
+ --
+ -- TODO: mention '--exact-configuration' in the error message
+ -- when this fails?
+ (depName `Map.member` requiredDepsMap) || isInternalDep
+
+ | otherwise =
+ -- Normal operation: just look up dependency in the package
+ -- index.
+ not . null . PackageIndex.lookupDependency pkgs' $ d
where
pkgs' = PackageIndex.insert internalPackage installedPackageSet
+ isInternalDep = pkgName pid == depName
+ && pkgVersion pid `withinRange` verRange
enableTest t = t { testEnabled = fromFlag (configTests cfg) }
flaggedTests = map (\(n, t) -> (n, mapTreeData enableTest t))
(condTestSuites pkg_descr0)
- enableBenchmark bm = bm { benchmarkEnabled = fromFlag (configBenchmarks cfg) }
- flaggedBenchmarks = map (\(n, bm) -> (n, mapTreeData enableBenchmark bm))
+ enableBenchmark bm = bm { benchmarkEnabled =
+ fromFlag (configBenchmarks cfg) }
+ flaggedBenchmarks = map (\(n, bm) ->
+ (n, mapTreeData enableBenchmark bm))
(condBenchmarks pkg_descr0)
pkg_descr0'' = pkg_descr0 { condTestSuites = flaggedTests
, condBenchmarks = flaggedBenchmarks }
@@ -337,9 +382,9 @@ configure (pkg_descr0, pbi) cfg
case finalizePackageDescription
(configConfigurationsFlags cfg)
dependencySatisfiable
- Distribution.System.buildPlatform
+ compPlatform
(compilerId comp)
- (configConstraints cfg)
+ allConstraints
pkg_descr0''
of Right r -> return r
Left missing ->
@@ -348,6 +393,17 @@ configure (pkg_descr0, pbi) cfg
. map (disp . simplifyDependency)
$ missing)
+ -- Sanity check: if '--exact-configuration' was given, ensure that the
+ -- complete flag assignment was specified on the command line.
+ when exactConf $ do
+ let cmdlineFlags = map fst (configConfigurationsFlags cfg)
+ allFlags = map flagName . genPackageFlags $ pkg_descr0
+ diffFlags = allFlags \\ cmdlineFlags
+ when (not . null $ diffFlags) $
+ die $ "'--exact-conf' was given, "
+ ++ "but the following flags were not specified: "
+ ++ intercalate ", " (map show diffFlags)
+
-- add extra include/lib dirs as specified in cfg
-- we do it here so that those get checked too
let pkg_descr =
@@ -362,16 +418,23 @@ configure (pkg_descr0, pbi) cfg
checkPackageProblems verbosity pkg_descr0
(updatePackageDescription pbi pkg_descr)
- let selectDependencies =
+ let selectDependencies :: [Dependency] ->
+ ([FailedDependency], [ResolvedDependency])
+ selectDependencies =
(\xs -> ([ x | Left x <- xs ], [ x | Right x <- xs ]))
- . map (selectDependency internalPackageSet installedPackageSet)
+ . map (selectDependency internalPackageSet installedPackageSet
+ requiredDepsMap)
- (failedDeps, allPkgDeps) = selectDependencies (buildDepends pkg_descr)
+ (failedDeps, allPkgDeps) =
+ selectDependencies (buildDepends pkg_descr)
- internalPkgDeps = [ pkgid | InternalDependency _ pkgid <- allPkgDeps ]
- externalPkgDeps = [ pkg | ExternalDependency _ pkg <- allPkgDeps ]
+ internalPkgDeps = [ pkgid
+ | InternalDependency _ pkgid <- allPkgDeps ]
+ externalPkgDeps = [ pkg
+ | ExternalDependency _ pkg <- allPkgDeps ]
- when (not (null internalPkgDeps) && not (newPackageDepsBehaviour pkg_descr)) $
+ when (not (null internalPkgDeps)
+ && not (newPackageDepsBehaviour pkg_descr)) $
die $ "The field 'build-depends: "
++ intercalate ", " (map (display . packageName) internalPkgDeps)
++ "' refers to a library which is defined within the same "
@@ -396,9 +459,11 @@ configure (pkg_descr0, pbi) cfg
| (pkg, deps) <- broken ]
let pseudoTopPkg = emptyInstalledPackageInfo {
- Installed.installedPackageId = InstalledPackageId (display (packageId pkg_descr)),
+ Installed.installedPackageId =
+ InstalledPackageId (display (packageId pkg_descr)),
Installed.sourcePackageId = packageId pkg_descr,
- Installed.depends = map Installed.installedPackageId externalPkgDeps
+ Installed.depends =
+ map Installed.installedPackageId externalPkgDeps
}
case PackageIndex.dependencyInconsistencies
. PackageIndex.insert pseudoTopPkg
@@ -413,13 +478,21 @@ 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
defaultDirs (configInstallDirs cfg)
-- check languages and extensions
- let langlist = nub $ catMaybes $ map defaultLanguage (allBuildInfo pkg_descr)
+ let langlist = nub $ catMaybes $ map defaultLanguage
+ (allBuildInfo pkg_descr)
let langs = unsupportedLanguages comp langlist
when (not (null langs)) $
die $ "The package " ++ display (packageId pkg_descr0)
@@ -440,7 +513,8 @@ configure (pkg_descr0, pbi) cfg
[ buildTool
| let exeNames = map exeName (executables pkg_descr)
, bi <- allBuildInfo pkg_descr
- , buildTool@(Dependency (PackageName toolName) reqVer) <- buildTools bi
+ , buildTool@(Dependency (PackageName toolName) reqVer)
+ <- buildTools bi
, let isInternal =
toolName `elem` exeNames
-- we assume all internal build-tools are
@@ -465,66 +539,13 @@ configure (pkg_descr0, pbi) cfg
"--enable-split-objs; ignoring")
return False
- -- 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
- -- needs. Note, this only works because we cannot yet depend on two
- -- versions of the same package.
- let configLib lib = configComponent (libBuildInfo lib)
- configExe exe = (exeName exe, configComponent (buildInfo exe))
- configTest test = (testName test,
- configComponent(testBuildInfo test))
- configBenchmark bm = (benchmarkName bm,
- configComponent(benchmarkBuildInfo bm))
- configComponent bi = ComponentLocalBuildInfo {
- componentPackageDeps =
- if newPackageDepsBehaviour pkg_descr'
- then [ (installedPackageId pkg, packageId pkg)
- | pkg <- selectSubset bi externalPkgDeps ]
- ++ [ (inplacePackageId pkgid, pkgid)
- | pkgid <- selectSubset bi internalPkgDeps ]
- else [ (installedPackageId pkg, packageId pkg)
- | pkg <- externalPkgDeps ]
- }
- selectSubset :: Package pkg => BuildInfo -> [pkg] -> [pkg]
- selectSubset bi pkgs =
- [ pkg | pkg <- pkgs, packageName pkg `elem` names ]
- where
- names = [ name | Dependency name _ <- targetBuildDepends bi ]
-
- -- Obtains the intrapackage dependencies for the given component
- let ipDeps component =
- mapMaybe exeDepToComp (buildTools bi)
- ++ mapMaybe libDepToComp (targetBuildDepends bi)
- where
- bi = foldComponent libBuildInfo buildInfo testBuildInfo
- benchmarkBuildInfo component
- exeDepToComp (Dependency (PackageName name) _) =
- CExe `fmap` find ((==) name . exeName)
- (executables pkg_descr')
- libDepToComp (Dependency pn _)
- | pn `elem` map packageName internalPkgDeps =
- CLib `fmap` library pkg_descr'
- libDepToComp _ = Nothing
-
- let sccs = (stronglyConnCompR . map lkup . vertices . transposeG) g
- where (g, lkup, _) = graphFromEdges
- $ allComponentsBy pkg_descr'
- $ \c -> (c, key c, map key (ipDeps c))
- key = foldComponent (const "library") exeName
- testName benchmarkName
-
- -- check for cycles in the dependency graph
- buildOrder <- forM sccs $ \scc -> case scc of
- AcyclicSCC (c,_,_) -> return (foldComponent (const CLibName)
- (CExeName . exeName)
- (CTestName . testName)
- (CBenchName . benchmarkName)
- c)
- CyclicSCC vs ->
- die $ "Found cycle in intrapackage dependency graph:\n "
- ++ intercalate " depends on "
- (map (\(_,k,_) -> "'" ++ k ++ "'") (vs ++ [head vs]))
+ let sharedLibsByDefault =
+ 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
+ _ -> False
let lbi = LocalBuildInfo {
configFlags = cfg,
@@ -533,28 +554,27 @@ configure (pkg_descr0, pbi) cfg
-- did they would go here.
installDirTemplates = installDirs,
compiler = comp,
+ hostPlatform = compPlatform,
buildDir = buildDir',
scratchDir = fromFlagOrDefault
(distPref </> "scratch")
(configScratchDir cfg),
- libraryConfig = configLib `fmap` library pkg_descr',
- executableConfigs = configExe `fmap` executables pkg_descr',
- testSuiteConfigs = configTest `fmap` testSuites pkg_descr',
- benchmarkConfigs = configBenchmark `fmap` benchmarks pkg_descr',
- compBuildOrder = buildOrder,
+ componentsConfigs = buildComponents,
installedPkgs = packageDependsIndex,
pkgDescrFile = Nothing,
localPkgDescr = pkg_descr',
withPrograms = programsConfig''',
withVanillaLib = fromFlag $ configVanillaLib cfg,
withProfLib = fromFlag $ configProfLib cfg,
- withSharedLib = fromFlag $ configSharedLib cfg,
+ withSharedLib = fromFlagOrDefault sharedLibsByDefault $
+ configSharedLib cfg,
withDynExe = fromFlag $ configDynExe cfg,
withProfExe = fromFlag $ configProfExe cfg,
withOptimization = fromFlag $ configOptimization cfg,
withGHCiLib = fromFlag $ configGHCiLib cfg,
splitObjs = split_objs,
stripExes = fromFlag $ configStripExes cfg,
+ stripLibs = fromFlag $ configStripLibs cfg,
withPackageDB = packageDbs,
progPrefix = fromFlag $ configProgPrefix cfg,
progSuffix = fromFlag $ configProgSuffix cfg
@@ -584,6 +604,7 @@ configure (pkg_descr0, pbi) cfg
dirinfo "Private binaries" (libexecdir dirs) (libexecdir relative)
dirinfo "Data files" (datadir dirs) (datadir relative)
dirinfo "Documentation" (docdir dirs) (docdir relative)
+ dirinfo "Configuration files" (sysconfdir dirs) (sysconfdir relative)
sequence_ [ reportProgram verbosity prog configuredProg
| (prog, configuredProg) <- knownPrograms programsConfig''' ]
@@ -594,10 +615,23 @@ configure (pkg_descr0, pbi) cfg
addExtraIncludeLibDirs pkg_descr =
let extraBi = mempty { extraLibDirs = configExtraLibDirs cfg
, PD.includeDirs = configExtraIncludeDirs cfg}
- modifyLib l = l{ libBuildInfo = libBuildInfo l `mappend` extraBi }
- modifyExecutable e = e{ buildInfo = buildInfo e `mappend` extraBi}
+ modifyLib l = l{ libBuildInfo = libBuildInfo l
+ `mappend` extraBi }
+ modifyExecutable e = e{ buildInfo = buildInfo e
+ `mappend` extraBi}
in pkg_descr{ library = modifyLib `fmap` library pkg_descr
- , executables = modifyExecutable `map` executables pkg_descr}
+ , executables = modifyExecutable `map`
+ executables pkg_descr}
+
+mkProgramsConfig :: ConfigFlags -> ProgramConfiguration -> ProgramConfiguration
+mkProgramsConfig cfg initialProgramsConfig = programsConfig
+ where
+ programsConfig = userSpecifyArgss (configProgramArgs cfg)
+ . userSpecifyPaths (configProgramPaths cfg)
+ . setProgramSearchPath searchpath
+ $ initialProgramsConfig
+ searchpath = getProgramSearchPath (initialProgramsConfig)
+ ++ map ProgramSearchPathDir (configProgramPathExtra cfg)
-- -----------------------------------------------------------------------------
-- Configuring package dependencies
@@ -618,7 +652,8 @@ hackageUrl :: String
hackageUrl = "http://hackage.haskell.org/package/"
data ResolvedDependency = ExternalDependency Dependency InstalledPackageInfo
- | InternalDependency Dependency PackageId -- should be a lib name
+ | InternalDependency Dependency PackageId -- should be a
+ -- lib name
data FailedDependency = DependencyNotExists PackageName
| DependencyNoVersion Dependency
@@ -626,9 +661,11 @@ data FailedDependency = DependencyNotExists PackageName
-- | Test for a package dependency and record the version we have installed.
selectDependency :: PackageIndex -- ^ Internally defined packages
-> PackageIndex -- ^ Installed packages
+ -> Map PackageName InstalledPackageInfo
+ -- ^ Packages for which we have been given specific deps to use
-> Dependency
-> Either FailedDependency ResolvedDependency
-selectDependency internalIndex installedIndex
+selectDependency internalIndex installedIndex requiredDepsMap
dep@(Dependency pkgname vr) =
-- If the dependency specification matches anything in the internal package
-- index, then we prefer that match to anything in the second.
@@ -648,12 +685,15 @@ selectDependency internalIndex installedIndex
[(_,[pkg])] | packageVersion pkg `withinRange` vr
-> Right $ InternalDependency dep (packageId pkg)
- _ -> case PackageIndex.lookupDependency installedIndex dep of
- [] -> Left $ DependencyNotExists pkgname
- pkgs -> Right $ ExternalDependency dep $
- -- by default we just pick the latest
+ _ -> case Map.lookup pkgname requiredDepsMap of
+ -- If we know the exact pkg to use, then use it.
+ Just pkginstance -> Right (ExternalDependency dep pkginstance)
+ -- Otherwise we just pick an arbitrary instance of the latest version.
+ Nothing -> case PackageIndex.lookupDependency installedIndex dep of
+ [] -> Left $ DependencyNotExists pkgname
+ pkgs -> Right $ ExternalDependency dep $
case last pkgs of
- (_ver, instances) -> head instances -- the first preference
+ (_ver, pkginstances) -> head pkginstances
reportSelectedDependencies :: Verbosity
-> [ResolvedDependency] -> IO ()
@@ -697,9 +737,24 @@ getInstalledPackages verbosity comp packageDBs progconf = do
LHC -> LHC.getInstalledPackages verbosity packageDBs progconf
NHC -> NHC.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 "
++ display flv
+-- | Like 'getInstalledPackages', but for a single package DB.
+getPackageDBContents :: Verbosity -> Compiler
+ -> PackageDB -> ProgramConfiguration
+ -> IO PackageIndex
+getPackageDBContents verbosity comp packageDB progconf = do
+ info verbosity "Reading installed packages..."
+ case compilerFlavor comp of
+ GHC -> GHC.getPackageDBContents verbosity packageDB progconf
+
+ -- For other compilers, try to fall back on 'getInstalledPackages'.
+ _ -> getInstalledPackages verbosity comp [packageDB] progconf
+
+
-- | The user interface specifies the package dbs to use with a combination of
-- @--global@, @--user@ and @--package-db=global|user|clear|$file@.
-- This function combines the global/user flag and interprets the package-db
@@ -717,7 +772,8 @@ interpretPackageDbFlags userInstall specificDBs =
extra dbs' (Just db:dbs) = extra (dbs' ++ [db]) dbs
newPackageDepsBehaviourMinVersion :: Version
-newPackageDepsBehaviourMinVersion = Version { versionBranch = [1,7,1], versionTags = [] }
+newPackageDepsBehaviourMinVersion = Version { versionBranch = [1,7,1],
+ versionTags = [] }
-- 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
@@ -728,15 +784,91 @@ newPackageDepsBehaviour :: PackageDescription -> Bool
newPackageDepsBehaviour pkg =
specVersion pkg >= newPackageDepsBehaviourMinVersion
+-- We are given both --constraint="foo < 2.0" style constraints and also
+-- specific packages to pick via --dependency="foo=foo-2.0-177d5cdf20962d0581".
+--
+-- When finalising the package we have to take into account the specific
+-- installed deps we've been given, and the finalise function expects
+-- constraints, so we have to translate these deps into version constraints.
+--
+-- But after finalising we then have to make sure we pick the right specific
+-- deps in the end. So we still need to remember which installed packages to
+-- pick.
+combinedConstraints :: [Dependency] ->
+ [(PackageName, InstalledPackageId)] ->
+ PackageIndex ->
+ Either String ([Dependency],
+ Map PackageName InstalledPackageInfo)
+combinedConstraints constraints dependencies installedPackages = do
+
+ when (not (null badInstalledPackageIds)) $
+ Left $ render $ text "The following package dependencies were requested"
+ $+$ nest 4 (dispDependencies badInstalledPackageIds)
+ $+$ text "however the given installed package instance does not exist."
+
+ when (not (null badNames)) $
+ Left $ render $ text "The following package dependencies were requested"
+ $+$ nest 4 (dispDependencies badNames)
+ $+$ text "however the installed package's name does not match the name given."
+
+ --TODO: we don't check that all dependencies are used!
+
+ return (allConstraints, idConstraintMap)
+
+ where
+ allConstraints :: [Dependency]
+ allConstraints = constraints
+ ++ [ thisPackageVersion (packageId pkg)
+ | (_, _, Just pkg) <- dependenciesPkgInfo ]
+
+ idConstraintMap :: Map PackageName InstalledPackageInfo
+ idConstraintMap = Map.fromList
+ [ (packageName pkg, pkg)
+ | (_, _, Just pkg) <- dependenciesPkgInfo ]
+
+ -- The dependencies along with the installed package info, if it exists
+ dependenciesPkgInfo :: [(PackageName, InstalledPackageId,
+ Maybe InstalledPackageInfo)]
+ dependenciesPkgInfo =
+ [ (pkgname, ipkgid, mpkg)
+ | (pkgname, ipkgid) <- dependencies
+ , let mpkg = PackageIndex.lookupInstalledPackageId
+ installedPackages ipkgid
+ ]
+
+ -- If we looked up a package specified by an installed package id
+ -- (i.e. someone has written a hash) and didn't find it then it's
+ -- an error.
+ badInstalledPackageIds =
+ [ (pkgname, ipkgid)
+ | (pkgname, ipkgid, Nothing) <- dependenciesPkgInfo ]
+
+ -- If someone has written e.g.
+ -- --dependency="foo=MyOtherLib-1.0-07...5bf30" then they have
+ -- probably made a mistake.
+ badNames =
+ [ (requestedPkgName, ipkgid)
+ | (requestedPkgName, ipkgid, Just pkg) <- dependenciesPkgInfo
+ , let foundPkgName = packageName pkg
+ , requestedPkgName /= foundPkgName ]
+
+ dispDependencies deps =
+ hsep [ text "--dependency="
+ <> quotes (disp pkgname <> char '=' <> disp ipkgid)
+ | (pkgname, ipkgid) <- deps ]
+
-- -----------------------------------------------------------------------------
-- Configuring program dependencies
-configureRequiredPrograms :: Verbosity -> [Dependency] -> ProgramConfiguration -> IO ProgramConfiguration
+configureRequiredPrograms :: Verbosity -> [Dependency] -> ProgramConfiguration
+ -> IO ProgramConfiguration
configureRequiredPrograms verbosity deps conf =
foldM (configureRequiredProgram verbosity) conf deps
-configureRequiredProgram :: Verbosity -> ProgramConfiguration -> Dependency -> IO ProgramConfiguration
-configureRequiredProgram verbosity conf (Dependency (PackageName progName) verRange) =
+configureRequiredProgram :: Verbosity -> ProgramConfiguration -> Dependency
+ -> IO ProgramConfiguration
+configureRequiredProgram verbosity conf
+ (Dependency (PackageName progName) verRange) =
case lookupKnownProgram progName conf of
Nothing -> die ("Unknown build tool " ++ progName)
Just prog
@@ -837,32 +969,133 @@ ccLdOptionsBuildInfo cflags ldflags =
-- -----------------------------------------------------------------------------
-- Determining the compiler details
-configCompilerAux :: ConfigFlags -> IO (Compiler, ProgramConfiguration)
-configCompilerAux cfg = configCompiler (flagToMaybe $ configHcFlavor cfg)
- (flagToMaybe $ configHcPath cfg)
- (flagToMaybe $ configHcPkg cfg)
- programsConfig
- (fromFlag (configVerbosity cfg))
+configCompilerAuxEx :: ConfigFlags
+ -> IO (Compiler, Platform, ProgramConfiguration)
+configCompilerAuxEx cfg = configCompilerEx (flagToMaybe $ configHcFlavor cfg)
+ (flagToMaybe $ configHcPath cfg)
+ (flagToMaybe $ configHcPkg cfg)
+ programsConfig
+ (fromFlag (configVerbosity cfg))
where
- programsConfig = userSpecifyArgss (configProgramArgs cfg)
- . userSpecifyPaths (configProgramPaths cfg)
- $ defaultProgramConfiguration
-
+ programsConfig = mkProgramsConfig cfg defaultProgramConfiguration
+
+configCompilerEx :: Maybe CompilerFlavor -> Maybe FilePath -> Maybe FilePath
+ -> ProgramConfiguration -> Verbosity
+ -> IO (Compiler, Platform, ProgramConfiguration)
+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
+ HaskellSuite {} -> HaskellSuite.configure verbosity hcPath hcPkg conf
+ _ -> die "Unknown compiler"
+ return (comp, fromMaybe buildPlatform maybePlatform, programsConfig)
+
+-- Ideally we would like to not have separate configCompiler* and
+-- configCompiler*Ex sets of functions, but there are many custom setup scripts
+-- in the wild that are using them, so the versions with old types are kept for
+-- backwards compatibility. Platform was added to the return triple in 1.18.
+
+{-# DEPRECATED configCompiler
+ "'configCompiler' is deprecated. Use 'configCompilerEx' instead." #-}
configCompiler :: Maybe CompilerFlavor -> Maybe FilePath -> Maybe FilePath
-> ProgramConfiguration -> Verbosity
-> IO (Compiler, ProgramConfiguration)
-configCompiler Nothing _ _ _ _ = die "Unknown compiler"
-configCompiler (Just hcFlavor) hcPath hcPkg conf verbosity = do
- 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
- _ -> die "Unknown compiler"
+configCompiler mFlavor hcPath hcPkg conf verbosity =
+ fmap (\(a,_,b) -> (a,b)) $ configCompilerEx mFlavor hcPath hcPkg conf verbosity
+
+{-# DEPRECATED configCompilerAux
+ "configCompilerAux is deprecated. Use 'configCompilerAuxEx' instead." #-}
+configCompilerAux :: ConfigFlags
+ -> IO (Compiler, ProgramConfiguration)
+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 =
+ 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 ]
+ where
+ -- The dependencies for the given component
+ componentDeps component =
+ [ CExeName toolname | Dependency (PackageName toolname) _
+ <- buildTools bi
+ , toolname `elem` map exeName
+ (executables pkg_descr) ]
+
+ ++ [ CLibName | Dependency pkgname _ <- targetBuildDepends bi
+ , pkgname `elem` map packageName internalPkgDeps ]
+ where
+ bi = componentBuildInfo component
+
+ -- 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
+ -- needs. Note, this only works because we cannot yet depend on two
+ -- versions of the same package.
+ componentLocalBuildInfo component =
+ case component of
+ CLib _ ->
+ LibComponentLocalBuildInfo {
+ componentPackageDeps = cpds,
+ componentLibraries = [LibraryName
+ ("HS" ++ display (package pkg_descr))]
+ }
+ CExe _ ->
+ ExeComponentLocalBuildInfo {
+ componentPackageDeps = cpds
+ }
+ CTest _ ->
+ TestComponentLocalBuildInfo {
+ componentPackageDeps = cpds
+ }
+ CBench _ ->
+ BenchComponentLocalBuildInfo {
+ componentPackageDeps = cpds
+ }
+ where
+ bi = componentBuildInfo component
+ cpds = if newPackageDepsBehaviour pkg_descr
+ then [ (installedPackageId pkg, packageId pkg)
+ | pkg <- selectSubset bi externalPkgDeps ]
+ ++ [ (inplacePackageId pkgid, pkgid)
+ | pkgid <- selectSubset bi internalPkgDeps ]
+ else [ (installedPackageId pkg, packageId pkg)
+ | pkg <- externalPkgDeps ]
+
+ selectSubset :: Package pkg => BuildInfo -> [pkg] -> [pkg]
+ selectSubset bi pkgs =
+ [ pkg | pkg <- pkgs, packageName pkg `elem` names ]
+ where
+ names = [ name | Dependency name _ <- targetBuildDepends 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] ]
+
+
+-- -----------------------------------------------------------------------------
+-- Testing C lib and header dependencies
-- Try to build a test C program which includes every header and links every
-- lib. If that fails, try to narrow it down by preprocessing (only) and linking
@@ -871,7 +1104,8 @@ configCompiler (Just hcFlavor) hcPath hcPkg conf verbosity = do
-- TODO: produce a log file from the compiler errors, if any.
checkForeignDeps :: PackageDescription -> LocalBuildInfo -> Verbosity -> IO ()
checkForeignDeps pkg lbi verbosity = do
- ifBuildsWith allHeaders (commonCcArgs ++ makeLdArgs allLibs) -- I'm feeling lucky
+ ifBuildsWith allHeaders (commonCcArgs ++ makeLdArgs allLibs) -- I'm feeling
+ -- lucky
(return ())
(do missingLibs <- findMissingLibs
missingHdr <- findOffendingHdr
@@ -908,7 +1142,7 @@ checkForeignDeps pkg lbi verbosity = do
libExists lib = builds (makeProgram []) (makeLdArgs [lib])
- commonCppArgs = hcDefines (compiler lbi)
+ commonCppArgs = platformDefines lbi
++ [ "-I" ++ autogenModulesDir lbi ]
++ [ "-I" ++ dir | dir <- collectField PD.includeDirs ]
++ ["-I."]
@@ -1007,66 +1241,6 @@ checkForeignDeps pkg lbi verbosity = do
++ "You can re-run configure with the verbosity flag "
++ "-v3 to see the error messages from the C compiler."
- --FIXME: share this with the PreProcessor module
- hcDefines :: Compiler -> [String]
- hcDefines comp =
- case compilerFlavor comp of
- GHC ->
- let ghcOS = case buildOS of
- Linux -> ["linux"]
- Windows -> ["mingw32"]
- OSX -> ["darwin"]
- FreeBSD -> ["freebsd"]
- OpenBSD -> ["openbsd"]
- NetBSD -> ["netbsd"]
- Solaris -> ["solaris2"]
- AIX -> ["aix"]
- HPUX -> ["hpux"]
- IRIX -> ["irix"]
- HaLVM -> []
- OtherOS _ -> []
- ghcArch = case buildArch of
- I386 -> ["i386"]
- X86_64 -> ["x86_64"]
- PPC -> ["powerpc"]
- PPC64 -> ["powerpc64"]
- Sparc -> ["sparc"]
- Arm -> ["arm"]
- Mips -> ["mips"]
- SH -> []
- IA64 -> ["ia64"]
- S390 -> ["s390"]
- Alpha -> ["alpha"]
- Hppa -> ["hppa"]
- Rs6000 -> ["rs6000"]
- M68k -> ["m68k"]
- Vax -> ["vax"]
- OtherArch _ -> []
- in ["-D__GLASGOW_HASKELL__=" ++ versionInt version] ++
- map (\os -> "-D" ++ os ++ "_HOST_OS=1") ghcOS ++
- map (\arch -> "-D" ++ arch ++ "_HOST_ARCH=1") ghcArch
- JHC -> ["-D__JHC__=" ++ versionInt version]
- NHC -> ["-D__NHC__=" ++ versionInt version]
- Hugs -> ["-D__HUGS__"]
- _ -> []
- where
- version = compilerVersion comp
- -- TODO: move this into the compiler abstraction
- -- FIXME: this forces GHC's crazy 4.8.2 -> 408 convention on all
- -- the other compilers. Check if that's really what they want.
- versionInt :: Version -> String
- versionInt (Version { versionBranch = [] }) = "1"
- versionInt (Version { versionBranch = [n] }) = show n
- versionInt (Version { versionBranch = n1:n2:_ })
- = -- 6.8.x -> 608
- -- 6.10.x -> 610
- let s1 = show n1
- s2 = show n2
- middle = case s2 of
- _ : _ : _ -> ""
- _ -> "0"
- in s1 ++ middle ++ s2
-
-- | Output package check warnings and errors. Exit if any errors.
checkPackageProblems :: Verbosity
-> GenericPackageDescription
@@ -1079,5 +1253,4 @@ checkPackageProblems verbosity gpkg pkg = do
warnings = [ w | PackageBuildWarning w <- pureChecks ++ ioChecks ]
if null errors
then mapM_ (warn verbosity) warnings
- else do mapM_ (hPutStrLn stderr . ("Error: " ++)) errors
- exitWith (ExitFailure 1)
+ else die (intercalate "\n\n" errors)
diff --git a/cabal/Cabal/Distribution/Simple/GHC.hs b/cabal/Cabal/Distribution/Simple/GHC.hs
index 33fdfb6..cb3c661 100644
--- a/cabal/Cabal/Distribution/Simple/GHC.hs
+++ b/cabal/Cabal/Distribution/Simple/GHC.hs
@@ -61,25 +61,27 @@ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
module Distribution.Simple.GHC (
- configure, getInstalledPackages,
+ getGhcInfo,
+ configure, getInstalledPackages, getPackageDBContents,
buildLib, buildExe,
+ replLib, replExe,
+ startInterpreter,
installLib, installExe,
libAbiHash,
initPackageDB,
+ invokeHcPkg,
registerPackage,
componentGhcOptions,
ghcLibDir,
-
- -- * Deprecated
- ghcVerbosityOptions,
- ghcPackageDbOptions,
+ ghcDynamic,
) where
import qualified Distribution.Simple.GHC.IPI641 as IPI641
import qualified Distribution.Simple.GHC.IPI642 as IPI642
import Distribution.PackageDescription as PD
( PackageDescription(..), BuildInfo(..), Executable(..)
- , Library(..), libModules, hcOptions, usedExtensions, allExtensions )
+ , Library(..), libModules, exeModules, hcOptions
+ , usedExtensions, allExtensions )
import Distribution.InstalledPackageInfo
( InstalledPackageInfo )
import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
@@ -88,28 +90,33 @@ import Distribution.Simple.PackageIndex (PackageIndex)
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.LocalBuildInfo
( LocalBuildInfo(..), ComponentLocalBuildInfo(..)
- , absoluteInstallDirs )
+ , LibraryName(..), absoluteInstallDirs )
import Distribution.Simple.InstallDirs hiding ( absoluteInstallDirs )
import Distribution.Simple.BuildPaths
import Distribution.Simple.Utils
import Distribution.Package
- ( PackageIdentifier, Package(..), PackageName(..) )
+ ( Package(..), PackageName(..) )
import qualified Distribution.ModuleName as ModuleName
import Distribution.Simple.Program
- ( Program(..), ConfiguredProgram(..), ProgramConfiguration, ProgArg
- , ProgramLocation(..), rawSystemProgram
+ ( Program(..), ConfiguredProgram(..), ProgramConfiguration
+ , ProgramLocation(..), ProgramSearchPath, ProgramSearchPathEntry(..)
+ , rawSystemProgram
, rawSystemProgramStdout, rawSystemProgramStdoutConf
- , getProgramInvocationOutput
- , requireProgramVersion, requireProgram, getProgramOutput
+ , getProgramOutput, getProgramInvocationOutput, suppressOverrideArgs
+ , requireProgramVersion, requireProgram
, userMaybeSpecifyPath, programPath, lookupProgram, addKnownProgram
, ghcProgram, ghcPkgProgram, hsc2hsProgram
- , arProgram, ranlibProgram, ldProgram
+ , arProgram, ldProgram
, gccProgram, 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)
+import Distribution.Simple.Setup
+ ( toFlag, fromFlag, fromFlagOrDefault )
+import qualified Distribution.Simple.Setup as Cabal
+ ( Flag )
import Distribution.Simple.Compiler
( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion
, OptimisationLevel(..), PackageDB(..), PackageDBStack
@@ -121,27 +128,32 @@ import Distribution.System
import Distribution.Verbosity
import Distribution.Text
( display, simpleParse )
-import Language.Haskell.Extension (Language(..), Extension(..), KnownExtension(..))
+import Language.Haskell.Extension (Language(..), Extension(..)
+ ,KnownExtension(..))
-import Control.Monad ( unless, when, liftM )
+import Control.Monad ( unless, when )
import Data.Char ( isSpace )
import Data.List
-import Data.Maybe ( catMaybes, fromMaybe )
+import qualified Data.Map as M ( Map, fromList, lookup )
+import Data.Maybe ( catMaybes, fromMaybe, maybeToList )
import Data.Monoid ( Monoid(..) )
import System.Directory
- ( removeFile, getDirectoryContents, doesFileExist
- , getTemporaryDirectory )
+ ( getDirectoryContents, doesFileExist, getTemporaryDirectory )
import System.FilePath ( (</>), (<.>), takeExtension,
- takeDirectory, replaceExtension, splitExtension )
+ takeDirectory, replaceExtension,
+ splitExtension )
import System.IO (hClose, hPutStrLn)
import System.Environment (getEnv)
import Distribution.Compat.Exception (catchExit, catchIO)
+import Distribution.System (Platform, platformFromTriple)
+
-- -----------------------------------------------------------------------------
-- Configuring
configure :: Verbosity -> Maybe FilePath -> Maybe FilePath
- -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration)
+ -> ProgramConfiguration
+ -> IO (Compiler, Maybe Platform, ProgramConfiguration)
configure verbosity hcPath hcPkgPath conf0 = do
(ghcProg, ghcVersion, conf1) <-
@@ -172,23 +184,21 @@ configure verbosity hcPath hcPkgPath conf0 = do
languages <- getLanguages verbosity ghcProg
extensions <- getExtensions verbosity ghcProg
- ghcInfo <- if ghcVersion >= Version [6,7] []
- then do xs <- getProgramOutput verbosity ghcProg ["--info"]
- case reads xs of
- [(i, ss)]
- | all isSpace ss ->
- return i
- _ ->
- die "Can't parse --info output of GHC"
- else return []
+ ghcInfo <- getGhcInfo verbosity ghcProg
+ let ghcInfoMap = M.fromList ghcInfo
let comp = Compiler {
- compilerId = CompilerId GHC ghcVersion,
- compilerLanguages = languages,
- compilerExtensions = extensions
+ compilerId = CompilerId GHC ghcVersion,
+ compilerLanguages = languages,
+ compilerExtensions = extensions,
+ compilerProperties = ghcInfoMap
}
- conf4 = configureToolchain ghcProg ghcInfo conf3 -- configure gcc and ld
- return (comp, conf4)
+ compPlatform = targetPlatform ghcInfo
+ conf4 = configureToolchain ghcProg ghcInfoMap conf3 -- configure gcc and ld
+ 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
@@ -198,28 +208,36 @@ configure verbosity hcPath hcPkgPath conf0 = do
-- > /usr/local/bin/ghc-pkg-6.6.1(.exe)
-- > /usr/local/bin/ghc-pkg(.exe)
--
-guessToolFromGhcPath :: FilePath -> ConfiguredProgram -> Verbosity
+guessToolFromGhcPath :: Program -> ConfiguredProgram
+ -> Verbosity -> ProgramSearchPath
-> IO (Maybe FilePath)
-guessToolFromGhcPath tool ghcProg verbosity
- = do let path = programPath ghcProg
+guessToolFromGhcPath tool ghcProg verbosity searchpath
+ = do let toolname = programName tool
+ path = programPath ghcProg
dir = takeDirectory path
versionSuffix = takeVersionSuffix (dropExeExtension path)
- guessNormal = dir </> tool <.> exeExtension
- guessGhcVersioned = dir </> (tool ++ "-ghc" ++ versionSuffix) <.> exeExtension
- guessVersioned = dir </> (tool ++ versionSuffix) <.> exeExtension
+ guessNormal = dir </> toolname <.> exeExtension
+ guessGhcVersioned = dir </> (toolname ++ "-ghc" ++ versionSuffix)
+ <.> exeExtension
+ guessVersioned = dir </> (toolname ++ versionSuffix)
+ <.> exeExtension
guesses | null versionSuffix = [guessNormal]
| otherwise = [guessGhcVersioned,
guessVersioned,
guessNormal]
- info verbosity $ "looking for tool " ++ show tool ++ " near compiler in " ++ dir
+ info verbosity $ "looking for tool " ++ toolname
+ ++ " near compiler in " ++ dir
exists <- mapM doesFileExist guesses
case [ file | (file, True) <- zip guesses exists ] of
- [] -> return Nothing
- (fp:_) -> do info verbosity $ "found " ++ tool ++ " in " ++ fp
+ -- 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
+ takeVersionSuffix = reverse . takeWhile (`elem ` "0123456789.-") .
+ reverse
dropExeExtension :: FilePath -> FilePath
dropExeExtension filepath =
@@ -235,8 +253,9 @@ guessToolFromGhcPath tool ghcProg verbosity
-- > /usr/local/bin/ghc-pkg-6.6.1(.exe)
-- > /usr/local/bin/ghc-pkg(.exe)
--
-guessGhcPkgFromGhcPath :: ConfiguredProgram -> Verbosity -> IO (Maybe FilePath)
-guessGhcPkgFromGhcPath = guessToolFromGhcPath "ghc-pkg"
+guessGhcPkgFromGhcPath :: ConfiguredProgram
+ -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath)
+guessGhcPkgFromGhcPath = guessToolFromGhcPath ghcPkgProgram
-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a
-- corresponding hsc2hs, we try looking for both a versioned and unversioned
@@ -246,40 +265,29 @@ guessGhcPkgFromGhcPath = guessToolFromGhcPath "ghc-pkg"
-- > /usr/local/bin/hsc2hs-6.6.1(.exe)
-- > /usr/local/bin/hsc2hs(.exe)
--
-guessHsc2hsFromGhcPath :: ConfiguredProgram -> Verbosity -> IO (Maybe FilePath)
-guessHsc2hsFromGhcPath = guessToolFromGhcPath "hsc2hs"
+guessHsc2hsFromGhcPath :: ConfiguredProgram
+ -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath)
+guessHsc2hsFromGhcPath = guessToolFromGhcPath hsc2hsProgram
-- | Adjust the way we find and configure gcc and ld
--
-configureToolchain :: ConfiguredProgram -> [(String, String)]
+configureToolchain :: ConfiguredProgram -> M.Map String String
-> ProgramConfiguration
-> ProgramConfiguration
configureToolchain ghcProg ghcInfo =
addKnownProgram gccProgram {
- programFindLocation = findProg gccProgram
- [ if ghcVersion >= Version [6,12] []
- then mingwBinDir </> binPrefix ++ "gcc.exe"
- else baseDir </> "gcc.exe" ],
+ programFindLocation = findProg gccProgram extraGccPath,
programPostConf = configureGcc
}
. addKnownProgram ldProgram {
- programFindLocation = findProg ldProgram
- [ if ghcVersion >= Version [6,12] []
- then mingwBinDir </> binPrefix ++ "ld.exe"
- else libDir </> "ld.exe" ],
+ programFindLocation = findProg ldProgram extraLdPath,
programPostConf = configureLd
}
. addKnownProgram arProgram {
- programFindLocation = findProg arProgram
- [ if ghcVersion >= Version [6,12] []
- then mingwBinDir </> binPrefix ++ "ar.exe"
- else libDir </> "ar.exe" ]
+ programFindLocation = findProg arProgram extraArPath
}
. addKnownProgram stripProgram {
- programFindLocation = findProg stripProgram
- [ if ghcVersion >= Version [6,12] []
- then mingwBinDir </> binPrefix ++ "strip.exe"
- else libDir </> "strip.exe" ]
+ programFindLocation = findProg stripProgram extraStripPath
}
where
Just ghcVersion = programVersion ghcProg
@@ -291,36 +299,65 @@ configureToolchain ghcProg ghcInfo =
isWindows = case buildOS of Windows -> True; _ -> False
binPrefix = ""
- -- on Windows finding and configuring ghc's gcc and ld is a bit special
- findProg :: Program -> [FilePath] -> Verbosity -> IO (Maybe FilePath)
- findProg prog locations
- | isWindows = \verbosity -> look locations verbosity
- | otherwise = programFindLocation prog
+ mkExtraPath :: Maybe FilePath -> FilePath -> [FilePath]
+ mkExtraPath mbPath mingwPath | isWindows = mbDir ++ [mingwPath]
+ | otherwise = mbDir
where
- look [] verbosity = do
- warn verbosity ("Couldn't find " ++ programName prog ++ " where I expected it. Trying the search path.")
- programFindLocation prog verbosity
- look (f:fs) verbosity = do
- exists <- doesFileExist f
- if exists then return (Just f)
- else look fs verbosity
+ 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 lookup key ghcInfo of
+ 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 [ProgArg]
- configureGcc v cp = liftM (++ (ccFlags ++ gccLinkerFlags))
- $ configureGcc' v cp
+ configureGcc :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
+ configureGcc v gccProg = do
+ gccProg' <- configureGcc' v gccProg
+ return gccProg' {
+ programDefaultArgs = programDefaultArgs gccProg'
+ ++ ccFlags ++ gccLinkerFlags
+ }
- configureGcc' :: Verbosity -> ConfiguredProgram -> IO [ProgArg]
+ 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
@@ -330,20 +367,25 @@ configureToolchain ghcProg ghcInfo =
-- various files:
FoundOnSystem {}
| ghcVersion < Version [6,11] [] ->
- return ["-B" ++ libDir, "-I" ++ includeDir]
- _ -> return []
- | otherwise = \_ _ -> return []
-
- configureLd :: Verbosity -> ConfiguredProgram -> IO [ProgArg]
- configureLd v cp = liftM (++ ldLinkerFlags) $ configureLd' v cp
+ 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 [ProgArg]
+ 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() {}"
+ hPutStrLn testchnd "int foo() { return 0; }"
hClose testchnd; hClose testohnd
rawSystemProgram verbosity ghcProg ["-c", testcfile,
"-o", testofile]
@@ -356,8 +398,8 @@ configureToolchain ghcProg ghcInfo =
`catchIO` (\_ -> return False)
`catchExit` (\_ -> return False)
if ldx
- then return ["-x"]
- else return []
+ then return ldProg { programDefaultArgs = ["-x"] }
+ else return ldProg
getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, Flag)]
getLanguages _ ghcProg
@@ -368,11 +410,27 @@ getLanguages _ ghcProg
where
Just ghcVersion = programVersion ghcProg
+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 <- rawSystemStdout verbosity (programPath ghcProg)
+ str <- getProgramOutput verbosity (suppressOverrideArgs ghcProg)
["--supported-languages"]
let extStrs = if ghcVersion >= Version [7] []
then lines str
@@ -467,24 +525,24 @@ oldLanguageExtensions =
,(DeriveDataTypeable , fglasgowExts)
,(ConstrainedClassMethods , fglasgowExts)
]
-
+-- | Given a single package DB, return all installed packages.
+getPackageDBContents :: Verbosity -> PackageDB -> ProgramConfiguration
+ -> IO PackageIndex
+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
checkPackageDbEnvVar
checkPackageDbStack packagedbs
pkgss <- getInstalledPackages' verbosity packagedbs conf
- topDir <- ghcLibDir' verbosity ghcProg
- let indexes = [ PackageIndex.fromList (map (substTopDir topDir) pkgs)
- | (_, pkgs) <- pkgss ]
- return $! hackRtsPackage (mconcat indexes)
+ index <- toPackageIndex verbosity pkgss conf
+ return $! hackRtsPackage index
where
- -- 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
- Just ghcProg = lookupProgram ghcProgram conf
-
hackRtsPackage index =
case PackageIndex.lookupPackageName index (PackageName "rts") of
[(_,[rts])]
@@ -492,10 +550,30 @@ getInstalledPackages verbosity packagedbs conf = do
_ -> index -- No (or multiple) ghc rts package is registered!!
-- Feh, whatever, the ghc testsuite does some crazy stuff.
+-- | Given a list of @(PackageDB, InstalledPackageInfo)@ pairs, produce a
+-- @PackageIndex@. Helper function used by 'getPackageDBContents' and
+-- 'getInstalledPackages'.
+toPackageIndex :: Verbosity
+ -> [(PackageDB, [InstalledPackageInfo])]
+ -> ProgramConfiguration
+ -> IO PackageIndex
+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)
+ | (_, pkgs) <- pkgss ]
+ return $! (mconcat indices)
+
+ where
+ Just ghcProg = lookupProgram ghcProgram conf
+
ghcLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath
ghcLibDir verbosity lbi =
(reverse . dropWhile isSpace . reverse) `fmap`
- rawSystemProgramStdoutConf verbosity ghcProgram (withPrograms lbi) ["--print-libdir"]
+ rawSystemProgramStdoutConf verbosity ghcProgram
+ (withPrograms lbi) ["--print-libdir"]
ghcLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath
ghcLibDir' verbosity ghcProg =
@@ -607,33 +685,55 @@ substTopDir topDir ipo
-- | Build a library with GHC.
--
-buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo
- -> Library -> ComponentLocalBuildInfo -> IO ()
-buildLib verbosity pkg_descr lbi lib clbi = do
- let pref = buildDir lbi
+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 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
- ifVanillaLib forceVanilla = when (forceVanilla || withVanillaLib lbi)
- ifProfLib = when (withProfLib lbi)
- ifSharedLib = when (withSharedLib lbi)
- ifGHCiLib = when (withGHCiLib lbi && withVanillaLib 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
ghcVersion = compilerVersion comp
(ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi)
- let runGhcProg = runGHC verbosity ghcProg
+ let runGhcProg = runGHC verbosity ghcProg comp
libBi <- hackThreadedFlag verbosity
comp (withProfLib lbi) (libBuildInfo lib)
- let libTargetDir = pref
- forceVanillaLib = EnableExtension TemplateHaskell `elem` allExtensions libBi
- -- TH always needs vanilla libs, even when building for profiling
+ let isGhcDynamic = ghcDynamic comp
+ dynamicTooSupported = ghcSupportsDynamicToo comp
+ doingTH = EnableExtension TemplateHaskell `elem` allExtensions libBi
+ forceVanillaLib = doingTH && not isGhcDynamic
+ forceSharedLib = doingTH && isGhcDynamic
+ -- TH always needs default libs, even when building for profiling
createDirectoryIfMissingVerbose verbosity True libTargetDir
- -- TODO: do we need to put hs-boot files into place for mutually recurive modules?
- let baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir
+ -- TODO: do we need to put hs-boot files into place for mutually recursive
+ -- modules?
+ let cObjs = map (`replaceExtension` objExtension) (cSources libBi)
+ baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir
vanillaOpts = baseOpts `mappend` mempty {
ghcOptMode = toFlag GhcModeMake,
+ ghcOptNumJobs = toFlag numJobs,
ghcOptPackageName = toFlag pkgid,
ghcOptInputModules = libModules lib
}
@@ -646,49 +746,91 @@ buildLib verbosity pkg_descr lbi lib clbi = do
}
sharedOpts = vanillaOpts `mappend` mempty {
- ghcOptDynamic = toFlag True,
- ghcOptFPic = toFlag True,
- ghcOptHiSuffix = toFlag "dyn_hi",
- ghcOptObjSuffix = toFlag "dyn_o",
- ghcOptExtra = ghcSharedOptions libBi
+ ghcOptDynLinkMode = toFlag GhcDynamicOnly,
+ ghcOptFPic = toFlag True,
+ ghcOptHiSuffix = toFlag "dyn_hi",
+ ghcOptObjSuffix = toFlag "dyn_o",
+ ghcOptExtra = ghcSharedOptions libBi
+ }
+ linkerOpts = mempty {
+ ghcOptLinkOptions = PD.ldOptions libBi,
+ ghcOptLinkLibs = extraLibs libBi,
+ ghcOptLinkLibPath = extraLibDirs libBi,
+ ghcOptLinkFrameworks = PD.frameworks libBi,
+ ghcOptInputFiles = [libTargetDir </> x | x <- cObjs]
+ }
+ replOpts = vanillaOpts {
+ ghcOptExtra = 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"
}
unless (null (libModules lib)) $
- do ifVanillaLib forceVanillaLib (runGhcProg vanillaOpts)
- ifProfLib (runGhcProg profOpts)
- ifSharedLib (runGhcProg sharedOpts)
+ do let vanilla = whenVanillaLib forceVanillaLib (runGhcProg vanillaOpts)
+ shared = whenSharedLib forceSharedLib (runGhcProg sharedOpts)
+ useDynToo = dynamicTooSupported &&
+ (forceVanillaLib || withVanillaLib lbi) &&
+ (forceSharedLib || withSharedLib lbi) &&
+ null (ghcSharedOptions libBi)
+ if useDynToo
+ then runGhcProg vanillaSharedOpts
+ 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 pref filename) `mappend` mempty {
- ghcOptProfilingMode = toFlag (withProfLib lbi)
+ libBi clbi libTargetDir filename)
+ profCcOpts = vanillaCcOpts `mappend` mempty {
+ ghcOptProfilingMode = toFlag True,
+ ghcOptObjSuffix = toFlag "p_o"
}
sharedCcOpts = vanillaCcOpts `mappend` mempty {
- ghcOptFPic = toFlag True,
- ghcOptDynamic = toFlag True,
- ghcOptObjSuffix = toFlag "dyn_o"
+ ghcOptFPic = toFlag True,
+ ghcOptDynLinkMode = toFlag GhcDynamicOnly,
+ ghcOptObjSuffix = toFlag "dyn_o"
}
odir = fromFlag (ghcOptObjDir vanillaCcOpts)
createDirectoryIfMissingVerbose verbosity True odir
runGhcProg vanillaCcOpts
- ifSharedLib (runGhcProg sharedCcOpts)
+ whenSharedLib forceSharedLib (runGhcProg sharedCcOpts)
+ 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)
+
+
-- link:
info verbosity "Linking..."
- let cObjs = map (`replaceExtension` objExtension) (cSources libBi)
- cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) (cSources libBi)
- vanillaLibFilePath = libTargetDir </> mkLibName pkgid
- profileLibFilePath = libTargetDir </> mkProfLibName pkgid
- sharedLibFilePath = libTargetDir </> mkSharedLibName pkgid
- (compilerId (compiler lbi))
- ghciLibFilePath = libTargetDir </> mkGHCiLibName pkgid
+ 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 pkgid
- (compilerId (compiler lbi))
+ sharedLibInstallPath = libInstallPath </> mkSharedLibName cid libName
stubObjs <- fmap catMaybes $ sequence
[ findFileWithExtension [objExtension] [libTargetDir]
@@ -707,40 +849,35 @@ buildLib verbosity pkg_descr lbi lib clbi = do
, x <- libModules lib ]
hObjs <- getHaskellObjects lib lbi
- pref objExtension True
+ libTargetDir objExtension True
hProfObjs <-
if (withProfLib lbi)
then getHaskellObjects lib lbi
- pref ("p_" ++ objExtension) True
+ libTargetDir ("p_" ++ objExtension) True
else return []
hSharedObjs <-
if (withSharedLib lbi)
then getHaskellObjects lib lbi
- pref ("dyn_" ++ objExtension) False
+ libTargetDir ("dyn_" ++ objExtension) False
else return []
unless (null hObjs && null cObjs && null stubObjs) $ do
- -- first remove library files if they exists
- sequence_
- [ removeFile libFilePath `catchIO` \_ -> return ()
- | libFilePath <- [vanillaLibFilePath, profileLibFilePath
- ,sharedLibFilePath, ghciLibFilePath] ]
let staticObjectFiles =
hObjs
- ++ map (pref </>) cObjs
+ ++ map (libTargetDir </>) cObjs
++ stubObjs
profObjectFiles =
hProfObjs
- ++ map (pref </>) cObjs
+ ++ map (libTargetDir </>) cProfObjs
++ stubProfObjs
ghciObjFiles =
hObjs
- ++ map (pref </>) cObjs
+ ++ map (libTargetDir </>) cObjs
++ stubObjs
dynamicObjectFiles =
hSharedObjs
- ++ map (pref </>) cSharedObjs
+ ++ map (libTargetDir </>) cSharedObjs
++ stubSharedObjs
-- After the relocation lib is created we invoke ghc -shared
-- with the dependencies spelled out as -package arguments
@@ -748,7 +885,7 @@ buildLib verbosity pkg_descr lbi lib clbi = do
ghcSharedLinkArgs =
mempty {
ghcOptShared = toFlag True,
- ghcOptDynamic = toFlag True,
+ ghcOptDynLinkMode = toFlag GhcDynamicOnly,
ghcOptInputFiles = dynamicObjectFiles,
ghcOptOutputFile = toFlag sharedLibFilePath,
-- For dynamic libs, Mac OS/X needs to know the install location
@@ -764,102 +901,192 @@ buildLib verbosity pkg_descr lbi lib clbi = do
ghcOptLinkLibPath = extraLibDirs libBi
}
- ifVanillaLib False $ do
- (arProg, _) <- requireProgram verbosity arProgram (withPrograms lbi)
- Ar.createArLibArchive verbosity arProg
+ whenVanillaLib False $ do
+ Ar.createArLibArchive verbosity (withPrograms lbi) (stripLibs lbi)
vanillaLibFilePath staticObjectFiles
- ifProfLib $ do
- (arProg, _) <- requireProgram verbosity arProgram (withPrograms lbi)
- Ar.createArLibArchive verbosity arProg
+ whenProfLib $ do
+ Ar.createArLibArchive verbosity (withPrograms lbi) (stripLibs lbi)
profileLibFilePath profObjectFiles
- ifGHCiLib $ do
+ whenGHCiLib $ do
(ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi)
Ld.combineObjectFiles verbosity ldProg
ghciLibFilePath ghciObjFiles
- ifSharedLib $
+ whenSharedLib False $
runGhcProg 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
+ (ghcProg, _) <- requireProgram verbosity ghcProgram conf
+ runGHC verbosity ghcProg comp replOpts
-- | Build an executable with GHC.
--
-buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo
- -> Executable -> ComponentLocalBuildInfo -> IO ()
-buildExe verbosity _pkg_descr lbi
+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 numJobsFlag _pkg_descr lbi
exe@Executable { exeName = exeName', modulePath = modPath } clbi = do
- let pref = buildDir lbi
(ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi)
- let runGhcProg = runGHC verbosity ghcProg
+ let comp = compiler lbi
+ numJobs = fromMaybe 1 $
+ fromFlagOrDefault Nothing numJobsFlag
+ runGhcProg = runGHC verbosity ghcProg comp
exeBi <- hackThreadedFlag verbosity
- (compiler lbi) (withProfExe lbi) (buildInfo exe)
+ comp (withProfExe lbi) (buildInfo exe)
-- exeNameReal, the name that GHC really uses (with .exe on Windows)
let exeNameReal = exeName' <.>
- (if null $ takeExtension exeName' then exeExtension else "")
+ (if takeExtension exeName' /= ('.':exeExtension)
+ then exeExtension
+ else "")
- let targetDir = pref </> exeName'
+ 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?
+ -- TODO: do we need to put hs-boot files into place for mutually recursive
+ -- modules? FIX: what about exeName.hi-boot?
-- build executables
- unless (null (cSources exeBi)) $ do
- info verbosity "Building C Sources."
- sequence_
- [ do let opts = (componentCcGhcOptions verbosity lbi exeBi clbi
- exeDir filename) `mappend` mempty {
- ghcOptDynamic = toFlag (withDynExe lbi),
- ghcOptProfilingMode = toFlag (withProfExe lbi)
- }
- odir = fromFlag (ghcOptObjDir opts)
- createDirectoryIfMissingVerbose verbosity True odir
- runGhcProg opts
- | filename <- cSources exeBi]
- srcMainFile <- findFile (exeDir : hsSourceDirs exeBi) modPath
-
- let cObjs = map (`replaceExtension` objExtension) (cSources exeBi)
- let vanillaOpts = (componentGhcOptions verbosity lbi exeBi clbi exeDir)
+ srcMainFile <- findFile (exeDir : hsSourceDirs exeBi) modPath
+ let isGhcDynamic = ghcDynamic comp
+ dynamicTooSupported = ghcSupportsDynamicToo 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 = [exeDir </> x | x <- cObjs]
- ++ [srcMainFile],
- ghcOptLinkOptions = PD.ldOptions exeBi,
- ghcOptLinkLibs = extraLibs exeBi,
- ghcOptLinkLibPath = extraLibDirs exeBi,
- ghcOptLinkFrameworks = PD.frameworks exeBi
+ ghcOptMode = toFlag GhcModeMake,
+ ghcOptInputFiles =
+ [ srcMainFile | isHaskellMain],
+ ghcOptInputModules =
+ [ m | not isHaskellMain, m <- exeModules exe]
}
-
- exeOpts | withProfExe lbi = vanillaOpts `mappend` mempty {
+ staticOpts = baseOpts `mappend` mempty {
+ ghcOptDynLinkMode = toFlag GhcStaticOnly
+ }
+ profOpts = baseOpts `mappend` mempty {
ghcOptProfilingMode = toFlag True,
ghcOptHiSuffix = toFlag "p_hi",
ghcOptObjSuffix = toFlag "p_o",
ghcOptExtra = ghcProfOptions exeBi
}
- | withDynExe lbi = vanillaOpts `mappend` mempty {
- ghcOptDynamic = toFlag True,
+ dynOpts = baseOpts `mappend` mempty {
+ ghcOptDynLinkMode = toFlag GhcDynamicOnly,
ghcOptHiSuffix = toFlag "dyn_hi",
ghcOptObjSuffix = toFlag "dyn_o",
ghcOptExtra = ghcSharedOptions exeBi
}
- | otherwise = vanillaOpts
+ dynTooOpts = staticOpts `mappend` mempty {
+ ghcOptDynLinkMode = toFlag GhcStaticAndDynamic,
+ ghcOptDynHiSuffix = toFlag "dyn_hi",
+ ghcOptDynObjSuffix = toFlag "dyn_o"
+ }
+ linkerOpts = mempty {
+ ghcOptLinkOptions = PD.ldOptions exeBi,
+ ghcOptLinkLibs = extraLibs exeBi,
+ ghcOptLinkLibPath = extraLibDirs exeBi,
+ ghcOptLinkFrameworks = PD.frameworks exeBi,
+ ghcOptInputFiles = [exeDir </> x | x <- cObjs]
+ }
+ replOpts = baseOpts {
+ ghcOptExtra = 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 compilng twice?
+ useDynToo = dynamicTooSupported && isGhcDynamic
+ && doingTH && withStaticExe && null (ghcSharedOptions exeBi)
+ compileTHOpts | isGhcDynamic = dynOpts
+ | otherwise = staticOpts
+ compileForTH
+ | forRepl = False
+ | useDynToo = False
+ | isGhcDynamic = 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 $
+ runGhcProg compileTHOpts { ghcOptNoLink = toFlag True
+ , ghcOptNumJobs = toFlag numJobs }
+
+ unless forRepl $
+ runGhcProg compileOpts { ghcOptNoLink = toFlag True
+ , ghcOptNumJobs = toFlag 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 {
+ ghcOptDynLinkMode = toFlag (if withDynExe lbi
+ then GhcDynamicOnly
+ else GhcStaticOnly),
+ ghcOptProfilingMode = toFlag (withProfExe lbi)
+ }
+ odir = fromFlag (ghcOptObjDir opts)
+ createDirectoryIfMissingVerbose verbosity True odir
+ runGhcProg opts
+ | filename <- cSrcs ]
- -- For building exe's for profiling that use TH we actually
- -- have to build twice, once without profiling and the again
- -- with profiling. This is because the code that TH needs to
- -- run at compile time needs to be the vanilla ABI so it can
- -- be loaded up and run by the compiler.
- when ((withProfExe lbi || withDynExe lbi) &&
- EnableExtension TemplateHaskell `elem` allExtensions exeBi) $
- runGhcProg vanillaOpts { ghcOptNoLink = toFlag True }
+ -- 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 $ runGhcProg replOpts
- runGhcProg exeOpts { ghcOptOutputFile = toFlag (targetDir </> exeNameReal) }
+ -- link:
+ unless forRepl $ do
+ info verbosity "Linking..."
+ runGhcProg linkOpts { ghcOptOutputFile = toFlag (targetDir </> exeNameReal) }
-- | Filter the "-threaded" flag when profiling as it does not
@@ -878,6 +1105,19 @@ 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
@@ -909,16 +1149,34 @@ libAbiHash verbosity pkg_descr lbi lib clbi = do
libBi <- hackThreadedFlag verbosity
(compiler lbi) (withProfLib lbi) (libBuildInfo lib)
let
- ghcArgs =
+ comp = compiler lbi
+ vanillaArgs =
(componentGhcOptions verbosity lbi libBi clbi (buildDir lbi))
`mappend` mempty {
ghcOptMode = toFlag GhcModeAbiHash,
ghcOptPackageName = toFlag (packageId pkg_descr),
ghcOptInputModules = exposedModules lib
}
+ sharedArgs = vanillaArgs `mappend` mempty {
+ ghcOptDynLinkMode = toFlag GhcDynamicOnly,
+ ghcOptFPic = toFlag True,
+ ghcOptHiSuffix = toFlag "dyn_hi",
+ ghcOptObjSuffix = toFlag "dyn_o",
+ ghcOptExtra = ghcSharedOptions libBi
+ }
+ profArgs = vanillaArgs `mappend` mempty {
+ ghcOptProfilingMode = toFlag True,
+ ghcOptHiSuffix = toFlag "p_hi",
+ ghcOptObjSuffix = toFlag "p_o",
+ ghcOptExtra = ghcProfOptions 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 ghcArgs)
+ getProgramInvocationOutput verbosity (ghcInvocation ghcProg comp ghcArgs)
componentGhcOptions :: Verbosity -> LocalBuildInfo
@@ -943,6 +1201,7 @@ componentGhcOptions verbosity lbi bi clbi odir =
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)),
@@ -966,7 +1225,8 @@ componentCcGhcOptions verbosity lbi bi clbi pref filename =
ghcOptMode = toFlag GhcModeCompile,
ghcOptInputFiles = [filename],
- ghcOptCppIncludePath = odir : PD.includeDirs bi,
+ ghcOptCppIncludePath = [autogenModulesDir lbi, odir]
+ ++ PD.includeDirs bi,
ghcOptPackageDBs = withPackageDB lbi,
ghcOptPackages = componentPackageDeps clbi,
ghcOptCcOptions = PD.ccOptions bi
@@ -980,27 +1240,8 @@ componentCcGhcOptions verbosity lbi bi clbi pref filename =
| otherwise = pref </> takeDirectory filename
-- ghc 6.4.0 had a bug in -odir handling for C compilations.
-{-# DEPRECATED ghcVerbosityOptions "Use the GhcOptions record instead" #-}
-ghcVerbosityOptions :: Verbosity -> [String]
-ghcVerbosityOptions verbosity
- | verbosity >= deafening = ["-v"]
- | verbosity >= normal = []
- | otherwise = ["-w", "-v0"]
-
-{-# DEPRECATED ghcPackageDbOptions "Use the GhcOptions record instead" #-}
-ghcPackageDbOptions :: PackageDBStack -> [String]
-ghcPackageDbOptions dbstack = case dbstack of
- (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs
- (GlobalPackageDB:dbs) -> "-no-user-package-conf"
- : concatMap specific dbs
- _ -> ierror
- where
- specific (SpecificPackageDB db) = [ "-package-conf", db ]
- specific _ = ierror
- ierror = error ("internal error: unexpected package db stack: " ++ show dbstack)
-
-mkGHCiLibName :: PackageIdentifier -> String
-mkGHCiLibName lib = "HS" ++ display lib <.> "o"
+mkGHCiLibName :: LibraryName -> String
+mkGHCiLibName (LibraryName lib) = lib <.> "o"
-- -----------------------------------------------------------------------------
-- Installing
@@ -1014,7 +1255,8 @@ installExe :: Verbosity
-> PackageDescription
-> Executable
-> IO ()
-installExe verbosity lbi installDirs buildPref (progprefix, progsuffix) _pkg exe = do
+installExe verbosity lbi installDirs buildPref
+ (progprefix, progsuffix) _pkg exe = do
let binDir = bindir installDirs
createDirectoryIfMissingVerbose verbosity True binDir
let exeFileName = exeName exe <.> exeExtension
@@ -1023,26 +1265,10 @@ installExe verbosity lbi installDirs buildPref (progprefix, progsuffix) _pkg exe
installExecutableFile verbosity
(buildPref </> exeName exe </> exeFileName)
(dest <.> exeExtension)
- stripExe verbosity lbi exeFileName (dest <.> exeExtension)
+ when (stripExes lbi) $
+ Strip.stripExe verbosity (withPrograms lbi) (dest <.> exeExtension)
installBinary (binDir </> fixedExeBaseName)
-stripExe :: Verbosity -> LocalBuildInfo -> FilePath -> FilePath -> IO ()
-stripExe verbosity lbi name path = when (stripExes lbi) $
- case lookupProgram stripProgram (withPrograms lbi) of
- Just strip -> rawSystemProgram verbosity strip args
- Nothing -> unless (buildOS == Windows) $
- -- Don't bother warning on windows, we don't expect them to
- -- have the strip program anyway.
- warn verbosity $ "Unable to strip executable '" ++ name
- ++ "' (missing the 'strip' program)"
- where
- args = path : case buildOS of
- OSX -> ["-x"] -- By default, stripping the ghc binary on at least
- -- some OS X installations causes:
- -- HSbase-3.0.o: unknown symbol `_environ'"
- -- The -x flag fixes that.
- _ -> []
-
-- |Install for ghc, .hi, .a and, if --with-ghci given, .o
installLib :: Verbosity
-> LocalBuildInfo
@@ -1051,59 +1277,51 @@ installLib :: Verbosity
-> FilePath -- ^Build location
-> PackageDescription
-> Library
+ -> ComponentLocalBuildInfo
-> IO ()
-installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib = do
+installLib verbosity lbi targetDir dynlibTargetDir builtDir _pkg lib clbi = do
-- copy .hi files over:
- let copyHelper installFun src dst n = do
- createDirectoryIfMissingVerbose verbosity True dst
- installFun verbosity (src </> n) (dst </> n)
- copy = copyHelper installOrdinaryFile
- copyShared = copyHelper installExecutableFile
- copyModuleFiles ext =
- findModuleFiles [builtDir] [ext] (libModules lib)
- >>= installOrdinaryFiles verbosity targetDir
- ifVanilla $ copyModuleFiles "hi"
- ifProf $ copyModuleFiles "p_hi"
- ifShared $ copyModuleFiles "dyn_hi"
+ whenVanilla $ copyModuleFiles "hi"
+ whenProf $ copyModuleFiles "p_hi"
+ whenShared $ copyModuleFiles "dyn_hi"
-- copy the built library files over:
- ifVanilla $ copy builtDir targetDir vanillaLibName
- ifProf $ copy builtDir targetDir profileLibName
- ifGHCi $ copy builtDir targetDir ghciLibName
- ifShared $ copyShared builtDir dynlibTargetDir sharedLibName
-
- -- run ranlib if necessary:
- ifVanilla $ updateLibArchive verbosity lbi
- (targetDir </> vanillaLibName)
- ifProf $ updateLibArchive verbosity lbi
- (targetDir </> profileLibName)
+ whenVanilla $ mapM_ (installOrdinary builtDir targetDir) vanillaLibNames
+ whenProf $ mapM_ (installOrdinary builtDir targetDir) profileLibNames
+ whenGHCi $ mapM_ (installOrdinary builtDir targetDir) ghciLibNames
+ whenShared $ mapM_ (installShared builtDir dynlibTargetDir) sharedLibNames
where
- vanillaLibName = mkLibName pkgid
- profileLibName = mkProfLibName pkgid
- ghciLibName = mkGHCiLibName pkgid
- sharedLibName = mkSharedLibName pkgid (compilerId (compiler lbi))
-
- pkgid = packageId pkg
+ 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
+ else installOrdinaryFile verbosity src dst
+
+ installOrdinary = install False
+ installShared = install True
+
+ copyModuleFiles ext =
+ findModuleFiles [builtDir] [ext] (libModules lib)
+ >>= 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
hasLib = not $ null (libModules lib)
&& null (cSources (libBuildInfo lib))
- ifVanilla = when (hasLib && withVanillaLib lbi)
- ifProf = when (hasLib && withProfLib lbi)
- ifGHCi = when (hasLib && withGHCiLib lbi)
- ifShared = when (hasLib && withSharedLib lbi)
-
--- | On MacOS X we have to call @ranlib@ to regenerate the archive index after
--- copying. This is because the silly MacOS X linker checks that the archive
--- index is not older than the file itself, which means simply
--- copying/installing the file breaks it!!
---
-updateLibArchive :: Verbosity -> LocalBuildInfo -> FilePath -> IO ()
-updateLibArchive verbosity lbi path
- | buildOS == OSX = do
- (ranlib, _) <- requireProgram verbosity ranlibProgram (withPrograms lbi)
- rawSystemProgram verbosity ranlib [path]
- | otherwise = return ()
+ whenVanilla = when (hasLib && withVanillaLib lbi)
+ whenProf = when (hasLib && withProfLib lbi)
+ whenGHCi = when (hasLib && withGHCiLib lbi)
+ whenShared = when (hasLib && withSharedLib lbi)
-- -----------------------------------------------------------------------------
-- Registering
@@ -1114,6 +1332,15 @@ 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
+ where
+ Just ghcPkgProg = lookupProgram ghcPkgProgram conf
+
registerPackage
:: Verbosity
-> InstalledPackageInfo
@@ -1125,3 +1352,18 @@ registerPackage
registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs = do
let Just ghcPkg = lookupProgram ghcPkgProgram (withPrograms lbi)
HcPkg.reregister verbosity ghcPkg packageDbs (Right installedPkgInfo)
+
+-- -----------------------------------------------------------------------------
+-- 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"
+
+ghcSupportsDynamicToo :: Compiler -> Bool
+ghcSupportsDynamicToo = ghcLookupProperty "Support dynamic-too"
diff --git a/cabal/Cabal/Distribution/Simple/Haddock.hs b/cabal/Cabal/Distribution/Simple/Haddock.hs
index 1434803..7ad86a1 100644
--- a/cabal/Cabal/Distribution/Simple/Haddock.hs
+++ b/cabal/Cabal/Distribution/Simple/Haddock.hs
@@ -6,12 +6,12 @@
-- 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 for haddock 0.x which involves
--- \'unlit\'ing and using @-DHADDOCK@ 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. 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.
--
-- The @hscolour@ support allows generating html versions of the original
-- source, with coloured syntax highlighting.
@@ -52,15 +52,20 @@ module Distribution.Simple.Haddock (
-- local
import Distribution.Package
- ( PackageIdentifier, Package(..), packageName )
+ ( PackageIdentifier(..)
+ , Package(..)
+ , PackageName(..), packageName )
import qualified Distribution.ModuleName as ModuleName
import Distribution.PackageDescription as PD
( PackageDescription(..), BuildInfo(..), allExtensions
- , Library(..), hasLibs, Executable(..) )
+ , Library(..), hasLibs, Executable(..)
+ , TestSuite(..), TestSuiteInterface(..)
+ , Benchmark(..), BenchmarkInterface(..) )
import Distribution.Simple.Compiler
( Compiler(..), compilerVersion )
import Distribution.Simple.GHC ( componentGhcOptions, ghcLibDir )
-import Distribution.Simple.Program.GHC ( GhcOptions(..), renderGhcOptions )
+import Distribution.Simple.Program.GHC
+ ( GhcOptions(..), GhcDynLinkMode(..), renderGhcOptions )
import Distribution.Simple.Program
( ConfiguredProgram(..), requireProgramVersion
, rawSystemProgram, rawSystemProgramStdout
@@ -75,11 +80,10 @@ import Distribution.Simple.Build (initialBuildSteps)
import Distribution.Simple.InstallDirs (InstallDirs(..), PathTemplateEnv, PathTemplate,
PathTemplateVariable(..),
toPathTemplate, fromPathTemplate,
- substPathTemplate,
- initialPathTemplateEnv)
+ substPathTemplate, initialPathTemplateEnv)
import Distribution.Simple.LocalBuildInfo
( LocalBuildInfo(..), Component(..), ComponentLocalBuildInfo(..)
- , withComponentsLBI )
+ , withAllComponentsInBuildOrder )
import Distribution.Simple.BuildPaths ( haddockName,
hscolourPref, autogenModulesDir,
)
@@ -90,9 +94,11 @@ import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
import Distribution.InstalledPackageInfo
( InstalledPackageInfo )
import Distribution.Simple.Utils
- ( die, warn, notice, intercalate, setupMessage
- , createDirectoryIfMissingVerbose, withTempFile, copyFileVerbose
- , withTempDirectory
+ ( die, copyFileTo, warn, notice, intercalate, setupMessage
+ , createDirectoryIfMissingVerbose
+ , TempFileOptions(..), defaultTempFileOptions
+ , withTempFileEx, copyFileVerbose
+ , withTempDirectoryEx, matchFileGlob
, findFileWithExtension, findFile )
import Distribution.Text
( display, simpleParse )
@@ -102,13 +108,13 @@ import Language.Haskell.Extension
-- Base
import System.Directory(removeFile, doesFileExist, createDirectoryIfMissing)
-import Control.Monad ( when, guard )
+import Control.Monad ( when, guard, forM_ )
import Control.Exception (assert)
import Data.Monoid
import Data.Maybe ( fromMaybe, listToMaybe )
import System.FilePath((</>), (<.>), splitFileName, splitExtension,
- normalise, splitPath, joinPath)
+ normalise, splitPath, joinPath, isAbsolute )
import System.IO (hClose, hPutStrLn)
import Distribution.Version
@@ -125,7 +131,7 @@ data HaddockArgs = HaddockArgs {
argContents :: Flag String, -- ^ optional url to contents page
argVerbose :: Any,
argOutput :: Flag [Output], -- ^ Html or Hoogle doc or both? required.
- argInterfaces :: [(FilePath, Maybe FilePath)], -- ^ [(interface file, path to the html docs for links)]
+ 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.
@@ -150,10 +156,13 @@ data Output = Html | Hoogle
haddock :: PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HaddockFlags -> IO ()
haddock pkg_descr _ _ haddockFlags
| not (hasLibs pkg_descr)
- && not (fromFlag $ haddockExecutables haddockFlags) =
+ && not (fromFlag $ haddockExecutables haddockFlags)
+ && not (fromFlag $ haddockTestSuites haddockFlags)
+ && not (fromFlag $ haddockBenchmarks haddockFlags) =
warn (fromFlag $ haddockVerbosity haddockFlags) $
"No documentation was generated as this package does not contain "
- ++ "a library. Perhaps you want to use the --executables flag."
+ ++ "a library. Perhaps you want to use the --executables, --tests or"
+ ++ " --benchmarks flags."
haddock pkg_descr lbi suffixes flags = do
@@ -185,7 +194,7 @@ haddock pkg_descr lbi suffixes flags = do
++ "GHC version.\n"
++ "The GHC version is " ++ display ghcVersion ++ " but "
++ "haddock is using GHC version " ++ display haddockGhcVersion
- where ghcVersion = compilerVersion (compiler lbi)
+ where ghcVersion = compilerVersion comp
-- the tools match the requests, we can proceed
@@ -201,39 +210,54 @@ haddock pkg_descr lbi suffixes flags = do
, fromPackageDescription pkg_descr ]
let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes
- withComponentsLBI pkg_descr lbi $ \comp clbi -> do
- pre comp
- case comp of
+ withAllComponentsInBuildOrder pkg_descr lbi $ \component clbi -> do
+ pre component
+ 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'
+ Nothing -> do
+ warn (fromFlag $ haddockVerbosity flags)
+ "Unsupported component, skipping..."
+ return ()
+ case component of
CLib lib -> do
- withTempDirectory verbosity (buildDir lbi) "tmp" $ \tmp -> 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 isVersion2 bi (commonArgs `mappend` libArgs)
- runHaddock verbosity confHaddock libArgs'
- CExe exe -> when (flag haddockExecutables) $ do
- withTempDirectory verbosity (buildDir lbi) "tmp" $ \tmp -> do
- let bi = buildInfo exe
- exeArgs <- fromExecutable verbosity tmp lbi exe clbi htmlTemplate
- exeArgs' <- prepareSources verbosity tmp
- lbi isVersion2 bi (commonArgs `mappend` exeArgs)
- runHaddock verbosity confHaddock exeArgs'
- _ -> return ()
+ lbi version bi (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
+
+ forM_ (extraDocFiles pkg_descr) $ \ fpath -> do
+ files <- matchFileGlob fpath
+ forM_ files $ copyFileTo verbosity (unDir $ argOutputDir commonArgs)
where
- verbosity = flag haddockVerbosity
- flag f = fromFlag $ f flags
- htmlTemplate = fmap toPathTemplate . flagToMaybe . haddockHtmlLocation $ flags
+ verbosity = flag haddockVerbosity
+ keepTempFiles = flag haddockKeepTempFiles
+ 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
- -> Bool -- haddock == 2.*
+ -> Version
-> BuildInfo
-> HaddockArgs
-> IO HaddockArgs
-prepareSources verbosity tmp lbi isVersion2 bi args@HaddockArgs{argTargets=files} =
+prepareSources verbosity tmp lbi haddockVersion bi args@HaddockArgs{argTargets=files} =
mapM (mockPP tmp) files >>= \targets -> return args {argTargets=targets}
where
mockPP pref file = do
@@ -259,9 +283,14 @@ prepareSources verbosity tmp lbi isVersion2 bi args@HaddockArgs{argTargets=files
removeFile targetFile
return hsFile
- needsCpp = EnableExtension CPP `elem` allExtensions bi
- defines | isVersion2 = []
- | otherwise = ["-D__HADDOCK__"]
+ 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
@@ -277,7 +306,7 @@ fromFlags env flags =
argCssFile = haddockCss flags,
argContents = fmap (fromPathTemplate . substPathTemplate env) (haddockContents flags),
argVerbose = maybe mempty (Any . (>= deafening)) . flagToMaybe $ haddockVerbosity flags,
- argOutput =
+ argOutput =
Flag $ case [ Html | Flag True <- [haddockHtml flags] ] ++
[ Hoogle | Flag True <- [haddockHoogle flags] ]
of [] -> [ Html ]
@@ -308,17 +337,30 @@ fromLibrary :: Verbosity
fromLibrary verbosity tmp lbi lib clbi htmlTemplate = do
inFiles <- map snd `fmap` getLibSourceFiles lbi lib
ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate
+ let vanillaOpts = (componentGhcOptions normal lbi bi clbi (buildDir lbi)) {
+ -- Noooooooooo!!!!!111
+ -- haddock stomps on our precious .hi
+ -- and .o files. Workaround by telling
+ -- haddock to write them elsewhere.
+ ghcOptObjDir = toFlag tmp,
+ ghcOptHiDir = toFlag tmp,
+ ghcOptStubDir = toFlag tmp
+ }
+ sharedOpts = vanillaOpts {
+ ghcOptDynLinkMode = toFlag GhcDynamicOnly,
+ ghcOptFPic = toFlag True,
+ ghcOptHiSuffix = toFlag "dyn_hi",
+ ghcOptObjSuffix = toFlag "dyn_o",
+ ghcOptExtra = ghcSharedOptions 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"
return ifaceArgs {
argHideModules = (mempty,otherModules $ bi),
- argGhcOptions = toFlag ((componentGhcOptions normal lbi bi clbi (buildDir lbi)) {
- -- Noooooooooo!!!!!111
- -- haddock stomps on our precious .hi
- -- and .o files. Workaround by telling
- -- haddock to write them elsewhere.
- ghcOptObjDir = toFlag tmp,
- ghcOptHiDir = toFlag tmp,
- ghcOptStubDir = toFlag tmp
- },ghcVersion),
+ argGhcOptions = toFlag (opts, ghcVersion),
argTargets = inFiles
}
where
@@ -333,16 +375,29 @@ fromExecutable :: Verbosity
fromExecutable verbosity tmp lbi exe clbi htmlTemplate = do
inFiles <- map snd `fmap` getExeSourceFiles lbi exe
ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate
+ let vanillaOpts = (componentGhcOptions normal lbi bi clbi (buildDir lbi)) {
+ -- Noooooooooo!!!!!111
+ -- haddock stomps on our precious .hi
+ -- and .o files. Workaround by telling
+ -- haddock to write them elsewhere.
+ ghcOptObjDir = toFlag tmp,
+ ghcOptHiDir = toFlag tmp,
+ ghcOptStubDir = toFlag tmp
+ }
+ sharedOpts = vanillaOpts {
+ ghcOptDynLinkMode = toFlag GhcDynamicOnly,
+ ghcOptFPic = toFlag True,
+ ghcOptHiSuffix = toFlag "dyn_hi",
+ ghcOptObjSuffix = toFlag "dyn_o",
+ ghcOptExtra = ghcSharedOptions 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"
return ifaceArgs {
- argGhcOptions = toFlag ((componentGhcOptions normal lbi bi clbi (buildDir lbi)) {
- -- Noooooooooo!!!!!111
- -- haddock stomps on our precious .hi
- -- and .o files. Workaround by telling
- -- haddock to write them elsewhere.
- ghcOptObjDir = toFlag tmp,
- ghcOptHiDir = toFlag tmp,
- ghcOptStubDir = toFlag tmp
- }, ghcVersion),
+ argGhcOptions = toFlag (opts, ghcVersion),
argOutputDir = Dir (exeName exe),
argTitle = Flag (exeName exe),
argTargets = inFiles
@@ -351,6 +406,24 @@ fromExecutable verbosity tmp lbi exe clbi htmlTemplate = do
bi = buildInfo exe
ghcVersion = compilerVersion (compiler lbi)
+compToExe :: Component -> Maybe Executable
+compToExe comp =
+ case comp of
+ CTest test@TestSuite { testInterface = TestSuiteExeV10 _ f } ->
+ Just Executable {
+ exeName = testName test,
+ modulePath = f,
+ buildInfo = testBuildInfo test
+ }
+ CBench bench@Benchmark { benchmarkInterface = BenchmarkExeV10 _ f } ->
+ Just Executable {
+ exeName = benchmarkName bench,
+ modulePath = f,
+ buildInfo = benchmarkBuildInfo bench
+ }
+ CExe exe -> Just exe
+ _ -> Nothing
+
getInterfaces :: Verbosity
-> LocalBuildInfo
-> ComponentLocalBuildInfo
@@ -376,11 +449,17 @@ getGhcLibDir verbosity lbi isVersion2
----------------------------------------------------------------------------------------------
-- | Call haddock with the specified arguments.
-runHaddock :: Verbosity -> ConfiguredProgram -> HaddockArgs -> IO ()
-runHaddock verbosity confHaddock args = do
+runHaddock :: Verbosity
+ -> TempFileOptions
+ -> Compiler
+ -> ConfiguredProgram
+ -> HaddockArgs
+ -> IO ()
+runHaddock verbosity tmpFileOpts comp confHaddock args = do
let haddockVersion = fromMaybe (error "unable to determine haddock version")
(programVersion confHaddock)
- renderArgs verbosity haddockVersion args $ \(flags,result)-> do
+ renderArgs verbosity tmpFileOpts haddockVersion comp args $
+ \(flags,result)-> do
rawSystemProgram verbosity confHaddock flags
@@ -388,18 +467,20 @@ runHaddock verbosity confHaddock args = do
renderArgs :: Verbosity
+ -> TempFileOptions
-> Version
+ -> Compiler
-> HaddockArgs
-> (([String], FilePath) -> IO a)
-> IO a
-renderArgs verbosity version args k = do
+renderArgs verbosity tmpFileOpts version comp args k = do
createDirectoryIfMissingVerbose verbosity True outputDir
- withTempFile outputDir "haddock-prolog.txt" $ \prologFileName h -> do
+ withTempFileEx tmpFileOpts outputDir "haddock-prolog.txt" $ \prologFileName h -> do
do
hPutStrLn h $ fromFlag $ argPrologue args
hClose h
- let pflag = (:[]).("--prologue="++) $ prologFileName
- k $ (pflag ++ renderPureArgs version args, result)
+ let pflag = "--prologue=" ++ prologFileName
+ k (pflag : renderPureArgs version comp args, result)
where
isVersion2 = version >= Version [2,0] []
outputDir = (unDir $ argOutputDir args)
@@ -415,14 +496,14 @@ renderArgs verbosity version args k = do
pkgid = arg argPackageName
arg f = fromFlag $ f args
-renderPureArgs :: Version -> HaddockArgs -> [String]
-renderPureArgs version args = concat
+renderPureArgs :: Version -> Compiler -> HaddockArgs -> [String]
+renderPureArgs version comp args = concat
[
(:[]) . (\f -> "--dump-interface="++ unDir (argOutputDir args) </> f)
. fromFlag . argInterfaceFile $ args,
- (\pkgName -> if isVersion2
- then ["--optghc=-package-name", "--optghc=" ++ pkgName]
- else ["--package=" ++ pkgName]) . display . fromFlag . argPackageName $ 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
@@ -436,13 +517,15 @@ renderPureArgs version args = concat
(:[]).("--title="++) . (bool (++" (internal documentation)") id (getAny $ argIgnoreExports args))
. fromFlag . argTitle $ args,
[ "--optghc=" ++ opt | isVersion2
- , (opts, ghcVersion) <- flagToList (argGhcOptions args)
- , opt <- renderGhcOptions ghcVersion opts ],
+ , (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
]
where
- renderInterfaces = map (\(i,mh) -> "--read-interface=" ++ maybe "" (++",") mh ++ i)
+ 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] []
@@ -455,7 +538,7 @@ renderPureArgs version args = concat
haddockPackageFlags :: LocalBuildInfo
-> ComponentLocalBuildInfo
-> Maybe PathTemplate
- -> IO ([(FilePath,Maybe FilePath)], Maybe String)
+ -> IO ([(FilePath,Maybe String)], Maybe String)
haddockPackageFlags lbi clbi htmlTemplate = do
let allPkgs = installedPkgs lbi
directDeps = map fst (componentPackageDeps clbi)
@@ -471,7 +554,9 @@ haddockPackageFlags lbi clbi htmlTemplate = do
if exists
then return (Right (interface, html))
else return (Left (packageId ipkg))
- | ipkg <- PackageIndex.allPackages transitiveDeps ]
+ | ipkg <- PackageIndex.allPackages transitiveDeps
+ , pkgName (packageId ipkg) `notElem` noHaddockWhitelist
+ ]
let missing = [ pkgid | Left pkgid <- interfaces ]
warning = "The documentation for the following packages are not "
@@ -483,20 +568,30 @@ haddockPackageFlags lbi clbi htmlTemplate = do
return (flags, if null missing then Nothing else Just warning)
where
+ noHaddockWhitelist = map PackageName [ "rts" ]
interfaceAndHtmlPath :: InstalledPackageInfo -> Maybe (FilePath, FilePath)
interfaceAndHtmlPath pkg = do
interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg)
html <- case htmlTemplate of
- Nothing -> listToMaybe (InstalledPackageInfo.haddockHTMLs pkg)
+ Nothing -> fmap fixFileUrl
+ (listToMaybe (InstalledPackageInfo.haddockHTMLs pkg))
Just htmlPathTemplate -> Just (expandTemplateVars htmlPathTemplate)
return (interface, html)
- where expandTemplateVars = fromPathTemplate . substPathTemplate env
- env = haddockTemplateEnv lbi (packageId pkg)
+ 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
+ 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)
-- --------------------------------------------------------------------------
-- hscolour support
@@ -527,16 +622,24 @@ hscolour' pkg_descr lbi suffixes flags = do
createDirectoryIfMissingVerbose verbosity True $ hscolourPref distPref pkg_descr
let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes
- withComponentsLBI pkg_descr lbi $ \comp _ -> do
+ withAllComponentsInBuildOrder pkg_descr lbi $ \comp _ -> do
pre comp
+ let
+ doExe com = case (compToExe com) of
+ Just exe -> do
+ let outputDir = hscolourPref distPref pkg_descr </> exeName exe </> "src"
+ runHsColour hscolourProg outputDir =<< getExeSourceFiles lbi exe
+ Nothing -> do
+ warn (fromFlag $ hscolourVerbosity flags)
+ "Unsupported component, skipping..."
+ return ()
case comp of
CLib lib -> do
let outputDir = hscolourPref distPref pkg_descr </> "src"
runHsColour hscolourProg outputDir =<< getLibSourceFiles lbi lib
- CExe exe | fromFlag (hscolourExecutables flags) -> do
- let outputDir = hscolourPref distPref pkg_descr </> exeName exe </> "src"
- runHsColour hscolourProg outputDir =<< getExeSourceFiles lbi exe
- _ -> return ()
+ CExe _ -> when (fromFlag (hscolourExecutables flags)) $ doExe comp
+ CTest _ -> when (fromFlag (hscolourTestSuites flags)) $ doExe comp
+ CBench _ -> when (fromFlag (hscolourBenchmarks flags)) $ doExe comp
where
stylesheet = flagToMaybe (hscolourCSS flags)
@@ -552,7 +655,7 @@ hscolour' pkg_descr lbi suffixes flags = do
| otherwise -> return ()
Just s -> copyFileVerbose verbosity s (outputDir </> "hscolour.css")
- flip mapM_ moduleFiles $ \(m, inFile) ->
+ forM_ moduleFiles $ \(m, inFile) ->
rawSystemProgram verbosity prog
["-css", "-anchor", "-o" ++ outFile m, inFile]
where
@@ -563,6 +666,8 @@ haddockToHscolour flags =
HscolourFlags {
hscolourCSS = haddockHscolourCss flags,
hscolourExecutables = haddockExecutables flags,
+ hscolourTestSuites = haddockTestSuites flags,
+ hscolourBenchmarks = haddockBenchmarks flags,
hscolourVerbosity = haddockVerbosity flags,
hscolourDistPref = haddockDistPref flags
}
diff --git a/cabal/Cabal/Distribution/Simple/HaskellSuite.hs b/cabal/Cabal/Distribution/Simple/HaskellSuite.hs
new file mode 100644
index 0000000..b01992c
--- /dev/null
+++ b/cabal/Cabal/Distribution/Simple/HaskellSuite.hs
@@ -0,0 +1,222 @@
+module Distribution.Simple.HaskellSuite where
+
+import Control.Monad
+import Control.Applicative
+import Data.Maybe
+import Data.Version
+import qualified Data.Map as M (empty)
+
+import Distribution.Simple.Program
+import Distribution.Simple.Compiler as Compiler
+import Distribution.Simple.Utils
+import Distribution.Simple.BuildPaths
+import Distribution.Verbosity
+import Distribution.Text
+import Distribution.Package
+import Distribution.InstalledPackageInfo hiding (includeDirs)
+import Distribution.Simple.PackageIndex as PackageIndex
+import Distribution.PackageDescription
+import Distribution.Simple.LocalBuildInfo
+import Distribution.System (Platform)
+import Distribution.Compat.Exception
+import Language.Haskell.Extension
+import Distribution.Simple.Program.Builtin
+ (haskellSuiteProgram, haskellSuitePkgProgram)
+
+configure
+ :: Verbosity -> Maybe FilePath -> Maybe FilePath
+ -> ProgramConfiguration -> IO (Compiler, Maybe Platform, ProgramConfiguration)
+configure verbosity mbHcPath hcPkgPath conf0 = do
+
+ -- We have no idea how a haskell-suite tool is named, so we require at
+ -- least some information from the user.
+ hcPath <-
+ let msg = "You have to provide name or path of a haskell-suite tool (-w PATH)"
+ in maybe (die msg) return mbHcPath
+
+ when (isJust hcPkgPath) $
+ warn verbosity "--with-hc-pkg option is ignored for haskell-suite"
+
+ (comp, confdCompiler, conf1) <- configureCompiler hcPath conf0
+
+ -- Update our pkg tool. It uses the same executable as the compiler, but
+ -- all command start with "pkg"
+ (confdPkg, _) <- requireProgram verbosity haskellSuitePkgProgram conf1
+ let conf2 =
+ updateProgram
+ confdPkg
+ { programLocation = programLocation confdCompiler
+ , programDefaultArgs = ["pkg"]
+ }
+ conf1
+
+ return (comp, Nothing, conf2)
+
+ where
+ configureCompiler hcPath conf0' = do
+ let
+ haskellSuiteProgram' =
+ haskellSuiteProgram
+ { programFindLocation = \v _p -> findProgramLocation v hcPath }
+
+ -- NB: cannot call requireProgram right away — it'd think that
+ -- the program is already configured and won't reconfigure it again.
+ -- Instead, call configureProgram directly first.
+ conf1 <- configureProgram verbosity haskellSuiteProgram' conf0'
+ (confdCompiler, conf2) <- requireProgram verbosity haskellSuiteProgram' conf1
+
+ extensions <- getExtensions verbosity confdCompiler
+ languages <- getLanguages verbosity confdCompiler
+ (compName, compVersion) <-
+ getCompilerVersion verbosity confdCompiler
+
+ let
+ comp = Compiler {
+ compilerId = CompilerId (HaskellSuite compName) compVersion,
+ compilerLanguages = languages,
+ compilerExtensions = extensions,
+ compilerProperties = M.empty
+ }
+
+ return (comp, confdCompiler, conf2)
+
+hstoolVersion :: Verbosity -> FilePath -> IO (Maybe Version)
+hstoolVersion = findProgramVersion "--hspkg-version" id
+
+numericVersion :: Verbosity -> FilePath -> IO (Maybe Version)
+numericVersion = findProgramVersion "--compiler-version" (last . words)
+
+getCompilerVersion :: Verbosity -> ConfiguredProgram -> IO (String, Version)
+getCompilerVersion verbosity prog = do
+ output <- rawSystemStdout verbosity (programPath prog) ["--compiler-version"]
+ let
+ parts = words output
+ name = concat $ init parts -- there shouldn't be any spaces in the name anyway
+ versionStr = last parts
+ version <-
+ maybe (die "haskell-suite: couldn't determine compiler version") return $
+ simpleParse versionStr
+ return (name, version)
+
+getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Compiler.Flag)]
+getExtensions verbosity prog = do
+ extStrs <-
+ lines <$>
+ rawSystemStdout verbosity (programPath prog) ["--supported-extensions"]
+ return
+ [ (ext, "-X" ++ display ext) | Just ext <- map simpleParse extStrs ]
+
+getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, Compiler.Flag)]
+getLanguages verbosity prog = do
+ langStrs <-
+ lines <$>
+ rawSystemStdout verbosity (programPath prog) ["--supported-languages"]
+ return
+ [ (ext, "-G" ++ display ext) | Just ext <- map simpleParse langStrs ]
+
+-- Other compilers do some kind of a packagedb stack check here. Not sure
+-- if we need something like that as well.
+getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration
+ -> IO PackageIndex
+getInstalledPackages verbosity packagedbs conf =
+ liftM (PackageIndex.fromList . concat) $ forM packagedbs $ \packagedb ->
+ do str <-
+ getDbProgramOutput verbosity haskellSuitePkgProgram conf
+ ["dump", packageDbOpt packagedb]
+ `catchExit` \_ -> die $ "pkg dump failed"
+ case parsePackages str of
+ Right ok -> return ok
+ _ -> die "failed to parse output of 'pkg dump'"
+
+ where
+ parsePackages str =
+ let parsed = map parseInstalledPackageInfo (splitPkgs str)
+ in case [ msg | ParseFailed msg <- parsed ] of
+ [] -> Right [ pkg | ParseOk _ pkg <- parsed ]
+ msgs -> Left msgs
+
+ splitPkgs :: String -> [String]
+ splitPkgs = map unlines . splitWith ("---" ==) . lines
+ where
+ splitWith :: (a -> Bool) -> [a] -> [[a]]
+ splitWith p xs = ys : case zs of
+ [] -> []
+ _:ws -> splitWith p ws
+ where (ys,zs) = break p xs
+
+buildLib
+ :: Verbosity -> PackageDescription -> LocalBuildInfo
+ -> Library -> ComponentLocalBuildInfo -> IO ()
+buildLib verbosity pkg_descr lbi lib clbi = do
+ -- In future, there should be a mechanism for the compiler to request any
+ -- number of the above parameters (or their parts) — in particular,
+ -- pieces of PackageDescription.
+ --
+ -- For now, we only pass those that we know are used.
+
+ let odir = buildDir lbi
+ bi = libBuildInfo lib
+ srcDirs = hsSourceDirs bi ++ [odir]
+ dbStack = withPackageDB lbi
+ language = fromMaybe Haskell98 (defaultLanguage bi)
+ conf = withPrograms lbi
+ pkgid = packageId pkg_descr
+
+ runDbProgram verbosity haskellSuiteProgram conf $
+ [ "compile", "--build-dir", odir ] ++
+ concat [ ["-i", d] | d <- srcDirs ] ++
+ concat [ ["-I", d] | d <- [autogenModulesDir lbi, odir] ++ includeDirs bi ] ++
+ [ packageDbOpt pkgDb | pkgDb <- dbStack ] ++
+ [ "--package-name", display pkgid ] ++
+ concat [ ["--package-id", display ipkgid ]
+ | (ipkgid, _) <- componentPackageDeps clbi ] ++
+ ["-G", display language] ++
+ concat [ ["-X", display ex] | ex <- usedExtensions bi ] ++
+ [ display modu | modu <- libModules lib ]
+
+
+
+installLib
+ :: Verbosity
+ -> LocalBuildInfo
+ -> FilePath -- ^install location
+ -> FilePath -- ^install location for dynamic librarys
+ -> FilePath -- ^Build location
+ -> PackageDescription
+ -> Library
+ -> IO ()
+installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib = do
+ let conf = withPrograms lbi
+ runDbProgram verbosity haskellSuitePkgProgram conf $
+ [ "install-library"
+ , "--build-dir", builtDir
+ , "--target-dir", targetDir
+ , "--dynlib-target-dir", dynlibTargetDir
+ , "--package-id", display $ packageId pkg
+ ] ++ map display (libModules lib)
+
+registerPackage
+ :: Verbosity
+ -> InstalledPackageInfo
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> Bool
+ -> PackageDBStack
+ -> IO ()
+registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs = do
+ (hspkg, _) <- requireProgram verbosity haskellSuitePkgProgram (withPrograms lbi)
+
+ runProgramInvocation verbosity $
+ (programInvocation hspkg
+ ["update", packageDbOpt $ last packageDbs])
+ { progInvokeInput = Just $ showInstalledPackageInfo installedPkgInfo }
+
+initPackageDB :: Verbosity -> ProgramConfiguration -> FilePath -> IO ()
+initPackageDB verbosity conf dbPath =
+ runDbProgram verbosity haskellSuitePkgProgram conf
+ ["init", dbPath]
+
+packageDbOpt :: PackageDB -> String
+packageDbOpt GlobalPackageDB = "--global"
+packageDbOpt UserPackageDB = "--user"
+packageDbOpt (SpecificPackageDB db) = "--package-db=" ++ db
diff --git a/cabal/Cabal/Distribution/Simple/Hpc.hs b/cabal/Cabal/Distribution/Simple/Hpc.hs
index b579d16..e2f1420 100644
--- a/cabal/Cabal/Distribution/Simple/Hpc.hs
+++ b/cabal/Cabal/Distribution/Simple/Hpc.hs
@@ -60,9 +60,13 @@ import Distribution.PackageDescription
, testModules
)
import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) )
-import Distribution.Simple.Program ( hpcProgram, requireProgram )
+import Distribution.Simple.Program
+ ( hpcProgram
+ , requireProgramVersion
+ )
import Distribution.Simple.Program.Hpc ( markup, union )
import Distribution.Simple.Utils ( notice )
+import Distribution.Version ( anyVersion )
import Distribution.Text
import Distribution.Verbosity ( Verbosity() )
import System.Directory ( createDirectoryIfMissing, doesFileExist )
@@ -138,14 +142,19 @@ markupTest :: Verbosity
markupTest verbosity lbi distPref libName suite = do
tixFileExists <- doesFileExist $ tixFilePath distPref $ testName suite
when tixFileExists $ do
- (hpc, _) <- requireProgram verbosity hpcProgram $ withPrograms lbi
- markup hpc verbosity (tixFilePath distPref $ testName suite)
- (mixDir distPref libName)
- (htmlDir distPref $ testName suite)
- (testModules suite ++ [ main ])
+ -- behaviour of 'markup' depends on version, so we need *a* version
+ -- but no particular one
+ (hpc, hpcVer, _) <- requireProgramVersion verbosity
+ hpcProgram anyVersion (withPrograms lbi)
+ markup hpc hpcVer verbosity
+ (tixFilePath distPref $ testName suite) mixDirs
+ (htmlDir distPref $ testName suite)
+ (testModules suite ++ [ main ])
notice verbosity $ "Test coverage report written to "
++ htmlDir distPref (testName suite)
</> "hpc_index" <.> "html"
+ where
+ mixDirs = map (mixDir distPref) [ testName suite, libName ]
-- | Generate the HTML markup for all of a package's test suites.
markupPackage :: Verbosity
@@ -158,13 +167,17 @@ markupPackage verbosity lbi distPref libName suites = do
let tixFiles = map (tixFilePath distPref . testName) suites
tixFilesExist <- mapM doesFileExist tixFiles
when (and tixFilesExist) $ do
- (hpc, _) <- requireProgram verbosity hpcProgram $ withPrograms lbi
+ -- behaviour of 'markup' depends on version, so we need *a* version
+ -- but no particular one
+ (hpc, hpcVer, _) <- requireProgramVersion verbosity
+ hpcProgram anyVersion (withPrograms lbi)
let outFile = tixFilePath distPref libName
- mixDir' = mixDir distPref libName
htmlDir' = htmlDir distPref libName
excluded = concatMap testModules suites ++ [ main ]
createDirectoryIfMissing True $ takeDirectory outFile
union hpc verbosity tixFiles outFile excluded
- markup hpc verbosity outFile mixDir' htmlDir' excluded
+ markup hpc hpcVer verbosity outFile mixDirs htmlDir' excluded
notice verbosity $ "Package coverage report written to "
++ htmlDir' </> "hpc_index.html"
+ where
+ mixDirs = map (mixDir distPref) $ libName : map testName suites
diff --git a/cabal/Cabal/Distribution/Simple/Hugs.hs b/cabal/Cabal/Distribution/Simple/Hugs.hs
index ef3dd53..f63bfab 100644
--- a/cabal/Cabal/Distribution/Simple/Hugs.hs
+++ b/cabal/Cabal/Distribution/Simple/Hugs.hs
@@ -108,6 +108,7 @@ import Distribution.ParseUtils
import Distribution.Verbosity
import Data.Char ( isSpace )
+import qualified Data.Map as M ( empty )
import Data.Maybe ( mapMaybe, catMaybes )
import Data.Monoid ( Monoid(..) )
import Control.Monad ( unless, when, filterM )
@@ -118,6 +119,7 @@ import System.Directory
import System.Exit
( ExitCode(ExitSuccess) )
import Distribution.Compat.Exception
+import Distribution.System ( Platform )
import qualified Data.ByteString.Lazy.Char8 as BS.Char8
@@ -125,7 +127,7 @@ import qualified Data.ByteString.Lazy.Char8 as BS.Char8
-- Configuring
configure :: Verbosity -> Maybe FilePath -> Maybe FilePath
- -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration)
+ -> ProgramConfiguration -> IO (Compiler, Maybe Platform, ProgramConfiguration)
configure verbosity hcPath _hcPkgPath conf = do
(_ffihugsProg, conf') <- requireProgram verbosity ffihugsProgram
@@ -137,9 +139,11 @@ configure verbosity hcPath _hcPkgPath conf = do
let comp = Compiler {
compilerId = CompilerId Hugs version,
compilerLanguages = hugsLanguages,
- compilerExtensions = hugsLanguageExtensions
+ compilerExtensions = hugsLanguageExtensions,
+ compilerProperties = M.empty
}
- return (comp, conf'')
+ compPlatform = Nothing
+ return (comp, compPlatform, conf'')
where
hugsProgram' = hugsProgram { programFindVersion = getVersion }
@@ -147,6 +151,7 @@ configure verbosity hcPath _hcPkgPath conf = do
getVersion :: Verbosity -> FilePath -> IO (Maybe Version)
getVersion verbosity hugsPath = do
(output, _err, exit) <- rawSystemStdInOut verbosity hugsPath []
+ Nothing Nothing
(Just (":quit", False)) False
if exit == ExitSuccess
then return $! findVersion output
diff --git a/cabal/Cabal/Distribution/Simple/Install.hs b/cabal/Cabal/Distribution/Simple/Install.hs
index d5d4242..7cc2189 100644
--- a/cabal/Cabal/Distribution/Simple/Install.hs
+++ b/cabal/Cabal/Distribution/Simple/Install.hs
@@ -51,11 +51,12 @@ import Distribution.PackageDescription (
import Distribution.Package (Package(..))
import Distribution.Simple.LocalBuildInfo (
LocalBuildInfo(..), InstallDirs(..), absoluteInstallDirs,
- substPathTemplate)
+ substPathTemplate, withLibLBI)
import Distribution.Simple.BuildPaths (haddockName, haddockPref)
import Distribution.Simple.Utils
- ( createDirectoryIfMissingVerbose, installDirectoryContents
- , installOrdinaryFile, die, info, notice, matchDirFileGlob )
+ ( createDirectoryIfMissingVerbose
+ , installDirectoryContents, installOrdinaryFile, isInSearchPath
+ , die, info, notice, warn, matchDirFileGlob )
import Distribution.Simple.Compiler
( CompilerFlavor(..), compilerFlavor )
import Distribution.Simple.Setup (CopyFlags(..), CopyDest(..), fromFlag)
@@ -66,6 +67,7 @@ import qualified Distribution.Simple.JHC as JHC
import qualified Distribution.Simple.LHC as LHC
import qualified Distribution.Simple.Hugs as Hugs
import qualified Distribution.Simple.UHC as UHC
+import qualified Distribution.Simple.HaskellSuite as HaskellSuite
import Control.Monad (when, unless)
import System.Directory
@@ -143,19 +145,23 @@ install pkg_descr lbi flags = do
let buildPref = buildDir lbi
when (hasLibs pkg_descr) $
notice verbosity ("Installing library in " ++ libPref)
- when (hasExes pkg_descr) $
+ when (hasExes pkg_descr) $ do
notice verbosity ("Installing executable(s) in " ++ binPref)
+ inPath <- isInSearchPath binPref
+ when (not inPath) $
+ warn verbosity ("The directory " ++ binPref
+ ++ " is not in the system search path.")
-- install include files for all compilers - they may be needed to compile
-- haskell files (using the CPP extension)
when (hasLibs pkg_descr) $ installIncludeFiles verbosity pkg_descr incPref
case compilerFlavor (compiler lbi) of
- GHC -> do withLib pkg_descr $
+ GHC -> do withLibLBI pkg_descr lbi $
GHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr
withExe pkg_descr $
GHC.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr
- LHC -> do withLib pkg_descr $
+ LHC -> do withLibLBI pkg_descr lbi $
LHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr
withExe pkg_descr $
LHC.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr
@@ -167,13 +173,15 @@ install pkg_descr lbi flags = do
let targetProgPref = progdir (absoluteInstallDirs pkg_descr lbi NoCopyDest)
let scratchPref = scratchDir lbi
Hugs.install verbosity lbi libPref progPref binPref targetProgPref scratchPref (progPrefixPref, progSuffixPref) pkg_descr
- NHC -> do withLib pkg_descr $ NHC.installLib verbosity libPref buildPref (packageId pkg_descr)
+ NHC -> do withLibLBI pkg_descr lbi $ NHC.installLib verbosity libPref buildPref (packageId pkg_descr)
withExe pkg_descr $ NHC.installExe verbosity binPref buildPref (progPrefixPref, progSuffixPref)
UHC -> do withLib pkg_descr $ UHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr
+ HaskellSuite {} ->
+ withLib pkg_descr $
+ HaskellSuite.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr
_ -> die $ "installing with "
++ display (compilerFlavor (compiler lbi))
++ " is not implemented"
- return ()
-- register step should be performed by caller.
-- | Install the files listed in data-files
diff --git a/cabal/Cabal/Distribution/Simple/InstallDirs.hs b/cabal/Cabal/Distribution/Simple/InstallDirs.hs
index 8555b9b..32ba7b7 100644
--- a/cabal/Cabal/Distribution/Simple/InstallDirs.hs
+++ b/cabal/Cabal/Distribution/Simple/InstallDirs.hs
@@ -1,6 +1,4 @@
{-# LANGUAGE CPP, ForeignFunctionInterface #-}
-{-# OPTIONS_NHC98 -cpp #-}
-{-# OPTIONS_JHC -fcpp -fffi #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Simple.InstallDirs
@@ -77,14 +75,12 @@ import Data.Maybe (fromMaybe)
import Data.Monoid (Monoid(..))
import System.Directory (getAppUserDataDirectory)
import System.FilePath ((</>), isPathSeparator, pathSeparator)
-#if __HUGS__ || __GLASGOW_HASKELL__ > 606
import System.FilePath (dropDrive)
-#endif
import Distribution.Package
( PackageIdentifier, packageName, packageVersion )
import Distribution.System
- ( OS(..), buildOS, Platform(..), buildPlatform )
+ ( OS(..), buildOS, Platform(..) )
import Distribution.Compiler
( CompilerId, CompilerFlavor(..) )
import Distribution.Text
@@ -120,7 +116,8 @@ data InstallDirs dir = InstallDirs {
docdir :: dir,
mandir :: dir,
htmldir :: dir,
- haddockdir :: dir
+ haddockdir :: dir,
+ sysconfdir :: dir
} deriving (Read, Show)
instance Functor InstallDirs where
@@ -138,7 +135,8 @@ instance Functor InstallDirs where
docdir = f (docdir dirs),
mandir = f (mandir dirs),
htmldir = f (htmldir dirs),
- haddockdir = f (haddockdir dirs)
+ haddockdir = f (haddockdir dirs),
+ sysconfdir = f (sysconfdir dirs)
}
instance Monoid dir => Monoid (InstallDirs dir) where
@@ -156,7 +154,8 @@ instance Monoid dir => Monoid (InstallDirs dir) where
docdir = mempty,
mandir = mempty,
htmldir = mempty,
- haddockdir = mempty
+ haddockdir = mempty,
+ sysconfdir = mempty
}
mappend = combineInstallDirs mappend
@@ -178,7 +177,8 @@ combineInstallDirs combine a b = InstallDirs {
docdir = docdir a `combine` docdir b,
mandir = mandir a `combine` mandir b,
htmldir = htmldir a `combine` htmldir b,
- haddockdir = haddockdir a `combine` haddockdir b
+ haddockdir = haddockdir a `combine` haddockdir b,
+ sysconfdir = sysconfdir a `combine` sysconfdir b
}
appendSubdirs :: (a -> a -> a) -> InstallDirs a -> InstallDirs a
@@ -240,7 +240,7 @@ defaultInstallDirs comp userInstall _hasLibs = do
JHC -> "$compiler"
LHC -> "$compiler"
UHC -> "$pkgid"
- _other -> "$pkgid" </> "$compiler",
+ _other -> "$arch-$os-$compiler" </> "$pkgid",
dynlibdir = "$libdir",
libexecdir = case buildOS of
Windows -> "$prefix" </> "$pkgid"
@@ -250,11 +250,12 @@ defaultInstallDirs comp userInstall _hasLibs = do
datadir = case buildOS of
Windows -> "$prefix"
_other -> "$prefix" </> "share",
- datasubdir = "$pkgid",
- docdir = "$datadir" </> "doc" </> "$pkgid",
+ datasubdir = "$arch-$os-$compiler" </> "$pkgid",
+ docdir = "$datadir" </> "doc" </> "$arch-$os-$compiler" </> "$pkgid",
mandir = "$datadir" </> "man",
htmldir = "$docdir" </> "html",
- haddockdir = "$htmldir"
+ haddockdir = "$htmldir",
+ sysconfdir = "$prefix" </> "etc"
}
-- ---------------------------------------------------------------------------
@@ -292,7 +293,8 @@ substituteInstallDirTemplates env dirs = dirs'
mandir = subst mandir (prefixBinLibDataVars ++ [docdirVar]),
htmldir = subst htmldir (prefixBinLibDataVars ++ [docdirVar]),
haddockdir = subst haddockdir (prefixBinLibDataVars ++
- [docdirVar, htmldirVar])
+ [docdirVar, htmldirVar]),
+ sysconfdir = subst sysconfdir prefixBinLibVars
}
subst dir env' = substPathTemplate (env'++env) (dir dirs)
@@ -310,10 +312,10 @@ substituteInstallDirTemplates env dirs = dirs'
-- | Convert from abstract install directories to actual absolute ones by
-- substituting for all the variables in the abstract paths, to get real
-- absolute path.
-absoluteInstallDirs :: PackageIdentifier -> CompilerId -> CopyDest
+absoluteInstallDirs :: PackageIdentifier -> CompilerId -> CopyDest -> Platform
-> InstallDirs PathTemplate
-> InstallDirs FilePath
-absoluteInstallDirs pkgId compilerId copydest dirs =
+absoluteInstallDirs pkgId compilerId copydest platform dirs =
(case copydest of
CopyTo destdir -> fmap ((destdir </>) . dropDrive)
_ -> id)
@@ -321,7 +323,7 @@ absoluteInstallDirs pkgId compilerId copydest dirs =
. fmap fromPathTemplate
$ substituteInstallDirTemplates env dirs
where
- env = initialPathTemplateEnv pkgId compilerId
+ env = initialPathTemplateEnv pkgId compilerId platform
-- |The location prefix for the /copy/ command.
@@ -336,10 +338,10 @@ data CopyDest
-- prevents us from making a relocatable package (also known as a \"prefix
-- independent\" package).
--
-prefixRelativeInstallDirs :: PackageIdentifier -> CompilerId
+prefixRelativeInstallDirs :: PackageIdentifier -> CompilerId -> Platform
-> InstallDirTemplates
-> InstallDirs (Maybe FilePath)
-prefixRelativeInstallDirs pkgId compilerId dirs =
+prefixRelativeInstallDirs pkgId compilerId platform dirs =
fmap relative
. appendSubdirs combinePathTemplate
$ -- substitute the path template into each other, except that we map
@@ -349,7 +351,7 @@ prefixRelativeInstallDirs pkgId compilerId dirs =
prefix = PathTemplate [Variable PrefixVar]
}
where
- env = initialPathTemplateEnv pkgId compilerId
+ env = initialPathTemplateEnv pkgId compilerId platform
-- If it starts with $prefix then it's relative and produce the relative
-- path by stripping off $prefix/ or $prefix
@@ -390,7 +392,8 @@ data PathTemplateVariable =
| ArchVar -- ^ The cpu architecture name, eg @i386@ or @x86_64@
| ExecutableNameVar -- ^ The executable name; used in shell wrappers
| TestSuiteNameVar -- ^ The name of the test suite being run
- | TestSuiteResultVar -- ^ The result of the test suite being run, eg @pass@, @fail@, or @error@.
+ | TestSuiteResultVar -- ^ The result of the test suite being run, eg
+ -- @pass@, @fail@, or @error@.
| BenchmarkNameVar -- ^ The name of the benchmark being run
deriving Eq
@@ -421,12 +424,12 @@ substPathTemplate environment (PathTemplate template) =
Nothing -> [component]
-- | The initial environment has all the static stuff but no paths
-initialPathTemplateEnv :: PackageIdentifier -> CompilerId -> PathTemplateEnv
-initialPathTemplateEnv pkgId compilerId =
+initialPathTemplateEnv :: PackageIdentifier -> CompilerId -> Platform
+ -> PathTemplateEnv
+initialPathTemplateEnv pkgId compilerId platform =
packageTemplateEnv pkgId
++ compilerTemplateEnv compilerId
- ++ platformTemplateEnv buildPlatform -- platform should be param if we want
- -- to do cross-platform configuation
+ ++ platformTemplateEnv platform
packageTemplateEnv :: PackageIdentifier -> PathTemplateEnv
packageTemplateEnv pkgId =
@@ -561,9 +564,6 @@ getWindowsProgramFilesDir = do
#if mingw32_HOST_OS
shGetFolderPath :: CInt -> IO (Maybe FilePath)
shGetFolderPath n =
-# if __HUGS__
- return Nothing
-# else
allocaArray long_path_size $ \pPath -> do
r <- c_SHGetFolderPath nullPtr n nullPtr 0 pPath
if (r /= 0)
@@ -571,7 +571,6 @@ shGetFolderPath n =
else do s <- peekCWString pPath; return (Just s)
where
long_path_size = 1024 -- MAX_PATH is 260, this should be plenty
-# endif
csidl_PROGRAM_FILES :: CInt
csidl_PROGRAM_FILES = 0x0026
@@ -586,19 +585,3 @@ foreign import stdcall unsafe "shlobj.h SHGetFolderPathW"
-> CWString
-> IO CInt
#endif
-
-#if !(__HUGS__ || __GLASGOW_HASKELL__ > 606)
--- Compat: this function only appears in FilePath > 1.0
--- (which at the time of writing is unreleased)
-dropDrive :: FilePath -> FilePath
-dropDrive (c:cs) | isPathSeparator c = cs
-dropDrive (_:':':c:cs) | isWindows
- && isPathSeparator c = cs -- path with drive letter
-dropDrive (_:':':cs) | isWindows = cs
-dropDrive cs = cs
-
-isWindows :: Bool
-isWindows = case buildOS of
- Windows -> True
- _ -> False
-#endif
diff --git a/cabal/Cabal/Distribution/Simple/JHC.hs b/cabal/Cabal/Distribution/Simple/JHC.hs
index efaa09a..da978be 100644
--- a/cabal/Cabal/Distribution/Simple/JHC.hs
+++ b/cabal/Cabal/Distribution/Simple/JHC.hs
@@ -84,9 +84,11 @@ import Distribution.Text
( Text(parse), display )
import Distribution.Compat.ReadP
( readP_to_S, string, skipSpaces )
+import Distribution.System ( Platform )
import Data.List ( nub )
import Data.Char ( isSpace )
+import qualified Data.Map as M ( empty )
import Data.Maybe ( fromMaybe )
import qualified Data.ByteString.Lazy.Char8 as BS.Char8
@@ -96,7 +98,7 @@ import qualified Data.ByteString.Lazy.Char8 as BS.Char8
-- Configuring
configure :: Verbosity -> Maybe FilePath -> Maybe FilePath
- -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration)
+ -> ProgramConfiguration -> IO (Compiler, Maybe Platform, ProgramConfiguration)
configure verbosity hcPath _hcPkgPath conf = do
(jhcProg, _, conf') <- requireProgramVersion verbosity
@@ -107,9 +109,11 @@ configure verbosity hcPath _hcPkgPath conf = do
comp = Compiler {
compilerId = CompilerId JHC version,
compilerLanguages = jhcLanguages,
- compilerExtensions = jhcLanguageExtensions
+ compilerExtensions = jhcLanguageExtensions,
+ compilerProperties = M.empty
}
- return (comp, conf')
+ compPlatform = Nothing
+ return (comp, compPlatform, conf')
jhcLanguages :: [(Language, Flag)]
jhcLanguages = [(Haskell98, "")]
diff --git a/cabal/Cabal/Distribution/Simple/LHC.hs b/cabal/Cabal/Distribution/Simple/LHC.hs
index 6b3fcbe..ff84672 100644
--- a/cabal/Cabal/Distribution/Simple/LHC.hs
+++ b/cabal/Cabal/Distribution/Simple/LHC.hs
@@ -81,20 +81,22 @@ import Distribution.Simple.PackageIndex
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.ParseUtils ( ParseResult(..) )
import Distribution.Simple.LocalBuildInfo
- ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) )
+ ( LocalBuildInfo(..), ComponentLocalBuildInfo(..),
+ LibraryName(..) )
import Distribution.Simple.InstallDirs
import Distribution.Simple.BuildPaths
import Distribution.Simple.Utils
import Distribution.Package
- ( PackageIdentifier, Package(..) )
+ ( Package(..) )
import qualified Distribution.ModuleName as ModuleName
import Distribution.Simple.Program
- ( Program(..), ConfiguredProgram(..), ProgramConfiguration, ProgArg
- , ProgramLocation(..), rawSystemProgram, rawSystemProgramConf
+ ( Program(..), ConfiguredProgram(..), ProgramConfiguration
+ , ProgramSearchPath, ProgramLocation(..)
+ , rawSystemProgram, rawSystemProgramConf
, rawSystemProgramStdout, rawSystemProgramStdoutConf
, requireProgramVersion
, userMaybeSpecifyPath, programPath, lookupProgram, addKnownProgram
- , arProgram, ranlibProgram, ldProgram
+ , arProgram, ldProgram
, gccProgram, stripProgram
, lhcProgram, lhcPkgProgram )
import qualified Distribution.Simple.Program.HcPkg as HcPkg
@@ -114,6 +116,7 @@ import Language.Haskell.Extension
import Control.Monad ( unless, when )
import Data.List
+import qualified Data.Map as M ( empty )
import Data.Maybe ( catMaybes )
import Data.Monoid ( Monoid(..) )
import System.Directory ( removeFile, renameFile,
@@ -123,12 +126,13 @@ import System.FilePath ( (</>), (<.>), takeExtension,
takeDirectory, replaceExtension )
import System.IO (hClose, hPutStrLn)
import Distribution.Compat.Exception (catchExit, catchIO)
+import Distribution.System ( Platform )
-- -----------------------------------------------------------------------------
-- Configuring
configure :: Verbosity -> Maybe FilePath -> Maybe FilePath
- -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration)
+ -> ProgramConfiguration -> IO (Compiler, Maybe Platform, ProgramConfiguration)
configure verbosity hcPath hcPkgPath conf = do
(lhcProg, lhcVersion, conf') <-
@@ -152,10 +156,12 @@ configure verbosity hcPath hcPkgPath conf = do
let comp = Compiler {
compilerId = CompilerId LHC lhcVersion,
compilerLanguages = languages,
- compilerExtensions = extensions
+ compilerExtensions = extensions,
+ compilerProperties = M.empty
}
conf''' = configureToolchain lhcProg conf'' -- configure gcc and ld
- return (comp, conf''')
+ compPlatform = Nothing
+ return (comp, compPlatform, conf''')
-- | Adjust the way we find and configure gcc and ld
--
@@ -178,32 +184,36 @@ configureToolchain lhcProg =
isWindows = case buildOS of Windows -> True; _ -> False
-- on Windows finding and configuring ghc's gcc and ld is a bit special
- findProg :: Program -> FilePath -> Verbosity -> IO (Maybe FilePath)
- findProg prog location | isWindows = \verbosity -> do
+ findProg :: Program -> FilePath
+ -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath)
+ findProg prog location | isWindows = \verbosity searchpath -> do
exists <- doesFileExist location
if exists then return (Just location)
else do warn verbosity ("Couldn't find " ++ programName prog ++ " where I expected it. Trying the search path.")
- programFindLocation prog verbosity
+ programFindLocation prog verbosity searchpath
| otherwise = programFindLocation prog
- configureGcc :: Verbosity -> ConfiguredProgram -> IO [ProgArg]
+ 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
-- that means we should add this extra flag to tell ghc's gcc
-- where it lives and thus where gcc can find its various files:
- FoundOnSystem {} -> return ["-B" ++ libDir, "-I" ++ includeDir]
- UserSpecified {} -> return []
- | otherwise = \_ _ -> return []
+ FoundOnSystem {} -> return gccProg {
+ programDefaultArgs = ["-B" ++ libDir,
+ "-I" ++ includeDir]
+ }
+ UserSpecified {} -> return gccProg
+ | otherwise = \_ gccProg -> return gccProg
-- we need to find out if ld supports the -x flag
- configureLd :: Verbosity -> ConfiguredProgram -> IO [ProgArg]
+ 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() {}"
+ hPutStrLn testchnd "int foo() { return 0; }"
hClose testchnd; hClose testohnd
rawSystemProgram verbosity lhcProg ["-c", testcfile,
"-o", testofile]
@@ -216,8 +226,8 @@ configureToolchain lhcProg =
`catchIO` (\_ -> return False)
`catchExit` (\_ -> return False)
if ldx
- then return ["-x"]
- else return []
+ then return ldProg { programDefaultArgs = ["-x"] }
+ else return ldProg
getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, Flag)]
getLanguages _ _ = return [(Haskell98, "")]
@@ -332,6 +342,11 @@ substTopDir topDir ipo
buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo
-> Library -> ComponentLocalBuildInfo -> IO ()
buildLib verbosity 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 pref = buildDir lbi
pkgid = packageId pkg_descr
runGhcProg = rawSystemProgramConf verbosity lhcProgram (withPrograms lbi)
@@ -385,11 +400,11 @@ buildLib verbosity pkg_descr lbi lib clbi = do
info verbosity "Linking..."
let cObjs = map (`replaceExtension` objExtension) (cSources libBi)
cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) (cSources libBi)
- vanillaLibFilePath = libTargetDir </> mkLibName pkgid
- profileLibFilePath = libTargetDir </> mkProfLibName pkgid
- sharedLibFilePath = libTargetDir </> mkSharedLibName pkgid
- (compilerId (compiler lbi))
- ghciLibFilePath = libTargetDir </> mkGHCiLibName pkgid
+ cid = compilerId (compiler lbi)
+ vanillaLibFilePath = libTargetDir </> mkLibName libName
+ profileLibFilePath = libTargetDir </> mkProfLibName libName
+ sharedLibFilePath = libTargetDir </> mkSharedLibName cid libName
+ ghciLibFilePath = libTargetDir </> mkGHCiLibName libName
stubObjs <- fmap catMaybes $ sequence
[ findFileWithExtension [objExtension] [libTargetDir]
@@ -695,8 +710,8 @@ ghcCcOptions lbi bi clbi odir
_ -> ["-optc-O2"])
++ ["-odir", odir]
-mkGHCiLibName :: PackageIdentifier -> String
-mkGHCiLibName lib = "HS" ++ display lib <.> "o"
+mkGHCiLibName :: LibraryName -> String
+mkGHCiLibName (LibraryName lib) = lib <.> "o"
-- -----------------------------------------------------------------------------
-- Installing
@@ -747,8 +762,9 @@ installLib :: Verbosity
-> FilePath -- ^Build location
-> PackageDescription
-> Library
+ -> ComponentLocalBuildInfo
-> IO ()
-installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib = do
+installLib verbosity lbi targetDir dynlibTargetDir builtDir _pkg lib clbi = do
-- copy .hi files over:
let copy src dst n = do
createDirectoryIfMissingVerbose verbosity True dst
@@ -762,24 +778,18 @@ installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib = do
flip mapM_ hcrFiles $ \(srcBase, srcFile) -> runLhc ["--install-library", srcBase </> srcFile]
-- copy the built library files over:
- ifVanilla $ copy builtDir targetDir vanillaLibName
- ifProf $ copy builtDir targetDir profileLibName
- ifGHCi $ copy builtDir targetDir ghciLibName
- ifShared $ copy builtDir dynlibTargetDir sharedLibName
-
- -- run ranlib if necessary:
- ifVanilla $ updateLibArchive verbosity lbi
- (targetDir </> vanillaLibName)
- ifProf $ updateLibArchive verbosity lbi
- (targetDir </> profileLibName)
+ ifVanilla $ mapM_ (copy builtDir targetDir) vanillaLibNames
+ ifProf $ mapM_ (copy builtDir targetDir) profileLibNames
+ ifGHCi $ mapM_ (copy builtDir targetDir) ghciLibNames
+ ifShared $ mapM_ (copy builtDir dynlibTargetDir) sharedLibNames
where
- vanillaLibName = mkLibName pkgid
- profileLibName = mkProfLibName pkgid
- ghciLibName = mkGHCiLibName pkgid
- sharedLibName = mkSharedLibName pkgid (compilerId (compiler lbi))
-
- pkgid = packageId pkg
+ cid = compilerId (compiler lbi)
+ libNames = componentLibraries clbi
+ vanillaLibNames = map mkLibName libNames
+ profileLibNames = map mkProfLibName libNames
+ ghciLibNames = map mkGHCiLibName libNames
+ sharedLibNames = map (mkSharedLibName cid) libNames
hasLib = not $ null (libModules lib)
&& null (cSources (libBuildInfo lib))
@@ -790,20 +800,6 @@ installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib = do
runLhc = rawSystemProgramConf verbosity lhcProgram (withPrograms lbi)
--- | use @ranlib@ or @ar -s@ to build an index. This is necessary on systems
--- like MacOS X. If we can't find those, don't worry too much about it.
---
-updateLibArchive :: Verbosity -> LocalBuildInfo -> FilePath -> IO ()
-updateLibArchive verbosity lbi path =
- case lookupProgram ranlibProgram (withPrograms lbi) of
- Just ranlib -> rawSystemProgram verbosity ranlib [path]
- Nothing -> case lookupProgram arProgram (withPrograms lbi) of
- Just ar -> rawSystemProgram verbosity ar ["-s", path]
- Nothing -> warn verbosity $
- "Unable to generate a symbol index for the static "
- ++ "library '" ++ path
- ++ "' (missing the 'ranlib' and 'ar' programs)"
-
-- -----------------------------------------------------------------------------
-- Registering
diff --git a/cabal/Cabal/Distribution/Simple/LocalBuildInfo.hs b/cabal/Cabal/Distribution/Simple/LocalBuildInfo.hs
index b757a89..ed0b8f7 100644
--- a/cabal/Cabal/Distribution/Simple/LocalBuildInfo.hs
+++ b/cabal/Cabal/Distribution/Simple/LocalBuildInfo.hs
@@ -51,11 +51,27 @@ module Distribution.Simple.LocalBuildInfo (
-- * Buildable package components
Component(..),
- foldComponent,
- componentBuildInfo,
- allComponentsBy,
ComponentName(..),
+ showComponentName,
ComponentLocalBuildInfo(..),
+ LibraryName(..),
+ foldComponent,
+ componentName,
+ componentBuildInfo,
+ componentEnabled,
+ componentDisabledReason,
+ ComponentDisabledReason(..),
+ pkgComponents,
+ pkgEnabledComponents,
+ lookupComponent,
+ getComponent,
+ getComponentLocalBuildInfo,
+ allComponentsInBuildOrder,
+ componentsInBuildOrder,
+ checkComponentsCyclic,
+
+ withAllComponentsInBuildOrder,
+ withComponentsInBuildOrder,
withComponentsLBI,
withLibLBI,
withExeLBI,
@@ -83,14 +99,17 @@ import Distribution.Simple.Compiler
( Compiler(..), PackageDBStack, OptimisationLevel )
import Distribution.Simple.PackageIndex
( PackageIndex )
-import Distribution.Simple.Utils
- ( die )
import Distribution.Simple.Setup
( ConfigFlags )
import Distribution.Text
( display )
-
+import Distribution.System
+ ( Platform )
import Data.List (nub, find)
+import Data.Graph
+import Data.Tree (flatten)
+import Data.Array ((!))
+import Data.Maybe
-- | Data cached after configuration step. See also
-- 'Distribution.Simple.Setup.ConfigFlags'.
@@ -107,18 +126,16 @@ data LocalBuildInfo = LocalBuildInfo {
--TODO: inplaceDirTemplates :: InstallDirs FilePath
compiler :: Compiler,
-- ^ The compiler we're building with
+ hostPlatform :: Platform,
+ -- ^ The platform we're building for
buildDir :: FilePath,
-- ^ Where to build the package.
--TODO: eliminate hugs's scratchDir, use builddir
scratchDir :: FilePath,
-- ^ Where to put the result of the Hugs build.
- libraryConfig :: Maybe ComponentLocalBuildInfo,
- executableConfigs :: [(String, ComponentLocalBuildInfo)],
- compBuildOrder :: [ComponentName],
- -- ^ All the components to build, ordered by topological sort
+ componentsConfigs :: [(ComponentName, ComponentLocalBuildInfo, [ComponentName])],
+ -- ^ All the components to build, ordered by topological sort, and with their dependencies
-- over the intrapackage dependency graph
- testSuiteConfigs :: [(String, ComponentLocalBuildInfo)],
- benchmarkConfigs :: [(String, ComponentLocalBuildInfo)],
installedPkgs :: PackageIndex,
-- ^ All the info about the installed packages that the
-- current package depends on (directly or indirectly).
@@ -138,6 +155,7 @@ data LocalBuildInfo = LocalBuildInfo {
withGHCiLib :: Bool, -- ^Whether to build libs suitable for use with GHCi.
splitObjs :: Bool, -- ^Use -split-objs with GHC, if available
stripExes :: Bool, -- ^Whether to strip executables during install
+ stripLibs :: Bool, -- ^Whether to strip libraries during install
progPrefix :: PathTemplate, -- ^Prefix to be prepended to installed executables
progSuffix :: PathTemplate -- ^Suffix to be appended to installed executables
} deriving (Read, Show)
@@ -145,12 +163,12 @@ data LocalBuildInfo = LocalBuildInfo {
-- | External package dependencies for the package as a whole. This is the
-- union of the individual 'componentPackageDeps', less any internal deps.
externalPackageDeps :: LocalBuildInfo -> [(InstalledPackageId, PackageId)]
-externalPackageDeps lbi = filter (not . internal . snd) $ nub $
- -- TODO: what about non-buildable components?
- maybe [] componentPackageDeps (libraryConfig lbi)
- ++ concatMap (componentPackageDeps . snd) (executableConfigs lbi)
- ++ concatMap (componentPackageDeps . snd) (testSuiteConfigs lbi)
- ++ concatMap (componentPackageDeps . snd) (benchmarkConfigs lbi)
+externalPackageDeps lbi =
+ -- TODO: what about non-buildable components?
+ nub [ (ipkgid, pkgid)
+ | (_,clbi,_) <- componentsConfigs lbi
+ , (ipkgid, pkgid) <- componentPackageDeps clbi
+ , not (internal pkgid) ]
where
-- True if this dependency is an internal one (depends on the library
-- defined in the same package).
@@ -175,13 +193,30 @@ data ComponentName = CLibName -- currently only a single lib
| CExeName String
| CTestName String
| CBenchName String
- deriving (Show, Eq, Read)
+ deriving (Show, Eq, Ord, Read)
+
+showComponentName :: ComponentName -> String
+showComponentName CLibName = "library"
+showComponentName (CExeName name) = "executable '" ++ name ++ "'"
+showComponentName (CTestName name) = "test suite '" ++ name ++ "'"
+showComponentName (CBenchName name) = "benchmark '" ++ name ++ "'"
-data ComponentLocalBuildInfo = ComponentLocalBuildInfo {
+data ComponentLocalBuildInfo
+ = LibComponentLocalBuildInfo {
-- | Resolved internal and external package dependencies for this component.
-- The 'BuildInfo' specifies a set of build dependencies that must be
-- satisfied in terms of version ranges. This field fixes those dependencies
-- to the specific versions available on this machine for this compiler.
+ componentPackageDeps :: [(InstalledPackageId, PackageId)],
+ componentLibraries :: [LibraryName]
+ }
+ | ExeComponentLocalBuildInfo {
+ componentPackageDeps :: [(InstalledPackageId, PackageId)]
+ }
+ | TestComponentLocalBuildInfo {
+ componentPackageDeps :: [(InstalledPackageId, PackageId)]
+ }
+ | BenchComponentLocalBuildInfo {
componentPackageDeps :: [(InstalledPackageId, PackageId)]
}
deriving (Read, Show)
@@ -197,113 +232,180 @@ foldComponent _ f _ _ (CExe exe) = f exe
foldComponent _ _ f _ (CTest tst) = f tst
foldComponent _ _ _ f (CBench bch) = f bch
+data LibraryName = LibraryName String
+ deriving (Read, Show)
+
componentBuildInfo :: Component -> BuildInfo
componentBuildInfo =
foldComponent libBuildInfo buildInfo testBuildInfo benchmarkBuildInfo
--- | Obtains all components (libs, exes, or test suites), transformed by the
--- given function. Useful for gathering dependencies with component context.
-allComponentsBy :: PackageDescription
- -> (Component -> a)
- -> [a]
-allComponentsBy pkg_descr f =
- [ f (CLib lib) | Just lib <- [library pkg_descr]
- , buildable (libBuildInfo lib) ]
- ++ [ f (CExe exe) | exe <- executables pkg_descr
- , buildable (buildInfo exe) ]
- ++ [ f (CTest tst) | tst <- testSuites pkg_descr
- , buildable (testBuildInfo tst)
- , testEnabled tst ]
- ++ [ f (CBench bm) | bm <- benchmarks pkg_descr
- , buildable (benchmarkBuildInfo bm)
- , benchmarkEnabled bm ]
+componentName :: Component -> ComponentName
+componentName =
+ foldComponent (const CLibName)
+ (CExeName . exeName)
+ (CTestName . testName)
+ (CBenchName . benchmarkName)
+
+-- | All the components in the package (libs, exes, or test suites).
+--
+pkgComponents :: PackageDescription -> [Component]
+pkgComponents pkg =
+ [ CLib lib | Just lib <- [library pkg] ]
+ ++ [ CExe exe | exe <- executables pkg ]
+ ++ [ CTest tst | tst <- testSuites pkg ]
+ ++ [ CBench bm | bm <- benchmarks pkg ]
+
+-- | All the components in the package that are buildable and enabled.
+-- Thus this excludes non-buildable components and test suites or benchmarks
+-- that have been disabled.
+--
+pkgEnabledComponents :: PackageDescription -> [Component]
+pkgEnabledComponents = filter componentEnabled . pkgComponents
+
+componentEnabled :: Component -> Bool
+componentEnabled = isNothing . componentDisabledReason
+
+data ComponentDisabledReason = DisabledComponent
+ | DisabledAllTests
+ | DisabledAllBenchmarks
+
+componentDisabledReason :: Component -> Maybe ComponentDisabledReason
+componentDisabledReason (CLib lib)
+ | not (buildable (libBuildInfo lib)) = Just DisabledComponent
+componentDisabledReason (CExe exe)
+ | not (buildable (buildInfo exe)) = Just DisabledComponent
+componentDisabledReason (CTest tst)
+ | not (buildable (testBuildInfo tst)) = Just DisabledComponent
+ | not (testEnabled tst) = Just DisabledAllTests
+componentDisabledReason (CBench bm)
+ | not (buildable (benchmarkBuildInfo bm)) = Just DisabledComponent
+ | not (benchmarkEnabled bm) = Just DisabledAllBenchmarks
+componentDisabledReason _ = Nothing
+
+lookupComponent :: PackageDescription -> ComponentName -> Maybe Component
+lookupComponent pkg CLibName =
+ fmap CLib $ library pkg
+lookupComponent pkg (CExeName name) =
+ fmap CExe $ find ((name ==) . exeName) (executables pkg)
+lookupComponent pkg (CTestName name) =
+ fmap CTest $ find ((name ==) . testName) (testSuites pkg)
+lookupComponent pkg (CBenchName name) =
+ fmap CBench $ find ((name ==) . benchmarkName) (benchmarks pkg)
+
+getComponent :: PackageDescription -> ComponentName -> Component
+getComponent pkg cname =
+ case lookupComponent pkg cname of
+ Just cpnt -> cpnt
+ Nothing -> missingComponent
+ where
+ missingComponent =
+ error $ "internal error: the package description contains no "
+ ++ "component corresponding to " ++ show cname
+
+
+getComponentLocalBuildInfo :: LocalBuildInfo -> ComponentName -> ComponentLocalBuildInfo
+getComponentLocalBuildInfo lbi cname =
+ case [ clbi
+ | (cname', clbi, _) <- componentsConfigs lbi
+ , cname == cname' ] of
+ [clbi] -> clbi
+ _ -> missingComponent
+ where
+ missingComponent =
+ error $ "internal error: there is no configuration data "
+ ++ "for component " ++ show cname
+
-- |If the package description has a library section, call the given
-- function with the library build info as argument. Extended version of
-- 'withLib' that also gives corresponding build info.
withLibLBI :: PackageDescription -> LocalBuildInfo
-> (Library -> ComponentLocalBuildInfo -> IO ()) -> IO ()
-withLibLBI pkg_descr lbi f = withLib pkg_descr $ \lib ->
- case libraryConfig lbi of
- Just clbi -> f lib clbi
- Nothing -> die missingLibConf
+withLibLBI pkg_descr lbi f =
+ withLib pkg_descr $ \lib ->
+ f lib (getComponentLocalBuildInfo lbi CLibName)
-- | Perform the action on each buildable 'Executable' in the package
-- description. Extended version of 'withExe' that also gives corresponding
-- build info.
withExeLBI :: PackageDescription -> LocalBuildInfo
-> (Executable -> ComponentLocalBuildInfo -> IO ()) -> IO ()
-withExeLBI pkg_descr lbi f = withExe pkg_descr $ \exe ->
- case lookup (exeName exe) (executableConfigs lbi) of
- Just clbi -> f exe clbi
- Nothing -> die (missingExeConf (exeName exe))
+withExeLBI pkg_descr lbi f =
+ withExe pkg_descr $ \exe ->
+ f exe (getComponentLocalBuildInfo lbi (CExeName (exeName exe)))
withTestLBI :: PackageDescription -> LocalBuildInfo
-> (TestSuite -> ComponentLocalBuildInfo -> IO ()) -> IO ()
-withTestLBI pkg_descr lbi f = withTest pkg_descr $ \test ->
- case lookup (testName test) (testSuiteConfigs lbi) of
- Just clbi -> f test clbi
- Nothing -> die (missingTestConf (testName test))
+withTestLBI pkg_descr lbi f =
+ withTest pkg_descr $ \test ->
+ f test (getComponentLocalBuildInfo lbi (CTestName (testName test)))
--- | Perform the action on each buildable 'Library' or 'Executable' (Component)
--- in the PackageDescription, subject to the build order specified by the
--- 'compBuildOrder' field of the given 'LocalBuildInfo'
+{-# DEPRECATED withComponentsLBI "Use withAllComponentsInBuildOrder" #-}
withComponentsLBI :: PackageDescription -> LocalBuildInfo
-> (Component -> ComponentLocalBuildInfo -> IO ())
-> IO ()
-withComponentsLBI pkg_descr lbi f = mapM_ compF (compBuildOrder lbi)
+withComponentsLBI = withAllComponentsInBuildOrder
+
+-- | Perform the action on each buildable 'Library' or 'Executable' (Component)
+-- in the PackageDescription, subject to the build order specified by the
+-- 'compBuildOrder' field of the given 'LocalBuildInfo'
+withAllComponentsInBuildOrder :: PackageDescription -> LocalBuildInfo
+ -> (Component -> ComponentLocalBuildInfo -> IO ())
+ -> IO ()
+withAllComponentsInBuildOrder pkg lbi f =
+ sequence_
+ [ f (getComponent pkg cname) clbi
+ | (cname, clbi) <- allComponentsInBuildOrder lbi ]
+
+withComponentsInBuildOrder :: PackageDescription -> LocalBuildInfo
+ -> [ComponentName]
+ -> (Component -> ComponentLocalBuildInfo -> IO ())
+ -> IO ()
+withComponentsInBuildOrder pkg lbi cnames f =
+ sequence_
+ [ f (getComponent pkg cname') clbi
+ | (cname', clbi) <- componentsInBuildOrder lbi cnames ]
+
+allComponentsInBuildOrder :: LocalBuildInfo
+ -> [(ComponentName, ComponentLocalBuildInfo)]
+allComponentsInBuildOrder lbi =
+ componentsInBuildOrder lbi
+ [ cname | (cname, _, _) <- componentsConfigs lbi ]
+
+componentsInBuildOrder :: LocalBuildInfo -> [ComponentName]
+ -> [(ComponentName, ComponentLocalBuildInfo)]
+componentsInBuildOrder lbi cnames =
+ map ((\(clbi,cname,_) -> (cname,clbi)) . vertexToNode)
+ . postOrder graph
+ . map (\cname -> fromMaybe (noSuchComp cname) (keyToVertex cname))
+ $ cnames
where
- compF CLibName =
- case library pkg_descr of
- Nothing -> die missinglib
- Just lib -> case libraryConfig lbi of
- Nothing -> die missingLibConf
- Just clbi -> f (CLib lib) clbi
- where
- missinglib = "internal error: component list includes a library "
- ++ "but the package description contains no library"
-
- compF (CExeName name) =
- case find (\exe -> exeName exe == name) (executables pkg_descr) of
- Nothing -> die missingexe
- Just exe -> case lookup name (executableConfigs lbi) of
- Nothing -> die (missingExeConf name)
- Just clbi -> f (CExe exe) clbi
- where
- missingexe = "internal error: component list includes an executable "
- ++ name ++ " but the package contains no such executable."
-
- compF (CTestName name) =
- case find (\tst -> testName tst == name) (testSuites pkg_descr) of
- Nothing -> die missingtest
- Just tst -> case lookup name (testSuiteConfigs lbi) of
- Nothing -> die (missingTestConf name)
- Just clbi -> f (CTest tst) clbi
- where
- missingtest = "internal error: component list includes a test suite "
- ++ name ++ " but the package contains no such test suite."
-
- compF (CBenchName name) =
- case find (\bch -> benchmarkName bch == name) (benchmarks pkg_descr) of
- Nothing -> die missingbench
- Just bch -> case lookup name (benchmarkConfigs lbi) of
- Nothing -> die (missingBenchConf name)
- Just clbi -> f (CBench bch) clbi
- where
- missingbench = "internal error: component list includes a benchmark "
- ++ name ++ " but the package contains no such benchmark."
-
-missingLibConf :: String
-missingExeConf, missingTestConf, missingBenchConf :: String -> String
-
-missingLibConf = "internal error: the package contains a library "
- ++ "but there is no corresponding configuration data"
-missingExeConf name = "internal error: the package contains an executable "
- ++ name ++ " but there is no corresponding configuration data"
-missingTestConf name = "internal error: the package contains a test suite "
- ++ name ++ " but there is no corresponding configuration data"
-missingBenchConf name = "internal error: the package contains a benchmark "
- ++ name ++ " but there is no corresponding configuration data"
+ (graph, vertexToNode, keyToVertex) =
+ graphFromEdges (map (\(a,b,c) -> (b,a,c)) (componentsConfigs lbi))
+
+ noSuchComp cname = error $ "internal error: componentsInBuildOrder: "
+ ++ "no such component: " ++ show cname
+
+ postOrder :: Graph -> [Vertex] -> [Vertex]
+ postOrder g vs = postorderF (dfs g vs) []
+
+ postorderF :: Forest a -> [a] -> [a]
+ postorderF ts = foldr (.) id $ map postorderT ts
+
+ postorderT :: Tree a -> [a] -> [a]
+ postorderT (Node a ts) = postorderF ts . (a :)
+
+checkComponentsCyclic :: Ord key => [(node, key, [key])]
+ -> Maybe [(node, key, [key])]
+checkComponentsCyclic es =
+ let (graph, vertexToNode, _) = graphFromEdges es
+ cycles = [ flatten c | c <- scc graph, isCycle c ]
+ isCycle (Node v []) = selfCyclic v
+ isCycle _ = True
+ selfCyclic v = v `elem` graph ! v
+ in case cycles of
+ [] -> Nothing
+ (c:_) -> Just (map vertexToNode c)
-- -----------------------------------------------------------------------------
@@ -317,6 +419,7 @@ absoluteInstallDirs pkg lbi copydest =
(packageId pkg)
(compilerId (compiler lbi))
copydest
+ (hostPlatform lbi)
(installDirTemplates lbi)
-- |See 'InstallDirs.prefixRelativeInstallDirs'
@@ -326,6 +429,7 @@ prefixRelativeInstallDirs pkg_descr lbi =
InstallDirs.prefixRelativeInstallDirs
(packageId pkg_descr)
(compilerId (compiler lbi))
+ (hostPlatform lbi)
(installDirTemplates lbi)
substPathTemplate :: PackageId -> LocalBuildInfo
@@ -335,3 +439,4 @@ substPathTemplate pkgid lbi = fromPathTemplate
where env = initialPathTemplateEnv
pkgid
(compilerId (compiler lbi))
+ (hostPlatform lbi)
diff --git a/cabal/Cabal/Distribution/Simple/NHC.hs b/cabal/Cabal/Distribution/Simple/NHC.hs
index 83ff384..93a6c8a 100644
--- a/cabal/Cabal/Distribution/Simple/NHC.hs
+++ b/cabal/Cabal/Distribution/Simple/NHC.hs
@@ -52,7 +52,7 @@ module Distribution.Simple.NHC (
import Distribution.Package
( PackageName, PackageIdentifier(..), InstalledPackageId(..)
- , packageId, packageName )
+ , packageName )
import Distribution.InstalledPackageInfo
( InstalledPackageInfo
, InstalledPackageInfo_( InstalledPackageInfo, installedPackageId
@@ -98,18 +98,20 @@ import System.Directory
( doesFileExist, doesDirectoryExist, getDirectoryContents
, removeFile, getHomeDirectory )
-import Data.Char ( toLower )
-import Data.List ( nub )
-import Data.Maybe ( catMaybes )
-import Data.Monoid ( Monoid(..) )
-import Control.Monad ( when, unless )
+import Data.Char ( toLower )
+import Data.List ( nub )
+import Data.Maybe ( catMaybes )
+import qualified Data.Map as M ( empty )
+import Data.Monoid ( Monoid(..) )
+import Control.Monad ( when, unless )
import Distribution.Compat.Exception
+import Distribution.System ( Platform )
-- -----------------------------------------------------------------------------
-- Configuring
configure :: Verbosity -> Maybe FilePath -> Maybe FilePath
- -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration)
+ -> ProgramConfiguration -> IO (Compiler, Maybe Platform, ProgramConfiguration)
configure verbosity hcPath _hcPkgPath conf = do
(_nhcProg, nhcVersion, conf') <-
@@ -132,9 +134,11 @@ configure verbosity hcPath _hcPkgPath conf = do
let comp = Compiler {
compilerId = CompilerId NHC nhcVersion,
compilerLanguages = nhcLanguages,
- compilerExtensions = nhcLanguageExtensions
+ compilerExtensions = nhcLanguageExtensions,
+ compilerProperties = M.empty
}
- return (comp, conf'''')
+ compPlatform = Nothing
+ return (comp, compPlatform, conf'''')
nhcLanguages :: [(Language, Flag)]
nhcLanguages = [(Haskell98, "-98")]
@@ -285,6 +289,10 @@ setInstalledPackageId pkginfo = pkginfo
buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo
-> Library -> ComponentLocalBuildInfo -> IO ()
buildLib verbosity 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 conf = withPrograms lbi
Just nhcProg = lookupProgram nhcProgram conf
let bi = libBuildInfo lib
@@ -325,7 +333,7 @@ buildLib verbosity pkg_descr lbi lib clbi = do
info verbosity "Linking..."
let --cObjs = [ targetDir </> cFile `replaceExtension` objExtension
-- | cFile <- cSources bi ]
- libFilePath = targetDir </> mkLibName (packageId pkg_descr)
+ libFilePath = targetDir </> mkLibName libName
hObjs = [ targetDir </> ModuleName.toFilePath m <.> objExtension
| m <- modules ]
@@ -414,11 +422,15 @@ installLib :: Verbosity -- ^verbosity
-> FilePath -- ^Build location
-> PackageIdentifier
-> Library
+ -> ComponentLocalBuildInfo
-> IO ()
-installLib verbosity pref buildPref pkgid lib
+installLib verbosity pref buildPref _pkgid lib clbi
= do let bi = libBuildInfo lib
modules = exposedModules lib ++ otherModules bi
findModuleFiles [buildPref] ["hi"] modules
>>= installOrdinaryFiles verbosity pref
- let libName = mkLibName pkgid
- installOrdinaryFile verbosity (buildPref </> libName) (pref </> libName)
+ let libNames = map mkLibName (componentLibraries clbi)
+ installLib' libName = installOrdinaryFile verbosity
+ (buildPref </> libName)
+ (pref </> libName)
+ mapM_ installLib' libNames
diff --git a/cabal/Cabal/Distribution/Simple/PackageIndex.hs b/cabal/Cabal/Distribution/Simple/PackageIndex.hs
index edb671f..bcb75eb 100644
--- a/cabal/Cabal/Distribution/Simple/PackageIndex.hs
+++ b/cabal/Cabal/Distribution/Simple/PackageIndex.hs
@@ -106,6 +106,8 @@ data PackageIndex = PackageIndex
-- of the same package version. These are unique by InstalledPackageId
-- and are kept in preference order.
--
+ -- FIXME: Clarify what "preference order" means. Check that this invariant is
+ -- preserved. See #1463 for discussion.
!(Map PackageName (Map Version [InstalledPackageInfo]))
deriving (Show, Read)
diff --git a/cabal/Cabal/Distribution/Simple/PreProcess.hs b/cabal/Cabal/Distribution/Simple/PreProcess.hs
index 0c6cb3e..87afb3f 100644
--- a/cabal/Cabal/Distribution/Simple/PreProcess.hs
+++ b/cabal/Cabal/Distribution/Simple/PreProcess.hs
@@ -51,7 +51,7 @@ module Distribution.Simple.PreProcess (preprocessComponent, knownSuffixHandlers,
ppSuffixes, PPSuffixHandler, PreProcessor(..),
mkSimplePreProcessor, runSimplePreProcessor,
ppCpp, ppCpp', ppGreenCard, ppC2hs, ppHsc2hs,
- ppHappy, ppAlex, ppUnlit
+ ppHappy, ppAlex, ppUnlit, platformDefines
)
where
@@ -71,14 +71,16 @@ import Distribution.PackageDescription as PD
import qualified Distribution.InstalledPackageInfo as Installed
( InstalledPackageInfo_(..) )
import qualified Distribution.Simple.PackageIndex as PackageIndex
+import Distribution.Simple.CCompiler
+ ( cSourceExtensions )
import Distribution.Simple.Compiler
- ( CompilerFlavor(..), Compiler(..), compilerFlavor, compilerVersion )
+ ( CompilerFlavor(..), compilerFlavor, compilerVersion )
import Distribution.Simple.LocalBuildInfo
( LocalBuildInfo(..), Component(..) )
import Distribution.Simple.BuildPaths (autogenModulesDir,cppHeaderName)
import Distribution.Simple.Utils
( createDirectoryIfMissingVerbose, withUTF8FileContents, writeUTF8File
- , die, setupMessage, intercalate, copyFileVerbose
+ , die, setupMessage, intercalate, copyFileVerbose, moreRecentFile
, findFileWithExtension, findFileWithExtension' )
import Distribution.Simple.Program
( Program(..), ConfiguredProgram(..), programPath
@@ -88,7 +90,7 @@ import Distribution.Simple.Program
, happyProgram, alexProgram, haddockProgram, ghcProgram, gccProgram )
import Distribution.Simple.Test ( writeSimpleTestStub, stubFilePath, stubName )
import Distribution.System
- ( OS(OSX, Windows), buildOS )
+ ( OS(..), buildOS, Arch(..), Platform(..) )
import Distribution.Text
import Distribution.Version
( Version(..), anyVersion, orLaterVersion )
@@ -96,7 +98,7 @@ import Distribution.Verbosity
import Data.Maybe (fromMaybe)
import Data.List (nub)
-import System.Directory (getModificationTime, doesFileExist)
+import System.Directory (doesFileExist)
import System.Info (os, arch)
import System.FilePath (splitExtension, dropExtensions, (</>), (<.>),
takeDirectory, normalise, replaceExtension)
@@ -219,9 +221,11 @@ preprocessComponent pd comp lbi isSrcDist verbosity handlers = case comp of
BenchmarkUnsupported tt -> die $ "No support for preprocessing benchmark "
++ "type " ++ display tt
where
- builtinSuffixes
+ builtinHaskellSuffixes
| NHC == compilerFlavor (compiler lbi) = ["hs", "lhs", "gc"]
| otherwise = ["hs", "lhs"]
+ builtinCSuffixes = cSourceExtensions
+ builtinSuffixes = builtinHaskellSuffixes ++ builtinCSuffixes
localHandlers bi = [(ext, h bi lbi) | (ext, h) <- handlers]
pre dirs dir lhndlrs fp =
preprocessFile dirs dir isSrcDist fp verbosity builtinSuffixes lhndlrs
@@ -232,7 +236,7 @@ preprocessComponent pd comp lbi isSrcDist verbosity handlers = case comp of
preProcessComponent bi modules exePath dir = do
let biHandlers = localHandlers bi
sourceDirs = hsSourceDirs bi ++ [ autogenModulesDir lbi ]
- sequence_ [ preprocessFile sourceDirs (buildDir lbi) isSrcDist
+ sequence_ [ preprocessFile sourceDirs dir isSrcDist
(ModuleName.toFilePath modu) verbosity builtinSuffixes
biHandlers
| modu <- modules ]
@@ -294,10 +298,8 @@ preprocessFile searchLoc buildLoc forSDist baseFile verbosity builtinSuffixes ha
ppsrcFiles <- findFileWithExtension builtinSuffixes [buildLoc] baseFile
recomp <- case ppsrcFiles of
Nothing -> return True
- Just ppsrcFile -> do
- btime <- getModificationTime ppsrcFile
- ptime <- getModificationTime psrcFile
- return (btime < ptime)
+ Just ppsrcFile ->
+ psrcFile `moreRecentFile` ppsrcFile
when recomp $ do
let destDir = buildLoc </> dirName srcStem
createDirectoryIfMissingVerbose verbosity True destDir
@@ -445,13 +447,15 @@ ppHsc2hs bi lbi =
-- system's dynamic linker. This is needed because hsc2hs works by
-- compiling a C program and then running it.
- ++ [ "--cflag=" ++ opt | opt <- hcDefines (compiler lbi) ]
- ++ [ "--cflag=" ++ opt | opt <- sysDefines ]
+ ++ [ "--cflag=" ++ opt | opt <- platformDefines lbi ]
-- Options from the current package:
++ [ "--cflag=-I" ++ dir | dir <- PD.includeDirs bi ]
++ [ "--cflag=" ++ opt | opt <- PD.ccOptions bi
++ PD.cppOptions bi ]
+ ++ [ "--cflag=" ++ opt | opt <-
+ [ "-I" ++ autogenModulesDir lbi,
+ "-include", autogenModulesDir lbi </> cppHeaderName ] ]
++ [ "--lflag=-L" ++ opt | opt <- PD.extraLibDirs bi ]
++ [ "--lflag=-Wl,-R," ++ opt | isELF
, opt <- PD.extraLibDirs bi ]
@@ -462,9 +466,7 @@ ppHsc2hs bi lbi =
++ [ "--cflag=" ++ opt
| pkg <- pkgs
, opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ]
- ++ [ opt | opt <- Installed.ccOptions pkg ]
- ++ [ "-I" ++ autogenModulesDir lbi,
- "-include", autogenModulesDir lbi </> cppHeaderName ] ]
+ ++ [ opt | opt <- Installed.ccOptions pkg ] ]
++ [ "--lflag=" ++ opt
| pkg <- pkgs
, opt <- [ "-L" ++ opt | opt <- Installed.libraryDirs pkg ]
@@ -530,43 +532,78 @@ ppC2hs bi lbi =
--TODO: remove cc-options from cpphs for cabal-version: >= 1.10
getCppOptions :: BuildInfo -> LocalBuildInfo -> [String]
getCppOptions bi lbi
- = hcDefines (compiler lbi)
- ++ sysDefines
+ = platformDefines lbi
++ cppOptions bi
++ ["-I" ++ dir | dir <- PD.includeDirs bi]
++ [opt | opt@('-':c:_) <- PD.ccOptions bi, c `elem` "DIU"]
-sysDefines :: [String]
-sysDefines = ["-D" ++ os ++ "_" ++ loc ++ "_OS" | loc <- locations]
- ++ ["-D" ++ arch ++ "_" ++ loc ++ "_ARCH" | loc <- locations]
- where
- locations = ["BUILD", "HOST"]
-
-hcDefines :: Compiler -> [String]
-hcDefines comp =
+platformDefines :: LocalBuildInfo -> [String]
+platformDefines lbi =
case compilerFlavor comp of
- GHC -> ["-D__GLASGOW_HASKELL__=" ++ versionInt version]
+ GHC ->
+ ["-D__GLASGOW_HASKELL__=" ++ versionInt version] ++
+ ["-D" ++ os ++ "_BUILD_OS=1"] ++
+ ["-D" ++ arch ++ "_BUILD_ARCH=1"] ++
+ map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr ++
+ map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr
JHC -> ["-D__JHC__=" ++ versionInt version]
NHC -> ["-D__NHC__=" ++ versionInt version]
Hugs -> ["-D__HUGS__"]
+ HaskellSuite {} ->
+ ["-D__HASKELL_SUITE__"] ++
+ map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr ++
+ map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr
_ -> []
- where version = compilerVersion comp
-
--- TODO: move this into the compiler abstraction
--- FIXME: this forces GHC's crazy 4.8.2 -> 408 convention on all the other
--- compilers. Check if that's really what they want.
-versionInt :: Version -> String
-versionInt (Version { versionBranch = [] }) = "1"
-versionInt (Version { versionBranch = [n] }) = show n
-versionInt (Version { versionBranch = n1:n2:_ })
- = -- 6.8.x -> 608
- -- 6.10.x -> 610
- let s1 = show n1
- s2 = show n2
- middle = case s2 of
- _ : _ : _ -> ""
- _ -> "0"
- in s1 ++ middle ++ s2
+ where
+ comp = compiler lbi
+ Platform hostArch hostOS = hostPlatform lbi
+ version = compilerVersion comp
+ -- TODO: move this into the compiler abstraction
+ -- FIXME: this forces GHC's crazy 4.8.2 -> 408 convention on all
+ -- the other compilers. Check if that's really what they want.
+ versionInt :: Version -> String
+ versionInt (Version { versionBranch = [] }) = "1"
+ versionInt (Version { versionBranch = [n] }) = show n
+ versionInt (Version { versionBranch = n1:n2:_ })
+ = -- 6.8.x -> 608
+ -- 6.10.x -> 610
+ let s1 = show n1
+ s2 = show n2
+ middle = case s2 of
+ _ : _ : _ -> ""
+ _ -> "0"
+ in s1 ++ middle ++ s2
+ osStr = case hostOS of
+ Linux -> ["linux"]
+ Windows -> ["mingw32"]
+ OSX -> ["darwin"]
+ FreeBSD -> ["freebsd"]
+ OpenBSD -> ["openbsd"]
+ NetBSD -> ["netbsd"]
+ Solaris -> ["solaris2"]
+ AIX -> ["aix"]
+ HPUX -> ["hpux"]
+ IRIX -> ["irix"]
+ HaLVM -> []
+ IOS -> ["ios"]
+ OtherOS _ -> []
+ archStr = case hostArch of
+ I386 -> ["i386"]
+ X86_64 -> ["x86_64"]
+ PPC -> ["powerpc"]
+ PPC64 -> ["powerpc64"]
+ Sparc -> ["sparc"]
+ Arm -> ["arm"]
+ Mips -> ["mips"]
+ SH -> []
+ IA64 -> ["ia64"]
+ S390 -> ["s390"]
+ Alpha -> ["alpha"]
+ Hppa -> ["hppa"]
+ Rs6000 -> ["rs6000"]
+ M68k -> ["m68k"]
+ Vax -> ["vax"]
+ OtherArch _ -> []
ppHappy :: BuildInfo -> LocalBuildInfo -> PreProcessor
ppHappy _ lbi = pp { platformIndependent = True }
diff --git a/cabal/Cabal/Distribution/Simple/Program.hs b/cabal/Cabal/Distribution/Simple/Program.hs
index c57d553..c669178 100644
--- a/cabal/Cabal/Distribution/Simple/Program.hs
+++ b/cabal/Cabal/Distribution/Simple/Program.hs
@@ -35,6 +35,8 @@
module Distribution.Simple.Program (
-- * Program and functions for constructing them
Program(..)
+ , ProgramSearchPath
+ , ProgramSearchPathEntry(..)
, simpleProgram
, findProgramLocation
, findProgramVersion
@@ -46,6 +48,7 @@ module Distribution.Simple.Program (
, ProgramLocation(..)
, runProgram
, getProgramOutput
+ , suppressOverrideArgs
-- * Program invocations
, ProgramInvocation(..)
@@ -67,6 +70,8 @@ module Distribution.Simple.Program (
, addKnownPrograms
, lookupKnownProgram
, knownPrograms
+ , getProgramSearchPath
+ , setProgramSearchPath
, userSpecifyPath
, userSpecifyPaths
, userMaybeSpecifyPath
@@ -95,7 +100,6 @@ module Distribution.Simple.Program (
, ffihugsProgram
, uhcProgram
, gccProgram
- , ranlibProgram
, arProgram
, stripProgram
, happyProgram
diff --git a/cabal/Cabal/Distribution/Simple/Program/Ar.hs b/cabal/Cabal/Distribution/Simple/Program/Ar.hs
index ea68dba..d1aad63 100644
--- a/cabal/Cabal/Distribution/Simple/Program/Ar.hs
+++ b/cabal/Cabal/Distribution/Simple/Program/Ar.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Simple.Program.Ar
@@ -10,24 +12,43 @@
module Distribution.Simple.Program.Ar (
createArLibArchive,
- multiStageProgramInvocation,
+ multiStageProgramInvocation
) where
-import Distribution.Simple.Program.Types
- ( ConfiguredProgram(..) )
+import Control.Monad (when, unless)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BS8
+import Data.Char (isSpace)
+import Distribution.Compat.CopyFile (filesEqual)
+import Distribution.Simple.Program
+ ( ProgramConfiguration, arProgram, requireProgram )
import Distribution.Simple.Program.Run
( programInvocation, multiStageProgramInvocation
, runProgramInvocation )
+import qualified Distribution.Simple.Program.Strip as Strip
+ ( stripLib )
+import Distribution.Simple.Utils
+ ( dieWithLocation, withTempDirectory )
import Distribution.System
( OS(..), buildOS )
import Distribution.Verbosity
( Verbosity, deafening, verbose )
+import System.Directory (doesFileExist, renameFile)
+import System.FilePath ((</>), splitFileName)
+import System.IO
+ ( Handle, IOMode(ReadWriteMode), SeekMode(AbsoluteSeek)
+ , hFileSize, hSeek, withBinaryFile )
-- | Call @ar@ to create a library archive from a bunch of object files.
--
-createArLibArchive :: Verbosity -> ConfiguredProgram
+createArLibArchive :: Verbosity -> ProgramConfiguration -> Bool
-> FilePath -> [FilePath] -> IO ()
-createArLibArchive verbosity ar target files =
+createArLibArchive verbosity progConf stripLib targetPath files = do
+ (ar, _) <- requireProgram verbosity arProgram progConf
+
+ let (targetDir, targetName) = splitFileName targetPath
+ withTempDirectory verbosity targetDir targetName $ \ tmpDir -> do
+ let tmpPath = tmpDir </> targetName
-- The args to use with "ar" are actually rather subtle and system-dependent.
-- In particular we have the following issues:
@@ -52,19 +73,91 @@ createArLibArchive verbosity ar target files =
OSX -> ["-q", "-s"]
_ -> ["-q"]
- extraArgs = verbosityOpts verbosity ++ [target]
+ extraArgs = verbosityOpts verbosity ++ [tmpPath]
simple = programInvocation ar (simpleArgs ++ extraArgs)
initial = programInvocation ar (initialArgs ++ extraArgs)
middle = initial
final = programInvocation ar (finalArgs ++ extraArgs)
- in sequence_
+ sequence_
[ runProgramInvocation verbosity inv
| inv <- multiStageProgramInvocation
simple (initial, middle, final) files ]
+ when stripLib $ Strip.stripLib verbosity progConf tmpPath
+ wipeMetadata tmpPath
+ equal <- filesEqual tmpPath targetPath
+ unless equal $ renameFile tmpPath targetPath
+
where
verbosityOpts v | v >= deafening = ["-v"]
| v >= verbose = []
| otherwise = ["-c"]
+
+-- | @ar@ by default includes various metadata for each object file in their
+-- respective headers, so the output can differ for the same inputs, making
+-- it difficult to avoid re-linking. GNU @ar@(1) has a deterministic mode
+-- (@-D@) flag that always writes zero for the mtime, UID and GID, and 0644
+-- for the file mode. However detecting whether @-D@ is supported seems
+-- rather harder than just re-implementing this feature.
+wipeMetadata :: FilePath -> IO ()
+wipeMetadata path = do
+ -- Check for existence first (ReadWriteMode would create one otherwise)
+ exists <- doesFileExist path
+ unless exists $ wipeError "Temporary file disappeared"
+ withBinaryFile path ReadWriteMode $ \ h -> hFileSize h >>= wipeArchive h
+
+ where
+ wipeError msg = dieWithLocation path Nothing $
+ "Distribution.Simple.Program.Ar.wipeMetadata: " ++ msg
+ archLF = "!<arch>\x0a" -- global magic, 8 bytes
+ x60LF = "\x60\x0a" -- header magic, 2 bytes
+ metadata = BS.concat
+ [ "0 " -- mtime, 12 bytes
+ , "0 " -- UID, 6 bytes
+ , "0 " -- GID, 6 bytes
+ , "0644 " -- mode, 8 bytes
+ ]
+ headerSize = 60
+
+ -- http://en.wikipedia.org/wiki/Ar_(Unix)#File_format_details
+ wipeArchive :: Handle -> Integer -> IO ()
+ wipeArchive h archiveSize = do
+ global <- BS.hGet h (BS.length archLF)
+ unless (global == archLF) $ wipeError "Bad global header"
+ wipeHeader (toInteger $ BS.length archLF)
+
+ where
+ wipeHeader :: Integer -> IO ()
+ wipeHeader offset = case compare offset archiveSize of
+ EQ -> return ()
+ GT -> wipeError (atOffset "Archive truncated")
+ LT -> do
+ header <- BS.hGet h headerSize
+ unless (BS.length header == headerSize) $
+ wipeError (atOffset "Short header")
+ let magic = BS.drop 58 header
+ unless (magic == x60LF) . wipeError . atOffset $
+ "Bad magic " ++ show magic ++ " in header"
+
+ let name = BS.take 16 header
+ let size = BS.take 10 $ BS.drop 48 header
+ objSize <- case reads (BS8.unpack size) of
+ [(n, s)] | all isSpace s -> return n
+ _ -> wipeError (atOffset "Bad file size in header")
+
+ let replacement = BS.concat [ name, metadata, size, magic ]
+ unless (BS.length replacement == headerSize) $
+ wipeError (atOffset "Something has gone terribly wrong")
+ hSeek h AbsoluteSeek offset
+ BS.hPut h replacement
+
+ let nextHeader = offset + toInteger headerSize +
+ -- Odd objects are padded with an extra '\x0a'
+ if odd objSize then objSize + 1 else objSize
+ hSeek h AbsoluteSeek nextHeader
+ wipeHeader nextHeader
+
+ where
+ atOffset msg = msg ++ " at offset " ++ show offset
diff --git a/cabal/Cabal/Distribution/Simple/Program/Builtin.hs b/cabal/Cabal/Distribution/Simple/Program/Builtin.hs
index 48446fa..f31b9d5 100644
--- a/cabal/Cabal/Distribution/Simple/Program/Builtin.hs
+++ b/cabal/Cabal/Distribution/Simple/Program/Builtin.hs
@@ -25,9 +25,10 @@ module Distribution.Simple.Program.Builtin (
jhcProgram,
hugsProgram,
ffihugsProgram,
+ haskellSuiteProgram,
+ haskellSuitePkgProgram,
uhcProgram,
gccProgram,
- ranlibProgram,
arProgram,
stripProgram,
happyProgram,
@@ -47,8 +48,10 @@ module Distribution.Simple.Program.Builtin (
import Distribution.Simple.Program.Types
( Program(..), simpleProgram )
+import Distribution.Simple.Program.Find
+ ( findProgramOnSearchPath )
import Distribution.Simple.Utils
- ( findProgramLocation, findProgramVersion )
+ ( findProgramVersion )
-- ------------------------------------------------------------
-- * Known programs
@@ -64,6 +67,8 @@ builtinPrograms =
, ghcPkgProgram
, hugsProgram
, ffihugsProgram
+ , haskellSuiteProgram
+ , haskellSuitePkgProgram
, nhcProgram
, hmakeProgram
, jhcProgram
@@ -82,7 +87,6 @@ builtinPrograms =
, greencardProgram
-- platform toolchain
, gccProgram
- , ranlibProgram
, arProgram
, stripProgram
, ldProgram
@@ -173,6 +177,39 @@ hugsProgram = simpleProgram "hugs"
ffihugsProgram :: Program
ffihugsProgram = simpleProgram "ffihugs"
+-- This represents a haskell-suite compiler. Of course, the compiler
+-- itself probably is not called "haskell-suite", so this is not a real
+-- program. (But we don't know statically the name of the actual compiler,
+-- so this is the best we can do.)
+--
+-- Having this Program value serves two purposes:
+--
+-- 1. We can accept options for the compiler in the form of
+--
+-- --haskell-suite-option(s)=...
+--
+-- 2. We can find a program later using this static id (with
+-- requireProgram).
+--
+-- The path to the real compiler is found and recorded in the ProgramDb
+-- during the configure phase.
+haskellSuiteProgram :: Program
+haskellSuiteProgram = (simpleProgram "haskell-suite") {
+ -- pretend that the program exists, otherwise it won't be in the
+ -- "configured" state
+ programFindLocation =
+ \_verbosity _searchPath -> return $ Just "haskell-suite-dummy-location"
+ }
+
+-- This represent a haskell-suite package manager. See the comments for
+-- haskellSuiteProgram.
+haskellSuitePkgProgram :: Program
+haskellSuitePkgProgram = (simpleProgram "haskell-suite-pkg") {
+ programFindLocation =
+ \_verbosity _searchPath -> return $ Just "haskell-suite-pkg-dummy-location"
+ }
+
+
happyProgram :: Program
happyProgram = (simpleProgram "happy") {
programFindVersion = findProgramVersion "--version" $ \str ->
@@ -198,9 +235,6 @@ gccProgram = (simpleProgram "gcc") {
programFindVersion = findProgramVersion "-dumpversion" id
}
-ranlibProgram :: Program
-ranlibProgram = simpleProgram "ranlib"
-
arProgram :: Program
arProgram = simpleProgram "ar"
@@ -233,7 +267,7 @@ cpphsProgram = (simpleProgram "cpphs") {
hscolourProgram :: Program
hscolourProgram = (simpleProgram "hscolour") {
- programFindLocation = \v -> findProgramLocation v "HsColour",
+ programFindLocation = \v p -> findProgramOnSearchPath v p "HsColour",
programFindVersion = findProgramVersion "-version" $ \str ->
-- Invoking "HsColour -version" gives a string like "HsColour 1.7"
case words str of
diff --git a/cabal/Cabal/Distribution/Simple/Program/Db.hs b/cabal/Cabal/Distribution/Simple/Program/Db.hs
index c01cf74..4d0d3af 100644
--- a/cabal/Cabal/Distribution/Simple/Program/Db.hs
+++ b/cabal/Cabal/Distribution/Simple/Program/Db.hs
@@ -32,6 +32,8 @@ module Distribution.Simple.Program.Db (
addKnownPrograms,
lookupKnownProgram,
knownPrograms,
+ getProgramSearchPath,
+ setProgramSearchPath,
userSpecifyPath,
userSpecifyPaths,
userMaybeSpecifyPath,
@@ -40,6 +42,7 @@ module Distribution.Simple.Program.Db (
userSpecifiedArgs,
lookupProgram,
updateProgram,
+ configuredPrograms,
-- ** Query and manipulate the program db
configureProgram,
@@ -52,10 +55,13 @@ module Distribution.Simple.Program.Db (
import Distribution.Simple.Program.Types
( Program(..), ProgArg, ConfiguredProgram(..), ProgramLocation(..) )
+import Distribution.Simple.Program.Find
+ ( ProgramSearchPath, defaultProgramSearchPath
+ , findProgramOnSearchPath, programSearchPathAsPATHVar )
import Distribution.Simple.Program.Builtin
( builtinPrograms )
import Distribution.Simple.Utils
- ( die, findProgramLocation )
+ ( die, doesExecutableExist )
import Distribution.Version
( Version, VersionRange, isAnyVersion, withinRange )
import Distribution.Text
@@ -70,9 +76,6 @@ import Data.Maybe
import qualified Data.Map as Map
import Control.Monad
( join, foldM )
-import System.Directory
- ( doesFileExist )
-
-- ------------------------------------------------------------
-- * Programs database
@@ -88,6 +91,7 @@ import System.Directory
-- 'Program' but also any user-provided arguments and location for the program.
data ProgramDb = ProgramDb {
unconfiguredProgs :: UnconfiguredProgs,
+ progSearchPath :: ProgramSearchPath,
configuredProgs :: ConfiguredProgs
}
@@ -97,8 +101,7 @@ type ConfiguredProgs = Map.Map String ConfiguredProgram
emptyProgramDb :: ProgramDb
-emptyProgramDb = ProgramDb Map.empty Map.empty
-
+emptyProgramDb = ProgramDb Map.empty defaultProgramSearchPath Map.empty
defaultProgramDb :: ProgramDb
defaultProgramDb = restoreProgramDb builtinPrograms emptyProgramDb
@@ -166,6 +169,21 @@ knownPrograms conf =
[ (p,p') | (p,_,_) <- Map.elems (unconfiguredProgs conf)
, let p' = Map.lookup (programName p) (configuredProgs conf) ]
+-- | Get the current 'ProgramSearchPath' used by the 'ProgramDb'.
+-- This is the default list of locations where programs are looked for when
+-- configuring them. This can be overriden for specific programs (with
+-- 'userSpecifyPath'), and specific known programs can modify or ignore this
+-- search path in their own configuration code.
+--
+getProgramSearchPath :: ProgramDb -> ProgramSearchPath
+getProgramSearchPath = progSearchPath
+
+-- | Change the current 'ProgramSearchPath' used by the 'ProgramDb'.
+-- This will affect programs that are configured from here on, so you
+-- should usually set it before configuring any programs.
+--
+setProgramSearchPath :: ProgramSearchPath -> ProgramDb -> ProgramDb
+setProgramSearchPath searchpath db = db { progSearchPath = searchpath }
-- |User-specify this path. Basically override any path information
-- for this program in the configuration. If it's not a known
@@ -248,6 +266,10 @@ updateProgram prog = updateConfiguredProgs $
Map.insert (programId prog) prog
+-- | List all configured programs.
+configuredPrograms :: ProgramDb -> [ConfiguredProgram]
+configuredPrograms = Map.elems . configuredProgs
+
-- ---------------------------
-- Configuring known programs
@@ -272,31 +294,32 @@ configureProgram :: Verbosity
configureProgram verbosity prog conf = do
let name = programName prog
maybeLocation <- case userSpecifiedPath prog conf of
- Nothing -> programFindLocation prog verbosity
+ Nothing -> programFindLocation prog verbosity (progSearchPath conf)
>>= return . fmap FoundOnSystem
Just path -> do
- absolute <- doesFileExist path
+ absolute <- doesExecutableExist path
if absolute
then return (Just (UserSpecified path))
- else findProgramLocation verbosity path
+ else findProgramOnSearchPath verbosity (progSearchPath conf) path
>>= maybe (die notFound) (return . Just . UserSpecified)
- where notFound = "Cannot find the program '" ++ name ++ "' at '"
- ++ path ++ "' or on the path"
+ where notFound = "Cannot find the program '" ++ name
+ ++ "'. User-specified path '"
+ ++ path ++ "' does not refer to an executable and "
+ ++ "the program is not on the system path."
case maybeLocation of
Nothing -> return conf
Just location -> do
version <- programFindVersion prog verbosity (locationPath location)
+ newPath <- programSearchPathAsPATHVar (progSearchPath conf)
let configuredProg = ConfiguredProgram {
programId = name,
programVersion = version,
programDefaultArgs = [],
programOverrideArgs = userSpecifiedArgs prog conf,
+ programOverrideEnv = [("PATH", Just newPath)],
programLocation = location
}
- extraArgs <- programPostConf prog verbosity configuredProg
- let configuredProg' = configuredProg {
- programDefaultArgs = extraArgs
- }
+ configuredProg' <- programPostConf prog verbosity configuredProg
return (updateConfiguredProgs (Map.insert name configuredProg') conf)
diff --git a/cabal/Cabal/Distribution/Simple/Program/Find.hs b/cabal/Cabal/Distribution/Simple/Program/Find.hs
new file mode 100644
index 0000000..73de277
--- /dev/null
+++ b/cabal/Cabal/Distribution/Simple/Program/Find.hs
@@ -0,0 +1,125 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Simple.Program.Types
+-- Copyright : Duncan Coutts 2013
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Portability : portable
+--
+-- A somewhat extended notion of the normal program search path concept.
+--
+-- Usually when finding executables we just want to look in the usual places
+-- using the OS's usual method for doing so. In Haskell the normal OS-specific
+-- method is captured by 'findExecutable'. On all common OSs that makes use of
+-- a @PATH@ environment variable, (though on Windows it is not just the @PATH@).
+--
+-- However it is sometimes useful to be able to look in additional locations
+-- without having to change the process-global @PATH@ environment variable.
+-- So we need an extension of the usual 'findExecutable' that can look in
+-- additional locations, either before, after or instead of the normal OS
+-- locations.
+--
+module Distribution.Simple.Program.Find (
+ -- * Program search path
+ ProgramSearchPath,
+ ProgramSearchPathEntry(..),
+ defaultProgramSearchPath,
+ findProgramOnSearchPath,
+ programSearchPathAsPATHVar,
+ ) where
+
+import Distribution.Verbosity
+ ( Verbosity )
+import Distribution.Simple.Utils
+ ( debug, doesExecutableExist )
+import Distribution.System
+ ( OS(..), buildOS )
+import System.Directory
+ ( findExecutable )
+import Distribution.Compat.Environment
+ ( getEnvironment )
+import System.FilePath
+ ( (</>), (<.>), splitSearchPath, searchPathSeparator )
+import Data.List
+ ( intercalate )
+
+
+-- | A search path to use when locating executables. This is analogous
+-- to the unix @$PATH@ or win32 @%PATH%@ but with the ability to use
+-- the system default method for finding executables ('findExecutable' which
+-- on unix is simply looking on the @$PATH@ but on win32 is a bit more
+-- complicated).
+--
+-- The default to use is @[ProgSearchPathDefault]@ but you can add extra dirs
+-- either before, after or instead of the default, e.g. here we add an extra
+-- dir to search after the usual ones.
+--
+-- > ['ProgramSearchPathDefault', 'ProgramSearchPathDir' dir]
+--
+type ProgramSearchPath = [ProgramSearchPathEntry]
+data ProgramSearchPathEntry =
+ ProgramSearchPathDir FilePath -- ^ A specific dir
+ | ProgramSearchPathDefault -- ^ The system default
+
+defaultProgramSearchPath :: ProgramSearchPath
+defaultProgramSearchPath = [ProgramSearchPathDefault]
+
+findProgramOnSearchPath :: Verbosity -> ProgramSearchPath
+ -> FilePath -> IO (Maybe FilePath)
+findProgramOnSearchPath verbosity searchpath prog = do
+ debug verbosity $ "Searching for " ++ prog ++ " in path."
+ res <- tryPathElems searchpath
+ case res of
+ Nothing -> debug verbosity ("Cannot find " ++ prog ++ " on the path")
+ Just path -> debug verbosity ("Found " ++ prog ++ " at "++ path)
+ return res
+ where
+ tryPathElems [] = return Nothing
+ tryPathElems (pe:pes) = do
+ res <- tryPathElem pe
+ case res of
+ Nothing -> tryPathElems pes
+ Just _ -> return res
+
+ tryPathElem (ProgramSearchPathDir dir) =
+ findFirstExe [ dir </> prog <.> ext | ext <- extensions ]
+ where
+ -- Possible improvement: on Windows, read the list of extensions from
+ -- the PATHEXT environment variable. By default PATHEXT is ".com; .exe;
+ -- .bat; .cmd".
+ extensions = case buildOS of
+ Windows -> ["", "exe"]
+ _ -> [""]
+
+ tryPathElem ProgramSearchPathDefault = do
+ -- 'findExecutable' doesn't check that the path really refers to an
+ -- executable on Windows (at least with GHC < 7.8). See
+ -- https://ghc.haskell.org/trac/ghc/ticket/2184
+ mExe <- findExecutable prog
+ case mExe of
+ Just exe -> do
+ exeExists <- doesExecutableExist exe
+ if exeExists
+ then return mExe
+ else return Nothing
+ _ -> return mExe
+
+ findFirstExe [] = return Nothing
+ findFirstExe (f:fs) = do
+ isExe <- doesExecutableExist f
+ if isExe
+ then return (Just f)
+ else findFirstExe fs
+
+-- | Interpret a 'ProgramSearchPath' to construct a new @$PATH@ env var.
+-- Note that this is close but not perfect because on Windows the search
+-- algorithm looks at more than just the @%PATH%@.
+programSearchPathAsPATHVar :: ProgramSearchPath -> IO String
+programSearchPathAsPATHVar searchpath = do
+ ess <- mapM getEntries searchpath
+ return (intercalate [searchPathSeparator] (concat ess))
+ where
+ getEntries (ProgramSearchPathDir dir) = return [dir]
+ getEntries ProgramSearchPathDefault = do
+ env <- getEnvironment
+ return (maybe [] splitSearchPath (lookup "PATH" env))
diff --git a/cabal/Cabal/Distribution/Simple/Program/GHC.hs b/cabal/Cabal/Distribution/Simple/Program/GHC.hs
index 340c04e..fe57054 100644
--- a/cabal/Cabal/Distribution/Simple/Program/GHC.hs
+++ b/cabal/Cabal/Distribution/Simple/Program/GHC.hs
@@ -2,6 +2,7 @@ module Distribution.Simple.Program.GHC (
GhcOptions(..),
GhcMode(..),
GhcOptimisation(..),
+ GhcDynLinkMode(..),
ghcInvocation,
renderGhcOptions,
@@ -13,18 +14,18 @@ module Distribution.Simple.Program.GHC (
import Distribution.Package
import Distribution.ModuleName
import Distribution.Simple.Compiler hiding (Flag)
-import Distribution.Simple.Setup (Flag(..), flagToMaybe, fromFlagOrDefault, flagToList)
+import Distribution.Simple.Setup ( Flag(..), flagToMaybe, fromFlagOrDefault,
+ flagToList )
--import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Program.Types
import Distribution.Simple.Program.Run
import Distribution.Text
import Distribution.Verbosity
import Distribution.Version
-import Language.Haskell.Extension ( Language(..), Extension(..) )
+import Language.Haskell.Extension ( Language(..), Extension(..) )
import Data.Monoid
-
-- | A structured set of GHC options/flags
--
data GhcOptions = GhcOptions {
@@ -52,6 +53,10 @@ data GhcOptions = GhcOptions {
-- | Location for output file; the @ghc -o@ flag.
ghcOptOutputFile :: Flag FilePath,
+ -- | Location for dynamic output file in 'GhcStaticAndDynamic' mode;
+ -- the @ghc -dyno@ flag.
+ ghcOptOutputDynFile :: Flag FilePath,
+
-- | Start with an empty search path for Haskell source files;
-- the @ghc -i@ flag (@-i@ on it's own with no path argument).
ghcOptSourcePathClear :: Flag Bool,
@@ -97,6 +102,9 @@ data GhcOptions = GhcOptions {
-- | Don't do the link step, useful in make mode; the @ghc -no-link@ flag.
ghcOptNoLink :: Flag Bool,
+ -- | Don't link in the normal RTS @main@ entry point; the @ghc -no-hs-main@ flag.
+ ghcOptLinkNoHsMain :: Flag Bool,
+
--------------------
-- C and CPP stuff
@@ -140,6 +148,9 @@ data GhcOptions = GhcOptions {
-- | Use the \"split object files\" feature; the @ghc -split-objs@ flag.
ghcOptSplitObjs :: Flag Bool,
+ -- | Run N jobs simultaneously (if possible).
+ ghcOptNumJobs :: Flag Int,
+
----------------
-- GHCi
@@ -151,14 +162,17 @@ data GhcOptions = GhcOptions {
ghcOptHiSuffix :: Flag String,
ghcOptObjSuffix :: Flag String,
+ ghcOptDynHiSuffix :: Flag String, -- ^ only in 'GhcStaticAndDynamic' mode
+ ghcOptDynObjSuffix :: Flag String, -- ^ only in 'GhcStaticAndDynamic' mode
ghcOptHiDir :: Flag FilePath,
ghcOptObjDir :: Flag FilePath,
+ ghcOptOutputDir :: Flag FilePath,
ghcOptStubDir :: Flag FilePath,
--------------------
-- Dynamic linking
- ghcOptDynamic :: Flag Bool,
+ ghcOptDynLinkMode :: Flag GhcDynLinkMode,
ghcOptShared :: Flag Bool,
ghcOptFPic :: Flag Bool,
ghcOptDylibName :: Flag String,
@@ -191,21 +205,28 @@ data GhcOptimisation = GhcNoOptimisation -- ^ @-O0@
| GhcSpecialOptimisation String -- ^ e.g. @-Odph@
deriving (Show, Eq)
+data GhcDynLinkMode = GhcStaticOnly -- ^ @-static@
+ | GhcDynamicOnly -- ^ @-dynamic@
+ | GhcStaticAndDynamic -- ^ @-static -dynamic-too@
+ deriving (Show, Eq)
-runGHC :: Verbosity -> ConfiguredProgram -> GhcOptions -> IO ()
-runGHC verbosity ghcProg opts = do
- runProgramInvocation verbosity (ghcInvocation ghcProg opts)
+runGHC :: Verbosity -> ConfiguredProgram -> Compiler -> GhcOptions -> IO ()
+runGHC verbosity ghcProg comp opts = do
+ runProgramInvocation verbosity (ghcInvocation ghcProg comp opts)
-ghcInvocation :: ConfiguredProgram -> GhcOptions -> ProgramInvocation
-ghcInvocation ConfiguredProgram { programVersion = Nothing } _ =
- error "ghcInvocation: the programVersion must not be Nothing"
-ghcInvocation prog@ConfiguredProgram { programVersion = Just ver } opts =
- programInvocation prog (renderGhcOptions ver opts)
+ghcInvocation :: ConfiguredProgram -> Compiler -> GhcOptions -> ProgramInvocation
+ghcInvocation prog comp opts =
+ programInvocation prog (renderGhcOptions comp opts)
-renderGhcOptions :: Version -> GhcOptions -> [String]
-renderGhcOptions version@(Version ver _) opts =
+
+renderGhcOptions :: Compiler -> GhcOptions -> [String]
+renderGhcOptions comp opts
+ | compilerFlavor comp /= GHC =
+ error $ "Distribution.Simple.Program.GHC.renderGhcOptions: "
+ ++ "compiler flavor must be 'GHC'!"
+ | otherwise =
concat
[ case flagToMaybe (ghcOptMode opts) of
Nothing -> []
@@ -242,11 +263,22 @@ renderGhcOptions version@(Version ver _) opts =
, [ "-split-objs" | flagBool ghcOptSplitObjs ]
+
+ , if parmakeSupported comp
+ then
+ let numJobs = fromFlagOrDefault 1 (ghcOptNumJobs opts)
+ in if numJobs > 1 then ["-j" ++ show numJobs] else []
+ else []
+
--------------------
-- Dynamic linking
, [ "-shared" | flagBool ghcOptShared ]
- , [ "-dynamic" | flagBool ghcOptDynamic ]
+ , case flagToMaybe (ghcOptDynLinkMode opts) of
+ Nothing -> []
+ Just GhcStaticOnly -> ["-static"]
+ Just GhcDynamicOnly -> ["-dynamic"]
+ Just GhcStaticAndDynamic -> ["-static", "-dynamic-too"]
, [ "-fPIC" | flagBool ghcOptFPic ]
, concat [ ["-dylib-install-name", libname] | libname <- flag ghcOptDylibName ]
@@ -256,6 +288,9 @@ renderGhcOptions version@(Version ver _) opts =
, concat [ ["-osuf", suf] | suf <- flag ghcOptObjSuffix ]
, concat [ ["-hisuf", suf] | suf <- flag ghcOptHiSuffix ]
+ , concat [ ["-dynosuf", suf] | suf <- flag ghcOptDynObjSuffix ]
+ , concat [ ["-dynhisuf",suf] | suf <- flag ghcOptDynHiSuffix ]
+ , concat [ ["-outputdir", dir] | dir <- flag ghcOptOutputDir, ver >= [6,10] ]
, concat [ ["-odir", dir] | dir <- flag ghcOptObjDir ]
, concat [ ["-hidir", dir] | dir <- flag ghcOptHiDir ]
, concat [ ["-stubdir", dir] | dir <- flag ghcOptStubDir, ver >= [6,8] ]
@@ -282,6 +317,7 @@ renderGhcOptions version@(Version ver _) opts =
, ["-l" ++ lib | lib <- flags ghcOptLinkLibs ]
, ["-L" ++ dir | dir <- flags ghcOptLinkLibPath ]
, concat [ ["-framework", fmwk] | fmwk <- flags ghcOptLinkFrameworks ]
+ , [ "-no-hs-main" | flagBool ghcOptLinkNoHsMain ]
-------------
-- Packages
@@ -306,8 +342,8 @@ renderGhcOptions version@(Version ver _) opts =
, [ case lookup ext (ghcOptExtensionMap opts) of
Just arg -> arg
- Nothing -> error $ "renderGhcOptions: " ++ display ext
- ++ " not present in ghcOptExtensionMap."
+ Nothing -> error $ "Distribution.Simple.Program.GHC.renderGhcOptions: "
+ ++ display ext ++ " not present in ghcOptExtensionMap."
| ext <- ghcOptExtensions opts ]
----------------
@@ -322,7 +358,8 @@ renderGhcOptions version@(Version ver _) opts =
, [ display modu | modu <- flags ghcOptInputModules ]
, ghcOptInputFiles opts
- , concat [ [ "-o", out] | out <- flag ghcOptOutputFile ]
+ , concat [ [ "-o", out] | out <- flag ghcOptOutputFile ]
+ , concat [ [ "-dyno", out] | out <- flag ghcOptOutputDynFile ]
---------------
-- Extra
@@ -337,6 +374,7 @@ renderGhcOptions version@(Version ver _) opts =
flags flg = flg opts
flagBool flg = fromFlagOrDefault False (flg opts)
+ version@(Version ver _) = compilerVersion comp
verbosityOpts :: Verbosity -> [String]
verbosityOpts verbosity
@@ -375,6 +413,7 @@ instance Monoid GhcOptions where
ghcOptInputFiles = mempty,
ghcOptInputModules = mempty,
ghcOptOutputFile = mempty,
+ ghcOptOutputDynFile = mempty,
ghcOptSourcePathClear = mempty,
ghcOptSourcePath = mempty,
ghcOptPackageName = mempty,
@@ -387,6 +426,7 @@ instance Monoid GhcOptions where
ghcOptLinkOptions = mempty,
ghcOptLinkFrameworks = mempty,
ghcOptNoLink = mempty,
+ ghcOptLinkNoHsMain = mempty,
ghcOptCcOptions = mempty,
ghcOptCppOptions = mempty,
ghcOptCppIncludePath = mempty,
@@ -398,13 +438,17 @@ instance Monoid GhcOptions where
ghcOptOptimisation = mempty,
ghcOptProfilingMode = mempty,
ghcOptSplitObjs = mempty,
+ ghcOptNumJobs = mempty,
ghcOptGHCiScripts = mempty,
ghcOptHiSuffix = mempty,
ghcOptObjSuffix = mempty,
+ ghcOptDynHiSuffix = mempty,
+ ghcOptDynObjSuffix = mempty,
ghcOptHiDir = mempty,
ghcOptObjDir = mempty,
+ ghcOptOutputDir = mempty,
ghcOptStubDir = mempty,
- ghcOptDynamic = mempty,
+ ghcOptDynLinkMode = mempty,
ghcOptShared = mempty,
ghcOptFPic = mempty,
ghcOptDylibName = mempty,
@@ -418,6 +462,7 @@ instance Monoid GhcOptions where
ghcOptInputFiles = combine ghcOptInputFiles,
ghcOptInputModules = combine ghcOptInputModules,
ghcOptOutputFile = combine ghcOptOutputFile,
+ ghcOptOutputDynFile = combine ghcOptOutputDynFile,
ghcOptSourcePathClear = combine ghcOptSourcePathClear,
ghcOptSourcePath = combine ghcOptSourcePath,
ghcOptPackageName = combine ghcOptPackageName,
@@ -430,6 +475,7 @@ instance Monoid GhcOptions where
ghcOptLinkOptions = combine ghcOptLinkOptions,
ghcOptLinkFrameworks = combine ghcOptLinkFrameworks,
ghcOptNoLink = combine ghcOptNoLink,
+ ghcOptLinkNoHsMain = combine ghcOptLinkNoHsMain,
ghcOptCcOptions = combine ghcOptCcOptions,
ghcOptCppOptions = combine ghcOptCppOptions,
ghcOptCppIncludePath = combine ghcOptCppIncludePath,
@@ -441,13 +487,17 @@ instance Monoid GhcOptions where
ghcOptOptimisation = combine ghcOptOptimisation,
ghcOptProfilingMode = combine ghcOptProfilingMode,
ghcOptSplitObjs = combine ghcOptSplitObjs,
+ ghcOptNumJobs = combine ghcOptNumJobs,
ghcOptGHCiScripts = combine ghcOptGHCiScripts,
ghcOptHiSuffix = combine ghcOptHiSuffix,
ghcOptObjSuffix = combine ghcOptObjSuffix,
+ ghcOptDynHiSuffix = combine ghcOptDynHiSuffix,
+ ghcOptDynObjSuffix = combine ghcOptDynObjSuffix,
ghcOptHiDir = combine ghcOptHiDir,
ghcOptObjDir = combine ghcOptObjDir,
+ ghcOptOutputDir = combine ghcOptOutputDir,
ghcOptStubDir = combine ghcOptStubDir,
- ghcOptDynamic = combine ghcOptDynamic,
+ ghcOptDynLinkMode = combine ghcOptDynLinkMode,
ghcOptShared = combine ghcOptShared,
ghcOptFPic = combine ghcOptFPic,
ghcOptDylibName = combine ghcOptDylibName,
diff --git a/cabal/Cabal/Distribution/Simple/Program/HcPkg.hs b/cabal/Cabal/Distribution/Simple/Program/HcPkg.hs
index de01a47..213146a 100644
--- a/cabal/Cabal/Distribution/Simple/Program/HcPkg.hs
+++ b/cabal/Cabal/Distribution/Simple/Program/HcPkg.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Simple.Program.HcPkg
--- Copyright : Duncan Coutts 2009
+-- Copyright : Duncan Coutts 2009, 2013
--
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
@@ -11,12 +11,14 @@
module Distribution.Simple.Program.HcPkg (
init,
+ invoke,
register,
reregister,
unregister,
expose,
hide,
dump,
+ list,
-- * Program invocations
initInvocation,
@@ -26,6 +28,7 @@ module Distribution.Simple.Program.HcPkg (
exposeInvocation,
hideInvocation,
dumpInvocation,
+ listInvocation,
) where
import Prelude hiding (init)
@@ -46,7 +49,7 @@ import Distribution.Simple.Program.Run
import Distribution.Version
( Version(..) )
import Distribution.Text
- ( display )
+ ( display, simpleParse )
import Distribution.Simple.Utils
( die )
import Distribution.Verbosity
@@ -74,6 +77,15 @@ init verbosity hcPkg path =
runProgramInvocation verbosity
(initInvocation hcPkg verbosity path)
+-- | Run @hc-pkg@ using a given package DB stack, directly forwarding the
+-- provided command-line arguments to it.
+invoke :: Verbosity -> ConfiguredProgram -> PackageDBStack -> [String] -> IO ()
+invoke verbosity hcPkg dbStack extraArgs =
+ runProgramInvocation verbosity invocation
+ where
+ args = packageDbStackOpts hcPkg dbStack ++ extraArgs
+ invocation = programInvocation hcPkg args
+
-- | Call @hc-pkg@ to register a package.
--
-- > hc-pkg register {filename | -} [--user | --global | --package-db]
@@ -130,7 +142,8 @@ hide verbosity hcPkg packagedb pkgid =
(hideInvocation hcPkg verbosity packagedb pkgid)
--- | Call @hc-pkg@ to get all the installed packages.
+-- | Call @hc-pkg@ to get all the details of all the packages in the given
+-- package database.
--
dump :: Verbosity -> ConfiguredProgram -> PackageDB -> IO [InstalledPackageInfo]
dump verbosity hcPkg packagedb = do
@@ -236,6 +249,33 @@ setInstalledPackageId pkginfo@InstalledPackageInfo {
setInstalledPackageId pkginfo = pkginfo
+-- | Call @hc-pkg@ to get the source package Id of all the packages in the
+-- given package database.
+--
+-- This is much less information than with 'dump', but also rather quicker.
+-- Note in particular that it does not include the 'InstalledPackageId', just
+-- the source 'PackageId' which is not necessarily unique in any package db.
+--
+list :: Verbosity -> ConfiguredProgram -> PackageDB -> IO [PackageId]
+list verbosity hcPkg packagedb = do
+
+ output <- getProgramInvocationOutput verbosity
+ (listInvocation hcPkg verbosity packagedb)
+ `catchExit` \_ -> die $ programId hcPkg ++ " list failed"
+
+ case parsePackageIds output of
+ Just ok -> return ok
+ _ -> die $ "failed to parse output of '"
+ ++ programId hcPkg ++ " list'"
+
+ where
+ parsePackageIds str =
+ let parsed = map simpleParse (words str)
+ in case [ () | Nothing <- parsed ] of
+ [] -> Just [ pkgid | Just pkgid <- parsed ]
+ _ -> Nothing
+
+
--------------------------
-- The program invocations
--
@@ -319,6 +359,18 @@ dumpInvocation hcPkg _verbosity packagedb =
-- We use verbosity level 'silent' because it is important that we
-- do not contaminate the output with info/debug messages.
+listInvocation :: ConfiguredProgram
+ -> Verbosity -> PackageDB -> ProgramInvocation
+listInvocation hcPkg _verbosity packagedb =
+ (programInvocation hcPkg args) {
+ progInvokeOutputEncoding = IOEncodingUTF8
+ }
+ where
+ args = ["list", "--simple-output", packageDbOpts hcPkg packagedb]
+ ++ verbosityOpts hcPkg silent
+ -- We use verbosity level 'silent' because it is important that we
+ -- do not contaminate the output with info/debug messages.
+
packageDbStackOpts :: ConfiguredProgram -> PackageDBStack -> [String]
packageDbStackOpts hcPkg dbstack = case dbstack of
diff --git a/cabal/Cabal/Distribution/Simple/Program/Hpc.hs b/cabal/Cabal/Distribution/Simple/Program/Hpc.hs
index 9de5c64..9f99871 100644
--- a/cabal/Cabal/Distribution/Simple/Program/Hpc.hs
+++ b/cabal/Cabal/Distribution/Simple/Program/Hpc.hs
@@ -16,34 +16,61 @@ module Distribution.Simple.Program.Hpc
import Distribution.ModuleName ( ModuleName )
import Distribution.Simple.Program.Run
( ProgramInvocation, programInvocation, runProgramInvocation )
-import Distribution.Simple.Program.Types ( ConfiguredProgram )
+import Distribution.Simple.Program.Types ( ConfiguredProgram(..) )
import Distribution.Text ( display )
+import Distribution.Simple.Utils ( warn )
import Distribution.Verbosity ( Verbosity )
+import Distribution.Version ( Version(..), orLaterVersion, withinRange )
+-- | Invoke hpc with the given parameters.
+--
+-- Prior to HPC version 0.7 (packaged with GHC 7.8), hpc did not handle
+-- multiple .mix paths correctly, so we print a warning, and only pass it the
+-- first path in the list. This means that e.g. test suites that import their
+-- library as a dependency can still work, but those that include the library
+-- modules directly (in other-modules) don't.
markup :: ConfiguredProgram
+ -> Version
-> Verbosity
-> FilePath -- ^ Path to .tix file
- -> FilePath -- ^ Path to directory with .mix files
+ -> [FilePath] -- ^ Paths to .mix file directories
-> FilePath -- ^ Path where html output should be located
-> [ModuleName] -- ^ List of modules to exclude from report
-> IO ()
-markup hpc verbosity tixFile hpcDir destDir excluded =
+markup hpc hpcVer verbosity tixFile hpcDirs destDir excluded = do
+ hpcDirs' <- if withinRange hpcVer (orLaterVersion version07)
+ then return hpcDirs
+ else do
+ warn verbosity $ "Your version of HPC (" ++ display hpcVer
+ ++ ") does not properly handle multiple search paths. "
+ ++ "Coverage report generation may fail unexpectedly. These "
+ ++ "issues are addressed in version 0.7 or later (GHC 7.8 or "
+ ++ "later)."
+ ++ if null droppedDirs
+ then ""
+ else " The following search paths have been abandoned: "
+ ++ show droppedDirs
+ return passedDirs
+
runProgramInvocation verbosity
- (markupInvocation hpc tixFile hpcDir destDir excluded)
+ (markupInvocation hpc tixFile hpcDirs' destDir excluded)
+ where
+ version07 = Version { versionBranch = [0, 7], versionTags = [] }
+ (passedDirs, droppedDirs) = splitAt 1 hpcDirs
markupInvocation :: ConfiguredProgram
-> FilePath -- ^ Path to .tix file
- -> FilePath -- ^ Path to directory with .mix files
+ -> [FilePath] -- ^ Paths to .mix file directories
-> FilePath -- ^ Path where html output should be
-- located
-> [ModuleName] -- ^ List of modules to exclude from
-- report
-> ProgramInvocation
-markupInvocation hpc tixFile hpcDir destDir excluded =
+markupInvocation hpc tixFile hpcDirs destDir excluded =
let args = [ "markup", tixFile
- , "--hpcdir=" ++ hpcDir
, "--destdir=" ++ destDir
]
+ ++ map ("--hpcdir=" ++) hpcDirs
++ ["--exclude=" ++ display moduleName
| moduleName <- excluded ]
in programInvocation hpc args
diff --git a/cabal/Cabal/Distribution/Simple/Program/Run.hs b/cabal/Cabal/Distribution/Simple/Program/Run.hs
index 5ab689e..5268be6 100644
--- a/cabal/Cabal/Distribution/Simple/Program/Run.hs
+++ b/cabal/Cabal/Distribution/Simple/Program/Run.hs
@@ -20,22 +20,26 @@ module Distribution.Simple.Program.Run (
runProgramInvocation,
getProgramInvocationOutput,
+ getEffectiveEnvironment,
) where
import Distribution.Simple.Program.Types
( ConfiguredProgram(..), programPath )
import Distribution.Simple.Utils
- ( die, rawSystemExit, rawSystemStdInOut
+ ( die, rawSystemExit, rawSystemIOWithEnv, rawSystemStdInOut
, toUTF8, fromUTF8, normaliseLineEndings )
import Distribution.Verbosity
( Verbosity )
import Data.List
( foldl', unfoldr )
+import qualified Data.Map as Map
import Control.Monad
( when )
import System.Exit
- ( ExitCode(..) )
+ ( ExitCode(..), exitWith )
+import Distribution.Compat.Environment
+ ( getEnvironment )
-- | Represents a specific invocation of a specific program.
--
@@ -47,7 +51,7 @@ import System.Exit
data ProgramInvocation = ProgramInvocation {
progInvokePath :: FilePath,
progInvokeArgs :: [String],
- progInvokeEnv :: [(String, String)],
+ progInvokeEnv :: [(String, Maybe String)],
progInvokeCwd :: Maybe FilePath,
progInvokeInput :: Maybe String,
progInvokeInputEncoding :: IOEncoding,
@@ -82,7 +86,8 @@ programInvocation prog args =
progInvokePath = programPath prog,
progInvokeArgs = programDefaultArgs prog
++ args
- ++ programOverrideArgs prog
+ ++ programOverrideArgs prog,
+ progInvokeEnv = programOverrideEnv prog
}
@@ -101,23 +106,39 @@ runProgramInvocation verbosity
ProgramInvocation {
progInvokePath = path,
progInvokeArgs = args,
- progInvokeEnv = [],
- progInvokeCwd = Nothing,
+ progInvokeEnv = envOverrides,
+ progInvokeCwd = mcwd,
+ progInvokeInput = Nothing
+ } = do
+ menv <- getEffectiveEnvironment envOverrides
+ exitCode <- rawSystemIOWithEnv verbosity
+ path args
+ mcwd menv
+ Nothing Nothing Nothing
+ when (exitCode /= ExitSuccess) $
+ exitWith exitCode
+
+runProgramInvocation verbosity
+ ProgramInvocation {
+ progInvokePath = path,
+ progInvokeArgs = args,
+ progInvokeEnv = envOverrides,
+ progInvokeCwd = mcwd,
progInvokeInput = Just inputStr,
progInvokeInputEncoding = encoding
} = do
+ menv <- getEffectiveEnvironment envOverrides
(_, errors, exitCode) <- rawSystemStdInOut verbosity
path args
- (Just input) False
+ mcwd menv
+ (Just input) True
when (exitCode /= ExitSuccess) $
die errors
where
input = case encoding of
IOEncodingText -> (inputStr, False)
- IOEncodingUTF8 -> (toUTF8 inputStr, True) -- use binary mode for utf8
-
-runProgramInvocation _ _ =
- die "runProgramInvocation: not yet implemented for this form of invocation"
+ IOEncodingUTF8 -> (toUTF8 inputStr, True) -- use binary mode for
+ -- utf8
getProgramInvocationOutput :: Verbosity -> ProgramInvocation -> IO String
@@ -125,25 +146,43 @@ getProgramInvocationOutput verbosity
ProgramInvocation {
progInvokePath = path,
progInvokeArgs = args,
- progInvokeEnv = [],
- progInvokeCwd = Nothing,
- progInvokeInput = Nothing,
+ progInvokeEnv = envOverrides,
+ progInvokeCwd = mcwd,
+ progInvokeInput = minputStr,
progInvokeOutputEncoding = encoding
} = do
- let utf8 = case encoding of IOEncodingUTF8 -> True; _ -> False
- decode | utf8 = fromUTF8 . normaliseLineEndings
- | otherwise = id
- (output, errors, exitCode) <- rawSystemStdInOut verbosity
- path args
- Nothing utf8
- when (exitCode /= ExitSuccess) $
- die errors
- return (decode output)
-
+ let utf8 = case encoding of IOEncodingUTF8 -> True; _ -> False
+ decode | utf8 = fromUTF8 . normaliseLineEndings
+ | otherwise = id
+ menv <- getEffectiveEnvironment envOverrides
+ (output, errors, exitCode) <- rawSystemStdInOut verbosity
+ path args
+ mcwd menv
+ input utf8
+ when (exitCode /= ExitSuccess) $
+ die errors
+ return (decode output)
+ where
+ input =
+ case minputStr of
+ Nothing -> Nothing
+ Just inputStr -> Just $
+ case encoding of
+ IOEncodingText -> (inputStr, False)
+ IOEncodingUTF8 -> (toUTF8 inputStr, True) -- use binary mode for utf8
-getProgramInvocationOutput _ _ =
- die "getProgramInvocationOutput: not yet implemented for this form of invocation"
+-- | Return the current environment extended with the given overrides.
+--
+getEffectiveEnvironment :: [(String, Maybe String)]
+ -> IO (Maybe [(String, String)])
+getEffectiveEnvironment [] = return Nothing
+getEffectiveEnvironment overrides =
+ fmap (Just . Map.toList . apply overrides . Map.fromList) getEnvironment
+ where
+ apply os env = foldl' (flip update) env os
+ update (var, Nothing) = Map.delete var
+ update (var, Just val) = Map.insert var val
-- | Like the unix xargs program. Useful for when we've got very long command
-- lines that might overflow an OS limit on command line length and so you
diff --git a/cabal/Cabal/Distribution/Simple/Program/Script.hs b/cabal/Cabal/Distribution/Simple/Program/Script.hs
index 71b3cf1..1365388 100644
--- a/cabal/Cabal/Distribution/Simple/Program/Script.hs
+++ b/cabal/Cabal/Distribution/Simple/Program/Script.hs
@@ -44,8 +44,7 @@ invocationAsShellScript
progInvokeInput = minput
} = unlines $
[ "#!/bin/sh" ]
- ++ [ "export " ++ var ++ "=" ++ quote val
- | (var,val) <- envExtra ]
+ ++ concatMap setEnv envExtra
++ [ "cd " ++ quote cwd | cwd <- maybeToList mcwd ]
++ [ (case minput of
Nothing -> ""
@@ -53,6 +52,9 @@ invocationAsShellScript
++ unwords (map quote $ path : args) ++ " \"$@\""]
where
+ setEnv (var, Nothing) = ["unset " ++ var, "export " ++ var]
+ setEnv (var, Just val) = ["export " ++ var ++ "=" ++ quote val]
+
quote :: String -> String
quote s = "'" ++ escape s ++ "'"
@@ -73,7 +75,7 @@ invocationAsBatchFile
progInvokeInput = minput
} = unlines $
[ "@echo off" ]
- ++ [ "set " ++ var ++ "=" ++ escape val | (var,val) <- envExtra ]
+ ++ map setEnv envExtra
++ [ "cd \"" ++ cwd ++ "\"" | cwd <- maybeToList mcwd ]
++ case minput of
Nothing ->
@@ -87,6 +89,9 @@ invocationAsBatchFile
++ concatMap (\arg -> ' ':quote arg) args ]
where
+ setEnv (var, Nothing) = "set " ++ var ++ "="
+ setEnv (var, Just val) = "set " ++ var ++ "=" ++ escape val
+
quote :: String -> String
quote s = "\"" ++ escapeQ s ++ "\""
diff --git a/cabal/Cabal/Distribution/Simple/Program/Strip.hs b/cabal/Cabal/Distribution/Simple/Program/Strip.hs
new file mode 100644
index 0000000..bc9331c
--- /dev/null
+++ b/cabal/Cabal/Distribution/Simple/Program/Strip.hs
@@ -0,0 +1,48 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Simple.Program.Strip
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Portability : portable
+--
+-- This module provides an library interface to the @strip@ program.
+
+module Distribution.Simple.Program.Strip (stripLib, stripExe)
+ where
+
+import Distribution.Simple.Program (ProgramConfiguration, lookupProgram
+ ,rawSystemProgram, stripProgram)
+import Distribution.Simple.Utils (warn)
+import Distribution.System (OS (..), buildOS)
+import Distribution.Verbosity (Verbosity)
+
+import Control.Monad (unless)
+import System.FilePath (takeBaseName)
+
+runStrip :: Verbosity -> ProgramConfiguration -> FilePath -> [String] -> IO ()
+runStrip verbosity progConf path args =
+ case lookupProgram stripProgram progConf of
+ Just strip -> rawSystemProgram verbosity strip (path:args)
+ Nothing -> unless (buildOS == Windows) $
+ -- Don't bother warning on windows, we don't expect them to
+ -- have the strip program anyway.
+ warn verbosity $ "Unable to strip executable or library '"
+ ++ (takeBaseName path)
+ ++ "' (missing the 'strip' program)"
+
+stripExe :: Verbosity -> ProgramConfiguration -> FilePath -> IO ()
+stripExe verbosity conf path =
+ runStrip verbosity conf path args
+ where
+ args = case buildOS of
+ OSX -> ["-x"] -- By default, stripping the ghc binary on at least
+ -- some OS X installations causes:
+ -- HSbase-3.0.o: unknown symbol `_environ'"
+ -- The -x flag fixes that.
+ _ -> []
+
+stripLib :: Verbosity -> ProgramConfiguration -> FilePath -> IO ()
+stripLib verbosity conf path = do
+ runStrip verbosity conf path args
+ where
+ args = ["--strip-unneeded"]
diff --git a/cabal/Cabal/Distribution/Simple/Program/Types.hs b/cabal/Cabal/Distribution/Simple/Program/Types.hs
index fc3f553..e41e917 100644
--- a/cabal/Cabal/Distribution/Simple/Program/Types.hs
+++ b/cabal/Cabal/Distribution/Simple/Program/Types.hs
@@ -17,18 +17,22 @@
module Distribution.Simple.Program.Types (
-- * Program and functions for constructing them
Program(..),
+ ProgramSearchPath,
+ ProgramSearchPathEntry(..),
simpleProgram,
-- * Configured program and related functions
ConfiguredProgram(..),
programPath,
+ suppressOverrideArgs,
ProgArg,
ProgramLocation(..),
simpleConfiguredProgram,
) where
-import Distribution.Simple.Utils
- ( findProgramLocation )
+import Distribution.Simple.Program.Find
+ ( ProgramSearchPath, ProgramSearchPathEntry(..)
+ , findProgramOnSearchPath )
import Distribution.Version
( Version )
import Distribution.Verbosity
@@ -43,19 +47,23 @@ data Program = Program {
-- | The simple name of the program, eg. ghc
programName :: String,
- -- | A function to search for the program if it's location was not
- -- specified by the user. Usually this will just be a
- programFindLocation :: Verbosity -> IO (Maybe FilePath),
+ -- | A function to search for the program if its location was not
+ -- specified by the user. Usually this will just be a call to
+ -- 'findProgramOnSearchPath'.
+ --
+ -- It is supplied with the prevailing search path which will typically
+ -- just be used as-is, but can be extended or ignored as needed.
+ programFindLocation :: Verbosity -> ProgramSearchPath
+ -> IO (Maybe FilePath),
-- | Try to find the version of the program. For many programs this is
-- not possible or is not necessary so it's ok to return Nothing.
programFindVersion :: Verbosity -> FilePath -> IO (Maybe Version),
-- | A function to do any additional configuration after we have
- -- located the program (and perhaps identified its version). It is
- -- allowed to return additional flags that will be passed to the
- -- program on every invocation.
- programPostConf :: Verbosity -> ConfiguredProgram -> IO [ProgArg]
+ -- located the program (and perhaps identified its version). For example
+ -- it could add args, or environment vars.
+ programPostConf :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
}
type ProgArg = String
@@ -83,6 +91,11 @@ data ConfiguredProgram = ConfiguredProgram {
-- all earlier flags.
programOverrideArgs :: [String],
+ -- | Override environment variables for this program.
+ -- These env vars will extend\/override the prevailing environment of
+ -- the current to form the environment for the new process.
+ programOverrideEnv :: [(String, Maybe String)],
+
-- | Location of the program. eg. @\/usr\/bin\/ghc-6.4@
programLocation :: ProgramLocation
} deriving (Read, Show, Eq)
@@ -101,6 +114,10 @@ data ProgramLocation
programPath :: ConfiguredProgram -> FilePath
programPath = locationPath . programLocation
+-- | Suppress any extra arguments added by the user.
+suppressOverrideArgs :: ConfiguredProgram -> ConfiguredProgram
+suppressOverrideArgs prog = prog { programOverrideArgs = [] }
+
-- | Make a simple named program.
--
-- By default we'll just search for it in the path and not try to find the
@@ -111,9 +128,9 @@ programPath = locationPath . programLocation
simpleProgram :: String -> Program
simpleProgram name = Program {
programName = name,
- programFindLocation = \v -> findProgramLocation v name,
+ programFindLocation = \v p -> findProgramOnSearchPath v p name,
programFindVersion = \_ _ -> return Nothing,
- programPostConf = \_ _ -> return []
+ programPostConf = \_ p -> return p
}
-- | Make a simple 'ConfiguredProgram'.
@@ -126,5 +143,6 @@ simpleConfiguredProgram name loc = ConfiguredProgram {
programVersion = Nothing,
programDefaultArgs = [],
programOverrideArgs = [],
+ programOverrideEnv = [],
programLocation = loc
}
diff --git a/cabal/Cabal/Distribution/Simple/Register.hs b/cabal/Cabal/Distribution/Simple/Register.hs
index 496c99a..db9acd9 100644
--- a/cabal/Cabal/Distribution/Simple/Register.hs
+++ b/cabal/Cabal/Distribution/Simple/Register.hs
@@ -58,6 +58,7 @@ module Distribution.Simple.Register (
unregister,
initPackageDB,
+ invokeHcPkg,
registerPackage,
generateRegistrationInfo,
inplaceInstalledPackageInfo,
@@ -67,12 +68,15 @@ module Distribution.Simple.Register (
import Distribution.Simple.LocalBuildInfo
( LocalBuildInfo(..), ComponentLocalBuildInfo(..)
+ , ComponentName(..), getComponentLocalBuildInfo
+ , LibraryName(..)
, InstallDirs(..), absoluteInstallDirs )
import Distribution.Simple.BuildPaths (haddockName)
import qualified Distribution.Simple.GHC as GHC
import qualified Distribution.Simple.LHC as LHC
import qualified Distribution.Simple.Hugs as Hugs
import qualified Distribution.Simple.UHC as UHC
+import qualified Distribution.Simple.HaskellSuite as HaskellSuite
import Distribution.Simple.Compiler
( compilerVersion, Compiler, CompilerFlavor(..), compilerFlavor
, PackageDBStack, registrationPackageDB )
@@ -123,10 +127,9 @@ import qualified Data.ByteString.Lazy.Char8 as BS.Char8
register :: PackageDescription -> LocalBuildInfo
-> RegisterFlags -- ^Install in the user's database?; verbose
-> IO ()
-register pkg@PackageDescription { library = Just lib }
- lbi@LocalBuildInfo { libraryConfig = Just clbi } regFlags
+register pkg@PackageDescription { library = Just lib } lbi regFlags
= do
-
+ let clbi = getComponentLocalBuildInfo lbi CLibName
installedPkgInfo <- generateRegistrationInfo
verbosity pkg lib lbi clbi inplace distPref
@@ -212,7 +215,19 @@ initPackageDB :: Verbosity -> Compiler -> ProgramConfiguration -> FilePath
initPackageDB verbosity comp conf dbPath =
case (compilerFlavor comp) of
GHC -> GHC.initPackageDB verbosity conf dbPath
- _ -> die "initPackageDB is not implemented for this compiler"
+ HaskellSuite {} -> HaskellSuite.initPackageDB verbosity conf dbPath
+ _ -> die "Distribution.Simple.Register.initPackageDB: \
+ \not implemented for this compiler"
+
+-- | Run @hc-pkg@ using a given package DB stack, directly forwarding the
+-- provided command-line arguments to it.
+invokeHcPkg :: Verbosity -> Compiler -> ProgramConfiguration -> PackageDBStack
+ -> [String] -> IO ()
+invokeHcPkg verbosity comp conf dbStack extraArgs =
+ case (compilerFlavor comp) of
+ GHC -> GHC.invokeHcPkg verbosity conf dbStack extraArgs
+ _ -> die "Distribution.Simple.Register.invokeHcPkg: \
+ \not implemented for this compiler"
registerPackage :: Verbosity
-> InstalledPackageInfo
@@ -233,6 +248,8 @@ registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs = do
UHC -> UHC.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs
JHC -> notice verbosity "Registering for jhc (nothing to do)"
NHC -> notice verbosity "Registering for nhc98 (nothing to do)"
+ HaskellSuite {} ->
+ HaskellSuite.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs
_ -> die "Registering is not implemented for this compiler"
@@ -293,7 +310,9 @@ generalInstalledPackageInfo adjustRelIncDirs pkg lib clbi installDirs =
IPI.libraryDirs = if hasLibrary
then libdir installDirs : extraLibDirs bi
else extraLibDirs bi,
- IPI.hsLibraries = [ "HS" ++ display (packageId pkg) | hasLibrary ],
+ IPI.hsLibraries = [ libname
+ | LibraryName libname <- componentLibraries clbi
+ , hasLibrary ],
IPI.extraLibraries = extraLibs bi,
IPI.extraGHCiLibraries = [],
IPI.includeDirs = absinc ++ adjustRelIncDirs relinc,
diff --git a/cabal/Cabal/Distribution/Simple/Setup.hs b/cabal/Cabal/Distribution/Simple/Setup.hs
index 89e242c..30d2f41 100644
--- a/cabal/Cabal/Distribution/Simple/Setup.hs
+++ b/cabal/Cabal/Distribution/Simple/Setup.hs
@@ -56,26 +56,32 @@ 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. -}
+{-# LANGUAGE CPP #-}
+
module Distribution.Simple.Setup (
GlobalFlags(..), emptyGlobalFlags, defaultGlobalFlags, globalCommand,
ConfigFlags(..), emptyConfigFlags, defaultConfigFlags, configureCommand,
+ configAbsolutePaths, readPackageDbList, showPackageDbList,
CopyFlags(..), emptyCopyFlags, defaultCopyFlags, copyCommand,
InstallFlags(..), emptyInstallFlags, defaultInstallFlags, installCommand,
HaddockFlags(..), emptyHaddockFlags, defaultHaddockFlags, haddockCommand,
HscolourFlags(..), emptyHscolourFlags, defaultHscolourFlags, hscolourCommand,
BuildFlags(..), emptyBuildFlags, defaultBuildFlags, buildCommand,
buildVerbose,
+ ReplFlags(..), defaultReplFlags, replCommand,
CleanFlags(..), emptyCleanFlags, defaultCleanFlags, cleanCommand,
RegisterFlags(..), emptyRegisterFlags, defaultRegisterFlags, registerCommand,
unregisterCommand,
SDistFlags(..), emptySDistFlags, defaultSDistFlags, sdistCommand,
TestFlags(..), emptyTestFlags, defaultTestFlags, testCommand,
TestShowDetails(..),
- BenchmarkFlags(..), emptyBenchmarkFlags, defaultBenchmarkFlags, benchmarkCommand,
+ BenchmarkFlags(..), emptyBenchmarkFlags,
+ defaultBenchmarkFlags, benchmarkCommand,
CopyDest(..),
configureArgs, configureOptions, configureCCompiler, configureLinker,
buildOptions, installDirsOptions,
+ programConfigurationOptions, programConfigurationPaths',
defaultDistPref,
@@ -85,7 +91,7 @@ module Distribution.Simple.Setup (
fromFlagOrDefault,
flagToMaybe,
flagToList,
- boolOpt, boolOpt', trueArg, falseArg, optionVerbosity ) where
+ boolOpt, boolOpt', trueArg, falseArg, optionVerbosity, optionNumJobs ) where
import Distribution.Compiler ()
import Distribution.ReadE
@@ -93,14 +99,17 @@ import Distribution.Text
( Text(..), display )
import qualified Distribution.Compat.ReadP as Parse
import qualified Text.PrettyPrint as Disp
-import Distribution.Package ( Dependency(..) )
+import Distribution.Package ( Dependency(..)
+ , PackageName
+ , InstalledPackageId )
import Distribution.PackageDescription
( FlagName(..), FlagAssignment )
import Distribution.Simple.Command hiding (boolOpt, boolOpt')
import qualified Distribution.Simple.Command as Command
import Distribution.Simple.Compiler
( CompilerFlavor(..), defaultCompilerFlavor, PackageDB(..)
- , OptimisationLevel(..), flagToOptimisationLevel )
+ , OptimisationLevel(..), flagToOptimisationLevel
+ , absolutePackageDBPath )
import Distribution.Simple.Utils
( wrapLine, lowercase, intercalate )
import Distribution.Simple.Program (Program(..), ProgramConfiguration,
@@ -114,6 +123,7 @@ import Distribution.Simple.InstallDirs
PathTemplate, toPathTemplate, fromPathTemplate )
import Distribution.Verbosity
+import Control.Monad (liftM)
import Data.List ( sort )
import Data.Char ( isSpace, isAlpha )
import Data.Monoid ( Monoid(..) )
@@ -152,7 +162,7 @@ instance Functor Flag where
instance Monoid (Flag a) where
mempty = NoFlag
_ `mappend` f@(Flag _) = f
- f `mappend` NoFlag = f
+ f `mappend` NoFlag = f
instance Bounded a => Bounded (Flag a) where
minBound = toFlag minBound
@@ -189,6 +199,9 @@ flagToList :: Flag a -> [a]
flagToList (Flag x) = [x]
flagToList NoFlag = []
+allFlags :: [Flag Bool] -> Flag Bool
+allFlags flags = toFlag $ all (\f -> fromFlagOrDefault False f) flags
+
-- ------------------------------------------------------------
-- * Global flags
-- ------------------------------------------------------------
@@ -261,23 +274,30 @@ data ConfigFlags = ConfigFlags {
-- because the type of configure is constrained by the UserHooks.
-- when we change UserHooks next we should pass the initial
-- ProgramConfiguration directly and not via ConfigFlags
- configPrograms :: ProgramConfiguration, -- ^All programs that cabal may run
+ configPrograms :: ProgramConfiguration, -- ^All programs that cabal may
+ -- run
configProgramPaths :: [(String, FilePath)], -- ^user specifed programs paths
configProgramArgs :: [(String, [String])], -- ^user specifed programs args
- configHcFlavor :: Flag CompilerFlavor, -- ^The \"flavor\" of the compiler, sugh as GHC or Hugs.
+ configProgramPathExtra :: [FilePath], -- ^Extend the $PATH
+ configHcFlavor :: Flag CompilerFlavor, -- ^The \"flavor\" of the
+ -- compiler, sugh as GHC or
+ -- Hugs.
configHcPath :: Flag FilePath, -- ^given compiler location
configHcPkg :: Flag FilePath, -- ^given hc-pkg location
configVanillaLib :: Flag Bool, -- ^Enable vanilla library
configProfLib :: Flag Bool, -- ^Enable profiling in the library
configSharedLib :: Flag Bool, -- ^Build shared library
- configDynExe :: Flag Bool, -- ^Enable dynamic linking of the executables.
- configProfExe :: Flag Bool, -- ^Enable profiling in the executables.
+ configDynExe :: Flag Bool, -- ^Enable dynamic linking of the
+ -- executables.
+ configProfExe :: Flag Bool, -- ^Enable profiling in the
+ -- executables.
configConfigureArgs :: [String], -- ^Extra arguments to @configure@
configOptimization :: Flag OptimisationLevel, -- ^Enable optimization.
configProgPrefix :: Flag PathTemplate, -- ^Installed executable prefix.
configProgSuffix :: Flag PathTemplate, -- ^Installed executable suffix.
- configInstallDirs :: InstallDirs (Flag PathTemplate), -- ^Installation paths
+ configInstallDirs :: InstallDirs (Flag PathTemplate), -- ^Installation
+ -- paths
configScratchDir :: Flag FilePath,
configExtraLibDirs :: [FilePath], -- ^ path to search for extra libraries
configExtraIncludeDirs :: [FilePath], -- ^ path to search for header files
@@ -289,22 +309,35 @@ data ConfigFlags = ConfigFlags {
configGHCiLib :: Flag Bool, -- ^Enable compiling library for GHCi
configSplitObjs :: Flag Bool, -- ^Enable -split-objs with GHC
configStripExes :: Flag Bool, -- ^Enable executable stripping
+ configStripLibs :: Flag Bool, -- ^Enable library stripping
configConstraints :: [Dependency], -- ^Additional constraints for
- -- dependencies
+ -- dependencies.
+ configDependencies :: [(PackageName, InstalledPackageId)],
+ -- ^The packages depended on.
configConfigurationsFlags :: FlagAssignment,
- configTests :: Flag Bool, -- ^Enable test suite compilation
- configBenchmarks :: Flag Bool, -- ^Enable benchmark compilation
- configLibCoverage :: Flag Bool -- ^ Enable test suite program coverage
+ configTests :: Flag Bool, -- ^Enable test suite compilation
+ configBenchmarks :: Flag Bool, -- ^Enable benchmark compilation
+ configLibCoverage :: Flag Bool,
+ -- ^Enable test suite program coverage.
+ configExactConfiguration :: Flag Bool
+ -- ^All direct dependencies and flags are provided on the command line by
+ -- the user via the '--dependency' and '--flags' options.
}
deriving (Read,Show)
+configAbsolutePaths :: ConfigFlags -> IO ConfigFlags
+configAbsolutePaths f =
+ (\v -> f { configPackageDBs = v })
+ `liftM` mapM (maybe (return Nothing) (liftM Just . absolutePackageDBPath))
+ (configPackageDBs f)
+
defaultConfigFlags :: ProgramConfiguration -> ConfigFlags
defaultConfigFlags progConf = emptyConfigFlags {
configPrograms = progConf,
configHcFlavor = maybe NoFlag Flag defaultCompilerFlavor,
configVanillaLib = Flag True,
configProfLib = Flag False,
- configSharedLib = Flag False,
+ configSharedLib = NoFlag,
configDynExe = Flag False,
configProfExe = Flag False,
configOptimization = Flag NormalOptimisation,
@@ -313,16 +346,24 @@ defaultConfigFlags progConf = emptyConfigFlags {
configDistPref = Flag defaultDistPref,
configVerbosity = Flag normal,
configUserInstall = Flag False, --TODO: reverse this
+#if defined(mingw32_HOST_OS)
+ -- See #1589.
+ configGHCiLib = Flag True,
+#else
configGHCiLib = Flag False,
+#endif
configSplitObjs = Flag False, -- takes longer, so turn off by default
configStripExes = Flag True,
- configTests = Flag False,
+ configStripLibs = Flag True,
+ configTests = Flag False,
configBenchmarks = Flag False,
- configLibCoverage = Flag False
+ configLibCoverage = Flag False,
+ configExactConfiguration = Flag False
}
configureCommand :: ProgramConfiguration -> CommandUI ConfigFlags
-configureCommand progConf = makeCommand name shortDesc longDesc defaultFlags options
+configureCommand progConf = makeCommand name shortDesc
+ longDesc defaultFlags options
where
name = "configure"
shortDesc = "Prepare to build the package."
@@ -332,13 +373,15 @@ configureCommand progConf = makeCommand name shortDesc longDesc defaultFlags opt
configureOptions showOrParseArgs
++ programConfigurationPaths progConf showOrParseArgs
configProgramPaths (\v fs -> fs { configProgramPaths = v })
+ ++ programConfigurationOption progConf showOrParseArgs
+ configProgramArgs (\v fs -> fs { configProgramArgs = v })
++ programConfigurationOptions progConf showOrParseArgs
configProgramArgs (\v fs -> fs { configProgramArgs = v })
-
configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags]
configureOptions showOrParseArgs =
- [optionVerbosity configVerbosity (\v flags -> flags { configVerbosity = v })
+ [optionVerbosity configVerbosity
+ (\v flags -> flags { configVerbosity = v })
,optionDistPref
configDistPref (\d flags -> flags { configDistPref = d })
showOrParseArgs
@@ -350,7 +393,12 @@ configureOptions showOrParseArgs =
, (Flag JHC, ([] , ["jhc"]), "compile with JHC")
, (Flag LHC, ([] , ["lhc"]), "compile with LHC")
, (Flag Hugs,([] , ["hugs"]), "compile with Hugs")
- , (Flag UHC, ([] , ["uhc"]), "compile with UHC")])
+ , (Flag UHC, ([] , ["uhc"]), "compile with UHC")
+
+ -- "haskell-suite" compiler id string will be replaced
+ -- by a more specific one during the configure stage
+ , (Flag (HaskellSuite "haskell-suite"), ([] , ["haskell-suite"]),
+ "compile with a haskell-suite compiler")])
,option "w" ["with-compiler"]
"give the path to a particular compiler"
@@ -435,6 +483,11 @@ configureOptions showOrParseArgs =
configStripExes (\v flags -> flags { configStripExes = v })
(boolOpt [] [])
+ ,option "" ["library-stripping"]
+ "strip libraries upon installation to reduce binary sizes"
+ configStripLibs (\v flags -> flags { configStripLibs = v })
+ (boolOpt [] [])
+
,option "" ["configure-option"]
"Extra option for configure"
configConfigureArgs (\v flags -> flags { configConfigureArgs = v })
@@ -464,20 +517,42 @@ configureOptions showOrParseArgs =
"A list of directories to search for external libraries"
configExtraLibDirs (\v flags -> flags {configExtraLibDirs = v})
(reqArg' "PATH" (\x -> [x]) id)
+
+ ,option "" ["extra-prog-path"]
+ "A list of directories to search for required programs (in addition to the normal search locations)"
+ configProgramPathExtra (\v flags -> flags {configProgramPathExtra = v})
+ (reqArg' "PATH" (\x -> [x]) id)
+
,option "" ["constraint"]
"A list of additional constraints on the dependencies."
configConstraints (\v flags -> flags { configConstraints = v})
(reqArg "DEPENDENCY"
(readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parse))
(map (\x -> display x)))
+
+ ,option "" ["dependency"]
+ "A list of exact dependencies. E.g., --dependency=\"void=void-0.5.8-177d5cdf20962d0581fe2e4932a6c309\""
+ configDependencies (\v flags -> flags { configDependencies = v})
+ (reqArg "NAME=ID"
+ (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parseDependency))
+ (map (\x -> display (fst x) ++ "=" ++ display (snd x))))
+
,option "" ["tests"]
"dependency checking and compilation for test suites listed in the package description file."
configTests (\v flags -> flags { configTests = v })
(boolOpt [] [])
+
,option "" ["library-coverage"]
"build library and test suites with Haskell Program Coverage enabled. (GHC only)"
configLibCoverage (\v flags -> flags { configLibCoverage = v })
(boolOpt [] [])
+
+ ,option "" ["exact-configuration"]
+ "All direct dependencies and flags are provided on the command line."
+ configExactConfiguration
+ (\v flags -> flags { configExactConfiguration = v })
+ trueArg
+
,option "" ["benchmarks"]
"dependency checking and compilation for benchmarks listed in the package description file."
configBenchmarks (\v flags -> flags { configBenchmarks = v })
@@ -493,20 +568,6 @@ configureOptions showOrParseArgs =
showFlagList fs = [ if not set then '-':fname else fname
| (FlagName fname, set) <- fs]
- readPackageDbList :: String -> [Maybe PackageDB]
- readPackageDbList "clear" = [Nothing]
- readPackageDbList "global" = [Just GlobalPackageDB]
- readPackageDbList "user" = [Just UserPackageDB]
- readPackageDbList other = [Just (SpecificPackageDB other)]
-
- showPackageDbList :: [Maybe PackageDB] -> [String]
- showPackageDbList = map showPackageDb
- where
- showPackageDb Nothing = "clear"
- showPackageDb (Just GlobalPackageDB) = "global"
- showPackageDb (Just UserPackageDB) = "user"
- showPackageDb (Just (SpecificPackageDB db)) = db
-
liftInstallDirs =
liftOption configInstallDirs (\v flags -> flags { configInstallDirs = v })
@@ -514,6 +575,28 @@ configureOptions showOrParseArgs =
reqArgFlag title _sf _lf d
(fmap fromPathTemplate . get) (set . fmap toPathTemplate)
+readPackageDbList :: String -> [Maybe PackageDB]
+readPackageDbList "clear" = [Nothing]
+readPackageDbList "global" = [Just GlobalPackageDB]
+readPackageDbList "user" = [Just UserPackageDB]
+readPackageDbList other = [Just (SpecificPackageDB other)]
+
+showPackageDbList :: [Maybe PackageDB] -> [String]
+showPackageDbList = map showPackageDb
+ where
+ showPackageDb Nothing = "clear"
+ showPackageDb (Just GlobalPackageDB) = "global"
+ showPackageDb (Just UserPackageDB) = "user"
+ showPackageDb (Just (SpecificPackageDB db)) = db
+
+
+parseDependency :: Parse.ReadP r (PackageName, InstalledPackageId)
+parseDependency = do
+ x <- parse
+ _ <- Parse.char '='
+ y <- parse
+ return (x, y)
+
installDirsOptions :: [OptionField (InstallDirs (Flag PathTemplate))]
installDirsOptions =
[ option "" ["prefix"]
@@ -565,6 +648,11 @@ installDirsOptions =
"installation directory for haddock interfaces"
haddockdir (\v flags -> flags { haddockdir = v })
installDirArg
+
+ , option "" ["sysconfdir"]
+ "installation directory for configuration files"
+ sysconfdir (\v flags -> flags { sysconfdir = v })
+ installDirArg
]
where
installDirArg _sf _lf d get set =
@@ -579,6 +667,7 @@ instance Monoid ConfigFlags where
configPrograms = error "FIXME: remove configPrograms",
configProgramPaths = mempty,
configProgramArgs = mempty,
+ configProgramPathExtra = mempty,
configHcFlavor = mempty,
configHcPath = mempty,
configHcPkg = mempty,
@@ -600,18 +689,22 @@ instance Monoid ConfigFlags where
configGHCiLib = mempty,
configSplitObjs = mempty,
configStripExes = mempty,
+ configStripLibs = mempty,
configExtraLibDirs = mempty,
configConstraints = mempty,
+ configDependencies = mempty,
configExtraIncludeDirs = mempty,
configConfigurationsFlags = mempty,
- configTests = mempty,
- configLibCoverage = mempty,
- configBenchmarks = mempty
+ configTests = mempty,
+ configLibCoverage = mempty,
+ configExactConfiguration = mempty,
+ configBenchmarks = mempty
}
mappend a b = ConfigFlags {
configPrograms = configPrograms b,
configProgramPaths = combine configProgramPaths,
configProgramArgs = combine configProgramArgs,
+ configProgramPathExtra = combine configProgramPathExtra,
configHcFlavor = combine configHcFlavor,
configHcPath = combine configHcPath,
configHcPkg = combine configHcPkg,
@@ -633,13 +726,16 @@ instance Monoid ConfigFlags where
configGHCiLib = combine configGHCiLib,
configSplitObjs = combine configSplitObjs,
configStripExes = combine configStripExes,
+ configStripLibs = combine configStripLibs,
configExtraLibDirs = combine configExtraLibDirs,
configConstraints = combine configConstraints,
+ configDependencies = combine configDependencies,
configExtraIncludeDirs = combine configExtraIncludeDirs,
configConfigurationsFlags = combine configConfigurationsFlags,
- configTests = combine configTests,
- configLibCoverage = combine configLibCoverage,
- configBenchmarks = combine configBenchmarks
+ configTests = combine configTests,
+ configLibCoverage = combine configLibCoverage,
+ configExactConfiguration = combine configExactConfiguration,
+ configBenchmarks = combine configBenchmarks
}
where combine field = field a `mappend` field b
@@ -782,19 +878,21 @@ instance Monoid InstallFlags where
-- | Flags to @sdist@: (snapshot, verbosity)
data SDistFlags = SDistFlags {
- sDistSnapshot :: Flag Bool,
- sDistDirectory :: Flag FilePath,
- sDistDistPref :: Flag FilePath,
- sDistVerbosity :: Flag Verbosity
+ sDistSnapshot :: Flag Bool,
+ sDistDirectory :: Flag FilePath,
+ sDistDistPref :: Flag FilePath,
+ sDistListSources :: Flag FilePath,
+ sDistVerbosity :: Flag Verbosity
}
deriving Show
defaultSDistFlags :: SDistFlags
defaultSDistFlags = SDistFlags {
- sDistSnapshot = Flag False,
- sDistDirectory = mempty,
- sDistDistPref = Flag defaultDistPref,
- sDistVerbosity = Flag normal
+ sDistSnapshot = Flag False,
+ sDistDirectory = mempty,
+ sDistDistPref = Flag defaultDistPref,
+ sDistListSources = mempty,
+ sDistVerbosity = Flag normal
}
sdistCommand :: CommandUI SDistFlags
@@ -809,13 +907,19 @@ sdistCommand = makeCommand name shortDesc longDesc defaultSDistFlags options
sDistDistPref (\d flags -> flags { sDistDistPref = d })
showOrParseArgs
+ ,option "" ["list-sources"]
+ "Just write a list of the package's sources to a file"
+ sDistListSources (\v flags -> flags { sDistListSources = v })
+ (reqArgFlag "FILE")
+
,option "" ["snapshot"]
"Produce a snapshot source distribution"
sDistSnapshot (\v flags -> flags { sDistSnapshot = v })
trueArg
,option "" ["output-directory"]
- "Generate a source distribution in the given directory"
+ ("Generate a source distribution in the given directory, "
+ ++ "without creating a tarball")
sDistDirectory (\v flags -> flags { sDistDirectory = v })
(reqArgFlag "DIR")
]
@@ -825,16 +929,18 @@ emptySDistFlags = mempty
instance Monoid SDistFlags where
mempty = SDistFlags {
- sDistSnapshot = mempty,
- sDistDirectory = mempty,
- sDistDistPref = mempty,
- sDistVerbosity = mempty
+ sDistSnapshot = mempty,
+ sDistDirectory = mempty,
+ sDistDistPref = mempty,
+ sDistListSources = mempty,
+ sDistVerbosity = mempty
}
mappend a b = SDistFlags {
- sDistSnapshot = combine sDistSnapshot,
- sDistDirectory = combine sDistDirectory,
- sDistDistPref = combine sDistDistPref,
- sDistVerbosity = combine sDistVerbosity
+ sDistSnapshot = combine sDistSnapshot,
+ sDistDirectory = combine sDistDirectory,
+ sDistDistPref = combine sDistDistPref,
+ sDistListSources = combine sDistListSources,
+ sDistVerbosity = combine sDistVerbosity
}
where combine field = field a `mappend` field b
@@ -865,7 +971,8 @@ defaultRegisterFlags = RegisterFlags {
}
registerCommand :: CommandUI RegisterFlags
-registerCommand = makeCommand name shortDesc longDesc defaultRegisterFlags options
+registerCommand = makeCommand name shortDesc longDesc
+ defaultRegisterFlags options
where
name = "register"
shortDesc = "Register this package with the compiler."
@@ -900,7 +1007,8 @@ registerCommand = makeCommand name shortDesc longDesc defaultRegisterFlags optio
]
unregisterCommand :: CommandUI RegisterFlags
-unregisterCommand = makeCommand name shortDesc longDesc defaultRegisterFlags options
+unregisterCommand = makeCommand name shortDesc
+ longDesc defaultRegisterFlags options
where
name = "unregister"
shortDesc = "Unregister this package with the compiler."
@@ -953,6 +1061,8 @@ instance Monoid RegisterFlags where
data HscolourFlags = HscolourFlags {
hscolourCSS :: Flag FilePath,
hscolourExecutables :: Flag Bool,
+ hscolourTestSuites :: Flag Bool,
+ hscolourBenchmarks :: Flag Bool,
hscolourDistPref :: Flag FilePath,
hscolourVerbosity :: Flag Verbosity
}
@@ -965,6 +1075,8 @@ defaultHscolourFlags :: HscolourFlags
defaultHscolourFlags = HscolourFlags {
hscolourCSS = NoFlag,
hscolourExecutables = Flag False,
+ hscolourTestSuites = Flag False,
+ hscolourBenchmarks = Flag False,
hscolourDistPref = Flag defaultDistPref,
hscolourVerbosity = Flag normal
}
@@ -973,25 +1085,31 @@ instance Monoid HscolourFlags where
mempty = HscolourFlags {
hscolourCSS = mempty,
hscolourExecutables = mempty,
+ hscolourTestSuites = mempty,
+ hscolourBenchmarks = mempty,
hscolourDistPref = mempty,
hscolourVerbosity = mempty
}
mappend a b = HscolourFlags {
hscolourCSS = combine hscolourCSS,
hscolourExecutables = combine hscolourExecutables,
+ hscolourTestSuites = combine hscolourTestSuites,
+ hscolourBenchmarks = combine hscolourBenchmarks,
hscolourDistPref = combine hscolourDistPref,
hscolourVerbosity = combine hscolourVerbosity
}
where combine field = field a `mappend` field b
hscolourCommand :: CommandUI HscolourFlags
-hscolourCommand = makeCommand name shortDesc longDesc defaultHscolourFlags options
+hscolourCommand = makeCommand name shortDesc longDesc
+ defaultHscolourFlags options
where
name = "hscolour"
shortDesc = "Generate HsColour colourised code, in HTML format."
longDesc = Just (\_ -> "Requires hscolour.\n")
options showOrParseArgs =
- [optionVerbosity hscolourVerbosity (\v flags -> flags { hscolourVerbosity = v })
+ [optionVerbosity hscolourVerbosity
+ (\v flags -> flags { hscolourVerbosity = v })
,optionDistPref
hscolourDistPref (\d flags -> flags { hscolourDistPref = d })
showOrParseArgs
@@ -1001,6 +1119,26 @@ hscolourCommand = makeCommand name shortDesc longDesc defaultHscolourFlags optio
hscolourExecutables (\v flags -> flags { hscolourExecutables = v })
trueArg
+ ,option "" ["tests"]
+ "Run hscolour for Test Suite targets"
+ hscolourTestSuites (\v flags -> flags { hscolourTestSuites = v })
+ trueArg
+
+ ,option "" ["benchmarks"]
+ "Run hscolour for Benchmark targets"
+ hscolourBenchmarks (\v flags -> flags { hscolourBenchmarks = v })
+ trueArg
+
+ ,option "" ["all"]
+ "Run hscolour for all targets"
+ (\f -> allFlags [ hscolourExecutables f
+ , hscolourTestSuites f
+ , hscolourBenchmarks f])
+ (\v flags -> flags { hscolourExecutables = v
+ , hscolourTestSuites = v
+ , hscolourBenchmarks = v })
+ trueArg
+
,option "" ["css"]
"Use a cascading style sheet"
hscolourCSS (\v flags -> flags { hscolourCSS = v })
@@ -1018,12 +1156,15 @@ data HaddockFlags = HaddockFlags {
haddockHtml :: Flag Bool,
haddockHtmlLocation :: Flag String,
haddockExecutables :: Flag Bool,
+ haddockTestSuites :: Flag Bool,
+ haddockBenchmarks :: Flag Bool,
haddockInternal :: Flag Bool,
haddockCss :: Flag FilePath,
haddockHscolour :: Flag Bool,
haddockHscolourCss :: Flag FilePath,
haddockContents :: Flag PathTemplate,
haddockDistPref :: Flag FilePath,
+ haddockKeepTempFiles:: Flag Bool,
haddockVerbosity :: Flag Verbosity
}
deriving Show
@@ -1036,12 +1177,15 @@ defaultHaddockFlags = HaddockFlags {
haddockHtml = Flag False,
haddockHtmlLocation = NoFlag,
haddockExecutables = Flag False,
+ haddockTestSuites = Flag False,
+ haddockBenchmarks = Flag False,
haddockInternal = Flag False,
haddockCss = NoFlag,
haddockHscolour = Flag False,
haddockHscolourCss = NoFlag,
haddockContents = NoFlag,
haddockDistPref = Flag defaultDistPref,
+ haddockKeepTempFiles= Flag False,
haddockVerbosity = Flag normal
}
@@ -1052,11 +1196,17 @@ haddockCommand = makeCommand name shortDesc longDesc defaultHaddockFlags options
shortDesc = "Generate Haddock HTML documentation."
longDesc = Just $ \_ -> "Requires the program haddock, either version 0.x or 2.x.\n"
options showOrParseArgs =
- [optionVerbosity haddockVerbosity (\v flags -> flags { haddockVerbosity = v })
+ [optionVerbosity haddockVerbosity
+ (\v flags -> flags { haddockVerbosity = v })
,optionDistPref
haddockDistPref (\d flags -> flags { haddockDistPref = d })
showOrParseArgs
+ ,option "" ["keep-temp-files"]
+ "Keep temporary files"
+ haddockKeepTempFiles (\b flags -> flags { haddockKeepTempFiles = b })
+ trueArg
+
,option "" ["hoogle"]
"Generate a hoogle database"
haddockHoogle (\v flags -> flags { haddockHoogle = v })
@@ -1077,6 +1227,26 @@ haddockCommand = makeCommand name shortDesc longDesc defaultHaddockFlags options
haddockExecutables (\v flags -> flags { haddockExecutables = v })
trueArg
+ ,option "" ["tests"]
+ "Run haddock for Test Suite targets"
+ haddockTestSuites (\v flags -> flags { haddockTestSuites = v })
+ trueArg
+
+ ,option "" ["benchmarks"]
+ "Run haddock for Benchmark targets"
+ haddockBenchmarks (\v flags -> flags { haddockBenchmarks = v })
+ trueArg
+
+ ,option "" ["all"]
+ "Run haddock for all targets"
+ (\f -> allFlags [ haddockExecutables f
+ , haddockTestSuites f
+ , haddockBenchmarks f])
+ (\v flags -> flags { haddockExecutables = v
+ , haddockTestSuites = v
+ , haddockBenchmarks = v })
+ trueArg
+
,option "" ["internal"]
"Run haddock for internal modules and include all symbols"
haddockInternal (\v flags -> flags { haddockInternal = v })
@@ -1096,7 +1266,7 @@ haddockCommand = makeCommand name shortDesc longDesc defaultHaddockFlags options
"Use PATH as the HsColour stylesheet"
haddockHscolourCss (\v flags -> flags { haddockHscolourCss = v })
(reqArgFlag "PATH")
-
+
,option "" ["contents-location"]
"Bake URL in as the location for the contents page"
haddockContents (\v flags -> flags { haddockContents = v })
@@ -1106,6 +1276,8 @@ haddockCommand = makeCommand name shortDesc longDesc defaultHaddockFlags options
]
++ programConfigurationPaths progConf ParseArgs
haddockProgramPaths (\v flags -> flags { haddockProgramPaths = v})
+ ++ programConfigurationOption progConf showOrParseArgs
+ haddockProgramArgs (\v fs -> fs { haddockProgramArgs = v })
++ programConfigurationOptions progConf ParseArgs
haddockProgramArgs (\v flags -> flags { haddockProgramArgs = v})
progConf = addKnownProgram haddockProgram
@@ -1123,12 +1295,15 @@ instance Monoid HaddockFlags where
haddockHtml = mempty,
haddockHtmlLocation = mempty,
haddockExecutables = mempty,
+ haddockTestSuites = mempty,
+ haddockBenchmarks = mempty,
haddockInternal = mempty,
haddockCss = mempty,
haddockHscolour = mempty,
haddockHscolourCss = mempty,
haddockContents = mempty,
haddockDistPref = mempty,
+ haddockKeepTempFiles= mempty,
haddockVerbosity = mempty
}
mappend a b = HaddockFlags {
@@ -1138,12 +1313,15 @@ instance Monoid HaddockFlags where
haddockHtml = combine haddockHoogle,
haddockHtmlLocation = combine haddockHtmlLocation,
haddockExecutables = combine haddockExecutables,
+ haddockTestSuites = combine haddockTestSuites,
+ haddockBenchmarks = combine haddockBenchmarks,
haddockInternal = combine haddockInternal,
haddockCss = combine haddockCss,
haddockHscolour = combine haddockHscolour,
haddockHscolourCss = combine haddockHscolourCss,
haddockContents = combine haddockContents,
haddockDistPref = combine haddockDistPref,
+ haddockKeepTempFiles= combine haddockKeepTempFiles,
haddockVerbosity = combine haddockVerbosity
}
where combine field = field a `mappend` field b
@@ -1208,7 +1386,11 @@ data BuildFlags = BuildFlags {
buildProgramPaths :: [(String, FilePath)],
buildProgramArgs :: [(String, [String])],
buildDistPref :: Flag FilePath,
- buildVerbosity :: Flag Verbosity
+ buildVerbosity :: Flag Verbosity,
+ buildNumJobs :: Flag (Maybe Int),
+ -- TODO: this one should not be here, it's just that the silly
+ -- UserHooks stop us from passing extra info in other ways
+ buildArgs :: [String]
}
deriving Show
@@ -1221,7 +1403,9 @@ defaultBuildFlags = BuildFlags {
buildProgramPaths = mempty,
buildProgramArgs = [],
buildDistPref = Flag defaultDistPref,
- buildVerbosity = Flag normal
+ buildVerbosity = Flag normal,
+ buildNumJobs = mempty,
+ buildArgs = []
}
buildCommand :: ProgramConfiguration -> CommandUI BuildFlags
@@ -1229,22 +1413,44 @@ buildCommand progConf = makeCommand name shortDesc longDesc
defaultBuildFlags (buildOptions progConf)
where
name = "build"
- shortDesc = "Make this package ready for installation."
- longDesc = Nothing
+ shortDesc = "Compile all targets or specific targets."
+ longDesc = Just $ \pname ->
+ "Examples:\n"
+ ++ " " ++ pname ++ " build "
+ ++ " All the components in the package\n"
+ ++ " " ++ pname ++ " build foo "
+ ++ " A component (i.e. lib, exe, test suite)\n"
+--TODO: re-enable once we have support for module/file targets
+-- ++ " " ++ pname ++ " build Foo.Bar "
+-- ++ " A module\n"
+-- ++ " " ++ pname ++ " build Foo/Bar.hs"
+-- ++ " A file\n\n"
+-- ++ "If a target is ambigious it can be qualified with the component "
+-- ++ "name, e.g.\n"
+-- ++ " " ++ pname ++ " build foo:Foo.Bar\n"
+-- ++ " " ++ pname ++ " build testsuite1:Foo/Bar.hs\n"
buildOptions :: ProgramConfiguration -> ShowOrParseArgs
-> [OptionField BuildFlags]
buildOptions progConf showOrParseArgs =
- optionVerbosity buildVerbosity (\v flags -> flags { buildVerbosity = v })
- : optionDistPref
- buildDistPref (\d flags -> flags { buildDistPref = d })
- showOrParseArgs
+ [ optionVerbosity
+ buildVerbosity (\v flags -> flags { buildVerbosity = v })
+
+ , optionDistPref
+ buildDistPref (\d flags -> flags { buildDistPref = d }) showOrParseArgs
+
+ , optionNumJobs
+ buildNumJobs (\v flags -> flags { buildNumJobs = v })
+ ]
- : programConfigurationPaths progConf showOrParseArgs
- buildProgramPaths (\v flags -> flags { buildProgramPaths = v})
+ ++ programConfigurationPaths progConf showOrParseArgs
+ buildProgramPaths (\v flags -> flags { buildProgramPaths = v})
+
+ ++ programConfigurationOption progConf showOrParseArgs
+ buildProgramArgs (\v fs -> fs { buildProgramArgs = v })
++ programConfigurationOptions progConf showOrParseArgs
- buildProgramArgs (\v flags -> flags { buildProgramArgs = v})
+ buildProgramArgs (\v flags -> flags { buildProgramArgs = v})
emptyBuildFlags :: BuildFlags
emptyBuildFlags = mempty
@@ -1254,16 +1460,106 @@ instance Monoid BuildFlags where
buildProgramPaths = mempty,
buildProgramArgs = mempty,
buildVerbosity = mempty,
- buildDistPref = mempty
+ buildDistPref = mempty,
+ buildNumJobs = mempty,
+ buildArgs = mempty
}
mappend a b = BuildFlags {
buildProgramPaths = combine buildProgramPaths,
buildProgramArgs = combine buildProgramArgs,
buildVerbosity = combine buildVerbosity,
- buildDistPref = combine buildDistPref
+ buildDistPref = combine buildDistPref,
+ buildNumJobs = combine buildNumJobs,
+ buildArgs = combine buildArgs
+ }
+ where combine field = field a `mappend` field b
+
+-- ------------------------------------------------------------
+-- * Repl Flags
+-- ------------------------------------------------------------
+
+data ReplFlags = ReplFlags {
+ replProgramPaths :: [(String, FilePath)],
+ replProgramArgs :: [(String, [String])],
+ replDistPref :: Flag FilePath,
+ replVerbosity :: Flag Verbosity,
+ replReload :: Flag Bool
+ }
+ deriving Show
+
+defaultReplFlags :: ReplFlags
+defaultReplFlags = ReplFlags {
+ replProgramPaths = mempty,
+ replProgramArgs = [],
+ replDistPref = Flag defaultDistPref,
+ replVerbosity = Flag normal,
+ replReload = Flag False
+ }
+
+instance Monoid ReplFlags where
+ mempty = ReplFlags {
+ replProgramPaths = mempty,
+ replProgramArgs = mempty,
+ replVerbosity = mempty,
+ replDistPref = mempty,
+ replReload = mempty
+ }
+ mappend a b = ReplFlags {
+ replProgramPaths = combine replProgramPaths,
+ replProgramArgs = combine replProgramArgs,
+ replVerbosity = combine replVerbosity,
+ replDistPref = combine replDistPref,
+ replReload = combine replReload
}
where combine field = field a `mappend` field b
+replCommand :: ProgramConfiguration -> CommandUI ReplFlags
+replCommand progConf = CommandUI {
+ commandName = "repl",
+ commandSynopsis = "Open an interpreter session for the given target.",
+ commandDescription = Just $ \pname ->
+ "Examples:\n"
+ ++ " " ++ pname ++ " repl "
+ ++ " The first component in the package\n"
+ ++ " " ++ pname ++ " repl foo "
+ ++ " A named component (i.e. lib, exe, test suite)\n",
+--TODO: re-enable once we have support for module/file targets
+-- ++ " " ++ pname ++ " repl Foo.Bar "
+-- ++ " A module\n"
+-- ++ " " ++ pname ++ " repl Foo/Bar.hs"
+-- ++ " A file\n\n"
+-- ++ "If a target is ambigious it can be qualified with the component "
+-- ++ "name, e.g.\n"
+-- ++ " " ++ pname ++ " repl foo:Foo.Bar\n"
+-- ++ " " ++ pname ++ " repl testsuite1:Foo/Bar.hs\n"
+
+ commandUsage = \pname -> "Usage: " ++ pname ++ " repl [FILENAME] [FLAGS]\n",
+ commandDefaultFlags = defaultReplFlags,
+ commandOptions = \showOrParseArgs ->
+ optionVerbosity replVerbosity (\v flags -> flags { replVerbosity = v })
+ : optionDistPref
+ replDistPref (\d flags -> flags { replDistPref = d })
+ showOrParseArgs
+
+ : programConfigurationPaths progConf showOrParseArgs
+ replProgramPaths (\v flags -> flags { replProgramPaths = v})
+
+ ++ programConfigurationOption progConf showOrParseArgs
+ replProgramArgs (\v flags -> flags { replProgramArgs = v})
+
+ ++ programConfigurationOptions progConf showOrParseArgs
+ replProgramArgs (\v flags -> flags { replProgramArgs = v})
+
+ ++ case showOrParseArgs of
+ ParseArgs ->
+ [ option "" ["reload"]
+ "Used from within an interpreter to update files."
+ replReload (\v flags -> flags { replReload = v })
+ trueArg
+ ]
+ _ -> []
+ }
+
-- ------------------------------------------------------------
-- * Test flags
-- ------------------------------------------------------------
@@ -1291,28 +1587,29 @@ instance Monoid TestShowDetails where
mappend a b = if a < b then b else a
data TestFlags = TestFlags {
- testDistPref :: Flag FilePath,
- testVerbosity :: Flag Verbosity,
- testHumanLog :: Flag PathTemplate,
- testMachineLog :: Flag PathTemplate,
+ testDistPref :: Flag FilePath,
+ testVerbosity :: Flag Verbosity,
+ testHumanLog :: Flag PathTemplate,
+ testMachineLog :: Flag PathTemplate,
testShowDetails :: Flag TestShowDetails,
- testKeepTix :: Flag Bool,
- --TODO: eliminate the test list and pass it directly as positional args to the testHook
- testList :: Flag [String],
+ testKeepTix :: Flag Bool,
+ --TODO: eliminate the test list and pass it directly as positional args to
+ --the testHook
+ testList :: Flag [String],
-- TODO: think about if/how options are passed to test exes
- testOptions :: [PathTemplate]
+ testOptions :: [PathTemplate]
}
defaultTestFlags :: TestFlags
defaultTestFlags = TestFlags {
- testDistPref = Flag defaultDistPref,
- testVerbosity = Flag normal,
- testHumanLog = toFlag $ toPathTemplate $ "$pkgid-$test-suite.log",
- testMachineLog = toFlag $ toPathTemplate $ "$pkgid.log",
+ testDistPref = Flag defaultDistPref,
+ testVerbosity = Flag normal,
+ testHumanLog = toFlag $ toPathTemplate $ "$pkgid-$test-suite.log",
+ testMachineLog = toFlag $ toPathTemplate $ "$pkgid.log",
testShowDetails = toFlag Failures,
- testKeepTix = toFlag False,
- testList = Flag [],
- testOptions = []
+ testKeepTix = toFlag False,
+ testList = Flag [],
+ testOptions = []
}
testCommand :: CommandUI TestFlags
@@ -1377,24 +1674,24 @@ emptyTestFlags = mempty
instance Monoid TestFlags where
mempty = TestFlags {
- testDistPref = mempty,
- testVerbosity = mempty,
- testHumanLog = mempty,
- testMachineLog = mempty,
+ testDistPref = mempty,
+ testVerbosity = mempty,
+ testHumanLog = mempty,
+ testMachineLog = mempty,
testShowDetails = mempty,
- testKeepTix = mempty,
- testList = mempty,
- testOptions = mempty
+ testKeepTix = mempty,
+ testList = mempty,
+ testOptions = mempty
}
mappend a b = TestFlags {
- testDistPref = combine testDistPref,
- testVerbosity = combine testVerbosity,
- testHumanLog = combine testHumanLog,
- testMachineLog = combine testMachineLog,
+ testDistPref = combine testDistPref,
+ testVerbosity = combine testVerbosity,
+ testHumanLog = combine testHumanLog,
+ testMachineLog = combine testMachineLog,
testShowDetails = combine testShowDetails,
- testKeepTix = combine testKeepTix,
- testList = combine testList,
- testOptions = combine testOptions
+ testKeepTix = combine testKeepTix,
+ testList = combine testList,
+ testOptions = combine testOptions
}
where combine field = field a `mappend` field b
@@ -1405,24 +1702,26 @@ instance Monoid TestFlags where
data BenchmarkFlags = BenchmarkFlags {
benchmarkDistPref :: Flag FilePath,
benchmarkVerbosity :: Flag Verbosity,
- benchmarkOptions :: [PathTemplate]
+ benchmarkOptions :: [PathTemplate]
}
defaultBenchmarkFlags :: BenchmarkFlags
defaultBenchmarkFlags = BenchmarkFlags {
benchmarkDistPref = Flag defaultDistPref,
benchmarkVerbosity = Flag normal,
- benchmarkOptions = []
+ benchmarkOptions = []
}
benchmarkCommand :: CommandUI BenchmarkFlags
-benchmarkCommand = makeCommand name shortDesc longDesc defaultBenchmarkFlags options
+benchmarkCommand = makeCommand name shortDesc
+ longDesc defaultBenchmarkFlags options
where
name = "bench"
shortDesc = "Run the benchmark, if any (configure with UserHooks)."
longDesc = Nothing
options showOrParseArgs =
- [ optionVerbosity benchmarkVerbosity (\v flags -> flags { benchmarkVerbosity = v })
+ [ optionVerbosity benchmarkVerbosity
+ (\v flags -> flags { benchmarkVerbosity = v })
, optionDistPref
benchmarkDistPref (\d flags -> flags { benchmarkDistPref = d })
showOrParseArgs
@@ -1450,12 +1749,12 @@ instance Monoid BenchmarkFlags where
mempty = BenchmarkFlags {
benchmarkDistPref = mempty,
benchmarkVerbosity = mempty,
- benchmarkOptions = mempty
+ benchmarkOptions = mempty
}
mappend a b = BenchmarkFlags {
benchmarkDistPref = combine benchmarkDistPref,
benchmarkVerbosity = combine benchmarkVerbosity,
- benchmarkOptions = combine benchmarkOptions
+ benchmarkOptions = combine benchmarkOptions
}
where combine field = field a `mappend` field b
@@ -1471,6 +1770,8 @@ programFlagsDescription progConf =
[ programName prog | (prog, _) <- knownPrograms progConf ]
++ "\n"
+-- | For each known program @PROG@ in 'progConf', produce a @with-PROG@
+-- 'OptionField'.
programConfigurationPaths
:: ProgramConfiguration
-> ShowOrParseArgs
@@ -1478,54 +1779,85 @@ programConfigurationPaths
-> ([(String, FilePath)] -> (flags -> flags))
-> [OptionField flags]
programConfigurationPaths progConf showOrParseArgs get set =
+ programConfigurationPaths' ("with-" ++) progConf showOrParseArgs get set
+
+-- | Like 'programConfigurationPaths', but allows to customise the option name.
+programConfigurationPaths'
+ :: (String -> String)
+ -> ProgramConfiguration
+ -> ShowOrParseArgs
+ -> (flags -> [(String, FilePath)])
+ -> ([(String, FilePath)] -> (flags -> flags))
+ -> [OptionField flags]
+programConfigurationPaths' mkName progConf showOrParseArgs get set =
case showOrParseArgs of
-- we don't want a verbose help text list so we just show a generic one:
ShowArgs -> [withProgramPath "PROG"]
- ParseArgs -> map (withProgramPath . programName . fst) (knownPrograms progConf)
+ ParseArgs -> map (withProgramPath . programName . fst)
+ (knownPrograms progConf)
where
withProgramPath prog =
- option "" ["with-" ++ prog]
+ option "" [mkName prog]
("give the path to " ++ prog)
get set
(reqArg' "PATH" (\path -> [(prog, path)])
(\progPaths -> [ path | (prog', path) <- progPaths, prog==prog' ]))
-programConfigurationOptions
+-- | For each known program @PROG@ in 'progConf', produce a @PROG-option@
+-- 'OptionField'.
+programConfigurationOption
:: ProgramConfiguration
-> ShowOrParseArgs
-> (flags -> [(String, [String])])
-> ([(String, [String])] -> (flags -> flags))
-> [OptionField flags]
-programConfigurationOptions progConf showOrParseArgs get set =
+programConfigurationOption progConf showOrParseArgs get set =
case showOrParseArgs of
-- we don't want a verbose help text list so we just show a generic one:
- ShowArgs -> [programOptions "PROG", programOption "PROG"]
- ParseArgs -> map (programOptions . programName . fst) (knownPrograms progConf)
- ++ map (programOption . programName . fst) (knownPrograms progConf)
+ ShowArgs -> [programOption "PROG"]
+ ParseArgs -> map (programOption . programName . fst)
+ (knownPrograms progConf)
where
- programOptions prog =
- option "" [prog ++ "-options"]
- ("give extra options to " ++ prog)
- get set
- (reqArg' "OPTS" (\args -> [(prog, splitArgs args)]) (const []))
-
programOption prog =
option "" [prog ++ "-option"]
("give an extra option to " ++ prog ++
" (no need to quote options containing spaces)")
get set
(reqArg' "OPT" (\arg -> [(prog, [arg])])
- (\progArgs -> concat [ args | (prog', args) <- progArgs, prog==prog' ]))
+ (\progArgs -> concat [ args
+ | (prog', args) <- progArgs, prog==prog' ]))
+-- | For each known program @PROG@ in 'progConf', produce a @PROG-options@
+-- 'OptionField'.
+programConfigurationOptions
+ :: ProgramConfiguration
+ -> ShowOrParseArgs
+ -> (flags -> [(String, [String])])
+ -> ([(String, [String])] -> (flags -> flags))
+ -> [OptionField flags]
+programConfigurationOptions progConf showOrParseArgs get set =
+ case showOrParseArgs of
+ -- we don't want a verbose help text list so we just show a generic one:
+ ShowArgs -> [programOptions "PROG"]
+ ParseArgs -> map (programOptions . programName . fst)
+ (knownPrograms progConf)
+ where
+ programOptions prog =
+ option "" [prog ++ "-options"]
+ ("give extra options to " ++ prog)
+ get set
+ (reqArg' "OPTS" (\args -> [(prog, splitArgs args)]) (const []))
-- ------------------------------------------------------------
-- * GetOpt Utils
-- ------------------------------------------------------------
-boolOpt :: SFlags -> SFlags -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
+boolOpt :: SFlags -> SFlags
+ -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
boolOpt = Command.boolOpt flagToMaybe Flag
-boolOpt' :: OptFlags -> OptFlags -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
+boolOpt' :: OptFlags -> OptFlags
+ -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
boolOpt' = Command.boolOpt' flagToMaybe Flag
trueArg, falseArg :: SFlags -> LFlags -> Description -> (b -> Flag Bool) ->
@@ -1562,6 +1894,28 @@ optionVerbosity get set =
(Flag verbose) -- default Value if no n is given
(fmap (Just . showForCabal) . flagToList))
+optionNumJobs :: (flags -> Flag (Maybe Int))
+ -> (Flag (Maybe Int) -> flags -> flags)
+ -> OptionField flags
+optionNumJobs get set =
+ option "j" ["jobs"]
+ "Run NUM jobs simultaneously (or '$ncpus' if no NUM is given)."
+ get set
+ (optArg "NUM" (fmap Flag numJobsParser)
+ (Flag Nothing)
+ (map (Just . maybe "$ncpus" show) . flagToList))
+ where
+ numJobsParser :: ReadE (Maybe Int)
+ numJobsParser = ReadE $ \s ->
+ case s of
+ "$ncpus" -> Right Nothing
+ _ -> case reads s of
+ [(n, "")]
+ | n < 1 -> Left "The number of jobs should be 1 or more."
+ | n > 64 -> Left "You probably don't want that many jobs."
+ | otherwise -> Right (Just n)
+ _ -> Left "The jobs value should be a number or '$ncpus'"
+
-- ------------------------------------------------------------
-- * Other Utils
-- ------------------------------------------------------------
@@ -1577,6 +1931,7 @@ configureArgs bcHack flags
++ optFlag' "libdir" libdir
++ optFlag' "libexecdir" libexecdir
++ optFlag' "datadir" datadir
+ ++ optFlag' "sysconfdir" sysconfdir
++ configConfigureArgs flags
where
hc_flag = case (configHcFlavor flags, configHcPath flags) of
@@ -1594,13 +1949,15 @@ configureArgs bcHack flags
. config_field
. configInstallDirs)
-configureCCompiler :: Verbosity -> ProgramConfiguration -> IO (FilePath, [String])
+configureCCompiler :: Verbosity -> ProgramConfiguration
+ -> IO (FilePath, [String])
configureCCompiler verbosity lbi = configureProg verbosity lbi gccProgram
configureLinker :: Verbosity -> ProgramConfiguration -> IO (FilePath, [String])
configureLinker verbosity lbi = configureProg verbosity lbi ldProgram
-configureProg :: Verbosity -> ProgramConfiguration -> Program -> IO (FilePath, [String])
+configureProg :: Verbosity -> ProgramConfiguration -> Program
+ -> IO (FilePath, [String])
configureProg verbosity programConfig prog = do
(p, _) <- requireProgram verbosity prog programConfig
let pInv = programInvocation p []
diff --git a/cabal/Cabal/Distribution/Simple/SrcDist.hs b/cabal/Cabal/Distribution/Simple/SrcDist.hs
index beca46e..c5aed2b 100644
--- a/cabal/Cabal/Distribution/Simple/SrcDist.hs
+++ b/cabal/Cabal/Distribution/Simple/SrcDist.hs
@@ -64,6 +64,10 @@ module Distribution.Simple.SrcDist (
snapshotPackage,
snapshotVersion,
dateToSnapshotNumber,
+
+ -- * Extracting the source files
+ listPackageSources
+
) where
import Distribution.PackageDescription
@@ -80,67 +84,79 @@ import Distribution.Version
( Version(versionBranch) )
import Distribution.Simple.Utils
( createDirectoryIfMissingVerbose, withUTF8FileContents, writeUTF8File
- , installOrdinaryFile, installOrdinaryFiles, setFileExecutable
+ , installOrdinaryFiles, installMaybeExecutableFiles
, findFile, findFileWithExtension, matchFileGlob
, withTempDirectory, defaultPackageDesc
, die, warn, notice, setupMessage )
-import Distribution.Simple.Setup (SDistFlags(..), fromFlag, flagToMaybe)
-import Distribution.Simple.PreProcess (PPSuffixHandler, ppSuffixes, preprocessComponent)
-import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), withComponentsLBI )
+import Distribution.Simple.Setup ( Flag(..), SDistFlags(..)
+ , fromFlag, flagToMaybe)
+import Distribution.Simple.PreProcess ( PPSuffixHandler, ppSuffixes
+ , preprocessComponent )
+import Distribution.Simple.LocalBuildInfo
+ ( LocalBuildInfo(..), withAllComponentsInBuildOrder )
import Distribution.Simple.BuildPaths ( autogenModuleName )
import Distribution.Simple.Program ( defaultProgramConfiguration, requireProgram,
rawSystemProgram, tarProgram )
import Distribution.Text
( display )
-import Control.Monad(when, unless)
+import Control.Monad(when, unless, forM)
import Data.Char (toLower)
import Data.List (partition, isPrefixOf)
import Data.Maybe (isNothing, catMaybes)
-import System.Time (getClockTime, toCalendarTime, CalendarTime(..))
-import System.Directory
- ( doesFileExist, Permissions(executable), getPermissions )
+import Data.Time (UTCTime, getCurrentTime, toGregorian, utctDay)
+import System.Directory ( doesFileExist )
+import System.IO (IOMode(WriteMode), hPutStrLn, withFile)
import Distribution.Verbosity (Verbosity)
import System.FilePath
- ( (</>), (<.>), takeDirectory, dropExtension, isAbsolute )
+ ( (</>), (<.>), dropExtension, isAbsolute )
-- |Create a source distribution.
-sdist :: PackageDescription -- ^information from the tarball
- -> Maybe LocalBuildInfo -- ^Information from configure
- -> SDistFlags -- ^verbosity & snapshot
+sdist :: PackageDescription -- ^information from the tarball
+ -> Maybe LocalBuildInfo -- ^Information from configure
+ -> SDistFlags -- ^verbosity & snapshot
-> (FilePath -> FilePath) -- ^build prefix (temp dir)
- -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes)
+ -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes)
-> IO ()
-sdist pkg mb_lbi flags mkTmpDir pps = do
-
- -- do some QA
- printPackageProblems verbosity pkg
-
- when (isNothing mb_lbi) $
- warn verbosity "Cannot run preprocessors. Run 'configure' command first."
-
- date <- toCalendarTime =<< getClockTime
- let pkg' | snapshot = snapshotPackage date pkg
- | otherwise = pkg
-
- case flagToMaybe (sDistDirectory flags) of
- Just targetDir -> do
- generateSourceDir targetDir pkg'
- notice verbosity $ "Source directory created: " ++ targetDir
-
- Nothing -> do
- createDirectoryIfMissingVerbose verbosity True tmpTargetDir
- withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do
- let targetDir = tmpDir </> tarBallName pkg'
- generateSourceDir targetDir pkg'
- targzFile <- createArchive verbosity pkg' mb_lbi tmpDir targetPref
- notice verbosity $ "Source tarball created: " ++ targzFile
+sdist pkg mb_lbi flags mkTmpDir pps =
+
+ -- When given --list-sources, just output the list of sources to a file.
+ case (sDistListSources flags) of
+ Flag path -> withFile path WriteMode $ \outHandle -> do
+ (ordinary, maybeExecutable) <- listPackageSources verbosity pkg pps
+ mapM_ (hPutStrLn outHandle) ordinary
+ mapM_ (hPutStrLn outHandle) maybeExecutable
+ notice verbosity $ "List of package sources written to file '"
+ ++ path ++ "'"
+ NoFlag -> do
+ -- do some QA
+ printPackageProblems verbosity pkg
+
+ when (isNothing mb_lbi) $
+ warn verbosity "Cannot run preprocessors. Run 'configure' command first."
+
+ date <- getCurrentTime
+ let pkg' | snapshot = snapshotPackage date pkg
+ | otherwise = pkg
+
+ case flagToMaybe (sDistDirectory flags) of
+ Just targetDir -> do
+ generateSourceDir targetDir pkg'
+ notice verbosity $ "Source directory created: " ++ targetDir
+
+ Nothing -> do
+ createDirectoryIfMissingVerbose verbosity True tmpTargetDir
+ withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do
+ let targetDir = tmpDir </> tarBallName pkg'
+ generateSourceDir targetDir pkg'
+ targzFile <- createArchive verbosity pkg' mb_lbi tmpDir targetPref
+ notice verbosity $ "Source tarball created: " ++ targzFile
where
generateSourceDir targetDir pkg' = do
setupMessage verbosity "Building source dist for" (packageId pkg')
- prepareTree verbosity pkg' mb_lbi distPref targetDir pps
+ prepareTree verbosity pkg' mb_lbi targetDir pps
when snapshot $
overwriteSnapshotPackageDesc verbosity pkg' targetDir
@@ -151,136 +167,204 @@ sdist pkg mb_lbi flags mkTmpDir pps = do
targetPref = distPref
tmpTargetDir = mkTmpDir distPref
+-- | List all source files of a package. Returns a tuple of lists: first
+-- component is a list of ordinary files, second one is a list of those files
+-- that may be executable.
+listPackageSources :: Verbosity -- ^ verbosity
+ -> PackageDescription -- ^ info from the cabal file
+ -> [PPSuffixHandler] -- ^ extra preprocessors (include
+ -- suffixes)
+ -> IO ([FilePath], [FilePath])
+listPackageSources verbosity pkg_descr0 pps = do
+ -- Call helpers that actually do all work.
+ ordinary <- listPackageSourcesOrdinary verbosity pkg_descr pps
+ maybeExecutable <- listPackageSourcesMaybeExecutable pkg_descr
+ return (ordinary, maybeExecutable)
+ where
+ pkg_descr = filterAutogenModule pkg_descr0
+
+-- | List those source files that may be executable (e.g. the configure script).
+listPackageSourcesMaybeExecutable :: PackageDescription -> IO [FilePath]
+listPackageSourcesMaybeExecutable pkg_descr =
+ -- Extra source files.
+ fmap concat . forM (extraSrcFiles pkg_descr) $ \fpath -> matchFileGlob fpath
+
+-- | List those source files that should be copied with ordinary permissions.
+listPackageSourcesOrdinary :: Verbosity
+ -> PackageDescription
+ -> [PPSuffixHandler]
+ -> IO [FilePath]
+listPackageSourcesOrdinary verbosity pkg_descr pps =
+ fmap concat . sequence $
+ [
+ -- Library sources.
+ withLib $ \Library { exposedModules = modules, libBuildInfo = libBi } ->
+ allSourcesBuildInfo libBi pps modules
+
+ -- Executables sources.
+ , fmap concat
+ . withExe $ \Executable { modulePath = mainPath, buildInfo = exeBi } -> do
+ biSrcs <- allSourcesBuildInfo exeBi pps []
+ mainSrc <- findMainExeFile exeBi pps mainPath
+ return (mainSrc:biSrcs)
+
+ -- Test suites sources.
+ , fmap concat
+ . withTest $ \t -> do
+ let bi = testBuildInfo t
+ case testInterface t of
+ TestSuiteExeV10 _ mainPath -> do
+ biSrcs <- allSourcesBuildInfo bi pps []
+ srcMainFile <- do
+ ppFile <- findFileWithExtension (ppSuffixes pps)
+ (hsSourceDirs bi) (dropExtension mainPath)
+ case ppFile of
+ Nothing -> findFile (hsSourceDirs bi) mainPath
+ Just pp -> return pp
+ return (srcMainFile:biSrcs)
+ TestSuiteLibV09 _ m ->
+ allSourcesBuildInfo bi pps [m]
+ TestSuiteUnsupported tp -> die $ "Unsupported test suite type: "
+ ++ show tp
+
+ -- Benchmarks sources.
+ , fmap concat
+ . withBenchmark $ \bm -> do
+ let bi = benchmarkBuildInfo bm
+ case benchmarkInterface bm of
+ BenchmarkExeV10 _ mainPath -> do
+ biSrcs <- allSourcesBuildInfo bi pps []
+ srcMainFile <- do
+ ppFile <- findFileWithExtension (ppSuffixes pps)
+ (hsSourceDirs bi) (dropExtension mainPath)
+ case ppFile of
+ Nothing -> findFile (hsSourceDirs bi) mainPath
+ Just pp -> return pp
+ return (srcMainFile:biSrcs)
+ BenchmarkUnsupported tp -> die $ "Unsupported benchmark type: "
+ ++ show tp
+
+ -- Data files.
+ , fmap concat
+ . forM (dataFiles pkg_descr) $ \filename ->
+ matchFileGlob (dataDir pkg_descr </> filename)
+
+ -- Extra doc files.
+ , fmap concat
+ . forM (extraDocFiles pkg_descr) $ \ filename ->
+ matchFileGlob filename
+
+ -- License file.
+ , return $ case [licenseFile pkg_descr]
+ of [[]] -> []
+ l -> l
+
+ -- Install-include files.
+ , withLib $ \ l -> do
+ let lbi = libBuildInfo l
+ relincdirs = "." : filter (not.isAbsolute) (includeDirs lbi)
+ mapM (fmap snd . findIncludeFile relincdirs) (installIncludes lbi)
+
+ -- Setup script, if it exists.
+ , fmap (maybe [] (\f -> [f])) $ findSetupFile ""
+
+ -- The .cabal file itself.
+ , fmap (\d -> [d]) (defaultPackageDesc verbosity)
+
+ ]
+ where
+ -- We have to deal with all libs and executables, so we have local
+ -- versions of these functions that ignore the 'buildable' attribute:
+ withLib action = maybe (return []) action (library pkg_descr)
+ withExe action = mapM action (executables pkg_descr)
+ withTest action = mapM action (testSuites pkg_descr)
+ withBenchmark action = mapM action (benchmarks pkg_descr)
+
-- |Prepare a directory tree of source files.
prepareTree :: Verbosity -- ^verbosity
-> PackageDescription -- ^info from the cabal file
-> Maybe LocalBuildInfo
- -> FilePath -- ^dist dir
-> FilePath -- ^source tree to populate
-> [PPSuffixHandler] -- ^extra preprocessors (includes suffixes)
-> IO ()
-prepareTree verbosity pkg_descr0 mb_lbi distPref targetDir pps = do
- createDirectoryIfMissingVerbose verbosity True targetDir
-
- -- maybe move the library files into place
- withLib $ \Library { exposedModules = modules, libBuildInfo = libBi } ->
- prepareDir verbosity pkg_descr distPref targetDir pps modules libBi
-
- -- move the executables into place
- withExe $ \Executable { modulePath = mainPath, buildInfo = exeBi } -> do
- prepareDir verbosity pkg_descr distPref targetDir pps [] exeBi
- srcMainFile <- do
- ppFile <- findFileWithExtension (ppSuffixes pps) (hsSourceDirs exeBi) (dropExtension mainPath)
- case ppFile of
- Nothing -> findFile (hsSourceDirs exeBi) mainPath
- Just pp -> return pp
- copyFileTo verbosity targetDir srcMainFile
-
- -- move the test suites into place
- withTest $ \t -> do
- let bi = testBuildInfo t
- prep = prepareDir verbosity pkg_descr distPref targetDir pps
- case testInterface t of
- TestSuiteExeV10 _ mainPath -> do
- prep [] bi
- srcMainFile <- do
- ppFile <- findFileWithExtension (ppSuffixes pps)
- (hsSourceDirs bi)
- (dropExtension mainPath)
- case ppFile of
- Nothing -> findFile (hsSourceDirs bi) mainPath
- Just pp -> return pp
- copyFileTo verbosity targetDir srcMainFile
- TestSuiteLibV09 _ m -> do
- prep [m] bi
- TestSuiteUnsupported tp -> die $ "Unsupported test suite type: " ++ show tp
-
- -- move the benchmarks into place
- withBenchmark $ \bm -> do
- let bi = benchmarkBuildInfo bm
- prep = prepareDir verbosity pkg_descr distPref targetDir pps
- case benchmarkInterface bm of
- BenchmarkExeV10 _ mainPath -> do
- prep [] bi
- srcMainFile <- do
- ppFile <- findFileWithExtension (ppSuffixes pps)
- (hsSourceDirs bi)
- (dropExtension mainPath)
- case ppFile of
- Nothing -> findFile (hsSourceDirs bi) mainPath
- Just pp -> return pp
- copyFileTo verbosity targetDir srcMainFile
- BenchmarkUnsupported tp -> die $ "Unsupported benchmark type: " ++ show tp
-
- flip mapM_ (dataFiles pkg_descr) $ \ filename -> do
- files <- matchFileGlob (dataDir pkg_descr </> filename)
- let dir = takeDirectory (dataDir pkg_descr </> filename)
- createDirectoryIfMissingVerbose verbosity True (targetDir </> dir)
- sequence_ [ installOrdinaryFile verbosity file (targetDir </> file)
- | file <- files ]
-
- when (not (null (licenseFile pkg_descr))) $
- copyFileTo verbosity targetDir (licenseFile pkg_descr)
- flip mapM_ (extraSrcFiles pkg_descr) $ \ fpath -> do
- files <- matchFileGlob fpath
- sequence_
- [ do copyFileTo verbosity targetDir file
- -- preserve executable bit on extra-src-files like ./configure
- perms <- getPermissions file
- when (executable perms) --only checks user x bit
- (setFileExecutable (targetDir </> file))
- | file <- files ]
-
- -- copy the install-include files
- withLib $ \ l -> do
- let lbi = libBuildInfo l
- relincdirs = "." : filter (not.isAbsolute) (includeDirs lbi)
- incs <- mapM (findInc relincdirs) (installIncludes lbi)
- flip mapM_ incs $ \(_,fpath) ->
- copyFileTo verbosity targetDir fpath
-
- -- if the package was configured then we can run platform independent
- -- pre-processors and include those generated files
+prepareTree verbosity pkg_descr0 mb_lbi targetDir pps = do
+ -- If the package was configured then we can run platform independent
+ -- pre-processors and include those generated files.
case mb_lbi of
Just lbi | not (null pps) -> do
- let lbi' = lbi{ buildDir = targetDir </> buildDir lbi }
- withComponentsLBI pkg_descr lbi' $ \c _ ->
+ let lbi' = lbi{ buildDir = targetDir </> buildDir lbi }
+ withAllComponentsInBuildOrder pkg_descr lbi' $ \c _ ->
preprocessComponent pkg_descr c lbi' True verbosity pps
_ -> return ()
- -- setup isn't listed in the description file.
- hsExists <- doesFileExist "Setup.hs"
- lhsExists <- doesFileExist "Setup.lhs"
- if hsExists then copyFileTo verbosity targetDir "Setup.hs"
- else if lhsExists then copyFileTo verbosity targetDir "Setup.lhs"
- else writeUTF8File (targetDir </> "Setup.hs") $ unlines [
- "import Distribution.Simple",
- "main = defaultMain"]
- -- the description file itself
- descFile <- defaultPackageDesc verbosity
- installOrdinaryFile verbosity descFile (targetDir </> descFile)
+ (ordinary, mExecutable) <- listPackageSources verbosity pkg_descr0 pps
+ installOrdinaryFiles verbosity targetDir (zip (repeat []) ordinary)
+ installMaybeExecutableFiles verbosity targetDir (zip (repeat []) mExecutable)
+ maybeCreateDefaultSetupScript targetDir
where
- pkg_descr = mapAllBuildInfo filterAutogenModule pkg_descr0
- filterAutogenModule bi = bi {
- otherModules = filter (/=autogenModule) (otherModules bi)
+ pkg_descr = filterAutogenModule pkg_descr0
+
+-- | Find the setup script file, if it exists.
+findSetupFile :: FilePath -> IO (Maybe FilePath)
+findSetupFile targetDir = do
+ hsExists <- doesFileExist setupHs
+ lhsExists <- doesFileExist setupLhs
+ if hsExists
+ then return (Just setupHs)
+ else if lhsExists
+ then return (Just setupLhs)
+ else return Nothing
+ where
+ setupHs = targetDir </> "Setup.hs"
+ setupLhs = targetDir </> "Setup.lhs"
+
+-- | Create a default setup script in the target directory, if it doesn't exist.
+maybeCreateDefaultSetupScript :: FilePath -> IO ()
+maybeCreateDefaultSetupScript targetDir = do
+ mSetupFile <- findSetupFile targetDir
+ case mSetupFile of
+ Just _setupFile -> return ()
+ Nothing -> do
+ writeUTF8File (targetDir </> "Setup.hs") $ unlines [
+ "import Distribution.Simple",
+ "main = defaultMain"]
+
+-- | Find the main executable file.
+findMainExeFile :: BuildInfo -> [PPSuffixHandler] -> FilePath -> IO FilePath
+findMainExeFile exeBi pps mainPath = do
+ ppFile <- findFileWithExtension (ppSuffixes pps) (hsSourceDirs exeBi)
+ (dropExtension mainPath)
+ case ppFile of
+ Nothing -> findFile (hsSourceDirs exeBi) mainPath
+ Just pp -> return pp
+
+-- | Given a list of include paths, try to find the include file named
+-- @f@. Return the name of the file and the full path, or exit with error if
+-- there's no such file.
+findIncludeFile :: [FilePath] -> String -> IO (String, FilePath)
+findIncludeFile [] f = die ("can't find include file " ++ f)
+findIncludeFile (d:ds) f = do
+ let path = (d </> f)
+ b <- doesFileExist path
+ if b then return (f,path) else findIncludeFile ds f
+
+-- | Remove the auto-generated module ('Paths_*') from 'exposed-modules' and
+-- 'other-modules'.
+filterAutogenModule :: PackageDescription -> PackageDescription
+filterAutogenModule pkg_descr0 = mapLib filterAutogenModuleLib $
+ mapAllBuildInfo filterAutogenModuleBI pkg_descr0
+ where
+ mapLib f pkg = pkg { library = fmap f (library pkg) }
+ filterAutogenModuleLib lib = lib {
+ exposedModules = filter (/=autogenModule) (exposedModules lib)
+ }
+ filterAutogenModuleBI bi = bi {
+ otherModules = filter (/=autogenModule) (otherModules bi)
}
autogenModule = autogenModuleName pkg_descr0
- findInc [] f = die ("can't find include file " ++ f)
- findInc (d:ds) f = do
- let path = (d </> f)
- b <- doesFileExist path
- if b then return (f,path) else findInc ds f
-
- -- We have to deal with all libs and executables, so we have local
- -- versions of these functions that ignore the 'buildable' attribute:
- withLib action = maybe (return ()) action (library pkg_descr)
- withExe action = mapM_ action (executables pkg_descr)
- withTest action = mapM_ action (testSuites pkg_descr)
- withBenchmark action = mapM_ action (benchmarks pkg_descr)
-
-- | Prepare a directory tree of source files for a snapshot version.
-- It is expected that the appropriate snapshot version has already been set
-- in the package description, eg using 'snapshotPackage' or 'snapshotVersion'.
@@ -288,12 +372,12 @@ prepareTree verbosity pkg_descr0 mb_lbi distPref targetDir pps = do
prepareSnapshotTree :: Verbosity -- ^verbosity
-> PackageDescription -- ^info from the cabal file
-> Maybe LocalBuildInfo
- -> FilePath -- ^dist dir
-> FilePath -- ^source tree to populate
- -> [PPSuffixHandler] -- ^extra preprocessors (includes suffixes)
+ -> [PPSuffixHandler] -- ^extra preprocessors (includes
+ -- suffixes)
-> IO ()
-prepareSnapshotTree verbosity pkg mb_lbi distPref targetDir pps = do
- prepareTree verbosity pkg mb_lbi distPref targetDir pps
+prepareSnapshotTree verbosity pkg mb_lbi targetDir pps = do
+ prepareTree verbosity pkg mb_lbi targetDir pps
overwriteSnapshotPackageDesc verbosity pkg targetDir
overwriteSnapshotPackageDesc :: Verbosity -- ^verbosity
@@ -318,7 +402,7 @@ overwriteSnapshotPackageDesc verbosity pkg targetDir = do
-- | Modifies a 'PackageDescription' by appending a snapshot number
-- corresponding to the given date.
--
-snapshotPackage :: CalendarTime -> PackageDescription -> PackageDescription
+snapshotPackage :: UTCTime -> PackageDescription -> PackageDescription
snapshotPackage date pkg =
pkg {
package = pkgid { pkgVersion = snapshotVersion date (pkgVersion pkgid) }
@@ -328,7 +412,7 @@ snapshotPackage date pkg =
-- | Modifies a 'Version' by appending a snapshot number corresponding
-- to the given date.
--
-snapshotVersion :: CalendarTime -> Version -> Version
+snapshotVersion :: UTCTime -> Version -> Version
snapshotVersion date version = version {
versionBranch = versionBranch version
++ [dateToSnapshotNumber date]
@@ -337,70 +421,62 @@ snapshotVersion date version = version {
-- | Given a date produce a corresponding integer representation.
-- For example given a date @18/03/2008@ produce the number @20080318@.
--
-dateToSnapshotNumber :: CalendarTime -> Int
-dateToSnapshotNumber date = year * 10000
- + month * 100
- + day
- where
- year = ctYear date
- month = fromEnum (ctMonth date) + 1
- day = ctDay date
-
--- |Create an archive from a tree of source files, and clean up the tree.
-createArchive :: Verbosity -- ^verbosity
- -> PackageDescription -- ^info from cabal file
- -> Maybe LocalBuildInfo -- ^info from configure
- -> FilePath -- ^source tree to archive
- -> FilePath -- ^name of archive to create
- -> IO FilePath
-
+dateToSnapshotNumber :: UTCTime -> Int
+dateToSnapshotNumber date = case toGregorian (utctDay date) of
+ (year, month, day) ->
+ fromIntegral year * 10000
+ + month * 100
+ + day
+
+-- | Callback type for use by sdistWith.
+type CreateArchiveFun = Verbosity -- ^verbosity
+ -> PackageDescription -- ^info from cabal file
+ -> Maybe LocalBuildInfo -- ^info from configure
+ -> FilePath -- ^source tree to archive
+ -> FilePath -- ^name of archive to create
+ -> IO FilePath
+
+-- | Create an archive from a tree of source files, and clean up the tree.
+createArchive :: CreateArchiveFun
createArchive verbosity pkg_descr mb_lbi tmpDir targetPref = do
let tarBallFilePath = targetPref </> tarBallName pkg_descr <.> "tar.gz"
(tarProg, _) <- requireProgram verbosity tarProgram
(maybe defaultProgramConfiguration withPrograms mb_lbi)
- -- Hmm: I could well be skating on thinner ice here by using the -C option (=> GNU tar-specific?)
- -- [The prev. solution used pipes and sub-command sequences to set up the paths correctly,
- -- which is problematic in a Windows setting.]
+ -- Hmm: I could well be skating on thinner ice here by using the -C option
+ -- (=> GNU tar-specific?) [The prev. solution used pipes and sub-command
+ -- sequences to set up the paths correctly, which is problematic in a Windows
+ -- setting.]
rawSystemProgram verbosity tarProg
["-C", tmpDir, "-czf", tarBallFilePath, tarBallName pkg_descr]
return tarBallFilePath
--- |Move the sources into place based on buildInfo
-prepareDir :: Verbosity -- ^verbosity
- -> PackageDescription -- ^info from the cabal file
- -> FilePath -- ^dist dir
- -> FilePath -- ^TargetPrefix
- -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes)
- -> [ModuleName] -- ^Exposed modules
- -> BuildInfo
- -> IO ()
-prepareDir verbosity _pkg _distPref inPref pps modules bi
- = do let searchDirs = hsSourceDirs bi
- sources <- sequence
- [ let file = ModuleName.toFilePath module_
- in findFileWithExtension suffixes searchDirs file
- >>= maybe (notFound module_) return
- | module_ <- modules ++ otherModules bi ]
- bootFiles <- sequence
- [ let file = ModuleName.toFilePath module_
- fileExts = ["hs-boot", "lhs-boot"]
- in findFileWithExtension fileExts (hsSourceDirs bi) file
- | module_ <- modules ++ otherModules bi ]
-
- let allSources = sources ++ catMaybes bootFiles ++ cSources bi
- installOrdinaryFiles verbosity inPref (zip (repeat []) allSources)
-
- where suffixes = ppSuffixes pps ++ ["hs", "lhs"]
- notFound m = die $ "Error: Could not find module: " ++ display m
- ++ " with any suffix: " ++ show suffixes
-
-copyFileTo :: Verbosity -> FilePath -> FilePath -> IO ()
-copyFileTo verbosity dir file = do
- let targetFile = dir </> file
- createDirectoryIfMissingVerbose verbosity True (takeDirectory targetFile)
- installOrdinaryFile verbosity file targetFile
+-- | Given a buildinfo, return the names of all source files.
+allSourcesBuildInfo :: BuildInfo
+ -> [PPSuffixHandler] -- ^ Extra preprocessors
+ -> [ModuleName] -- ^ Exposed modules
+ -> IO [FilePath]
+allSourcesBuildInfo bi pps modules = do
+ let searchDirs = hsSourceDirs bi
+ sources <- sequence
+ [ let file = ModuleName.toFilePath module_
+ in findFileWithExtension suffixes searchDirs file
+ >>= maybe (notFound module_) return
+ | module_ <- modules ++ otherModules bi ]
+ bootFiles <- sequence
+ [ let file = ModuleName.toFilePath module_
+ fileExts = ["hs-boot", "lhs-boot"]
+ in findFileWithExtension fileExts (hsSourceDirs bi) file
+ | module_ <- modules ++ otherModules bi ]
+
+ return $ sources ++ catMaybes bootFiles ++ cSources bi
+
+ where
+ suffixes = ppSuffixes pps ++ ["hs", "lhs"]
+ notFound m = die $ "Error: Could not find module: " ++ display m
+ ++ " with any suffix: " ++ show suffixes
+
printPackageProblems :: Verbosity -> PackageDescription -> IO ()
printPackageProblems verbosity pkg_descr = do
diff --git a/cabal/Cabal/Distribution/Simple/Test.hs b/cabal/Cabal/Distribution/Simple/Test.hs
index ce8b38c..3fade9b 100644
--- a/cabal/Cabal/Distribution/Simple/Test.hs
+++ b/cabal/Cabal/Distribution/Simple/Test.hs
@@ -71,13 +71,13 @@ import Distribution.Simple.InstallDirs
import qualified Distribution.Simple.LocalBuildInfo as LBI
( LocalBuildInfo(..) )
import Distribution.Simple.Setup ( TestFlags(..), TestShowDetails(..), fromFlag )
-import Distribution.Simple.Utils ( die, notice )
+import Distribution.Simple.Utils ( die, notice, rawSystemIOWithEnv )
import Distribution.TestSuite
( OptionDescr(..), Options, Progress(..), Result(..), TestInstance(..)
, Test(..) )
import Distribution.Text
import Distribution.Verbosity ( normal, Verbosity )
-import Distribution.System ( buildPlatform, Platform )
+import Distribution.System ( Platform )
import Control.Exception ( bracket )
import Control.Monad ( when, unless, filterM )
@@ -86,12 +86,11 @@ import Data.Maybe ( mapMaybe )
import System.Directory
( createDirectoryIfMissing, doesDirectoryExist, doesFileExist
, getCurrentDirectory, getDirectoryContents, removeDirectoryRecursive
- , removeFile )
-import System.Environment ( getEnvironment )
+ , removeFile, setCurrentDirectory )
+import Distribution.Compat.Environment ( getEnvironment )
import System.Exit ( ExitCode(..), exitFailure, exitWith )
import System.FilePath ( (</>), (<.>) )
import System.IO ( hClose, IOMode(..), openFile )
-import System.Process ( runProcess, waitForProcess )
-- | Logs all test results for a package, broken down first by test suite and
-- then by test case.
@@ -108,7 +107,7 @@ localPackageLog :: PD.PackageDescription -> LBI.LocalBuildInfo -> PackageLog
localPackageLog pkg_descr lbi = PackageLog
{ package = PD.package pkg_descr
, compiler = compilerId $ LBI.compiler lbi
- , platform = buildPlatform
+ , platform = LBI.hostPlatform lbi
, testSuites = []
}
@@ -191,10 +190,10 @@ testController flags pkg_descr lbi suite preTest cmd postTest logNamer = do
pwd <- getCurrentDirectory
existingEnv <- getEnvironment
let dataDirPath = pwd </> PD.dataDir pkg_descr
- shellEnv = Just $ (pkgPathEnvVar pkg_descr "datadir", dataDirPath)
- : ("HPCTIXFILE", (</>) pwd
- $ tixFilePath distPref $ PD.testName suite)
- : existingEnv
+ shellEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath)
+ : ("HPCTIXFILE", (</>) pwd
+ $ tixFilePath distPref $ PD.testName suite)
+ : existingEnv
bracket (openCabalTemp testLogDir) deleteIfExists $ \tempLog ->
bracket (openCabalTemp testLogDir) deleteIfExists $ \tempInput -> do
@@ -223,10 +222,9 @@ testController flags pkg_descr lbi suite preTest cmd postTest logNamer = do
exit <- do
hLog <- openFile tempLog AppendMode
hIn <- openFile tempInput ReadMode
- -- these handles get closed by runProcess
- proc <- runProcess cmd opts Nothing shellEnv
- (Just hIn) (Just hLog) (Just hLog)
- waitForProcess proc
+ -- these handles get closed by rawSystemIOWithEnv
+ rawSystemIOWithEnv verbosity cmd opts Nothing (Just shellEnv)
+ (Just hIn) (Just hLog) (Just hLog)
-- Generate TestSuiteLog from executable exit code and a machine-
-- readable test log
@@ -432,6 +430,7 @@ testSuiteLogPath template pkg_descr lbi testLog =
where
env = initialPathTemplateEnv
(PD.package pkg_descr) (compilerId $ LBI.compiler lbi)
+ (LBI.hostPlatform lbi)
++ [ (TestSuiteNameVar, toPathTemplate $ testSuiteName testLog)
, (TestSuiteResultVar, result)
]
@@ -448,7 +447,8 @@ testOption pkg_descr lbi suite template =
fromPathTemplate $ substPathTemplate env template
where
env = initialPathTemplateEnv
- (PD.package pkg_descr) (compilerId $ LBI.compiler lbi) ++
+ (PD.package pkg_descr) (compilerId $ LBI.compiler lbi)
+ (LBI.hostPlatform lbi) ++
[(TestSuiteNameVar, toPathTemplate $ PD.testName suite)]
packageLogPath :: PathTemplate
@@ -460,6 +460,7 @@ packageLogPath template pkg_descr lbi =
where
env = initialPathTemplateEnv
(PD.package pkg_descr) (compilerId $ LBI.compiler lbi)
+ (LBI.hostPlatform lbi)
-- | The filename of the source file for the stub executable associated with a
-- library 'TestSuite'.
@@ -498,7 +499,10 @@ simpleTestStub m = unlines
stubMain :: IO [Test] -> IO ()
stubMain tests = do
(f, n) <- fmap read getContents
- tests >>= stubRunTests >>= stubWriteLog f n
+ dir <- getCurrentDirectory
+ results <- tests >>= stubRunTests
+ setCurrentDirectory dir
+ stubWriteLog f n results
-- | The test runner used in library "TestSuite" stub executables. Runs a list
-- of 'Test's. An executable calling this function is meant to be invoked as
@@ -541,4 +545,3 @@ stubWriteLog f n logs = do
when (suiteError testLog) $ exitWith $ ExitFailure 2
when (suiteFailed testLog) $ exitWith $ ExitFailure 1
exitWith ExitSuccess
-
diff --git a/cabal/Cabal/Distribution/Simple/UHC.hs b/cabal/Cabal/Distribution/Simple/UHC.hs
index 873b938..987dcf5 100644
--- a/cabal/Cabal/Distribution/Simple/UHC.hs
+++ b/cabal/Cabal/Distribution/Simple/UHC.hs
@@ -53,6 +53,7 @@ module Distribution.Simple.UHC (
import Control.Monad
import Data.List
+import qualified Data.Map as M ( empty )
import Distribution.Compat.ReadP
import Distribution.InstalledPackageInfo
import Distribution.Package
@@ -69,12 +70,13 @@ import Distribution.Version
import Language.Haskell.Extension
import System.Directory
import System.FilePath
+import Distribution.System ( Platform )
-- -----------------------------------------------------------------------------
-- Configuring
configure :: Verbosity -> Maybe FilePath -> Maybe FilePath
- -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration)
+ -> ProgramConfiguration -> IO (Compiler, Maybe Platform, ProgramConfiguration)
configure verbosity hcPath _hcPkgPath conf = do
(_uhcProg, uhcVersion, conf') <-
@@ -83,11 +85,13 @@ configure verbosity hcPath _hcPkgPath conf = do
(userMaybeSpecifyPath "uhc" hcPath conf)
let comp = Compiler {
- compilerId = CompilerId UHC uhcVersion,
- compilerLanguages = uhcLanguages,
- compilerExtensions = uhcLanguageExtensions
+ compilerId = CompilerId UHC uhcVersion,
+ compilerLanguages = uhcLanguages,
+ compilerExtensions = uhcLanguageExtensions,
+ compilerProperties = M.empty
}
- return (comp, conf')
+ compPlatform = Nothing
+ return (comp, compPlatform, conf')
uhcLanguages :: [(Language, C.Flag)]
uhcLanguages = [(Haskell98, "")]
diff --git a/cabal/Cabal/Distribution/Simple/UserHooks.hs b/cabal/Cabal/Distribution/Simple/UserHooks.hs
index 07f0bf1..865f0bd 100644
--- a/cabal/Cabal/Distribution/Simple/UserHooks.hs
+++ b/cabal/Cabal/Distribution/Simple/UserHooks.hs
@@ -64,7 +64,7 @@ import Distribution.Simple.Program (Program)
import Distribution.Simple.Command (noExtraFlags)
import Distribution.Simple.PreProcess (PPSuffixHandler)
import Distribution.Simple.Setup
- (ConfigFlags, BuildFlags, CleanFlags, CopyFlags,
+ (ConfigFlags, BuildFlags, ReplFlags, CleanFlags, CopyFlags,
InstallFlags, SDistFlags, RegisterFlags, HscolourFlags,
HaddockFlags, TestFlags, BenchmarkFlags)
import Distribution.Simple.LocalBuildInfo (LocalBuildInfo)
@@ -105,6 +105,13 @@ data UserHooks = UserHooks {
-- |Hook to run after build command. Second arg indicates verbosity level.
postBuild :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO (),
+ -- |Hook to run before repl command. Second arg indicates verbosity level.
+ preRepl :: Args -> ReplFlags -> IO HookedBuildInfo,
+ -- |Over-ride this hook to get different behavior during interpretation.
+ replHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> ReplFlags -> [String] -> IO (),
+ -- |Hook to run after repl command. Second arg indicates verbosity level.
+ postRepl :: Args -> ReplFlags -> PackageDescription -> LocalBuildInfo -> IO (),
+
-- |Hook to run before clean command. Second arg indicates verbosity level.
preClean :: Args -> CleanFlags -> IO HookedBuildInfo,
-- |Over-ride this hook to get different behavior during clean.
@@ -144,7 +151,7 @@ data UserHooks = UserHooks {
-- |Hook to run before unregister command
preUnreg :: Args -> RegisterFlags -> IO HookedBuildInfo,
- -- |Over-ride this hook to get different behavior during registration.
+ -- |Over-ride this hook to get different behavior during unregistration.
unregHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO (),
-- |Hook to run after unregister command
postUnreg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO (),
@@ -191,9 +198,12 @@ emptyUserHooks
preConf = rn,
confHook = (\_ _ -> return (error "No local build info generated during configure. Over-ride empty configure hook.")),
postConf = ru,
- preBuild = rn,
+ preBuild = rn',
buildHook = ru,
postBuild = ru,
+ preRepl = \_ _ -> return emptyHookedBuildInfo,
+ replHook = \_ _ _ _ _ -> return (),
+ postRepl = ru,
preClean = rn,
cleanHook = ru,
postClean = ru,
@@ -218,14 +228,13 @@ emptyUserHooks
preHaddock = rn,
haddockHook = ru,
postHaddock = ru,
- preTest = \_ _ -> return emptyHookedBuildInfo, -- same as rn, but without
- -- noExtraFlags
+ preTest = rn',
testHook = ru,
postTest = ru,
- preBench = \_ _ -> return emptyHookedBuildInfo, -- same as rn, but without
- -- noExtraFlags
+ preBench = rn',
benchHook = \_ -> ru,
postBench = ru
}
- where rn args _ = noExtraFlags args >> return emptyHookedBuildInfo
+ where rn args _ = noExtraFlags args >> return emptyHookedBuildInfo
+ rn' _ _ = return emptyHookedBuildInfo
ru _ _ _ _ = return ()
diff --git a/cabal/Cabal/Distribution/Simple/Utils.hs b/cabal/Cabal/Distribution/Simple/Utils.hs
index d1f45a7..0c6e0f9 100644
--- a/cabal/Cabal/Distribution/Simple/Utils.hs
+++ b/cabal/Cabal/Distribution/Simple/Utils.hs
@@ -1,6 +1,4 @@
{-# LANGUAGE CPP, ForeignFunctionInterface #-}
-{-# OPTIONS_NHC98 -cpp #-}
-{-# OPTIONS_JHC -fcpp -fffi #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Simple.Utils
@@ -52,9 +50,9 @@ module Distribution.Simple.Utils (
-- * logging and errors
die,
dieWithLocation,
- topHandler,
+ topHandler, topHandlerWith,
warn, notice, setupMessage, info, debug,
- chattyTry,
+ debugNoWrap, chattyTry,
-- * running programs
rawSystemExit,
@@ -62,6 +60,7 @@ module Distribution.Simple.Utils (
rawSystemExitWithEnv,
rawSystemStdout,
rawSystemStdInOut,
+ rawSystemIOWithEnv,
maybeExit,
xargs,
findProgramLocation,
@@ -73,14 +72,19 @@ module Distribution.Simple.Utils (
copyFileVerbose,
copyDirectoryRecursiveVerbose,
copyFiles,
+ copyFileTo,
-- * installing files
installOrdinaryFile,
installExecutableFile,
+ installMaybeExecutableFile,
installOrdinaryFiles,
+ installExecutableFiles,
+ installMaybeExecutableFiles,
installDirectoryContents,
-- * File permissions
+ doesExecutableExist,
setFileOrdinary,
setFileExecutable,
@@ -96,19 +100,28 @@ module Distribution.Simple.Utils (
findModuleFiles,
getDirectoryContentsRecursive,
+ -- * environment variables
+ isInSearchPath,
+
-- * simple file globbing
matchFileGlob,
matchDirFileGlob,
parseFileGlob,
FileGlob(..),
+ -- * modification time
+ moreRecentFile,
+ existsAndIsMoreRecentThan,
+
-- * temp files and dirs
- withTempFile,
- withTempDirectory,
+ TempFileOptions(..), defaultTempFileOptions,
+ withTempFile, withTempFileEx,
+ withTempDirectory, withTempDirectoryEx,
-- * .cabal and .buildinfo files
defaultPackageDesc,
findPackageDesc,
+ tryFindPackageDesc,
defaultHookedPackageDesc,
findHookedPackageDesc,
@@ -136,13 +149,11 @@ module Distribution.Simple.Utils (
) where
import Control.Monad
- ( when, unless, filterM )
-#ifdef __GLASGOW_HASKELL__
+ ( join, when, unless, filterM )
import Control.Concurrent.MVar
( newEmptyMVar, putMVar, takeMVar )
-#endif
import Data.List
- ( nub, unfoldr, isPrefixOf, tails, intersperse )
+ ( nub, unfoldr, isPrefixOf, tails, intercalate )
import Data.Char as Char
( toLower, chr, ord )
import Data.Bits
@@ -151,30 +162,28 @@ import qualified Data.ByteString.Lazy as BS
import qualified Data.ByteString.Lazy.Char8 as BS.Char8
import System.Directory
- ( getDirectoryContents, doesDirectoryExist, doesFileExist, removeFile
- , findExecutable )
+ ( Permissions(executable), getDirectoryContents, getPermissions
+ , doesDirectoryExist, doesFileExist, removeFile, findExecutable
+ , getModificationTime )
import System.Environment
( getProgName )
-import System.Cmd
- ( rawSystem )
import System.Exit
( exitWith, ExitCode(..) )
import System.FilePath
- ( normalise, (</>), (<.>), takeDirectory, splitFileName
+ ( normalise, (</>), (<.>)
+ , getSearchPath, takeDirectory, splitFileName
, splitExtension, splitExtensions, splitDirectories )
import System.Directory
( createDirectory, renameFile, removeDirectoryRecursive )
import System.IO
( Handle, openFile, openBinaryFile, openBinaryTempFile
, IOMode(ReadMode), hSetBinaryMode
- , hGetContents, stderr, stdout, hPutStr, hFlush, hClose )
+ , hGetContents, stdin, stderr, stdout, hPutStr, hFlush, hClose )
import System.IO.Error as IO.Error
( isDoesNotExistError, isAlreadyExistsError
, ioeSetFileName, ioeGetFileName, ioeGetErrorString )
-#if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 608))
import System.IO.Error
( ioeSetLocation, ioeGetLocation )
-#endif
import System.IO.Unsafe
( unsafeInterleaveIO )
import qualified Control.Exception as Exception
@@ -188,15 +197,22 @@ import qualified Distribution.ModuleName as ModuleName
import Distribution.Version
(Version(..))
-import Control.Exception (evaluate)