[project @ 2002-05-09 13:16:29 by simonmar]
[packages/base.git] / Data / Array / IO.hs
1 {-# OPTIONS -#include "HsBase.h" #-}
2 -----------------------------------------------------------------------------
3 -- |
4 -- Module : Data.Array.IO
5 -- Copyright : (c) The University of Glasgow 2001
6 -- License : BSD-style (see the file libraries/base/LICENSE)
7 --
8 -- Maintainer : libraries@haskell.org
9 -- Stability : experimental
10 -- Portability : non-portable
11 --
12 -- Mutable boxed and unboxed arrays in the IO monad.
13 --
14 -----------------------------------------------------------------------------
15
16 module Data.Array.IO (
17 module Data.Array.MArray,
18 IOArray, -- instance of: Eq, Typeable
19 IOUArray, -- instance of: Eq, Typeable
20 castIOUArray, -- :: IOUArray i a -> IO (IOUArray i b)
21 hGetArray, -- :: Handle -> IOUArray Int Word8 -> Int -> IO Int
22 hPutArray, -- :: Handle -> IOUArray Int Word8 -> Int -> IO ()
23 ) where
24
25 import Prelude
26
27 import Data.Array ( Array )
28 import Data.Array.MArray
29 import Data.Int
30 import Data.Word
31 import Data.Dynamic
32
33 import Foreign.C
34 import Foreign.Ptr ( Ptr, FunPtr )
35 import Foreign.StablePtr ( StablePtr )
36
37 #ifdef __GLASGOW_HASKELL__
38 -- GHC only to the end of file
39
40 import Data.Array.Base
41 import GHC.Arr ( STArray, freezeSTArray, unsafeFreezeSTArray,
42 thawSTArray, unsafeThawSTArray )
43
44 import GHC.ST ( ST(..) )
45
46 import GHC.IOBase
47 import GHC.Handle
48 import GHC.Conc
49
50 import GHC.Base
51
52 -----------------------------------------------------------------------------
53 -- Polymorphic non-strict mutable arrays (IO monad)
54
55 newtype IOArray i e = IOArray (STArray RealWorld i e) deriving Eq
56
57 iOArrayTc :: TyCon
58 iOArrayTc = mkTyCon "IOArray"
59
60 instance (Typeable a, Typeable b) => Typeable (IOArray a b) where
61 typeOf a = mkAppTy iOArrayTc [typeOf ((undefined :: IOArray a b -> a) a),
62 typeOf ((undefined :: IOArray a b -> b) a)]
63
64 instance HasBounds IOArray where
65 {-# INLINE bounds #-}
66 bounds (IOArray marr) = bounds marr
67
68 instance MArray IOArray e IO where
69 {-# INLINE newArray #-}
70 newArray lu init = stToIO $ do
71 marr <- newArray lu init; return (IOArray marr)
72 {-# INLINE newArray_ #-}
73 newArray_ lu = stToIO $ do
74 marr <- newArray_ lu; return (IOArray marr)
75 {-# INLINE unsafeRead #-}
76 unsafeRead (IOArray marr) i = stToIO (unsafeRead marr i)
77 {-# INLINE unsafeWrite #-}
78 unsafeWrite (IOArray marr) i e = stToIO (unsafeWrite marr i e)
79
80 -----------------------------------------------------------------------------
81 -- Flat unboxed mutable arrays (IO monad)
82
83 newtype IOUArray i e = IOUArray (STUArray RealWorld i e) deriving Eq
84
85 iOUArrayTc :: TyCon
86 iOUArrayTc = mkTyCon "IOUArray"
87
88 instance (Typeable a, Typeable b) => Typeable (IOUArray a b) where
89 typeOf a = mkAppTy iOUArrayTc [typeOf ((undefined :: IOUArray a b -> a) a),
90 typeOf ((undefined :: IOUArray a b -> b) a)]
91
92 instance HasBounds IOUArray where
93 {-# INLINE bounds #-}
94 bounds (IOUArray marr) = bounds marr
95
96 instance MArray IOUArray Bool IO where
97 {-# INLINE newArray #-}
98 newArray lu init = stToIO $ do
99 marr <- newArray lu init; return (IOUArray marr)
100 {-# INLINE newArray_ #-}
101 newArray_ lu = stToIO $ do
102 marr <- newArray_ lu; return (IOUArray marr)
103 {-# INLINE unsafeRead #-}
104 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
105 {-# INLINE unsafeWrite #-}
106 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
107
108 instance MArray IOUArray Char IO where
109 {-# INLINE newArray #-}
110 newArray lu init = stToIO $ do
111 marr <- newArray lu init; return (IOUArray marr)
112 {-# INLINE newArray_ #-}
113 newArray_ lu = stToIO $ do
114 marr <- newArray_ lu; return (IOUArray marr)
115 {-# INLINE unsafeRead #-}
116 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
117 {-# INLINE unsafeWrite #-}
118 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
119
120 instance MArray IOUArray Int IO where
121 {-# INLINE newArray #-}
122 newArray lu init = stToIO $ do
123 marr <- newArray lu init; return (IOUArray marr)
124 {-# INLINE newArray_ #-}
125 newArray_ lu = stToIO $ do
126 marr <- newArray_ lu; return (IOUArray marr)
127 {-# INLINE unsafeRead #-}
128 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
129 {-# INLINE unsafeWrite #-}
130 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
131
132 instance MArray IOUArray Word IO where
133 {-# INLINE newArray #-}
134 newArray lu init = stToIO $ do
135 marr <- newArray lu init; return (IOUArray marr)
136 {-# INLINE newArray_ #-}
137 newArray_ lu = stToIO $ do
138 marr <- newArray_ lu; return (IOUArray marr)
139 {-# INLINE unsafeRead #-}
140 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
141 {-# INLINE unsafeWrite #-}
142 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
143
144 instance MArray IOUArray (Ptr a) IO where
145 {-# INLINE newArray #-}
146 newArray lu init = stToIO $ do
147 marr <- newArray lu init; return (IOUArray marr)
148 {-# INLINE newArray_ #-}
149 newArray_ lu = stToIO $ do
150 marr <- newArray_ lu; return (IOUArray marr)
151 {-# INLINE unsafeRead #-}
152 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
153 {-# INLINE unsafeWrite #-}
154 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
155
156 instance MArray IOUArray (FunPtr a) IO where
157 {-# INLINE newArray #-}
158 newArray lu init = stToIO $ do
159 marr <- newArray lu init; return (IOUArray marr)
160 {-# INLINE newArray_ #-}
161 newArray_ lu = stToIO $ do
162 marr <- newArray_ lu; return (IOUArray marr)
163 {-# INLINE unsafeRead #-}
164 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
165 {-# INLINE unsafeWrite #-}
166 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
167
168 instance MArray IOUArray Float IO where
169 {-# INLINE newArray #-}
170 newArray lu init = stToIO $ do
171 marr <- newArray lu init; return (IOUArray marr)
172 {-# INLINE newArray_ #-}
173 newArray_ lu = stToIO $ do
174 marr <- newArray_ lu; return (IOUArray marr)
175 {-# INLINE unsafeRead #-}
176 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
177 {-# INLINE unsafeWrite #-}
178 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
179
180 instance MArray IOUArray Double IO where
181 {-# INLINE newArray #-}
182 newArray lu init = stToIO $ do
183 marr <- newArray lu init; return (IOUArray marr)
184 {-# INLINE newArray_ #-}
185 newArray_ lu = stToIO $ do
186 marr <- newArray_ lu; return (IOUArray marr)
187 {-# INLINE unsafeRead #-}
188 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
189 {-# INLINE unsafeWrite #-}
190 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
191
192 instance MArray IOUArray (StablePtr a) IO where
193 {-# INLINE newArray #-}
194 newArray lu init = stToIO $ do
195 marr <- newArray lu init; return (IOUArray marr)
196 {-# INLINE newArray_ #-}
197 newArray_ lu = stToIO $ do
198 marr <- newArray_ lu; return (IOUArray marr)
199 {-# INLINE unsafeRead #-}
200 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
201 {-# INLINE unsafeWrite #-}
202 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
203
204 instance MArray IOUArray Int8 IO where
205 {-# INLINE newArray #-}
206 newArray lu init = stToIO $ do
207 marr <- newArray lu init; return (IOUArray marr)
208 {-# INLINE newArray_ #-}
209 newArray_ lu = stToIO $ do
210 marr <- newArray_ lu; return (IOUArray marr)
211 {-# INLINE unsafeRead #-}
212 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
213 {-# INLINE unsafeWrite #-}
214 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
215
216 instance MArray IOUArray Int16 IO where
217 {-# INLINE newArray #-}
218 newArray lu init = stToIO $ do
219 marr <- newArray lu init; return (IOUArray marr)
220 {-# INLINE newArray_ #-}
221 newArray_ lu = stToIO $ do
222 marr <- newArray_ lu; return (IOUArray marr)
223 {-# INLINE unsafeRead #-}
224 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
225 {-# INLINE unsafeWrite #-}
226 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
227
228 instance MArray IOUArray Int32 IO where
229 {-# INLINE newArray #-}
230 newArray lu init = stToIO $ do
231 marr <- newArray lu init; return (IOUArray marr)
232 {-# INLINE newArray_ #-}
233 newArray_ lu = stToIO $ do
234 marr <- newArray_ lu; return (IOUArray marr)
235 {-# INLINE unsafeRead #-}
236 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
237 {-# INLINE unsafeWrite #-}
238 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
239
240 instance MArray IOUArray Int64 IO where
241 {-# INLINE newArray #-}
242 newArray lu init = stToIO $ do
243 marr <- newArray lu init; return (IOUArray marr)
244 {-# INLINE newArray_ #-}
245 newArray_ lu = stToIO $ do
246 marr <- newArray_ lu; return (IOUArray marr)
247 {-# INLINE unsafeRead #-}
248 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
249 {-# INLINE unsafeWrite #-}
250 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
251
252 instance MArray IOUArray Word8 IO where
253 {-# INLINE newArray #-}
254 newArray lu init = stToIO $ do
255 marr <- newArray lu init; return (IOUArray marr)
256 {-# INLINE newArray_ #-}
257 newArray_ lu = stToIO $ do
258 marr <- newArray_ lu; return (IOUArray marr)
259 {-# INLINE unsafeRead #-}
260 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
261 {-# INLINE unsafeWrite #-}
262 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
263
264 instance MArray IOUArray Word16 IO where
265 {-# INLINE newArray #-}
266 newArray lu init = stToIO $ do
267 marr <- newArray lu init; return (IOUArray marr)
268 {-# INLINE newArray_ #-}
269 newArray_ lu = stToIO $ do
270 marr <- newArray_ lu; return (IOUArray marr)
271 {-# INLINE unsafeRead #-}
272 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
273 {-# INLINE unsafeWrite #-}
274 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
275
276 instance MArray IOUArray Word32 IO where
277 {-# INLINE newArray #-}
278 newArray lu init = stToIO $ do
279 marr <- newArray lu init; return (IOUArray marr)
280 {-# INLINE newArray_ #-}
281 newArray_ lu = stToIO $ do
282 marr <- newArray_ lu; return (IOUArray marr)
283 {-# INLINE unsafeRead #-}
284 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
285 {-# INLINE unsafeWrite #-}
286 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
287
288 instance MArray IOUArray Word64 IO where
289 {-# INLINE newArray #-}
290 newArray lu init = stToIO $ do
291 marr <- newArray lu init; return (IOUArray marr)
292 {-# INLINE newArray_ #-}
293 newArray_ lu = stToIO $ do
294 marr <- newArray_ lu; return (IOUArray marr)
295 {-# INLINE unsafeRead #-}
296 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
297 {-# INLINE unsafeWrite #-}
298 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
299
300 -----------------------------------------------------------------------------
301 -- Freezing
302
303 freezeIOArray :: Ix ix => IOArray ix e -> IO (Array ix e)
304 freezeIOArray (IOArray marr) = stToIO (freezeSTArray marr)
305
306 freezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e)
307 freezeIOUArray (IOUArray marr) = stToIO (freezeSTUArray marr)
308
309 {-# RULES
310 "freeze/IOArray" freeze = freezeIOArray
311 "freeze/IOUArray" freeze = freezeIOUArray
312 #-}
313
314 {-# INLINE unsafeFreezeIOArray #-}
315 unsafeFreezeIOArray :: Ix ix => IOArray ix e -> IO (Array ix e)
316 unsafeFreezeIOArray (IOArray marr) = stToIO (unsafeFreezeSTArray marr)
317
318 {-# INLINE unsafeFreezeIOUArray #-}
319 unsafeFreezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e)
320 unsafeFreezeIOUArray (IOUArray marr) = stToIO (unsafeFreezeSTUArray marr)
321
322 {-# RULES
323 "unsafeFreeze/IOArray" unsafeFreeze = unsafeFreezeIOArray
324 "unsafeFreeze/IOUArray" unsafeFreeze = unsafeFreezeIOUArray
325 #-}
326
327 -----------------------------------------------------------------------------
328 -- Thawing
329
330 thawIOArray :: Ix ix => Array ix e -> IO (IOArray ix e)
331 thawIOArray arr = stToIO $ do
332 marr <- thawSTArray arr
333 return (IOArray marr)
334
335 thawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e)
336 thawIOUArray arr = stToIO $ do
337 marr <- thawSTUArray arr
338 return (IOUArray marr)
339
340 {-# RULES
341 "thaw/IOArray" thaw = thawIOArray
342 "thaw/IOUArray" thaw = thawIOUArray
343 #-}
344
345 {-# INLINE unsafeThawIOArray #-}
346 unsafeThawIOArray :: Ix ix => Array ix e -> IO (IOArray ix e)
347 unsafeThawIOArray arr = stToIO $ do
348 marr <- unsafeThawSTArray arr
349 return (IOArray marr)
350
351 {-# INLINE unsafeThawIOUArray #-}
352 unsafeThawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e)
353 unsafeThawIOUArray arr = stToIO $ do
354 marr <- unsafeThawSTUArray arr
355 return (IOUArray marr)
356
357 {-# RULES
358 "unsafeThaw/IOArray" unsafeThaw = unsafeThawIOArray
359 "unsafeThaw/IOUArray" unsafeThaw = unsafeThawIOUArray
360 #-}
361
362 castSTUArray :: STUArray s ix a -> ST s (STUArray s ix b)
363 castSTUArray (STUArray l u marr#) = return (STUArray l u marr#)
364
365 castIOUArray :: IOUArray ix a -> IO (IOUArray ix b)
366 castIOUArray (IOUArray marr) = stToIO $ do
367 marr' <- castSTUArray marr
368 return (IOUArray marr')
369
370 -- ---------------------------------------------------------------------------
371 -- hGetArray
372
373 hGetArray :: Handle -> IOUArray Int Word8 -> Int -> IO Int
374 hGetArray handle (IOUArray (STUArray l u ptr)) count
375 | count <= 0 || count > rangeSize (l,u)
376 = illegalBufferSize handle "hGetArray" count
377 | otherwise = do
378 wantReadableHandle "hGetArray" handle $
379 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
380 buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r } <- readIORef ref
381 if bufferEmpty buf
382 then readChunk fd is_stream ptr 0 count
383 else do
384 let avail = w - r
385 copied <- if (count >= avail)
386 then do
387 memcpy_ba_baoff ptr raw r (fromIntegral avail)
388 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
389 return avail
390 else do
391 memcpy_ba_baoff ptr raw r (fromIntegral count)
392 writeIORef ref buf{ bufRPtr = r + count }
393 return count
394
395 let remaining = count - copied
396 if remaining > 0
397 then do rest <- readChunk fd is_stream ptr copied remaining
398 return (rest + count)
399 else return count
400
401 readChunk :: FD -> Bool -> RawBuffer -> Int -> Int -> IO Int
402 readChunk fd is_stream ptr init_off bytes = loop init_off bytes
403 where
404 loop :: Int -> Int -> IO Int
405 loop off bytes | bytes <= 0 = return (off - init_off)
406 loop off bytes = do
407 r' <- throwErrnoIfMinus1RetryMayBlock "readChunk"
408 (read_off_ba (fromIntegral fd) is_stream ptr
409 (fromIntegral off) (fromIntegral bytes))
410 (threadWaitRead fd)
411 let r = fromIntegral r'
412 if r == 0
413 then return (off - init_off)
414 else loop (off + r) (bytes - r)
415
416 -- ---------------------------------------------------------------------------
417 -- hPutArray
418
419 hPutArray
420 :: Handle -- handle to write to
421 -> IOUArray Int Word8 -- buffer
422 -> Int -- number of bytes of data to write
423 -> IO ()
424
425 hPutArray handle (IOUArray (STUArray l u raw)) count
426 | count <= 0 || count > rangeSize (l,u)
427 = illegalBufferSize handle "hPutArray" count
428 | otherwise
429 = do wantWritableHandle "hPutArray" handle $
430 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=stream } -> do
431
432 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
433 <- readIORef ref
434
435 -- enough room in handle buffer?
436 if (size - w > count)
437 -- There's enough room in the buffer:
438 -- just copy the data in and update bufWPtr.
439 then do memcpy_baoff_ba old_raw w raw (fromIntegral count)
440 writeIORef ref old_buf{ bufWPtr = w + count }
441 return ()
442
443 -- else, we have to flush
444 else do flushed_buf <- flushWriteBuffer fd stream old_buf
445 writeIORef ref flushed_buf
446 let this_buf =
447 Buffer{ bufBuf=raw, bufState=WriteBuffer,
448 bufRPtr=0, bufWPtr=count, bufSize=count }
449 flushWriteBuffer fd stream this_buf
450 return ()
451
452 -- ---------------------------------------------------------------------------
453 -- Internal Utils
454
455 foreign import ccall unsafe "__hscore_memcpy_dst_off"
456 memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
457 foreign import ccall unsafe "__hscore_memcpy_src_off"
458 memcpy_ba_baoff :: RawBuffer -> RawBuffer -> Int -> CSize -> IO (Ptr ())
459
460 illegalBufferSize :: Handle -> String -> Int -> IO a
461 illegalBufferSize handle fn sz =
462 ioException (IOError (Just handle)
463 InvalidArgument fn
464 ("illegal buffer size " ++ showsPrec 9 (sz::Int) [])
465 Nothing)
466
467 #endif /* __GLASGOW_HASKELL__ */