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
90
|
module GraphicsUtilities(
bracket, bracket_,
safeTry
) where
----------------------------------------------------------------
-- Safe and convenient routines to: allocate; use; deallocate
----------------------------------------------------------------
-- Run a computation "m" bracketed with setup code "left" and cleanup
-- code "right" making certain that "right" is executed if "left" was
-- executed successfully.
--
-- If no error occurs, this is equivalent to:
--
-- [ r | x <- left, r <- m x, right x ]
--
-- If an error occurs while executing "m x", this is equivalent to:
--
-- [ fail err | x <- left, err <- m' x, right x ]
--
-- where m' is that part of m which executes before the failure occurs.
--
-- ToDo: It would be very nice if these could catch other kinds of errors
-- too (pattern match failure, heap overflow, stack overflow, ...).
-- The "safeBind" operation below is _almost_ good enough to let
-- us write such a function. The big problem comes when you combine it with
-- concurrency - should we treat thread suspension as success or as failure.
-- (Neither works!)
bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket left right m = do
x <- left
rs <- safeTry (m x)
case rs of
Right r -> right x >> return r
Left e -> right x >> fail e
-- variant of the above where middle computation doesn't want x
bracket_ :: IO a -> (a -> IO b) -> IO c -> IO c
bracket_ left right m = do
x <- left
rs <- safeTry m
case rs of
Right r -> right x >> return r
Left e -> right x >> fail e
----------------------------------------------------------------
----------------------------------------------------------------
-- Safe Try
----------------------------------------------------------------
-- Run a computation and always succeed - even if we hit "error",
-- call "fail", or call "exitWith".
--
-- ToDo:
--
-- 1) catch heap/stack overflow and ctrl-C
--
-- 2) suspending a thread really shouldn't be treated like a kind
-- of error - but there's no other choice given the current
-- implementation of concurrency.
safeTry :: IO a -> IO (Either IOError a)
safeTry (IO m) = IO $ \ f s ->
case catchError (m Hugs_Error Hugs_Return) of
Just (Hugs_Return a) -> s (Right a)
r -> s (Left (mkErr r))
where
mkErr :: Maybe (IOResult a) -> IOError
mkErr (Just Hugs_SuspendThread) = userError "suspended inside protected code"
mkErr (Just (Hugs_ExitWith e)) = userError "exited inside protected code"
mkErr (Just (Hugs_Error e)) = e
mkErr Nothing = userError "pattern match failure inside protected code"
{-
-- here's the unmodified bindIO function for comparision
bindIO :: IO a -> (Maybe a -> IO b) -> IO b
bindIO (IO m) k = IO $ \ f s ->
case m Hugs_Error Hugs_Return of
Hugs_Return a -> case k (Just a) of { IO k' -> k' f s }
Hugs_SuspendThread -> Hugs_SuspendThread
Hugs_ExitWith e -> Hugs_ExitWith e
Hugs_Error e -> f e
-}
primitive catchError :: a -> Maybe a
|
