%
-% (c) The AQUA Project, Glasgow University, 1994-1996
+% (c) The AQUA Project, Glasgow University, 1994-1998
%
-
\section[IO]{Module @IO@}
+Implementation of the standard Haskell IO interface, see
+@http://haskell.org/onlinelibrary/io.html@ for the official
+definition.
+
\begin{code}
{-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-}
module IO (
- Handle, HandlePosn,
+ Handle, -- abstract, instance of: Eq, Show.
+ HandlePosn(..), -- abstract, instance of: Eq, Show.
IOMode(ReadMode,WriteMode,AppendMode,ReadWriteMode),
BufferMode(NoBuffering,LineBuffering,BlockBuffering),
SeekMode(AbsoluteSeek,RelativeSeek,SeekFromEnd),
- stdin, stdout, stderr,
-
- openFile, hClose,
- hFileSize, hIsEOF, isEOF,
- hSetBuffering, hGetBuffering, hFlush,
- hGetPosn, hSetPosn, hSeek,
- hWaitForInput, hReady, hGetChar, hGetLine, hLookAhead, hGetContents,
- hPutChar, hPutStr, hPutStrLn, hPrint,
- hIsOpen, hIsClosed, hIsReadable, hIsWritable, hIsSeekable,
-
- isAlreadyExistsError, isDoesNotExistError, isAlreadyInUseError,
- isFullError, isEOFError,
- isIllegalOperation, isPermissionError, isUserError,
- ioeGetErrorString,
- ioeGetHandle, ioeGetFileName,
- try, bracket, bracket_
+ stdin, stdout, stderr, -- :: Handle
+
+ openFile, -- :: FilePath -> IOMode -> IO Handle
+ hClose, -- :: Handle -> IO ()
+ hFileSize, -- :: Handle -> IO Integer
+ hIsEOF, -- :: Handle -> IO Bool
+ isEOF, -- :: IO Bool
+
+ hSetBuffering, -- :: Handle -> BufferMode -> IO ()
+ hGetBuffering, -- :: Handle -> IO BufferMode
+ hFlush, -- :: Handle -> IO ()
+ hGetPosn, -- :: Handle -> IO HandlePosn
+ hSetPosn, -- :: Handle -> HandlePosn -> IO ()
+ hSeek, -- :: Handle -> SeekMode -> Integer -> IO ()
+ hWaitForInput, -- :: Handle -> Int -> IO Bool
+ hReady, -- :: Handle -> IO Bool
+ hGetChar, -- :: Handle -> IO Char
+ hGetLine, -- :: Handle -> IO [Char]
+ hLookAhead, -- :: Handle -> IO Char
+ hGetContents, -- :: Handle -> IO [Char]
+ hPutChar, -- :: Handle -> Char -> IO ()
+ hPutStr, -- :: Handle -> [Char] -> IO ()
+ hPutStrLn, -- :: Handle -> [Char] -> IO ()
+ hPrint, -- :: Show a => Handle -> a -> IO ()
+ hIsOpen, hIsClosed, -- :: Handle -> IO Bool
+ hIsReadable, hIsWritable, -- :: Handle -> IO Bool
+ hIsSeekable, -- :: Handle -> IO Bool
+
+ isAlreadyExistsError, isDoesNotExistError, -- :: IOError -> Bool
+ isAlreadyInUseError, isFullError,
+ isEOFError, isIllegalOperation,
+ isPermissionError, isUserError,
+
+ ioeGetErrorString, -- :: IOError -> String
+ ioeGetHandle, -- :: IOError -> Maybe Handle
+ ioeGetFileName, -- :: IOError -> Maybe FilePath
+
+ try, -- :: IO a -> IO (Either IOError a)
+ bracket, -- :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
+ bracket_, -- :: IO a -> (a -> IO b) -> IO c -> IO c
+
+ -- extensions
+ hPutBuf,
+ hPutBufBA,
+ slurpFile
+
) where
-import PrelST
+import PrelBase
+
import PrelIOBase
-import PrelArr ( MutableByteArray(..), newCharArray )
import PrelHandle -- much of the real stuff is in here
-import PrelPack ( unpackNBytesST )
-import PrelBase
+
import PrelRead ( readParen, Read(..), reads, lex )
-import PrelMaybe
-import PrelEither
-import PrelAddr
-import PrelGHC
+import PrelNum ( toInteger )
+import PrelBounded () -- Bounded Int instance.
+import PrelEither ( Either(..) )
+import PrelAddr ( Addr(..), nullAddr )
+import PrelArr ( ByteArray )
+import PrelPack ( unpackNBytesAccST )
#ifndef __PARALLEL_HASKELL__
-import PrelForeign ( ForeignObj, makeForeignObj, writeForeignObj )
+import PrelForeign ( ForeignObj )
#endif
-import Ix
import Char ( ord, chr )
-\end{code}
-%*********************************************************
-%* *
-\subsection{Signatures}
-%* *
-%*********************************************************
-
-\begin{code}
---IOHandle:hClose :: Handle -> IO ()
---IOHandle:hFileSize :: Handle -> IO Integer
---IOHandle:hFlush :: Handle -> IO ()
---IOHandle:hGetBuffering :: Handle -> IO BufferMode
-hGetChar :: Handle -> IO Char
-hGetContents :: Handle -> IO String
---IOHandle:hGetPosn :: Handle -> IO HandlePosn
---IOHandle:hIsClosed :: Handle -> IO Bool
---IOHandle:hIsEOF :: Handle -> IO Bool
---IOHandle:hIsOpen :: Handle -> IO Bool
---IOHandle:hIsReadable :: Handle -> IO Bool
---IOHandle:hIsSeekable :: Handle -> IO Bool
---IOHandle:hIsWritable :: Handle -> IO Bool
-hLookAhead :: Handle -> IO Char
-hPrint :: Show a => Handle -> a -> IO ()
-hPutChar :: Handle -> Char -> IO ()
-hPutStr :: Handle -> String -> IO ()
-hPutStrLn :: Handle -> String -> IO ()
-hReady :: Handle -> IO Bool
-hWaitForInput :: Handle -> Int -> IO Bool
-
---IOHandle:hSeek :: Handle -> SeekMode -> Integer -> IO ()
---IOHandle:hSetBuffering :: Handle -> BufferMode -> IO ()
---IOHandle:hSetPosn :: HandlePosn -> IO ()
--- ioeGetFileName :: IOError -> Maybe FilePath
--- ioeGetErrorString :: IOError -> String
--- ioeGetHandle :: IOError -> Maybe Handle
--- isAlreadyExistsError :: IOError -> Bool
--- isAlreadyInUseError :: IOError -> Bool
---IOHandle:isEOF :: IO Bool
--- isEOFError :: IOError -> Bool
--- isFullError :: IOError -> Bool
--- isIllegalOperation :: IOError -> Bool
--- isPermissionError :: IOError -> Bool
--- isUserError :: IOError -> Bool
---IOHandle:openFile :: FilePath -> IOMode -> IO Handle
---IOHandle:stdin, stdout, stderr :: Handle
\end{code}
Standard instances for @Handle@:
\begin{code}
instance Eq IOError where
- (IOError h1 e1 str1) == (IOError h2 e2 str2) =
- e1==e2 && str1==str2 && h1==h2
-
-#ifndef __CONCURRENT_HASKELL__
+ (IOError h1 e1 loc1 str1) == (IOError h2 e2 loc2 str2) =
+ e1==e2 && str1==str2 && h1==h2 && loc1 == loc2
instance Eq Handle where
(Handle h1) == (Handle h2) = h1 == h2
-#else
-
-{- OLD equality instance. The simpler one above
- seems more accurate! This one is still used for concurrent haskell,
- since there's no equality instance over MVars.
--}
-
-instance Eq Handle where
- h1 == h2 =
- unsafePerformIO (do
- h1_ <- readHandle h1
- writeHandle h1 h1_
- h2_<- readHandle h2
- writeHandle h2 h2_
- return (
- case (h1_,h2_) of
- (ErrorHandle (IOError h1 _ _), ErrorHandle (IOError h2 _ _)) -> h1 == h2
- (ClosedHandle, ClosedHandle) -> True
- (SemiClosedHandle v1 _, SemiClosedHandle v2 _) -> v1 == v2
- (ReadHandle v1 _ _ , ReadHandle v2 _ _) -> v1 == v2
- (WriteHandle v1 _ _ , WriteHandle v2 _ _) -> v1 == v2
- (AppendHandle v1 _ _ , AppendHandle v2 _ _) -> v1 == v2
- (ReadWriteHandle v1 _ _ , ReadWriteHandle v2 _ _) -> v1 == v2
- _ -> False))
-
-#endif
-
-instance Show Handle where {showsPrec p h = showString "<<Handle>>"}
-
--Type declared in IOHandle, instance here because it depends on Eq.Handle
instance Eq HandlePosn where
(HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2
@hWaitForInput@ is the generalisation, wait for \tr{n} milliseconds
before deciding whether the Handle has run dry or not.
+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.
+
\begin{code}
---hReady :: Handle -> IO Bool
+hReady :: Handle -> IO Bool
hReady h = hWaitForInput h 0
---hWaitForInput :: Handle -> Int -> IO Bool
+hWaitForInput :: Handle -> Int -> IO Bool
hWaitForInput handle msecs = do
- hdl <- wantReadableHandle handle
- rc <- _ccall_ inputReady (filePtr hdl) msecs
- writeHandle handle (markHandle hdl)
+ handle_ <- wantReadableHandle "hWaitForInput" handle
+ rc <- _ccall_ inputReady (haFO__ handle_) (msecs::Int) -- ConcHask: SAFE, won't block
+ writeHandle handle handle_
case rc of
0 -> return False
1 -> return True
_ -> constructErrorAndFail "hWaitForInput"
\end{code}
-Computation $hGetChar hdl$ reads the next character from handle
-{\em hdl}, blocking until a character is available.
+@hGetChar hdl@ reads the next character from handle @hdl@,
+blocking until a character is available.
\begin{code}
---hGetChar :: Handle -> IO Char
-
+hGetChar :: Handle -> IO Char
hGetChar handle = do
- hdl <- wantReadableHandle handle
- intc <- _ccall_ fileGetc (filePtr hdl)
- writeHandle handle (markHandle hdl)
- if intc /= ``EOF''
+ handle_ <- wantReadableHandle "hGetChar" handle
+ let fo = haFO__ handle_
+ intc <- mayBlock fo (_ccall_ fileGetc fo) -- ConcHask: UNSAFE, may block
+ writeHandle handle handle_
+ if intc /= (-1)
then return (chr intc)
else constructErrorAndFail "hGetChar"
hGetLine :: Handle -> IO String
hGetLine h = do
- c <- hGetChar h
- if c == '\n'
- then return ""
- else do
- s <- hGetLine h
- return (c:s)
+ c <- hGetChar h
+ if c == '\n'
+ then return ""
+ else do
+ s <- hGetLine h
+ return (c:s)
\end{code}
-Computation $hLookahead hdl$ returns the next character from handle
-{\em hdl} without removing it from the input buffer, blocking until a
+@hLookahead hdl@ returns the next character from handle @hdl@
+without removing it from the input buffer, blocking until a
character is available.
\begin{code}
---hLookAhead :: Handle -> IO Char
-
+hLookAhead :: Handle -> IO Char
hLookAhead handle = do
- hdl <- wantReadableHandle handle
- intc <- _ccall_ fileLookAhead (filePtr hdl)
- writeHandle handle (markHandle hdl)
- if intc /= ``EOF''
+ handle_ <- wantReadableHandle "hLookAhead" handle
+ let fo = haFO__ handle_
+ intc <- mayBlock fo (_ccall_ fileLookAhead fo) -- ConcHask: UNSAFE, may block
+ writeHandle handle handle_
+ if intc /= (-1)
then return (chr intc)
else constructErrorAndFail "hLookAhead"
%* *
%*********************************************************
-Computation $hGetContents hdl$ returns the list of characters
-corresponding to the unread portion of the channel or file managed by
-{\em hdl}, which is made semi-closed.
+@hGetContents hdl@ returns the list of characters corresponding
+to the unread portion of the channel or file managed by @hdl@,
+which is made semi-closed.
\begin{code}
---hGetContents :: Handle -> IO String
-
+hGetContents :: Handle -> IO String
hGetContents handle = do
- hdl_ <- wantReadableHandle handle
+ handle_ <- wantReadableHandle "hGetContents" handle
{-
To avoid introducing an extra layer of buffering here,
we provide three lazy read methods, based on character,
line, and block buffering.
-}
- hdl_ <- getBufferMode hdl_
- case (bufferMode hdl_) of
- Just LineBuffering -> do
- buf_info <- allocBuf Nothing
- writeHandle handle (SemiClosedHandle (filePtr hdl_) buf_info)
- unsafeInterleaveIO (lazyReadLine handle)
- Just (BlockBuffering size) -> do
- buf_info <- allocBuf size
- writeHandle handle (SemiClosedHandle (filePtr hdl_) buf_info)
- unsafeInterleaveIO (lazyReadBlock handle)
- _ -> do -- Nothing is treated pessimistically as NoBuffering
- writeHandle handle (SemiClosedHandle (filePtr hdl_) (``NULL'', 0))
- unsafeInterleaveIO (lazyReadChar handle)
- where
- allocBuf :: Maybe Int -> IO (Addr, Int)
- allocBuf msize = do
- buf <- _ccall_ malloc size
- if buf /= ``NULL''
- then return (buf, size)
- else fail (IOError Nothing ResourceExhausted "not enough virtual memory")
- where
- size =
- case msize of
- Just x -> x
- Nothing -> ``BUFSIZ''
+ writeHandle handle (handle_{ haType__ = SemiClosedHandle })
+ case (haBufferMode__ handle_) of
+ LineBuffering -> unsafeInterleaveIO (lazyReadLine handle (haFO__ handle_))
+ BlockBuffering _ -> unsafeInterleaveIO (lazyReadBlock handle (haFO__ handle_))
+ NoBuffering -> unsafeInterleaveIO (lazyReadChar handle (haFO__ handle_))
+
\end{code}
-Note that someone may yank our handle out from under us, and then re-use
-the same FILE * for something else. Therefore, we have to re-examine the
-handle every time through.
+Note that someone may close the semi-closed handle (or change its buffering),
+so each these lazy read functions are pulled on, they have to check whether
+the handle has indeed been closed.
\begin{code}
-lazyReadBlock :: Handle -> IO String
-lazyReadLine :: Handle -> IO String
-lazyReadChar :: Handle -> IO String
-
-lazyReadBlock handle = do
- htype <- readHandle handle
- case htype of
- -- There cannae be an ErrorHandle here
- ClosedHandle -> do
- writeHandle handle htype
- return ""
- SemiClosedHandle fp (buf, size) -> do
- bytes <- _ccall_ readBlock buf fp size
- some <- (if bytes <= 0
- then return ""
- else stToIO (unpackNBytesST buf bytes))
- if bytes < 0
- then do
- _ccall_ free buf
- _ccall_ closeFile fp
-#ifndef __PARALLEL_HASKELL__
- writeForeignObj fp ``NULL''
- writeHandle handle (SemiClosedHandle fp (``NULL'', 0))
-#else
- writeHandle handle (SemiClosedHandle ``NULL'' (``NULL'', 0))
-#endif
- return some
- else do
- writeHandle handle htype
- more <- unsafeInterleaveIO (lazyReadBlock handle)
- return (some ++ more)
-
-lazyReadLine handle = do
- htype <- readHandle handle
- case htype of
- -- There cannae be an ErrorHandle here
- ClosedHandle -> do
- writeHandle handle htype
- return ""
- SemiClosedHandle fp (buf, size) -> do
- bytes <- _ccall_ readLine buf fp size
- some <- (if bytes <= 0
- then return ""
- else stToIO (unpackNBytesST buf bytes))
- if bytes < 0
- then do
- _ccall_ free buf
- _ccall_ closeFile fp
#ifndef __PARALLEL_HASKELL__
- writeForeignObj fp ``NULL''
- writeHandle handle (SemiClosedHandle fp (``NULL'', 0))
+lazyReadBlock :: Handle -> ForeignObj -> IO String
+lazyReadLine :: Handle -> ForeignObj -> IO String
+lazyReadChar :: Handle -> ForeignObj -> IO String
#else
- writeHandle handle (SemiClosedHandle ``NULL'' (``NULL'', 0))
+lazyReadBlock :: Handle -> Addr -> IO String
+lazyReadLine :: Handle -> Addr -> IO String
+lazyReadChar :: Handle -> Addr -> IO String
#endif
- return some
- else do
- writeHandle handle htype
- more <- unsafeInterleaveIO (lazyReadLine handle)
- return (some ++ more)
-
-lazyReadChar handle = do
- htype <- readHandle handle
- case htype of
- -- There cannae be an ErrorHandle here
- ClosedHandle -> do
- writeHandle handle htype
+
+lazyReadBlock handle fo = do
+ buf <- _ccall_ getBufStart fo (0::Int)
+ bytes <- mayBlock fo (_ccall_ readBlock fo) -- ConcHask: UNSAFE, may block.
+ case bytes of
+ -3 -> -- buffering has been turned off, use lazyReadChar instead
+ lazyReadChar handle fo
+ -2 -> return ""
+ -1 -> do -- an error occurred, close the handle
+ handle_ <- readHandle handle
+ _ccall_ closeFile (haFO__ handle_) 0{-don't bother flushing-} -- ConcHask: SAFE, won't block.
+ writeHandle handle (handle_ { haType__ = ClosedHandle,
+ haFO__ = nullFile__ })
return ""
- SemiClosedHandle fp buf_info -> do
- char <- _ccall_ readChar fp
- if char == ``EOF''
- then do
- _ccall_ closeFile fp
-#ifndef __PARALLEL_HASKELL__
- writeForeignObj fp ``NULL''
- writeHandle handle (SemiClosedHandle fp (``NULL'', 0))
-#else
- writeHandle handle (SemiClosedHandle ``NULL'' (``NULL'', 0))
-#endif
- return ""
- else do
- writeHandle handle htype
- more <- unsafeInterleaveIO (lazyReadChar handle)
- return (chr char : more)
+ _ -> do
+ more <- unsafeInterleaveIO (lazyReadBlock handle fo)
+ stToIO (unpackNBytesAccST buf bytes more)
+
+lazyReadLine handle fo = do
+ bytes <- mayBlock fo (_ccall_ readLine fo) -- ConcHask: UNSAFE, may block.
+ case bytes of
+ -3 -> -- buffering has been turned off, use lazyReadChar instead
+ lazyReadChar handle fo
+ -2 -> return "" -- handle closed by someone else, stop reading.
+ -1 -> do -- an error occurred, close the handle
+ handle_ <- readHandle handle
+ _ccall_ closeFile (haFO__ handle_) 0{- don't bother flushing-} -- ConcHask: SAFE, won't block
+ writeHandle handle (handle_ { haType__ = ClosedHandle,
+ haFO__ = nullFile__ })
+ return ""
+ _ -> do
+ more <- unsafeInterleaveIO (lazyReadLine handle fo)
+ buf <- _ccall_ getBufStart fo bytes -- ConcHask: won't block
+ stToIO (unpackNBytesAccST buf bytes more)
+
+lazyReadChar handle fo = do
+ char <- mayBlock fo (_ccall_ readChar fo) -- ConcHask: UNSAFE, may block.
+ case char of
+ -4 -> -- buffering is now block-buffered, use lazyReadBlock instead
+ lazyReadBlock handle fo
+
+ -3 -> -- buffering is now line-buffered, use lazyReadLine instead
+ lazyReadLine handle fo
+ -2 -> return ""
+ -1 -> do -- error, silently close handle.
+ handle_ <- readHandle handle
+ _ccall_ closeFile (haFO__ handle_) 0{-don't bother flusing-} -- ConcHask: SAFE, won't block
+ writeHandle handle (handle_{ haType__ = ClosedHandle,
+ haFO__ = nullFile__ })
+ return ""
+ _ -> do
+ more <- unsafeInterleaveIO (lazyReadChar handle fo)
+ return (chr char : more)
\end{code}
%* *
%*********************************************************
-Computation $hPutChar hdl c$ writes the character {\em c} to the file
-or channel managed by {\em hdl}. Characters may be buffered if
-buffering is enabled for {\em hdl}.
+@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@
\begin{code}
---hPutChar :: Handle -> Char -> IO ()
-
+hPutChar :: Handle -> Char -> IO ()
hPutChar handle c = do
- hdl <- wantWriteableHandle handle
- rc <- _ccall_ filePutc (filePtr hdl) (ord c)
- writeHandle handle (markHandle hdl)
+ handle_ <- wantWriteableHandle "hPutChar" handle
+ let fo = haFO__ handle_
+ rc <- mayBlock fo (_ccall_ filePutc fo (ord c)) -- ConcHask: UNSAFE, may block.
+ writeHandle handle handle_
if rc == 0
then return ()
else constructErrorAndFail "hPutChar"
+
\end{code}
-Computation $hPutStr hdl s$ writes the string {\em s} to the file or
-channel managed by {\em hdl}.
+@hPutStr hdl s@ writes the string @s@ to the file or
+channel managed by @hdl@, buffering the output if needs be.
\begin{code}
---hPutStr :: Handle -> String -> IO ()
-
+hPutStr :: Handle -> String -> IO ()
hPutStr handle str = do
- hdl <- wantWriteableHandle handle
- {-
- The code below is not correct for line-buffered terminal streams,
- as the output stream is not flushed when terminal input is requested
- again, just upon seeing a newline character. A temporary fix for the
- most common line-buffered output stream, stdout, is to assume the
- buffering it was given when created (no buffering). This is not
- as bad as it looks, since stdio buffering sits underneath this.
-
- ToDo: fix me
- -}
- hdl <- getBufferMode hdl
- success <-
- (case bufferMode hdl of
- Just LineBuffering ->
- writeChars (filePtr hdl) str
- --writeLines (filePtr hdl) str
- Just (BlockBuffering (Just size)) ->
- writeBlocks (filePtr hdl) size str
- Just (BlockBuffering Nothing) ->
- writeBlocks (filePtr hdl) (``BUFSIZ''-1) str
- _ -> -- Nothing is treated pessimistically as NoBuffering
- writeChars (filePtr hdl) str
- )
- writeHandle handle (markHandle hdl)
- if success
- then return ()
- else constructErrorAndFail "hPutStr"
+ handle_ <- wantWriteableHandle "hPutStr" handle
+ let fo = haFO__ handle_
+ case haBufferMode__ handle_ of
+ LineBuffering -> do
+ buf <- _ccall_ getWriteableBuf fo
+ pos <- _ccall_ getBufWPtr fo
+ bsz <- _ccall_ getBufSize fo
+ writeLines fo buf bsz pos str
+ BlockBuffering _ -> do
+ buf <- _ccall_ getWriteableBuf fo
+ pos <- _ccall_ getBufWPtr fo
+ bsz <- _ccall_ getBufSize fo
+ writeBlocks fo buf bsz pos str
+ NoBuffering -> do
+ writeChars fo str
+ writeHandle handle handle_
-#ifndef __PARALLEL_HASKELL__
-writeLines :: ForeignObj -> String -> IO Bool
-#else
-writeLines :: Addr -> String -> IO Bool
-#endif
-writeLines = writeChunks (``BUFSIZ''-1) True
+\end{code}
+
+Going across the border between Haskell and C is relatively costly,
+so for block writes we pack the character strings on the Haskell-side
+before passing the external write routine a pointer to the buffer.
+
+\begin{code}
#ifndef __PARALLEL_HASKELL__
-writeBlocks :: ForeignObj -> Int -> String -> IO Bool
+writeLines :: ForeignObj -> Addr -> Int -> Int -> String -> IO ()
#else
-writeBlocks :: Addr -> Int -> String -> IO Bool
+writeLines :: Addr -> Addr -> Int -> Int -> String -> IO ()
#endif
-writeBlocks fp size s = writeChunks size False fp s
-
- {-
- The breaking up of output into lines along \n boundaries
- works fine as long as there are newlines to split by.
- Avoid the splitting up into lines alltogether (doesn't work
- for overly long lines like the stuff that showsPrec instances
- normally return). Instead, we split them up into fixed size
- chunks before blasting them off to the Real World.
-
- Hacked to avoid multiple passes over the strings - unsightly, but
- a whole lot quicker. -- SOF 3/96
- -}
+writeLines obj buf bf@(I# bufLen) (I# initPos#) s =
+ let
+ write_char :: Addr -> Int# -> Char# -> IO ()
+ write_char (A# buf) n# c# =
+ IO $ \ s# ->
+ case (writeCharOffAddr# buf n# c# s#) of s2# -> IOok s2# ()
+
+ shoveString :: Int# -> [Char] -> IO ()
+ shoveString n ls =
+ case ls of
+ [] ->
+ if n ==# 0# then
+ _ccall_ setBufWPtr obj (0::Int)
+ else do
+ {-
+ At the end of a buffer write, update the buffer position
+ in the underlying file object, so that if the handle
+ is subsequently dropped by the program, the whole
+ buffer will be properly flushed.
+
+ There's one case where this delayed up-date of the buffer
+ position can go wrong: if a thread is killed, it might be
+ in the middle of filling up a buffer, with the result that
+ the partial buffer update is lost upon finalisation. Not
+ that killing of threads is supported at the moment.
+
+ -}
+ _ccall_ setBufWPtr obj (I# n)
+
+ ((C# x):xs) -> do
+ write_char buf n x
+ {- Flushing on buffer exhaustion or newlines (even if it isn't the last one) -}
+ if n ==# bufLen || x `eqChar#` '\n'#
+ then do
+ rc <- mayBlock obj (_ccall_ writeFileObject obj (I# (n +# 1#))) -- ConcHask: UNSAFE, may block.
+ if rc == 0
+ then shoveString 0# xs
+ else constructErrorAndFail "writeLines"
+ else
+ shoveString (n +# 1#) xs
+ in
+ shoveString initPos# s
#ifndef __PARALLEL_HASKELL__
-writeChunks :: Int -> Bool -> ForeignObj -> String -> IO Bool
+writeBlocks :: ForeignObj -> Addr -> Int -> Int -> String -> IO ()
#else
-writeChunks :: Int -> Bool -> Addr -> String -> IO Bool
+writeBlocks :: Addr -> Addr -> Int -> Int -> String -> IO ()
#endif
-writeChunks (I# bufLen) chopOnNewLine fp s =
- stToIO (newCharArray (0,I# bufLen)) >>= \ arr@(MutableByteArray _ arr#) ->
+writeBlocks obj buf bf@(I# bufLen) (I# initPos#) s =
let
- write_char :: MutableByteArray# RealWorld -> Int# -> Char# -> IO ()
- write_char arr# n x = IO $ \ s# ->
- case (writeCharArray# arr# n x s#) of { s1# ->
- IOok s1# () }
+ write_char :: Addr -> Int# -> Char# -> IO ()
+ write_char (A# buf) n# c# =
+ IO $ \ s# ->
+ case (writeCharOffAddr# buf n# c# s#) of s2# -> IOok s2# ()
- shoveString :: Int# -> [Char] -> IO Bool
+ shoveString :: Int# -> [Char] -> IO ()
shoveString n ls =
case ls of
[] ->
if n ==# 0# then
- return True
+ _ccall_ setBufWPtr obj (0::Int)
else do
- rc <- _ccall_ writeFile arr fp (I# n)
- return (rc==0)
+ {-
+ At the end of a buffer write, update the buffer position
+ in the underlying file object, so that if the handle
+ is subsequently dropped by the program, the whole
+ buffer will be properly flushed.
+
+ There's one case where this delayed up-date of the buffer
+ position can go wrong: if a thread is killed, it might be
+ in the middle of filling up a buffer, with the result that
+ the partial buffer update is lost upon finalisation. However,
+ by the time killThread is supported, Haskell finalisers are also
+ likely to be in, which means the 'IOFileObject' hack can go
+ alltogether.
+
+ -}
+ _ccall_ setBufWPtr obj (I# n)
((C# x):xs) -> do
- write_char arr# n x
-
- {- Flushing lines - should we bother? Yes, for line-buffered output. -}
- if n ==# bufLen || (chopOnNewLine && (x `eqChar#` '\n'#))
+ write_char buf n x
+ if n ==# bufLen
then do
- rc <- _ccall_ writeFile arr fp (I# (n +# 1#))
+ rc <- mayBlock obj (_ccall_ writeFileObject obj (I# (n +# 1#))) -- ConcHask: UNSAFE, may block.
if rc == 0
then shoveString 0# xs
- else return False
+ else constructErrorAndFail "writeChunks"
else
shoveString (n +# 1#) xs
in
- shoveString 0# s
+ shoveString initPos# s
#ifndef __PARALLEL_HASKELL__
-writeChars :: ForeignObj -> String -> IO Bool
+writeChars :: ForeignObj -> String -> IO ()
#else
-writeChars :: Addr -> String -> IO Bool
+writeChars :: Addr -> String -> IO ()
#endif
-writeChars fp "" = return True
-writeChars fp (c:cs) = do
- rc <- _ccall_ filePutc fp (ord c)
+writeChars fo "" = return ()
+writeChars fo (c:cs) = do
+ rc <- mayBlock fo (_ccall_ filePutc fo (ord c)) -- ConcHask: UNSAFE, may block.
if rc == 0
- then writeChars fp cs
- else return False
+ then writeChars fo cs
+ else constructErrorAndFail "writeChars"
\end{code}
-The @hPutBuf hdl len elt_sz buf@ action writes the buffer @buf@ to
-the file/channel managed by @hdl@
-the string {\em s} to the file or
-channel managed by {\em hdl}.
-
-begin{code}
-hPutBuf :: Handle -> Int -> Int -> ByteArray Int -> IO ()
-hPutBuf handle len el_sz buf = do
- hdl <- wantWriteableHandle handle
- {-
- The code below is not correct for line-buffered terminal streams,
- as the output stream is not flushed when terminal input is requested
- again, just upon seeing a newline character. A temporary fix for the
- most common line-buffered output stream, stdout, is to assume the
- buffering it was given when created (no buffering). This is not
- as bad as it looks, since stdio buffering sits underneath this.
-
- ToDo: fix me
- -}
- hdl <- getBufferMode hdl
- success <-
- (case bufferMode hdl of
- Just LineBuffering ->
- writeChars (filePtr hdl) str
- --writeLines (filePtr hdl) str
- Just (BlockBuffering (Just size)) ->
- writeBlocks (filePtr hdl) size str
- Just (BlockBuffering Nothing) ->
- writeBlocks (filePtr hdl) ``BUFSIZ'' str
- _ -> -- Nothing is treated pessimistically as NoBuffering
- writeChars (filePtr hdl) str)
- writeHandle handle (markHandle hdl)
- if success
- then return ()
- else constructErrorAndFail "hPutBuf"
-
-end{code}
-
-Computation $hPrint hdl t$ writes the string representation of {\em t}
-given by the $shows$ function to the file or channel managed by {\em
+Computation @hPrint hdl t@ writes the string representation of {\em t}
+given by the @shows@ function to the file or channel managed by {\em
hdl}.
-SOF 2/97: Seem to have disappeared in 1.4 libs.
+[ Seem to have disappeared from the 1.4 interface - SOF 2/97 ]
\begin{code}
---hPrint :: Show a => Handle -> a -> IO ()
+hPrint :: Show a => Handle -> a -> IO ()
hPrint hdl = hPutStr hdl . show
\end{code}
the handle \tr{hdl}, adding a newline at the end.
\begin{code}
---hPutStrLn :: Handle -> String -> IO ()
+hPutStrLn :: Handle -> String -> IO ()
hPutStrLn hndl str = do
hPutStr hndl str
hPutChar hndl '\n'
Right r -> return r
Left e -> fail e
\end{code}
-
module PrelHandle where
-import PrelST
-import PrelArr ( ByteArray(..), newVar, readVar, writeVar )
+import PrelBase
+import PrelArr ( newVar, readVar, writeVar, ByteArray )
import PrelRead ( Read )
import PrelList ( span )
import PrelIOBase
-import PrelTup
-import PrelMaybe
-import PrelBase
-import PrelAddr
-import PrelErr ( error )
-import PrelGHC
+import PrelMaybe ( Maybe(..) )
+import PrelAddr ( Addr, nullAddr )
+import PrelBounded () -- get at Bounded Int instance.
+import PrelNum ( toInteger )
import Ix
#ifndef __PARALLEL_HASKELL__
writeHandle (Handle h) hc = stToIO (writeVar h hc)
#endif
-\end{code}
-%*********************************************************
-%* *
-\subsection{Functions}
-%* *
-%*********************************************************
-
-\begin{code}
-#ifndef __PARALLEL_HASKELL__
-filePtr :: Handle__ -> ForeignObj
-#else
-filePtr :: Handle__ -> Addr
-#endif
-filePtr (SemiClosedHandle fp _) = fp
-filePtr (ReadHandle fp _ _) = fp
-filePtr (WriteHandle fp _ _) = fp
-filePtr (AppendHandle fp _ _) = fp
-filePtr (ReadWriteHandle fp _ _) = fp
-
-bufferMode :: Handle__ -> Maybe BufferMode
-bufferMode (ReadHandle _ m _) = m
-bufferMode (WriteHandle _ m _) = m
-bufferMode (AppendHandle _ m _) = m
-bufferMode (ReadWriteHandle _ m _) = m
-
-markHandle :: Handle__ -> Handle__
-markHandle h@(ReadHandle fp m b)
- | b = h
- | otherwise = ReadHandle fp m True
-markHandle h@(WriteHandle fp m b)
- | b = h
- | otherwise = WriteHandle fp m True
-markHandle h@(AppendHandle fp m b)
- | b = h
- | otherwise = AppendHandle fp m True
-markHandle h@(ReadWriteHandle fp m b)
- | b = h
- | otherwise = ReadWriteHandle fp m True
\end{code}
--------------------------------------------
-
%*********************************************************
%* *
\subsection[StdHandles]{Standard handles}
\begin{code}
stdin, stdout, stderr :: Handle
-stdin = unsafePerformIO (do
- rc <- _ccall_ getLock (``stdin''::Addr) 0
+stdout = unsafePerformIO (do
+ rc <- _ccall_ getLock 1 1 -- ConcHask: SAFE, won't block
case rc of
- 0 -> newHandle ClosedHandle
+ 0 -> newHandle (mkClosedHandle__)
1 -> do
-#ifndef __PARALLEL_HASKELL__
- fp <- makeForeignObj (``stdin''::Addr) (``&freeStdFile''::Addr)
- newHandle (ReadHandle fp Nothing False)
+#ifndef __CONCURRENT_HASKELL__
+ fo <- _ccall_ openStdFile 1 1{-flush on close-} 0{-writeable-} -- ConcHask: SAFE, won't block
#else
- newHandle (ReadHandle ``stdin'' Nothing False)
+ fo <- _ccall_ openStdFile 1 (1{-flush on close-} + 128{-don't block on I/O-})
+ 0{-writeable-} -- ConcHask: SAFE, won't block
#endif
- _ -> do ioError <- constructError "stdin"
- newHandle (ErrorHandle ioError)
+
+#ifndef __PARALLEL_HASKELL__
+ fo <- makeForeignObj fo (``&freeStdFileObject''::Addr)
+#endif
+ (bm, bf_size) <- getBMode__ fo
+ mkBuffer__ fo bf_size
+ newHandle (Handle__ fo WriteHandle bm "stdout")
+ _ -> do ioError <- constructError "stdout"
+ newHandle (mkErrorHandle__ ioError)
)
-stdout = unsafePerformIO (do
- rc <- _ccall_ getLock (``stdout''::Addr) 1
+stdin = unsafePerformIO (do
+ rc <- _ccall_ getLock 0 0 -- ConcHask: SAFE, won't block
case rc of
- 0 -> newHandle ClosedHandle
+ 0 -> newHandle (mkClosedHandle__)
1 -> do
-#ifndef __PARALLEL_HASKELL__
- fp <- makeForeignObj (``stdout''::Addr) (``&freeStdFile''::Addr)
- newHandle (WriteHandle fp Nothing False)
+#ifndef __CONCURRENT_HASKELL__
+ fo <- _ccall_ openStdFile 0 0{-don't flush on close -} 1{-readable-} -- ConcHask: SAFE, won't block
#else
- newHandle (WriteHandle ``stdout'' Nothing False)
+ fo <- _ccall_ openStdFile 0 (0{-flush on close-} + 128{-don't block on I/O-})
+ 1{-readable-} -- ConcHask: SAFE, won't block
#endif
- _ -> do ioError <- constructError "stdout"
- newHandle (ErrorHandle ioError)
+
+#ifndef __PARALLEL_HASKELL__
+ fo <- makeForeignObj fo (``&freeStdFileObject''::Addr)
+#endif
+ (bm, bf_size) <- getBMode__ fo
+ mkBuffer__ fo bf_size
+ hdl <- newHandle (Handle__ fo ReadHandle bm "stdin")
+ -- when stdin and stdout are both connected to a terminal, ensure
+ -- that anything buffered on stdout is flushed prior to reading from stdin.
+ --
+ hConnectTerms stdout hdl
+ return hdl
+ _ -> do ioError <- constructError "stdin"
+ newHandle (mkErrorHandle__ ioError)
)
+
stderr = unsafePerformIO (do
- rc <- _ccall_ getLock (``stderr''::Addr) 1
+ rc <- _ccall_ getLock 2 1 -- ConcHask: SAFE, won't block
case rc of
- 0 -> newHandle ClosedHandle
+ 0 -> newHandle (mkClosedHandle__)
1 -> do
-#ifndef __PARALLEL_HASKELL__
- fp <- makeForeignObj (``stderr''::Addr) (``&freeStdFile''::Addr)
- newHandle (WriteHandle fp (Just NoBuffering) False)
+#ifndef __CONCURRENT_HASKELL__
+ fo <- _ccall_ openStdFile 2 1{-flush on close-} 0{-writeable-} -- ConcHask: SAFE, won't block
#else
- newHandle (WriteHandle ``stderr'' (Just NoBuffering) False)
+ fo <- _ccall_ openStdFile 2 (1{-flush on close-} + 128{-don't block on I/O-})
+ 0{-writeable-} -- ConcHask: SAFE, won't block
#endif
+
+#ifndef __PARALLEL_HASKELL__
+ fo <- makeForeignObj fo (``&freeStdFileObject''::Addr)
+#endif
+ newHandle (Handle__ fo WriteHandle NoBuffering "stderr")
_ -> do ioError <- constructError "stderr"
- newHandle (ErrorHandle ioError)
+ newHandle (mkErrorHandle__ ioError)
)
\end{code}
openFileEx :: FilePath -> IOModeEx -> IO Handle
openFileEx f m = do
- ptr <- _ccall_ openFile f m'
- if ptr /= ``NULL'' then do
+ fo <- _ccall_ openFile f file_mode binary flush_on_close -- ConcHask: SAFE, won't block
+ if fo /= nullAddr then do
#ifndef __PARALLEL_HASKELL__
- fp <- makeForeignObj ptr ((``&freeFile'')::Addr)
- newHandle (htype fp Nothing False)
-#else
- newHandle (htype ptr Nothing False)
+ fo <- makeForeignObj fo ((``&freeFileObject'')::Addr)
#endif
+ (bm, bf_size) <- getBMode__ fo
+ mkBuffer__ fo bf_size
+ newHandle (Handle__ fo htype bm f)
else do
constructErrorAndFailWithInfo "openFile" f
where
- imo = case m of
- BinaryMode imo -> imo
- TextMode imo -> imo
+ (imo, binary) =
+ case m of
+ BinaryMode imo -> (imo, 1)
+ TextMode imo -> (imo, 0)
- m' = case m of
- BinaryMode _ -> imo' ++ "b"
- TextMode imo -> imo'
+#ifndef __CONCURRENT_HASKELL__
+ file_mode = file_mode'
+#else
+ file_mode = file_mode' + 128{-Don't block on I/O-}
+#endif
- imo' =
+ (flush_on_close, file_mode') =
case imo of
- ReadMode -> "r"
- WriteMode -> "w"
- AppendMode -> "a"
- ReadWriteMode -> "r+"
+ AppendMode -> (1, 0)
+ WriteMode -> (1, 1)
+ ReadMode -> (0, 2)
+ ReadWriteMode -> (1, 3)
htype = case imo of
ReadMode -> ReadHandle
hClose :: Handle -> IO ()
hClose handle = do
- htype <- readHandle handle
- case htype of
+ handle_ <- readHandle handle
+ case haType__ handle_ of
ErrorHandle ioError -> do
- writeHandle handle htype
+ writeHandle handle handle_
fail ioError
ClosedHandle -> do
- writeHandle handle htype
- ioe_closedHandle handle
- SemiClosedHandle fp (buf,_) -> do
- (if buf /= ``NULL'' then
- _ccall_ free buf
- else
- return ())
- fp_a <- _casm_ `` %r = (char *)%0; '' fp
- if fp_a /= (``NULL''::Addr) then do
- -- Under what condition can this be NULL?
- rc <- _ccall_ closeFile fp
- {- We explicitly close a file object so that we can be told
- if there were any errors. Note that after @hClose@
- has been performed, the ForeignObj embedded in the Handle
- is still lying around in the heap, so care is taken
- to avoid closing the file object when the ForeignObj
- is finalised. -}
- if rc == 0 then do
-#ifndef __PARALLEL_HASKELL__
- -- Mark the foreign object data value as
- -- gone to the finaliser (freeFile())
- writeForeignObj fp ``NULL''
-#endif
- writeHandle handle ClosedHandle
- else do
- writeHandle handle htype
- constructErrorAndFail "hClose"
-
- else writeHandle handle htype
+ writeHandle handle handle_
+ ioe_closedHandle "hClose" handle
+ _ -> do
+ rc <- _ccall_ closeFile (haFO__ handle_) 1{-flush if you can-} -- ConcHask: SAFE, won't block
+ {- We explicitly close a file object so that we can be told
+ if there were any errors. Note that after @hClose@
+ has been performed, the ForeignObj embedded in the Handle
+ is still lying around in the heap, so care is taken
+ to avoid closing the file object when the ForeignObj
+ is finalised. (we overwrite the file ptr in the underlying
+ FileObject with a NULL as part of closeFile())
+ -}
+ if rc == 0
+ then
+ writeHandle handle (handle_{ haType__ = ClosedHandle,
+ haFO__ = nullFile__ })
+ else do
+ writeHandle handle handle_
+ constructErrorAndFail "hClose"
- other -> do
- let fp = filePtr other
- rc <- _ccall_ closeFile fp
- if rc == 0 then do
-#ifndef __PARALLEL_HASKELL__
- -- Mark the foreign object data
- writeForeignObj fp ``NULL''
-#endif
- writeHandle handle ClosedHandle
- else do
- writeHandle handle htype
- constructErrorAndFail "hClose"
\end{code}
Computation $hClose hdl$ makes handle {\em hdl} closed. Before the
\begin{code}
hFileSize :: Handle -> IO Integer
hFileSize handle = do
- htype <- readHandle handle
- case htype of
+ handle_ <- readHandle handle
+ case haType__ handle_ of
ErrorHandle ioError -> do
- writeHandle handle htype
+ writeHandle handle handle_
fail ioError
ClosedHandle -> do
- writeHandle handle htype
- ioe_closedHandle handle
- SemiClosedHandle _ _ -> do
- writeHandle handle htype
- ioe_closedHandle handle
+ writeHandle handle handle_
+ ioe_closedHandle "hFileSize" handle
+ SemiClosedHandle -> do
+ writeHandle handle handle_
+ ioe_closedHandle "hFileSize" handle
other ->
-- HACK! We build a unique MP_INT of the right shape to hold
-- a single unsigned word, and we let the C routine
_casm_ ``%r = 1;'' >>= \(I# hack#) ->
case int2Integer# hack# of
result@(J# _ _ d#) -> do
- let bogus_bounds = (error "fileSize"::(Int,Int))
- rc <- _ccall_ fileSize (filePtr other)
- (ByteArray bogus_bounds d#)
- writeHandle handle htype
+ rc <- _ccall_ fileSize (haFO__ handle_) d# -- ConcHask: SAFE, won't block
+ writeHandle handle handle_
if rc == 0 then
return result
else
constructErrorAndFail "hFileSize"
\end{code}
-For a readable handle {\em hdl}, computation $hIsEOF hdl$ returns
-$True$ if no further input can be taken from {\em hdl} or for a
+For a readable handle {\em 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$.
+the file. Otherwise, it returns @False@.
\begin{code}
hIsEOF :: Handle -> IO Bool
hIsEOF handle = do
- htype <- readHandle handle
- case htype of
- ErrorHandle ioError -> do
- writeHandle handle htype
- fail ioError
- ClosedHandle -> do
- writeHandle handle htype
- ioe_closedHandle handle
- SemiClosedHandle _ _ -> do
- writeHandle handle htype
- ioe_closedHandle handle
- WriteHandle _ _ _ -> do
- writeHandle handle htype
- fail (IOError (Just handle) IllegalOperation
- "handle is not open for reading")
- AppendHandle _ _ _ -> do
- writeHandle handle htype
- fail (IOError (Just handle) IllegalOperation
- "handle is not open for reading")
- other -> do
- rc <- _ccall_ fileEOF (filePtr other)
- writeHandle handle (markHandle htype)
- case rc of
- 0 -> return False
- 1 -> return True
- _ -> constructErrorAndFail "hIsEOF"
+ handle_ <- wantReadableHandle "hIsEOF" handle
+ let fo = haFO__ handle_
+ rc <- mayBlock fo (_ccall_ fileEOF fo) -- ConcHask: UNSAFE, may block
+ writeHandle handle handle_
+ case rc of
+ 0 -> return False
+ 1 -> return True
+ _ -> constructErrorAndFail "hIsEOF"
isEOF :: IO Bool
isEOF = hIsEOF stdin
hSetBuffering handle mode =
case mode of
BlockBuffering (Just n)
- | n <= 0 -> fail (IOError (Just handle) InvalidArgument
- "illegal buffer size")
- other -> do
- htype <- readHandle handle
- if isMarked htype then do
- writeHandle handle htype
- fail (IOError (Just handle)
- UnsupportedOperation
- "can't set buffering for a dirty handle")
- else
- case htype of
- ErrorHandle ioError -> do
- writeHandle handle htype
- fail ioError
- ClosedHandle -> do
- writeHandle handle htype
- ioe_closedHandle handle
- other -> do
- {-
- We're being non-standard here, and allow the buffering
- of a semi-closed handle to be changed. -- sof 6/98
- -}
- rc <- _ccall_ setBuffering (filePtr other) bsize
- if rc == 0 then
- writeHandle handle ((hcon other) (filePtr other)
- (Just mode) True)
- else do
- writeHandle handle htype
- constructErrorAndFail "hSetBuffering"
-
+ | n <= 0 -> fail (IOError (Just handle)
+ InvalidArgument
+ "hSetBuffering"
+ ("illegal buffer size " ++ showsPrec 9 n [])) -- 9 => should be parens'ified.
+ _ -> do
+ handle_ <- readHandle handle
+ case haType__ handle_ of
+ ErrorHandle ioError -> do
+ writeHandle handle handle_
+ fail ioError
+ ClosedHandle -> do
+ writeHandle handle handle_
+ ioe_closedHandle "hSetBuffering" handle
+ _ -> 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]
+ -}
+ let fo = haFO__ handle_
+ rc <- mayBlock fo (_ccall_ setBuffering fo bsize) -- ConcHask: UNSAFE, may block
+ if rc == 0
+ then do
+ writeHandle handle (handle_{ haBufferMode__ = mode })
+ else do
+ -- Note: failure to change the buffer size will cause old buffer to be flushed.
+ writeHandle handle handle_
+ constructErrorAndFail "hSetBuffering"
where
- isMarked :: Handle__ -> Bool
- isMarked (ReadHandle fp m b) = b
- isMarked (WriteHandle fp m b) = b
- isMarked (AppendHandle fp m b) = b
- isMarked (ReadWriteHandle fp m b) = b
- isMarked _ = False
-
bsize :: Int
bsize = case mode of
- NoBuffering -> 0
- LineBuffering -> -1
- BlockBuffering Nothing -> -2
- BlockBuffering (Just n) -> n
-
-#ifndef __PARALLEL_HASKELL__
- hcon :: Handle__ -> (ForeignObj -> (Maybe BufferMode) -> Bool -> Handle__)
-#else
- hcon :: Handle__ -> (Addr -> (Maybe BufferMode) -> Bool -> Handle__)
-#endif
- hcon (ReadHandle _ _ _) = ReadHandle
- hcon (WriteHandle _ _ _) = WriteHandle
- hcon (AppendHandle _ _ _) = AppendHandle
- hcon (ReadWriteHandle _ _ _) = ReadWriteHandle
+ NoBuffering -> 0
+ LineBuffering -> -1
+ BlockBuffering Nothing -> -2
+ BlockBuffering (Just n) -> n
\end{code}
-Computation $flush hdl$ causes any items buffered for output in handle
-{\em hdl} to be sent immediately to the operating system.
+The action @hFlush hdl@ causes any items buffered for output
+in handle {\em hdl} to be sent immediately to the operating
+system.
\begin{code}
hFlush :: Handle -> IO ()
hFlush handle = do
- htype <- readHandle handle
- case htype of
- ErrorHandle ioError -> do
- writeHandle handle htype
- fail ioError
- ClosedHandle -> do
- writeHandle handle htype
- ioe_closedHandle handle
- SemiClosedHandle _ _ -> do
- writeHandle handle htype
- ioe_closedHandle handle
- other -> do
- rc <- _ccall_ flushFile (filePtr other)
- writeHandle handle (markHandle htype)
- if rc == 0 then
- return ()
- else
- constructErrorAndFail "hFlush"
+ handle_ <- wantWriteableHandle "hFlush" handle
+ let fo = haFO__ handle_
+ rc <- mayBlock fo (_ccall_ flushFile fo) -- ConcHask: UNSAFE, may block
+ writeHandle handle handle_
+ if rc == 0 then
+ return ()
+ else
+ constructErrorAndFail "hFlush"
+
\end{code}
%*********************************************************
\begin{code}
-data HandlePosn = HandlePosn Handle Int
+data HandlePosn
+ = HandlePosn
+ Handle -- Q: should this be a weak or strong ref. to the handle?
+ Int
data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd
deriving (Eq, Ord, Ix, Enum, Read, Show)
\end{code}
-Computation $hGetPosn hdl$ returns the current I/O
+Computation @hGetPosn hdl@ returns the current I/O
position of {\em hdl} as an abstract position. Computation
$hSetPosn p$ sets the position of {\em hdl}
to a previously obtained position {\em p}.
\begin{code}
hGetPosn :: Handle -> IO HandlePosn
hGetPosn handle = do
- htype <- readHandle handle
- case htype of
- ErrorHandle ioError -> do
- writeHandle handle htype
- fail ioError
- ClosedHandle -> do
- writeHandle handle htype
- ioe_closedHandle handle
- SemiClosedHandle _ _ -> do
- writeHandle handle htype
- ioe_closedHandle handle
- other -> do
- posn <- _ccall_ getFilePosn (filePtr other)
- writeHandle handle htype
- if posn /= -1 then
- return (HandlePosn handle posn)
- else
- constructErrorAndFail "hGetPosn"
+ handle_ <- wantSeekableHandle "hGetPosn" handle
+ posn <- _ccall_ getFilePosn (haFO__ handle_) -- ConcHask: SAFE, won't block
+ writeHandle handle handle_
+ if posn /= -1 then
+ return (HandlePosn handle posn)
+ else
+ constructErrorAndFail "hGetPosn"
hSetPosn :: HandlePosn -> IO ()
hSetPosn (HandlePosn handle posn) = do
- htype <- readHandle handle
- case htype of
- ErrorHandle ioError -> do
- writeHandle handle htype
- fail ioError
- ClosedHandle -> do
- writeHandle handle htype
- ioe_closedHandle handle
- SemiClosedHandle _ _ -> do
- writeHandle handle htype
- ioe_closedHandle handle
- AppendHandle _ _ _ -> do
- writeHandle handle htype
- fail (IOError (Just handle) IllegalOperation "handle is not seekable")
- other -> do
- rc <- _ccall_ setFilePosn (filePtr other) posn
- writeHandle handle (markHandle htype)
- if rc == 0 then
- return ()
- else
- constructErrorAndFail "hSetPosn"
+ handle_ <- wantSeekableHandle "hSetPosn" handle -- not as silly as it looks: the handle may have been closed in the meantime.
+ let fo = haFO__ handle_
+ rc <- mayBlock fo (_ccall_ setFilePosn fo posn) -- ConcHask: UNSAFE, may block
+ writeHandle handle handle_
+ if rc == 0 then
+ return ()
+ else
+ constructErrorAndFail "hSetPosn"
\end{code}
-Computation $hSeek hdl mode i$ sets the position of handle
-{\em hdl} depending on $mode$. If {\em mode} is
+The action @hSeek hdl mode i@ sets the position of handle
+@hdl@ depending on @mode@. If @mode@ is
\begin{itemize}
-\item[{\bf AbsoluteSeek}] The position of {\em hdl} is set to {\em i}.
-\item[{\bf RelativeSeek}] The position of {\em hdl} is set to offset {\em i} from
+\item[{\bf AbsoluteSeek}] The position of @hdl@ is set to @i@.
+\item[{\bf RelativeSeek}] The position of @hdl@ is set to offset @i@ from
the current position.
-\item[{\bf SeekToEnd}] The position of {\em hdl} is set to offset {\em i} from
+\item[{\bf SeekFromEnd}] The position of @hdl@ is set to offset @i@ from
the end of the file.
-\item[{\bf SeekFromBeginning}] The position of {\em hdl} is set to offset {\em i} from
-the beginning of the file.
\end{itemize}
-Some handles may not be seekable $hIsSeekable$, or only support a
+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.
+ - relative seeking on buffered handles can lead to non-obvious results.
+
\begin{code}
hSeek :: Handle -> SeekMode -> Integer -> IO ()
hSeek handle mode offset@(J# _ s# d#) = do
- htype <- readHandle handle
- case htype of
- ErrorHandle ioError -> do
- writeHandle handle htype
- fail ioError
- ClosedHandle -> do
- writeHandle handle htype
- ioe_closedHandle handle
- SemiClosedHandle _ _ -> do
- writeHandle handle htype
- ioe_closedHandle handle
- AppendHandle _ _ _ -> do
- writeHandle handle htype
- fail (IOError (Just handle) IllegalOperation "handle is not seekable")
- other -> do
- rc <- _ccall_ seekFile (filePtr other) whence (I# s#)
- (ByteArray (0,0) d#)
- writeHandle handle (markHandle htype)
- if rc == 0 then
- return ()
- else
- constructErrorAndFail "hSeek"
+ handle_ <- wantSeekableHandle "hSeek" handle
+ let fo = haFO__ handle_
+ rc <- mayBlock fo (_ccall_ seekFile fo whence (I# s#) d#) -- ConcHask: UNSAFE, may block
+ writeHandle handle handle_
+ if rc == 0 then
+ return ()
+ else
+ constructErrorAndFail "hSeek"
where
whence :: Int
whence = case mode of
- AbsoluteSeek -> ``SEEK_SET''
- RelativeSeek -> ``SEEK_CUR''
- SeekFromEnd -> ``SEEK_END''
+ AbsoluteSeek -> 0
+ RelativeSeek -> 1
+ SeekFromEnd -> 2
\end{code}
%*********************************************************
\begin{code}
hIsOpen :: Handle -> IO Bool
hIsOpen handle = do
- htype <- readHandle handle
- case htype of
+ handle_ <- readHandle handle
+ case haType__ handle_ of
ErrorHandle ioError -> do
- writeHandle handle htype
+ writeHandle handle handle_
fail ioError
ClosedHandle -> do
- writeHandle handle htype
+ writeHandle handle handle_
return False
- SemiClosedHandle _ _ -> do
- writeHandle handle htype
+ SemiClosedHandle -> do
+ writeHandle handle handle_
return False
- other -> do
- writeHandle handle htype
+ _ -> do
+ writeHandle handle handle_
return True
hIsClosed :: Handle -> IO Bool
hIsClosed handle = do
- htype <- readHandle handle
- case htype of
+ handle_ <- readHandle handle
+ case haType__ handle_ of
ErrorHandle ioError -> do
- writeHandle handle htype
+ writeHandle handle handle_
fail ioError
ClosedHandle -> do
- writeHandle handle htype
+ writeHandle handle handle_
return True
- other -> do
- writeHandle handle htype
+ _ -> do
+ writeHandle handle handle_
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 handle = do
- htype <- readHandle handle
- case htype of
+ handle_ <- readHandle handle
+ case haType__ handle_ of
ErrorHandle ioError -> do
- writeHandle handle htype
+ writeHandle handle handle_
fail ioError
ClosedHandle -> do
- writeHandle handle htype
- ioe_closedHandle handle
- SemiClosedHandle _ _ -> do
- writeHandle handle htype
- ioe_closedHandle handle
- other -> do
- writeHandle handle htype
- return (isReadable other)
+ writeHandle handle handle_
+ ioe_closedHandle "hIsReadable" handle
+ SemiClosedHandle -> do
+ writeHandle handle handle_
+ ioe_closedHandle "hIsReadable" handle
+ htype -> do
+ writeHandle handle handle_
+ return (isReadable htype)
where
- isReadable (ReadHandle _ _ _) = True
- isReadable (ReadWriteHandle _ _ _) = True
- isReadable _ = False
+ isReadable ReadHandle = True
+ isReadable ReadWriteHandle = True
+ isReadable _ = False
hIsWritable :: Handle -> IO Bool
hIsWritable handle = do
- htype <- readHandle handle
- case htype of
+ handle_ <- readHandle handle
+ case haType__ handle_ of
ErrorHandle ioError -> do
- writeHandle handle htype
+ writeHandle handle handle_
fail ioError
ClosedHandle -> do
- writeHandle handle htype
- ioe_closedHandle handle
- SemiClosedHandle _ _ -> do
- writeHandle handle htype
- ioe_closedHandle handle
- other -> do
- writeHandle handle htype
- return (isWritable other)
+ writeHandle handle handle_
+ ioe_closedHandle "hIsWritable" handle
+ SemiClosedHandle -> do
+ writeHandle handle handle_
+ ioe_closedHandle "hIsWritable" handle
+ htype -> do
+ writeHandle handle handle_
+ return (isWritable htype)
where
- isWritable (AppendHandle _ _ _) = True
- isWritable (WriteHandle _ _ _) = True
- isWritable (ReadWriteHandle _ _ _) = True
- isWritable _ = False
-
-getBufferMode :: Handle__ -> IO Handle__
-getBufferMode htype =
- case bufferMode htype of
- Just x -> return htype
- Nothing -> do
- rc <- _ccall_ getBufferMode (filePtr htype)
- let
- mode =
- case rc of
- 0 -> Just NoBuffering
- -1 -> Just LineBuffering
- -2 -> Just (BlockBuffering Nothing)
- -3 -> Nothing
- n -> Just (BlockBuffering (Just n))
- return (case htype of
- ReadHandle fp _ b -> ReadHandle fp mode b
- WriteHandle fp _ b -> WriteHandle fp mode b
- AppendHandle fp _ b -> AppendHandle fp mode b
- ReadWriteHandle fp _ b -> ReadWriteHandle fp mode b)
-
-hIsBlockBuffered :: Handle -> IO (Bool,Maybe Int)
-hIsBlockBuffered handle = do
- htype <- readHandle handle
- case htype of
- ErrorHandle ioError -> do
- writeHandle handle htype
- fail ioError
- ClosedHandle -> do
- writeHandle handle htype
- ioe_closedHandle handle
- SemiClosedHandle _ _ -> do
- writeHandle handle htype
- ioe_closedHandle handle
- other -> do
- other <- getBufferMode other
- case bufferMode other of
- Just (BlockBuffering size) -> do
- writeHandle handle other
- return (True, size)
- Just _ -> do
- writeHandle handle other
- return (False, Nothing)
- Nothing ->
- constructErrorAndFail "hIsBlockBuffered"
-
-hIsLineBuffered :: Handle -> IO Bool
-hIsLineBuffered handle = do
- htype <- readHandle handle
- case htype of
- ErrorHandle ioError -> do
- writeHandle handle htype
- fail ioError
- ClosedHandle -> do
- writeHandle handle htype
- ioe_closedHandle handle
- SemiClosedHandle _ _ -> do
- writeHandle handle htype
- ioe_closedHandle handle
- other -> do
- other <- getBufferMode other
- case bufferMode other of
- Just LineBuffering -> do
- writeHandle handle other
- return True
- Just _ -> do
- writeHandle handle other
- return False
- Nothing ->
- constructErrorAndFail "hIsLineBuffered"
-
-hIsNotBuffered :: Handle -> IO Bool
-hIsNotBuffered handle = do
- htype <- readHandle handle
- case htype of
- ErrorHandle ioError -> do
- writeHandle handle htype
- fail ioError
- ClosedHandle -> do
- writeHandle handle htype
- ioe_closedHandle handle
- SemiClosedHandle _ _ -> do
- writeHandle handle htype
- ioe_closedHandle handle
- other -> do
- other <- getBufferMode other
- case bufferMode other of
- Just NoBuffering -> do
- writeHandle handle other
- return True
- Just _ -> do
- writeHandle handle other
- return False
- Nothing ->
- constructErrorAndFail "hIsNotBuffered"
+ isWritable AppendHandle = True
+ isWritable WriteHandle = True
+ isWritable ReadWriteHandle = True
+ isWritable _ = False
+
+#ifndef __PARALLEL_HASKELL__
+getBMode__ :: ForeignObj -> IO (BufferMode, Int)
+#else
+getBMode__ :: Addr -> IO (BufferMode, Int)
+#endif
+getBMode__ fo = do
+ rc <- _ccall_ getBufferMode fo -- ConcHask: SAFE, won't block
+ case (rc::Int) of
+ 0 -> return (NoBuffering, 0)
+ -1 -> return (LineBuffering, default_buffer_size)
+ -2 -> return (BlockBuffering Nothing, default_buffer_size)
+ -3 -> return (NoBuffering, 0) -- only happens on un-stat()able files.
+ n -> return (BlockBuffering (Just n), n)
+ where
+ default_buffer_size :: Int
+ default_buffer_size = (``BUFSIZ'' - 1)
+\end{code}
+
+Querying how a handle buffers its data:
+
+\begin{code}
hGetBuffering :: Handle -> IO BufferMode
hGetBuffering handle = do
- htype <- readHandle handle
- case htype of
+ handle_ <- readHandle handle
+ case haType__ handle_ of
ErrorHandle ioError -> do
- writeHandle handle htype
+ writeHandle handle handle_
fail ioError
ClosedHandle -> do
- writeHandle handle htype
- ioe_closedHandle handle
- other -> do
+ writeHandle handle handle_
+ ioe_closedHandle "hGetBuffering" handle
+ _ -> do
{-
We're being non-standard here, and allow the buffering
of a semi-closed handle to be queried. -- sof 6/98
-}
- other <- getBufferMode other
- case bufferMode other of
- Just v -> do
- writeHandle handle other
- return v
- Nothing ->
- constructErrorAndFail "hGetBuffering"
+ let v = haBufferMode__ handle_
+ writeHandle handle handle_
+ return v -- could be stricter..
+
+\end{code}
+\begin{code}
hIsSeekable :: Handle -> IO Bool
hIsSeekable handle = do
- htype <- readHandle handle
- case htype of
+ handle_ <- readHandle handle
+ case haType__ handle_ of
ErrorHandle ioError -> do
- writeHandle handle htype
+ writeHandle handle handle_
fail ioError
ClosedHandle -> do
- writeHandle handle htype
- ioe_closedHandle handle
- SemiClosedHandle _ _ -> do
- writeHandle handle htype
- ioe_closedHandle handle
- AppendHandle _ _ _ -> do
- writeHandle handle htype
+ writeHandle handle handle_
+ ioe_closedHandle "hIsSeekable" handle
+ SemiClosedHandle -> do
+ writeHandle handle handle_
+ ioe_closedHandle "hIsSeekable" handle
+ AppendHandle -> do
+ writeHandle handle handle_
return False
other -> do
- rc <- _ccall_ seekFileP (filePtr other)
- writeHandle handle htype
+ rc <- _ccall_ seekFileP (haFO__ handle_) -- ConcHask: SAFE, won't block
+ writeHandle handle handle_
case rc of
0 -> return False
1 -> return True
%* *
%*********************************************************
+Non-standard GHC extension is to allow the echoing status
+of a handles connected to terminals to be reconfigured:
+
\begin{code}
hSetEcho :: Handle -> Bool -> IO ()
hSetEcho hdl on = do
if not isT
then return ()
else do
- htype <- readHandle hdl
- case htype of
+ handle_ <- readHandle hdl
+ case haType__ handle_ of
ErrorHandle ioError -> do
- writeHandle hdl htype
+ writeHandle hdl handle_
fail ioError
ClosedHandle -> do
- writeHandle hdl htype
- ioe_closedHandle hdl
+ writeHandle hdl handle_
+ ioe_closedHandle "hSetEcho" hdl
other -> do
- rc <- _ccall_ setTerminalEcho (filePtr htype) (if on then 1 else 0)
- writeHandle hdl htype
+ rc <- _ccall_ setTerminalEcho (haFO__ handle_) (if on then 1 else 0) -- ConcHask: SAFE, won't block
+ writeHandle hdl handle_
if rc /= -1
then return ()
else constructErrorAndFail "hSetEcho"
if not isT
then return False
else do
- htype <- readHandle hdl
- case htype of
+ handle_ <- readHandle hdl
+ case haType__ handle_ of
ErrorHandle ioError -> do
- writeHandle hdl htype
+ writeHandle hdl handle_
fail ioError
ClosedHandle -> do
- writeHandle hdl htype
- ioe_closedHandle hdl
+ writeHandle hdl handle_
+ ioe_closedHandle "hGetEcho" hdl
other -> do
- rc <- _ccall_ getTerminalEcho (filePtr htype)
- writeHandle hdl htype
+ rc <- _ccall_ getTerminalEcho (haFO__ handle_) -- ConcHask: SAFE, won't block
+ writeHandle hdl handle_
case rc of
1 -> return True
0 -> return False
hIsTerminalDevice :: Handle -> IO Bool
hIsTerminalDevice hdl = do
- htype <- readHandle hdl
- case htype of
+ handle_ <- readHandle hdl
+ case haType__ handle_ of
ErrorHandle ioError -> do
- writeHandle hdl htype
+ writeHandle hdl handle_
fail ioError
ClosedHandle -> do
- writeHandle hdl htype
- ioe_closedHandle hdl
+ writeHandle hdl handle_
+ ioe_closedHandle "hIsTerminalDevice" hdl
other -> do
- rc <- _ccall_ isTerminalDevice (filePtr htype)
- writeHandle hdl htype
+ rc <- _ccall_ isTerminalDevice (haFO__ handle_) -- ConcHask: SAFE, won't block
+ writeHandle hdl handle_
case rc of
1 -> return True
0 -> return False
_ -> constructErrorAndFail "hIsTerminalDevice"
\end{code}
+\begin{code}
+hConnectTerms :: Handle -> Handle -> IO ()
+hConnectTerms hW hR = hConnectHdl_ hW hR 1{-check if they're both coming connected to ttys-}
+
+hConnectTo :: Handle -> Handle -> IO ()
+hConnectTo hW hR = hConnectHdl_ hW hR 0{-connect regardless-}
+
+hConnectHdl_ :: Handle -> Handle -> Int -> IO ()
+hConnectHdl_ hW hR is_tty = do
+ hW_ <- wantWriteableHandle "hConnectTo" hW
+ hR_ <- wantReadableHandle "hConnectTo" hR
+ _ccall_ setConnectedTo (haFO__ hR_) (haFO__ hW_) is_tty -- ConcHask: SAFE, won't block
+ writeHandle hR hR_
+ writeHandle hW hW_
+
+\end{code}
+
+As an extension, we also allow characters to be pushed back.
+Like ANSI C stdio, we guarantee no more than one character of
+pushback. (For unbuffered channels, the (default) push-back limit is
+2 chars tho.)
+
+\begin{code}
+hUngetChar :: Handle -> Char -> IO ()
+hUngetChar handle c = do
+ handle_ <- wantReadableHandle "hLookAhead" handle
+ rc <- _ccall_ ungetChar (haFO__ handle_) (ord c) -- ConcHask: SAFE, won't block
+ writeHandle handle handle_
+ if rc == (-1)
+ then constructErrorAndFail "hUngetChar"
+ else return ()
+
+\end{code}
+
+
+Hoisting files in in one go is sometimes useful, so we support
+this as an extension:
+
+\begin{code}
+-- in one go, read file into an externally allocated buffer.
+slurpFile :: FilePath -> IO (Addr, Int)
+slurpFile fname = do
+ hdl <- openFile fname ReadMode
+ sz <- hFileSize hdl
+ if sz > toInteger (maxBound::Int) then
+ fail (userError "slurpFile: file too big")
+ else do
+ let sz_i = fromInteger sz
+ chunk <- _ccall_ allocMemory__ (sz_i::Int)
+ if chunk == nullAddr
+ then do
+ hClose hdl
+ constructErrorAndFail "slurpFile"
+ else do
+ handle_ <- readHandle hdl
+ let fo = haFO__ handle_
+ rc <- mayBlock fo (_ccall_ readChunk fo chunk sz_i) -- ConcHask: UNSAFE, may block.
+ writeHandle hdl handle_
+ hClose hdl
+ if rc < 0
+ then constructErrorAndFail "slurpFile"
+ else return (chunk, rc)
+
+\end{code}
+
+The @hPutBuf hdl buf len@ action writes an already packed sequence of
+bytes to the file/channel managed by @hdl@ - non-standard.
+
+\begin{code}
+hPutBuf :: Handle -> Addr -> Int -> IO ()
+hPutBuf handle buf len = do
+ handle_ <- wantWriteableHandle "hPutBuf" handle
+ let fo = haFO__ handle_
+ rc <- mayBlock fo (_ccall_ writeBuf fo buf len) -- ConcHask: UNSAFE, may block.
+ writeHandle handle handle_
+ if rc == 0
+ then return ()
+ else constructErrorAndFail "hPutBuf"
+
+hPutBufBA :: Handle -> ByteArray Int -> Int -> IO ()
+hPutBufBA handle buf len = do
+ handle_ <- wantWriteableHandle "hPutBufBA" handle
+ let fo = haFO__ handle_
+ rc <- mayBlock fo (_ccall_ writeBufBA fo buf len) -- ConcHask: UNSAFE, may block.
+ writeHandle handle handle_
+ if rc == 0
+ then return ()
+ else constructErrorAndFail "hPutBuf"
+\end{code}
+
+Sometimes it's useful to get at the file descriptor that
+the Handle contains..
+
+\begin{code}
+getHandleFd :: Handle -> IO Int
+getHandleFd handle = do
+ handle_ <- readHandle handle
+ case (haType__ handle_) of
+ ErrorHandle ioError -> do
+ writeHandle handle handle_
+ fail ioError
+ ClosedHandle -> do
+ writeHandle handle handle_
+ ioe_closedHandle "getHandleFd" handle
+ _ -> do
+ fd <- _ccall_ getFileFd (haFO__ handle_)
+ writeHandle handle handle_
+ return fd
+\end{code}
%*********************************************************
%* *
%*********************************************************
-These two functions are meant to get things out of @IOErrors@.
+These three functions are meant to get things out of @IOErrors@.
+
+(ToDo: improve!)
\begin{code}
ioeGetFileName :: IOError -> Maybe FilePath
ioeGetErrorString :: IOError -> String
ioeGetHandle :: IOError -> Maybe Handle
-ioeGetHandle (IOError h _ _) = h
-ioeGetErrorString (IOError _ iot str) =
+ioeGetHandle (IOError h _ _ _) = h
+ioeGetErrorString (IOError _ iot _ str) =
case iot of
EOF -> "end of file"
_ -> str
-ioeGetFileName (IOError _ _ str) =
+ioeGetFileName (IOError _ _ _ str) =
case span (/=':') str of
(fs,[]) -> Nothing
(fs,_) -> Just fs
\end{code}
-Internal function for creating an @IOError@ representing the
-access of a closed file.
-
-\begin{code}
-
-ioe_closedHandle :: Handle -> IO a
-ioe_closedHandle h = fail (IOError (Just h) IllegalOperation "handle is closed")
-\end{code}
-
A number of operations want to get at a readable or writeable handle, and fail
if it isn't:
\begin{code}
-wantReadableHandle :: Handle -> IO Handle__
-wantReadableHandle handle = do
- htype <- readHandle handle
- case htype of
+wantReadableHandle :: String -> Handle -> IO Handle__
+wantReadableHandle fun handle = do
+ handle_ <- readHandle handle
+ case haType__ handle_ of
+ ErrorHandle ioError -> do
+ writeHandle handle handle_
+ fail ioError
+ ClosedHandle -> do
+ writeHandle handle handle_
+ ioe_closedHandle fun handle
+ SemiClosedHandle -> do
+ writeHandle handle handle_
+ ioe_closedHandle fun handle
+ AppendHandle -> do
+ writeHandle handle handle_
+ fail not_readable_error
+ WriteHandle -> do
+ writeHandle handle handle_
+ fail not_readable_error
+ other -> return handle_
+ where
+ not_readable_error =
+ IOError (Just handle) IllegalOperation fun
+ ("handle is not open for reading")
+
+wantWriteableHandle :: String -> Handle -> IO Handle__
+wantWriteableHandle fun handle = do
+ handle_ <- readHandle handle
+ case haType__ handle_ of
ErrorHandle ioError -> do
- writeHandle handle htype
+ writeHandle handle handle_
fail ioError
ClosedHandle -> do
- writeHandle handle htype
- ioe_closedHandle handle
- SemiClosedHandle _ _ -> do
- writeHandle handle htype
- ioe_closedHandle handle
- AppendHandle _ _ _ -> do
- writeHandle handle htype
- fail (IOError (Just handle) IllegalOperation
- "handle is not open for reading")
- WriteHandle _ _ _ -> do
- writeHandle handle htype
- fail (IOError (Just handle) IllegalOperation
- "handle is not open for reading")
- other -> return other
-
-wantWriteableHandle :: Handle
- -> IO Handle__
-wantWriteableHandle handle = do
- htype <- readHandle handle
- case htype of
+ writeHandle handle handle_
+ ioe_closedHandle fun handle
+ SemiClosedHandle -> do
+ writeHandle handle handle_
+ ioe_closedHandle fun handle
+ ReadHandle -> do
+ writeHandle handle handle_
+ fail not_writeable_error
+ other -> return handle_
+ where
+ not_writeable_error =
+ IOError (Just handle) IllegalOperation fun
+ ("handle is not open for writing")
+
+wantSeekableHandle :: String -> Handle -> IO Handle__
+wantSeekableHandle fun handle = do
+ handle_ <- readHandle handle
+ case haType__ handle_ of
ErrorHandle ioError -> do
- writeHandle handle htype
+ writeHandle handle handle_
fail ioError
ClosedHandle -> do
- writeHandle handle htype
- ioe_closedHandle handle
- SemiClosedHandle _ _ -> do
- writeHandle handle htype
- ioe_closedHandle handle
- ReadHandle _ _ _ -> do
- writeHandle handle htype
- fail (IOError (Just handle) IllegalOperation "handle is not open for writing")
- other -> return other
+ writeHandle handle handle_
+ ioe_closedHandle fun handle
+ SemiClosedHandle -> do
+ writeHandle handle handle_
+ ioe_closedHandle fun handle
+ AppendHandle -> do
+ writeHandle handle handle_
+ fail not_seekable_error
+ _ -> return handle_
+ where
+ not_seekable_error =
+ IOError (Just handle)
+ IllegalOperation fun
+ ("handle is not seekable")
\end{code}
+
+Internal function for creating an @IOError@ representing the
+access to a closed file.
+
+\begin{code}
+ioe_closedHandle :: String -> Handle -> IO a
+ioe_closedHandle fun h = fail (IOError (Just h) IllegalOperation fun "handle is closed")
+\end{code}
+
+Internal helper functions for Concurrent Haskell implementation
+of IO:
+
+\begin{code}
+#ifndef __PARALLEL_HASKELL__
+mayBlock :: ForeignObj -> IO Int -> IO Int
+#else
+mayBlock :: Addr -> IO Int -> IO Int
+#endif
+
+#ifndef __CONCURRENT_HASKELL__
+mayBlock _ act = act
+#else
+mayBlock fo act = do
+ rc <- act
+ case rc of
+ -5 -> do -- (possibly blocking) read
+ fd <- _ccall_ getFileFd fo
+ threadWaitRead fd
+ _ccall_ clearNonBlockingIOFlag__ fo -- force read to happen this time.
+ mayBlock fo act -- input available, re-try
+ -6 -> do -- (possibly blocking) write
+ fd <- _ccall_ getFileFd fo
+ threadWaitWrite fd
+ _ccall_ clearNonBlockingIOFlag__ fo -- force write to happen this time.
+ mayBlock fo act -- output possible
+ -7 -> do -- (possibly blocking) write on connected handle
+ fd <- _ccall_ getConnFileFd fo
+ threadWaitWrite fd
+ _ccall_ clearConnNonBlockingIOFlag__ fo -- force write to happen this time.
+ mayBlock fo act -- output possible
+ _ -> do
+ _ccall_ setNonBlockingIOFlag__ fo -- reset file object.
+ _ccall_ setConnNonBlockingIOFlag__ fo -- reset (connected) file object.
+ return rc
+
+#endif
+\end{code}
+
+
projects / ghc-hetmet.git / commitdiff