X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Data%2FArray%2FIO.hs;h=b43573d7613f66bf578b116fb65704e5cccb8dff;hb=cf60c1b36b79bb79003825e4e1d7647a301a9c6e;hp=b225e4b4c1601878edcf681ca777d5b5259c1be5;hpb=69c06d8a8b8a90492b81b1f252094949e0ace294;p=ghc-base.git

diff --git a/Data/Array/IO.hs b/Data/Array/IO.hs
index b225e4b..b43573d 100644
--- a/Data/Array/IO.hs
+++ b/Data/Array/IO.hs
@@ -31,292 +31,27 @@ module Data.Array.IO (
 
 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
-
------------------------------------------------------------------------------
--- | Mutable, boxed, non-strict arrays in the 'IO' monad.  The type
--- arguments are as follows:
---
---  * @i@: the index type of the array (should be an instance of @Ix@)
---
---  * @e@: the element type of the array.
---
-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)
-
--- | Mutable, unboxed, strict arrays in the 'IO' monad.  The type
--- arguments are as follows:
---
---  * @i@: the index type of the array (should be an instance of @Ix@)
---
---  * @e@: the element type of the array.  Only certain element types
---    are supported: see 'MArray' for a list of instances.
---
-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
 
@@ -379,17 +114,6 @@ 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#)
-
--- | Casts an 'IOUArray' with one element type into one with a
--- different element type.  All the elements of the resulting array
--- are undefined (unless you know what you\'re doing...).
-castIOUArray :: IOUArray ix a -> IO (IOUArray ix b)
-castIOUArray (IOUArray marr) = stToIO $ do
-    marr' <- castSTUArray marr
-    return (IOUArray marr')
-
 -- ---------------------------------------------------------------------------
 -- hGetArray
 
@@ -405,7 +129,9 @@ hGetArray
 		-- 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 $ 
@@ -428,7 +154,7 @@ hGetArray handle (IOUArray (STUArray l u ptr)) 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
@@ -437,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)
@@ -457,7 +181,9 @@ hPutArray
 	-> 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 $ 
@@ -498,4 +224,37 @@ 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
+  | count < 0 || count > rangeSize (bounds arr)
+  = illegalBufferSize handle "hGetArray" count
+  | otherwise = 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
+  | count < 0 || count > rangeSize (bounds arr)
+  = illegalBufferSize handle "hPutArray" count
+  | otherwise = 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__ */