1 {-# OPTIONS -#include "HsBase.h" #-}
2 -----------------------------------------------------------------------------
4 -- Module : Data.Array.IO
5 -- Copyright : (c) The University of Glasgow 2001
6 -- License : BSD-style (see the file libraries/core/LICENSE)
8 -- Maintainer : libraries@haskell.org
9 -- Stability : experimental
10 -- Portability : non-portable
12 -- $Id: IO.hs,v 1.5 2002/02/07 11:13:29 simonmar Exp $
14 -- Mutable boxed/unboxed arrays in the IO monad.
16 -----------------------------------------------------------------------------
18 module Data.Array.IO (
19 module Data.Array.MArray,
20 IOArray, -- instance of: Eq, Typeable
21 IOUArray, -- instance of: Eq, Typeable
22 castIOUArray, -- :: IOUArray i a -> IO (IOUArray i b)
23 hGetArray, -- :: Handle -> IOUArray Int Word8 -> Int -> IO Int
24 hPutArray, -- :: Handle -> IOUArray Int Word8 -> Int -> IO ()
29 import Data.Array ( Array )
30 import Data.Array.MArray
36 import Foreign.Ptr ( Ptr, FunPtr )
37 import Foreign.StablePtr ( StablePtr )
39 #ifdef __GLASGOW_HASKELL__
40 -- GHC only to the end of file
42 import Data.Array.Base
43 import GHC.Arr ( STArray, freezeSTArray, unsafeFreezeSTArray,
44 thawSTArray, unsafeThawSTArray )
46 import GHC.ST ( ST(..) )
54 -----------------------------------------------------------------------------
55 -- Polymorphic non-strict mutable arrays (IO monad)
57 newtype IOArray i e = IOArray (STArray RealWorld i e) deriving Eq
60 iOArrayTc = mkTyCon "IOArray"
62 instance (Typeable a, Typeable b) => Typeable (IOArray a b) where
63 typeOf a = mkAppTy iOArrayTc [typeOf ((undefined :: IOArray a b -> a) a),
64 typeOf ((undefined :: IOArray a b -> b) a)]
66 instance HasBounds IOArray where
68 bounds (IOArray marr) = bounds marr
70 instance MArray IOArray e IO where
71 {-# INLINE newArray #-}
72 newArray lu init = stToIO $ do
73 marr <- newArray lu init; return (IOArray marr)
74 {-# INLINE newArray_ #-}
75 newArray_ lu = stToIO $ do
76 marr <- newArray_ lu; return (IOArray marr)
77 {-# INLINE unsafeRead #-}
78 unsafeRead (IOArray marr) i = stToIO (unsafeRead marr i)
79 {-# INLINE unsafeWrite #-}
80 unsafeWrite (IOArray marr) i e = stToIO (unsafeWrite marr i e)
82 -----------------------------------------------------------------------------
83 -- Flat unboxed mutable arrays (IO monad)
85 newtype IOUArray i e = IOUArray (STUArray RealWorld i e) deriving Eq
88 iOUArrayTc = mkTyCon "IOUArray"
90 instance (Typeable a, Typeable b) => Typeable (IOUArray a b) where
91 typeOf a = mkAppTy iOUArrayTc [typeOf ((undefined :: IOUArray a b -> a) a),
92 typeOf ((undefined :: IOUArray a b -> b) a)]
94 instance HasBounds IOUArray where
96 bounds (IOUArray marr) = bounds marr
98 instance MArray IOUArray Bool IO where
99 {-# INLINE newArray #-}
100 newArray lu init = stToIO $ do
101 marr <- newArray lu init; return (IOUArray marr)
102 {-# INLINE newArray_ #-}
103 newArray_ lu = stToIO $ do
104 marr <- newArray_ lu; return (IOUArray marr)
105 {-# INLINE unsafeRead #-}
106 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
107 {-# INLINE unsafeWrite #-}
108 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
110 instance MArray IOUArray Char IO where
111 {-# INLINE newArray #-}
112 newArray lu init = stToIO $ do
113 marr <- newArray lu init; return (IOUArray marr)
114 {-# INLINE newArray_ #-}
115 newArray_ lu = stToIO $ do
116 marr <- newArray_ lu; return (IOUArray marr)
117 {-# INLINE unsafeRead #-}
118 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
119 {-# INLINE unsafeWrite #-}
120 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
122 instance MArray IOUArray Int IO where
123 {-# INLINE newArray #-}
124 newArray lu init = stToIO $ do
125 marr <- newArray lu init; return (IOUArray marr)
126 {-# INLINE newArray_ #-}
127 newArray_ lu = stToIO $ do
128 marr <- newArray_ lu; return (IOUArray marr)
129 {-# INLINE unsafeRead #-}
130 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
131 {-# INLINE unsafeWrite #-}
132 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
134 instance MArray IOUArray Word IO where
135 {-# INLINE newArray #-}
136 newArray lu init = stToIO $ do
137 marr <- newArray lu init; return (IOUArray marr)
138 {-# INLINE newArray_ #-}
139 newArray_ lu = stToIO $ do
140 marr <- newArray_ lu; return (IOUArray marr)
141 {-# INLINE unsafeRead #-}
142 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
143 {-# INLINE unsafeWrite #-}
144 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
146 instance MArray IOUArray (Ptr a) IO where
147 {-# INLINE newArray #-}
148 newArray lu init = stToIO $ do
149 marr <- newArray lu init; return (IOUArray marr)
150 {-# INLINE newArray_ #-}
151 newArray_ lu = stToIO $ do
152 marr <- newArray_ lu; return (IOUArray marr)
153 {-# INLINE unsafeRead #-}
154 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
155 {-# INLINE unsafeWrite #-}
156 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
158 instance MArray IOUArray (FunPtr a) IO where
159 {-# INLINE newArray #-}
160 newArray lu init = stToIO $ do
161 marr <- newArray lu init; return (IOUArray marr)
162 {-# INLINE newArray_ #-}
163 newArray_ lu = stToIO $ do
164 marr <- newArray_ lu; return (IOUArray marr)
165 {-# INLINE unsafeRead #-}
166 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
167 {-# INLINE unsafeWrite #-}
168 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
170 instance MArray IOUArray Float IO where
171 {-# INLINE newArray #-}
172 newArray lu init = stToIO $ do
173 marr <- newArray lu init; return (IOUArray marr)
174 {-# INLINE newArray_ #-}
175 newArray_ lu = stToIO $ do
176 marr <- newArray_ lu; return (IOUArray marr)
177 {-# INLINE unsafeRead #-}
178 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
179 {-# INLINE unsafeWrite #-}
180 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
182 instance MArray IOUArray Double IO where
183 {-# INLINE newArray #-}
184 newArray lu init = stToIO $ do
185 marr <- newArray lu init; return (IOUArray marr)
186 {-# INLINE newArray_ #-}
187 newArray_ lu = stToIO $ do
188 marr <- newArray_ lu; return (IOUArray marr)
189 {-# INLINE unsafeRead #-}
190 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
191 {-# INLINE unsafeWrite #-}
192 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
194 instance MArray IOUArray (StablePtr a) IO where
195 {-# INLINE newArray #-}
196 newArray lu init = stToIO $ do
197 marr <- newArray lu init; return (IOUArray marr)
198 {-# INLINE newArray_ #-}
199 newArray_ lu = stToIO $ do
200 marr <- newArray_ lu; return (IOUArray marr)
201 {-# INLINE unsafeRead #-}
202 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
203 {-# INLINE unsafeWrite #-}
204 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
206 instance MArray IOUArray Int8 IO where
207 {-# INLINE newArray #-}
208 newArray lu init = stToIO $ do
209 marr <- newArray lu init; return (IOUArray marr)
210 {-# INLINE newArray_ #-}
211 newArray_ lu = stToIO $ do
212 marr <- newArray_ lu; return (IOUArray marr)
213 {-# INLINE unsafeRead #-}
214 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
215 {-# INLINE unsafeWrite #-}
216 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
218 instance MArray IOUArray Int16 IO where
219 {-# INLINE newArray #-}
220 newArray lu init = stToIO $ do
221 marr <- newArray lu init; return (IOUArray marr)
222 {-# INLINE newArray_ #-}
223 newArray_ lu = stToIO $ do
224 marr <- newArray_ lu; return (IOUArray marr)
225 {-# INLINE unsafeRead #-}
226 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
227 {-# INLINE unsafeWrite #-}
228 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
230 instance MArray IOUArray Int32 IO where
231 {-# INLINE newArray #-}
232 newArray lu init = stToIO $ do
233 marr <- newArray lu init; return (IOUArray marr)
234 {-# INLINE newArray_ #-}
235 newArray_ lu = stToIO $ do
236 marr <- newArray_ lu; return (IOUArray marr)
237 {-# INLINE unsafeRead #-}
238 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
239 {-# INLINE unsafeWrite #-}
240 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
242 instance MArray IOUArray Int64 IO where
243 {-# INLINE newArray #-}
244 newArray lu init = stToIO $ do
245 marr <- newArray lu init; return (IOUArray marr)
246 {-# INLINE newArray_ #-}
247 newArray_ lu = stToIO $ do
248 marr <- newArray_ lu; return (IOUArray marr)
249 {-# INLINE unsafeRead #-}
250 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
251 {-# INLINE unsafeWrite #-}
252 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
254 instance MArray IOUArray Word8 IO where
255 {-# INLINE newArray #-}
256 newArray lu init = stToIO $ do
257 marr <- newArray lu init; return (IOUArray marr)
258 {-# INLINE newArray_ #-}
259 newArray_ lu = stToIO $ do
260 marr <- newArray_ lu; return (IOUArray marr)
261 {-# INLINE unsafeRead #-}
262 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
263 {-# INLINE unsafeWrite #-}
264 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
266 instance MArray IOUArray Word16 IO where
267 {-# INLINE newArray #-}
268 newArray lu init = stToIO $ do
269 marr <- newArray lu init; return (IOUArray marr)
270 {-# INLINE newArray_ #-}
271 newArray_ lu = stToIO $ do
272 marr <- newArray_ lu; return (IOUArray marr)
273 {-# INLINE unsafeRead #-}
274 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
275 {-# INLINE unsafeWrite #-}
276 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
278 instance MArray IOUArray Word32 IO where
279 {-# INLINE newArray #-}
280 newArray lu init = stToIO $ do
281 marr <- newArray lu init; return (IOUArray marr)
282 {-# INLINE newArray_ #-}
283 newArray_ lu = stToIO $ do
284 marr <- newArray_ lu; return (IOUArray marr)
285 {-# INLINE unsafeRead #-}
286 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
287 {-# INLINE unsafeWrite #-}
288 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
290 instance MArray IOUArray Word64 IO where
291 {-# INLINE newArray #-}
292 newArray lu init = stToIO $ do
293 marr <- newArray lu init; return (IOUArray marr)
294 {-# INLINE newArray_ #-}
295 newArray_ lu = stToIO $ do
296 marr <- newArray_ lu; return (IOUArray marr)
297 {-# INLINE unsafeRead #-}
298 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
299 {-# INLINE unsafeWrite #-}
300 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
302 -----------------------------------------------------------------------------
305 freezeIOArray :: Ix ix => IOArray ix e -> IO (Array ix e)
306 freezeIOArray (IOArray marr) = stToIO (freezeSTArray marr)
308 freezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e)
309 freezeIOUArray (IOUArray marr) = stToIO (freezeSTUArray marr)
312 "freeze/IOArray" freeze = freezeIOArray
313 "freeze/IOUArray" freeze = freezeIOUArray
316 {-# INLINE unsafeFreezeIOArray #-}
317 unsafeFreezeIOArray :: Ix ix => IOArray ix e -> IO (Array ix e)
318 unsafeFreezeIOArray (IOArray marr) = stToIO (unsafeFreezeSTArray marr)
320 {-# INLINE unsafeFreezeIOUArray #-}
321 unsafeFreezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e)
322 unsafeFreezeIOUArray (IOUArray marr) = stToIO (unsafeFreezeSTUArray marr)
325 "unsafeFreeze/IOArray" unsafeFreeze = unsafeFreezeIOArray
326 "unsafeFreeze/IOUArray" unsafeFreeze = unsafeFreezeIOUArray
329 -----------------------------------------------------------------------------
332 thawIOArray :: Ix ix => Array ix e -> IO (IOArray ix e)
333 thawIOArray arr = stToIO $ do
334 marr <- thawSTArray arr
335 return (IOArray marr)
337 thawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e)
338 thawIOUArray arr = stToIO $ do
339 marr <- thawSTUArray arr
340 return (IOUArray marr)
343 "thaw/IOArray" thaw = thawIOArray
344 "thaw/IOUArray" thaw = thawIOUArray
347 {-# INLINE unsafeThawIOArray #-}
348 unsafeThawIOArray :: Ix ix => Array ix e -> IO (IOArray ix e)
349 unsafeThawIOArray arr = stToIO $ do
350 marr <- unsafeThawSTArray arr
351 return (IOArray marr)
353 {-# INLINE unsafeThawIOUArray #-}
354 unsafeThawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e)
355 unsafeThawIOUArray arr = stToIO $ do
356 marr <- unsafeThawSTUArray arr
357 return (IOUArray marr)
360 "unsafeThaw/IOArray" unsafeThaw = unsafeThawIOArray
361 "unsafeThaw/IOUArray" unsafeThaw = unsafeThawIOUArray
364 castSTUArray :: STUArray s ix a -> ST s (STUArray s ix b)
365 castSTUArray (STUArray l u marr#) = return (STUArray l u marr#)
367 castIOUArray :: IOUArray ix a -> IO (IOUArray ix b)
368 castIOUArray (IOUArray marr) = stToIO $ do
369 marr' <- castSTUArray marr
370 return (IOUArray marr')
372 -- ---------------------------------------------------------------------------
375 hGetArray :: Handle -> IOUArray Int Word8 -> Int -> IO Int
376 hGetArray handle (IOUArray (STUArray l u ptr)) count
377 | count <= 0 || count > rangeSize (l,u)
378 = illegalBufferSize handle "hGetArray" count
380 wantReadableHandle "hGetArray" handle $
381 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
382 buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r } <- readIORef ref
384 then readChunk fd is_stream ptr 0 count
387 copied <- if (count >= avail)
389 memcpy_ba_baoff ptr raw r (fromIntegral avail)
390 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
393 memcpy_ba_baoff ptr raw r (fromIntegral count)
394 writeIORef ref buf{ bufRPtr = r + count }
397 let remaining = count - copied
399 then do rest <- readChunk fd is_stream ptr copied remaining
400 return (rest + count)
403 readChunk :: FD -> Bool -> RawBuffer -> Int -> Int -> IO Int
404 readChunk fd is_stream ptr init_off bytes = loop init_off bytes
406 loop :: Int -> Int -> IO Int
407 loop off bytes | bytes <= 0 = return (off - init_off)
409 r' <- throwErrnoIfMinus1RetryMayBlock "readChunk"
410 (read_off_ba (fromIntegral fd) is_stream ptr
411 (fromIntegral off) (fromIntegral bytes))
413 let r = fromIntegral r'
415 then return (off - init_off)
416 else loop (off + r) (bytes - r)
418 -- ---------------------------------------------------------------------------
422 :: Handle -- handle to write to
423 -> IOUArray Int Word8 -- buffer
424 -> Int -- number of bytes of data to write
427 hPutArray handle (IOUArray (STUArray l u raw)) count
428 | count <= 0 || count > rangeSize (l,u)
429 = illegalBufferSize handle "hPutArray" count
431 = do wantWritableHandle "hPutArray" handle $
432 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=stream } -> do
434 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
437 -- enough room in handle buffer?
438 if (size - w > count)
439 -- There's enough room in the buffer:
440 -- just copy the data in and update bufWPtr.
441 then do memcpy_baoff_ba old_raw w raw (fromIntegral count)
442 writeIORef ref old_buf{ bufWPtr = w + count }
445 -- else, we have to flush
446 else do flushed_buf <- flushWriteBuffer fd stream old_buf
447 writeIORef ref flushed_buf
449 Buffer{ bufBuf=raw, bufState=WriteBuffer,
450 bufRPtr=0, bufWPtr=count, bufSize=count }
451 flushWriteBuffer fd stream this_buf
454 -- ---------------------------------------------------------------------------
457 foreign import "__hscore_memcpy_dst_off" unsafe
458 memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
459 foreign import "__hscore_memcpy_src_off" unsafe
460 memcpy_ba_baoff :: RawBuffer -> RawBuffer -> Int -> CSize -> IO (Ptr ())
462 illegalBufferSize :: Handle -> String -> Int -> IO a
463 illegalBufferSize handle fn (sz :: Int) =
464 ioException (IOError (Just handle)
466 ("illegal buffer size " ++ showsPrec 9 sz [])
469 #endif /* __GLASGOW_HASKELL__ */