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.

Cabal.cabal

@@ -93,6 +93,7 @@ Library
 
   Other-Modules:
         Distribution.GetOpt,
+        Distribution.Compat.Exception,
         Distribution.Compat.TempFile,
         Distribution.Simple.GHC.Makefile,
         Distribution.Simple.GHC.IPI641,

Distribution/Compat/Exception.hs

+{-# 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
+

Distribution/Simple/Configure.hs

@@ -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)

Distribution/Simple/GHC.hs

@@ -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] ]
 

Distribution/Simple/Hugs.hs

@@ -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))

Distribution/Simple/NHC.hs

@@ -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 = ""

Distribution/Simple/Program.hs

@@ -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

Distribution/Simple/Utils.hs

@@ -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