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