Merge branch 'master' into type-nats
[packages/base.git] / tests / exceptionsrun002.hs
1 module Main where
2
3 import qualified Control.Exception as Exception
4 import System.IO.Error (mkIOError)
5 import Data.IORef
6 import Prelude
7
8 safeCatch :: IO () -> IO ()
9 safeCatch f = Exception.catch f
10 ((\_ -> return ()) :: Exception.SomeException -> IO ())
11
12 type Thrower = IO Bool
13
14 type Catcher = IO Bool -> IO () -> IO ()
15
16 checkCatch :: Catcher -> Thrower -> IO Bool
17 checkCatch catcher thrower = do
18 ref <- newIORef False
19 safeCatch (catcher thrower (writeIORef ref True))
20 readIORef ref
21
22 data Named a = MkNamed String a
23
24 checkNamedCatch :: Named Catcher -> Named Thrower -> IO ()
25 checkNamedCatch (MkNamed cname catcher) (MkNamed tname thrower) = do
26 didCatch <- checkCatch catcher thrower
27 putStrLn (cname ++ (if didCatch then " CAUGHT " else " MISSED ") ++ tname)
28
29 checkNamedCatches :: [Named Catcher] -> [Named Thrower] -> IO ()
30 checkNamedCatches [] _ = return ()
31 checkNamedCatches _ [] = return ()
32 checkNamedCatches [c] (t:tr) = do checkNamedCatch c t
33 checkNamedCatches [c] tr
34 checkNamedCatches (c:cr) ts = do checkNamedCatches [c] ts
35 checkNamedCatches cr ts
36
37
38 -- throwers
39
40 returnThrower :: Named Thrower
41 returnThrower = MkNamed "return" (return True)
42
43 returnUndefinedThrower :: Named Thrower
44 returnUndefinedThrower = MkNamed "return undefined" (return undefined)
45
46 returnErrorThrower :: Named Thrower
47 returnErrorThrower = MkNamed "return error" (return (error "some error"))
48
49 undefinedThrower :: Named Thrower
50 undefinedThrower = MkNamed "undefined" undefined
51
52 failThrower :: Named Thrower
53 failThrower = MkNamed "fail" (fail "some failure")
54
55 errorThrower :: Named Thrower
56 errorThrower = MkNamed "error" (error "some error")
57
58 throwThrower :: Named Thrower
59 throwThrower = MkNamed "Exception.throw"
60 (Exception.throw (Exception.ErrorCall "throw error"))
61
62 ioErrorErrorCallThrower :: Named Thrower
63 ioErrorErrorCallThrower = MkNamed "ioError ErrorCall"
64 (Exception.throwIO (Exception.ErrorCall "throw error"))
65
66 ioErrorIOExceptionThrower :: Named Thrower
67 ioErrorIOExceptionThrower = MkNamed "ioError IOException"
68 (Exception.throwIO (mkIOError undefined undefined undefined undefined))
69
70 returnThrowThrower :: Named Thrower
71 returnThrowThrower = MkNamed "return Exception.throw"
72 (return (Exception.throw (Exception.ErrorCall "throw error")))
73
74
75 -- catchers
76
77 bindCatcher :: Named Catcher
78 bindCatcher = MkNamed ">>" (>>)
79
80 preludeCatchCatcher :: Named Catcher
81 preludeCatchCatcher = MkNamed "Prelude.catch"
82 (\f cc -> Prelude.catch (f >> (return ())) (const cc))
83
84 ceCatchCatcher :: Named Catcher
85 ceCatchCatcher = MkNamed "Exception.catch"
86 (\f cc -> Exception.catch (f >> (return ())) (const cc :: Exception.SomeException -> IO ()))
87
88 finallyCatcher :: Named Catcher
89 finallyCatcher = MkNamed "Exception.finally"
90 (\f cc -> Exception.finally (f >> (return ())) cc)
91
92 main = checkNamedCatches
93 [bindCatcher,preludeCatchCatcher,ceCatchCatcher,finallyCatcher]
94 [returnThrower,returnUndefinedThrower,returnThrowThrower,returnErrorThrower,failThrower,
95 errorThrower,throwThrower,ioErrorErrorCallThrower,ioErrorIOExceptionThrower,undefinedThrower]
96