--- /dev/null
+{-# OPTIONS -fno-implicit-prelude -#include "PrelIOUtils.h" #-}
+
+#undef DEBUG_DUMP
+#undef DEBUG
+
+-- -----------------------------------------------------------------------------
+-- $Id: PrelHandle.hs,v 1.1 2001/11/07 18:25:35 sof Exp $
+--
+-- (c) The University of Glasgow, 1994-2001
+--
+-- This module defines the basic operations on I/O "handles".
+
+module PrelHandle (
+ withHandle, withHandle', withHandle_,
+ wantWritableHandle, wantReadableHandle, wantSeekableHandle,
+
+ newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer,
+ flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer, fillReadBuffer,
+ read_off,
+
+ ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,
+
+ stdin, stdout, stderr,
+ IOMode(..), IOModeEx(..), openFile, openFileEx, openFd,
+ hFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode,
+ hFlush,
+
+ hClose, hClose_help,
+
+ HandlePosn(..), hGetPosn, hSetPosn,
+ SeekMode(..), hSeek,
+
+ hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable,
+ hSetEcho, hGetEcho, hIsTerminalDevice,
+ ioeGetFileName, ioeGetErrorString, ioeGetHandle,
+
+#ifdef DEBUG_DUMP
+ puts,
+#endif
+
+ ) where
+
+#include "config.h"
+
+import Monad
+
+import PrelBits
+import PrelPosix hiding ( o_BINARY )
+import PrelMarshalUtils
+import PrelCString
+import PrelCTypes
+import PrelCError
+import PrelReal
+
+import PrelArr
+import PrelBase
+import PrelPtr
+import PrelRead ( Read )
+import PrelList
+import PrelIOBase
+import PrelMaybe ( Maybe(..) )
+import PrelException
+import PrelEnum
+import PrelNum ( Integer(..), Num(..) )
+import PrelShow
+import PrelReal ( toInteger )
+
+import PrelConc
+
+-- -----------------------------------------------------------------------------
+-- TODO:
+
+-- hWaitForInput blocks (should use a timeout)
+
+-- unbuffered hGetLine is a bit dodgy
+
+-- hSetBuffering: can't change buffering on a stream,
+-- when the read buffer is non-empty? (no way to flush the buffer)
+
+-- ---------------------------------------------------------------------------
+-- Are files opened by default in text or binary mode, if the user doesn't
+-- specify?
+dEFAULT_OPEN_IN_BINARY_MODE :: Bool
+dEFAULT_OPEN_IN_BINARY_MODE = False
+
+-- Is seeking on text-mode handles allowed, or not?
+foreign import ccall "prel_supportsTextMode" unsafe tEXT_MODE_SEEK_ALLOWED :: Bool
+
+-- ---------------------------------------------------------------------------
+-- Creating a new handle
+
+newFileHandle :: (MVar Handle__ -> IO ()) -> Handle__ -> IO Handle
+newFileHandle finalizer hc = do
+ m <- newMVar hc
+ addMVarFinalizer m (finalizer m)
+ return (FileHandle m)
+
+-- ---------------------------------------------------------------------------
+-- Working with Handles
+
+{-
+In the concurrent world, handles are locked during use. This is done
+by wrapping an MVar around the handle which acts as a mutex over
+operations on the handle.
+
+To avoid races, we use the following bracketing operations. The idea
+is to obtain the lock, do some operation and replace the lock again,
+whether the operation succeeded or failed. We also want to handle the
+case where the thread receives an exception while processing the IO
+operation: in these cases we also want to relinquish the lock.
+
+There are three versions of @withHandle@: corresponding to the three
+possible combinations of:
+
+ - the operation may side-effect the handle
+ - the operation may return a result
+
+If the operation generates an error or an exception is raised, the
+original handle is always replaced [ this is the case at the moment,
+but we might want to revisit this in the future --SDM ].
+-}
+
+{-# INLINE withHandle #-}
+withHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
+withHandle fun h@(FileHandle m) act = withHandle' fun h m act
+withHandle fun h@(DuplexHandle m _) act = withHandle' fun h m act
+
+withHandle' fun h m act =
+ block $ do
+ h_ <- takeMVar m
+ checkBufferInvariants h_
+ (h',v) <- catchException (act h_)
+ (\ ex -> putMVar m h_ >> throw (augmentIOError ex fun h h_))
+ checkBufferInvariants h'
+ putMVar m h'
+ return v
+
+{-# INLINE withHandle_ #-}
+withHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a
+withHandle_ fun h@(FileHandle m) act = withHandle_' fun h m act
+withHandle_ fun h@(DuplexHandle m _) act = withHandle_' fun h m act
+
+withHandle_' fun h m act =
+ block $ do
+ h_ <- takeMVar m
+ checkBufferInvariants h_
+ v <- catchException (act h_)
+ (\ ex -> putMVar m h_ >> throw (augmentIOError ex fun h h_))
+ checkBufferInvariants h_
+ putMVar m h_
+ return v
+
+withAllHandles__ :: String -> Handle -> (Handle__ -> IO Handle__) -> IO ()
+withAllHandles__ fun h@(FileHandle m) act = withHandle__' fun h m act
+withAllHandles__ fun h@(DuplexHandle r w) act = do
+ withHandle__' fun h r act
+ withHandle__' fun h w act
+
+withHandle__' fun h m act =
+ block $ do
+ h_ <- takeMVar m
+ checkBufferInvariants h_
+ h' <- catchException (act h_)
+ (\ ex -> putMVar m h_ >> throw (augmentIOError ex fun h h_))
+ checkBufferInvariants h'
+ putMVar m h'
+ return ()
+
+augmentIOError (IOException (IOError _ iot _ str fp)) fun h h_
+ = IOException (IOError (Just h) iot fun str filepath)
+ where filepath | Just _ <- fp = fp
+ | otherwise = Just (haFilePath h_)
+augmentIOError other_exception _ _ _
+ = other_exception
+
+-- ---------------------------------------------------------------------------
+-- Wrapper for write operations.
+
+wantWritableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
+wantWritableHandle fun h@(FileHandle m) act
+ = wantWritableHandle' fun h m act
+wantWritableHandle fun h@(DuplexHandle _ m) act
+ = wantWritableHandle' fun h m act
+ -- ToDo: in the Duplex case, we don't need to checkWritableHandle
+
+wantWritableHandle'
+ :: String -> Handle -> MVar Handle__
+ -> (Handle__ -> IO a) -> IO a
+wantWritableHandle' fun h m act
+ = withHandle_' fun h m (checkWritableHandle act)
+
+checkWritableHandle act handle_
+ = case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ ReadHandle -> ioe_notWritable
+ ReadWriteHandle -> do
+ let ref = haBuffer handle_
+ buf <- readIORef ref
+ new_buf <-
+ if not (bufferIsWritable buf)
+ then do b <- flushReadBuffer (haFD handle_) buf
+ return b{ bufState=WriteBuffer }
+ else return buf
+ writeIORef ref new_buf
+ act handle_
+ _other -> act handle_
+
+-- ---------------------------------------------------------------------------
+-- Wrapper for read operations.
+
+wantReadableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
+wantReadableHandle fun h@(FileHandle m) act
+ = wantReadableHandle' fun h m act
+wantReadableHandle fun h@(DuplexHandle m _) act
+ = wantReadableHandle' fun h m act
+ -- ToDo: in the Duplex case, we don't need to checkReadableHandle
+
+wantReadableHandle'
+ :: String -> Handle -> MVar Handle__
+ -> (Handle__ -> IO a) -> IO a
+wantReadableHandle' fun h m act
+ = withHandle_' fun h m (checkReadableHandle act)
+
+checkReadableHandle act handle_ =
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ AppendHandle -> ioe_notReadable
+ WriteHandle -> ioe_notReadable
+ ReadWriteHandle -> do
+ let ref = haBuffer handle_
+ buf <- readIORef ref
+ when (bufferIsWritable buf) $ do
+ new_buf <- flushWriteBuffer (haFD handle_) buf
+ writeIORef ref new_buf{ bufState=ReadBuffer }
+ act handle_
+ _other -> act handle_
+
+-- ---------------------------------------------------------------------------
+-- Wrapper for seek operations.
+
+wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
+wantSeekableHandle fun h@(DuplexHandle _ _) _act =
+ ioException (IOError (Just h) IllegalOperation fun
+ "handle is not seekable" Nothing)
+wantSeekableHandle fun h@(FileHandle m) act =
+ withHandle_' fun h m (checkSeekableHandle act)
+
+checkSeekableHandle act handle_ =
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ AppendHandle -> ioe_notSeekable
+ _ | haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED -> act handle_
+ | otherwise -> ioe_notSeekable_notBin
+
+-- -----------------------------------------------------------------------------
+-- Handy IOErrors
+
+ioe_closedHandle, ioe_EOF,
+ ioe_notReadable, ioe_notWritable,
+ ioe_notSeekable, ioe_notSeekable_notBin :: IO a
+
+ioe_closedHandle = ioException
+ (IOError Nothing IllegalOperation ""
+ "handle is closed" Nothing)
+ioe_EOF = ioException
+ (IOError Nothing EOF "" "" Nothing)
+ioe_notReadable = ioException
+ (IOError Nothing IllegalOperation ""
+ "handle is not open for reading" Nothing)
+ioe_notWritable = ioException
+ (IOError Nothing IllegalOperation ""
+ "handle is not open for writing" Nothing)
+ioe_notSeekable = ioException
+ (IOError Nothing IllegalOperation ""
+ "handle is not seekable" Nothing)
+ioe_notSeekable_notBin = ioException
+ (IOError Nothing IllegalOperation ""
+ "seek operations on text-mode handles are not allowed on this platform"
+ Nothing)
+
+ioe_bufsiz :: Int -> IO a
+ioe_bufsiz n = ioException
+ (IOError Nothing InvalidArgument "hSetBuffering"
+ ("illegal buffer size " ++ showsPrec 9 n []) Nothing)
+ -- 9 => should be parens'ified.
+
+-- -----------------------------------------------------------------------------
+-- Handle Finalizers
+
+-- For a duplex handle, we arrange that the read side points to the write side
+-- (and hence keeps it alive if the read side is alive). This is done by
+-- having the haType field of the read side be ReadSideHandle with a pointer
+-- to the write side. The finalizer is then placed on the write side, and
+-- the handle only gets finalized once, when both sides are no longer
+-- required.
+
+addFinalizer :: Handle -> IO ()
+addFinalizer (FileHandle m) = addMVarFinalizer m (handleFinalizer m)
+addFinalizer (DuplexHandle _ w) = addMVarFinalizer w (handleFinalizer w)
+
+stdHandleFinalizer :: MVar Handle__ -> IO ()
+stdHandleFinalizer m = do
+ h_ <- takeMVar m
+ flushWriteBufferOnly h_
+
+handleFinalizer :: MVar Handle__ -> IO ()
+handleFinalizer m = do
+ h_ <- takeMVar m
+ flushWriteBufferOnly h_
+ let fd = fromIntegral (haFD h_)
+ unlockFile fd
+ -- ToDo: closesocket() for a WINSOCK socket?
+ when (fd /= -1) (c_close fd >> return ())
+ return ()
+
+-- ---------------------------------------------------------------------------
+-- Grimy buffer operations
+
+#ifdef DEBUG
+checkBufferInvariants h_ = do
+ let ref = haBuffer h_
+ Buffer{ bufWPtr=w, bufRPtr=r, bufSize=size, bufState=state } <- readIORef ref
+ if not (
+ size > 0
+ && r <= w
+ && w <= size
+ && ( r /= w || (r == 0 && w == 0) )
+ && ( state /= WriteBuffer || r == 0 )
+ && ( state /= WriteBuffer || w < size ) -- write buffer is never full
+ )
+ then error "buffer invariant violation"
+ else return ()
+#else
+checkBufferInvariants h_ = return ()
+#endif
+
+newEmptyBuffer :: RawBuffer -> BufferState -> Int -> Buffer
+newEmptyBuffer b state size
+ = Buffer{ bufBuf=b, bufRPtr=0, bufWPtr=0, bufSize=size, bufState=state }
+
+allocateBuffer :: Int -> BufferState -> IO Buffer
+allocateBuffer sz@(I# size) state = IO $ \s ->
+ case newByteArray# size s of { (# s, b #) ->
+ (# s, newEmptyBuffer b state sz #) }
+
+writeCharIntoBuffer :: RawBuffer -> Int -> Char -> IO Int
+writeCharIntoBuffer slab (I# off) (C# c)
+ = IO $ \s -> case writeCharArray# slab off c s of
+ s -> (# s, I# (off +# 1#) #)
+
+readCharFromBuffer :: RawBuffer -> Int -> IO (Char, Int)
+readCharFromBuffer slab (I# off)
+ = IO $ \s -> case readCharArray# slab off s of
+ (# s, c #) -> (# s, (C# c, I# (off +# 1#)) #)
+
+getBuffer :: FD -> BufferState -> IO (IORef Buffer, BufferMode)
+getBuffer fd state = do
+ buffer <- allocateBuffer dEFAULT_BUFFER_SIZE state
+ ioref <- newIORef buffer
+ is_tty <- fdIsTTY fd
+
+ let buffer_mode
+ | is_tty = LineBuffering
+ | otherwise = BlockBuffering Nothing
+
+ return (ioref, buffer_mode)
+
+mkUnBuffer :: IO (IORef Buffer)
+mkUnBuffer = do
+ buffer <- allocateBuffer 1 ReadBuffer
+ newIORef buffer
+
+-- flushWriteBufferOnly flushes the buffer iff it contains pending write data.
+flushWriteBufferOnly :: Handle__ -> IO ()
+flushWriteBufferOnly h_ = do
+ let fd = haFD h_
+ ref = haBuffer h_
+ buf <- readIORef ref
+ new_buf <- if bufferIsWritable buf
+ then flushWriteBuffer fd buf
+ else return buf
+ writeIORef ref new_buf
+
+-- flushBuffer syncs the file with the buffer, including moving the
+-- file pointer backwards in the case of a read buffer.
+flushBuffer :: Handle__ -> IO ()
+flushBuffer h_ = do
+ let ref = haBuffer h_
+ buf <- readIORef ref
+
+ flushed_buf <-
+ case bufState buf of
+ ReadBuffer -> flushReadBuffer (haFD h_) buf
+ WriteBuffer -> flushWriteBuffer (haFD h_) buf
+
+ writeIORef ref flushed_buf
+
+-- When flushing a read buffer, we seek backwards by the number of
+-- characters in the buffer. The file descriptor must therefore be
+-- seekable: attempting to flush the read buffer on an unseekable
+-- handle is not allowed.
+
+flushReadBuffer :: FD -> Buffer -> IO Buffer
+flushReadBuffer fd buf
+ | bufferEmpty buf = return buf
+ | otherwise = do
+ let off = negate (bufWPtr buf - bufRPtr buf)
+# ifdef DEBUG_DUMP
+ puts ("flushReadBuffer: new file offset = " ++ show off ++ "\n")
+# endif
+ throwErrnoIfMinus1Retry "flushReadBuffer"
+ (c_lseek (fromIntegral fd) (fromIntegral off) sEEK_CUR)
+ return buf{ bufWPtr=0, bufRPtr=0 }
+
+flushWriteBuffer :: FD -> Buffer -> IO Buffer
+flushWriteBuffer fd buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } = do
+ let bytes = w - r
+#ifdef DEBUG_DUMP
+ puts ("flushWriteBuffer, fd=" ++ show fd ++ ", bytes=" ++ show bytes ++ "\n")
+#endif
+ if bytes == 0
+ then return (buf{ bufRPtr=0, bufWPtr=0 })
+ else do
+ res <- throwErrnoIfMinus1RetryMayBlock "flushWriteBuffer"
+ (write_off (fromIntegral fd) b (fromIntegral r)
+ (fromIntegral bytes))
+ (threadWaitWrite fd)
+ let res' = fromIntegral res
+ if res' < bytes
+ then flushWriteBuffer fd (buf{ bufRPtr = r + res' })
+ else return buf{ bufRPtr=0, bufWPtr=0 }
+
+foreign import "prel_PrelHandle_write" unsafe
+ write_off :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
+
+
+fillReadBuffer :: FD -> Bool -> Buffer -> IO Buffer
+fillReadBuffer fd is_line
+ buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } =
+ -- buffer better be empty:
+ assert (r == 0 && w == 0) $ do
+ fillReadBufferLoop fd is_line buf b w size
+
+-- For a line buffer, we just get the first chunk of data to arrive,
+-- and don't wait for the whole buffer to be full (but we *do* wait
+-- until some data arrives). This isn't really line buffering, but it
+-- appears to be what GHC has done for a long time, and I suspect it
+-- is more useful than line buffering in most cases.
+
+fillReadBufferLoop fd is_line buf b w size = do
+ let bytes = size - w
+ if bytes == 0 -- buffer full?
+ then return buf{ bufRPtr=0, bufWPtr=w }
+ else do
+#ifdef DEBUG_DUMP
+ puts ("fillReadBufferLoop: bytes = " ++ show bytes ++ "\n")
+#endif
+ res <- throwErrnoIfMinus1RetryMayBlock "fillReadBuffer"
+ (read_off fd b (fromIntegral w) (fromIntegral bytes))
+ (threadWaitRead fd)
+ let res' = fromIntegral res
+#ifdef DEBUG_DUMP
+ puts ("fillReadBufferLoop: res' = " ++ show res' ++ "\n")
+#endif
+ if res' == 0
+ then if w == 0
+ then ioe_EOF
+ else return buf{ bufRPtr=0, bufWPtr=w }
+ else if res' < bytes && not is_line
+ then fillReadBufferLoop fd is_line buf b (w+res') size
+ else return buf{ bufRPtr=0, bufWPtr=w+res' }
+
+foreign import "prel_PrelHandle_read" unsafe
+ read_off :: FD -> RawBuffer -> Int -> CInt -> IO CInt
+
+-- ---------------------------------------------------------------------------
+-- Standard Handles
+
+-- Three handles are allocated during program initialisation. The first
+-- two manage input or output from the Haskell program's standard input
+-- or output channel respectively. The third manages output to the
+-- standard error channel. These handles are initially open.
+
+fd_stdin = 0 :: FD
+fd_stdout = 1 :: FD
+fd_stderr = 2 :: FD
+
+stdin :: Handle
+stdin = unsafePerformIO $ do
+ -- ToDo: acquire lock
+ setNonBlockingFD fd_stdin
+ (buf, bmode) <- getBuffer fd_stdin ReadBuffer
+ spares <- newIORef BufferListNil
+ newFileHandle stdHandleFinalizer
+ (Handle__ { haFD = fd_stdin,
+ haType = ReadHandle,
+ haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
+ haBufferMode = bmode,
+ haFilePath = "<stdin>",
+ haBuffer = buf,
+ haBuffers = spares
+ })
+
+stdout :: Handle
+stdout = unsafePerformIO $ do
+ -- ToDo: acquire lock
+ -- We don't set non-blocking mode on stdout or sterr, because
+ -- some shells don't recover properly.
+ -- setNonBlockingFD fd_stdout
+ (buf, bmode) <- getBuffer fd_stdout WriteBuffer
+ spares <- newIORef BufferListNil
+ newFileHandle stdHandleFinalizer
+ (Handle__ { haFD = fd_stdout,
+ haType = WriteHandle,
+ haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
+ haBufferMode = bmode,
+ haFilePath = "<stdout>",
+ haBuffer = buf,
+ haBuffers = spares
+ })
+
+stderr :: Handle
+stderr = unsafePerformIO $ do
+ -- ToDo: acquire lock
+ -- We don't set non-blocking mode on stdout or sterr, because
+ -- some shells don't recover properly.
+ -- setNonBlockingFD fd_stderr
+ buffer <- mkUnBuffer
+ spares <- newIORef BufferListNil
+ newFileHandle stdHandleFinalizer
+ (Handle__ { haFD = fd_stderr,
+ haType = WriteHandle,
+ haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
+ haBufferMode = NoBuffering,
+ haFilePath = "<stderr>",
+ haBuffer = buffer,
+ haBuffers = spares
+ })
+
+-- ---------------------------------------------------------------------------
+-- Opening and Closing Files
+
+{-
+Computation `openFile file mode' allocates and returns a new, open
+handle to manage the file `file'. It manages input if `mode'
+is `ReadMode', output if `mode' is `WriteMode' or `AppendMode',
+and both input and output if mode is `ReadWriteMode'.
+
+If the file does not exist and it is opened for output, it should be
+created as a new file. If `mode' is `WriteMode' and the file
+already exists, then it should be truncated to zero length. The
+handle is positioned at the end of the file if `mode' is
+`AppendMode', and otherwise at the beginning (in which case its
+internal position is 0).
+
+Implementations should enforce, locally to the Haskell process,
+multiple-reader single-writer locking on files, which is to say that
+there may either be many handles on the same file which manage input,
+or just one handle on the file which manages output. If any open or
+semi-closed handle is managing a file for output, no new handle can be
+allocated for that file. If any open or semi-closed handle is
+managing a file for input, new handles can only be allocated if they
+do not manage output.
+
+Two files are the same if they have the same absolute name. An
+implementation is free to impose stricter conditions.
+-}
+
+data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode
+ deriving (Eq, Ord, Ix, Enum, Read, Show)
+
+data IOModeEx
+ = BinaryMode IOMode
+ | TextMode IOMode
+ deriving (Eq, Read, Show)
+
+addFilePathToIOError fun fp (IOException (IOError h iot _ str _))
+ = IOException (IOError h iot fun str (Just fp))
+addFilePathToIOError _ _ other_exception
+ = other_exception
+
+openFile :: FilePath -> IOMode -> IO Handle
+openFile fp im =
+ catch
+ (openFile' fp (if dEFAULT_OPEN_IN_BINARY_MODE
+ then BinaryMode im
+ else TextMode im))
+ (\e -> throw (addFilePathToIOError "openFile" fp e))
+
+openFileEx :: FilePath -> IOModeEx -> IO Handle
+openFileEx fp m =
+ catch
+ (openFile' fp m)
+ (\e -> throw (addFilePathToIOError "openFileEx" fp e))
+
+
+openFile' filepath ex_mode =
+ withCString filepath $ \ f ->
+
+ let
+ (mode, binary) =
+ case ex_mode of
+ BinaryMode bmo -> (bmo, True)
+ TextMode tmo -> (tmo, False)
+
+ oflags1 = case mode of
+ ReadMode -> read_flags
+ WriteMode -> write_flags
+ ReadWriteMode -> rw_flags
+ AppendMode -> append_flags
+
+ truncate | WriteMode <- mode = True
+ | otherwise = False
+
+ binary_flags
+ | binary = o_BINARY -- is '0' if not supported.
+ | otherwise = 0
+
+ oflags = oflags1 .|. binary_flags
+ in do
+
+ -- the old implementation had a complicated series of three opens,
+ -- which is perhaps because we have to be careful not to open
+ -- directories. However, the man pages I've read say that open()
+ -- always returns EISDIR if the file is a directory and was opened
+ -- for writing, so I think we're ok with a single open() here...
+ fd <- fromIntegral `liftM`
+ throwErrnoIfMinus1Retry "openFile"
+ (c_open f (fromIntegral oflags) 0o666)
+
+ openFd fd filepath mode binary truncate
+ -- ASSERT: if we just created the file, then openFd won't fail
+ -- (so we don't need to worry about removing the newly created file
+ -- in the event of an error).
+
+
+std_flags = o_NONBLOCK .|. o_NOCTTY
+output_flags = std_flags .|. o_CREAT
+read_flags = std_flags .|. o_RDONLY
+write_flags = output_flags .|. o_WRONLY
+rw_flags = output_flags .|. o_RDWR
+append_flags = write_flags .|. o_APPEND
+
+-- ---------------------------------------------------------------------------
+-- openFd
+
+openFd :: FD -> FilePath -> IOMode -> Bool -> Bool -> IO Handle
+openFd fd filepath mode binary truncate = do
+ -- turn on non-blocking mode
+ setNonBlockingFD fd
+
+ let (ha_type, write) =
+ case mode of
+ ReadMode -> ( ReadHandle, False )
+ WriteMode -> ( WriteHandle, True )
+ ReadWriteMode -> ( ReadWriteHandle, True )
+ AppendMode -> ( AppendHandle, True )
+
+ -- open() won't tell us if it was a directory if we only opened for
+ -- reading, so check again.
+ fd_type <- fdType fd
+ case fd_type of
+ Directory ->
+ ioException (IOError Nothing InappropriateType "openFile"
+ "is a directory" Nothing)
+
+ Stream
+ | ReadWriteHandle <- ha_type -> mkDuplexHandle fd filepath binary
+ | otherwise -> mkFileHandle fd filepath ha_type binary
+
+ -- regular files need to be locked
+ RegularFile -> do
+ r <- lockFile (fromIntegral fd) (fromBool write) 1{-exclusive-}
+ when (r == -1) $
+ ioException (IOError Nothing ResourceBusy "openFile"
+ "file is locked" Nothing)
+
+ -- truncate the file if necessary
+ when truncate (fileTruncate filepath)
+
+ mkFileHandle fd filepath ha_type binary
+
+
+foreign import "lockFile" unsafe
+ lockFile :: CInt -> CInt -> CInt -> IO CInt
+
+foreign import "unlockFile" unsafe
+ unlockFile :: CInt -> IO CInt
+
+mkFileHandle :: FD -> FilePath -> HandleType -> Bool -> IO Handle
+mkFileHandle fd filepath ha_type binary = do
+ (buf, bmode) <- getBuffer fd (initBufferState ha_type)
+ spares <- newIORef BufferListNil
+ newFileHandle handleFinalizer
+ (Handle__ { haFD = fd,
+ haType = ha_type,
+ haIsBin = binary,
+ haBufferMode = bmode,
+ haFilePath = filepath,
+ haBuffer = buf,
+ haBuffers = spares
+ })
+
+mkDuplexHandle :: FD -> FilePath -> Bool -> IO Handle
+mkDuplexHandle fd filepath binary = do
+ (w_buf, w_bmode) <- getBuffer fd WriteBuffer
+ w_spares <- newIORef BufferListNil
+ let w_handle_ =
+ Handle__ { haFD = fd,
+ haType = WriteHandle,
+ haIsBin = binary,
+ haBufferMode = w_bmode,
+ haFilePath = filepath,
+ haBuffer = w_buf,
+ haBuffers = w_spares
+ }
+ write_side <- newMVar w_handle_
+
+ (r_buf, r_bmode) <- getBuffer fd ReadBuffer
+ r_spares <- newIORef BufferListNil
+ let r_handle_ =
+ Handle__ { haFD = fd,
+ haType = ReadSideHandle write_side,
+ haIsBin = binary,
+ haBufferMode = r_bmode,
+ haFilePath = filepath,
+ haBuffer = r_buf,
+ haBuffers = r_spares
+ }
+ read_side <- newMVar r_handle_
+
+ addMVarFinalizer write_side (handleFinalizer write_side)
+ return (DuplexHandle read_side write_side)
+
+
+initBufferState ReadHandle = ReadBuffer
+initBufferState _ = WriteBuffer
+
+-- ---------------------------------------------------------------------------
+-- Closing a handle
+
+-- Computation `hClose hdl' makes handle `hdl' closed. Before the
+-- computation finishes, any items buffered for output and not already
+-- sent to the operating system are flushed as for `hFlush'.
+
+-- For a duplex handle, we close&flush the write side, and just close
+-- the read side.
+
+hClose :: Handle -> IO ()
+hClose h@(FileHandle m) = hClose' h m
+hClose h@(DuplexHandle r w) = do
+ hClose' h w
+ withHandle__' "hClose" h r $ \ handle_ -> do
+ return handle_{ haFD = -1,
+ haType = ClosedHandle
+ }
+
+hClose' h m = withHandle__' "hClose" h m $ hClose_help
+
+hClose_help handle_ =
+ case haType handle_ of
+ ClosedHandle -> return handle_
+ _ -> do
+ let fd = fromIntegral (haFD handle_)
+ flushWriteBufferOnly handle_
+ throwErrnoIfMinus1Retry_ "hClose" (c_close fd)
+
+ -- free the spare buffers
+ writeIORef (haBuffers handle_) BufferListNil
+
+ -- unlock it
+ unlockFile fd
+
+ -- we must set the fd to -1, because the finalizer is going
+ -- to run eventually and try to close/unlock it.
+ return (handle_{ haFD = -1,
+ haType = ClosedHandle
+ })
+
+-----------------------------------------------------------------------------
+-- Detecting the size of a file
+
+-- For a handle `hdl' which attached to a physical file, `hFileSize
+-- hdl' returns the size of `hdl' in terms of the number of items
+-- which can be read from `hdl'.
+
+hFileSize :: Handle -> IO Integer
+hFileSize handle =
+ withHandle_ "hFileSize" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ _ -> do flushWriteBufferOnly handle_
+ r <- fdFileSize (haFD handle_)
+ if r /= -1
+ then return r
+ else ioException (IOError Nothing InappropriateType "hFileSize"
+ "not a regular file" Nothing)
+
+-- ---------------------------------------------------------------------------
+-- Detecting the End of Input
+
+-- For a readable handle `hdl', `hIsEOF hdl' returns
+-- `True' if no further input can be taken from `hdl' or for a
+-- physical file, if the current I/O position is equal to the length of
+-- the file. Otherwise, it returns `False'.
+
+hIsEOF :: Handle -> IO Bool
+hIsEOF handle =
+ catch
+ (do hLookAhead handle; return False)
+ (\e -> if isEOFError e then return True else throw e)
+
+isEOF :: IO Bool
+isEOF = hIsEOF stdin
+
+-- ---------------------------------------------------------------------------
+-- Looking ahead
+
+-- hLookahead returns the next character from the handle without
+-- removing it from the input buffer, blocking until a character is
+-- available.
+
+hLookAhead :: Handle -> IO Char
+hLookAhead handle = do
+ wantReadableHandle "hLookAhead" handle $ \handle_ -> do
+ let ref = haBuffer handle_
+ fd = haFD handle_
+ is_line = haBufferMode handle_ == LineBuffering
+ buf <- readIORef ref
+
+ -- fill up the read buffer if necessary
+ new_buf <- if bufferEmpty buf
+ then fillReadBuffer fd is_line buf
+ else return buf
+
+ writeIORef ref new_buf
+
+ (c,_) <- readCharFromBuffer (bufBuf buf) (bufRPtr buf)
+ return c
+
+-- ---------------------------------------------------------------------------
+-- Buffering Operations
+
+-- Three kinds of buffering are supported: line-buffering,
+-- block-buffering or no-buffering. See PrelIOBase for definition and
+-- further explanation of what the type represent.
+
+-- Computation `hSetBuffering hdl mode' sets the mode of buffering for
+-- handle hdl on subsequent reads and writes.
+--
+-- * If mode is LineBuffering, line-buffering should be enabled if possible.
+--
+-- * If mode is `BlockBuffering size', then block-buffering
+-- should be enabled if possible. The size of the buffer is n items
+-- if size is `Just n' and is otherwise implementation-dependent.
+--
+-- * If mode is NoBuffering, then buffering is disabled if possible.
+
+-- If the buffer mode is changed from BlockBuffering or
+-- LineBuffering to NoBuffering, then any items in the output
+-- buffer are written to the device, and any items in the input buffer
+-- are discarded. The default buffering mode when a handle is opened
+-- is implementation-dependent and may depend on the object which is
+-- attached to that handle.
+
+hSetBuffering :: Handle -> BufferMode -> IO ()
+hSetBuffering handle mode =
+ withAllHandles__ "hSetBuffering" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ _ -> do
+ {- Note:
+ - we flush the old buffer regardless of whether
+ the new buffer could fit the contents of the old buffer
+ or not.
+ - allow a handle's buffering to change even if IO has
+ occurred (ANSI C spec. does not allow this, nor did
+ the previous implementation of IO.hSetBuffering).
+ - a non-standard extension is to allow the buffering
+ of semi-closed handles to change [sof 6/98]
+ -}
+ flushBuffer handle_
+
+ let state = initBufferState (haType handle_)
+ new_buf <-
+ case mode of
+ -- we always have a 1-character read buffer for
+ -- unbuffered handles: it's needed to
+ -- support hLookAhead.
+ NoBuffering -> allocateBuffer 1 ReadBuffer
+ LineBuffering -> allocateBuffer dEFAULT_BUFFER_SIZE state
+ BlockBuffering Nothing -> allocateBuffer dEFAULT_BUFFER_SIZE state
+ BlockBuffering (Just n) | n <= 0 -> ioe_bufsiz n
+ | otherwise -> allocateBuffer n state
+ writeIORef (haBuffer handle_) new_buf
+
+ -- for input terminals we need to put the terminal into
+ -- cooked or raw mode depending on the type of buffering.
+ is_tty <- fdIsTTY (haFD handle_)
+ when (is_tty && isReadableHandleType (haType handle_)) $
+ case mode of
+ NoBuffering -> setCooked (haFD handle_) False
+ _ -> setCooked (haFD handle_) True
+
+ -- throw away spare buffers, they might be the wrong size
+ writeIORef (haBuffers handle_) BufferListNil
+
+ return (handle_{ haBufferMode = mode })
+
+-- -----------------------------------------------------------------------------
+-- hFlush
+
+-- The action `hFlush hdl' causes any items buffered for output
+-- in handle `hdl' to be sent immediately to the operating
+-- system.
+
+hFlush :: Handle -> IO ()
+hFlush handle =
+ wantWritableHandle "hFlush" handle $ \ handle_ -> do
+ buf <- readIORef (haBuffer handle_)
+ if bufferIsWritable buf && not (bufferEmpty buf)
+ then do flushed_buf <- flushWriteBuffer (haFD handle_) buf
+ writeIORef (haBuffer handle_) flushed_buf
+ else return ()
+
+
+-- -----------------------------------------------------------------------------
+-- Repositioning Handles
+
+data HandlePosn = HandlePosn Handle HandlePosition
+
+instance Eq HandlePosn where
+ (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2
+
+instance Show HandlePosn where
+ showsPrec p (HandlePosn h pos) =
+ showsPrec p h . showString " at position " . shows pos
+
+ -- HandlePosition is the Haskell equivalent of POSIX' off_t.
+ -- We represent it as an Integer on the Haskell side, but
+ -- cheat slightly in that hGetPosn calls upon a C helper
+ -- that reports the position back via (merely) an Int.
+type HandlePosition = Integer
+
+-- Computation `hGetPosn hdl' returns the current I/O position of
+-- `hdl' as an abstract position. Computation `hSetPosn p' sets the
+-- position of `hdl' to a previously obtained position `p'.
+
+hGetPosn :: Handle -> IO HandlePosn
+hGetPosn handle =
+ wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
+
+#if defined(mingw32_TARGET_OS)
+ -- urgh, on Windows we have to worry about \n -> \r\n translation,
+ -- so we can't easily calculate the file position using the
+ -- current buffer size. Just flush instead.
+ flushBuffer handle_
+#endif
+ let fd = fromIntegral (haFD handle_)
+ posn <- fromIntegral `liftM`
+ throwErrnoIfMinus1Retry "hGetPosn"
+ (c_lseek fd 0 sEEK_CUR)
+
+ let ref = haBuffer handle_
+ buf <- readIORef ref
+
+ let real_posn
+ | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf)
+ | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf)
+# ifdef DEBUG_DUMP
+ puts ("\nhGetPosn: (fd, posn, real_posn) = " ++ show (fd, posn, real_posn) ++ "\n")
+ puts (" (bufWPtr, bufRPtr) = " ++ show (bufWPtr buf, bufRPtr buf) ++ "\n")
+# endif
+ return (HandlePosn handle real_posn)
+
+
+hSetPosn :: HandlePosn -> IO ()
+hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
+
+-- ---------------------------------------------------------------------------
+-- hSeek
+
+{-
+The action `hSeek hdl mode i' sets the position of handle
+`hdl' depending on `mode'. If `mode' is
+
+ * AbsoluteSeek - The position of `hdl' is set to `i'.
+ * RelativeSeek - The position of `hdl' is set to offset `i' from
+ the current position.
+ * SeekFromEnd - The position of `hdl' is set to offset `i' from
+ the end of the file.
+
+Some handles may not be seekable (see `hIsSeekable'), or only
+support a subset of the possible positioning operations (e.g. it may
+only be possible to seek to the end of a tape, or to a positive
+offset from the beginning or current position).
+
+It is not possible to set a negative I/O position, or for a physical
+file, an I/O position beyond the current end-of-file.
+
+Note:
+ - when seeking using `SeekFromEnd', positive offsets (>=0) means
+ seeking at or past EOF.
+
+ - we possibly deviate from the report on the issue of seeking within
+ the buffer and whether to flush it or not. The report isn't exactly
+ clear here.
+-}
+
+data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd
+ deriving (Eq, Ord, Ix, Enum, Read, Show)
+
+hSeek :: Handle -> SeekMode -> Integer -> IO ()
+hSeek handle mode offset =
+ wantSeekableHandle "hSeek" handle $ \ handle_ -> do
+# ifdef DEBUG_DUMP
+ puts ("hSeek " ++ show (mode,offset) ++ "\n")
+# endif
+ let ref = haBuffer handle_
+ buf <- readIORef ref
+ let r = bufRPtr buf
+ w = bufWPtr buf
+ fd = haFD handle_
+
+ let do_seek =
+ throwErrnoIfMinus1Retry_ "hSeek"
+ (c_lseek (fromIntegral (haFD handle_)) (fromIntegral offset) whence)
+
+ whence :: CInt
+ whence = case mode of
+ AbsoluteSeek -> sEEK_SET
+ RelativeSeek -> sEEK_CUR
+ SeekFromEnd -> sEEK_END
+
+ if bufferIsWritable buf
+ then do new_buf <- flushWriteBuffer fd buf
+ writeIORef ref new_buf
+ do_seek
+ else do
+
+ if mode == RelativeSeek && offset >= 0 && offset < fromIntegral (w - r)
+ then writeIORef ref buf{ bufRPtr = r + fromIntegral offset }
+ else do
+
+ new_buf <- flushReadBuffer (haFD handle_) buf
+ writeIORef ref new_buf
+ do_seek
+
+-- -----------------------------------------------------------------------------
+-- Handle Properties
+
+-- A number of operations return information about the properties of a
+-- handle. Each of these operations returns `True' if the handle has
+-- the specified property, and `False' otherwise.
+
+hIsOpen :: Handle -> IO Bool
+hIsOpen handle =
+ withHandle_ "hIsOpen" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> return False
+ SemiClosedHandle -> return False
+ _ -> return True
+
+hIsClosed :: Handle -> IO Bool
+hIsClosed handle =
+ withHandle_ "hIsClosed" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> return True
+ _ -> return False
+
+{- not defined, nor exported, but mentioned
+ here for documentation purposes:
+
+ hSemiClosed :: Handle -> IO Bool
+ hSemiClosed h = do
+ ho <- hIsOpen h
+ hc <- hIsClosed h
+ return (not (ho || hc))
+-}
+
+hIsReadable :: Handle -> IO Bool
+hIsReadable (DuplexHandle _ _) = return True
+hIsReadable handle =
+ withHandle_ "hIsReadable" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ htype -> return (isReadableHandleType htype)
+
+hIsWritable :: Handle -> IO Bool
+hIsWritable (DuplexHandle _ _) = return False
+hIsWritable handle =
+ withHandle_ "hIsWritable" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ htype -> return (isWritableHandleType htype)
+
+-- Querying how a handle buffers its data:
+
+hGetBuffering :: Handle -> IO BufferMode
+hGetBuffering handle =
+ withHandle_ "hGetBuffering" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ _ ->
+ -- We're being non-standard here, and allow the buffering
+ -- of a semi-closed handle to be queried. -- sof 6/98
+ return (haBufferMode handle_) -- could be stricter..
+
+hIsSeekable :: Handle -> IO Bool
+hIsSeekable handle =
+ withHandle_ "hIsSeekable" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ AppendHandle -> return False
+ _ -> do t <- fdType (haFD handle_)
+ return (t == RegularFile
+ && (haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED))
+
+-- -----------------------------------------------------------------------------
+-- Changing echo status
+
+-- Non-standard GHC extension is to allow the echoing status
+-- of a handles connected to terminals to be reconfigured:
+
+hSetEcho :: Handle -> Bool -> IO ()
+hSetEcho handle on = do
+ isT <- hIsTerminalDevice handle
+ if not isT
+ then return ()
+ else
+ withHandle_ "hSetEcho" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ _ -> setEcho (haFD handle_) on
+
+hGetEcho :: Handle -> IO Bool
+hGetEcho handle = do
+ isT <- hIsTerminalDevice handle
+ if not isT
+ then return False
+ else
+ withHandle_ "hGetEcho" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ _ -> getEcho (haFD handle_)
+
+hIsTerminalDevice :: Handle -> IO Bool
+hIsTerminalDevice handle = do
+ withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ _ -> fdIsTTY (haFD handle_)
+
+-- -----------------------------------------------------------------------------
+-- hSetBinaryMode
+hSetBinaryMode handle bin =
+ withAllHandles__ "hSetBinaryMode" handle $ \ handle_ ->
+ do throwErrnoIfMinus1_ "hSetBinaryMode"
+ (setmode (fromIntegral (haFD handle_)) bin)
+ return handle_{haIsBin=bin}
+
+foreign import "prel_setmode" setmode :: CInt -> Bool -> IO CInt
+
+-- -----------------------------------------------------------------------------
+-- Miscellaneous
+
+-- These three functions are meant to get things out of an IOError.
+
+ioeGetFileName :: IOError -> Maybe FilePath
+ioeGetErrorString :: IOError -> String
+ioeGetHandle :: IOError -> Maybe Handle
+
+ioeGetHandle (IOException (IOError h _ _ _ _)) = h
+ioeGetHandle (UserError _) = Nothing
+ioeGetHandle _ = error "IO.ioeGetHandle: not an IO error"
+
+ioeGetErrorString (IOException (IOError _ iot _ _ _)) = show iot
+ioeGetErrorString (UserError str) = str
+ioeGetErrorString _ = error "IO.ioeGetErrorString: not an IO error"
+
+ioeGetFileName (IOException (IOError _ _ _ _ fn)) = fn
+ioeGetFileName (UserError _) = Nothing
+ioeGetFileName _ = error "IO.ioeGetFileName: not an IO error"
+
+-- ---------------------------------------------------------------------------
+-- debugging
+
+#ifdef DEBUG_DUMP
+puts :: String -> IO ()
+puts s = withCString s $ \cstr -> do c_write 1 cstr (fromIntegral (length s))
+ return ()
+#endif
+
+-- wrappers to platform-specific constants:
+foreign import ccall "prel_bufsiz" unsafe dEFAULT_BUFFER_SIZE :: Int
+foreign import ccall "prel_seek_cur" unsafe sEEK_CUR :: CInt
+foreign import ccall "prel_seek_set" unsafe sEEK_SET :: CInt
+foreign import ccall "prel_seek_end" unsafe sEEK_END :: CInt
+foreign import ccall "prel_o_binary" unsafe o_BINARY :: CInt
+
+
--- /dev/null
+{-# OPTIONS -fno-implicit-prelude -#include "PrelIOUtils.h" #-}
+
+#undef DEBUG_DUMP
+
+-- -----------------------------------------------------------------------------
+-- $Id: PrelIO.hs,v 1.1 2001/11/07 18:25:35 sof Exp $
+--
+-- (c) The University of Glasgow, 1992-2001
+--
+-- Module PrelIO
+
+-- This module defines all basic IO operations.
+-- These are needed for the IO operations exported by Prelude,
+-- but as it happens they also do everything required by library
+-- module IO.
+
+module PrelIO (
+ putChar, putStr, putStrLn, print, getChar, getLine, getContents,
+ interact, readFile, writeFile, appendFile, readLn, readIO, hReady,
+ hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
+ hPutStrLn, hPrint,
+ commitBuffer', -- hack, see below
+ hGetcBuffered, -- needed by ghc/compiler/utils/StringBuffer.lhs
+ ) where
+
+import PrelBase
+
+import PrelPosix
+import PrelMarshalUtils
+import PrelStorable
+import PrelCError
+import PrelCString
+import PrelCTypes
+import PrelCTypesISO
+
+import PrelIOBase
+import PrelHandle -- much of the real stuff is in here
+
+import PrelMaybe
+import PrelReal
+import PrelNum
+import PrelRead
+import PrelShow
+import PrelMaybe ( Maybe(..) )
+import PrelPtr
+import PrelList
+import PrelException ( ioError, catch, throw )
+import PrelConc
+
+-- -----------------------------------------------------------------------------
+-- Standard IO
+
+putChar :: Char -> IO ()
+putChar c = hPutChar stdout c
+
+putStr :: String -> IO ()
+putStr s = hPutStr stdout s
+
+putStrLn :: String -> IO ()
+putStrLn s = do putStr s
+ putChar '\n'
+
+print :: Show a => a -> IO ()
+print x = putStrLn (show x)
+
+getChar :: IO Char
+getChar = hGetChar stdin
+
+getLine :: IO String
+getLine = hGetLine stdin
+
+getContents :: IO String
+getContents = hGetContents stdin
+
+interact :: (String -> String) -> IO ()
+interact f = do s <- getContents
+ putStr (f s)
+
+readFile :: FilePath -> IO String
+readFile name = openFile name ReadMode >>= hGetContents
+
+writeFile :: FilePath -> String -> IO ()
+writeFile name str = do
+ hdl <- openFile name WriteMode
+ hPutStr hdl str
+ hClose hdl
+
+appendFile :: FilePath -> String -> IO ()
+appendFile name str = do
+ hdl <- openFile name AppendMode
+ hPutStr hdl str
+ hClose hdl
+
+readLn :: Read a => IO a
+readLn = do l <- getLine
+ r <- readIO l
+ return r
+
+ -- raises an exception instead of an error
+readIO :: Read a => String -> IO a
+readIO s = case (do { (x,t) <- reads s ;
+ ("","") <- lex t ;
+ return x }) of
+#ifndef NEW_READS_REP
+ [x] -> return x
+ [] -> ioError (userError "Prelude.readIO: no parse")
+ _ -> ioError (userError "Prelude.readIO: ambiguous parse")
+#else
+ Just x -> return x
+ Nothing -> ioError (userError "Prelude.readIO: no parse")
+#endif
+
+-- ---------------------------------------------------------------------------
+-- Simple input operations
+
+-- Computation "hReady hdl" indicates whether at least
+-- one item is available for input from handle "hdl".
+
+-- If hWaitForInput finds anything in the Handle's buffer, it
+-- immediately returns. If not, it tries to read from the underlying
+-- OS handle. Notice that for buffered Handles connected to terminals
+-- this means waiting until a complete line is available.
+
+hReady :: Handle -> IO Bool
+hReady h = hWaitForInput h 0
+
+hWaitForInput :: Handle -> Int -> IO Bool
+hWaitForInput h msecs = do
+ wantReadableHandle "hReady" h $ \ handle_ -> do
+ let ref = haBuffer handle_
+ buf <- readIORef ref
+
+ if not (bufferEmpty buf)
+ then return True
+ else do
+
+ r <- throwErrnoIfMinus1Retry "hReady"
+ (inputReady (fromIntegral (haFD handle_)) (fromIntegral msecs))
+ return (r /= 0)
+
+foreign import "inputReady"
+ inputReady :: CInt -> CInt -> IO CInt
+
+-- ---------------------------------------------------------------------------
+-- hGetChar
+
+-- hGetChar reads the next character from a handle,
+-- blocking until a character is available.
+
+hGetChar :: Handle -> IO Char
+hGetChar handle =
+ wantReadableHandle "hGetChar" handle $ \handle_ -> do
+
+ let fd = haFD handle_
+ ref = haBuffer handle_
+
+ buf <- readIORef ref
+ if not (bufferEmpty buf)
+ then hGetcBuffered fd ref buf
+ else do
+
+ -- buffer is empty.
+ case haBufferMode handle_ of
+ LineBuffering -> do
+ new_buf <- fillReadBuffer fd True buf
+ hGetcBuffered fd ref new_buf
+ BlockBuffering _ -> do
+ new_buf <- fillReadBuffer fd False buf
+ hGetcBuffered fd ref new_buf
+ NoBuffering -> do
+ -- make use of the minimal buffer we already have
+ let raw = bufBuf buf
+ r <- throwErrnoIfMinus1RetryMayBlock "hGetChar"
+ (read_off (fromIntegral fd) raw 0 1)
+ (threadWaitRead fd)
+ if r == 0
+ then ioe_EOF
+ else do (c,_) <- readCharFromBuffer raw 0
+ return c
+
+hGetcBuffered fd ref buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w }
+ = do (c,r) <- readCharFromBuffer b r
+ let new_buf | r == w = buf{ bufRPtr=0, bufWPtr=0 }
+ | otherwise = buf{ bufRPtr=r }
+ writeIORef ref new_buf
+ return c
+
+-- ---------------------------------------------------------------------------
+-- hGetLine
+
+-- If EOF is reached before EOL is encountered, ignore the EOF and
+-- return the partial line. Next attempt at calling hGetLine on the
+-- handle will yield an EOF IO exception though.
+
+-- ToDo: the unbuffered case is wrong: it doesn't lock the handle for
+-- the duration.
+hGetLine :: Handle -> IO String
+hGetLine h = do
+ m <- wantReadableHandle "hGetLine" h $ \ handle_ -> do
+ case haBufferMode handle_ of
+ NoBuffering -> return Nothing
+ LineBuffering -> do
+ l <- hGetLineBuffered handle_
+ return (Just l)
+ BlockBuffering _ -> do
+ l <- hGetLineBuffered handle_
+ return (Just l)
+ case m of
+ Nothing -> hGetLineUnBuffered h
+ Just l -> return l
+
+
+hGetLineBuffered handle_ = do
+ let ref = haBuffer handle_
+ buf <- readIORef ref
+ hGetLineBufferedLoop handle_ ref buf []
+
+
+hGetLineBufferedLoop handle_ ref
+ buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } xss =
+ let
+ -- find the end-of-line character, if there is one
+ loop raw r
+ | r == w = return (False, w)
+ | otherwise = do
+ (c,r') <- readCharFromBuffer raw r
+ if c == '\n'
+ then return (True, r) -- NB. not r': don't include the '\n'
+ else loop raw r'
+ in do
+ (eol, off) <- loop raw r
+
+#ifdef DEBUG_DUMP
+ puts ("hGetLineBufferedLoop: r=" ++ show r ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n")
+#endif
+
+ xs <- unpack raw r off
+ if eol
+ then do if w == off + 1
+ then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
+ else writeIORef ref buf{ bufRPtr = off + 1 }
+ return (concat (reverse (xs:xss)))
+ else do
+ maybe_buf <- maybeFillReadBuffer (haFD handle_) True
+ buf{ bufWPtr=0, bufRPtr=0 }
+ case maybe_buf of
+ -- Nothing indicates we caught an EOF, and we may have a
+ -- partial line to return.
+ Nothing -> let str = concat (reverse (xs:xss)) in
+ if not (null str)
+ then return str
+ else ioe_EOF
+ Just new_buf ->
+ hGetLineBufferedLoop handle_ ref new_buf (xs:xss)
+
+
+maybeFillReadBuffer fd is_line buf
+ = catch
+ (do buf <- fillReadBuffer fd is_line buf
+ return (Just buf)
+ )
+ (\e -> do if isEOFError e
+ then return Nothing
+ else throw e)
+
+
+unpack :: RawBuffer -> Int -> Int -> IO [Char]
+unpack buf r 0 = return ""
+unpack buf (I# r) (I# len) = IO $ \s -> unpack [] (len -# 1#) s
+ where
+ unpack acc i s
+ | i <# r = (# s, acc #)
+ | otherwise =
+ case readCharArray# buf i s of
+ (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
+
+
+hGetLineUnBuffered :: Handle -> IO String
+hGetLineUnBuffered h = do
+ c <- hGetChar h
+ if c == '\n' then
+ return ""
+ else do
+ l <- getRest
+ return (c:l)
+ where
+ getRest = do
+ c <-
+ catch
+ (hGetChar h)
+ (\ err -> do
+ if isEOFError err then
+ return '\n'
+ else
+ ioError err)
+ if c == '\n' then
+ return ""
+ else do
+ s <- getRest
+ return (c:s)
+
+-- -----------------------------------------------------------------------------
+-- hGetContents
+
+-- hGetContents returns the list of characters corresponding to the
+-- unread portion of the channel or file managed by the handle, which
+-- is made semi-closed.
+
+-- hGetContents on a DuplexHandle only affects the read side: you can
+-- carry on writing to it afterwards.
+
+hGetContents :: Handle -> IO String
+hGetContents handle =
+ withHandle "hGetContents" handle $ \handle_ ->
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ AppendHandle -> ioe_notReadable
+ WriteHandle -> ioe_notReadable
+ _ -> do xs <- lazyRead handle
+ return (handle_{ haType=SemiClosedHandle}, xs )
+
+-- Note that someone may close the semi-closed handle (or change its
+-- buffering), so each time these lazy read functions are pulled on,
+-- they have to check whether the handle has indeed been closed.
+
+lazyRead :: Handle -> IO String
+lazyRead handle =
+ unsafeInterleaveIO $
+ withHandle "lazyRead" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> return (handle_, "")
+ SemiClosedHandle -> lazyRead' handle handle_
+ _ -> ioException
+ (IOError (Just handle) IllegalOperation "lazyRead"
+ "illegal handle type" Nothing)
+
+lazyRead' h handle_ = do
+ let ref = haBuffer handle_
+ fd = haFD handle_
+
+ -- even a NoBuffering handle can have a char in the buffer...
+ -- (see hLookAhead)
+ buf <- readIORef ref
+ if not (bufferEmpty buf)
+ then lazyReadHaveBuffer h handle_ fd ref buf
+ else do
+
+ case haBufferMode handle_ of
+ NoBuffering -> do
+ -- make use of the minimal buffer we already have
+ let raw = bufBuf buf
+ fd = haFD handle_
+ r <- throwErrnoIfMinus1RetryMayBlock "lazyRead"
+ (read_off (fromIntegral fd) raw 0 1)
+ (threadWaitRead fd)
+ if r == 0
+ then do handle_ <- hClose_help handle_
+ return (handle_, "")
+ else do (c,_) <- readCharFromBuffer raw 0
+ rest <- lazyRead h
+ return (handle_, c : rest)
+
+ LineBuffering -> lazyReadBuffered h handle_ fd ref buf
+ BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf
+
+-- we never want to block during the read, so we call fillReadBuffer with
+-- is_line==True, which tells it to "just read what there is".
+lazyReadBuffered h handle_ fd ref buf = do
+ catch
+ (do buf <- fillReadBuffer fd True{-is_line-} buf
+ lazyReadHaveBuffer h handle_ fd ref buf
+ )
+ -- all I/O errors are discarded. Additionally, we close the handle.
+ (\e -> do handle_ <- hClose_help handle_
+ return (handle_, "")
+ )
+
+lazyReadHaveBuffer h handle_ fd ref buf = do
+ more <- lazyRead h
+ writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
+ s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
+ return (handle_, s)
+
+
+unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
+unpackAcc buf r 0 acc = return ""
+unpackAcc buf (I# r) (I# len) acc = IO $ \s -> unpack acc (len -# 1#) s
+ where
+ unpack acc i s
+ | i <# r = (# s, acc #)
+ | otherwise =
+ case readCharArray# buf i s of
+ (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
+
+-- ---------------------------------------------------------------------------
+-- hPutChar
+
+-- `hPutChar hdl ch' writes the character `ch' to the file or channel
+-- managed by `hdl'. Characters may be buffered if buffering is
+-- enabled for `hdl'.
+
+hPutChar :: Handle -> Char -> IO ()
+hPutChar handle c =
+ c `seq` do -- must evaluate c before grabbing the handle lock
+ wantWritableHandle "hPutChar" handle $ \ handle_ -> do
+ let fd = haFD handle_
+ case haBufferMode handle_ of
+ LineBuffering -> hPutcBuffered handle_ True c
+ BlockBuffering _ -> hPutcBuffered handle_ False c
+ NoBuffering ->
+ withObject (castCharToCChar c) $ \buf ->
+ throwErrnoIfMinus1RetryMayBlock_ "hPutChar"
+ (c_write (fromIntegral fd) buf 1)
+ (threadWaitWrite fd)
+
+
+hPutcBuffered handle_ is_line c = do
+ let ref = haBuffer handle_
+ buf <- readIORef ref
+ let w = bufWPtr buf
+ w' <- writeCharIntoBuffer (bufBuf buf) w c
+ let new_buf = buf{ bufWPtr = w' }
+ if bufferFull new_buf || is_line && c == '\n'
+ then do
+ flushed_buf <- flushWriteBuffer (haFD handle_) new_buf
+ writeIORef ref flushed_buf
+ else do
+ writeIORef ref new_buf
+
+
+hPutChars :: Handle -> [Char] -> IO ()
+hPutChars handle [] = return ()
+hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
+
+-- ---------------------------------------------------------------------------
+-- hPutStr
+
+-- `hPutStr hdl s' writes the string `s' to the file or
+-- hannel managed by `hdl', buffering the output if needs be.
+
+-- We go to some trouble to avoid keeping the handle locked while we're
+-- evaluating the string argument to hPutStr, in case doing so triggers another
+-- I/O operation on the same handle which would lead to deadlock. The classic
+-- case is
+--
+-- putStr (trace "hello" "world")
+--
+-- so the basic scheme is this:
+--
+-- * copy the string into a fresh buffer,
+-- * "commit" the buffer to the handle.
+--
+-- Committing may involve simply copying the contents of the new
+-- buffer into the handle's buffer, flushing one or both buffers, or
+-- maybe just swapping the buffers over (if the handle's buffer was
+-- empty). See commitBuffer below.
+
+hPutStr :: Handle -> String -> IO ()
+hPutStr handle str = do
+ buffer_mode <- wantWritableHandle "hPutStr" handle
+ (\ handle_ -> do getSpareBuffer handle_)
+ case buffer_mode of
+ (NoBuffering, _) -> do
+ hPutChars handle str -- v. slow, but we don't care
+ (LineBuffering, buf) -> do
+ writeLines handle buf str
+ (BlockBuffering _, buf) -> do
+ writeBlocks handle buf str
+
+
+getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer)
+getSpareBuffer Handle__{haBuffer=ref,
+ haBuffers=spare_ref,
+ haBufferMode=mode}
+ = do
+ case mode of
+ NoBuffering -> return (mode, error "no buffer!")
+ _ -> do
+ bufs <- readIORef spare_ref
+ buf <- readIORef ref
+ case bufs of
+ BufferListCons b rest -> do
+ writeIORef spare_ref rest
+ return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf))
+ BufferListNil -> do
+ new_buf <- allocateBuffer (bufSize buf) WriteBuffer
+ return (mode, new_buf)
+
+
+writeLines :: Handle -> Buffer -> String -> IO ()
+writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s =
+ let
+ shoveString :: Int -> [Char] -> IO ()
+ -- check n == len first, to ensure that shoveString is strict in n.
+ shoveString n cs | n == len = do
+ new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
+ writeLines hdl new_buf cs
+ shoveString n [] = do
+ commitBuffer hdl raw len n False{-no flush-} True{-release-}
+ return ()
+ shoveString n (c:cs) = do
+ n' <- writeCharIntoBuffer raw n c
+ if (c == '\n')
+ then do
+ new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
+ writeLines hdl new_buf cs
+ else
+ shoveString n' cs
+ in
+ shoveString 0 s
+
+writeBlocks :: Handle -> Buffer -> String -> IO ()
+writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s =
+ let
+ shoveString :: Int -> [Char] -> IO ()
+ -- check n == len first, to ensure that shoveString is strict in n.
+ shoveString n cs | n == len = do
+ new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
+ writeBlocks hdl new_buf cs
+ shoveString n [] = do
+ commitBuffer hdl raw len n False{-no flush-} True{-release-}
+ return ()
+ shoveString n (c:cs) = do
+ n' <- writeCharIntoBuffer raw n c
+ shoveString n' cs
+ in
+ shoveString 0 s
+
+-- -----------------------------------------------------------------------------
+-- commitBuffer handle buf sz count flush release
+--
+-- Write the contents of the buffer 'buf' ('sz' bytes long, containing
+-- 'count' bytes of data) to handle (handle must be block or line buffered).
+--
+-- Implementation:
+--
+-- for block/line buffering,
+-- 1. If there isn't room in the handle buffer, flush the handle
+-- buffer.
+--
+-- 2. If the handle buffer is empty,
+-- if flush,
+-- then write buf directly to the device.
+-- else swap the handle buffer with buf.
+--
+-- 3. If the handle buffer is non-empty, copy buf into the
+-- handle buffer. Then, if flush != 0, flush
+-- the buffer.
+
+commitBuffer
+ :: Handle -- handle to commit to
+ -> RawBuffer -> Int -- address and size (in bytes) of buffer
+ -> Int -- number of bytes of data in buffer
+ -> Bool -- True <=> flush the handle afterward
+ -> Bool -- release the buffer?
+ -> IO Buffer
+
+commitBuffer hdl raw sz@(I# _) count@(I# _) flush release = do
+ wantWritableHandle "commitAndReleaseBuffer" hdl $
+ commitBuffer' hdl raw sz count flush release
+
+-- Explicitly lambda-lift this function to subvert GHC's full laziness
+-- optimisations, which otherwise tends to float out subexpressions
+-- past the \handle, which is really a pessimisation in this case because
+-- that lambda is a one-shot lambda.
+--
+-- Don't forget to export the function, to stop it being inlined too
+-- (this appears to be better than NOINLINE, because the strictness
+-- analyser still gets to worker-wrapper it).
+--
+-- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001
+--
+commitBuffer' hdl raw sz@(I# _) count@(I# _) flush release
+ handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do
+
+#ifdef DEBUG_DUMP
+ puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
+ ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")
+#endif
+
+ old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
+ <- readIORef ref
+
+ buf_ret <-
+ -- enough room in handle buffer?
+ if (not flush && (size - w > count))
+ -- The > is to be sure that we never exactly fill
+ -- up the buffer, which would require a flush. So
+ -- if copying the new data into the buffer would
+ -- make the buffer full, we just flush the existing
+ -- buffer and the new data immediately, rather than
+ -- copying before flushing.
+
+ -- not flushing, and there's enough room in the buffer:
+ -- just copy the data in and update bufWPtr.
+ then do memcpy_off old_raw w raw (fromIntegral count)
+ writeIORef ref old_buf{ bufWPtr = w + count }
+ return (newEmptyBuffer raw WriteBuffer sz)
+
+ -- else, we have to flush
+ else do flushed_buf <- flushWriteBuffer fd old_buf
+
+ let this_buf =
+ Buffer{ bufBuf=raw, bufState=WriteBuffer,
+ bufRPtr=0, bufWPtr=count, bufSize=sz }
+
+ -- if: (a) we don't have to flush, and
+ -- (b) size(new buffer) == size(old buffer), and
+ -- (c) new buffer is not full,
+ -- we can just just swap them over...
+ if (not flush && sz == size && count /= sz)
+ then do
+ writeIORef ref this_buf
+ return flushed_buf
+
+ -- otherwise, we have to flush the new data too,
+ -- and start with a fresh buffer
+ else do
+ flushWriteBuffer fd this_buf
+ writeIORef ref flushed_buf
+ -- if the sizes were different, then allocate
+ -- a new buffer of the correct size.
+ if sz == size
+ then return (newEmptyBuffer raw WriteBuffer sz)
+ else allocateBuffer size WriteBuffer
+
+ -- release the buffer if necessary
+ case buf_ret of
+ Buffer{ bufSize=buf_ret_sz, bufBuf=buf_ret_raw } -> do
+ if release && buf_ret_sz == size
+ then do
+ spare_bufs <- readIORef spare_buf_ref
+ writeIORef spare_buf_ref
+ (BufferListCons buf_ret_raw spare_bufs)
+ return buf_ret
+ else
+ return buf_ret
+
+
+foreign import "prel_PrelIO_memcpy" unsafe
+ memcpy_off :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
+
+-- ---------------------------------------------------------------------------
+-- hPutStrLn
+
+-- Derived action `hPutStrLn hdl str' writes the string `str' to
+-- the handle `hdl', adding a newline at the end.
+
+hPutStrLn :: Handle -> String -> IO ()
+hPutStrLn hndl str = do
+ hPutStr hndl str
+ hPutChar hndl '\n'
+
+-- ---------------------------------------------------------------------------
+-- hPrint
+
+-- Computation `hPrint hdl t' writes the string representation of `t'
+-- given by the `shows' function to the file or channel managed by `hdl'.
+
+hPrint :: Show a => Handle -> a -> IO ()
+hPrint hdl = hPutStrLn hdl . show
projects / ghc-hetmet.git / commitdiff