Commits (162)
......@@ -5,6 +5,7 @@ cabal-dev/
Cabal/dist/
Cabal/tests/Setup
cabal-install/dist/
cabal-install/tests/PackageTests/*/dist/
.hpc/
*.hi
*.o
......@@ -29,3 +30,4 @@ Cabal/ghc.mk
# TAGS files
TAGS
tags
......@@ -2,7 +2,6 @@
# The following enables several GHC versions to be tested; often it's enough to test only against the last release in a major GHC version. Feel free to omit lines listings versions you don't need/want testing for.
env:
- GHCVER=7.0.4
- GHCVER=7.4.2
- GHCVER=7.6.3
- GHCVER=7.8.2
......@@ -12,15 +11,15 @@ env:
before_install:
- travis_retry sudo add-apt-repository -y ppa:hvr/ghc
- travis_retry sudo apt-get update
- travis_retry sudo apt-get install cabal-install-1.18 ghc-$GHCVER-prof ghc-$GHCVER-dyn happy
- export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/1.18/bin:$PATH
- travis_retry sudo apt-get install cabal-install-1.20 ghc-$GHCVER-prof ghc-$GHCVER-dyn happy
- export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/1.20/bin:$PATH
install:
- sudo /opt/ghc/$GHCVER/bin/ghc-pkg recache
- /opt/ghc/$GHCVER/bin/ghc-pkg recache --user
- cabal update
- cd Cabal
- cabal install --only-dependencies --enable-tests --enable-benchmarks
- sudo /opt/ghc/$GHCVER/bin/ghc-pkg recache
- /opt/ghc/$GHCVER/bin/ghc-pkg recache --user
# Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail.
script:
......
name: Cabal
version: 1.20.0.1
version: 1.21.0.0
copyright: 2003-2006, Isaac Jones
2005-2011, Duncan Coutts
license: BSD3
......@@ -24,7 +24,10 @@ build-type: Custom
-- that we build Setup.lhs using our own local Cabal source code.
extra-source-files:
README tests/README changelog
README.md tests/README.md changelog
doc/developing-packages.markdown doc/index.markdown
doc/installing-packages.markdown
doc/misc.markdown
-- Generated with 'misc/gen-extra-source-files.sh' & 'M-x sort-lines':
tests/PackageTests/BenchmarkExeV10/Foo.hs
......@@ -80,6 +83,11 @@ extra-source-files:
tests/PackageTests/DeterministicAr/Lib.hs
tests/PackageTests/DeterministicAr/my.cabal
tests/PackageTests/EmptyLib/empty/empty.cabal
tests/PackageTests/Haddock/CPP.hs
tests/PackageTests/Haddock/Literate.lhs
tests/PackageTests/Haddock/my.cabal
tests/PackageTests/Haddock/NoCPP.hs
tests/PackageTests/Haddock/Simple.hs
tests/PackageTests/OrderFlags/Foo.hs
tests/PackageTests/OrderFlags/my.cabal
tests/PackageTests/PathsModule/Executable/Main.hs
......@@ -119,15 +127,15 @@ source-repository head
library
build-depends:
base >= 4 && < 5,
deepseq >= 1.3 && < 1.4,
filepath >= 1 && < 1.4,
directory >= 1 && < 1.3,
process >= 1.0.1.1 && < 1.3,
time >= 1.1 && < 1.5,
containers >= 0.1 && < 0.6,
array >= 0.1 && < 0.6,
pretty >= 1 && < 1.2,
base >= 4 && < 5,
deepseq >= 1.3 && < 1.4,
filepath >= 1 && < 1.4,
directory >= 1 && < 1.3,
process >= 1.2 && < 1.3,
time >= 1.1 && < 1.5,
containers >= 0.1 && < 0.6,
array >= 0.1 && < 0.6,
pretty >= 1 && < 1.2,
bytestring >= 0.9
if !os(windows)
......@@ -233,7 +241,7 @@ test-suite unit-tests
test-framework-hunit,
test-framework-quickcheck2,
HUnit,
QuickCheck < 2.7,
QuickCheck < 2.8,
Cabal
ghc-options: -Wall
default-language: Haskell98
......@@ -261,6 +269,7 @@ test-suite package-tests
PackageTests.CMain.Check
PackageTests.DeterministicAr.Check
PackageTests.EmptyLib.Check
PackageTests.Haddock.Check
PackageTests.OrderFlags.Check
PackageTests.PackageTester
PackageTests.PathsModule.Executable.Check
......@@ -277,7 +286,7 @@ test-suite package-tests
test-framework-quickcheck2 >= 0.2.12,
test-framework-hunit,
HUnit,
QuickCheck >= 2.1.0.1 && < 2.7,
QuickCheck >= 2.1.0.1 && < 2.8,
Cabal,
process,
directory,
......
......@@ -14,7 +14,7 @@
-- it makes no difference which branch is \"shorter\".
--
-- See also Koen's paper /Parallel Parsing Processes/
-- (<http://www.cs.chalmers.se/~koen/publications.html>).
-- (<http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.19.9217>).
--
-- This version of ReadP has been locally hacked to make it H98, by
-- Martin Sj&#xF6;gren <mailto:msjogren@gmail.com>
......
......@@ -952,13 +952,6 @@ data ConfVar = OS OS
| Impl CompilerFlavor VersionRange
deriving (Eq, Show, Typeable, Data)
--instance Text ConfVar where
-- disp (OS os) = "os(" ++ display os ++ ")"
-- disp (Arch arch) = "arch(" ++ display arch ++ ")"
-- disp (Flag (ConfFlag f)) = "flag(" ++ f ++ ")"
-- disp (Impl c v) = "impl(" ++ display c
-- ++ " " ++ display v ++ ")"
-- | A boolean expression parameterized over the variable type used.
data Condition c = Var c
| Lit Bool
......@@ -967,13 +960,6 @@ data Condition c = Var c
| CAnd (Condition c) (Condition c)
deriving (Show, Eq, Typeable, Data)
--instance Text c => Text (Condition c) where
-- disp (Var x) = text (show x)
-- disp (Lit b) = text (show b)
-- disp (CNot c) = char '!' <> parens (ppCond c)
-- disp (COr c1 c2) = parens $ sep [ppCond c1, text "||" <+> ppCond c2]
-- disp (CAnd c1 c2) = parens $ sep [ppCond c1, text "&&" <+> ppCond c2]
data CondTree v c a = CondNode
{ condTreeData :: a
, condTreeConstraints :: c
......@@ -982,16 +968,3 @@ data CondTree v c a = CondNode
, Maybe (CondTree v c a))]
}
deriving (Show, Eq, Typeable, Data)
--instance (Text v, Text c) => Text (CondTree v c a) where
-- disp (CondNode _dat cs ifs) =
-- (text "build-depends: " <+>
-- disp cs)
-- $+$
-- (vcat $ map ppIf ifs)
-- where
-- ppIf (c,thenTree,mElseTree) =
-- ((text "if" <+> ppCond c <> colon) $$
-- nest 2 (ppCondTree thenTree disp))
-- $+$ (maybe empty (\t -> text "else: " $$ nest 2 (ppCondTree t disp))
-- mElseTree)
......@@ -594,8 +594,9 @@ checkGhcOptions pkg =
, checkFlags ["-fhpc"] $
PackageDistInexcusable $
"'ghc-options: -fhpc' is not appropriate for a distributed package."
, check (any ("-d" `isPrefixOf`) all_ghc_options) $
-- -dynamic is not a debug flag
, check (any (\opt -> "-d" `isPrefixOf` opt && opt /= "-dynamic") all_ghc_options) $
PackageDistInexcusable $
"'ghc-options: -d*' debug flags are not appropriate for a distributed package."
......
-----------------------------------------------------------------------------
--
-- |
-- Module : Distribution.PackageDescription.PrettyPrint
-- Copyright : Jürgen Nicklisch-Franken 2010
-- License : BSD3
......@@ -8,7 +8,7 @@
-- Stability : provisional
-- Portability : portable
--
-- | Pretty printing for cabal files
-- Pretty printing for cabal files
--
-----------------------------------------------------------------------------
......@@ -32,7 +32,7 @@ import Text.PrettyPrint
import Distribution.Simple.Utils (writeUTF8File)
import Distribution.ParseUtils (showFreeText, FieldDescr(..), indentWith, ppField, ppFields)
import Distribution.PackageDescription.Parse (pkgDescrFieldDescrs,binfoFieldDescrs,libFieldDescrs,
sourceRepoFieldDescrs)
sourceRepoFieldDescrs,flagFieldDescrs)
import Distribution.Package (Dependency(..))
import Distribution.Text (Text(..))
import Data.Maybe (isJust, fromJust, isNothing)
......@@ -74,6 +74,23 @@ ppSourceRepo repo =
where
sourceRepoFieldDescrs' = [fd | fd <- sourceRepoFieldDescrs, fieldName fd /= "kind"]
-- TODO: this is a temporary hack. Ideally, fields containing default values
-- would be filtered out when the @FieldDescr a@ list is generated.
ppFieldsFiltered :: [(String, String)] -> [FieldDescr a] -> a -> Doc
ppFieldsFiltered removable fields x = ppFields (filter nondefault fields) x
where
nondefault (FieldDescr name getter _) =
maybe True (render (getter x) /=) (lookup name removable)
binfoDefaults :: [(String, String)]
binfoDefaults = [("buildable", "True")]
libDefaults :: [(String, String)]
libDefaults = ("exposed", "True") : binfoDefaults
flagDefaults :: [(String, String)]
flagDefaults = [("default", "True"), ("manual", "False")]
ppDiffFields :: [FieldDescr a] -> a -> a -> Doc
ppDiffFields fields x y =
vcat [ ppField name (getter x)
......@@ -91,20 +108,17 @@ ppGenPackageFlags :: [Flag] -> Doc
ppGenPackageFlags flds = vcat [ppFlag f | f <- flds]
ppFlag :: Flag -> Doc
ppFlag (MkFlag name desc dflt manual) =
emptyLine $ text "flag" <+> ppFlagName name $+$
(nest indentWith ((if null desc
then empty
else text "Description: " <+> showFreeText desc) $+$
(if dflt then empty else text "Default: False") $+$
(if manual then text "Manual: True" else empty)))
ppFlag flag@(MkFlag name _ _ _) =
emptyLine $ text "flag" <+> ppFlagName name $+$ nest indentWith fields
where
fields = ppFieldsFiltered flagDefaults flagFieldDescrs flag
ppLibrary :: (Maybe (CondTree ConfVar [Dependency] Library)) -> Doc
ppLibrary Nothing = empty
ppLibrary (Just condTree) =
emptyLine $ text "library" $+$ nest indentWith (ppCondTree condTree Nothing ppLib)
where
ppLib lib Nothing = ppFields libFieldDescrs lib
ppLib lib Nothing = ppFieldsFiltered libDefaults libFieldDescrs lib
$$ ppCustomFields (customFieldsBI (libBuildInfo lib))
ppLib lib (Just plib) = ppDiffFields libFieldDescrs lib plib
$$ ppCustomFields (customFieldsBI (libBuildInfo lib))
......@@ -116,7 +130,7 @@ ppExecutables exes =
where
ppExe (Executable _ modulePath' buildInfo') Nothing =
(if modulePath' == "" then empty else text "main-is:" <+> text modulePath')
$+$ ppFields binfoFieldDescrs buildInfo'
$+$ ppFieldsFiltered binfoDefaults binfoFieldDescrs buildInfo'
$+$ ppCustomFields (customFieldsBI buildInfo')
ppExe (Executable _ modulePath' buildInfo')
(Just (Executable _ modulePath2 buildInfo2)) =
......@@ -138,7 +152,7 @@ ppTestSuites suites =
(testSuiteMainIs testsuite)
$+$ maybe empty (\m -> text "test-module:" <+> disp m)
(testSuiteModule testsuite)
$+$ ppFields binfoFieldDescrs (testBuildInfo testsuite)
$+$ ppFieldsFiltered binfoDefaults binfoFieldDescrs (testBuildInfo testsuite)
$+$ ppCustomFields (customFieldsBI (testBuildInfo testsuite))
where
maybeTestType | testInterface testsuite == mempty = Nothing
......@@ -168,7 +182,7 @@ ppBenchmarks suites =
maybeBenchmarkType
$+$ maybe empty (\f -> text "main-is:" <+> text f)
(benchmarkMainIs benchmark)
$+$ ppFields binfoFieldDescrs (benchmarkBuildInfo benchmark)
$+$ ppFieldsFiltered binfoDefaults binfoFieldDescrs (benchmarkBuildInfo benchmark)
$+$ ppCustomFields (customFieldsBI (benchmarkBuildInfo benchmark))
where
maybeBenchmarkType | benchmarkInterface benchmark == mempty = Nothing
......@@ -209,6 +223,7 @@ ppCondTree ct@(CondNode it deps ifs) mbIt ppIt =
then ppCondTree ct Nothing ppIt
else res
where
-- TODO: this ends up printing trailing spaces when combined with nest.
ppIf (c,thenTree,mElseTree) =
((emptyLine $ text "if" <+> ppCondition c) $$
nest indentWith (ppCondTree thenTree
......@@ -225,7 +240,7 @@ ppDeps deps =
text "build-depends:" $+$ nest indentWith (vcat (punctuate comma (map disp deps)))
emptyLine :: Doc -> Doc
emptyLine d = text " " $+$ d
emptyLine d = text "" $+$ d
......@@ -284,6 +284,7 @@ ppField name fielddoc
, "includes"
, "install-includes"
, "other-modules"
, "depends"
]
showFields :: [FieldDescr a] -> a -> String
......@@ -733,7 +734,6 @@ showTestedWith (compiler, version) = text (show compiler) <+> disp version
-- and with blank lines replaced by dots for correct re-parsing.
showFreeText :: String -> Doc
showFreeText "" = empty
showFreeText ('\n' :r) = text " " $+$ text "." $+$ showFreeText r
showFreeText s = vcat [text (if null l then "." else l) | l <- lines_ s]
-- | 'lines_' breaks a string up into a list of strings at newline
......
......@@ -347,12 +347,9 @@ testAction hooks flags args = do
-- default action is a no-op and if the package uses the old test interface
-- the new handler will find no tests.
runTests hooks args False pkg_descr localBuildInfo
--FIXME: this is a hack, passing the args inside the flags
-- it's because the args to not get passed to the main test hook
let flags' = flags { testList = Flag args }
hookedAction preTest testHook postTest
hookedActionWithArgs preTest testHook postTest
(getBuildConfig hooks verbosity distPref)
hooks flags' args
hooks flags args
benchAction :: UserHooks -> BenchmarkFlags -> Args -> IO ()
benchAction hooks flags args = do
......@@ -510,7 +507,7 @@ simpleUserHooks =
buildHook = defaultBuildHook,
replHook = defaultReplHook,
copyHook = \desc lbi _ f -> install desc lbi f, -- has correct 'copy' behavior with params
testHook = defaultTestHook,
testHook = defaultTestHook,
benchHook = defaultBenchHook,
instHook = defaultInstallHook,
sDistHook = \p l h f -> sdist p l f srcPref (allSuffixHandlers h),
......@@ -653,10 +650,10 @@ getHookedBuildInfo verbosity = do
info verbosity $ "Reading parameters from " ++ infoFile
readHookedBuildInfo verbosity infoFile
defaultTestHook :: PackageDescription -> LocalBuildInfo
defaultTestHook :: Args -> PackageDescription -> LocalBuildInfo
-> UserHooks -> TestFlags -> IO ()
defaultTestHook pkg_descr localbuildinfo _ flags =
test pkg_descr localbuildinfo flags
defaultTestHook args pkg_descr localbuildinfo _ flags =
test args pkg_descr localbuildinfo flags
defaultBenchHook :: Args -> PackageDescription -> LocalBuildInfo
-> UserHooks -> BenchmarkFlags -> IO ()
......
......@@ -75,7 +75,7 @@ import Distribution.Simple.Program
, ProgramSearchPathEntry(..), getProgramSearchPath, setProgramSearchPath
, configureAllKnownPrograms, knownPrograms, lookupKnownProgram
, userSpecifyArgss, userSpecifyPaths
, requireProgram, requireProgramVersion
, lookupProgram, requireProgram, requireProgramVersion
, pkgConfigProgram, gccProgram, rawSystemProgramStdoutConf )
import Distribution.Simple.Setup
( ConfigFlags(..), CopyDest(..), fromFlag, fromFlagOrDefault, flagToMaybe )
......@@ -110,6 +110,8 @@ import qualified Distribution.Simple.Hugs as Hugs
import qualified Distribution.Simple.UHC as UHC
import qualified Distribution.Simple.HaskellSuite as HaskellSuite
-- Prefer the more generic Data.Traversable.mapM to Prelude.mapM
import Prelude hiding ( mapM )
import Control.Monad
( when, unless, foldM, filterM )
import Data.List
......@@ -120,6 +122,8 @@ import Data.Monoid
( Monoid(..) )
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Traversable
( mapM )
import System.Directory
( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory )
import System.FilePath
......@@ -865,9 +869,12 @@ configurePkgconfigPackages verbosity pkg_descr conf
(lessVerbose verbosity) pkgConfigProgram
(orLaterVersion $ Version [0,9,0] []) conf
mapM_ requirePkg allpkgs
lib' <- updateLibrary (library pkg_descr)
exes' <- mapM updateExecutable (executables pkg_descr)
let pkg_descr' = pkg_descr { library = lib', executables = exes' }
lib' <- mapM addPkgConfigBILib (library pkg_descr)
exes' <- mapM addPkgConfigBIExe (executables pkg_descr)
tests' <- mapM addPkgConfigBITest (testSuites pkg_descr)
benches' <- mapM addPkgConfigBIBench (benchmarks pkg_descr)
let pkg_descr' = pkg_descr { library = lib', executables = exes',
testSuites = tests', benchmarks = benches' }
return (pkg_descr', conf')
where
......@@ -898,14 +905,26 @@ configurePkgconfigPackages verbosity pkg_descr conf
| isAnyVersion range = ""
| otherwise = " version " ++ display range
updateLibrary Nothing = return Nothing
updateLibrary (Just lib) = do
bi <- pkgconfigBuildInfo (pkgconfigDepends (libBuildInfo lib))
return $ Just lib { libBuildInfo = libBuildInfo lib `mappend` bi }
-- Adds pkgconfig dependencies to the build info for a component
addPkgConfigBI compBI setCompBI comp = do
bi <- pkgconfigBuildInfo (pkgconfigDepends (compBI comp))
return $ setCompBI comp (compBI comp `mappend` bi)
updateExecutable exe = do
bi <- pkgconfigBuildInfo (pkgconfigDepends (buildInfo exe))
return exe { buildInfo = buildInfo exe `mappend` bi }
-- Adds pkgconfig dependencies to the build info for a library
addPkgConfigBILib = addPkgConfigBI libBuildInfo $
\lib bi -> lib { libBuildInfo = bi }
-- Adds pkgconfig dependencies to the build info for an executable
addPkgConfigBIExe = addPkgConfigBI buildInfo $
\exe bi -> exe { buildInfo = bi }
-- Adds pkgconfig dependencies to the build info for a test suite
addPkgConfigBITest = addPkgConfigBI testBuildInfo $
\test bi -> test { testBuildInfo = bi }
-- Adds pkgconfig dependencies to the build info for a benchmark
addPkgConfigBIBench = addPkgConfigBI benchmarkBuildInfo $
\bench bi -> bench { benchmarkBuildInfo = bi }
pkgconfigBuildInfo :: [Dependency] -> IO BuildInfo
pkgconfigBuildInfo [] = return mempty
......@@ -1159,11 +1178,20 @@ checkForeignDeps pkg lbi verbosity = do
_ <- rawSystemProgramStdoutConf verbosity
gccProgram (withPrograms lbi) (cName:"-o":oNname:args)
return True
--TODO: need a better error in the case of not finding gcc!
`catchIO` (\_ -> return False)
`catchExit` (\_ -> return False)
explainErrors Nothing [] = return () -- should be impossible!
explainErrors _ _
| isNothing . lookupProgram gccProgram . withPrograms $ lbi
= die $ unlines $
[ "No working gcc",
"This package depends on foreign library but we cannot "
++ "find a working C compiler. If you have it in a "
++ "non-standard location you can use the --with-gcc "
++ "flag to specify it." ]
explainErrors hdr libs = die $ unlines $
[ if plural
then "Missing dependencies on foreign libraries:"
......
......@@ -1207,10 +1207,10 @@ componentCcGhcOptions verbosity lbi bi clbi pref filename =
++ PD.includeDirs bi,
ghcOptPackageDBs = withPackageDB lbi,
ghcOptPackages = componentPackageDeps clbi,
ghcOptCcOptions = PD.ccOptions bi
++ case withOptimization lbi of
ghcOptCcOptions = (case withOptimization lbi of
NoOptimisation -> []
_ -> ["-O2"],
_ -> ["-O2"]) ++
PD.ccOptions bi,
ghcOptObjDir = toFlag odir
}
where
......
......@@ -7,12 +7,9 @@
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
--
-- This module deals with the @haddock@ and @hscolour@ commands. Sadly this is a
-- rather complicated module. It deals with two versions of haddock (0.x and
-- 2.x). It has to do pre-processing which involves \'unlit\'ing and using
-- @-D__HADDOCK__@ for any source code that uses @cpp@. It uses information
-- about installed packages (from @ghc-pkg@) to find the locations of
-- documentation for dependent packages, so it can create links.
-- This module deals with the @haddock@ and @hscolour@ commands.
-- It uses information about installed packages (from @ghc-pkg@) to find the
-- locations of documentation for dependent packages, so it can create links.
--
-- The @hscolour@ support allows generating HTML versions of the original
-- source, with coloured syntax highlighting.
......@@ -30,7 +27,7 @@ import Distribution.Package
, PackageName(..), packageName )
import qualified Distribution.ModuleName as ModuleName
import Distribution.PackageDescription as PD
( PackageDescription(..), BuildInfo(..), allExtensions
( PackageDescription(..), BuildInfo(..), usedExtensions
, Library(..), hasLibs, Executable(..)
, TestSuite(..), TestSuiteInterface(..)
, Benchmark(..), BenchmarkInterface(..) )
......@@ -43,8 +40,7 @@ import Distribution.Simple.Program
( ConfiguredProgram(..), requireProgramVersion
, rawSystemProgram, rawSystemProgramStdout
, hscolourProgram, haddockProgram )
import Distribution.Simple.PreProcess (ppCpp', ppUnlit
, PPSuffixHandler, runSimplePreProcessor
import Distribution.Simple.PreProcess (PPSuffixHandler
, preprocessComponent)
import Distribution.Simple.Setup
( defaultHscolourFlags, Flag(..), toFlag, flagToMaybe, flagToList, fromFlag
......@@ -79,15 +75,14 @@ import Distribution.Text
import Distribution.Verbosity
import Language.Haskell.Extension
-- Base
import System.Directory(removeFile, doesFileExist, createDirectoryIfMissing)
import System.Directory(doesFileExist)
import Control.Monad ( when, guard, forM_ )
import Control.Exception (assert)
import Control.Monad ( when, forM_ )
import Data.Either ( rights )
import Data.Monoid
import Data.Maybe ( fromMaybe, listToMaybe )
import System.FilePath((</>), (<.>), splitFileName, splitExtension,
import System.FilePath((</>), (<.>),
normalise, splitPath, joinPath, isAbsolute )
import System.IO (hClose, hPutStrLn, hSetEncoding, utf8)
import Distribution.Version
......@@ -110,8 +105,8 @@ data HaddockArgs = HaddockArgs {
argOutputDir :: Directory, -- ^ where to generate the documentation.
argTitle :: Flag String, -- ^ page's title, required.
argPrologue :: Flag String, -- ^ prologue text, required.
argGhcOptions :: Flag (GhcOptions, Version), -- ^ additional flags to pass to ghc for haddock-2
argGhcLibDir :: Flag FilePath, -- ^ to find the correct ghc, required by haddock-2.
argGhcOptions :: Flag (GhcOptions, Version), -- ^ additional flags to pass to ghc
argGhcLibDir :: Flag FilePath, -- ^ to find the correct ghc, required.
argTargets :: [FilePath] -- ^ modules to process.
}
......@@ -144,32 +139,25 @@ haddock pkg_descr lbi suffixes flags = do
setupMessage verbosity "Running Haddock for" (packageId pkg_descr)
(confHaddock, version, _) <-
requireProgramVersion verbosity haddockProgram
(orLaterVersion (Version [0,6] [])) (withPrograms lbi)
(orLaterVersion (Version [2,0] [])) (withPrograms lbi)
-- various sanity checks
let isVersion2 = version >= Version [2,0] []
when ( flag haddockHoogle
&& version > Version [2] []
&& version < Version [2,2] []) $
die "haddock 2.0 and 2.1 do not support the --hoogle flag."
when (flag haddockHscolour && version < Version [0,8] []) $
die "haddock --hyperlink-source requires Haddock version 0.8 or later"
when isVersion2 $ do
haddockGhcVersionStr <- rawSystemProgramStdout verbosity confHaddock
["--ghc-version"]
case simpleParse haddockGhcVersionStr of
Nothing -> die "Could not get GHC version from Haddock"
Just haddockGhcVersion
| haddockGhcVersion == ghcVersion -> return ()
| otherwise -> die $
"Haddock's internal GHC version must match the configured "
++ "GHC version.\n"
++ "The GHC version is " ++ display ghcVersion ++ " but "
++ "haddock is using GHC version " ++ display haddockGhcVersion
where ghcVersion = compilerVersion comp
haddockGhcVersionStr <- rawSystemProgramStdout verbosity confHaddock
["--ghc-version"]
case simpleParse haddockGhcVersionStr of
Nothing -> die "Could not get GHC version from Haddock"
Just haddockGhcVersion
| haddockGhcVersion == ghcVersion -> return ()
| otherwise -> die $
"Haddock's internal GHC version must match the configured "
++ "GHC version.\n"
++ "The GHC version is " ++ display ghcVersion ++ " but "
++ "haddock is using GHC version " ++ display haddockGhcVersion
where ghcVersion = compilerVersion comp
-- the tools match the requests, we can proceed
......@@ -178,7 +166,7 @@ haddock pkg_descr lbi suffixes flags = do
when (flag haddockHscolour) $ hscolour' pkg_descr lbi suffixes $
defaultHscolourFlags `mappend` haddockToHscolour flags
libdirArgs <- getGhcLibDir verbosity lbi isVersion2
libdirArgs <- getGhcLibDir verbosity lbi
let commonArgs = mconcat
[ libdirArgs
, fromFlags (haddockTemplateEnv lbi (packageId pkg_descr)) flags
......@@ -191,10 +179,9 @@ haddock pkg_descr lbi suffixes flags = do
doExe com = case (compToExe com) of
Just exe -> do
withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $ \tmp -> do
let bi = buildInfo exe
exeArgs <- fromExecutable verbosity tmp lbi exe clbi htmlTemplate
exeArgs' <- prepareSources verbosity tmp
lbi version bi (commonArgs `mappend` exeArgs)
exeArgs <- fromExecutable verbosity tmp lbi exe clbi htmlTemplate
version
let exeArgs' = commonArgs `mappend` exeArgs
runHaddock verbosity tmpFileOpts comp confHaddock exeArgs'
Nothing -> do
warn (fromFlag $ haddockVerbosity flags)
......@@ -203,10 +190,9 @@ haddock pkg_descr lbi suffixes flags = do
case component of
CLib lib -> do
withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $ \tmp -> do
let bi = libBuildInfo lib
libArgs <- fromLibrary verbosity tmp lbi lib clbi htmlTemplate
libArgs' <- prepareSources verbosity tmp
lbi version bi (commonArgs `mappend` libArgs)
libArgs <- fromLibrary verbosity tmp lbi lib clbi htmlTemplate
version
let libArgs' = commonArgs `mappend` libArgs
runHaddock verbosity tmpFileOpts comp confHaddock libArgs'
CExe _ -> when (flag haddockExecutables) $ doExe component
CTest _ -> when (flag haddockTestSuites) $ doExe component
......@@ -223,50 +209,6 @@ haddock pkg_descr lbi suffixes flags = do
flag f = fromFlag $ f flags
htmlTemplate = fmap toPathTemplate . flagToMaybe . haddockHtmlLocation $ flags
-- | performs cpp and unlit preprocessing where needed on the files in
-- | argTargets, which must have an .hs or .lhs extension.
prepareSources :: Verbosity
-> FilePath
-> LocalBuildInfo
-> Version
-> BuildInfo
-> HaddockArgs
-> IO HaddockArgs
prepareSources verbosity tmp lbi haddockVersion bi args@HaddockArgs{argTargets=files} =
mapM (mockPP tmp) files >>= \targets -> return args {argTargets=targets}
where
mockPP pref file = do
let (filePref, fileName) = splitFileName file
targetDir = pref </> filePref
targetFile = targetDir </> fileName
(targetFileNoext, targetFileExt) = splitExtension $ targetFile
hsFile = targetFileNoext <.> "hs"
assert (targetFileExt `elem` [".lhs",".hs"]) $ return ()
createDirectoryIfMissing True targetDir
if needsCpp
then do
runSimplePreProcessor (ppCpp' defines bi lbi)
file targetFile verbosity
else
copyFileVerbose verbosity file targetFile
when (targetFileExt == ".lhs") $ do
runSimplePreProcessor ppUnlit targetFile hsFile verbosity
removeFile targetFile
return hsFile
needsCpp = EnableExtension CPP `elem` allExtensions bi
isVersion2 = haddockVersion >= Version [2,0] []
defines | isVersion2 = [haddockVersionMacro]
| otherwise = ["-D__HADDOCK__", haddockVersionMacro]
haddockVersionMacro = "-D__HADDOCK_VERSION__="
++ show (v1 * 1000 + v2 * 10 + v3)
where
[v1, v2, v3] = take 3 $ versionBranch haddockVersion ++ [0,0]
-- ------------------------------------------------------------------------------
-- Contributions to HaddockArgs.
......@@ -309,8 +251,9 @@ fromLibrary :: Verbosity
-> FilePath
-> LocalBuildInfo -> Library -> ComponentLocalBuildInfo
-> Maybe PathTemplate -- ^ template for HTML location
-> Version
-> IO HaddockArgs
fromLibrary verbosity tmp lbi lib clbi htmlTemplate = do
fromLibrary verbosity tmp lbi lib clbi htmlTemplate haddockVersion = do
inFiles <- map snd `fmap` getLibSourceFiles lbi lib
ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate
let vanillaOpts = (componentGhcOptions normal lbi bi clbi (buildDir lbi)) {
......@@ -321,7 +264,7 @@ fromLibrary verbosity tmp lbi lib clbi htmlTemplate = do
ghcOptObjDir = toFlag tmp,
ghcOptHiDir = toFlag tmp,
ghcOptStubDir = toFlag tmp
}
} `mappend` getGhcCppOpts haddockVersion bi
sharedOpts = vanillaOpts {
ghcOptDynLinkMode = toFlag GhcDynamicOnly,
ghcOptFPic = toFlag True,
......@@ -347,8 +290,9 @@ fromExecutable :: Verbosity
-> FilePath
-> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo
-> Maybe PathTemplate -- ^ template for HTML location
-> Version
-> IO HaddockArgs
fromExecutable verbosity tmp lbi exe clbi htmlTemplate = do
fromExecutable verbosity tmp lbi exe clbi htmlTemplate haddockVersion = do
inFiles <- map snd `fmap` getExeSourceFiles lbi exe
ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate
let vanillaOpts = (componentGhcOptions normal lbi bi clbi (buildDir lbi)) {
......@@ -359,7 +303,7 @@ fromExecutable verbosity tmp lbi exe clbi htmlTemplate = do
ghcOptObjDir = toFlag tmp,
ghcOptHiDir = toFlag tmp,
ghcOptStubDir = toFlag tmp
}
} `mappend` getGhcCppOpts haddockVersion bi
sharedOpts = vanillaOpts {
ghcOptDynLinkMode = toFlag GhcDynamicOnly,
ghcOptFPic = toFlag True,
......@@ -412,15 +356,27 @@ getInterfaces verbosity lbi clbi htmlTemplate = do
argInterfaces = packageFlags
}
getGhcCppOpts :: Version
-> BuildInfo
-> GhcOptions
getGhcCppOpts haddockVersion bi =
mempty {
ghcOptExtensions = [EnableExtension CPP | needsCpp],
ghcOptCppOptions = defines
}
where
needsCpp = EnableExtension CPP `elem` usedExtensions bi
defines = [haddockVersionMacro]
haddockVersionMacro = "-D__HADDOCK_VERSION__="
++ show (v1 * 1000 + v2 * 10 + v3)
where
[v1, v2, v3] = take 3 $ versionBranch haddockVersion ++ [0,0]
getGhcLibDir :: Verbosity -> LocalBuildInfo
-> Bool -- ^ are we using haddock-2.x ?
-> IO HaddockArgs
getGhcLibDir verbosity lbi isVersion2
| isVersion2 =
do l <- ghcLibDir verbosity lbi
return $ mempty { argGhcLibDir = Flag l }
| otherwise =
return mempty
getGhcLibDir verbosity lbi = do
l <- ghcLibDir verbosity lbi
return $ mempty { argGhcLibDir = Flag l }
-- ------------------------------------------------------------------------------
-- | Call haddock with the specified arguments.
......@@ -458,7 +414,6 @@ renderArgs verbosity tmpFileOpts version comp args k = do
let pflag = "--prologue=" ++ prologFileName
k (pflag : renderPureArgs version comp args, result)
where
isVersion2 = version >= Version [2,0] []
outputDir = (unDir $ argOutputDir args)
result = intercalate ", "
. map (\o -> outputDir </>
......@@ -467,8 +422,7 @@ renderArgs verbosity tmpFileOpts version comp args k = do
Hoogle -> pkgstr <.> "txt")
$ arg argOutput
where
pkgstr | isVersion2 = display $ packageName pkgid
| otherwise = display pkgid
pkgstr = display $ packageName pkgid
pkgid = arg argPackageName
arg f = fromFlag $ f args
......@@ -477,9 +431,8 @@ renderPureArgs version comp args = concat
[
(:[]) . (\f -> "--dump-interface="++ unDir (argOutputDir args) </> f)
. fromFlag . argInterfaceFile $ args,
(\pname -> if isVersion2
then ["--optghc=-package-name", "--optghc=" ++ pname]
else ["--package=" ++ pname]) . display . fromFlag . argPackageName $ args,
(\pname -> ["--optghc=-package-name", "--optghc=" ++ pname]
) . display . fromFlag . argPackageName $ args,
(\(All b,xs) -> bool (map (("--hide=" ++). display) xs) [] b) . argHideModules $ args,
bool ["--ignore-all-exports"] [] . getAny . argIgnoreExports $ args,
maybe [] (\(m,e,l) -> ["--source-module=" ++ m
......@@ -495,10 +448,9 @@ renderPureArgs version comp args = concat
(:[]).("--odir="++) . unDir . argOutputDir $ args,
(:[]).("--title="++) . (bool (++" (internal documentation)") id (getAny $ argIgnoreExports args))
. fromFlag . argTitle $ args,
[ "--optghc=" ++ opt | isVersion2
, (opts, _ghcVer) <- flagToList (argGhcOptions args)
[ "--optghc=" ++ opt | (opts, _ghcVer) <- flagToList (argGhcOptions args)
, opt <- renderGhcOptions comp opts ],
maybe [] (\l -> ["-B"++l]) $ guard isVersion2 >> flagToMaybe (argGhcLibDir args), -- error if isVersion2 and Nothing?
maybe [] (\l -> ["-B"++l]) $ flagToMaybe (argGhcLibDir args), -- error if Nothing?
argTargets $ args
]
where
......@@ -506,7 +458,6 @@ renderPureArgs version comp args = concat
map (\(i,mh) -> "--read-interface=" ++
maybe "" (++",") mh ++ i)
bool a b c = if c then a else b
isVersion2 = version >= Version [2,0] []
isVersion2_5 = version >= Version [2,5] []
isVersion2_14 = version >= Version [2,14] []
verbosityFlag
......
......@@ -172,6 +172,7 @@ buildLib verbosity pkg_descr lbi lib clbi = do
| (ipkgid, _) <- componentPackageDeps clbi ] ++
["-G", display language] ++
concat [ ["-X", display ex] | ex <- usedExtensions bi ] ++
cppOptions (libBuildInfo lib) ++
[ display modu | modu <- libModules lib ]
......
......@@ -54,10 +54,10 @@ import Distribution.Simple.Utils
, findFileWithExtension, findFileWithExtension' )
import Distribution.Simple.Program
( Program(..), ConfiguredProgram(..), programPath
, lookupProgram, requireProgram, requireProgramVersion
, requireProgram, requireProgramVersion
, rawSystemProgramConf, rawSystemProgram
, greencardProgram, cpphsProgram, hsc2hsProgram, c2hsProgram
, happyProgram, alexProgram, haddockProgram, ghcProgram, gccProgram )
, happyProgram, alexProgram, ghcProgram, gccProgram )
import Distribution.Simple.Test.LibV09
( writeSimpleTestStub, stubFilePath, stubName )
import Distribution.System
......@@ -355,7 +355,6 @@ ppGhcCpp extraArgs _bi lbi =
-- double-unlitted. In the future we might switch to
-- using cpphs --unlit instead.
++ (if ghcVersion >= Version [6,6] [] then ["-x", "hs"] else [])
++ (if use_optP_P lbi then ["-optP-P"] else [])
++ [ "-optP-include", "-optP"++ (autogenModulesDir lbi </> cppHeaderName) ]
++ ["-o", outFile, inFile]
++ extraArgs
......@@ -377,16 +376,6 @@ ppCpphs extraArgs _bi lbi =
++ extraArgs
}
-- Haddock versions before 0.8 choke on #line and #file pragmas. Those
-- pragmas are necessary for correct links when we preprocess. So use
-- -optP-P only if the Haddock version is prior to 0.8.
use_optP_P :: LocalBuildInfo -> Bool
use_optP_P lbi
= case lookupProgram haddockProgram (withPrograms lbi) of
Just (ConfiguredProgram { programVersion = Just version })
| version >= Version [0,8] [] -> False
_ -> True
ppHsc2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor
ppHsc2hs bi lbi =
PreProcessor {
......
......@@ -34,6 +34,7 @@ module Distribution.Simple.Program.Db (
knownPrograms,
getProgramSearchPath,
setProgramSearchPath,
modifyProgramSearchPath,
userSpecifyPath,
userSpecifyPaths,
userMaybeSpecifyPath,
......@@ -185,6 +186,16 @@ getProgramSearchPath = progSearchPath
setProgramSearchPath :: ProgramSearchPath -> ProgramDb -> ProgramDb
setProgramSearchPath searchpath db = db { progSearchPath = searchpath }
-- | Modify the current 'ProgramSearchPath' used by the 'ProgramDb'.
-- This will affect programs that are configured from here on, so you
-- should usually modify it before configuring any programs.
--
modifyProgramSearchPath :: (ProgramSearchPath -> ProgramSearchPath)
-> ProgramDb
-> ProgramDb
modifyProgramSearchPath f db =
setProgramSearchPath (f $ getProgramSearchPath db) db
-- |User-specify this path. Basically override any path information
-- for this program in the configuration. If it's not a known
-- program ignore it.
......
......@@ -132,9 +132,9 @@ expose verbosity hcPkg packagedb pkgid =
(exposeInvocation hcPkg verbosity packagedb pkgid)
-- | Call @hc-pkg@ to expose a package.
-- | Call @hc-pkg@ to hide a package.
--
-- > hc-pkg expose [pkgid] [--user | --global | --package-db]
-- > hc-pkg hide [pkgid] [--user | --global | --package-db]
--
hide :: Verbosity -> ConfiguredProgram -> PackageDB -> PackageId -> IO ()
hide verbosity hcPkg packagedb pkgid =
......
......@@ -1167,7 +1167,7 @@ haddockCommand = makeCommand name shortDesc longDesc defaultHaddockFlags options
where
name = "haddock"
shortDesc = "Generate Haddock HTML documentation."
longDesc = Just $ \_ -> "Requires the program haddock, either version 0.x or 2.x.\n"
longDesc = Just $ \_ -> "Requires the program haddock, version 2.x.\n"
options showOrParseArgs = haddockOptions showOrParseArgs
++ programConfigurationPaths progConf ParseArgs
haddockProgramPaths (\v flags -> flags { haddockProgramPaths = v})
......@@ -1573,9 +1573,6 @@ data TestFlags = TestFlags {
testMachineLog :: Flag PathTemplate,
testShowDetails :: Flag TestShowDetails,
testKeepTix :: Flag Bool,
--TODO: eliminate the test list and pass it directly as positional args to
--the testHook
testList :: Flag [String],
-- TODO: think about if/how options are passed to test exes
testOptions :: [PathTemplate]
}
......@@ -1588,7 +1585,6 @@ defaultTestFlags = TestFlags {
testMachineLog = toFlag $ toPathTemplate $ "$pkgid.log",
testShowDetails = toFlag Failures,
testKeepTix = toFlag False,
testList = Flag [],
testOptions = []
}
......@@ -1620,7 +1616,8 @@ testCommand = makeCommand name shortDesc longDesc defaultTestFlags options
, option [] ["show-details"]
("'always': always show results of individual test cases. "
++ "'never': never show results of individual test cases. "
++ "'failures': show results of failing test cases.")
++ "'failures': show results of failing test cases. "
++ "'streaming': show results of test cases in real time.")
testShowDetails (\v flags -> flags { testShowDetails = v })
(reqArg "FILTER"
(readP_to_E (\_ -> "--show-details flag expects one of "
......@@ -1660,7 +1657,6 @@ instance Monoid TestFlags where
testMachineLog = mempty,
testShowDetails = mempty,
testKeepTix = mempty,
testList = mempty,
testOptions = mempty
}
mappend a b = TestFlags {
......@@ -1670,7 +1666,6 @@ instance Monoid TestFlags where
testMachineLog = combine testMachineLog,
testShowDetails = combine testShowDetails,
testKeepTix = combine testKeepTix,
testList = combine testList,
testOptions = combine testOptions
}
where combine field = field a `mappend` field b
......
......@@ -27,6 +27,7 @@ import Distribution.Simple.InstallDirs
import qualified Distribution.Simple.LocalBuildInfo as LBI
( LocalBuildInfo(..) )
import Distribution.Simple.Setup ( TestFlags(..), fromFlag )
import Distribution.Simple.UserHooks ( Args )
import qualified Distribution.Simple.Test.ExeV10 as ExeV10
import qualified Distribution.Simple.Test.LibV09 as LibV09
import Distribution.Simple.Test.Log
......@@ -42,16 +43,17 @@ import System.Exit ( ExitCode(..), exitFailure, exitWith )
import System.FilePath ( (</>) )
-- |Perform the \"@.\/setup test@\" action.
test :: PD.PackageDescription -- ^information from the .cabal file
test :: Args -- ^positional command-line arguments
-> PD.PackageDescription -- ^information from the .cabal file
-> LBI.LocalBuildInfo -- ^information from the configure step
-> TestFlags -- ^flags sent to test
-> IO ()
test pkg_descr lbi flags = do
test args pkg_descr lbi flags = do
let verbosity = fromFlag $ testVerbosity flags
machineTemplate = fromFlag $ testMachineLog flags
distPref = fromFlag $ testDistPref flags
testLogDir = distPref </> "test"
testNames = fromFlag $ testList flags
testNames = args
pkgTests = PD.testSuites pkg_descr
enabledTests = [ t | t <- pkgTests
, PD.testEnabled t
......
......@@ -144,7 +144,7 @@ data UserHooks = UserHooks {
-- |Hook to run before test command.
preTest :: Args -> TestFlags -> IO HookedBuildInfo,
-- |Over-ride this hook to get different behavior during test.
testHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> TestFlags -> IO (),
testHook :: Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> TestFlags -> IO (),
-- |Hook to run after test command.
postTest :: Args -> TestFlags -> PackageDescription -> LocalBuildInfo -> IO (),
......@@ -200,7 +200,7 @@ emptyUserHooks
haddockHook = ru,
postHaddock = ru,
preTest = rn',
testHook = ru,
testHook = \_ -> ru,
postTest = ru,
preBench = rn',
benchHook = \_ -> ru,
......
......@@ -24,6 +24,7 @@ module Distribution.Simple.Utils (
topHandler, topHandlerWith,
warn, notice, setupMessage, info, debug,
debugNoWrap, chattyTry,
printRawCommandAndArgs,
-- * running programs
rawSystemExit,
......@@ -149,7 +150,7 @@ import System.Directory
import System.IO
( Handle, openFile, openBinaryFile, openBinaryTempFile
, IOMode(ReadMode), hSetBinaryMode
, hGetContents, stdin, stderr, stdout, hPutStr, hFlush, hClose )
, hGetContents, stderr, stdout, hPutStr, hFlush, hClose )
import System.IO.Error as IO.Error
( isDoesNotExistError, isAlreadyExistsError
, ioeSetFileName, ioeGetFileName, ioeGetErrorString )
......@@ -169,23 +170,12 @@ import Distribution.Version
(Version(..))
import Control.Exception (IOException, evaluate, throwIO)
import System.Process (rawSystem)
import qualified System.Process as Process (CreateProcess(..))
import Control.Concurrent (forkIO)
import System.Process (runInteractiveProcess, waitForProcess, proc,
StdStream(..))
#if __GLASGOW_HASKELL__ >= 702
import System.Process (showCommandForUser)
#endif
#ifndef mingw32_HOST_OS
import System.Posix.Signals (installHandler, sigINT, sigQUIT, Handler(..))
import System.Process.Internals (defaultSignal, runGenProcess_)
#else
import System.Process (createProcess)
#endif
import qualified System.Process as Process
( CreateProcess(..), StdStream(..), proc)
import System.Process
( createProcess, rawSystem, runInteractiveProcess
, showCommandForUser, waitForProcess)
import Distribution.Compat.CopyFile
( copyFile, copyOrdinaryFile, copyExecutableFile
, setFileOrdinary, setFileExecutable, setDirOrdinary )
......@@ -345,12 +335,7 @@ maybeExit cmd = do
printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO ()
printRawCommandAndArgs verbosity path args
| verbosity >= deafening = print (path, args)
| verbosity >= verbose =
#if __GLASGOW_HASKELL__ >= 702
putStrLn $ showCommandForUser path args
#else
putStrLn $ unwords (path : args)
#endif
| verbosity >= verbose = putStrLn $ showCommandForUser path args
| otherwise = return ()
printRawCommandAndArgsAndEnv :: Verbosity
......@@ -365,39 +350,6 @@ printRawCommandAndArgsAndEnv verbosity path args env
| otherwise = return ()
-- This is taken directly from the process package.
-- The reason we need it is that runProcess doesn't handle ^C in the same
-- way that rawSystem handles it, but rawSystem doesn't allow us to pass
-- an environment.
syncProcess :: String -> Process.CreateProcess -> IO ExitCode
#if mingw32_HOST_OS
syncProcess _fun c = do
(_,_,_,p) <- createProcess c
waitForProcess p
#else
syncProcess fun c = do
-- The POSIX version of system needs to do some manipulation of signal
-- handlers. Since we're going to be synchronously waiting for the child,
-- we want to ignore ^C in the parent, but handle it the default way
-- in the child (using SIG_DFL isn't really correct, it should be the
-- original signal handler, but the GHC RTS will have already set up
-- its own handler and we don't want to use that).
r <- Exception.bracket (installHandlers) (restoreHandlers) $
(\_ -> do (_,_,_,p) <- runGenProcess_ fun c
(Just defaultSignal) (Just defaultSignal)
waitForProcess p)
return r
where
installHandlers = do
old_int <- installHandler sigINT Ignore Nothing
old_quit <- installHandler sigQUIT Ignore Nothing
return (old_int, old_quit)
restoreHandlers (old_int, old_quit) = do
_ <- installHandler sigINT old_int Nothing
_ <- installHandler sigQUIT old_quit Nothing
return ()
#endif /* mingw32_HOST_OS */
-- Exit with the same exit code if the subcommand fails
rawSystemExit :: Verbosity -> FilePath -> [String] -> IO ()
rawSystemExit verbosity path args = do
......@@ -425,8 +377,10 @@ rawSystemExitWithEnv :: Verbosity
rawSystemExitWithEnv verbosity path args env = do
printRawCommandAndArgsAndEnv verbosity path args env
hFlush stdout
exitcode <- syncProcess "rawSystemExitWithEnv" (proc path args)
{ Process.env = Just env }
(_,_,_,ph) <- createProcess $
(Process.proc path args) { Process.env = (Just env)
, Process.delegate_ctlc = True }
exitcode <- waitForProcess ph
unless (exitcode == ExitSuccess) $ do
debug verbosity $ path ++ " returned " ++ show exitcode
exitWith exitcode
......@@ -445,26 +399,20 @@ rawSystemIOWithEnv verbosity path args mcwd menv inp out err = do
maybe (printRawCommandAndArgs verbosity path args)
(printRawCommandAndArgsAndEnv verbosity path args) menv
hFlush stdout
exitcode <- syncProcess "rawSystemIOWithEnv" (proc path args)
{ Process.cwd = mcwd
, Process.env = menv
, Process.std_in = mbToStd inp
, Process.std_out = mbToStd out
, Process.std_err = mbToStd err }
`Exception.finally` (mapM_ maybeClose [inp, out, err])
(_,_,_,ph) <- createProcess $
(Process.proc path args) { Process.cwd = mcwd
, Process.env = menv
, Process.std_in = mbToStd inp
, Process.std_out = mbToStd out
, Process.std_err = mbToStd err
, Process.delegate_ctlc = True }
exitcode <- waitForProcess ph
unless (exitcode == ExitSuccess) $ do
debug verbosity $ path ++ " returned " ++ show exitcode
return exitcode
where
-- Also taken from System.Process
maybeClose :: Maybe Handle -> IO ()
maybeClose (Just hdl)
| hdl /= stdin && hdl /= stdout && hdl /= stderr = hClose hdl
maybeClose _ = return ()
mbToStd :: Maybe Handle -> StdStream
mbToStd Nothing = Inherit
mbToStd (Just hdl) = UseHandle hdl
mbToStd :: Maybe Handle -> Process.StdStream
mbToStd = maybe Process.Inherit Process.UseHandle
-- | Run a command and return its output.
--
......