Commit 75190409 authored by Duncan Coutts's avatar Duncan Coutts
Browse files

Allow building with base 4

parent 0d8b3a93
......@@ -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
......
......@@ -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
......
......@@ -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
......
{-# 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
......@@ -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,
......
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