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
|
-----------------------------------------------------------------------------
-- IO monad extensions:
--
-- Suitable for use with Hugs 1.4.
-----------------------------------------------------------------------------
module IOExts
( fixIO
, unsafePerformIO
, unsafeInterleaveIO
, IORef
-- instance Eq (MutVar a)
, newIORef
, readIORef
, writeIORef
, performGC
, trace
, unsafePtrEq
) where
import Trace( trace )
import IO( ioeGetErrorString )
primitive performGC "primGC" :: IO ()
unsafePerformIO :: IO a -> a
unsafePerformIO m = performIO (runAndShowError m)
unsafeInterleaveIO :: IO a -> IO a
unsafeInterleaveIO m = interleaveIO (runAndShowError m)
primitive unsafePtrEq :: a -> a -> Bool
fixIO :: (a -> IO a) -> IO a
fixIO m = IO fixIO'
where
fixIO' fail succ =
case r of
Hugs_Return a -> succ a
Hugs_Error err -> fail err
other -> other
where
r = case m a of { IO ma -> ma Hugs_Error Hugs_Return }
a = case r of
Hugs_Return a -> a
Hugs_Error err -> error "IOExts:fixIO: thread exited with error"
_ -> error "IOExts:fixIO: thread exited with no result"
performIO :: IO a -> a
performIO (IO m) =
case m Hugs_Error Hugs_Return of
Hugs_Return a -> a
Hugs_Error err -> error "IOExts.performIO: thread exited with error"
_ -> error "IOExts.performIO: thread exited with no result"
interleaveIO :: IO a -> IO a
interleaveIO (IO m) = IO (\ f s ->
s (case m Hugs_Error Hugs_Return of
Hugs_Return a -> a
Hugs_Error err -> error "IOExts.interleaveIO: thread exited with error"
_ -> error "IOExts.interleaveIO: thread exited with no result"
))
runAndShowError :: IO a -> IO a
runAndShowError m =
m `catch` \err -> do
putChar '\n'
putStr (ioeGetErrorString err)
return undefined
data IORef a -- mutable variables containing values of type a
primitive newIORef "newRef" :: a -> IO (IORef a)
primitive readIORef "getRef" :: IORef a -> IO a
primitive writeIORef "setRef" :: IORef a -> a -> IO ()
primitive eqIORef "eqRef" :: IORef a -> IORef a -> Bool
instance Eq (IORef a) where
(==) = eqIORef
-----------------------------------------------------------------------------
|
