[commit: packages/Cabal] ghc-head: Add a generalised variant of 'topHandler'. (dd2a717)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/Cabal

On branch  : ghc-head
Link       : http://git.haskell.org/?p=packages/Cabal.git;a=commit;h=dd2a717ba282e8290d20027c10c9e3495cd44c87

>---------------------------------------------------------------

commit dd2a717ba282e8290d20027c10c9e3495cd44c87
Author: Mikhail Glushenkov <mikhail.glushenkov at gmail.com>
Date:   Mon May 13 11:23:44 2013 +0200

    Add a generalised variant of 'topHandler'.


>---------------------------------------------------------------

dd2a717ba282e8290d20027c10c9e3495cd44c87
 Cabal/Distribution/Simple/Utils.hs |   11 +++++++----
 1 file changed, 7 insertions(+), 4 deletions(-)

diff --git a/Cabal/Distribution/Simple/Utils.hs b/Cabal/Distribution/Simple/Utils.hs
index 82a1763..f1fb555 100644
--- a/Cabal/Distribution/Simple/Utils.hs
+++ b/Cabal/Distribution/Simple/Utils.hs
@@ -50,7 +50,7 @@ module Distribution.Simple.Utils (
         -- * logging and errors
         die,
         dieWithLocation,
-        topHandler,
+        topHandler, topHandlerWith,
         warn, notice, setupMessage, info, debug,
         debugNoWrap, chattyTry,
 
@@ -238,14 +238,14 @@ dieWithLocation filename lineno msg =
 die :: String -> IO a
 die msg = ioError (userError msg)
 
-topHandler :: IO a -> IO a
-topHandler prog = catchIO prog handle
+topHandlerWith :: (Exception.IOException -> IO a) -> IO a -> IO a
+topHandlerWith cont prog = catchIO prog handle
   where
     handle ioe = do
       hFlush stdout
       pname <- getProgName
       hPutStr stderr (mesage pname)
-      exitWith (ExitFailure 1)
+      cont ioe
       where
         mesage pname = wrapText (pname ++ ": " ++ file ++ detail)
         file         = case ioeGetFileName ioe of
@@ -256,6 +256,9 @@ topHandler prog = catchIO prog handle
                          _                              -> ""
         detail       = ioeGetErrorString ioe
 
+topHandler :: IO a -> IO a
+topHandler prog = topHandlerWith (const $ exitWith (ExitFailure 1)) prog
+
 -- | Non fatal conditions that may be indicative of an error or problem.
 --
 -- We display these at the 'normal' verbosity level.