Cabal 1.14.0 → 1.16.0
raw patch · 20 files changed
+1283/−767 lines, 20 filesdep ~containersdep ~directorydep ~unix
Dependency ranges changed: containers, directory, unix
Files
- Cabal.cabal +7/−6
- Distribution/License.hs +8/−0
- Distribution/PackageDescription/Check.hs +18/−0
- Distribution/Simple/Build.hs +130/−119
- Distribution/Simple/Build/PathsModule.hs +10/−6
- Distribution/Simple/Configure.hs +56/−17
- Distribution/Simple/GHC.hs +212/−173
- Distribution/Simple/Haddock.hs +76/−61
- Distribution/Simple/InstallDirs.hs +3/−3
- Distribution/Simple/LHC.hs +26/−11
- Distribution/Simple/LocalBuildInfo.hs +7/−0
- Distribution/Simple/PackageIndex.hs +15/−3
- Distribution/Simple/Program/GHC.hs +456/−0
- Distribution/Simple/Program/HcPkg.hs +28/−21
- Distribution/Simple/Register.hs +7/−3
- Distribution/Simple/Setup.hs +20/−9
- Distribution/Simple/Test.hs +120/−77
- Distribution/TestSuite.hs +72/−257
- README +11/−0
- tests/PackageTests/PackageTester.hs +1/−1
Cabal.cabal view
@@ -1,5 +1,5 @@ Name: Cabal-Version: 1.14.0+Version: 1.16.0 Copyright: 2003-2006, Isaac Jones 2005-2011, Duncan Coutts License: BSD3@@ -27,8 +27,8 @@ README changelog source-repository head- type: darcs- location: http://darcs.haskell.org/cabal/+ type: git+ location: https://github.com/haskell/cabal/ subdir: Cabal Flag base4@@ -43,15 +43,15 @@ if flag(base4) { build-depends: base >= 4 } else { build-depends: base < 4 } if flag(base3) { build-depends: base >= 3 } else { build-depends: base < 3 } if flag(base3)- Build-Depends: directory >= 1 && < 1.2,+ Build-Depends: directory >= 1 && < 1.3, process >= 1 && < 1.2, old-time >= 1 && < 1.2,- containers >= 0.1 && < 0.5,+ containers >= 0.1 && < 0.6, array >= 0.1 && < 0.5, pretty >= 1 && < 1.2 if !os(windows)- Build-Depends: unix >= 2.0 && < 2.6+ Build-Depends: unix >= 2.0 && < 2.7 ghc-options: -Wall -fno-ignore-asserts if impl(ghc >= 6.8)@@ -98,6 +98,7 @@ 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/License.hs view
@@ -89,6 +89,11 @@ -- | The MIT license, similar to the BSD3. Very free license. | MIT + -- | The Apache License. Version 2.0 is the current version,+ -- previous versions are considered historical.++ | Apache (Maybe Version)+ -- | Holder makes no claim to ownership, least restrictive license. | PublicDomain @@ -107,6 +112,7 @@ knownLicenses = [ GPL unversioned, GPL (version [2]), GPL (version [3]) , LGPL unversioned, LGPL (version [2,1]), LGPL (version [3]) , BSD3, MIT+ , Apache unversioned, Apache (version [2, 0]) , PublicDomain, AllRightsReserved, OtherLicense] where unversioned = Nothing@@ -115,6 +121,7 @@ instance Text License where disp (GPL version) = Disp.text "GPL" <> dispOptVersion version disp (LGPL version) = Disp.text "LGPL" <> dispOptVersion version+ disp (Apache version) = Disp.text "Apache" <> dispOptVersion version disp (UnknownLicense other) = Disp.text other disp other = Disp.text (show other) @@ -127,6 +134,7 @@ ("BSD3", Nothing) -> BSD3 ("BSD4", Nothing) -> BSD4 ("MIT", Nothing) -> MIT+ ("Apache", _ ) -> Apache version ("PublicDomain", Nothing) -> PublicDomain ("AllRightsReserved", Nothing) -> AllRightsReserved ("OtherLicense", Nothing) -> OtherLicense
Distribution/PackageDescription/Check.hs view
@@ -180,6 +180,7 @@ ++ checkSourceRepos pkg ++ checkGhcOptions pkg ++ checkCCOptions pkg+ ++ checkCPPOptions pkg ++ checkPaths pkg ++ checkCabalVersion pkg @@ -516,6 +517,9 @@ unknownLicenseVersion (LGPL (Just v)) | v `notElem` knownVersions = Just knownVersions where knownVersions = [ v' | LGPL (Just v') <- knownLicenses ]+ unknownLicenseVersion (Apache (Just v))+ | v `notElem` knownVersions = Just knownVersions+ where knownVersions = [ v' | Apache (Just v') <- knownLicenses ] unknownLicenseVersion _ = Nothing checkSourceRepos :: PackageDescription -> [PackageCheck]@@ -582,6 +586,11 @@ ++ "is using the FFI incorrectly and will probably not work with GHC " ++ "6.10 or later." + , checkFlags ["-fdefer-type-errors"] $+ PackageDistInexcusable $+ "'ghc-options: -fdefer-type-errors' is fine during development but "+ ++ "is not appropriate for a distributed package."+ , checkFlags ["-fhpc"] $ PackageDistInexcusable $ "'ghc-options: -fhpc' is not appropriate for a distributed package."@@ -751,6 +760,15 @@ checkCCFlags :: [String] -> PackageCheck -> Maybe PackageCheck checkCCFlags flags = check (any (`elem` flags) all_ccOptions)++checkCPPOptions :: PackageDescription -> [PackageCheck]+checkCPPOptions pkg =+ catMaybes [+ checkAlternatives "cpp-options" "include-dirs"+ [ (flag, dir) | flag@('-':'I':dir) <- all_cppOptions]+ ]+ where all_cppOptions = [ opts | bi <- allBuildInfo pkg+ , opts <- cppOptions bi ] checkAlternatives :: String -> String -> [(String, String)] -> Maybe PackageCheck checkAlternatives badField goodField flags =
Distribution/Simple/Build.hs view
@@ -81,7 +81,7 @@ import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(compiler, buildDir, withPackageDB, withPrograms) , Component(..), ComponentLocalBuildInfo(..), withComponentsLBI- , inplacePackageId )+ , componentBuildInfo, inplacePackageId ) import Distribution.Simple.Program.Types import Distribution.Simple.Program.Db import Distribution.Simple.BuildPaths@@ -125,132 +125,143 @@ internalPackageDB <- createInternalPackageDB distPref - let pre c lbi' = preprocessComponent pkg_descr c lbi' False verbosity suffixes withComponentsLBI pkg_descr lbi $ \comp clbi ->- case comp of- CLib lib -> do- let bi = libBuildInfo lib- progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi)- lbi' = lbi { withPrograms = progs' }- pre comp lbi'- info verbosity "Building library..."- buildLib verbosity pkg_descr lbi' lib 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 - -- Register the library in-place, so exes can depend- -- on internally defined libraries.- pwd <- getCurrentDirectory- let installedPkgInfo =- (inplaceInstalledPackageInfo pwd distPref pkg_descr lib lbi clbi) {- -- The inplace registration uses the "-inplace" suffix,- -- not an ABI hash.- IPI.installedPackageId = inplacePackageId (packageId installedPkgInfo)++buildComponent :: Verbosity+ -> PackageDescription+ -> LocalBuildInfo+ -> [PPSuffixHandler]+ -> Component+ -> ComponentLocalBuildInfo+ -> FilePath+ -> IO ()+buildComponent verbosity pkg_descr lbi suffixes+ comp@(CLib lib) clbi distPref = do+ preprocessComponent pkg_descr comp lbi False verbosity suffixes+ info verbosity "Building library..."+ buildLib verbosity pkg_descr lbi lib clbi++ -- Register the library in-place, so exes can depend+ -- on internally defined libraries.+ pwd <- getCurrentDirectory+ let installedPkgInfo =+ (inplaceInstalledPackageInfo pwd distPref pkg_descr lib lbi clbi) {+ -- The inplace registration uses the "-inplace" suffix,+ -- not an ABI hash.+ IPI.installedPackageId = inplacePackageId (packageId installedPkgInfo)+ }+ registerPackage verbosity+ installedPkgInfo pkg_descr lbi True -- True meaning inplace+ (withPackageDB lbi)+++buildComponent verbosity pkg_descr lbi suffixes+ comp@(CExe exe) clbi _ = do+ preprocessComponent pkg_descr comp lbi False verbosity suffixes+ info verbosity $ "Building executable " ++ exeName exe ++ "..."+ buildExe verbosity pkg_descr lbi exe clbi+++buildComponent verbosity pkg_descr lbi suffixes+ comp@(CTest+ test@TestSuite { testInterface = TestSuiteExeV10 _ f })+ clbi _distPref = do+ let bi = testBuildInfo test+ exe = Executable {+ exeName = testName test,+ modulePath = f,+ buildInfo = bi }- registerPackage verbosity- installedPkgInfo pkg_descr lbi True -- True meaning inplace- (withPackageDB lbi ++ [internalPackageDB])+ preprocessComponent pkg_descr comp lbi False verbosity suffixes+ info verbosity $ "Building test suite " ++ testName test ++ "..."+ buildExe verbosity pkg_descr lbi exe clbi - CExe exe -> do- let bi = buildInfo exe- progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi)- lbi' = lbi {- withPrograms = progs',- withPackageDB = withPackageDB lbi ++ [internalPackageDB]- }- pre comp lbi'- info verbosity $ "Building executable " ++ exeName exe ++ "..."- buildExe verbosity pkg_descr lbi' exe clbi - CTest test -> do- case testInterface test of- TestSuiteExeV10 _ f -> do- let bi = testBuildInfo test- exe = Executable- { exeName = testName test- , modulePath = f- , buildInfo = bi- }- progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi)- lbi' = lbi {- withPrograms = progs',- withPackageDB = withPackageDB lbi ++ [internalPackageDB]- }- pre comp lbi'- info verbosity $ "Building test suite " ++ testName test ++ "..."- buildExe verbosity pkg_descr lbi' exe clbi- TestSuiteLibV09 _ m -> 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)- }- progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi)- lbi' = lbi {- withPrograms = progs',- withPackageDB = withPackageDB lbi ++ [internalPackageDB]+buildComponent verbosity pkg_descr lbi suffixes+ comp@(CTest+ test@TestSuite { testInterface = TestSuiteLibV09 _ m })+ clbi distPref = do+ pwd <- getCurrentDirectory+ let bi = testBuildInfo test+ lib = Library {+ exposedModules = [ m ],+ libExposed = True,+ libBuildInfo = bi+ }+ pkg = pkg_descr {+ package = (package pkg_descr) {+ pkgName = PackageName (testName test)+ }+ , buildDepends = targetBuildDepends $ testBuildInfo test+ , executables = []+ , testSuites = []+ , library = Just lib+ }+ ipi = (inplaceInstalledPackageInfo pwd distPref pkg lib lbi clbi) {+ IPI.installedPackageId = inplacePackageId $ packageId ipi+ }+ testDir = buildDir lbi </> stubName test+ </> stubName test ++ "-tmp"+ testLibDep = thisPackageVersion $ package pkg+ exe = Executable {+ exeName = stubName test,+ modulePath = stubFilePath test,+ buildInfo = (testBuildInfo test) {+ hsSourceDirs = [ testDir ],+ targetBuildDepends = testLibDep+ : (targetBuildDepends $ testBuildInfo test) }+ }+ -- | The stub executable needs a new 'ComponentLocalBuildInfo'+ -- that exposes the relevant test suite library.+ exeClbi = clbi {+ componentPackageDeps =+ (IPI.installedPackageId ipi, packageId ipi)+ : (filter (\(_, x) -> let PackageName name = pkgName x+ in name == "Cabal" || name == "base")+ (componentPackageDeps clbi))+ }+ preprocessComponent pkg_descr comp lbi False verbosity suffixes+ info verbosity $ "Building test suite " ++ testName test ++ "..."+ buildLib verbosity pkg lbi lib clbi+ registerPackage verbosity ipi pkg lbi True $ withPackageDB lbi+ buildExe verbosity pkg_descr lbi exe exeClbi - pre comp lbi'- info verbosity $ "Building test suite " ++ testName test ++ "..."- buildLib verbosity pkg lbi' lib clbi- registerPackage verbosity ipi pkg lbi' True $ withPackageDB lbi'- buildExe verbosity pkg_descr lbi' exe exeClbi- TestSuiteUnsupported tt -> die $ "No support for building test suite "- ++ "type " ++ display tt - CBench bm -> do- case benchmarkInterface bm of- BenchmarkExeV10 _ f -> do- let bi = benchmarkBuildInfo bm- exe = Executable- { exeName = benchmarkName bm- , modulePath = f- , buildInfo = bi- }- progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi)- lbi' = lbi {- withPrograms = progs',- withPackageDB = withPackageDB lbi ++ [internalPackageDB]- }- pre comp lbi'- info verbosity $ "Building benchmark " ++ benchmarkName bm ++ "..."- buildExe verbosity pkg_descr lbi' exe clbi- BenchmarkUnsupported tt -> die $ "No support for building benchmark "- ++ "type " ++ display tt+buildComponent _ _ _ _+ (CTest TestSuite { testInterface = TestSuiteUnsupported tt })+ _ _ =+ die $ "No support for building test suite type " ++ display tt+++buildComponent verbosity pkg_descr lbi suffixes+ comp@(CBench+ bm@Benchmark { benchmarkInterface = BenchmarkExeV10 _ f })+ clbi _ = do+ let bi = benchmarkBuildInfo bm+ exe = Executable+ { exeName = benchmarkName bm+ , modulePath = f+ , buildInfo = bi+ }+ preprocessComponent pkg_descr comp lbi False verbosity suffixes+ info verbosity $ "Building benchmark " ++ benchmarkName bm ++ "..."+ buildExe verbosity pkg_descr lbi exe clbi+++buildComponent _ _ _ _+ (CBench Benchmark { benchmarkInterface = BenchmarkUnsupported tt })+ _ _ =+ die $ "No support for building benchmark type " ++ display tt+ -- | Initialize a new package db file for libraries defined -- internally to the package.
Distribution/Simple/Build/PathsModule.hs view
@@ -19,7 +19,7 @@ ) where import Distribution.System- ( OS(Windows), buildOS )+ ( OS(Windows), buildOS, Arch(..), buildArch ) import Distribution.Simple.Compiler ( CompilerFlavor(..), compilerFlavor, compilerVersion ) import Distribution.Package@@ -74,7 +74,8 @@ foreign_imports++ "import qualified Control.Exception as Exception\n"++ "import Data.Version (Version(..))\n"++- "import System.Environment (getEnv)"+++ "import System.Environment (getEnv)\n"+++ "import Prelude\n"++ "\n"++ "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"++ "catchIO = Exception.catch\n" ++@@ -167,7 +168,7 @@ | isHugs = "progdirrel :: String\n"++ "progdirrel = "++show (fromJust flat_progdirrel)++"\n\n"++ get_prefix_hugs- | otherwise = get_prefix_win32+ | otherwise = get_prefix_win32 buildArch path_sep = show [pathSeparator] @@ -189,8 +190,8 @@ fixchar '-' = '_' fixchar c = c -get_prefix_win32 :: String-get_prefix_win32 =+get_prefix_win32 :: Arch -> String+get_prefix_win32 arch = "getPrefixDirRel :: FilePath -> IO FilePath\n"++ "getPrefixDirRel dirRel = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.\n"++ " where\n"++@@ -204,8 +205,11 @@ " return ((bindir `minusFileName` bindirrel) `joinFileName` dirRel)\n"++ " | otherwise -> try_size (size * 2)\n"++ "\n"++- "foreign import stdcall unsafe \"windows.h GetModuleFileNameW\"\n"+++ "foreign import " ++ cconv ++ " unsafe \"windows.h GetModuleFileNameW\"\n"++ " c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n"+ where cconv = case arch of+ I386 -> "stdcall"+ X86_64 -> "ccall" get_prefix_hugs :: String
Distribution/Simple/Configure.hs view
@@ -61,6 +61,7 @@ ccLdOptionsBuildInfo, tryGetConfigStateFile, checkForeignDeps,+ interpretPackageDbFlags, ) where @@ -111,7 +112,7 @@ , withFileContents, writeFileAtomic , withTempFile ) import Distribution.System- ( OS(..), buildOS, buildPlatform )+ ( OS(..), buildOS, Arch(..), buildArch, buildPlatform ) import Distribution.Version ( Version(..), anyVersion, orLaterVersion, withinRange, isAnyVersion ) import Distribution.Verbosity@@ -150,8 +151,6 @@ ( comma, punctuate, render, nest, sep ) import Distribution.Compat.Exception ( catchExit, catchIO ) -import Prelude hiding (catch)- tryGetConfigStateFile :: (Read a) => FilePath -> IO (Either String a) tryGetConfigStateFile filename = do exists <- doesFileExist filename@@ -279,8 +278,8 @@ . userSpecifyPaths (configProgramPaths cfg) $ configPrograms cfg userInstall = fromFlag (configUserInstall cfg)- packageDbs = implicitPackageDbStack userInstall- (flagToMaybe $ configPackageDB cfg)+ packageDbs = interpretPackageDbFlags userInstall+ (configPackageDBs cfg) -- detect compiler (comp, programsConfig') <- configCompiler@@ -683,6 +682,11 @@ -> PackageDBStack -> ProgramConfiguration -> IO PackageIndex getInstalledPackages verbosity comp packageDBs progconf = do+ when (null packageDBs) $+ die $ "No package databases have been specified. If you use "+ ++ "--package-db=clear, you must follow it with --package-db= "+ ++ "with 'global', 'user' or a specific file."+ info verbosity "Reading installed packages..." case compilerFlavor comp of GHC -> GHC.getInstalledPackages verbosity packageDBs progconf@@ -694,20 +698,22 @@ flv -> die $ "don't know how to find the installed packages for " ++ display flv --- | Currently the user interface specifies the package dbs to use with just a--- single valued option, a 'PackageDB'. However internally we represent the--- stack of 'PackageDB's explictly as a list. This function converts encodes--- the package db stack implicit in a single packagedb.+-- | The user interface specifies the package dbs to use with a combination of+-- @--global@, @--user@ and @--package-db=global|user|clear|$file@.+-- This function combines the global/user flag and interprets the package-db+-- flag into a single package db stack. ---implicitPackageDbStack :: Bool -> Maybe PackageDB -> PackageDBStack-implicitPackageDbStack userInstall maybePackageDB- | userInstall = GlobalPackageDB : UserPackageDB : extra- | otherwise = GlobalPackageDB : extra+interpretPackageDbFlags :: Bool -> [Maybe PackageDB] -> PackageDBStack+interpretPackageDbFlags userInstall specificDBs =+ extra initialStack specificDBs where- extra = case maybePackageDB of- Just (SpecificPackageDB db) -> [SpecificPackageDB db]- _ -> []+ initialStack | userInstall = [GlobalPackageDB, UserPackageDB]+ | otherwise = [GlobalPackageDB] + extra dbs' [] = dbs'+ extra _ (Nothing:dbs) = extra [] dbs+ extra dbs' (Just db:dbs) = extra (dbs' ++ [db]) dbs+ newPackageDepsBehaviourMinVersion :: Version newPackageDepsBehaviourMinVersion = Version { versionBranch = [1,7,1], versionTags = [] } @@ -1003,7 +1009,40 @@ hcDefines :: Compiler -> [String] hcDefines comp = case compilerFlavor comp of- GHC -> ["-D__GLASGOW_HASKELL__=" ++ versionInt version]+ GHC ->+ let ghcOS = case buildOS of+ Linux -> ["linux"]+ Windows -> ["mingw32"]+ OSX -> ["darwin"]+ FreeBSD -> ["freebsd"]+ OpenBSD -> ["openbsd"]+ NetBSD -> ["netbsd"]+ Solaris -> ["solaris2"]+ AIX -> ["aix"]+ HPUX -> ["hpux"]+ IRIX -> ["irix"]+ HaLVM -> []+ OtherOS _ -> []+ ghcArch = case buildArch of+ I386 -> ["i386"]+ X86_64 -> ["x86_64"]+ PPC -> ["powerpc"]+ PPC64 -> ["powerpc64"]+ Sparc -> ["sparc"]+ Arm -> ["arm"]+ Mips -> ["mips"]+ SH -> []+ IA64 -> ["ia64"]+ S390 -> ["s390"]+ Alpha -> ["alpha"]+ Hppa -> ["hppa"]+ Rs6000 -> ["rs6000"]+ M68k -> ["m68k"]+ Vax -> ["vax"]+ OtherArch _ -> []+ in ["-D__GLASGOW_HASKELL__=" ++ versionInt version] +++ map (\os -> "-D" ++ os ++ "_HOST_OS=1") ghcOS +++ map (\arch -> "-D" ++ arch ++ "_HOST_ARCH=1") ghcArch JHC -> ["-D__JHC__=" ++ versionInt version] NHC -> ["-D__NHC__=" ++ versionInt version] Hugs -> ["-D__HUGS__"]
Distribution/Simple/GHC.hs view
@@ -66,10 +66,12 @@ installLib, installExe, libAbiHash, registerPackage,- ghcOptions,+ componentGhcOptions,+ ghcLibDir,++ -- * Deprecated ghcVerbosityOptions, ghcPackageDbOptions,- ghcLibDir, ) where import qualified Distribution.Simple.GHC.IPI641 as IPI641@@ -94,8 +96,9 @@ import qualified Distribution.ModuleName as ModuleName import Distribution.Simple.Program ( Program(..), ConfiguredProgram(..), ProgramConfiguration, ProgArg- , ProgramLocation(..), rawSystemProgram, rawSystemProgramConf+ , ProgramLocation(..), rawSystemProgram , rawSystemProgramStdout, rawSystemProgramStdoutConf+ , getProgramInvocationOutput , requireProgramVersion, requireProgram, getProgramOutput , userMaybeSpecifyPath, programPath, lookupProgram, addKnownProgram , ghcProgram, ghcPkgProgram, hsc2hsProgram@@ -104,10 +107,12 @@ import qualified Distribution.Simple.Program.HcPkg as HcPkg import qualified Distribution.Simple.Program.Ar as Ar import qualified Distribution.Simple.Program.Ld as Ld+import Distribution.Simple.Program.GHC+import Distribution.Simple.Setup (toFlag, fromFlag) import Distribution.Simple.Compiler ( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion , OptimisationLevel(..), PackageDB(..), PackageDBStack- , Flag, languageToFlags, extensionsToFlags )+ , Flag ) import Distribution.Version ( Version(..), anyVersion, orLaterVersion ) import Distribution.System@@ -120,7 +125,7 @@ import Control.Monad ( unless, when, liftM ) import Data.Char ( isSpace ) import Data.List-import Data.Maybe ( catMaybes )+import Data.Maybe ( catMaybes, fromMaybe ) import Data.Monoid ( Monoid(..) ) import System.Directory ( removeFile, getDirectoryContents, doesFileExist@@ -128,6 +133,7 @@ import System.FilePath ( (</>), (<.>), takeExtension, takeDirectory, replaceExtension, splitExtension ) import System.IO (hClose, hPutStrLn)+import System.Environment (getEnv) import Distribution.Compat.Exception (catchExit, catchIO) -- -----------------------------------------------------------------------------@@ -251,23 +257,29 @@ addKnownProgram gccProgram { programFindLocation = findProg gccProgram [ if ghcVersion >= Version [6,12] []- then mingwBinDir </> "gcc.exe"+ then mingwBinDir </> binPrefix ++ "gcc.exe" else baseDir </> "gcc.exe" ], programPostConf = configureGcc } . addKnownProgram ldProgram { programFindLocation = findProg ldProgram [ if ghcVersion >= Version [6,12] []- then mingwBinDir </> "ld.exe"+ then mingwBinDir </> binPrefix ++ "ld.exe" else libDir </> "ld.exe" ], programPostConf = configureLd } . addKnownProgram arProgram { programFindLocation = findProg arProgram [ if ghcVersion >= Version [6,12] []- then mingwBinDir </> "ar.exe"+ then mingwBinDir </> binPrefix ++ "ar.exe" else libDir </> "ar.exe" ] }+ . addKnownProgram stripProgram {+ programFindLocation = findProg stripProgram+ [ if ghcVersion >= Version [6,12] []+ then mingwBinDir </> binPrefix ++ "strip.exe"+ else libDir </> "strip.exe" ]+ } where Just ghcVersion = programVersion ghcProg compilerDir = takeDirectory (programPath ghcProg)@@ -276,6 +288,7 @@ libDir = baseDir </> "gcc-lib" includeDir = baseDir </> "include" </> "mingw" isWindows = case buildOS of Windows -> True; _ -> False+ binPrefix = "" -- on Windows finding and configuring ghc's gcc and ld is a bit special findProg :: Program -> [FilePath] -> Verbosity -> IO (Maybe FilePath)@@ -457,6 +470,7 @@ getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration -> IO PackageIndex getInstalledPackages verbosity packagedbs conf = do+ checkPackageDbEnvVar checkPackageDbStack packagedbs pkgss <- getInstalledPackages' verbosity packagedbs conf topDir <- ghcLibDir' verbosity ghcProg@@ -487,11 +501,29 @@ (reverse . dropWhile isSpace . reverse) `fmap` rawSystemProgramStdout verbosity ghcProg ["--print-libdir"] +-- Cabal does not use the environment variable GHC_PACKAGE_PATH; let users+-- know that this is the case. See ticket #335. Simply ignoring it is not a+-- good idea, since then ghc and cabal are looking at different sets of+-- package dbs and chaos is likely to ensue.+checkPackageDbEnvVar :: IO ()+checkPackageDbEnvVar = do+ hasGPP <- (getEnv "GHC_PACKAGE_PATH" >> return True)+ `catchIO` (\_ -> return False)+ when hasGPP $+ die $ "Use of GHC's environment variable GHC_PACKAGE_PATH is "+ ++ "incompatible with Cabal. Use the flag --package-db to specify a "+ ++ "package database (it can be used multiple times)."+ checkPackageDbStack :: PackageDBStack -> IO () checkPackageDbStack (GlobalPackageDB:rest) | GlobalPackageDB `notElem` rest = return ()+checkPackageDbStack rest+ | GlobalPackageDB `notElem` rest =+ die $ "With current ghc versions the global package db is always used "+ ++ "and must be listed first. This ghc limitation may be lifted in "+ ++ "future, see http://hackage.haskell.org/trac/ghc/ticket/5977" checkPackageDbStack _ =- die $ "GHC.getInstalledPackages: the global package db must be "+ die $ "If the global package db is specified, it must be " ++ "specified first and cannot be specified multiple times" -- GHC < 6.10 put "$topdir/include/mingw" in rts's installDirs. This@@ -579,7 +611,6 @@ buildLib verbosity pkg_descr lbi lib clbi = do let pref = buildDir lbi pkgid = packageId pkg_descr- runGhcProg = rawSystemProgramConf verbosity ghcProgram (withPrograms lbi) ifVanillaLib forceVanilla = when (forceVanilla || withVanillaLib lbi) ifProfLib = when (withProfLib lbi) ifSharedLib = when (withSharedLib lbi)@@ -587,6 +618,9 @@ comp = compiler lbi ghcVersion = compilerVersion comp + (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi)+ let runGhcProg = runGHC verbosity ghcProg+ libBi <- hackThreadedFlag verbosity comp (withProfLib lbi) (libBuildInfo lib) @@ -596,39 +630,51 @@ createDirectoryIfMissingVerbose verbosity True libTargetDir -- TODO: do we need to put hs-boot files into place for mutually recurive modules?- let ghcArgs =- "--make"- : ["-package-name", display pkgid ]- ++ constructGHCCmdLine lbi libBi clbi libTargetDir verbosity- ++ map display (libModules lib)- ghcArgsProf = ghcArgs- ++ ["-prof",- "-hisuf", "p_hi",- "-osuf", "p_o"- ]- ++ ghcProfOptions libBi- ghcArgsShared = ghcArgs- ++ ["-dynamic",- "-hisuf", "dyn_hi",- "-osuf", "dyn_o", "-fPIC"- ]- ++ ghcSharedOptions libBi+ let baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir+ vanillaOpts = baseOpts `mappend` mempty {+ ghcOptMode = toFlag GhcModeMake,+ ghcOptPackageName = toFlag pkgid,+ ghcOptInputModules = libModules lib+ }++ profOpts = vanillaOpts `mappend` mempty {+ ghcOptProfilingMode = toFlag True,+ ghcOptHiSuffix = toFlag "p_hi",+ ghcOptObjSuffix = toFlag "p_o",+ ghcOptExtra = ghcProfOptions libBi+ }++ sharedOpts = vanillaOpts `mappend` mempty {+ ghcOptDynamic = toFlag True,+ ghcOptFPic = toFlag True,+ ghcOptHiSuffix = toFlag "dyn_hi",+ ghcOptObjSuffix = toFlag "dyn_o",+ ghcOptExtra = ghcSharedOptions libBi+ }+ unless (null (libModules lib)) $- do ifVanillaLib forceVanillaLib (runGhcProg ghcArgs)- ifProfLib (runGhcProg ghcArgsProf)- ifSharedLib (runGhcProg ghcArgsShared)+ do ifVanillaLib forceVanillaLib (runGhcProg vanillaOpts)+ ifProfLib (runGhcProg profOpts)+ ifSharedLib (runGhcProg sharedOpts) -- build any C sources unless (null (cSources libBi)) $ do info verbosity "Building C Sources..."- sequence_ [do let (odir,args) = constructCcCmdLine lbi libBi clbi pref- filename verbosity- False- (withProfLib lbi)- createDirectoryIfMissingVerbose verbosity True odir- runGhcProg args- ifSharedLib (runGhcProg (args ++ ["-fPIC", "-osuf dyn_o"]))- | filename <- cSources libBi]+ sequence_+ [ do let vanillaCcOpts = (componentCcGhcOptions verbosity lbi+ libBi clbi pref filename) `mappend` mempty {+ ghcOptProfilingMode = toFlag (withProfLib lbi)+ }+ sharedCcOpts = vanillaCcOpts `mappend` mempty {+ ghcOptFPic = toFlag True,+ ghcOptDynamic = toFlag True,+ ghcOptObjSuffix = toFlag "dyn_o"+ }+ odir = fromFlag (ghcOptObjDir vanillaCcOpts)+ createDirectoryIfMissingVerbose verbosity True odir+ runGhcProg vanillaCcOpts+ ifSharedLib (runGhcProg sharedCcOpts)+ | filename <- cSources libBi] -- link: info verbosity "Linking..."@@ -699,20 +745,23 @@ -- with the dependencies spelled out as -package arguments -- and ghc invokes the linker with the proper library paths ghcSharedLinkArgs =- [ "-no-auto-link-packages",- "-shared",- "-dynamic",- "-o", sharedLibFilePath ]- -- For dynamic libs, Mac OS/X needs to know the install location- -- at build time.- ++ (if buildOS == OSX- then ["-dylib-install-name", sharedLibInstallPath]- else [])- ++ dynamicObjectFiles- ++ ["-package-name", display pkgid ]- ++ ghcPackageFlags lbi clbi- ++ ["-l"++extraLib | extraLib <- extraLibs libBi]- ++ ["-L"++extraLibDir | extraLibDir <- extraLibDirs libBi]+ mempty {+ ghcOptShared = toFlag True,+ ghcOptDynamic = toFlag True,+ ghcOptInputFiles = dynamicObjectFiles,+ ghcOptOutputFile = toFlag sharedLibFilePath,+ -- For dynamic libs, Mac OS/X needs to know the install location+ -- at build time.+ ghcOptDylibName = if buildOS == OSX+ then toFlag sharedLibInstallPath+ else mempty,+ ghcOptPackageName = toFlag pkgid,+ ghcOptNoAutoLinkPackages = toFlag True,+ ghcOptPackageDBs = withPackageDB lbi,+ ghcOptPackages = componentPackageDeps clbi,+ ghcOptLinkLibs = extraLibs libBi,+ ghcOptLinkLibPath = extraLibDirs libBi+ } ifVanillaLib False $ do (arProg, _) <- requireProgram verbosity arProgram (withPrograms lbi)@@ -740,8 +789,10 @@ buildExe verbosity _pkg_descr lbi exe@Executable { exeName = exeName', modulePath = modPath } clbi = do let pref = buildDir lbi- runGhcProg = rawSystemProgramConf verbosity ghcProgram (withPrograms lbi) + (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi)+ let runGhcProg = runGHC verbosity ghcProg+ exeBi <- hackThreadedFlag verbosity (compiler lbi) (withProfExe lbi) (buildInfo exe) @@ -759,48 +810,58 @@ -- build executables unless (null (cSources exeBi)) $ do info verbosity "Building C Sources."- sequence_ [do let (odir,args) = constructCcCmdLine lbi exeBi clbi- exeDir filename verbosity- (withDynExe lbi) (withProfExe lbi)- createDirectoryIfMissingVerbose verbosity True odir- runGhcProg args- | filename <- cSources exeBi]+ sequence_+ [ do let opts = (componentCcGhcOptions verbosity lbi exeBi clbi+ exeDir filename) `mappend` mempty {+ ghcOptDynamic = toFlag (withDynExe lbi),+ ghcOptProfilingMode = toFlag (withProfExe lbi)+ }+ odir = fromFlag (ghcOptObjDir opts)+ createDirectoryIfMissingVerbose verbosity True odir+ runGhcProg opts+ | filename <- cSources exeBi] srcMainFile <- findFile (exeDir : hsSourceDirs exeBi) modPath let cObjs = map (`replaceExtension` objExtension) (cSources exeBi)- let binArgs linkExe dynExe profExe =- "--make"- : (if linkExe- then ["-o", targetDir </> exeNameReal]- else ["-c"])- ++ constructGHCCmdLine lbi exeBi clbi exeDir verbosity- ++ [exeDir </> x | x <- cObjs]- ++ [srcMainFile]- ++ ["-optl" ++ opt | opt <- PD.ldOptions exeBi]- ++ ["-l"++lib | lib <- extraLibs exeBi]- ++ ["-L"++libDir | libDir <- extraLibDirs exeBi]- ++ concat [["-framework", f] | f <- PD.frameworks exeBi]- ++ if dynExe- then ["-dynamic"]- else []- ++ if profExe- then ["-prof",- "-hisuf", "p_hi",- "-osuf", "p_o"- ] ++ ghcProfOptions exeBi- else []+ let vanillaOpts = (componentGhcOptions verbosity lbi exeBi clbi exeDir)+ `mappend` mempty {+ ghcOptMode = toFlag GhcModeMake,+ ghcOptInputFiles = [exeDir </> x | x <- cObjs]+ ++ [srcMainFile],+ ghcOptLinkOptions = PD.ldOptions exeBi,+ ghcOptLinkLibs = extraLibs exeBi,+ ghcOptLinkLibPath = extraLibDirs exeBi,+ ghcOptLinkFrameworks = PD.frameworks exeBi+ } + dynamicOpts = vanillaOpts `mappend` mempty {+ ghcOptDynamic = toFlag True,+ ghcOptExtra = ghcSharedOptions exeBi+ }++ exeOpts | withDynExe lbi = dynamicOpts+ | otherwise = vanillaOpts++ exeProfOpts = exeOpts `mappend` mempty {+ ghcOptProfilingMode = toFlag True,+ ghcOptHiSuffix = toFlag "p_hi",+ ghcOptObjSuffix = toFlag "p_o",+ ghcOptExtra = ghcProfOptions exeBi,+ ghcOptNoLink = toFlag True+ } -- For building exe's for profiling that use TH we actually -- have to build twice, once without profiling and the again -- with profiling. This is because the code that TH needs to -- run at compile time needs to be the vanilla ABI so it can -- be loaded up and run by the compiler.- when (withProfExe lbi && EnableExtension TemplateHaskell `elem` allExtensions exeBi)- (runGhcProg (binArgs False (withDynExe lbi) False))+ when (withProfExe lbi &&+ EnableExtension TemplateHaskell `elem` allExtensions exeBi) $+ runGhcProg exeProfOpts { ghcOptNoLink = toFlag True } - runGhcProg (binArgs True (withDynExe lbi) (withProfExe lbi))+ runGhcProg exeOpts { ghcOptOutputFile = toFlag (targetDir </> exeNameReal) } + -- | Filter the "-threaded" flag when profiling as it does not -- work with ghc-6.8 and older. hackThreadedFlag :: Verbosity -> Compiler -> Bool -> BuildInfo -> IO BuildInfo@@ -849,74 +910,84 @@ (compiler lbi) (withProfLib lbi) (libBuildInfo lib) let ghcArgs =- "--abi-hash"- : ["-package-name", display (packageId pkg_descr) ]- ++ constructGHCCmdLine lbi libBi clbi (buildDir lbi) verbosity- ++ map display (exposedModules lib)+ (componentGhcOptions verbosity lbi libBi clbi (buildDir lbi))+ `mappend` mempty {+ ghcOptMode = toFlag GhcModeAbiHash,+ ghcOptPackageName = toFlag (packageId pkg_descr),+ ghcOptInputModules = exposedModules lib+ } --- rawSystemProgramStdoutConf verbosity ghcProgram (withPrograms lbi) ghcArgs+ (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi)+ getProgramInvocationOutput verbosity (ghcInvocation ghcProg ghcArgs) -constructGHCCmdLine- :: LocalBuildInfo- -> BuildInfo- -> ComponentLocalBuildInfo- -> FilePath- -> Verbosity- -> [String]-constructGHCCmdLine lbi bi clbi odir verbosity =- ghcVerbosityOptions verbosity- -- Unsupported extensions have already been checked by configure- ++ ghcOptions lbi bi clbi odir+componentGhcOptions :: Verbosity -> LocalBuildInfo+ -> BuildInfo -> ComponentLocalBuildInfo -> FilePath+ -> GhcOptions+componentGhcOptions verbosity lbi bi clbi odir =+ mempty {+ ghcOptVerbosity = toFlag verbosity,+ ghcOptHideAllPackages = toFlag True,+ ghcOptCabal = toFlag True,+ ghcOptPackageDBs = withPackageDB lbi,+ ghcOptPackages = componentPackageDeps clbi,+ ghcOptSplitObjs = toFlag (splitObjs lbi),+ ghcOptSourcePathClear = toFlag True,+ ghcOptSourcePath = [odir] ++ nub (hsSourceDirs bi)+ ++ [autogenModulesDir lbi],+ ghcOptCppIncludePath = [autogenModulesDir lbi, odir]+ ++ PD.includeDirs bi,+ ghcOptCppOptions = cppOptions bi,+ ghcOptCppIncludes = [autogenModulesDir lbi </> cppHeaderName],+ ghcOptFfiIncludes = PD.includes bi,+ ghcOptObjDir = toFlag odir,+ ghcOptHiDir = toFlag odir,+ ghcOptStubDir = toFlag odir,+ ghcOptOptimisation = toGhcOptimisation (withOptimization lbi),+ ghcOptExtra = hcOptions GHC bi,+ ghcOptLanguage = toFlag (fromMaybe Haskell98 (defaultLanguage bi)),+ -- Unsupported extensions have already been checked by configure+ ghcOptExtensions = usedExtensions bi,+ ghcOptExtensionMap = compilerExtensions (compiler lbi)+ }+ where+ toGhcOptimisation NoOptimisation = mempty --TODO perhaps override?+ toGhcOptimisation NormalOptimisation = toFlag GhcNormalOptimisation+ toGhcOptimisation MaximumOptimisation = toFlag GhcMaximumOptimisation ++componentCcGhcOptions :: Verbosity -> LocalBuildInfo+ -> BuildInfo -> ComponentLocalBuildInfo+ -> FilePath -> FilePath+ -> GhcOptions+componentCcGhcOptions verbosity lbi bi clbi pref filename =+ mempty {+ ghcOptVerbosity = toFlag verbosity,+ ghcOptMode = toFlag GhcModeCompile,+ ghcOptInputFiles = [filename],++ ghcOptCppIncludePath = odir : PD.includeDirs bi,+ ghcOptPackageDBs = withPackageDB lbi,+ ghcOptPackages = componentPackageDeps clbi,+ ghcOptCcOptions = PD.ccOptions bi+ ++ case withOptimization lbi of+ NoOptimisation -> []+ _ -> ["-O2"],+ ghcOptObjDir = toFlag odir+ }+ where+ odir | compilerVersion (compiler lbi) >= Version [6,4,1] [] = pref+ | otherwise = pref </> takeDirectory filename+ -- ghc 6.4.0 had a bug in -odir handling for C compilations.++{-# DEPRECATED ghcVerbosityOptions "Use the GhcOptions record instead" #-} ghcVerbosityOptions :: Verbosity -> [String] ghcVerbosityOptions verbosity | verbosity >= deafening = ["-v"] | verbosity >= normal = [] | otherwise = ["-w", "-v0"] -ghcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo- -> FilePath -> [String]-ghcOptions lbi bi clbi odir- = ["-hide-all-packages"]- ++ ["-fbuilding-cabal-package" | ghcVer >= Version [6,11] [] ]- ++ ghcPackageDbOptions (withPackageDB lbi)- ++ ["-split-objs" | splitObjs lbi ]- ++ ["-i"]- ++ ["-i" ++ odir]- ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)]- ++ ["-i" ++ autogenModulesDir lbi]- ++ ["-I" ++ autogenModulesDir lbi]- ++ ["-I" ++ odir]- ++ ["-I" ++ dir | dir <- PD.includeDirs bi]- ++ ["-optP" ++ opt | opt <- cppOptions bi]- ++ [ "-optP-include", "-optP"++ (autogenModulesDir lbi </> cppHeaderName) ]- ++ [ "-#include \"" ++ inc ++ "\"" | ghcVer < Version [6,11] []- , inc <- PD.includes bi ]- ++ [ "-odir", odir, "-hidir", odir ]- ++ concat [ ["-stubdir", odir] | ghcVer >= Version [6,8] [] ]- ++ ghcPackageFlags lbi clbi- ++ (case withOptimization lbi of- NoOptimisation -> []- NormalOptimisation -> ["-O"]- MaximumOptimisation -> ["-O2"])- ++ hcOptions GHC bi- ++ languageToFlags (compiler lbi) (defaultLanguage bi)- ++ extensionsToFlags (compiler lbi) (usedExtensions bi)- where- ghcVer = compilerVersion (compiler lbi)--ghcPackageFlags :: LocalBuildInfo -> ComponentLocalBuildInfo -> [String]-ghcPackageFlags lbi clbi- | ghcVer >= Version [6,11] []- = concat [ ["-package-id", display ipkgid]- | (ipkgid, _) <- componentPackageDeps clbi ]-- | otherwise = concat [ ["-package", display pkgid]- | (_, pkgid) <- componentPackageDeps clbi ]- where- ghcVer = compilerVersion (compiler lbi)-+{-# DEPRECATED ghcPackageDbOptions "Use the GhcOptions record instead" #-} ghcPackageDbOptions :: PackageDBStack -> [String] ghcPackageDbOptions dbstack = case dbstack of (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs@@ -927,38 +998,6 @@ specific (SpecificPackageDB db) = [ "-package-conf", db ] specific _ = ierror ierror = error ("internal error: unexpected package db stack: " ++ show dbstack)--constructCcCmdLine :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo- -> FilePath -> FilePath -> Verbosity -> Bool -> Bool- ->(FilePath,[String])-constructCcCmdLine lbi bi clbi pref filename verbosity dynamic profiling- = let odir | compilerVersion (compiler lbi) >= Version [6,4,1] [] = pref- | otherwise = pref </> takeDirectory filename- -- ghc 6.4.1 fixed a bug in -odir handling- -- for C compilations.- in- (odir,- ghcCcOptions lbi bi clbi odir- ++ (if verbosity >= deafening then ["-v"] else [])- ++ ["-c",filename]- -- Note: When building with profiling enabled, we pass the -prof- -- option to ghc here when compiling C code, so that the PROFILING- -- macro gets defined. The macro is used in ghc's Rts.h in the- -- definitions of closure layouts (Closures.h).- ++ ["-dynamic" | dynamic]- ++ ["-prof" | profiling])--ghcCcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo- -> FilePath -> [String]-ghcCcOptions lbi bi clbi odir- = ["-I" ++ dir | dir <- odir : PD.includeDirs bi]- ++ ghcPackageDbOptions (withPackageDB lbi)- ++ ghcPackageFlags lbi clbi- ++ ["-optc" ++ opt | opt <- PD.ccOptions bi]- ++ (case withOptimization lbi of- NoOptimisation -> []- _ -> ["-optc-O2"])- ++ ["-odir", odir] mkGHCiLibName :: PackageIdentifier -> String mkGHCiLibName lib = "HS" ++ display lib <.> "o"
Distribution/Simple/Haddock.hs view
@@ -59,7 +59,8 @@ , Library(..), hasLibs, Executable(..) ) import Distribution.Simple.Compiler ( Compiler(..), compilerVersion )-import Distribution.Simple.GHC ( ghcLibDir )+import Distribution.Simple.GHC ( componentGhcOptions, ghcLibDir )+import Distribution.Simple.Program.GHC ( GhcOptions(..), renderGhcOptions ) import Distribution.Simple.Program ( ConfiguredProgram(..), requireProgramVersion , rawSystemProgram, rawSystemProgramStdout@@ -68,7 +69,7 @@ , PPSuffixHandler, runSimplePreProcessor , preprocessComponent) import Distribution.Simple.Setup- ( defaultHscolourFlags, Flag(..), flagToMaybe, fromFlag+ ( defaultHscolourFlags, Flag(..), toFlag, flagToMaybe, flagToList, fromFlag , HaddockFlags(..), HscolourFlags(..) ) import Distribution.Simple.Build (initialBuildSteps) import Distribution.Simple.InstallDirs (InstallDirs(..), PathTemplateEnv, PathTemplate,@@ -77,8 +78,8 @@ substPathTemplate, initialPathTemplateEnv) import Distribution.Simple.LocalBuildInfo- ( LocalBuildInfo(..), externalPackageDeps- , Component(..), ComponentLocalBuildInfo(..), withComponentsLBI )+ ( LocalBuildInfo(..), Component(..), ComponentLocalBuildInfo(..)+ , withComponentsLBI ) import Distribution.Simple.BuildPaths ( haddockName, hscolourPref, autogenModulesDir, )@@ -93,7 +94,6 @@ , createDirectoryIfMissingVerbose, withTempFile, copyFileVerbose , withTempDirectory , findFileWithExtension, findFile )-import Distribution.Simple.GHC (ghcOptions) import Distribution.Text ( display, simpleParse ) @@ -129,7 +129,7 @@ argOutputDir :: Directory, -- ^ where to generate the documentation. argTitle :: Flag String, -- ^ page's title, required. argPrologue :: Flag String, -- ^ prologue text, required.- argGhcFlags :: [String], -- ^ additional flags to pass to ghc for haddock-2+ argGhcOptions :: Flag (GhcOptions, Version), -- ^ additional flags to pass to ghc for haddock-2 argGhcLibDir :: Flag FilePath, -- ^ to find the correct ghc, required by haddock-2. argTargets :: [FilePath] -- ^ modules to process. }@@ -194,11 +194,10 @@ when (flag haddockHscolour) $ hscolour' pkg_descr lbi suffixes $ defaultHscolourFlags `mappend` haddockToHscolour flags - args <- fmap mconcat . sequence $- [ getInterfaces verbosity lbi (flagToMaybe (haddockHtmlLocation flags))- , getGhcLibDir verbosity lbi isVersion2 ]- ++ map return- [ fromFlags (haddockTemplateEnv lbi (packageId pkg_descr)) flags+ libdirArgs <- getGhcLibDir verbosity lbi isVersion2+ let commonArgs = mconcat+ [ libdirArgs+ , fromFlags (haddockTemplateEnv lbi (packageId pkg_descr)) flags , fromPackageDescription pkg_descr ] let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes@@ -208,21 +207,22 @@ CLib lib -> do withTempDirectory verbosity (buildDir lbi) "tmp" $ \tmp -> do let bi = libBuildInfo lib- libArgs <- fromLibrary tmp lbi lib clbi+ libArgs <- fromLibrary verbosity tmp lbi lib clbi htmlTemplate libArgs' <- prepareSources verbosity tmp- lbi isVersion2 bi (args `mappend` libArgs)+ lbi isVersion2 bi (commonArgs `mappend` libArgs) runHaddock verbosity confHaddock libArgs' CExe exe -> when (flag haddockExecutables) $ do withTempDirectory verbosity (buildDir lbi) "tmp" $ \tmp -> do let bi = buildInfo exe- exeArgs <- fromExecutable tmp lbi exe clbi+ exeArgs <- fromExecutable verbosity tmp lbi exe clbi htmlTemplate exeArgs' <- prepareSources verbosity tmp- lbi isVersion2 bi (args `mappend` exeArgs)+ lbi isVersion2 bi (commonArgs `mappend` exeArgs) runHaddock verbosity confHaddock exeArgs' _ -> return () where verbosity = flag haddockVerbosity flag f = fromFlag $ f flags+ htmlTemplate = fmap toPathTemplate . flagToMaybe . haddockHtmlLocation $ flags -- | performs cpp and unlit preprocessing where needed on the files in -- | argTargets, which must have an .hs or .lhs extension.@@ -300,52 +300,64 @@ subtitle | null (synopsis pkg_descr) = "" | otherwise = ": " ++ synopsis pkg_descr -fromLibrary :: FilePath+fromLibrary :: Verbosity+ -> FilePath -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo+ -> Maybe PathTemplate -- ^ template for html location -> IO HaddockArgs-fromLibrary tmp lbi lib clbi =- do inFiles <- map snd `fmap` getLibSourceFiles lbi lib- return $ mempty {- argHideModules = (mempty,otherModules $ bi),- argGhcFlags = ghcOptions lbi bi clbi (buildDir lbi)- -- Noooooooooo!!!!!111- -- haddock stomps on our precious .hi- -- and .o files. Workaround by telling- -- haddock to write them elsewhere.- ++ [ "-odir", tmp, "-hidir", tmp- , "-stubdir", tmp ],- argTargets = inFiles- }- where- bi = libBuildInfo lib+fromLibrary verbosity tmp lbi lib clbi htmlTemplate = do+ inFiles <- map snd `fmap` getLibSourceFiles lbi lib+ ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate+ return ifaceArgs {+ argHideModules = (mempty,otherModules $ bi),+ argGhcOptions = toFlag ((componentGhcOptions normal lbi bi clbi (buildDir lbi)) {+ -- Noooooooooo!!!!!111+ -- haddock stomps on our precious .hi+ -- and .o files. Workaround by telling+ -- haddock to write them elsewhere.+ ghcOptObjDir = toFlag tmp,+ ghcOptHiDir = toFlag tmp,+ ghcOptStubDir = toFlag tmp+ },ghcVersion),+ argTargets = inFiles+ }+ where+ bi = libBuildInfo lib+ ghcVersion = compilerVersion (compiler lbi) -fromExecutable :: FilePath+fromExecutable :: Verbosity+ -> FilePath -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo+ -> Maybe PathTemplate -- ^ template for html location -> IO HaddockArgs-fromExecutable tmp lbi exe clbi =- do inFiles <- map snd `fmap` getExeSourceFiles lbi exe- return $ mempty {- argGhcFlags = ghcOptions lbi bi clbi (buildDir lbi)- -- Noooooooooo!!!!!111- -- haddock stomps on our precious .hi- -- and .o files. Workaround by telling- -- haddock to write them elsewhere.- ++ [ "-odir", tmp, "-hidir", tmp- , "-stubdir", tmp ],- argOutputDir = Dir (exeName exe),- argTitle = Flag (exeName exe),- argTargets = inFiles- }- where- bi = buildInfo exe+fromExecutable verbosity tmp lbi exe clbi htmlTemplate = do+ inFiles <- map snd `fmap` getExeSourceFiles lbi exe+ ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate+ return ifaceArgs {+ argGhcOptions = toFlag ((componentGhcOptions normal lbi bi clbi (buildDir lbi)) {+ -- Noooooooooo!!!!!111+ -- haddock stomps on our precious .hi+ -- and .o files. Workaround by telling+ -- haddock to write them elsewhere.+ ghcOptObjDir = toFlag tmp,+ ghcOptHiDir = toFlag tmp,+ ghcOptStubDir = toFlag tmp+ }, ghcVersion),+ argOutputDir = Dir (exeName exe),+ argTitle = Flag (exeName exe),+ argTargets = inFiles+ }+ where+ bi = buildInfo exe+ ghcVersion = compilerVersion (compiler lbi) getInterfaces :: Verbosity- -> LocalBuildInfo- -> Maybe String -- ^ template for html location- -> IO HaddockArgs-getInterfaces verbosity lbi location = do- let htmlTemplate = fmap toPathTemplate $ location- (packageFlags, warnings) <- haddockPackageFlags lbi htmlTemplate+ -> LocalBuildInfo+ -> ComponentLocalBuildInfo+ -> Maybe PathTemplate -- ^ template for html location+ -> IO HaddockArgs+getInterfaces verbosity lbi clbi htmlTemplate = do+ (packageFlags, warnings) <- haddockPackageFlags lbi clbi htmlTemplate maybe (return ()) (warn verbosity) warnings return $ mempty { argInterfaces = packageFlags@@ -378,7 +390,7 @@ renderArgs :: Verbosity -> Version -> HaddockArgs- -> (([[Char]], FilePath) -> IO a)+ -> (([String], FilePath) -> IO a) -> IO a renderArgs verbosity version args k = do createDirectoryIfMissingVerbose verbosity True outputDir@@ -403,7 +415,7 @@ pkgid = arg argPackageName arg f = fromFlag $ f args -renderPureArgs :: Version -> HaddockArgs -> [[Char]]+renderPureArgs :: Version -> HaddockArgs -> [String] renderPureArgs version args = concat [ (:[]) . (\f -> "--dump-interface="++ unDir (argOutputDir args) </> f)@@ -423,7 +435,9 @@ (:[]).("--odir="++) . unDir . argOutputDir $ args, (:[]).("--title="++) . (bool (++" (internal documentation)") id (getAny $ argIgnoreExports args)) . fromFlag . argTitle $ args,- bool id (const []) isVersion2 . map ("--optghc=" ++) . argGhcFlags $ args,+ [ "--optghc=" ++ opt | isVersion2+ , (opts, ghcVersion) <- flagToList (argGhcOptions args)+ , opt <- renderGhcOptions ghcVersion opts ], maybe [] (\l -> ["-B"++l]) $ guard isVersion2 >> flagToMaybe (argGhcLibDir args), -- error if isVersion2 and Nothing? argTargets $ args ]@@ -439,11 +453,12 @@ ----------------------------------------------------------------------------------------------------------- haddockPackageFlags :: LocalBuildInfo+ -> ComponentLocalBuildInfo -> Maybe PathTemplate -> IO ([(FilePath,Maybe FilePath)], Maybe String)-haddockPackageFlags lbi htmlTemplate = do+haddockPackageFlags lbi clbi htmlTemplate = do let allPkgs = installedPkgs lbi- directDeps = map fst (externalPackageDeps lbi)+ directDeps = map fst (componentPackageDeps clbi) transitiveDeps <- case dependencyClosure allPkgs directDeps of Left x -> return x Right inf -> die $ "internal error when calculating transative "@@ -609,7 +624,7 @@ argOutputDir = mempty, argTitle = mempty, argPrologue = mempty,- argGhcFlags = mempty,+ argGhcOptions = mempty, argGhcLibDir = mempty, argTargets = mempty }@@ -627,7 +642,7 @@ argOutputDir = mult argOutputDir, argTitle = mult argTitle, argPrologue = mult argPrologue,- argGhcFlags = mult argGhcFlags,+ argGhcOptions = mult argGhcOptions, argGhcLibDir = mult argGhcLibDir, argTargets = mult argTargets }
Distribution/Simple/InstallDirs.hs view
@@ -90,7 +90,7 @@ import Distribution.Text ( display ) -#if mingw32_HOST_OS || mingw32_TARGET_OS+#if mingw32_HOST_OS import Foreign import Foreign.C #endif@@ -551,14 +551,14 @@ getWindowsProgramFilesDir :: IO FilePath getWindowsProgramFilesDir = do-#if mingw32_HOST_OS || mingw32_TARGET_OS+#if mingw32_HOST_OS m <- shGetFolderPath csidl_PROGRAM_FILES #else let m = Nothing #endif return (fromMaybe "C:\\Program Files" m) -#if mingw32_HOST_OS || mingw32_TARGET_OS+#if mingw32_HOST_OS shGetFolderPath :: CInt -> IO (Maybe FilePath) shGetFolderPath n = # if __HUGS__
Distribution/Simple/LHC.hs view
@@ -241,7 +241,7 @@ -> IO PackageIndex getInstalledPackages verbosity packagedbs conf = do checkPackageDbStack packagedbs- pkgss <- getInstalledPackages' verbosity packagedbs conf+ pkgss <- getInstalledPackages' lhcPkg verbosity packagedbs conf let indexes = [ PackageIndex.fromList (map (substTopDir topDir) pkgs) | (_, pkgs) <- pkgss ] return $! (mconcat indexes)@@ -251,6 +251,7 @@ -- paths. We need to substitute the right value in so that when -- we, for example, call gcc, we have proper paths to give it Just ghcProg = lookupProgram lhcProgram conf+ Just lhcPkg = lookupProgram lhcPkgProgram conf compilerDir = takeDirectory (programPath ghcProg) topDir = takeDirectory compilerDir @@ -263,9 +264,10 @@ -- | Get the packages from specific PackageDBs, not cumulative. ---getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramConfiguration- -> IO [(PackageDB, [InstalledPackageInfo])]-getInstalledPackages' verbosity packagedbs conf+getInstalledPackages' :: ConfiguredProgram -> Verbosity+ -> [PackageDB] -> ProgramConfiguration+ -> IO [(PackageDB, [InstalledPackageInfo])]+getInstalledPackages' lhcPkg verbosity packagedbs conf = sequence [ do str <- rawSystemProgramStdoutConf verbosity lhcPkgProgram conf@@ -294,9 +296,15 @@ packageDbGhcPkgFlag GlobalPackageDB = "--global" packageDbGhcPkgFlag UserPackageDB = "--user"- packageDbGhcPkgFlag (SpecificPackageDB path) = "--package-conf=" ++ path+ packageDbGhcPkgFlag (SpecificPackageDB path) = "--" ++ packageDbFlag ++ "=" ++ path + packageDbFlag+ | programVersion lhcPkg < Just (Version [7,5] [])+ = "package-conf"+ | otherwise+ = "package-db" + substTopDir :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo substTopDir topDir ipo = ipo {@@ -607,7 +615,7 @@ -> FilePath -> [String] ghcOptions lbi bi clbi odir = ["-hide-all-packages"]- ++ ghcPackageDbOptions (withPackageDB lbi)+ ++ ghcPackageDbOptions lbi ++ (if splitObjs lbi then ["-split-objs"] else []) ++ ["-i"] ++ ["-i" ++ odir]@@ -643,17 +651,24 @@ where ghcVer = compilerVersion (compiler lbi) -ghcPackageDbOptions :: PackageDBStack -> [String]-ghcPackageDbOptions dbstack = case dbstack of+ghcPackageDbOptions :: LocalBuildInfo -> [String]+ghcPackageDbOptions lbi = case dbstack of (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs- (GlobalPackageDB:dbs) -> "-no-user-package-conf"+ (GlobalPackageDB:dbs) -> ("-no-user-" ++ packageDbFlag) : concatMap specific dbs _ -> ierror where- specific (SpecificPackageDB db) = [ "-package-conf", db ]+ specific (SpecificPackageDB db) = [ '-':packageDbFlag, db ] specific _ = ierror ierror = error ("internal error: unexpected package db stack: " ++ show dbstack) + dbstack = withPackageDB lbi+ packageDbFlag+ | compilerVersion (compiler lbi) < Version [7,5] []+ = "package-conf"+ | otherwise+ = "package-db"+ constructCcCmdLine :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> FilePath -> FilePath -> Verbosity -> (FilePath,[String]) constructCcCmdLine lbi bi clbi pref filename verbosity@@ -672,7 +687,7 @@ -> FilePath -> [String] ghcCcOptions lbi bi clbi odir = ["-I" ++ dir | dir <- PD.includeDirs bi]- ++ ghcPackageDbOptions (withPackageDB lbi)+ ++ ghcPackageDbOptions lbi ++ ghcPackageFlags lbi clbi ++ ["-optc" ++ opt | opt <- PD.ccOptions bi] ++ (case withOptimization lbi of
Distribution/Simple/LocalBuildInfo.hs view
@@ -52,6 +52,7 @@ -- * Buildable package components Component(..), foldComponent,+ componentBuildInfo, allComponentsBy, ComponentName(..), ComponentLocalBuildInfo(..),@@ -148,6 +149,8 @@ -- 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) where -- True if this dependency is an internal one (depends on the library -- defined in the same package).@@ -193,6 +196,10 @@ foldComponent _ f _ _ (CExe exe) = f exe foldComponent _ _ f _ (CTest tst) = f tst foldComponent _ _ _ f (CBench bch) = f bch++componentBuildInfo :: Component -> BuildInfo+componentBuildInfo =+ foldComponent libBuildInfo buildInfo testBuildInfo benchmarkBuildInfo -- | Obtains all components (libs, exes, or test suites), transformed by the -- given function. Useful for gathering dependencies with component context.
Distribution/Simple/PackageIndex.hs view
@@ -43,6 +43,7 @@ -- ** Bulk queries allPackages, allPackagesByName,+ allPackagesBySourcePackageId, -- ** Special queries brokenPackages,@@ -293,11 +294,22 @@ -- | Get all the packages from the index. ----- They are grouped by package name, case-sensitively.+-- They are grouped by package name (case-sensitively). ---allPackagesByName :: PackageIndex -> [[InstalledPackageInfo]]+allPackagesByName :: PackageIndex -> [(PackageName, [InstalledPackageInfo])] allPackagesByName (PackageIndex _ pnames) =- concatMap Map.elems (Map.elems pnames)+ [ (pkgname, concat (Map.elems pvers))+ | (pkgname, pvers) <- Map.toList pnames ]++-- | Get all the packages from the index.+--+-- They are grouped by source package id (package name and version).+--+allPackagesBySourcePackageId :: PackageIndex -> [(PackageId, [InstalledPackageInfo])]+allPackagesBySourcePackageId (PackageIndex _ pnames) =+ [ (packageId ipkg, ipkgs)+ | pvers <- Map.elems pnames+ , ipkgs@(ipkg:_) <- Map.elems pvers ] -- -- * Lookups
+ Distribution/Simple/Program/GHC.hs view
@@ -0,0 +1,456 @@+module Distribution.Simple.Program.GHC (+ GhcOptions(..),+ GhcMode(..),+ GhcOptimisation(..),++ ghcInvocation,+ renderGhcOptions,++ runGHC,++ ) where++import Distribution.Package+import Distribution.ModuleName+import Distribution.Simple.Compiler hiding (Flag)+import Distribution.Simple.Setup (Flag(..), flagToMaybe, fromFlagOrDefault, flagToList)+--import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.Program.Types+import Distribution.Simple.Program.Run+import Distribution.Text+import Distribution.Verbosity+import Distribution.Version+import Language.Haskell.Extension ( Language(..), Extension(..) )++import Data.Monoid+++-- | A structured set of GHC options/flags+--+data GhcOptions = GhcOptions {++ -- | The major mode for the ghc invocation.+ ghcOptMode :: Flag GhcMode,++ -- | Any extra options to pass directly to ghc. These go at the end and hence+ -- override other stuff.+ ghcOptExtra :: [String],++ -- | Extra default flags to pass directly to ghc. These go at the beginning+ -- and so can be overridden by other stuff.+ ghcOptExtraDefault :: [String],++ -----------------------+ -- Inputs and outputs++ -- | The main input files; could be .hs, .hi, .c, .o, depending on mode.+ ghcOptInputFiles :: [FilePath],++ -- | The names of input Haskell modules, mainly for @--make@ mode.+ ghcOptInputModules :: [ModuleName],++ -- | Location for output file; the @ghc -o@ flag.+ ghcOptOutputFile :: Flag FilePath,++ -- | Start with an empty search path for Haskell source files;+ -- the @ghc -i@ flag (@-i@ on it's own with no path argument).+ ghcOptSourcePathClear :: Flag Bool,++ -- | Search path for Haskell source files; the @ghc -i@ flag.+ ghcOptSourcePath :: [FilePath],++ -------------+ -- Packages++ -- | The package name the modules will belong to; the @ghc -package-name@ flag+ ghcOptPackageName :: Flag PackageId,++ -- | GHC package databases to use, the @ghc -package-conf@ flag+ ghcOptPackageDBs :: PackageDBStack,++ -- | The GHC packages to use. For compatability with old and new ghc, this+ -- requires both the short and long form of the package id;+ -- the @ghc -package@ or @ghc -package-id@ flags.+ ghcOptPackages :: [(InstalledPackageId, PackageId)],++ -- | Start with a clean package set; the @ghc -hide-all-packages@ flag+ ghcOptHideAllPackages :: Flag Bool,++ -- | Don't automatically link in Haskell98 etc; the @ghc -no-auto-link-packages@ flag.+ ghcOptNoAutoLinkPackages :: Flag Bool,++ -----------------+ -- Linker stuff++ -- | Names of libraries to link in; the @ghc -l@ flag.+ ghcOptLinkLibs :: [FilePath],++ -- | Search path for libraries to link in; the @ghc -L@ flag.+ ghcOptLinkLibPath :: [FilePath],++ -- | Options to pass through to the linker; the @ghc -optl@ flag.+ ghcOptLinkOptions :: [String],++ -- | OSX only: frameworks to link in; the @ghc -framework@ flag.+ ghcOptLinkFrameworks :: [String],++ -- | Don't do the link step, useful in make mode; the @ghc -no-link@ flag.+ ghcOptNoLink :: Flag Bool,++ --------------------+ -- C and CPP stuff++ -- | Options to pass through to the C compiler; the @ghc -optc@ flag.+ ghcOptCcOptions :: [String],++ -- | Options to pass through to CPP; the @ghc -optP@ flag.+ ghcOptCppOptions :: [String],++ -- | Search path for CPP includes like header files; the @ghc -I@ flag.+ ghcOptCppIncludePath :: [FilePath],++ -- | Extra header files to include at CPP stage; the @ghc -optP-include@ flag.+ ghcOptCppIncludes :: [FilePath],++ -- | Extra header files to include for old-style FFI; the @ghc -#include@ flag.+ ghcOptFfiIncludes :: [FilePath],++ ----------------------------+ -- Language and extensions++ -- | The base language; the @ghc -XHaskell98@ or @-XHaskell2010@ flag.+ ghcOptLanguage :: Flag Language,++ -- | The language extensions; the @ghc -X@ flag.+ ghcOptExtensions :: [Extension],++ -- | A GHC version-dependent mapping of extensions to flags. This must be+ -- set to be able to make use of the 'ghcOptExtensions'.+ ghcOptExtensionMap :: [(Extension, String)],++ ----------------+ -- Compilation++ -- | What optimisation level to use; the @ghc -O@ flag.+ ghcOptOptimisation :: Flag GhcOptimisation,++ -- | Compile in profiling mode; the @ghc -prof@ flag.+ ghcOptProfilingMode :: Flag Bool,++ -- | Use the \"split object files\" feature; the @ghc -split-objs@ flag.+ ghcOptSplitObjs :: Flag Bool,++ ----------------+ -- GHCi++ -- | Extra GHCi startup scripts; the @-ghci-script@ flag+ ghcOptGHCiScripts :: [FilePath],++ ------------------------+ -- Redirecting outputs++ ghcOptHiSuffix :: Flag String,+ ghcOptObjSuffix :: Flag String,+ ghcOptHiDir :: Flag FilePath,+ ghcOptObjDir :: Flag FilePath,+ ghcOptStubDir :: Flag FilePath,++ --------------------+ -- Dynamic linking++ ghcOptDynamic :: Flag Bool,+ ghcOptShared :: Flag Bool,+ ghcOptFPic :: Flag Bool,+ ghcOptDylibName :: Flag String,++ ---------------+ -- Misc flags++ -- | Get GHC to be quiet or verbose with what it's doing; the @ghc -v@ flag.+ ghcOptVerbosity :: Flag Verbosity,++ -- | Let GHC know that it is Cabal that's calling it.+ -- Modifies some of the GHC error messages.+ ghcOptCabal :: Flag Bool++} deriving Show+++data GhcMode = GhcModeCompile -- ^ @ghc -c@+ | GhcModeLink -- ^ @ghc@+ | GhcModeMake -- ^ @ghc --make@+ | GhcModeInteractive -- ^ @ghci@ \/ @ghc --interactive@+ | GhcModeAbiHash -- ^ @ghc --abi-hash@+-- | GhcModeDepAnalysis -- ^ @ghc -M@+-- | GhcModeEvaluate -- ^ @ghc -e@+ deriving (Show, Eq)++data GhcOptimisation = GhcNoOptimisation -- ^ @-O0@+ | GhcNormalOptimisation -- ^ @-O@+ | GhcMaximumOptimisation -- ^ @-O2@+ | GhcSpecialOptimisation String -- ^ e.g. @-Odph@+ deriving (Show, Eq)+++runGHC :: Verbosity -> ConfiguredProgram -> GhcOptions -> IO ()+runGHC verbosity ghcProg opts = do+ runProgramInvocation verbosity (ghcInvocation ghcProg opts)+++ghcInvocation :: ConfiguredProgram -> GhcOptions -> ProgramInvocation+ghcInvocation ConfiguredProgram { programVersion = Nothing } _ =+ error "ghcInvocation: the programVersion must not be Nothing"+ghcInvocation prog@ConfiguredProgram { programVersion = Just ver } opts =+ programInvocation prog (renderGhcOptions ver opts)+++renderGhcOptions :: Version -> GhcOptions -> [String]+renderGhcOptions version@(Version ver _) opts =+ concat+ [ case flagToMaybe (ghcOptMode opts) of+ Nothing -> []+ Just GhcModeCompile -> ["-c"]+ Just GhcModeLink -> []+ Just GhcModeMake -> ["--make"]+ Just GhcModeInteractive -> ["--interactive"]+ Just GhcModeAbiHash -> ["--abi-hash"]+-- Just GhcModeDepAnalysis -> ["-M"]+-- Just GhcModeEvaluate -> ["-e", expr]++ , flags ghcOptExtraDefault++ , [ "-no-link" | flagBool ghcOptNoLink ]++ ---------------+ -- Misc flags++ , maybe [] verbosityOpts (flagToMaybe (ghcOptVerbosity opts))++ , [ "-fbuilding-cabal-package" | flagBool ghcOptCabal, ver >= [6,11] ]++ ----------------+ -- Compilation++ , case flagToMaybe (ghcOptOptimisation opts) of+ Nothing -> []+ Just GhcNoOptimisation -> ["-O0"]+ Just GhcNormalOptimisation -> ["-O"]+ Just GhcMaximumOptimisation -> ["-O2"]+ Just (GhcSpecialOptimisation s) -> ["-O" ++ s] -- eg -Odph++ , [ "-prof" | flagBool ghcOptProfilingMode ]++ , [ "-split-objs" | flagBool ghcOptSplitObjs ]++ --------------------+ -- Dynamic linking++ , [ "-shared" | flagBool ghcOptShared ]+ , [ "-dynamic" | flagBool ghcOptDynamic ]+ , [ "-fPIC" | flagBool ghcOptFPic ]++ , concat [ ["-dylib-install-name", libname] | libname <- flag ghcOptDylibName ]++ ------------------------+ -- Redirecting outputs++ , concat [ ["-osuf", suf] | suf <- flag ghcOptObjSuffix ]+ , concat [ ["-hisuf", suf] | suf <- flag ghcOptHiSuffix ]+ , concat [ ["-odir", dir] | dir <- flag ghcOptObjDir ]+ , concat [ ["-hidir", dir] | dir <- flag ghcOptHiDir ]+ , concat [ ["-stubdir", dir] | dir <- flag ghcOptStubDir, ver >= [6,8] ]++ -----------------------+ -- Source search path++ , [ "-i" | flagBool ghcOptSourcePathClear ]+ , [ "-i" ++ dir | dir <- flags ghcOptSourcePath ]++ --------------------+ -- C and CPP stuff++ , [ "-I" ++ dir | dir <- flags ghcOptCppIncludePath ]+ , [ "-optP" ++ opt | opt <- flags ghcOptCppOptions ]+ , concat [ [ "-optP-include", "-optP" ++ inc] | inc <- flags ghcOptCppIncludes ]+ , [ "-#include \"" ++ inc ++ "\"" | inc <- flags ghcOptFfiIncludes, ver < [6,11] ]+ , [ "-optc" ++ opt | opt <- flags ghcOptCcOptions ]++ -----------------+ -- Linker stuff++ , [ "-optl" ++ opt | opt <- flags ghcOptLinkOptions ]+ , ["-l" ++ lib | lib <- flags ghcOptLinkLibs ]+ , ["-L" ++ dir | dir <- flags ghcOptLinkLibPath ]+ , concat [ ["-framework", fmwk] | fmwk <- flags ghcOptLinkFrameworks ]++ -------------+ -- Packages++ , concat [ ["-package-name", display pkgid] | pkgid <- flag ghcOptPackageName ]++ , [ "-hide-all-packages" | flagBool ghcOptHideAllPackages ]+ , [ "-no-auto-link-packages" | flagBool ghcOptNoAutoLinkPackages ]++ , packageDbArgs version (flags ghcOptPackageDBs)++ , concat $ if ver >= [6,11]+ then [ ["-package-id", display ipkgid] | (ipkgid,_) <- flags ghcOptPackages ]+ else [ ["-package", display pkgid] | (_,pkgid) <- flags ghcOptPackages ]++ ----------------------------+ -- Language and extensions++ , [ "-X" ++ display lang | lang <- flag ghcOptLanguage ]++ , [ case lookup ext (ghcOptExtensionMap opts) of+ Just arg -> arg+ Nothing -> error $ "renderGhcOptions: " ++ display ext+ ++ " not present in ghcOptExtensionMap."+ | ext <- ghcOptExtensions opts ]++ ----------------+ -- GHCi++ , concat [ [ "-ghci-script", script ] | script <- flags ghcOptGHCiScripts+ , ver >= [7,2] ]++ ---------------+ -- Inputs++ , [ display modu | modu <- flags ghcOptInputModules ]+ , ghcOptInputFiles opts++ , concat [ [ "-o", out] | out <- flag ghcOptOutputFile ]++ ---------------+ -- Extra++ , ghcOptExtra opts++ ]+++ where+ flag flg = flagToList (flg opts)+ flags flg = flg opts+ flagBool flg = fromFlagOrDefault False (flg opts)+++verbosityOpts :: Verbosity -> [String]+verbosityOpts verbosity+ | verbosity >= deafening = ["-v"]+ | verbosity >= normal = []+ | otherwise = ["-w", "-v0"]+++packageDbArgs :: Version -> PackageDBStack -> [String]+packageDbArgs (Version ver _) dbstack = case dbstack of+ (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs+ (GlobalPackageDB:dbs) -> ("-no-user-" ++ packageDbFlag)+ : concatMap specific dbs+ _ -> ierror+ where+ specific (SpecificPackageDB db) = [ '-':packageDbFlag , db ]+ specific _ = ierror+ ierror = error $ "internal error: unexpected package db stack: "+ ++ show dbstack++ packageDbFlag+ | ver < [7,5]+ = "package-conf"+ | otherwise+ = "package-db"+++-- -----------------------------------------------------------------------------+-- Boilerplate Monoid instance for GhcOptions++instance Monoid GhcOptions where+ mempty = GhcOptions {+ ghcOptMode = mempty,+ ghcOptExtra = mempty,+ ghcOptExtraDefault = mempty,+ ghcOptInputFiles = mempty,+ ghcOptInputModules = mempty,+ ghcOptOutputFile = mempty,+ ghcOptSourcePathClear = mempty,+ ghcOptSourcePath = mempty,+ ghcOptPackageName = mempty,+ ghcOptPackageDBs = mempty,+ ghcOptPackages = mempty,+ ghcOptHideAllPackages = mempty,+ ghcOptNoAutoLinkPackages = mempty,+ ghcOptLinkLibs = mempty,+ ghcOptLinkLibPath = mempty,+ ghcOptLinkOptions = mempty,+ ghcOptLinkFrameworks = mempty,+ ghcOptNoLink = mempty,+ ghcOptCcOptions = mempty,+ ghcOptCppOptions = mempty,+ ghcOptCppIncludePath = mempty,+ ghcOptCppIncludes = mempty,+ ghcOptFfiIncludes = mempty,+ ghcOptLanguage = mempty,+ ghcOptExtensions = mempty,+ ghcOptExtensionMap = mempty,+ ghcOptOptimisation = mempty,+ ghcOptProfilingMode = mempty,+ ghcOptSplitObjs = mempty,+ ghcOptGHCiScripts = mempty,+ ghcOptHiSuffix = mempty,+ ghcOptObjSuffix = mempty,+ ghcOptHiDir = mempty,+ ghcOptObjDir = mempty,+ ghcOptStubDir = mempty,+ ghcOptDynamic = mempty,+ ghcOptShared = mempty,+ ghcOptFPic = mempty,+ ghcOptDylibName = mempty,+ ghcOptVerbosity = mempty,+ ghcOptCabal = mempty+ }+ mappend a b = GhcOptions {+ ghcOptMode = combine ghcOptMode,+ ghcOptExtra = combine ghcOptExtra,+ ghcOptExtraDefault = combine ghcOptExtraDefault,+ ghcOptInputFiles = combine ghcOptInputFiles,+ ghcOptInputModules = combine ghcOptInputModules,+ ghcOptOutputFile = combine ghcOptOutputFile,+ ghcOptSourcePathClear = combine ghcOptSourcePathClear,+ ghcOptSourcePath = combine ghcOptSourcePath,+ ghcOptPackageName = combine ghcOptPackageName,+ ghcOptPackageDBs = combine ghcOptPackageDBs,+ ghcOptPackages = combine ghcOptPackages,+ ghcOptHideAllPackages = combine ghcOptHideAllPackages,+ ghcOptNoAutoLinkPackages = combine ghcOptNoAutoLinkPackages,+ ghcOptLinkLibs = combine ghcOptLinkLibs,+ ghcOptLinkLibPath = combine ghcOptLinkLibPath,+ ghcOptLinkOptions = combine ghcOptLinkOptions,+ ghcOptLinkFrameworks = combine ghcOptLinkFrameworks,+ ghcOptNoLink = combine ghcOptNoLink,+ ghcOptCcOptions = combine ghcOptCcOptions,+ ghcOptCppOptions = combine ghcOptCppOptions,+ ghcOptCppIncludePath = combine ghcOptCppIncludePath,+ ghcOptCppIncludes = combine ghcOptCppIncludes,+ ghcOptFfiIncludes = combine ghcOptFfiIncludes,+ ghcOptLanguage = combine ghcOptLanguage,+ ghcOptExtensions = combine ghcOptExtensions,+ ghcOptExtensionMap = combine ghcOptExtensionMap,+ ghcOptOptimisation = combine ghcOptOptimisation,+ ghcOptProfilingMode = combine ghcOptProfilingMode,+ ghcOptSplitObjs = combine ghcOptSplitObjs,+ ghcOptGHCiScripts = combine ghcOptGHCiScripts,+ ghcOptHiSuffix = combine ghcOptHiSuffix,+ ghcOptObjSuffix = combine ghcOptObjSuffix,+ ghcOptHiDir = combine ghcOptHiDir,+ ghcOptObjDir = combine ghcOptObjDir,+ ghcOptStubDir = combine ghcOptStubDir,+ ghcOptDynamic = combine ghcOptDynamic,+ ghcOptShared = combine ghcOptShared,+ ghcOptFPic = combine ghcOptFPic,+ ghcOptDylibName = combine ghcOptDylibName,+ ghcOptVerbosity = combine ghcOptVerbosity,+ ghcOptCabal = combine ghcOptCabal+ }+ where+ combine field = field a `mappend` field b
Distribution/Simple/Program/HcPkg.hs view
@@ -64,7 +64,7 @@ -- | Call @hc-pkg@ to register a package. ----- > hc-pkg register {filename | -} [--user | --global | --package-conf]+-- > hc-pkg register {filename | -} [--user | --global | --package-db] -- register :: Verbosity -> ConfiguredProgram -> PackageDBStack -> Either FilePath@@ -77,7 +77,7 @@ -- | Call @hc-pkg@ to re-register a package. ----- > hc-pkg register {filename | -} [--user | --global | --package-conf]+-- > hc-pkg register {filename | -} [--user | --global | --package-db] -- reregister :: Verbosity -> ConfiguredProgram -> PackageDBStack -> Either FilePath@@ -90,7 +90,7 @@ -- | Call @hc-pkg@ to unregister a package ----- > hc-pkg unregister [pkgid] [--user | --global | --package-conf]+-- > hc-pkg unregister [pkgid] [--user | --global | --package-db] -- unregister :: Verbosity -> ConfiguredProgram -> PackageDB -> PackageId -> IO () unregister verbosity hcPkg packagedb pkgid =@@ -100,7 +100,7 @@ -- | Call @hc-pkg@ to expose a package. ----- > hc-pkg expose [pkgid] [--user | --global | --package-conf]+-- > hc-pkg expose [pkgid] [--user | --global | --package-db] -- expose :: Verbosity -> ConfiguredProgram -> PackageDB -> PackageId -> IO () expose verbosity hcPkg packagedb pkgid =@@ -110,7 +110,7 @@ -- | Call @hc-pkg@ to expose a package. ----- > hc-pkg expose [pkgid] [--user | --global | --package-conf]+-- > hc-pkg expose [pkgid] [--user | --global | --package-db] -- hide :: Verbosity -> ConfiguredProgram -> PackageDB -> PackageId -> IO () hide verbosity hcPkg packagedb pkgid =@@ -245,8 +245,8 @@ where args = [cmdname, pkgFile] ++ (if legacyVersion hcPkg- then [packageDbOpts (last packagedbs)]- else packageDbStackOpts packagedbs)+ then [packageDbOpts hcPkg (last packagedbs)]+ else packageDbStackOpts hcPkg packagedbs) ++ verbosityOpts hcPkg verbosity registerInvocation' cmdname hcPkg verbosity packagedbs (Right pkgInfo) =@@ -257,8 +257,8 @@ where args = [cmdname, "-"] ++ (if legacyVersion hcPkg- then [packageDbOpts (last packagedbs)]- else packageDbStackOpts packagedbs)+ then [packageDbOpts hcPkg (last packagedbs)]+ else packageDbStackOpts hcPkg packagedbs) ++ verbosityOpts hcPkg verbosity @@ -267,7 +267,7 @@ -> ProgramInvocation unregisterInvocation hcPkg verbosity packagedb pkgid = programInvocation hcPkg $- ["unregister", packageDbOpts packagedb, display pkgid]+ ["unregister", packageDbOpts hcPkg packagedb, display pkgid] ++ verbosityOpts hcPkg verbosity @@ -275,7 +275,7 @@ -> Verbosity -> PackageDB -> PackageId -> ProgramInvocation exposeInvocation hcPkg verbosity packagedb pkgid = programInvocation hcPkg $- ["expose", packageDbOpts packagedb, display pkgid]+ ["expose", packageDbOpts hcPkg packagedb, display pkgid] ++ verbosityOpts hcPkg verbosity @@ -283,7 +283,7 @@ -> Verbosity -> PackageDB -> PackageId -> ProgramInvocation hideInvocation hcPkg verbosity packagedb pkgid = programInvocation hcPkg $- ["hide", packageDbOpts packagedb, display pkgid]+ ["hide", packageDbOpts hcPkg packagedb, display pkgid] ++ verbosityOpts hcPkg verbosity @@ -294,31 +294,38 @@ progInvokeOutputEncoding = IOEncodingUTF8 } where- args = ["dump", packageDbOpts packagedb]+ args = ["dump", packageDbOpts hcPkg packagedb] ++ verbosityOpts hcPkg silent -- We use verbosity level 'silent' because it is important that we -- do not contaminate the output with info/debug messages. -packageDbStackOpts :: PackageDBStack -> [String]-packageDbStackOpts dbstack = case dbstack of+packageDbStackOpts :: ConfiguredProgram -> PackageDBStack -> [String]+packageDbStackOpts hcPkg dbstack = case dbstack of (GlobalPackageDB:UserPackageDB:dbs) -> "--global" : "--user" : map specific dbs (GlobalPackageDB:dbs) -> "--global"- : "--no-user-package-conf"+ : ("--no-user-" ++ packageDbFlag hcPkg) : map specific dbs _ -> ierror where- specific (SpecificPackageDB db) = "--package-conf=" ++ db+ specific (SpecificPackageDB db) = "--" ++ packageDbFlag hcPkg ++ "=" ++ db specific _ = ierror ierror :: a ierror = error ("internal error: unexpected package db stack: " ++ show dbstack) -packageDbOpts :: PackageDB -> String-packageDbOpts GlobalPackageDB = "--global"-packageDbOpts UserPackageDB = "--user"-packageDbOpts (SpecificPackageDB db) = "--package-conf=" ++ db+packageDbFlag :: ConfiguredProgram -> String+packageDbFlag hcPkg+ | programVersion hcPkg < Just (Version [7,5] [])+ = "package-conf"+ | otherwise+ = "package-db"++packageDbOpts :: ConfiguredProgram -> PackageDB -> String+packageDbOpts _ GlobalPackageDB = "--global"+packageDbOpts _ UserPackageDB = "--user"+packageDbOpts hcPkg (SpecificPackageDB db) = "--" ++ packageDbFlag hcPkg ++ "=" ++ db verbosityOpts :: ConfiguredProgram -> Verbosity -> [String] verbosityOpts hcPkg v
Distribution/Simple/Register.hs view
@@ -212,7 +212,10 @@ -> PackageDBStack -> IO () registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs = do- setupMessage verbosity "Registering" (packageId pkg)+ let msg = if inplace+ then "In-place registering"+ else "Registering"+ setupMessage verbosity msg (packageId pkg) case compilerFlavor (compiler lbi) of GHC -> GHC.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs LHC -> LHC.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs@@ -317,9 +320,10 @@ -> ComponentLocalBuildInfo -> InstalledPackageInfo inplaceInstalledPackageInfo inplaceDir distPref pkg lib lbi clbi =- generalInstalledPackageInfo adjustReativeIncludeDirs pkg lib clbi installDirs+ generalInstalledPackageInfo adjustRelativeIncludeDirs pkg lib clbi+ installDirs where- adjustReativeIncludeDirs = map (inplaceDir </>)+ adjustRelativeIncludeDirs = map (inplaceDir </>) installDirs = (absoluteInstallDirs pkg lbi NoCopyDest) { libdir = inplaceDir </> buildDir lbi,
Distribution/Simple/Setup.hs view
@@ -285,7 +285,7 @@ configDistPref :: Flag FilePath, -- ^"dist" prefix configVerbosity :: Flag Verbosity, -- ^verbosity level configUserInstall :: Flag Bool, -- ^The --user\/--global flag- configPackageDB :: Flag PackageDB, -- ^Which package DB to use+ configPackageDBs :: [Maybe PackageDB], -- ^Which package DBs to use configGHCiLib :: Flag Bool, -- ^Enable compiling library for GHCi configSplitObjs :: Flag Bool, -- ^Enable -split-objs with GHC configStripExes :: Flag Bool, -- ^Enable executable stripping@@ -446,12 +446,9 @@ (boolOpt' ([],["user"]) ([], ["global"])) ,option "" ["package-db"]- "Use a specific package database (to satisfy dependencies and register in)"- configPackageDB (\v flags -> flags { configPackageDB = v })- (reqArg' "PATH" (Flag . SpecificPackageDB)- (\f -> case f of- Flag (SpecificPackageDB db) -> [db]- _ -> []))+ "Use a given package database (to satisfy dependencies and register in). May be a specific file, 'global', 'user' or 'clear'."+ configPackageDBs (\v flags -> flags { configPackageDBs = v })+ (reqArg' "DB" readPackageDbList showPackageDbList) ,option "f" ["flags"] "Force values for the given flags in Cabal conditionals in the .cabal file. E.g., --flags=\"debug -usebytestrings\" forces the flag \"debug\" to true and \"usebytestrings\" to false."@@ -496,6 +493,20 @@ 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 }) @@ -585,7 +596,7 @@ configDistPref = mempty, configVerbosity = mempty, configUserInstall = mempty,- configPackageDB = mempty,+ configPackageDBs = mempty, configGHCiLib = mempty, configSplitObjs = mempty, configStripExes = mempty,@@ -618,7 +629,7 @@ configDistPref = combine configDistPref, configVerbosity = combine configVerbosity, configUserInstall = combine configUserInstall,- configPackageDB = combine configPackageDB,+ configPackageDBs = combine configPackageDBs, configGHCiLib = combine configGHCiLib, configSplitObjs = combine configSplitObjs, configStripExes = combine configStripExes,
Distribution/Simple/Test.hs view
@@ -42,13 +42,13 @@ module Distribution.Simple.Test ( test- , runTests+ , stubMain , writeSimpleTestStub , stubFilePath , stubName , PackageLog(..) , TestSuiteLog(..)- , Case(..)+ , TestLogs(..) , suitePassed, suiteFailed, suiteError ) where @@ -72,16 +72,17 @@ ( LocalBuildInfo(..) ) import Distribution.Simple.Setup ( TestFlags(..), TestShowDetails(..), fromFlag ) import Distribution.Simple.Utils ( die, notice )-import qualified Distribution.TestSuite as TestSuite- ( Test, Result(..), ImpureTestable(..), TestOptions(..), Options(..) )+import Distribution.TestSuite+ ( OptionDescr(..), Options, Progress(..), Result(..), TestInstance(..)+ , Test(..) ) import Distribution.Text import Distribution.Verbosity ( normal, Verbosity ) import Distribution.System ( buildPlatform, Platform ) import Control.Exception ( bracket )-import Control.Monad ( when, liftM, unless, filterM )+import Control.Monad ( when, unless, filterM ) import Data.Char ( toUpper )-import Data.Monoid ( mempty )+import Data.Maybe ( mapMaybe ) import System.Directory ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist , getCurrentDirectory, getDirectoryContents, removeDirectoryRecursive@@ -113,40 +114,55 @@ -- | Logs test suite results, itemized by test case. data TestSuiteLog = TestSuiteLog- { name :: String- , cases :: [Case]+ { testSuiteName :: String+ , testLogs :: TestLogs , logFile :: FilePath -- path to human-readable log file } deriving (Read, Show, Eq) -data Case = Case- { caseName :: String- , caseOptions :: TestSuite.Options- , caseResult :: TestSuite.Result- }+data TestLogs+ = TestLog+ { testName :: String+ , testOptionsReturned :: Options+ , testResult :: Result+ }+ | GroupLogs String [TestLogs] deriving (Read, Show, Eq) -getTestOptions :: TestSuite.Test -> TestSuiteLog -> IO TestSuite.Options-getTestOptions t l =- case filter ((== TestSuite.name t) . caseName) (cases l) of- (x:_) -> return $ caseOptions x- _ -> TestSuite.defaultOptions t+-- | Count the number of pass, fail, and error test results in a 'TestLogs'+-- tree.+countTestResults :: TestLogs+ -> (Int, Int, Int) -- ^ Passes, fails, and errors,+ -- respectively.+countTestResults = go (0, 0, 0)+ where+ go (p, f, e) (TestLog { testResult = r }) =+ case r of+ Pass -> (p + 1, f, e)+ Fail _ -> (p, f + 1, e)+ Error _ -> (p, f, e + 1)+ go (p, f, e) (GroupLogs _ ts) = foldl go (p, f, e) ts -- | From a 'TestSuiteLog', determine if the test suite passed. suitePassed :: TestSuiteLog -> Bool-suitePassed = all (== TestSuite.Pass) . map caseResult . cases+suitePassed l =+ case countTestResults (testLogs l) of+ (_, 0, 0) -> True+ _ -> False -- | From a 'TestSuiteLog', determine if the test suite failed. suiteFailed :: TestSuiteLog -> Bool-suiteFailed = any isFail . map caseResult . cases- where isFail (TestSuite.Fail _) = True- isFail _ = False+suiteFailed l =+ case countTestResults (testLogs l) of+ (_, 0, _) -> False+ _ -> True -- | From a 'TestSuiteLog', determine if the test suite encountered errors. suiteError :: TestSuiteLog -> Bool-suiteError = any isError . map caseResult . cases- where isError (TestSuite.Error _) = True- isError _ = False+suiteError l =+ case countTestResults (testLogs l) of+ (_, _, 0) -> False+ _ -> True -- | Run a test executable, logging the output and generating the appropriate -- summary messages.@@ -170,7 +186,7 @@ let distPref = fromFlag $ testDistPref flags verbosity = fromFlag $ testVerbosity flags testLogDir = distPref </> "test"- options = map (testOption pkg_descr lbi suite) $ testOptions flags+ opts = map (testOption pkg_descr lbi suite) $ testOptions flags pwd <- getCurrentDirectory existingEnv <- getEnvironment@@ -191,8 +207,8 @@ -- Remove old .tix files if appropriate. unless (fromFlag $ testKeepTix flags) $ do let tDir = tixDir distPref $ PD.testName suite- exists <- doesDirectoryExist tDir- when exists $ removeDirectoryRecursive tDir+ exists' <- doesDirectoryExist tDir+ when exists' $ removeDirectoryRecursive tDir -- Create directory for HPC files. createDirectoryIfMissing True $ tixDir distPref $ PD.testName suite@@ -208,7 +224,7 @@ hLog <- openFile tempLog AppendMode hIn <- openFile tempInput ReadMode -- these handles get closed by runProcess- proc <- runProcess cmd options Nothing shellEnv+ proc <- runProcess cmd opts Nothing shellEnv (Just hIn) (Just hLog) (Just hLog) waitForProcess proc @@ -274,7 +290,7 @@ , PD.buildable (PD.testBuildInfo t) ] doTest :: (PD.TestSuite, Maybe TestSuiteLog) -> IO TestSuiteLog- doTest (suite, mLog) = do+ doTest (suite, _) = do let testLogPath = testSuiteLogPath humanTemplate pkg_descr lbi go pre cmd post = testController flags pkg_descr lbi suite pre cmd post testLogPath@@ -285,12 +301,16 @@ preTest _ = "" postTest exit _ = let r = case exit of- ExitSuccess -> TestSuite.Pass- ExitFailure c -> TestSuite.Fail+ ExitSuccess -> Pass+ ExitFailure c -> Fail $ "exit code: " ++ show c in TestSuiteLog- { name = PD.testName suite- , cases = [Case (PD.testName suite) mempty r]+ { testSuiteName = PD.testName suite+ , testLogs = TestLog+ { testName = PD.testName suite+ , testOptionsReturned = []+ , testResult = r+ } , logFile = "" } go preTest cmd postTest@@ -298,23 +318,21 @@ PD.TestSuiteLibV09 _ _ -> do let cmd = LBI.buildDir lbi </> stubName suite </> stubName suite <.> exeExtension- oldLog = case mLog of- Nothing -> TestSuiteLog- { name = PD.testName suite- , cases = []- , logFile = []- }- Just l -> l- preTest f = show $ oldLog { logFile = f }+ preTest f = show ( f+ , PD.testName suite+ ) postTest _ = read go preTest cmd postTest _ -> return TestSuiteLog- { name = PD.testName suite- , cases = [Case (PD.testName suite) mempty- $ TestSuite.Error $ "No support for running "- ++ "test suite type: "- ++ show (disp $ PD.testType suite)]+ { testSuiteName = PD.testName suite+ , testLogs = TestLog+ { testName = PD.testName suite+ , testOptionsReturned = []+ , testResult = Error $+ "No support for running test suite type: "+ ++ show (disp $ PD.testType suite)+ } , logFile = "" } @@ -365,30 +383,33 @@ -- all test suites passed and 'False' otherwise. summarizePackage :: Verbosity -> PackageLog -> IO Bool summarizePackage verbosity packageLog = do- let cases' = map caseResult $ concatMap cases $ testSuites packageLog- passedCases = length $ filter (== TestSuite.Pass) cases'- totalCases = length cases'+ let counts = map (countTestResults . testLogs) $ testSuites packageLog+ (passed, failed, errors) = foldl1 addTriple counts+ totalCases = passed + failed + errors passedSuites = length $ filter suitePassed $ testSuites packageLog totalSuites = length $ testSuites packageLog notice verbosity $ show passedSuites ++ " of " ++ show totalSuites- ++ " test suites (" ++ show passedCases ++ " of "+ ++ " test suites (" ++ show passed ++ " of " ++ show totalCases ++ " test cases) passed." return $! passedSuites == totalSuites+ where+ addTriple (p1, f1, e1) (p2, f2, e2) = (p1 + p2, f1 + f2, e1 + e2) -- | Print a summary of a single test case's result to the console, supressing -- output for certain verbosity or test filter levels.-summarizeCase :: Verbosity -> TestShowDetails -> Case -> IO ()-summarizeCase verbosity details t =- when shouldPrint $ notice verbosity $ "Test case " ++ caseName t- ++ ": " ++ show (caseResult t)+summarizeTest :: Verbosity -> TestShowDetails -> TestLogs -> IO ()+summarizeTest _ _ (GroupLogs {}) = return ()+summarizeTest verbosity details t =+ when shouldPrint $ notice verbosity $ "Test case " ++ testName t+ ++ ": " ++ show (testResult t) where shouldPrint = (details > Never) && (notPassed || details == Always)- notPassed = caseResult t /= TestSuite.Pass+ notPassed = testResult t /= Pass -- | Print a summary of the test suite's results on the console, suppressing -- output for certain verbosity or test filter levels. summarizeSuiteFinish :: TestSuiteLog -> String summarizeSuiteFinish testLog = unlines- [ "Test suite " ++ name testLog ++ ": " ++ resStr+ [ "Test suite " ++ testSuiteName testLog ++ ": " ++ resStr , "Test suite logged to: " ++ logFile testLog ] where resStr = map toUpper (resultString testLog)@@ -411,7 +432,7 @@ where env = initialPathTemplateEnv (PD.package pkg_descr) (compilerId $ LBI.compiler lbi)- ++ [ (TestSuiteNameVar, toPathTemplate $ name testLog)+ ++ [ (TestSuiteNameVar, toPathTemplate $ testSuiteName testLog) , (TestSuiteResultVar, result) ] result = toPathTemplate $ resultString testLog@@ -465,13 +486,20 @@ simpleTestStub :: ModuleName -> String simpleTestStub m = unlines [ "module Main ( main ) where"- , "import Control.Monad ( liftM )"- , "import Distribution.Simple.Test ( runTests )"+ , "import Distribution.Simple.Test ( stubMain )" , "import " ++ show (disp m) ++ " ( tests )" , "main :: IO ()"- , "main = runTests tests"+ , "main = stubMain tests" ] +-- | Main function for test stubs. Once, it was written directly into the stub,+-- but minimizing the amount of code actually in the stub maximizes the number+-- of detectable errors when Cabal is compiled.+stubMain :: IO [Test] -> IO ()+stubMain tests = do+ (f, n) <- fmap read getContents+ tests >>= stubRunTests >>= stubWriteLog f n+ -- | The test runner used in library "TestSuite" stub executables. Runs a list -- of 'Test's. An executable calling this function is meant to be invoked as -- the child of a Cabal process during @.\/setup test@. A 'TestSuiteLog',@@ -479,23 +507,38 @@ -- the test suite and the location of the machine-readable test suite log file. -- Human-readable log information is written to the standard output for capture -- by the calling Cabal process.-runTests :: [TestSuite.Test] -> IO ()-runTests tests = do- testLogIn <- liftM read getContents- let go :: TestSuite.Test -> IO Case- go t = do- o <- getTestOptions t testLogIn- r <- TestSuite.runM t o- let ret = Case- { caseName = TestSuite.name t- , caseOptions = o- , caseResult = r- }- summarizeCase normal Always ret- return ret- cases' <- mapM go tests- let testLog = testLogIn { cases = cases'}+stubRunTests :: [Test] -> IO TestLogs+stubRunTests tests = do+ logs <- mapM stubRunTests' tests+ return $ GroupLogs "Default" logs+ where+ stubRunTests' (Test t) = do+ l <- run t >>= finish+ summarizeTest normal Always l+ return l+ where+ finish (Finished result) =+ return TestLog+ { testName = name t+ , testOptionsReturned = defaultOptions t+ , testResult = result+ }+ finish (Progress _ next) = next >>= finish+ stubRunTests' g@(Group {}) = do+ logs <- mapM stubRunTests' $ groupTests g+ return $ GroupLogs (groupName g) logs+ stubRunTests' (ExtraOptions _ t) = stubRunTests' t+ maybeDefaultOption opt =+ maybe Nothing (\d -> Just (optionName opt, d)) $ optionDefault opt+ defaultOptions testInst = mapMaybe maybeDefaultOption $ options testInst++-- | From a test stub, write the 'TestSuiteLog' to temporary file for the calling+-- Cabal process to read.+stubWriteLog :: FilePath -> String -> TestLogs -> IO ()+stubWriteLog f n logs = do+ let testLog = TestSuiteLog { testSuiteName = n, testLogs = logs, logFile = f } writeFile (logFile testLog) $ show testLog when (suiteError testLog) $ exitWith $ ExitFailure 2 when (suiteFailed testLog) $ exitWith $ ExitFailure 1 exitWith ExitSuccess+
Distribution/TestSuite.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP, ExistentialQuantification #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.TestSuite@@ -40,271 +39,87 @@ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} -#if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 610))-#define NEW_EXCEPTION-#endif- module Distribution.TestSuite- ( -- * Example- -- $example- -- * Options- Options(..)- , lookupOption- , TestOptions(..)- -- * Tests- , Test- , pure, impure+ ( TestInstance(..)+ , OptionDescr(..)+ , OptionType(..)+ , Test(..)+ , Options+ , Progress(..) , Result(..)- , ImpureTestable(..)- , PureTestable(..)+ , testGroup ) where -#ifdef NEW_EXCEPTION-import Control.Exception ( evaluate, catch, throw, SomeException, fromException )-#else-import Control.Exception ( evaluate, catch, throw, Exception(IOException) )-#endif----TODO: it is totally unreasonable that we have to import things from GHC.* here.--- see ghc ticket #3517-#ifdef __GLASGOW_HASKELL__-#if __GLASGOW_HASKELL__ >= 612-import GHC.IO.Exception ( IOErrorType(Interrupted) )-#else-import GHC.IOBase ( IOErrorType(Interrupted) )-#endif-import System.IO.Error ( ioeGetErrorType )-#endif--import Data.List ( unionBy )-import Data.Monoid ( Monoid(..) )-import Data.Typeable ( TypeRep )-import Prelude hiding ( catch )---- | 'Options' are provided to pass options to test runners, making tests--- reproducable. Each option is a @('String', 'String')@ of the form--- @(Name, Value)@. Use 'mappend' to combine sets of 'Options'; if the same--- option is given different values, the value from the left argument of--- 'mappend' will be used.-newtype Options = Options [(String, String)]- deriving (Read, Show, Eq)--instance Monoid Options where- mempty = Options []- mappend (Options a) (Options b) = Options $ unionBy (equating fst) a b- where- equating p x y = p x == p y---class TestOptions t where- -- | The name of the test.- name :: t -> String-- -- | A list of the options a test recognizes. The name and 'TypeRep' are- -- provided so that test agents can ensure that user-specified options are- -- correctly typed.- options :: t -> [(String, TypeRep)]-- -- | The default options for a test. Test frameworks should provide a new- -- random seed, if appropriate.- defaultOptions :: t -> IO Options-- -- | Try to parse the provided options. Return the names of unparsable- -- options. This allows test agents to detect bad user-specified options.- check :: t -> Options -> [String]---- | Read an option from the specified set of 'Options'. It is an error to--- lookup an option that has not been specified. For this reason, test agents--- should 'mappend' any 'Options' against the 'defaultOptions' for a test, so--- the default value specified by the test framework will be used for any--- otherwise-unspecified options.-lookupOption :: Read r => String -> Options -> r-lookupOption n (Options opts) =- case lookup n opts of- Just str -> read str- Nothing -> error $ "test option not specified: " ++ n--data Result- = Pass -- ^ indicates a successful test- | Fail String -- ^ indicates a test completed unsuccessfully;- -- the 'String' value should be a human-readable message- -- indicating how the test failed.- | Error String -- ^ indicates a test that could not be- -- completed due to some error; the test framework- -- should provide a message indicating the- -- nature of the error.- deriving (Read, Show, Eq)+data TestInstance = TestInstance+ { run :: IO Progress -- ^ Perform the test.+ , name :: String -- ^ A name for the test, unique within a+ -- test suite.+ , tags :: [String] -- ^ Users can select groups of tests by+ -- their tags.+ , options :: [OptionDescr] -- ^ Descriptions of the options recognized+ -- by this test.+ , setOption :: String -> String -> Either String TestInstance+ -- ^ Try to set the named option to the given value. Returns an error+ -- message if the option is not supported or the value could not be+ -- correctly parsed; otherwise, a 'TestInstance' with the option set to+ -- the given value is returned.+ } --- | Class abstracting impure tests. Test frameworks should implement this--- class only as a last resort for test types which actually require 'IO'.--- In particular, tests that simply require pseudo-random number generation can--- be implemented as pure tests.-class TestOptions t => ImpureTestable t where- -- | Runs an impure test and returns the result. Test frameworks- -- implementing this class are responsible for converting any exceptions to- -- the correct 'Result' value.- runM :: t -> Options -> IO Result+data OptionDescr = OptionDescr+ { optionName :: String+ , optionDescription :: String -- ^ A human-readable description of the+ -- option to guide the user setting it.+ , optionType :: OptionType+ , optionDefault :: Maybe String+ }+ deriving (Eq, Read, Show) --- | Class abstracting pure tests. Test frameworks should prefer to implement--- this class over 'ImpureTestable'. A default instance exists so that any pure--- test can be lifted into an impure test; when lifted, any exceptions are--- automatically caught. Test agents that lift pure tests themselves must--- handle exceptions.-class TestOptions t => PureTestable t where- -- | The result of a pure test.- run :: t -> Options -> Result+data OptionType+ = OptionFile+ { optionFileMustExist :: Bool+ , optionFileIsDir :: Bool+ , optionFileExtensions :: [String]+ }+ | OptionString+ { optionStringMultiline :: Bool+ }+ | OptionNumber+ { optionNumberIsInt :: Bool+ , optionNumberBounds :: (Maybe String, Maybe String)+ }+ | OptionBool+ | OptionEnum [String]+ | OptionSet [String]+ | OptionRngSeed+ deriving (Eq, Read, Show) --- | 'Test' is a wrapper for pure and impure tests so that lists containing--- arbitrary test types can be constructed. data Test- = forall p. PureTestable p => PureTest p- | forall i. ImpureTestable i => ImpureTest i---- | A convenient function for wrapping pure tests into 'Test's.-pure :: PureTestable p => p -> Test-pure = PureTest---- | A convenient function for wrapping impure tests into 'Test's.-impure :: ImpureTestable i => i -> Test-impure = ImpureTest--instance TestOptions Test where- name (PureTest p) = name p- name (ImpureTest i) = name i-- options (PureTest p) = options p- options (ImpureTest i) = options i-- defaultOptions (PureTest p) = defaultOptions p- defaultOptions (ImpureTest p) = defaultOptions p-- check (PureTest p) = check p- check (ImpureTest p) = check p--instance ImpureTestable Test where- runM (PureTest p) o = catch (evaluate $ run p o) handler+ = Test TestInstance+ | Group+ { groupName :: String+ , concurrently :: Bool+ -- ^ If true, then children of this group may be run in parallel.+ -- Note that this setting is not inherited by children. In+ -- particular, consider a group F with "concurrently = False" that+ -- has some children, including a group T with "concurrently =+ -- True". The children of group T may be run concurrently with each+ -- other, as long as none are run at the same time as any of the+ -- direct children of group F.+ , groupTests :: [Test]+ }+ | ExtraOptions [OptionDescr] Test - -- Because we have to handle old and new style exceptions, GHC and non-GHC- -- this code is totally horrible and really fragile. Has to be tested with- -- lots of ghc versions to check it is right, and with non-ghc too. :-(-#ifdef NEW_EXCEPTION- where- handler :: SomeException -> IO Result- handler e = case fromException e of- Just ioe | isInterruptedError ioe -> throw e- _ -> return (Error (show e))-#else- where- handler :: Exception -> IO Result- handler e = case e of- IOException ioe | isInterruptedError ioe -> throw e- _ -> return (Error (show e))-#endif+type Options = [(String, String)] - -- We do not want to catch control-C here, but only GHC- -- defines the Interrupted exception type! (ticket #3517)- isInterruptedError ioe =-#ifdef __GLASGOW_HASKELL__- ioeGetErrorType ioe == Interrupted-#else- False-#endif+data Progress = Finished Result+ | Progress String (IO Progress) - runM (ImpureTest i) o = runM i o+data Result = Pass+ | Fail String+ | Error String+ deriving (Eq, Read, Show) --- $example--- The following terms are used carefully throughout this file:------ [test interface] The interface provided by this module.------ [test agent] A program used by package users to coordinates the running--- of tests and the reporting of their results.------ [test framework] A package used by software authors to specify tests,--- such as QuickCheck or HUnit.------ Test frameworks are obligated to supply, at least, instances of the--- 'TestOptions' and 'ImpureTestable' classes. It is preferred that test--- frameworks implement 'PureTestable' whenever possible, so that test agents--- have an assurance that tests can be safely run in parallel.------ Test agents that allow the user to specify options should avoid setting--- options not listed by the 'options' method. Test agents should use 'check'--- before running tests with non-default options. Test frameworks must--- implement a 'check' function that attempts to parse the given options safely.------ The packages cabal-test-hunit, cabal-test-quickcheck1, and--- cabal-test-quickcheck2 provide simple interfaces to these popular test--- frameworks. An example from cabal-test-quickcheck2 is shown below. A--- better implementation would eliminate the console output from QuickCheck\'s--- built-in runner and provide an instance of 'PureTestable' instead of--- 'ImpureTestable'.------ > import Control.Monad (liftM)--- > import Data.Maybe (catMaybes, fromJust, maybe)--- > import Data.Typeable (Typeable(..))--- > import qualified Distribution.TestSuite as Cabal--- > import System.Random (newStdGen, next, StdGen)--- > import qualified Test.QuickCheck as QC--- >--- > data QCTest = forall prop. QC.Testable prop => QCTest String prop--- >--- > test :: QC.Testable prop => String -> prop -> Cabal.Test--- > test n p = Cabal.impure $ QCTest n p--- >--- > instance Cabal.TestOptions QCTest where--- > name (QCTest n _) = n--- >--- > options _ =--- > [ ("std-gen", typeOf (undefined :: String))--- > , ("max-success", typeOf (undefined :: Int))--- > , ("max-discard", typeOf (undefined :: Int))--- > , ("size", typeOf (undefined :: Int))--- > ]--- >--- > defaultOptions _ = do--- > rng <- newStdGen--- > return $ Cabal.Options $--- > [ ("std-gen", show rng)--- > , ("max-success", show $ QC.maxSuccess QC.stdArgs)--- > , ("max-discard", show $ QC.maxDiscard QC.stdArgs)--- > , ("size", show $ QC.maxSize QC.stdArgs)--- > ]--- >--- > check t (Cabal.Options opts) = catMaybes--- > [ maybeNothing "max-success" ([] :: [(Int, String)])--- > , maybeNothing "max-discard" ([] :: [(Int, String)])--- > , maybeNothing "size" ([] :: [(Int, String)])--- > ]--- > -- There is no need to check the parsability of "std-gen"--- > -- because the Read instance for StdGen always succeeds.--- > where--- > maybeNothing n x =--- > maybe Nothing (\str ->--- > if reads str == x then Just n else Nothing)--- > $ lookup n opts--- >--- > instance Cabal.ImpureTestable QCTest where--- > runM (QCTest _ prop) o =--- > catch go (return . Cabal.Error . show)--- > where--- > go = do--- > result <- QC.quickCheckWithResult args prop--- > return $ case result of--- > QC.Success {} -> Cabal.Pass--- > QC.GaveUp {}->--- > Cabal.Fail $ "gave up after "--- > ++ show (QC.numTests result)--- > ++ " tests"--- > QC.Failure {} -> Cabal.Fail $ QC.reason result--- > QC.NoExpectedFailure {} ->--- > Cabal.Fail "passed (expected failure)"--- > args = QC.Args--- > { QC.replay = Just--- > ( Cabal.lookupOption "std-gen" o--- > , Cabal.lookupOption "size" o--- > )--- > , QC.maxSuccess = Cabal.lookupOption "max-success" o--- > , QC.maxDiscard = Cabal.lookupOption "max-discard" o--- > , QC.maxSize = Cabal.lookupOption "size" o--- > }+-- | Create a named group of tests, which are assumed to be safe to run in+-- parallel.+testGroup :: String -> [Test] -> Test+testGroup n ts = Group { groupName = n, concurrently = True, groupTests = ts }
README view
@@ -10,6 +10,17 @@ Installation instructions for the Cabal library =============================================== +If you have the `cabal` program already+---------------------------------------++In this case it's simple, just++ cabal install++Of course, if you don't have an existing version of the `cabal` program+then to get one you'd first need to install the Cabal library! To avoid+this bootstrapping problem, you can install the Cabal library directly:+ Installing as a user (no root or administer access) ---------------------------------------------------
tests/PackageTests/PackageTester.hs view
@@ -132,7 +132,7 @@ r <- run (Just $ directory spec) "ghc" [ "--make" , "-fhpc"- , "-package-conf " ++ wd </> "../dist/package.conf.inplace"+ , "-package-db " ++ wd </> "../dist/package.conf.inplace" , "Setup.hs" ] requireSuccess r