IO exception rework

ghc 7.4 comaplains about use of System.IO.Error to catch exceptions.
Ok, use Control.Exception, with variants specialized to only catch IO
exceptions.

Annex/Content.hs

@@ -25,7 +25,6 @@ module Annex.Content (
 	preseedTmp,
 ) where
 
-import System.IO.Error (try)
 import Control.Exception (bracket_)
 import System.Posix.Types
 
@@ -79,7 +78,7 @@ lockContent key a = do
 	where
 		lock Nothing = return Nothing
 		lock (Just l) = do
-			v <- try $ setLock l (WriteLock, AbsoluteSeek, 0, 0)
+			v <- tryIO $ setLock l (WriteLock, AbsoluteSeek, 0, 0)
 			case v of
 				Left _ -> error "content is locked"
 				Right _ -> return $ Just l

Annex/Journal.hs

@@ -91,4 +91,4 @@ lockJournal a = do
 {- Runs an action, catching failure and running something to fix it up, and
  - retrying if necessary. -}
 doRedo :: IO a -> IO b -> IO a
-doRedo a b = catch a $ const $ b >> a
+doRedo a b = catchIO a $ const $ b >> a

Annex/Ssh.hs

@@ -11,7 +11,6 @@ module Annex.Ssh (
 ) where
 
 import qualified Data.Map as M
-import System.IO.Error (try)
 
 import Common.Annex
 import Annex.LockPool
@@ -72,7 +71,8 @@ sshCleanup = do
 			let lockfile = socket2lock socketfile
 			unlockFile lockfile
 			fd <- liftIO $ openFd lockfile ReadWrite (Just stdFileMode) defaultFileFlags
-			v <- liftIO $ try $ setLock fd (WriteLock, AbsoluteSeek, 0, 0)
+			v <- liftIO $ tryIO $
+				setLock fd (WriteLock, AbsoluteSeek, 0, 0)
 			case v of
 				Left _ -> return ()
 				Right _ -> stopssh socketfile

Backend.hs

@@ -16,7 +16,6 @@ module Backend (
 	maybeLookupBackendName
 ) where
 
-import System.IO.Error (try)
 import System.Posix.Files
 
 import Common.Annex
@@ -77,7 +76,7 @@ genKey' (b:bs) file = do
  - by examining what the file symlinks to. -}
 lookupFile :: FilePath -> Annex (Maybe (Key, Backend))
 lookupFile file = do
-	tl <- liftIO $ try getsymlink
+	tl <- liftIO $ tryIO getsymlink
 	case tl of
 		Left _ -> return Nothing
 		Right l -> makekey l

CmdLine.hs

@@ -11,7 +11,6 @@ module CmdLine (
 	shutdown
 ) where
 
-import qualified System.IO.Error as IO
 import qualified Control.Exception as E
 import Control.Exception (throw)
 import System.Console.GetOpt
@@ -74,7 +73,7 @@ tryRun' errnum _ cmd []
 	| otherwise = return ()
 tryRun' errnum state cmd (a:as) = run >>= handle
 	where
-		run = IO.try $ Annex.run state $ do
+		run = tryIO $ Annex.run state $ do
 			Annex.Queue.flushWhenFull
 			a
 		handle (Left err) = showerr err >> cont False state

Command/Fsck.hs

@@ -81,7 +81,7 @@ performRemote key file backend numcopies remote = do
 			t <- fromRepo gitAnnexTmpDir
 			let tmp = t </> "fsck" ++ show pid ++ "." ++ keyFile key
 			liftIO $ createDirectoryIfMissing True t
-			let cleanup = liftIO $ catch (removeFile tmp) (const $ return ())
+			let cleanup = liftIO $ catchIO (removeFile tmp) (const $ return ())
 			cleanup
 			cleanup `after` a tmp
 		getfile tmp = do

Common.hs

@@ -21,6 +21,7 @@ import System.Posix.Process as X hiding (executeFile)
 import System.Exit as X
 
 import Utility.Misc as X
+import Utility.Exception as X
 import Utility.SafeCommand as X
 import Utility.Path as X
 import Utility.Directory as X

Remote/Bup.hs

@@ -8,7 +8,6 @@
 module Remote.Bup (remote) where
 
 import qualified Data.ByteString.Lazy.Char8 as L
-import System.IO.Error
 import qualified Data.Map as M
 import System.Process
 
@@ -200,7 +199,7 @@ getBupUUID :: Git.Repo -> UUID -> Annex (UUID, Git.Repo)
 getBupUUID r u
 	| Git.repoIsUrl r = return (u, r)
 	| otherwise = liftIO $ do
-		ret <- try $ Git.Config.read r
+		ret <- tryIO $ Git.Config.read r
 		case ret of
 			Right r' -> return (toUUID $ Git.Config.get "annex.uuid" "" r', r')
 			Left _ -> return (NoUUID, r)

Upgrade/V0.hs

@@ -7,8 +7,6 @@
 
 module Upgrade.V0 where
 
-import System.IO.Error (try)
-
 import Common.Annex
 import Annex.Content
 import qualified Upgrade.V1
@@ -47,7 +45,7 @@ getKeysPresent0 dir = do
 			return $ map fileKey0 files
 	where
 		present d = do
-			result <- try $
+			result <- tryIO $
 				getFileStatus $ dir ++ "/" ++ takeFileName d
 			case result of
 				Right s -> return $ isRegularFile s

Upgrade/V1.hs

@@ -7,7 +7,6 @@
 
 module Upgrade.V1 where
 
-import System.IO.Error (try)
 import System.Posix.Types
 import Data.Char
 
@@ -183,7 +182,7 @@ readLog1 file = catchDefaultIO (parseLog <$> readFileStrict file) []
 
 lookupFile1 :: FilePath -> Annex (Maybe (Key, Backend))
 lookupFile1 file = do
-	tl <- liftIO $ try getsymlink
+	tl <- liftIO $ tryIO getsymlink
 	case tl of
 		Left _ -> return Nothing
 		Right l -> makekey l
@@ -216,7 +215,7 @@ getKeyFilesPresent1' dir = do
 			liftIO $ filterM present files
 	where
 		present f = do
-			result <- try $ getFileStatus f
+			result <- tryIO $ getFileStatus f
 			case result of
 				Right s -> return $ isRegularFile s
 				Left _ -> return False

Utility/Directory.hs

@@ -16,11 +16,12 @@ import Control.Monad.IfElse
 
 import Utility.SafeCommand
 import Utility.TempFile
+import Utility.Exception
 
 {- Moves one filename to another.
  - First tries a rename, but falls back to moving across devices if needed. -}
 moveFile :: FilePath -> FilePath -> IO ()
-moveFile src dest = try (rename src dest) >>= onrename
+moveFile src dest = tryIO (rename src dest) >>= onrename
 	where
 		onrename (Right _) = return ()
 		onrename (Left e)
@@ -40,11 +41,10 @@ moveFile src dest = try (rename src dest) >>= onrename
 						Param src, Param tmp]
 					unless ok $ do
 						-- delete any partial
-						_ <- try $
+						_ <- tryIO $ removeFile tmp
-							removeFile tmp
 						rethrow
 		isdir f = do
-			r <- try (getFileStatus f)
+			r <- tryIO $ getFileStatus f
 			case r of
 				(Left _) -> return False
 				(Right s) -> return $ isDirectory s

Utility/Exception.hs

@@ -0,0 +1,39 @@
+{- Simple IO exception handling
+ -
+ - Copyright 2011-2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Utility.Exception where
+
+import Prelude hiding (catch)
+import Control.Exception
+import Control.Applicative
+
+{- Catches IO errors and returns a Bool -}
+catchBoolIO :: IO Bool -> IO Bool
+catchBoolIO a = catchDefaultIO a False
+
+{- Catches IO errors and returns a Maybe -}
+catchMaybeIO :: IO a -> IO (Maybe a)
+catchMaybeIO a = catchDefaultIO (Just <$> a) Nothing
+
+{- Catches IO errors and returns a default value. -}
+catchDefaultIO :: IO a -> a -> IO a
+catchDefaultIO a def = catchIO a (const $ return def)
+
+{- Catches IO errors and returns the error message. -}
+catchMsgIO :: IO a -> IO (Either String a)
+catchMsgIO a = dispatch <$> tryIO a
+	where
+		dispatch (Left e) = Left $ show e
+		dispatch (Right v) = Right v
+
+{- catch specialized for IO errors only -}
+catchIO :: IO a -> (IOException -> IO a) -> IO a
+catchIO = catch
+
+{- try specialized for IO errors only -}
+tryIO :: IO a -> IO (Either IOException a)
+tryIO = try

Utility/Misc.hs

@@ -8,9 +8,7 @@
 module Utility.Misc where
 
 import System.IO
-import System.IO.Error (try)
 import Control.Monad
-import Control.Applicative
 
 {- A version of hgetContents that is not lazy. Ensures file is 
  - all read before it gets closed. -}
@@ -37,22 +35,3 @@ separate c l = unbreak $ break c l
 {- Breaks out the first line. -}
 firstLine :: String-> String
 firstLine = takeWhile (/= '\n')
-
-{- Catches IO errors and returns a Bool -}
-catchBoolIO :: IO Bool -> IO Bool
-catchBoolIO a = catchDefaultIO a False
-
-{- Catches IO errors and returns a Maybe -}
-catchMaybeIO :: IO a -> IO (Maybe a)
-catchMaybeIO a = catchDefaultIO (Just <$> a) Nothing
-
-{- Catches IO errors and returns a default value. -}
-catchDefaultIO :: IO a -> a -> IO a
-catchDefaultIO a def = catch a (const $ return def)
-
-{- Catches IO errors and returns the error message. -}
-catchMsgIO :: IO a -> IO (Either String a)
-catchMsgIO a = dispatch <$> try a
-	where
-		dispatch (Left e) = Left $ show e
-		dispatch (Right v) = Right v

Utility/TempFile.hs

@@ -12,7 +12,7 @@ import System.IO
 import System.Posix.Process hiding (executeFile)
 import System.Directory
 
-import Utility.Misc
+import Utility.Exception
 import Utility.Path
 
 {- Runs an action like writeFile, writing to a temp file first and