Allow building with base 4

Distribution/Client/Install.hs

@@ -21,7 +21,18 @@ import Data.Maybe
          ( isJust, fromMaybe )
 import qualified Data.Map as Map
 import Control.Exception as Exception
-         ( handle, handleJust, Exception(IOException) )
+         ( handleJust )
+#if MIN_VERSION_base(4,0,0)
+import Control.Exception as Exception
+         ( Exception(toException), catches, Handler(Handler), IOException )
+import System.Exit
+         ( ExitCode )
+#else
+import Control.Exception as Exception
+         ( Exception(IOException, ExitException) )
+#endif
+import Distribution.Compat.Exception
+         ( SomeException, catchIO, catchExit )
 import Control.Monad
          ( when, unless )
 import System.Directory
@@ -294,7 +305,11 @@ storeDetailedBuildReports verbosity logsDir reports = sequence_
       warn verbosity $ "Missing log file for build report: "
                     ++ fromMaybe ""  (ioeGetFileName ioe)
 
+#if MIN_VERSION_base(4,0,0)
+    missingFile ioe
+#else
     missingFile (IOException ioe)
+#endif
       | isDoesNotExistError ioe  = Just ioe
     missingFile _                = Nothing
 
@@ -645,9 +660,10 @@ installUnpackedPackage verbosity scriptOptions miscOptions
 
   -- Doc generation phase
       docsResult <- if shouldHaddock
-        then Exception.handle (\_ -> return DocsFailed) $ do
-               setup haddockCommand haddockFlags
-               return DocsOk
+        then (do setup haddockCommand haddockFlags
+                 return DocsOk)
+               `catchIO`   (\_ -> return DocsFailed)
+               `catchExit` (\_ -> return DocsFailed)
         else return DocsNotTried
 
   -- Tests phase
@@ -710,9 +726,21 @@ installUnpackedPackage verbosity scriptOptions miscOptions
         else die $ "Unable to find cabal executable at: " ++ self
 
 -- helper
-onFailure :: (Exception -> BuildFailure) -> IO BuildResult -> IO BuildResult
-onFailure result = Exception.handle (return . Left . result)
-
+onFailure :: (SomeException -> BuildFailure) -> IO BuildResult -> IO BuildResult
+onFailure result action =
+#if MIN_VERSION_base(4,0,0)
+  action `catches`
+    [ Handler $ \ioe  -> handler (ioe  :: IOException)
+    , Handler $ \exit -> handler (exit :: ExitCode)
+    ]
+  where
+    handler :: Exception e => e -> IO BuildResult
+    handler = return . Left . result . toException
+#else
+  action
+    `catchIO`   (return . Left . result . IOException)
+    `catchExit` (return . Left . result . ExitException)
+#endif
 
 withWin32SelfUpgrade :: Verbosity
                      -> ConfigFlags

Distribution/Client/Types.hs

@@ -26,8 +26,8 @@ import Distribution.Version
 
 import Data.Map (Map)
 import Network.URI (URI)
-import Control.Exception
-         ( Exception )
+import Distribution.Compat.Exception
+         ( SomeException )
 
 newtype Username = Username { unUsername :: String }
 newtype Password = Password { unPassword :: String }
@@ -137,11 +137,11 @@ data UnresolvedDependency
 
 type BuildResult  = Either BuildFailure BuildSuccess
 data BuildFailure = DependentFailed PackageId
-                  | DownloadFailed  Exception
-                  | UnpackFailed    Exception
-                  | ConfigureFailed Exception
-                  | BuildFailed     Exception
-                  | InstallFailed   Exception
+                  | DownloadFailed  SomeException
+                  | UnpackFailed    SomeException
+                  | ConfigureFailed SomeException
+                  | BuildFailed     SomeException
+                  | InstallFailed   SomeException
 data BuildSuccess = BuildOk         DocsResult TestsResult
 
 data DocsResult  = DocsNotTried  | DocsFailed  | DocsOk

Distribution/Client/Utils.hs

@@ -17,8 +17,9 @@ import System.Directory
 import Distribution.Compat.TempFile
          ( createTempDirectory )
 import qualified Control.Exception as Exception
-         ( handle, throwIO, evaluate, finally, bracket )
-
+         ( evaluate, finally, bracket )
+import qualified Distribution.Compat.Exception as Exception
+         ( onException )
 -- | Generic merging utility. For sorted input lists this is a full outer join.
 --
 -- * The result list never contains @(Nothing, Nothing)@.
@@ -51,9 +52,8 @@ duplicatesBy cmp = filter moreThanOne . groupBy eq . sortBy cmp
 writeFileAtomic :: FilePath -> BS.ByteString -> IO ()
 writeFileAtomic targetFile content = do
   (tmpFile, tmpHandle) <- openBinaryTempFile targetDir template
-  Exception.handle (\err -> do hClose tmpHandle
-                               removeFile tmpFile
-                               Exception.throwIO err) $ do
+  Exception.onException (do hClose tmpHandle
+                            removeFile tmpFile) $ do
       BS.hPut tmpHandle content
       hClose tmpHandle
       renameFile tmpFile targetFile

Distribution/Compat/Exception.hs

@@ -0,0 +1,52 @@
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -cpp #-}
+{-# OPTIONS_NHC98 -cpp #-}
+{-# OPTIONS_JHC -fcpp #-}
+-- #hide
+module Distribution.Compat.Exception (
+  SomeException,
+  onException,
+  catchIO,
+  catchExit,
+  throwIOIO
+  ) where
+
+import System.Exit
+import qualified Control.Exception as Exception
+#if MIN_VERSION_base(4,0,0)
+import Control.Exception (SomeException)
+#else
+import Control.Exception (Exception)
+type SomeException = Exception
+#endif
+
+onException :: IO a -> IO b -> IO a
+#if MIN_VERSION_base(4,0,0)
+onException = Exception.onException
+#else
+onException io what = io `Exception.catch` \e -> do what
+                                                    Exception.throw e
+#endif
+
+throwIOIO :: Exception.IOException -> IO a
+#if MIN_VERSION_base(4,0,0)
+throwIOIO = Exception.throwIO
+#else
+throwIOIO = Exception.throwIO . Exception.IOException
+#endif
+
+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
+#if MIN_VERSION_base(4,0,0)
+catchIO = Exception.catch
+#else
+catchIO = Exception.catchJust Exception.ioErrors
+#endif
+
+catchExit :: IO a -> (ExitCode -> IO a) -> IO a
+#if MIN_VERSION_base(4,0,0)
+catchExit = Exception.catch
+#else
+catchExit = Exception.catchJust exitExceptions
+    where exitExceptions (Exception.ExitException ee) = Just ee
+          exitExceptions _                            = Nothing
+#endif

cabal-install.cabal

@@ -79,7 +79,7 @@ Executable cabal
         Distribution.Compat.TempFile
         Paths_cabal_install
 
-    build-depends: base >= 2 && < 4,
+    build-depends: base >= 2 && < 5,
                    Cabal >= 1.7.5 && < 1.9,
                    filepath >= 1.0,
                    network >= 1 && < 3,