X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Data%2FArray%2FIO.hs;h=12316836bc2db08defd50026f4bc9f8293f93bd0;hb=6b1a36a595eddf1e124529646afdb75c76a9966d;hp=bd4ad93944b40536277ca692b780ed8e1569cf9b;hpb=1a987d7f69fbf646f8b97a0eb128d6804665557a;p=haskell-directory.git

diff --git a/Data/Array/IO.hs b/Data/Array/IO.hs
index bd4ad93..1231683 100644
--- a/Data/Array/IO.hs
+++ b/Data/Array/IO.hs
@@ -1,304 +1,57 @@
-{-# OPTIONS -#include "HsBase.h" #-}
+{-# OPTIONS_GHC -#include "HsBase.h" #-}
 -----------------------------------------------------------------------------
--- 
+-- |
 -- Module      :  Data.Array.IO
 -- Copyright   :  (c) The University of Glasgow 2001
--- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
 -- 
 -- Maintainer  :  libraries@haskell.org
 -- Stability   :  experimental
--- Portability :  non-portable
---
--- $Id: IO.hs,v 1.6 2002/03/26 17:11:15 simonmar Exp $
+-- Portability :  non-portable (uses Data.Array.MArray)
 --
--- Mutable boxed/unboxed arrays in the IO monad.
+-- Mutable boxed and unboxed arrays in the IO monad.
 --
 -----------------------------------------------------------------------------
 
 module Data.Array.IO (
-   module Data.Array.MArray,
+   -- * @IO@ arrays with boxed elements
    IOArray,		-- instance of: Eq, Typeable
+
+   -- * @IO@ arrays with unboxed elements
    IOUArray,		-- instance of: Eq, Typeable
    castIOUArray,	-- :: IOUArray i a -> IO (IOUArray i b)
+
+   -- * Overloaded mutable array interface
+   module Data.Array.MArray,
+
+   -- * Doing I\/O with @IOUArray@s
    hGetArray,		-- :: Handle -> IOUArray Int Word8 -> Int -> IO Int
    hPutArray,		-- :: Handle -> IOUArray Int Word8 -> Int -> IO ()
  ) where
 
 import Prelude
 
+import Data.Array.Base
+import Data.Array.IO.Internals
 import Data.Array		( Array )
 import Data.Array.MArray
 import Data.Int
 import Data.Word
-import Data.Dynamic
-
-import Foreign.C
-import Foreign.Ptr		( Ptr, FunPtr )
-import Foreign.StablePtr	( StablePtr )
 
 #ifdef __GLASGOW_HASKELL__
--- GHC only to the end of file
-
-import Data.Array.Base
-import GHC.Arr    	( STArray, freezeSTArray, unsafeFreezeSTArray,
-                          thawSTArray, unsafeThawSTArray )
-
-import GHC.ST		( ST(..) )
+import Foreign
+import Foreign.C
 
+import GHC.Arr
 import GHC.IOBase
 import GHC.Handle
-import GHC.Conc
-
-import GHC.Base
-
------------------------------------------------------------------------------
--- Polymorphic non-strict mutable arrays (IO monad)
-
-newtype IOArray i e = IOArray (STArray RealWorld i e) deriving Eq
-
-iOArrayTc :: TyCon
-iOArrayTc = mkTyCon "IOArray"
-
-instance (Typeable a, Typeable b) => Typeable (IOArray a b) where
-  typeOf a = mkAppTy iOArrayTc [typeOf ((undefined :: IOArray a b -> a) a),
-				typeOf ((undefined :: IOArray a b -> b) a)]
-
-instance HasBounds IOArray where
-    {-# INLINE bounds #-}
-    bounds (IOArray marr) = bounds marr
-
-instance MArray IOArray e IO where
-    {-# INLINE newArray #-}
-    newArray lu init = stToIO $ do
-        marr <- newArray lu init; return (IOArray marr)
-    {-# INLINE newArray_ #-}
-    newArray_ lu = stToIO $ do
-        marr <- newArray_ lu; return (IOArray marr)
-    {-# INLINE unsafeRead #-}
-    unsafeRead (IOArray marr) i = stToIO (unsafeRead marr i)
-    {-# INLINE unsafeWrite #-}
-    unsafeWrite (IOArray marr) i e = stToIO (unsafeWrite marr i e)
-
------------------------------------------------------------------------------
--- Flat unboxed mutable arrays (IO monad)
-
-newtype IOUArray i e = IOUArray (STUArray RealWorld i e) deriving Eq
-
-iOUArrayTc :: TyCon
-iOUArrayTc = mkTyCon "IOUArray"
-
-instance (Typeable a, Typeable b) => Typeable (IOUArray a b) where
-  typeOf a = mkAppTy iOUArrayTc [typeOf ((undefined :: IOUArray a b -> a) a),
-				 typeOf ((undefined :: IOUArray a b -> b) a)]
-
-instance HasBounds IOUArray where
-    {-# INLINE bounds #-}
-    bounds (IOUArray marr) = bounds marr
-
-instance MArray IOUArray Bool IO where
-    {-# INLINE newArray #-}
-    newArray lu init = stToIO $ do
-        marr <- newArray lu init; return (IOUArray marr)
-    {-# INLINE newArray_ #-}
-    newArray_ lu = stToIO $ do
-        marr <- newArray_ lu; return (IOUArray marr)
-    {-# INLINE unsafeRead #-}
-    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
-    {-# INLINE unsafeWrite #-}
-    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
-
-instance MArray IOUArray Char IO where
-    {-# INLINE newArray #-}
-    newArray lu init = stToIO $ do
-        marr <- newArray lu init; return (IOUArray marr)
-    {-# INLINE newArray_ #-}
-    newArray_ lu = stToIO $ do
-        marr <- newArray_ lu; return (IOUArray marr)
-    {-# INLINE unsafeRead #-}
-    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
-    {-# INLINE unsafeWrite #-}
-    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
-
-instance MArray IOUArray Int IO where
-    {-# INLINE newArray #-}
-    newArray lu init = stToIO $ do
-        marr <- newArray lu init; return (IOUArray marr)
-    {-# INLINE newArray_ #-}
-    newArray_ lu = stToIO $ do
-        marr <- newArray_ lu; return (IOUArray marr)
-    {-# INLINE unsafeRead #-}
-    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
-    {-# INLINE unsafeWrite #-}
-    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
-
-instance MArray IOUArray Word IO where
-    {-# INLINE newArray #-}
-    newArray lu init = stToIO $ do
-        marr <- newArray lu init; return (IOUArray marr)
-    {-# INLINE newArray_ #-}
-    newArray_ lu = stToIO $ do
-        marr <- newArray_ lu; return (IOUArray marr)
-    {-# INLINE unsafeRead #-}
-    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
-    {-# INLINE unsafeWrite #-}
-    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
-
-instance MArray IOUArray (Ptr a) IO where
-    {-# INLINE newArray #-}
-    newArray lu init = stToIO $ do
-        marr <- newArray lu init; return (IOUArray marr)
-    {-# INLINE newArray_ #-}
-    newArray_ lu = stToIO $ do
-        marr <- newArray_ lu; return (IOUArray marr)
-    {-# INLINE unsafeRead #-}
-    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
-    {-# INLINE unsafeWrite #-}
-    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
-
-instance MArray IOUArray (FunPtr a) IO where
-    {-# INLINE newArray #-}
-    newArray lu init = stToIO $ do
-        marr <- newArray lu init; return (IOUArray marr)
-    {-# INLINE newArray_ #-}
-    newArray_ lu = stToIO $ do
-        marr <- newArray_ lu; return (IOUArray marr)
-    {-# INLINE unsafeRead #-}
-    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
-    {-# INLINE unsafeWrite #-}
-    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
-
-instance MArray IOUArray Float IO where
-    {-# INLINE newArray #-}
-    newArray lu init = stToIO $ do
-        marr <- newArray lu init; return (IOUArray marr)
-    {-# INLINE newArray_ #-}
-    newArray_ lu = stToIO $ do
-        marr <- newArray_ lu; return (IOUArray marr)
-    {-# INLINE unsafeRead #-}
-    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
-    {-# INLINE unsafeWrite #-}
-    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
-
-instance MArray IOUArray Double IO where
-    {-# INLINE newArray #-}
-    newArray lu init = stToIO $ do
-        marr <- newArray lu init; return (IOUArray marr)
-    {-# INLINE newArray_ #-}
-    newArray_ lu = stToIO $ do
-        marr <- newArray_ lu; return (IOUArray marr)
-    {-# INLINE unsafeRead #-}
-    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
-    {-# INLINE unsafeWrite #-}
-    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
-
-instance MArray IOUArray (StablePtr a) IO where
-    {-# INLINE newArray #-}
-    newArray lu init = stToIO $ do
-        marr <- newArray lu init; return (IOUArray marr)
-    {-# INLINE newArray_ #-}
-    newArray_ lu = stToIO $ do
-        marr <- newArray_ lu; return (IOUArray marr)
-    {-# INLINE unsafeRead #-}
-    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
-    {-# INLINE unsafeWrite #-}
-    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
-
-instance MArray IOUArray Int8 IO where
-    {-# INLINE newArray #-}
-    newArray lu init = stToIO $ do
-        marr <- newArray lu init; return (IOUArray marr)
-    {-# INLINE newArray_ #-}
-    newArray_ lu = stToIO $ do
-        marr <- newArray_ lu; return (IOUArray marr)
-    {-# INLINE unsafeRead #-}
-    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
-    {-# INLINE unsafeWrite #-}
-    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
-
-instance MArray IOUArray Int16 IO where
-    {-# INLINE newArray #-}
-    newArray lu init = stToIO $ do
-        marr <- newArray lu init; return (IOUArray marr)
-    {-# INLINE newArray_ #-}
-    newArray_ lu = stToIO $ do
-        marr <- newArray_ lu; return (IOUArray marr)
-    {-# INLINE unsafeRead #-}
-    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
-    {-# INLINE unsafeWrite #-}
-    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
-
-instance MArray IOUArray Int32 IO where
-    {-# INLINE newArray #-}
-    newArray lu init = stToIO $ do
-        marr <- newArray lu init; return (IOUArray marr)
-    {-# INLINE newArray_ #-}
-    newArray_ lu = stToIO $ do
-        marr <- newArray_ lu; return (IOUArray marr)
-    {-# INLINE unsafeRead #-}
-    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
-    {-# INLINE unsafeWrite #-}
-    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
-
-instance MArray IOUArray Int64 IO where
-    {-# INLINE newArray #-}
-    newArray lu init = stToIO $ do
-        marr <- newArray lu init; return (IOUArray marr)
-    {-# INLINE newArray_ #-}
-    newArray_ lu = stToIO $ do
-        marr <- newArray_ lu; return (IOUArray marr)
-    {-# INLINE unsafeRead #-}
-    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
-    {-# INLINE unsafeWrite #-}
-    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
-
-instance MArray IOUArray Word8 IO where
-    {-# INLINE newArray #-}
-    newArray lu init = stToIO $ do
-        marr <- newArray lu init; return (IOUArray marr)
-    {-# INLINE newArray_ #-}
-    newArray_ lu = stToIO $ do
-        marr <- newArray_ lu; return (IOUArray marr)
-    {-# INLINE unsafeRead #-}
-    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
-    {-# INLINE unsafeWrite #-}
-    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
-
-instance MArray IOUArray Word16 IO where
-    {-# INLINE newArray #-}
-    newArray lu init = stToIO $ do
-        marr <- newArray lu init; return (IOUArray marr)
-    {-# INLINE newArray_ #-}
-    newArray_ lu = stToIO $ do
-        marr <- newArray_ lu; return (IOUArray marr)
-    {-# INLINE unsafeRead #-}
-    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
-    {-# INLINE unsafeWrite #-}
-    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
-
-instance MArray IOUArray Word32 IO where
-    {-# INLINE newArray #-}
-    newArray lu init = stToIO $ do
-        marr <- newArray lu init; return (IOUArray marr)
-    {-# INLINE newArray_ #-}
-    newArray_ lu = stToIO $ do
-        marr <- newArray_ lu; return (IOUArray marr)
-    {-# INLINE unsafeRead #-}
-    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
-    {-# INLINE unsafeWrite #-}
-    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
-
-instance MArray IOUArray Word64 IO where
-    {-# INLINE newArray #-}
-    newArray lu init = stToIO $ do
-        marr <- newArray lu init; return (IOUArray marr)
-    {-# INLINE newArray_ #-}
-    newArray_ lu = stToIO $ do
-        marr <- newArray_ lu; return (IOUArray marr)
-    {-# INLINE unsafeRead #-}
-    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
-    {-# INLINE unsafeWrite #-}
-    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
+#else
+import Data.Char
+import System.IO
+import System.IO.Error
+#endif
 
+#ifdef __GLASGOW_HASKELL__
 -----------------------------------------------------------------------------
 -- Freezing
 
@@ -361,20 +114,24 @@ unsafeThawIOUArray arr = stToIO $ do
 "unsafeThaw/IOUArray" unsafeThaw = unsafeThawIOUArray
     #-}
 
-castSTUArray :: STUArray s ix a -> ST s (STUArray s ix b)
-castSTUArray (STUArray l u marr#) = return (STUArray l u marr#)
-
-castIOUArray :: IOUArray ix a -> IO (IOUArray ix b)
-castIOUArray (IOUArray marr) = stToIO $ do
-    marr' <- castSTUArray marr
-    return (IOUArray marr')
-
 -- ---------------------------------------------------------------------------
 -- hGetArray
 
-hGetArray :: Handle -> IOUArray Int Word8 -> Int -> IO Int
+-- | Reads a number of 'Word8's from the specified 'Handle' directly
+-- into an array.
+hGetArray
+ 	:: Handle		-- ^ Handle to read from
+	-> IOUArray Int Word8	-- ^ Array in which to place the values
+	-> Int			-- ^ Number of 'Word8's to read
+	-> IO Int
+		-- ^ Returns: the number of 'Word8's actually 
+		-- read, which might be smaller than the number requested
+		-- if the end of file was reached.
+
 hGetArray handle (IOUArray (STUArray l u ptr)) count
-  | count <= 0 || count > rangeSize (l,u)
+  | count == 0
+  = return 0
+  | count < 0 || count > rangeSize (l,u)
   = illegalBufferSize handle "hGetArray" count
   | otherwise = do
       wantReadableHandle "hGetArray" handle $ 
@@ -386,18 +143,18 @@ hGetArray handle (IOUArray (STUArray l u ptr)) count
 		let avail = w - r
 		copied <- if (count >= avail)
 		       	    then do 
-				memcpy_ba_baoff ptr raw r (fromIntegral avail)
+				memcpy_ba_baoff ptr raw (fromIntegral r) (fromIntegral avail)
 				writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
 				return avail
 		     	    else do 
-				memcpy_ba_baoff ptr raw r (fromIntegral count)
+				memcpy_ba_baoff ptr raw (fromIntegral r) (fromIntegral count)
 				writeIORef ref buf{ bufRPtr = r + count }
 				return count
 
 		let remaining = count - copied
 		if remaining > 0 
 		   then do rest <- readChunk fd is_stream ptr copied remaining
-			   return (rest + count)
+			   return (rest + copied)
 		   else return count
 
 readChunk :: FD -> Bool -> RawBuffer -> Int -> Int -> IO Int
@@ -406,10 +163,8 @@ readChunk fd is_stream ptr init_off bytes = loop init_off bytes
   loop :: Int -> Int -> IO Int
   loop off bytes | bytes <= 0 = return (off - init_off)
   loop off bytes = do
-    r' <- throwErrnoIfMinus1RetryMayBlock "readChunk"
-	    (read_off_ba (fromIntegral fd) is_stream ptr 
-		(fromIntegral off) (fromIntegral bytes))
-	    (threadWaitRead fd)
+    r' <- readRawBuffer "readChunk" (fromIntegral fd) is_stream ptr
+    				    (fromIntegral off) (fromIntegral bytes)
     let r = fromIntegral r'
     if r == 0
 	then return (off - init_off)
@@ -418,14 +173,17 @@ readChunk fd is_stream ptr init_off bytes = loop init_off bytes
 -- ---------------------------------------------------------------------------
 -- hPutArray
 
+-- | Writes an array of 'Word8' to the specified 'Handle'.
 hPutArray
-	:: Handle			-- handle to write to
-	-> IOUArray Int Word8		-- buffer
-	-> Int				-- number of bytes of data to write
+	:: Handle			-- ^ Handle to write to
+	-> IOUArray Int Word8		-- ^ Array to write from
+	-> Int				-- ^ Number of 'Word8's to write
 	-> IO ()
 
 hPutArray handle (IOUArray (STUArray l u raw)) count
-  | count <= 0 || count > rangeSize (l,u)
+  | count == 0
+  = return ()
+  | count < 0 || count > rangeSize (l,u)
   = illegalBufferSize handle "hPutArray" count
   | otherwise
    = do wantWritableHandle "hPutArray" handle $ 
@@ -438,7 +196,7 @@ hPutArray handle (IOUArray (STUArray l u raw)) count
           if (size - w > count)
 		-- There's enough room in the buffer:
 		-- just copy the data in and update bufWPtr.
-	    then do memcpy_baoff_ba old_raw w raw (fromIntegral count)
+	    then do memcpy_baoff_ba old_raw (fromIntegral w) raw (fromIntegral count)
 		    writeIORef ref old_buf{ bufWPtr = w + count }
 		    return ()
 
@@ -455,9 +213,9 @@ hPutArray handle (IOUArray (STUArray l u raw)) count
 -- Internal Utils
 
 foreign import ccall unsafe "__hscore_memcpy_dst_off"
-   memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
+   memcpy_baoff_ba :: RawBuffer -> CInt -> RawBuffer -> CSize -> IO (Ptr ())
 foreign import ccall unsafe "__hscore_memcpy_src_off"
-   memcpy_ba_baoff :: RawBuffer -> RawBuffer -> Int -> CSize -> IO (Ptr ())
+   memcpy_ba_baoff :: RawBuffer -> RawBuffer -> CInt -> CSize -> IO (Ptr ())
 
 illegalBufferSize :: Handle -> String -> Int -> IO a
 illegalBufferSize handle fn sz = 
@@ -466,4 +224,39 @@ illegalBufferSize handle fn sz =
 			    ("illegal buffer size " ++ showsPrec 9 (sz::Int) [])
 			    Nothing)
 
-#endif /* __GLASGOW_HASKELL__ */
+#else /* !__GLASGOW_HASKELL__ */
+hGetArray :: Handle -> IOUArray Int Word8 -> Int -> IO Int
+hGetArray handle arr count = do
+	bds <- getBounds arr
+	if count < 0 || count > rangeSize bds
+	   then illegalBufferSize handle "hGetArray" count
+	   else get 0
+ where
+  get i | i == count = return i
+	| otherwise = do
+		error_or_c <- try (hGetChar handle)
+		case error_or_c of
+		    Left ex
+			| isEOFError ex -> return i
+			| otherwise -> ioError ex
+		    Right c -> do
+			unsafeWrite arr i (fromIntegral (ord c))
+			get (i+1)
+
+hPutArray :: Handle -> IOUArray Int Word8 -> Int -> IO ()
+hPutArray handle arr count = do
+	bds <- getBounds arr
+	if count < 0 || count > rangeSize bds
+	   then illegalBufferSize handle "hPutArray" count
+	   else put 0
+ where
+  put i | i == count = return ()
+	| otherwise = do
+		w <- unsafeRead arr i
+		hPutChar handle (chr (fromIntegral w))
+		put (i+1)
+
+illegalBufferSize :: Handle -> String -> Int -> IO a
+illegalBufferSize _ fn sz = ioError $
+	userError (fn ++ ": illegal buffer size " ++ showsPrec 9 (sz::Int) [])
+#endif /* !__GLASGOW_HASKELL__ */