a476a324c1d2327f7d4058a5015ed3b256f2776c
[ghc.git] / libraries / base / Data / Array / IO.hs
1 {-# OPTIONS_GHC -#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 (uses Data.Array.MArray)
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 -- * @IO@ arrays with unboxed elements
21 IOUArray, -- instance of: Eq, Typeable
22 castIOUArray, -- :: IOUArray i a -> IO (IOUArray i b)
23
24 -- * Overloaded mutable array interface
25 module Data.Array.MArray,
26
27 -- * Doing I\/O with @IOUArray@s
28 hGetArray, -- :: Handle -> IOUArray Int Word8 -> Int -> IO Int
29 hPutArray, -- :: Handle -> IOUArray Int Word8 -> Int -> IO ()
30 ) where
31
32 import Prelude
33
34 import Data.Array.Base
35 import Data.Array.IO.Internals
36 import Data.Array ( Array )
37 import Data.Array.MArray
38 import Data.Int
39 import Data.Word
40
41 #ifdef __GLASGOW_HASKELL__
42 import Foreign
43 import Foreign.C
44
45 import GHC.Arr
46 import GHC.IOBase
47 import GHC.Handle
48 #else
49 import Data.Char
50 import System.IO
51 import System.IO.Error
52 #endif
53
54 #ifdef __GLASGOW_HASKELL__
55 -----------------------------------------------------------------------------
56 -- Freezing
57
58 freezeIOArray :: Ix ix => IOArray ix e -> IO (Array ix e)
59 freezeIOArray (IOArray marr) = stToIO (freezeSTArray marr)
60
61 freezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e)
62 freezeIOUArray (IOUArray marr) = stToIO (freezeSTUArray marr)
63
64 {-# RULES
65 "freeze/IOArray" freeze = freezeIOArray
66 "freeze/IOUArray" freeze = freezeIOUArray
67 #-}
68
69 {-# INLINE unsafeFreezeIOArray #-}
70 unsafeFreezeIOArray :: Ix ix => IOArray ix e -> IO (Array ix e)
71 unsafeFreezeIOArray (IOArray marr) = stToIO (unsafeFreezeSTArray marr)
72
73 {-# INLINE unsafeFreezeIOUArray #-}
74 unsafeFreezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e)
75 unsafeFreezeIOUArray (IOUArray marr) = stToIO (unsafeFreezeSTUArray marr)
76
77 {-# RULES
78 "unsafeFreeze/IOArray" unsafeFreeze = unsafeFreezeIOArray
79 "unsafeFreeze/IOUArray" unsafeFreeze = unsafeFreezeIOUArray
80 #-}
81
82 -----------------------------------------------------------------------------
83 -- Thawing
84
85 thawIOArray :: Ix ix => Array ix e -> IO (IOArray ix e)
86 thawIOArray arr = stToIO $ do
87 marr <- thawSTArray arr
88 return (IOArray marr)
89
90 thawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e)
91 thawIOUArray arr = stToIO $ do
92 marr <- thawSTUArray arr
93 return (IOUArray marr)
94
95 {-# RULES
96 "thaw/IOArray" thaw = thawIOArray
97 "thaw/IOUArray" thaw = thawIOUArray
98 #-}
99
100 {-# INLINE unsafeThawIOArray #-}
101 unsafeThawIOArray :: Ix ix => Array ix e -> IO (IOArray ix e)
102 unsafeThawIOArray arr = stToIO $ do
103 marr <- unsafeThawSTArray arr
104 return (IOArray marr)
105
106 {-# INLINE unsafeThawIOUArray #-}
107 unsafeThawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e)
108 unsafeThawIOUArray arr = stToIO $ do
109 marr <- unsafeThawSTUArray arr
110 return (IOUArray marr)
111
112 {-# RULES
113 "unsafeThaw/IOArray" unsafeThaw = unsafeThawIOArray
114 "unsafeThaw/IOUArray" unsafeThaw = unsafeThawIOUArray
115 #-}
116
117 -- ---------------------------------------------------------------------------
118 -- hGetArray
119
120 -- | Reads a number of 'Word8's from the specified 'Handle' directly
121 -- into an array.
122 hGetArray
123 :: Handle -- ^ Handle to read from
124 -> IOUArray Int Word8 -- ^ Array in which to place the values
125 -> Int -- ^ Number of 'Word8's to read
126 -> IO Int
127 -- ^ Returns: the number of 'Word8's actually
128 -- read, which might be smaller than the number requested
129 -- if the end of file was reached.
130
131 hGetArray handle (IOUArray (STUArray l u ptr)) count
132 | count == 0
133 = return 0
134 | count < 0 || count > rangeSize (l,u)
135 = illegalBufferSize handle "hGetArray" count
136 | otherwise = do
137 wantReadableHandle "hGetArray" handle $
138 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
139 buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r } <- readIORef ref
140 if bufferEmpty buf
141 then readChunk fd is_stream ptr 0 count
142 else do
143 let avail = w - r
144 copied <- if (count >= avail)
145 then do
146 memcpy_ba_baoff ptr raw r (fromIntegral avail)
147 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
148 return avail
149 else do
150 memcpy_ba_baoff ptr raw r (fromIntegral count)
151 writeIORef ref buf{ bufRPtr = r + count }
152 return count
153
154 let remaining = count - copied
155 if remaining > 0
156 then do rest <- readChunk fd is_stream ptr copied remaining
157 return (rest + copied)
158 else return count
159
160 readChunk :: FD -> Bool -> RawBuffer -> Int -> Int -> IO Int
161 readChunk fd is_stream ptr init_off bytes = loop init_off bytes
162 where
163 loop :: Int -> Int -> IO Int
164 loop off bytes | bytes <= 0 = return (off - init_off)
165 loop off bytes = do
166 r' <- readRawBuffer "readChunk" (fromIntegral fd) is_stream ptr
167 (fromIntegral off) (fromIntegral bytes)
168 let r = fromIntegral r'
169 if r == 0
170 then return (off - init_off)
171 else loop (off + r) (bytes - r)
172
173 -- ---------------------------------------------------------------------------
174 -- hPutArray
175
176 -- | Writes an array of 'Word8' to the specified 'Handle'.
177 hPutArray
178 :: Handle -- ^ Handle to write to
179 -> IOUArray Int Word8 -- ^ Array to write from
180 -> Int -- ^ Number of 'Word8's to write
181 -> IO ()
182
183 hPutArray handle (IOUArray (STUArray l u raw)) count
184 | count == 0
185 = return ()
186 | count < 0 || count > rangeSize (l,u)
187 = illegalBufferSize handle "hPutArray" count
188 | otherwise
189 = do wantWritableHandle "hPutArray" handle $
190 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=stream } -> do
191
192 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
193 <- readIORef ref
194
195 -- enough room in handle buffer?
196 if (size - w > count)
197 -- There's enough room in the buffer:
198 -- just copy the data in and update bufWPtr.
199 then do memcpy_baoff_ba old_raw w raw (fromIntegral count)
200 writeIORef ref old_buf{ bufWPtr = w + count }
201 return ()
202
203 -- else, we have to flush
204 else do flushed_buf <- flushWriteBuffer fd stream old_buf
205 writeIORef ref flushed_buf
206 let this_buf =
207 Buffer{ bufBuf=raw, bufState=WriteBuffer,
208 bufRPtr=0, bufWPtr=count, bufSize=count }
209 flushWriteBuffer fd stream this_buf
210 return ()
211
212 -- ---------------------------------------------------------------------------
213 -- Internal Utils
214
215 foreign import ccall unsafe "__hscore_memcpy_dst_off"
216 memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
217 foreign import ccall unsafe "__hscore_memcpy_src_off"
218 memcpy_ba_baoff :: RawBuffer -> RawBuffer -> Int -> CSize -> IO (Ptr ())
219
220 illegalBufferSize :: Handle -> String -> Int -> IO a
221 illegalBufferSize handle fn sz =
222 ioException (IOError (Just handle)
223 InvalidArgument fn
224 ("illegal buffer size " ++ showsPrec 9 (sz::Int) [])
225 Nothing)
226
227 #else /* !__GLASGOW_HASKELL__ */
228 hGetArray :: Handle -> IOUArray Int Word8 -> Int -> IO Int
229 hGetArray handle arr count = do
230 bds <- getBounds arr
231 if count < 0 || count > rangeSize bds
232 then illegalBufferSize handle "hGetArray" count
233 else get 0
234 where
235 get i | i == count = return i
236 | otherwise = do
237 error_or_c <- try (hGetChar handle)
238 case error_or_c of
239 Left ex
240 | isEOFError ex -> return i
241 | otherwise -> ioError ex
242 Right c -> do
243 unsafeWrite arr i (fromIntegral (ord c))
244 get (i+1)
245
246 hPutArray :: Handle -> IOUArray Int Word8 -> Int -> IO ()
247 hPutArray handle arr count = do
248 bds <- getBounds arr
249 if count < 0 || count > rangeSize bds
250 then illegalBufferSize handle "hPutArray" count
251 else put 0
252 where
253 put i | i == count = return ()
254 | otherwise = do
255 w <- unsafeRead arr i
256 hPutChar handle (chr (fromIntegral w))
257 put (i+1)
258
259 illegalBufferSize :: Handle -> String -> Int -> IO a
260 illegalBufferSize _ fn sz = ioError $
261 userError (fn ++ ": illegal buffer size " ++ showsPrec 9 (sz::Int) [])
262 #endif /* !__GLASGOW_HASKELL__ */