1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89

{-# LANGUAGE CPP #-}
-- | For when you gotta catch 'em all
--
-- Also defines an orphan 'Alternative' instance for 'IO'
module Pokemon (SomeException, Exception, pokemonException, tryPokemonIO) where

import Control.Applicative
#ifdef __GLASGOW_HASKELL__
import Control.Exception hiding (catch)
import System.Exit
import qualified Control.Exception (catch)
#else
-- Stub types and classes for Haskell98
type SomeException = IOError

class Exception e where
	toException :: e -> SomeException
	fromException :: SomeException -> Maybe e

instance Exception IOError where
	toException = id
	fromException = Just
#endif

-- | Describes the class of exceptions that should be caught when you
--   need to catch 'em all.
pokemonException :: SomeException -> SomeException
#ifdef __GLASGOW_HASKELL__
pokemonException e =
	let Just r =
		fmap rethrowArithException (fromException e) <|>
		fmap rethrowErrorCall (fromException e) <|>
		fmap rethrowExitCode (fromException e) <|>
		fmap rethrowArrayException (fromException e) <|>
		fmap rethrowAsyncException (fromException e) <|>
		fmap rethrowAssertionFailed (fromException e) <|>
		fmap rethrowDeadlock (fromException e) <|>
		fmap rethrowBlockedIndefinitelyOnSTM (fromException e) <|>
		fmap rethrowBlockedIndefinitelyOnMVar (fromException e) <|>
		fmap rethrowNestedAtomically (fromException e) <|>
		fmap rethrowNoMethodError (fromException e) <|>
		fmap rethrowRecUpdError (fromException e) <|>
		fmap rethrowRecConError (fromException e) <|>
		fmap rethrowRecSelError (fromException e) <|>
		fmap rethrowPatternMatchFail (fromException e) <|>
		Just e
	in
		r
	where
	rethrowArithException = throw :: ArithException -> a
	rethrowErrorCall = throw :: ErrorCall -> a
	rethrowExitCode = throw :: ExitCode -> a
	rethrowArrayException = throw :: ArrayException -> a
	rethrowAsyncException = throw :: AsyncException -> a
	rethrowAssertionFailed = throw :: AssertionFailed -> a
	rethrowDeadlock = throw :: Deadlock -> a
	rethrowBlockedIndefinitelyOnSTM = throw :: BlockedIndefinitelyOnSTM -> a
	rethrowBlockedIndefinitelyOnMVar = throw :: BlockedIndefinitelyOnMVar -> a
	rethrowNestedAtomically = throw :: NestedAtomically -> a
	rethrowNoMethodError = throw :: NoMethodError -> a
	rethrowRecUpdError = throw :: RecUpdError -> a
	rethrowRecConError = throw :: RecConError -> a
	rethrowRecSelError = throw :: RecSelError -> a
	rethrowPatternMatchFail = throw :: PatternMatchFail -> a
#else
-- Nothing to rethrow in Haskell98
pokemonException = id
#endif

-- | Catch 'em all and produce 'Either'
tryPokemonIO :: IO a -> IO (Either SomeException a)
tryPokemonIO io = fmap Right io
#ifdef __GLASGOW_HASKELL__
	`Control.Exception.catch`
#else
	`catch`
#endif
	(\e -> return $! Left $! pokemonException e)

-- If you catch one, do this instead
instance Alternative IO where
	empty = ioError (userError "IO Alternative empty")
	a <|> b = a
#ifdef __GLASGOW_HASKELL__
		`Control.Exception.catch`
#else
		`catch`
#endif
		(\e -> (return $! pokemonException e) >> b)