Commit c8c99e8d authored by Ian Lynagh's avatar Ian Lynagh
Browse files

Be better about exiting if a command we run fails

parent ba91a28f
......@@ -62,13 +62,12 @@ import Distribution.PackageDescription (setupMessage, PackageDescription(..),
Library(..), withLib, libModules)
import Distribution.Compiler (CompilerFlavor(..), Compiler(..))
import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..))
import Distribution.Simple.Utils (rawSystemVerbose,
import Distribution.Simple.Utils (rawSystemExit,
moduleToFilePath, die, dieWithLocation)
import Distribution.Version (Version(..))
import Control.Monad (unless)
import Control.Monad (when, unless)
import Data.Maybe (fromMaybe)
import Data.List (nub)
import System.Exit (ExitCode(..))
import System.Directory (removeFile, getModificationTime)
import System.Info (os, arch)
import Distribution.Compat.FilePath
......@@ -91,7 +90,7 @@ import Distribution.Compat.FilePath
type PreProcessor = FilePath -- Location of the source file in need of preprocessing
-> FilePath -- Output filename
-> Int -- verbose
-> IO ExitCode
-> IO () -- Should exit if the preprocessor fails
-- |A preprocessor for turning non-Haskell files with the given extension
......@@ -111,23 +110,19 @@ preprocessSources pkg_descr lbi verbose handlers = do
withLib pkg_descr () $ \ lib -> do
setupMessage verbose "Preprocessing library" pkg_descr
let bi = libBuildInfo lib
let biHandlers = localHandlers bi
sequence_ [do retVal <- preprocessModule (hsSourceDirs bi) modu
verbose builtinSuffixes biHandlers
unless (retVal == ExitSuccess)
(die $ "got error code while preprocessing: " ++ modu)
| modu <- libModules pkg_descr]
let biHandlers = localHandlers bi
sequence_ [ preprocessModule (hsSourceDirs bi) modu
verbose builtinSuffixes biHandlers
| modu <- libModules pkg_descr]
unless (null (executables pkg_descr)) $
setupMessage verbose "Preprocessing executables for" pkg_descr
withExe pkg_descr $ \ theExe -> do
let bi = buildInfo theExe
let biHandlers = localHandlers bi
sequence_ [do retVal <- preprocessModule (nub $ (hsSourceDirs bi)
++(maybe [] (hsSourceDirs . libBuildInfo) (library pkg_descr)))
let biHandlers = localHandlers bi
sequence_ [ preprocessModule (nub $ (hsSourceDirs bi)
++ (maybe [] (hsSourceDirs . libBuildInfo) (library pkg_descr)))
modu verbose builtinSuffixes biHandlers
unless (retVal == ExitSuccess)
(die $ "got error code while preprocessing: " ++ modu)
| modu <- otherModules bi]
| modu <- otherModules bi]
where hc = compilerFlavor (compiler lbi)
builtinSuffixes
| hc == NHC = ["hs", "lhs", "gc"]
......@@ -142,14 +137,14 @@ preprocessModule
-> Int -- ^verbose
-> [String] -- ^builtin suffixes
-> [(String, PreProcessor)] -- ^possible preprocessors
-> IO ExitCode
-> IO ()
preprocessModule searchLoc modu verbose builtinSuffixes handlers = do
bsrcFiles <- moduleToFilePath searchLoc modu builtinSuffixes
psrcFiles <- moduleToFilePath searchLoc modu (map fst handlers)
case psrcFiles of
[] -> case bsrcFiles of
[] -> die ("can't find source for " ++ modu ++ " in " ++ show searchLoc)
_ -> return ExitSuccess
_ -> return ()
(psrcFile:_) -> do
let (srcStem, ext) = splitFileExt psrcFile
pp = fromMaybe (error "Internal error in preProcess module: Just expected")
......@@ -160,9 +155,7 @@ preprocessModule searchLoc modu verbose builtinSuffixes handlers = do
btime <- getModificationTime bsrcFile
ptime <- getModificationTime psrcFile
return (btime < ptime)
if recomp
then pp psrcFile (srcStem `joinFileExt` "hs") verbose
else return ExitSuccess
when recomp $ pp psrcFile (srcStem `joinFileExt` "hs") verbose
removePreprocessedPackage :: PackageDescription
-> FilePath -- ^root of source tree (where to look for hsSources)
......@@ -202,7 +195,7 @@ ppGreenCard' :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor
ppGreenCard' inputArgs _ lbi
= maybe (ppNone "greencard") pp (withGreencard lbi)
where pp greencard inFile outFile verbose
= rawSystemVerbose verbose greencard
= rawSystemExit verbose greencard
(["-tffi", "-o" ++ outFile, inFile] ++ inputArgs)
-- This one is useful for preprocessors that can't handle literate source.
......@@ -211,7 +204,6 @@ ppUnlit :: PreProcessor
ppUnlit inFile outFile _verbose = do
contents <- readFile inFile
writeFile outFile (unlit inFile contents)
return ExitSuccess
ppCpp :: BuildInfo -> LocalBuildInfo -> PreProcessor
ppCpp = ppCpp' []
......@@ -226,8 +218,8 @@ ppCpp' inputArgs bi lbi =
hc = compiler lbi
use_cpphs cpphs inFile outFile verbose
= rawSystemVerbose verbose cpphs cpphsArgs
where cpphsArgs = ("-O"++outFile) : inFile : "--noline" : "--strip"
= rawSystemExit verbose cpphs cpphsArgs
where cpphsArgs = ("-O" ++ outFile) : inFile : "--noline" : "--strip"
: extraArgs
extraArgs = sysDefines ++ cppOptions bi lbi ++ inputArgs
......@@ -239,7 +231,7 @@ ppCpp' inputArgs bi lbi =
use_ghc inFile outFile verbose
= do p_p <- use_optP_P lbi
rawSystemVerbose verbose (compilerPath hc)
rawSystemExit verbose (compilerPath hc)
(["-E", "-cpp"] ++
-- This is a bit of an ugly hack. We're going to
-- unlit the file ourselves later on if appropriate,
......@@ -321,7 +313,7 @@ ppAlex _ lbi
standardPP :: String -> [String] -> PreProcessor
standardPP eName args inFile outFile verbose
= rawSystemVerbose verbose eName (args ++ ["-o", outFile, inFile])
= rawSystemExit verbose eName (args ++ ["-o", outFile, inFile])
ppNone :: String -> PreProcessor
ppNone name inFile _ _ =
......
......@@ -63,7 +63,7 @@ module Distribution.Program(
import qualified Distribution.Compat.Map as Map
import Distribution.Compat.Directory(findExecutable)
import Distribution.Simple.Utils (die, rawSystemVerbose, maybeExit)
import Distribution.Simple.Utils (die, rawSystemExit)
-- |Represents a program which cabal may call.
data Program
......@@ -275,12 +275,12 @@ rawSystemProgram :: Int -- ^Verbosity
rawSystemProgram verbose (Program { programLocation=(UserSpecified p)
, programArgs=args
}) extraArgs
= maybeExit $ rawSystemVerbose verbose p (extraArgs ++ args)
= rawSystemExit verbose p (extraArgs ++ args)
rawSystemProgram verbose (Program { programLocation=(FoundOnSystem p)
, programArgs=args
}) extraArgs
= maybeExit $ rawSystemVerbose verbose p (args ++ extraArgs)
= rawSystemExit verbose p (args ++ extraArgs)
rawSystemProgram _ (Program { programLocation=EmptyLocation
, programName=n}) _
......
......@@ -91,12 +91,14 @@ import Distribution.Simple.Configure(getPersistBuildConfig, maybeGetPersistBuild
import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), distPref,
srcPref, haddockPref )
import Distribution.Simple.Install(install)
import Distribution.Simple.Utils (die, currentDir, rawSystemVerbose,
import Distribution.Simple.Utils (die, currentDir,
defaultPackageDesc, defaultHookedPackageDesc,
moduleToFilePath, findFile, warn)
#if mingw32_HOST_OS || mingw32_TARGET_OS
import Distribution.Simple.Utils (rawSystemPath)
import Distribution.Simple.Utils (rawSystemPathExit)
#else
import Distribution.Simple.Utils (rawSystemExit)
#endif
import Language.Haskell.Extension
-- Base
......@@ -490,7 +492,7 @@ haddock pkg_descr lbi hooks (HaddockFlags hoogle verbose) = do
createDirectoryIfMissing True targetDir
if (needsCpp pkg_descr)
then ppCpp' inputArgs bi lbi file targetFile verbose
else copyFile file targetFile >> return ExitSuccess
else copyFile file targetFile
when (targetFileExt == "lhs") $ do
ppUnlit targetFile (joinFileExt targetFileNoext "hs") verbose
return ()
......@@ -689,14 +691,13 @@ autoconfUserHooks
#if mingw32_HOST_OS || mingw32_TARGET_OS
-- FIXME: hack for script files under MinGW
-- This assumes sh (check for #! line?)
rawSystemPath verbose "sh" ("configure" : args')
rawSystemPathExit verbose "sh" ("configure" : args')
#else
-- FIXME: should we really be discarding the exit code?
rawSystemVerbose verbose "./configure" args'
rawSystemExit verbose "./configure" args'
#endif
else do
else
no_extra_flags args
return ExitSuccess
return ExitSuccess
readHook :: (a -> Int) -> Args -> a -> IO HookedBuildInfo
readHook verbose a flags = do
......
......@@ -55,7 +55,7 @@ import Distribution.PackageDescription
libModules, hcOptions )
import Distribution.Simple.LocalBuildInfo
( LocalBuildInfo(..), autogenModulesDir, mkIncludeDir )
import Distribution.Simple.Utils( rawSystemExit, rawSystemPath,
import Distribution.Simple.Utils( rawSystemExit, rawSystemPathExit,
#if defined(mingw32_TARGET_OS) || defined(mingw32_HOST_OS)
rawSystemVerbose,
#endif
......@@ -218,17 +218,15 @@ build pkg_descr lbi verbose = do
runLd ld args = do
exists <- doesFileExist ghciLibName
status <- rawSystemLd verbose ld
rawSystemLd verbose ld
(args ++ if exists then [ghciLibName] else [])
when (status == ExitSuccess)
(renameFile (ghciLibName `joinFileExt` "tmp") ghciLibName)
return status
renameFile (ghciLibName `joinFileExt` "tmp") ghciLibName
#if defined(mingw32_TARGET_OS) || defined(mingw32_HOST_OS)
rawSystemLd = rawSystemVerbose
rawSystemLd = rawSystemExit
maxCommandLineSize = 30 * 1024
#else
rawSystemLd = rawSystemPath
rawSystemLd = rawSystemPathExit
--TODO: discover this at configure time on unix
maxCommandLineSize = 30 * 1024
#endif
......@@ -249,13 +247,13 @@ build pkg_descr lbi verbose = do
#endif
mbAr <- lookupProgram "ar" (withPrograms lbi)
let arProg = case fmap programLocation mbAr of { Just (UserSpecified x) -> x ; _ -> "ar" }
ifVanillaLib False $ maybeExit $ xargs maxCommandLineSize
(rawSystemPath verbose) arProg arArgs arObjArgs
ifVanillaLib False $ xargs maxCommandLineSize
(rawSystemPathExit verbose) arProg arArgs arObjArgs
ifProfLib $ maybeExit $ xargs maxCommandLineSize
(rawSystemPath verbose) arProg arProfArgs arProfObjArgs
ifProfLib $ xargs maxCommandLineSize
(rawSystemPathExit verbose) arProg arProfArgs arProfObjArgs
ifGHCiLib $ maybeExit $ xargs maxCommandLineSize
ifGHCiLib $ xargs maxCommandLineSize
runLd ld ldArgs ldObjArgs
-- build any executables
......
......@@ -63,16 +63,16 @@ import Distribution.PackageDescription
import Distribution.Package (showPackageId, PackageIdentifier(pkgVersion))
import Distribution.Version (Version(versionBranch))
import Distribution.Simple.Utils (smartCopySources, die, findPackageDesc,
findFile, copyFileVerbose, rawSystemPath)
findFile, copyFileVerbose, rawSystemPathExit)
import Distribution.Setup (SDistFlags(..))
import Distribution.PreProcess (PPSuffixHandler, ppSuffixes, removePreprocessed)
import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) )
import Distribution.Program ( lookupProgram, ProgramLocation(..), Program(programLocation) )
import Control.Exception (finally)
import Control.Monad(when)
import Data.Char (isSpace, toLower)
import Data.List (isPrefixOf)
import System.Exit (ExitCode(..))
import System.Time (getClockTime, toCalendarTime, CalendarTime(..))
import Distribution.Compat.Directory (doesFileExist, doesDirectoryExist,
getCurrentDirectory, createDirectoryIfMissing, removeDirectoryRecursive)
......@@ -190,24 +190,12 @@ createArchive pkg_descr verbose mb_lbi tmpDir targetPref = do
-- Hmm: I could well be skating on thinner ice here by using the -C option (=> GNU tar-specific?)
-- [The prev. solution used pipes and sub-command sequences to set up the paths correctly,
-- which is problematic in a Windows setting.]
ret <- rawSystemPath verbose tarProgram
rawSystemPathExit verbose tarProgram
["-C", tmpDir, "-czf", tarBallFilePath, nameVersion pkg_descr]
removeDirectoryRecursive tmpDir
case ret of
ExitSuccess -> do
putStrLn $ "Source tarball created: " ++ tarBallFilePath
return tarBallFilePath
ExitFailure n -> die ("source tarball creation failed! Tar exited " ++
"with status " ++ show n)
where
appendVersion :: Int -> String -> String
appendVersion n line
| "version:" `isPrefixOf` map toLower line =
trimTrailingSpace line ++ "." ++ show n
| otherwise = line
trimTrailingSpace :: String -> String
trimTrailingSpace = reverse . dropWhile isSpace . reverse
-- XXX this should be done back where tmpDir is made, not here
`finally` removeDirectoryRecursive tmpDir
putStrLn $ "Source tarball created: " ++ tarBallFilePath
return tarBallFilePath
-- |Move the sources into place based on buildInfo
prepareDir :: Int -- ^verbose
......
......@@ -45,8 +45,6 @@ module Distribution.Simple.Utils (
die,
dieWithLocation,
warn,
rawSystemPath,
rawSystemVerbose,
rawSystemExit,
maybeExit,
xargs,
......@@ -99,8 +97,7 @@ import Distribution.Compat.FilePath
(splitFileName, splitFileExt, joinFileName, joinFileExt, joinPaths,
pathSeparator,splitFilePath)
import System.Directory (getDirectoryContents, getCurrentDirectory
, doesDirectoryExist, doesFileExist, removeFile, getPermissions
, Permissions(executable))
, doesDirectoryExist, doesFileExist, removeFile)
import Distribution.Compat.Directory
(copyFile, findExecutable, createDirectoryIfMissing,
......@@ -131,31 +128,10 @@ warn verbosity msg = do
-- -----------------------------------------------------------------------------
-- rawSystem variants
rawSystemPath :: Int -> String -> [String] -> IO ExitCode
rawSystemPath verbose prog args = do
r <- findExecutable prog
case r of
Nothing -> die ("Cannot find: " ++ prog)
Just path -> rawSystemVerbose verbose path args
rawSystemVerbose :: Int -> FilePath -> [String] -> IO ExitCode
rawSystemVerbose verbose prog args = do
when (verbose > 0) $
putStrLn (prog ++ concatMap (' ':) args)
e <- doesFileExist prog
if e
then do perms <- getPermissions prog
if (executable perms)
then rawSystem prog args
else die ("Error: file is not executable: " ++ show prog)
else die ("Error: file does not exist: " ++ show prog)
maybeExit :: IO ExitCode -> IO ()
maybeExit cmd = do
res <- cmd
if res /= ExitSuccess
then exitWith res
else return ()
unless (res == ExitSuccess) $ exitWith res
-- Exit with the same exitcode if the subcommand fails
rawSystemExit :: Int -> FilePath -> [String] -> IO ()
......@@ -167,7 +143,10 @@ rawSystemExit verbose path args = do
-- Exit with the same exitcode if the subcommand fails
rawSystemPathExit :: Int -> String -> [String] -> IO ()
rawSystemPathExit verbose prog args = do
maybeExit $ rawSystemPath verbose prog args
r <- findExecutable prog
case r of
Nothing -> die ("Cannot find: " ++ prog)
Just path -> rawSystemExit verbose path args
-- | Like the unix xargs program. Useful for when we've got very long command
-- lines that might overflow an OS limit on command line length and so you
......@@ -175,20 +154,14 @@ rawSystemPathExit verbose prog args = do
--
-- Use it with either of the rawSystem variants above. For example:
--
-- > xargs (32*1024) (rawSystemPath verbose) prog fixedArgs bigArgs
-- > xargs (32*1024) (rawSystemPathExit verbose) prog fixedArgs bigArgs
--
xargs :: Int -> (FilePath -> [String] -> IO ExitCode)
-> FilePath -> [String] -> [String] -> IO ExitCode
xargs :: Int -> (FilePath -> [String] -> IO ())
-> FilePath -> [String] -> [String] -> IO ()
xargs maxSize rawSystemFun prog fixedArgs bigArgs =
let fixedArgSize = sum (map length fixedArgs) + length fixedArgs
chunkSize = maxSize - fixedArgSize
loop [] = return ExitSuccess
loop (args:remainingArgs) = do
status <- rawSystemFun prog (fixedArgs ++ args)
case status of
ExitSuccess -> loop remainingArgs
_ -> return status
in loop (chunks chunkSize bigArgs)
in mapM_ (rawSystemFun prog . (fixedArgs ++)) (chunks chunkSize bigArgs)
where chunks len = unfoldr $ \s ->
if null s then Nothing
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment