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__ */