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