1module Darcs.Util.Exception
2    ( firstJustIO
3    , catchall
4    , catchNonExistence
5    , clarifyErrors
6    , prettyException
7    , prettyError
8    , die
9    , handleOnly
10    , handleOnlyIOError
11    , ifIOError
12    , ifDoesNotExistError
13    ) where
14
15
16import Darcs.Prelude
17
18import Control.Exception
19    ( Exception(fromException)
20    , SomeException
21    , catch
22    , handle
23    , throwIO
24    )
25import Data.Maybe ( isJust )
26
27import System.Exit ( exitFailure )
28import System.IO ( stderr, hPutStrLn )
29import System.IO.Error
30    ( ioeGetErrorString
31    , ioeGetFileName
32    , isDoesNotExistError
33    , isUserError
34    )
35
36import Darcs.Util.SignalHandler ( catchNonSignal )
37
38catchall :: IO a
39         -> IO a
40         -> IO a
41a `catchall` b = a `catchNonSignal` (\_ -> b)
42
43catchNonExistence :: IO a -> a -> IO a
44catchNonExistence job nonexistval =
45    catch job $
46    \e -> if isDoesNotExistError e then return nonexistval
47                                   else ioError e
48
49-- | The firstJustM returns the first Just entry in a list of monadic
50-- operations. This is close to `listToMaybe `fmap` sequence`, but the sequence
51-- operator evaluates all monadic members of the list before passing it along
52-- (i.e. sequence is strict). The firstJustM is lazy in that list member monads
53-- are only evaluated up to the point where the first Just entry is obtained.
54firstJustM :: Monad m
55           => [m (Maybe a)]
56           -> m (Maybe a)
57firstJustM [] = return Nothing
58firstJustM (e:es) = e >>= (\v -> if isJust v then return v else firstJustM es)
59
60
61-- | The firstJustIO is a slight modification to firstJustM: the entries in the
62-- list must be IO monad operations and the firstJustIO will silently turn any
63-- monad call that throws an exception into Nothing, basically causing it to be
64-- ignored.
65firstJustIO :: [IO (Maybe a)]
66            -> IO (Maybe a)
67firstJustIO = firstJustM . map (`catchall` return Nothing)
68
69
70clarifyErrors :: IO a
71              -> String
72              -> IO a
73clarifyErrors a e = a `catch` (\x -> die $ unlines [prettyException x,e])
74
75prettyException :: SomeException
76                -> String
77prettyException e | Just ioe <- fromException e, isUserError ioe = ioeGetErrorString ioe
78prettyException e | Just ioe <- fromException e, isDoesNotExistError ioe =
79  case ioeGetFileName ioe of
80    Just f  -> f ++ " does not exist"
81    Nothing -> show e
82prettyException e = show e
83
84
85prettyError :: IOError -> String
86prettyError e | isUserError e = ioeGetErrorString e
87              | otherwise = show e
88
89-- | Terminate the program with an error message.
90die :: String -> IO a
91die msg = hPutStrLn stderr msg >> exitFailure
92
93-- | Handle only actual IO exceptions i.e. not "user errors" e.g. those raised
94-- by calling 'fail'.
95--
96-- We use 'fail' all over the place to signify erroneous conditions and we
97-- normally don't want to handle such errors.
98handleOnlyIOError :: IO a -> IO a -> IO a
99handleOnlyIOError = handleOnly (not . isUserError)
100
101-- | Like 'handleOnlyIOError' but restricted to returning a given value.
102ifIOError :: a -> IO a -> IO a
103ifIOError use_instead = handleOnlyIOError (return use_instead)
104
105-- | Like 'ifIOError' but restricted to handling non-existence.
106ifDoesNotExistError :: a -> IO a -> IO a
107ifDoesNotExistError use_instead = handleOnly isDoesNotExistError (return use_instead)
108
109-- | Handle only a those exceptions for which the predicate succeeds.
110handleOnly :: Exception e => (e -> Bool) -> IO a -> IO a -> IO a
111handleOnly pred handler = handle (\e -> if pred e then handler else throwIO e)
112