diff --git a/Cabal.cabal b/Cabal.cabal --- a/Cabal.cabal +++ b/Cabal.cabal @@ -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, diff --git a/Distribution/License.hs b/Distribution/License.hs --- a/Distribution/License.hs +++ b/Distribution/License.hs @@ -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 diff --git a/Distribution/PackageDescription/Check.hs b/Distribution/PackageDescription/Check.hs --- a/Distribution/PackageDescription/Check.hs +++ b/Distribution/PackageDescription/Check.hs @@ -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 = diff --git a/Distribution/Simple/Build.hs b/Distribution/Simple/Build.hs --- a/Distribution/Simple/Build.hs +++ b/Distribution/Simple/Build.hs @@ -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. diff --git a/Distribution/Simple/Build/PathsModule.hs b/Distribution/Simple/Build/PathsModule.hs --- a/Distribution/Simple/Build/PathsModule.hs +++ b/Distribution/Simple/Build/PathsModule.hs @@ -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 diff --git a/Distribution/Simple/Configure.hs b/Distribution/Simple/Configure.hs --- a/Distribution/Simple/Configure.hs +++ b/Distribution/Simple/Configure.hs @@ -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__"] diff --git a/Distribution/Simple/GHC.hs b/Distribution/Simple/GHC.hs --- a/Distribution/Simple/GHC.hs +++ b/Distribution/Simple/GHC.hs @@ -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" diff --git a/Distribution/Simple/Haddock.hs b/Distribution/Simple/Haddock.hs --- a/Distribution/Simple/Haddock.hs +++ b/Distribution/Simple/Haddock.hs @@ -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 } diff --git a/Distribution/Simple/InstallDirs.hs b/Distribution/Simple/InstallDirs.hs --- a/Distribution/Simple/InstallDirs.hs +++ b/Distribution/Simple/InstallDirs.hs @@ -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__ diff --git a/Distribution/Simple/LHC.hs b/Distribution/Simple/LHC.hs --- a/Distribution/Simple/LHC.hs +++ b/Distribution/Simple/LHC.hs @@ -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 diff --git a/Distribution/Simple/LocalBuildInfo.hs b/Distribution/Simple/LocalBuildInfo.hs --- a/Distribution/Simple/LocalBuildInfo.hs +++ b/Distribution/Simple/LocalBuildInfo.hs @@ -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. diff --git a/Distribution/Simple/PackageIndex.hs b/Distribution/Simple/PackageIndex.hs --- a/Distribution/Simple/PackageIndex.hs +++ b/Distribution/Simple/PackageIndex.hs @@ -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 diff --git a/Distribution/Simple/Program/GHC.hs b/Distribution/Simple/Program/GHC.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Program/GHC.hs @@ -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 diff --git a/Distribution/Simple/Program/HcPkg.hs b/Distribution/Simple/Program/HcPkg.hs --- a/Distribution/Simple/Program/HcPkg.hs +++ b/Distribution/Simple/Program/HcPkg.hs @@ -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 diff --git a/Distribution/Simple/Register.hs b/Distribution/Simple/Register.hs --- a/Distribution/Simple/Register.hs +++ b/Distribution/Simple/Register.hs @@ -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, diff --git a/Distribution/Simple/Setup.hs b/Distribution/Simple/Setup.hs --- a/Distribution/Simple/Setup.hs +++ b/Distribution/Simple/Setup.hs @@ -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, diff --git a/Distribution/Simple/Test.hs b/Distribution/Simple/Test.hs --- a/Distribution/Simple/Test.hs +++ b/Distribution/Simple/Test.hs @@ -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 + diff --git a/Distribution/TestSuite.hs b/Distribution/TestSuite.hs --- a/Distribution/TestSuite.hs +++ b/Distribution/TestSuite.hs @@ -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 } diff --git a/README b/README --- a/README +++ b/README @@ -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) --------------------------------------------------- diff --git a/tests/PackageTests/PackageTester.hs b/tests/PackageTests/PackageTester.hs --- a/tests/PackageTests/PackageTester.hs +++ b/tests/PackageTests/PackageTester.hs @@ -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