{- Simple IO exception handling (and some more)
 -
 - Copyright 2011-2015 Joey Hess <id@joeyh.name>
 -
 - License: BSD-2-clause
 -}

{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}

module Utility.Exception (
	module X,
	catchBoolIO,
	catchMaybeIO,
	catchDefaultIO,
	catchMsgIO,
	catchIO,
	tryIO,
	bracketIO,
	catchNonAsync,
	tryNonAsync,
	tryWhenExists,
	catchHardwareFault,
) where

import Control.Monad.Catch as X hiding (Handler)
import qualified Control.Monad.Catch as M
import Control.Exception (IOException, AsyncException)
import Control.Monad
import Control.Monad.IO.Class (liftIO, MonadIO)
import System.IO.Error (isDoesNotExistError, ioeGetErrorType)
import GHC.IO.Exception (IOErrorType(..))

{- Catches IO errors and returns a Bool -}
catchBoolIO :: MonadCatch m => m Bool -> m Bool
catchBoolIO :: forall (m :: * -> *). MonadCatch m => m Bool -> m Bool
catchBoolIO = forall (m :: * -> *) a. MonadCatch m => a -> m a -> m a
catchDefaultIO Bool
False

{- Catches IO errors and returns a Maybe -}
catchMaybeIO :: MonadCatch m => m a -> m (Maybe a)
catchMaybeIO :: forall (m :: * -> *) a. MonadCatch m => m a -> m (Maybe a)
catchMaybeIO m a
a = forall (m :: * -> *) a. MonadCatch m => a -> m a -> m a
catchDefaultIO forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ m a
a forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just)

{- Catches IO errors and returns a default value. -}
catchDefaultIO :: MonadCatch m => a -> m a -> m a
catchDefaultIO :: forall (m :: * -> *) a. MonadCatch m => a -> m a -> m a
catchDefaultIO a
def m a
a = forall (m :: * -> *) a.
MonadCatch m =>
m a -> (IOException -> m a) -> m a
catchIO m a
a (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return a
def)

{- Catches IO errors and returns the error message. -}
catchMsgIO :: MonadCatch m => m a -> m (Either String a)
catchMsgIO :: forall (m :: * -> *) a. MonadCatch m => m a -> m (Either String a)
catchMsgIO m a
a = do
	Either IOException a
v <- forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either IOException a)
tryIO m a
a
	forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) forall a b. b -> Either a b
Right Either IOException a
v

{- catch specialized for IO errors only -}
catchIO :: MonadCatch m => m a -> (IOException -> m a) -> m a
catchIO :: forall (m :: * -> *) a.
MonadCatch m =>
m a -> (IOException -> m a) -> m a
catchIO = forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
M.catch

{- try specialized for IO errors only -}
tryIO :: MonadCatch m => m a -> m (Either IOException a)
tryIO :: forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either IOException a)
tryIO = forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
M.try

{- bracket with setup and cleanup actions lifted to IO.
 -
 - Note that unlike catchIO and tryIO, this catches all exceptions. -}
bracketIO :: (MonadMask m, MonadIO m) => IO v -> (v -> IO b) -> (v -> m a) -> m a
bracketIO :: forall (m :: * -> *) v b a.
(MonadMask m, MonadIO m) =>
IO v -> (v -> IO b) -> (v -> m a) -> m a
bracketIO IO v
setup v -> IO b
cleanup = forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO v
setup) (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> IO b
cleanup)

{- Catches all exceptions except for async exceptions.
 - This is often better to use than catching them all, so that
 - ThreadKilled and UserInterrupt get through.
 -}
catchNonAsync :: MonadCatch m => m a -> (SomeException -> m a) -> m a
catchNonAsync :: forall (m :: * -> *) a.
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
catchNonAsync m a
a SomeException -> m a
onerr = m a
a forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, MonadCatch m) =>
m a -> f (Handler m a) -> m a
`catches`
	[ forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
M.Handler (\ (AsyncException
e :: AsyncException) -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM AsyncException
e)
	, forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
M.Handler (\ (SomeException
e :: SomeException) -> SomeException -> m a
onerr SomeException
e)
	]

tryNonAsync :: MonadCatch m => m a -> m (Either SomeException a)
tryNonAsync :: forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either SomeException a)
tryNonAsync m a
a = forall {a}. m (Either a a)
go forall (m :: * -> *) a.
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
`catchNonAsync` (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left)
  where
	go :: m (Either a a)
go = do
		a
v <- m a
a
		forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right a
v)

{- Catches only DoesNotExist exceptions, and lets all others through. -}
tryWhenExists :: MonadCatch m => m a -> m (Maybe a)
tryWhenExists :: forall (m :: * -> *) a. MonadCatch m => m a -> m (Maybe a)
tryWhenExists m a
a = do
	Either () a
v <- forall (m :: * -> *) e b a.
(MonadCatch m, Exception e) =>
(e -> Maybe b) -> m a -> m (Either b a)
tryJust (forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> Bool
isDoesNotExistError) m a
a
	forall (m :: * -> *) a. Monad m => a -> m a
return (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just Either () a
v)

{- Catches only exceptions caused by hardware faults.
 - Ie, disk IO error. -}
catchHardwareFault :: MonadCatch m => m a -> (IOException -> m a) -> m a
catchHardwareFault :: forall (m :: * -> *) a.
MonadCatch m =>
m a -> (IOException -> m a) -> m a
catchHardwareFault m a
a IOException -> m a
onhardwareerr = forall (m :: * -> *) a.
MonadCatch m =>
m a -> (IOException -> m a) -> m a
catchIO m a
a IOException -> m a
onlyhw
  where
	onlyhw :: IOException -> m a
onlyhw IOException
e
		| IOException -> IOErrorType
ioeGetErrorType IOException
e forall a. Eq a => a -> a -> Bool
== IOErrorType
HardwareFault = IOException -> m a
onhardwareerr IOException
e
		| Bool
otherwise = forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM IOException
e