IOEnv.hs 6.8 KB
Newer Older
1
2
3
4
5
6
7
8
9
-- (c) The University of Glasgow 2002
--
-- The IO Monad with an environment
--

module IOEnv (
	IOEnv,	-- Instance of Monad

	-- Standard combinators, specialised
10
	returnM, thenM, thenM_, failM, failWithM,
11
	mappM, mappM_, mapSndM, sequenceM, sequenceM_, 
12
	foldlM, foldrM,
13
	mapAndUnzipM, mapAndUnzip3M, 
14
	checkM, ifM, zipWithM, zipWithM_,
15
16
17
18
19

	-- Getting at the environment
	getEnv, setEnv, updEnv,

	runIOEnv, unsafeInterleaveM,			
20
	tryM, tryAllM, tryMostM, fixM, 
21
22
23
24
25
26
27

	-- I/O operations
	ioToIOEnv,
	IORef, newMutVar, readMutVar, writeMutVar, updMutVar
  ) where
#include "HsVersions.h"

28
import Panic		( try, tryUser, tryMost, Exception(..) )
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
import DATA_IOREF	( IORef, newIORef, readIORef, writeIORef )
import UNSAFE_IO	( unsafeInterleaveIO )
import FIX_IO		( fixIO )


----------------------------------------------------------------------
--		Defining the monad type
----------------------------------------------------------------------


newtype IOEnv env a = IOEnv (env -> IO a)
unIOEnv (IOEnv m) = m

instance Monad (IOEnv m) where
  (>>=)  = thenM
  (>>)   = thenM_
  return = returnM
  fail s = failM	-- Ignore the string

returnM :: a -> IOEnv env a
returnM a = IOEnv (\ env -> return a)

thenM :: IOEnv env a -> (a -> IOEnv env b) -> IOEnv env b
thenM (IOEnv m) f = IOEnv (\ env -> do { r <- m env ;
				       unIOEnv (f r) env })

thenM_ :: IOEnv env a -> IOEnv env b -> IOEnv env b
thenM_ (IOEnv m) f = IOEnv (\ env -> do { m env ; unIOEnv f env })

failM :: IOEnv env a
failM = IOEnv (\ env -> ioError (userError "IOEnv failure"))

61
62
63
failWithM :: String -> IOEnv env a
failWithM s = IOEnv (\ env -> ioError (userError s))

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


----------------------------------------------------------------------
--	Fundmantal combinators specific to the monad
----------------------------------------------------------------------


---------------------------
runIOEnv :: env -> IOEnv env a -> IO a
runIOEnv env (IOEnv m) = m env


---------------------------
{-# NOINLINE fixM #-}
  -- Aargh!  Not inlining fixTc alleviates a space leak problem.
  -- Normally fixTc is used with a lazy tuple match: if the optimiser is
  -- shown the definition of fixTc, it occasionally transforms the code
  -- in such a way that the code generator doesn't spot the selector
  -- thunks.  Sigh.

fixM :: (a -> IOEnv env a) -> IOEnv env a
fixM f = IOEnv (\ env -> fixIO (\ r -> unIOEnv (f r) env))


---------------------------
tryM :: IOEnv env r -> IOEnv env (Either Exception r)
90
91
92
93
94
95
96
97
98
99
100
101
-- Reflect UserError exceptions into IOEnv monad
-- The idea is that errors in the program being compiled will give rise
-- to UserErrors.  But, say, pattern-match failures in GHC itself should
-- not be caught here, else they'll be reported as errors in the program 
-- begin compiled!
tryM (IOEnv thing) = IOEnv (\ env -> tryUser (thing env))

tryAllM :: IOEnv env r -> IOEnv env (Either Exception r)
-- Catch *all* exceptions
-- This is used when running a Template-Haskell splice, when
-- even a pattern-match failure is a programmer error
tryAllM (IOEnv thing) = IOEnv (\ env -> try (thing env))
102

103
104
105
tryMostM :: IOEnv env r -> IOEnv env (Either Exception r)
tryMostM (IOEnv thing) = IOEnv (\ env -> tryMost (thing env))

106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
---------------------------
unsafeInterleaveM :: IOEnv env a -> IOEnv env a
unsafeInterleaveM (IOEnv m) = IOEnv (\ env -> unsafeInterleaveIO (m env))


----------------------------------------------------------------------
--	Accessing input/output
----------------------------------------------------------------------

ioToIOEnv :: IO a -> IOEnv env a
ioToIOEnv io = IOEnv (\ env -> io)

newMutVar :: a -> IOEnv env (IORef a)
newMutVar val = IOEnv (\ env -> newIORef val)

writeMutVar :: IORef a -> a -> IOEnv env ()
writeMutVar var val = IOEnv (\ env -> writeIORef var val)

readMutVar :: IORef a -> IOEnv env a
readMutVar var = IOEnv (\ env -> readIORef var)

updMutVar :: IORef a -> (a->a) -> IOEnv env ()
updMutVar var upd_fn = IOEnv (\ env -> do { v <- readIORef var; writeIORef var (upd_fn v) })


----------------------------------------------------------------------
--	Accessing the environment
----------------------------------------------------------------------

getEnv :: IOEnv env env
{-# INLINE getEnv #-}
getEnv = IOEnv (\ env -> return env)

setEnv :: env' -> IOEnv env' a -> IOEnv env a
{-# INLINE setEnv #-}
setEnv new_env (IOEnv m) = IOEnv (\ env -> m new_env)

updEnv :: (env -> env') -> IOEnv env' a -> IOEnv env a
{-# INLINE updEnv #-}
updEnv upd (IOEnv m) = IOEnv (\ env -> m (upd env))


----------------------------------------------------------------------
--	Standard combinators, but specialised for this monad
--			(for efficiency)
----------------------------------------------------------------------

mappM  	      :: (a -> IOEnv env b) -> [a] -> IOEnv env [b]
mappM_ 	      :: (a -> IOEnv env b) -> [a] -> IOEnv env ()
155
mapSndM       :: (b -> IOEnv env c) -> [(a,b)] -> IOEnv env [(a,c)]
156
157
	-- Funny names to avoid clash with Prelude
sequenceM     :: [IOEnv env a] -> IOEnv env [a]
158
sequenceM_    :: [IOEnv env a] -> IOEnv env ()
159
foldlM        :: (a -> b -> IOEnv env a)  -> a -> [b] -> IOEnv env a
160
foldrM        :: (b -> a -> IOEnv env a)  -> a -> [b] -> IOEnv env a
161
162
mapAndUnzipM  :: (a -> IOEnv env (b,c))   -> [a] -> IOEnv env ([b],[c])
mapAndUnzip3M :: (a -> IOEnv env (b,c,d)) -> [a] -> IOEnv env ([b],[c],[d])
163
164
checkM	      :: Bool -> IOEnv env a -> IOEnv env ()	-- Perform arg if bool is False
ifM	      :: Bool -> IOEnv env a -> IOEnv env ()	-- Perform arg if bool is True
165
166
167
168

mappM f []     = return []
mappM f (x:xs) = do { r <- f x; rs <- mappM f xs; return (r:rs) }

169
170
171
mapSndM f []     = return []
mapSndM f ((a,b):xs) = do { c <- f b; rs <- mapSndM f xs; return ((a,c):rs) }

172
173
174
mappM_ f []     = return ()
mappM_ f (x:xs) = f x >> mappM_ f xs

175
176
177
178
179
180
181
182
183
184
zipWithM :: (a -> b -> IOEnv env c) -> [a] -> [b] -> IOEnv env [c]
zipWithM f [] bs = return []
zipWithM f as [] = return []
zipWithM f (a:as) (b:bs) = do { r <- f a b; rs <- zipWithM f as bs; return (r:rs) } 

zipWithM_ :: (a -> b -> IOEnv env c) -> [a] -> [b] -> IOEnv env ()
zipWithM_ f [] bs = return ()
zipWithM_ f as [] = return ()
zipWithM_ f (a:as) (b:bs) = do { f a b; zipWithM_ f as bs } 

185
186
187
sequenceM [] = return []
sequenceM (x:xs) = do { r <- x; rs <- sequenceM xs; return (r:rs) }

188
189
190
sequenceM_ []     = return ()
sequenceM_ (x:xs) = do { x; sequenceM_ xs }

191
192
193
foldlM k z [] = return z
foldlM k z (x:xs) = do { r <- k z x; foldlM k r xs }

194
195
196
foldrM k z [] = return z
foldrM k z (x:xs) = do { r <- foldrM k z xs; k x r }

197
198
199
200
201
202
203
204
205
206
207
mapAndUnzipM f []     = return ([],[])
mapAndUnzipM f (x:xs) = do { (r,s) <- f x; 
			     (rs,ss) <- mapAndUnzipM f xs; 
			     return (r:rs, s:ss) }

mapAndUnzip3M f []     = return ([],[], [])
mapAndUnzip3M f (x:xs) = do { (r,s,t) <- f x; 
			      (rs,ss,ts) <- mapAndUnzip3M f xs; 
			      return (r:rs, s:ss, t:ts) }

checkM True  err = return ()
208
checkM False err = do { err; return () }
209

210
ifM True  do_it = do { do_it; return () }
211
ifM False do_it = return ()