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 -- Mutable boxed and unboxed arrays in the IO monad.
14 -----------------------------------------------------------------------------
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 ()
27 import Data.Array ( Array )
28 import Data.Array.MArray
34 import Foreign.Ptr ( Ptr, FunPtr )
35 import Foreign.StablePtr ( StablePtr )
37 #ifdef __GLASGOW_HASKELL__
38 -- GHC only to the end of file
40 import Data.Array.Base
41 import GHC.Arr ( STArray, freezeSTArray, unsafeFreezeSTArray,
42 thawSTArray, unsafeThawSTArray )
44 import GHC.ST ( ST(..) )
52 -----------------------------------------------------------------------------
53 -- Polymorphic non-strict mutable arrays (IO monad)
55 newtype IOArray i e = IOArray (STArray RealWorld i e) deriving Eq
58 iOArrayTc = mkTyCon "IOArray"
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)]
64 instance HasBounds IOArray where
66 bounds (IOArray marr) = bounds marr
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)
80 -----------------------------------------------------------------------------
81 -- Flat unboxed mutable arrays (IO monad)
83 newtype IOUArray i e = IOUArray (STUArray RealWorld i e) deriving Eq
86 iOUArrayTc = mkTyCon "IOUArray"
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)]
92 instance HasBounds IOUArray where
94 bounds (IOUArray marr) = bounds marr
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
300 -----------------------------------------------------------------------------
303 freezeIOArray :: Ix ix => IOArray ix e -> IO (Array ix e)
304 freezeIOArray (IOArray marr) = stToIO (freezeSTArray marr)
306 freezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e)
307 freezeIOUArray (IOUArray marr) = stToIO (freezeSTUArray marr)
310 "freeze/IOArray" freeze = freezeIOArray
311 "freeze/IOUArray" freeze = freezeIOUArray
314 {-# INLINE unsafeFreezeIOArray #-}
315 unsafeFreezeIOArray :: Ix ix => IOArray ix e -> IO (Array ix e)
316 unsafeFreezeIOArray (IOArray marr) = stToIO (unsafeFreezeSTArray marr)
318 {-# INLINE unsafeFreezeIOUArray #-}
319 unsafeFreezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e)
320 unsafeFreezeIOUArray (IOUArray marr) = stToIO (unsafeFreezeSTUArray marr)
323 "unsafeFreeze/IOArray" unsafeFreeze = unsafeFreezeIOArray
324 "unsafeFreeze/IOUArray" unsafeFreeze = unsafeFreezeIOUArray
327 -----------------------------------------------------------------------------
330 thawIOArray :: Ix ix => Array ix e -> IO (IOArray ix e)
331 thawIOArray arr = stToIO $ do
332 marr <- thawSTArray arr
333 return (IOArray marr)
335 thawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e)
336 thawIOUArray arr = stToIO $ do
337 marr <- thawSTUArray arr
338 return (IOUArray marr)
341 "thaw/IOArray" thaw = thawIOArray
342 "thaw/IOUArray" thaw = thawIOUArray
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)
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)
358 "unsafeThaw/IOArray" unsafeThaw = unsafeThawIOArray
359 "unsafeThaw/IOUArray" unsafeThaw = unsafeThawIOUArray
362 castSTUArray :: STUArray s ix a -> ST s (STUArray s ix b)
363 castSTUArray (STUArray l u marr#) = return (STUArray l u marr#)
365 castIOUArray :: IOUArray ix a -> IO (IOUArray ix b)
366 castIOUArray (IOUArray marr) = stToIO $ do
367 marr' <- castSTUArray marr
368 return (IOUArray marr')
370 -- ---------------------------------------------------------------------------
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
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
382 then readChunk fd is_stream ptr 0 count
385 copied <- if (count >= avail)
387 memcpy_ba_baoff ptr raw r (fromIntegral avail)
388 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
391 memcpy_ba_baoff ptr raw r (fromIntegral count)
392 writeIORef ref buf{ bufRPtr = r + count }
395 let remaining = count - copied
397 then do rest <- readChunk fd is_stream ptr copied remaining
398 return (rest + count)
401 readChunk :: FD -> Bool -> RawBuffer -> Int -> Int -> IO Int
402 readChunk fd is_stream ptr init_off bytes = loop init_off bytes
404 loop :: Int -> Int -> IO Int
405 loop off bytes | bytes <= 0 = return (off - init_off)
407 r' <- throwErrnoIfMinus1RetryMayBlock "readChunk"
408 (read_off_ba (fromIntegral fd) is_stream ptr
409 (fromIntegral off) (fromIntegral bytes))
411 let r = fromIntegral r'
413 then return (off - init_off)
414 else loop (off + r) (bytes - r)
416 -- ---------------------------------------------------------------------------
420 :: Handle -- handle to write to
421 -> IOUArray Int Word8 -- buffer
422 -> Int -- number of bytes of data to write
425 hPutArray handle (IOUArray (STUArray l u raw)) count
426 | count <= 0 || count > rangeSize (l,u)
427 = illegalBufferSize handle "hPutArray" count
429 = do wantWritableHandle "hPutArray" handle $
430 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=stream } -> do
432 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
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 }
443 -- else, we have to flush
444 else do flushed_buf <- flushWriteBuffer fd stream old_buf
445 writeIORef ref flushed_buf
447 Buffer{ bufBuf=raw, bufState=WriteBuffer,
448 bufRPtr=0, bufWPtr=count, bufSize=count }
449 flushWriteBuffer fd stream this_buf
452 -- ---------------------------------------------------------------------------
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 ())
460 illegalBufferSize :: Handle -> String -> Int -> IO a
461 illegalBufferSize handle fn sz =
462 ioException (IOError (Just handle)
464 ("illegal buffer size " ++ showsPrec 9 (sz::Int) [])
467 #endif /* __GLASGOW_HASKELL__ */