Commit 067a960e authored by Ian Lynagh's avatar Ian Lynagh
Browse files

Make Cabal compatible with extensible exceptions

The code is now also more correct, e.g. when we are ignoring IO exceptions
while trying to delete something, we don't also ignore timeout exceptions.
parent 5efb687d
......@@ -93,6 +93,7 @@ Library
Other-Modules:
Distribution.GetOpt,
Distribution.Compat.Exception,
Distribution.Compat.TempFile,
Distribution.Simple.GHC.Makefile,
Distribution.Simple.GHC.IPI641,
......
{-# OPTIONS -cpp #-}
-- OPTIONS required for ghc-6.4.x compat, and must appear first
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -cpp #-}
{-# OPTIONS_NHC98 -cpp #-}
{-# OPTIONS_JHC -fcpp #-}
#if !defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ >= 609)
#define NEW_EXCEPTION
#endif
module Distribution.Compat.Exception
(onException, catchIO, catchExit)
where
import System.Exit
import Control.Exception as Exception
#ifndef NEW_EXCEPTION
onException :: IO a -> IO () -> IO a
onException io what = io `Exception.catch` \e -> do what
Exception.throw e
#endif
catchIO :: IO a -> (IOException -> IO a) -> IO a
#ifdef NEW_EXCEPTION
catchIO = Exception.catch
#else
catchIO io handler = io `Exception.catch` handler'
where handler' (IOException ioe) = handler ioe
handler' e = throw e
#endif
catchExit :: IO a -> (ExitCode -> IO a) -> IO a
#ifdef NEW_EXCEPTION
catchExit = Exception.catch
#else
catchExit io handler = io `Exception.catch` handler'
where handler' (ExitException ee) = handler ee
handler' e = throw e
#endif
......@@ -121,8 +121,6 @@ import qualified Distribution.Simple.Hugs as Hugs
import Control.Monad
( when, unless, foldM )
import Control.Exception as Exception
( catch )
import Data.List
( nub, partition, isPrefixOf, maximumBy )
import Data.Maybe
......@@ -143,6 +141,7 @@ import Distribution.Text
( Text(disp), display, simpleParse )
import Text.PrettyPrint.HughesPJ
( comma, punctuate, render, nest, sep )
import Distribution.Compat.Exception ( catchIO )
import Prelude hiding (catch)
......@@ -558,7 +557,7 @@ configurePkgconfigPackages verbosity pkg_descr conf
requirePkg dep@(Dependency (PackageName pkg) range) = do
version <- pkgconfig ["--modversion", pkg]
`Exception.catch` \_ -> die notFound
`catchIO` \_ -> die notFound
case simpleParse version of
Nothing -> die "parsing output of pkg-config --modversion failed"
Just v | not (withinRange v range) -> die (badVersion v)
......
......@@ -127,9 +127,7 @@ import System.Exit ( ExitCode(..) )
import System.FilePath ( (</>), (<.>), takeExtension,
takeDirectory, replaceExtension, splitExtension )
import System.IO (openFile, IOMode(WriteMode), hClose, hPutStrLn)
import qualified Control.Exception as Exception (catch)
import Control.Exception as Exception
( handle, try, Exception(..) )
import Distribution.Compat.Exception (catchExit, catchIO)
-- -----------------------------------------------------------------------------
-- Configuring
......@@ -184,11 +182,12 @@ configure verbosity hcPath hcPkgPath conf = do
rawSystemProgram verbosity ghcProg ["-c", testcfile,
"-o", testofile]
withTempFile tempDir ".o" $ \testofile' testohnd' ->
handle (\_ -> return False) $ do
do
hClose testohnd'
rawSystemProgramStdout verbosity ldProg
["-x", "-r", testofile, "-o", testofile']
return True
`catchIO` (\_ -> return False)
let conf''''' = updateProgram ldProg {
programArgs = if ldx then ["-x"] else []
} conf''''
......@@ -323,9 +322,9 @@ getInstalledPackages' verbosity packagedbs conf
sequence
[ do str <- rawSystemProgramStdoutConf verbosity ghcPkgProgram conf
["describe", "*", packageDbGhcPkgFlag packagedb]
`Exception.catch` \e ->
`catchExit` \e ->
case e of
ExitException (ExitFailure 2) ->
ExitFailure 2 ->
-- exit code 2 means no packages found
return ""
_ -> die $
......@@ -506,7 +505,7 @@ build pkg_descr lbi verbosity = do
unless (null hObjs && null cObjs && null stubObjs) $ do
-- first remove library files if they exists
sequence_
[ try (removeFile libFilePath)
[ removeFile libFilePath `catchIO` \_ -> return ()
| libFilePath <- [vanillaLibFilePath, profileLibFilePath
,sharedLibFilePath, ghciLibFilePath] ]
......
......@@ -81,12 +81,11 @@ import Distribution.Verbosity
import Data.Char ( isSpace )
import Data.Maybe ( mapMaybe, catMaybes )
import Control.Monad ( unless, when, filterM )
import Control.Exception ( try )
import Data.List ( nub, sort, isSuffixOf )
import System.Directory ( Permissions(..), getPermissions,
setPermissions, copyFile,
removeDirectoryRecursive )
import Distribution.Compat.Exception
-- -----------------------------------------------------------------------------
-- Configuring
......@@ -362,7 +361,7 @@ install
-> PackageDescription
-> IO ()
install verbosity libDir installProgDir binDir targetProgDir buildPref (progprefix,progsuffix) pkg_descr = do
try $ removeDirectoryRecursive libDir
removeDirectoryRecursive libDir `catchIO` \_ -> return ()
smartCopySources verbosity [buildPref] libDir (libModules pkg_descr) hugsInstallSuffixes
let buildProgDir = buildPref </> "programs"
when (any (buildable . buildInfo) (executables pkg_descr)) $
......@@ -371,7 +370,7 @@ install verbosity libDir installProgDir binDir targetProgDir buildPref (progpref
let theBuildDir = buildProgDir </> exeName exe
let installDir = installProgDir </> exeName exe
let targetDir = targetProgDir </> exeName exe
try $ removeDirectoryRecursive installDir
removeDirectoryRecursive installDir `catchIO` \_ -> return ()
smartCopySources verbosity [theBuildDir] installDir
(ModuleName.main : autogenModuleName pkg_descr
: otherModules (buildInfo exe))
......
......@@ -81,9 +81,9 @@ import System.FilePath
import System.Directory
( removeFile )
import Control.Exception (try)
import Data.List ( nub )
import Control.Monad ( when, unless )
import Distribution.Compat.Exception
-- -----------------------------------------------------------------------------
-- Configuring
......@@ -179,7 +179,8 @@ build pkg_descr lbi verbosity = do
| m <- modules ]
unless (null hObjs {-&& null cObjs-}) $ do
try (removeFile libFilePath) -- first remove library if it exists
-- first remove library if it exists
removeFile libFilePath `catchIO` \_ -> return ()
let arVerbosity | verbosity >= deafening = "v"
| verbosity >= normal = ""
......
......@@ -105,7 +105,7 @@ import Distribution.Verbosity
import System.Directory
( doesFileExist, findExecutable )
import Control.Monad (join, foldM)
import qualified Control.Exception as Exception (catch)
import Distribution.Compat.Exception (catchIO)
-- | Represents a program which can be configured.
data Program = Program {
......@@ -190,7 +190,7 @@ findProgramVersion :: ProgArg -- ^ version args
-> IO (Maybe Version)
findProgramVersion versionArg selectVersion verbosity path = do
str <- rawSystemStdout verbosity path [versionArg]
`Exception.catch` \_ -> return ""
`catchIO` \_ -> return ""
let version :: Maybe Version
version = simpleParse (selectVersion str)
case version of
......
......@@ -145,7 +145,7 @@ import System.IO
import System.IO.Error as IO.Error
( try )
import qualified Control.Exception as Exception
( bracket, bracket_, catch, handle, throwIO )
( bracket, bracket_, catch, handle, finally, throwIO )
import Distribution.Text
( display )
......@@ -166,6 +166,7 @@ import System.Directory (getTemporaryDirectory)
#endif
import Distribution.Compat.TempFile (openTempFile, openBinaryTempFile)
import Distribution.Compat.Exception (catchIO, onException)
import Distribution.Verbosity
-- We only get our own version number when we're building with ourselves
......@@ -248,7 +249,7 @@ chattyTry :: String -- ^ a description of the action we were attempting
-> IO () -- ^ the action itself
-> IO ()
chattyTry desc action =
Exception.catch action $ \exception ->
catchIO action $ \exception ->
putStrLn $ "Error while " ++ desc ++ ": " ++ show exception
-- -----------------------------------------------------------------------------
......@@ -613,10 +614,7 @@ withFileContents name action =
writeFileAtomic :: FilePath -> String -> IO ()
writeFileAtomic targetFile content = do
(tmpFile, tmpHandle) <- openBinaryTempFile targetDir template
Exception.handle (\err -> do hClose tmpHandle
removeFile tmpFile
Exception.throwIO err) $ do
hPutStr tmpHandle content
do hPutStr tmpHandle content
hClose tmpHandle
#if mingw32_HOST_OS || mingw32_TARGET_OS
renameFile tmpFile targetFile
......@@ -633,6 +631,8 @@ writeFileAtomic targetFile content = do
#else
renameFile tmpFile targetFile
#endif
`onException` do hClose tmpHandle
removeFile tmpFile
where
template = targetName <.> "tmp"
targetDir | null targetDir_ = currentDir
......
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