X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Flib%2Fstd%2FIO.lhs;h=4ce03d6fa4dc91889bc9dcf97a4d5fd37fa133dd;hb=a586da3a7156cd3aa32f0491ef42d7d1b5de4972;hp=6670ff3172218b7912c669052ce21f0b23553dac;hpb=b9bd8aedf924bd9396c2634792f5c472b36c3bf0;p=ghc-hetmet.git diff --git a/ghc/lib/std/IO.lhs b/ghc/lib/std/IO.lhs index 6670ff3..4ce03d6 100644 --- a/ghc/lib/std/IO.lhs +++ b/ghc/lib/std/IO.lhs @@ -8,9 +8,6 @@ Implementation of the standard Haskell IO interface, see definition. \begin{code} -{-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-} - -#ifndef BODY /* Hugs just includes this in PreludeBuiltin so no header needed */ module IO ( Handle, -- abstract, instance of: Eq, Show. HandlePosn(..), -- abstract, instance of: Eq, Show. @@ -84,565 +81,402 @@ module IO ( readIO, -- :: Read a => String -> IO a readLn, -- :: Read a => IO a - -- extensions - hPutBuf, -#ifndef __HUGS__ - hPutBufBA, -#endif - slurpFile - ) where -#ifdef __HUGS__ - -import PreludeBuiltin - -#else - ---import PrelST -import PrelBase - -import PrelIOBase -import PrelHandle -- much of the real stuff is in here - -import PrelRead ( readParen, Read(..), reads, lex, - readIO - ) ---import PrelNum ( toInteger ) -import PrelBounded () -- Bounded Int instance. -import PrelEither ( Either(..) ) -import PrelAddr ( Addr(..), nullAddr ) -import PrelArr ( ByteArray ) -import PrelPack ( unpackNBytesAccST ) -import PrelException ( ioError, catch ) - -#ifndef __PARALLEL_HASKELL__ -import PrelForeign ( ForeignObj ) -#endif - -import Char ( ord, chr ) - -#endif /* ndef __HUGS__ */ -#endif /* ndef BODY */ - -#ifndef HEAD - -#ifdef __HUGS__ -#define cat2(x,y) x/**/y -#define CCALL(fun) cat2(prim_,fun) -#define __CONCURRENT_HASKELL__ -#define stToIO id -#define unpackNBytesAccST primUnpackCStringAcc -#else -#define CCALL(fun) _ccall_ fun -#define ref_freeStdFileObject (``&freeStdFileObject''::Addr) -#define ref_freeFileObject (``&freeFileObject''::Addr) -#define const_BUFSIZ ``BUFSIZ'' -#endif - +#ifndef __HUGS__ +import PrelIOBase -- Together these four Prelude modules define +import PrelHandle -- all the stuff exported by IO for the GHC version +import PrelIO +import PrelException + + +-- The entire rest of this module is just Hugs + +#else /* ifndef __HUGS__ */ + +import Ix(Ix) +import PrelPrim ( IORef + , unsafePerformIO + , prelCleanupAfterRunAction + , copy_String_to_cstring + , primIntToChar + , primWriteCharOffAddr + , nullAddr + , newIORef + , writeIORef + , readIORef + , nh_close + , nh_errno + , nh_stdin + , nh_stdout + , nh_stderr + , nh_flush + , nh_open + , nh_free + , nh_read + , nh_write + , nh_filesize + , nh_iseof + ) \end{code} -Standard instances for @Handle@: - -\begin{code} -instance Eq IOError where - (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 - ---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 - --- Type declared in IOBase, instance here because it --- depends on PrelRead.(Read Maybe) instance. -instance Read BufferMode where - readsPrec _ = - readParen False - (\r -> let lr = lex r - in - [(NoBuffering, rest) | ("NoBuffering", rest) <- lr] ++ - [(LineBuffering,rest) | ("LineBuffering",rest) <- lr] ++ - [(BlockBuffering mb,rest2) | ("BlockBuffering",rest1) <- lr, - (mb, rest2) <- reads rest1]) - -\end{code} %********************************************************* %* * -\subsection{Simple input operations} +\subsection{The HUGS version of IO %* * %********************************************************* -Computation @hReady hdl@ indicates whether at least -one item is available for input from handle {\em hdl}. - -@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 h = hWaitForInput h 0 - -hWaitForInput :: Handle -> Int -> IO Bool -hWaitForInput handle msecs = - wantReadableHandle "hWaitForInput" handle $ \ handle_ -> do - rc <- CCALL(inputReady) (haFO__ handle_) (msecs::Int) -- ConcHask: SAFE, won't block - writeHandle handle handle_ - case (rc::Int) of - 0 -> return False - 1 -> return True - _ -> constructErrorAndFail "hWaitForInput" -\end{code} - -@hGetChar hdl@ reads the next character from handle @hdl@, -blocking until a character is available. - \begin{code} -hGetChar :: Handle -> IO Char -hGetChar handle = - wantReadableHandle "hGetChar" handle $ \ handle_ -> do - let fo = haFO__ handle_ - intc <- mayBlock fo (CCALL(fileGetc) fo) -- ConcHask: UNSAFE, may block - writeHandle handle handle_ - if intc /= ((-1)::Int) - 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) - -\end{code} - -@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 = do - wantReadableHandle "hLookAhead" handle $ \ handle_ -> do - 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" - -\end{code} +import Ix(Ix) +import Monad(when) + +unimp :: String -> a +unimp s = error ("IO library: function not implemented: " ++ s) + +type FILE_STAR = Addr +type Ptr = Addr +nULL = nullAddr + +data Handle + = Handle { name :: FilePath, + file :: FILE_STAR, -- C handle + mut :: IORef Handle_Mut, -- open/closed/semiclosed + mode :: IOMode, + seekable :: Bool + } + +data Handle_Mut + = Handle_Mut { state :: HState + } + deriving Show + +set_state :: Handle -> HState -> IO () +set_state hdl new_state + = writeIORef (mut hdl) (Handle_Mut { state = new_state }) +get_state :: Handle -> IO HState +get_state hdl + = readIORef (mut hdl) >>= \m -> return (state m) + +mkErr :: Handle -> String -> IO a +mkErr h msg + = do mut <- readIORef (mut h) + when (state mut /= HClosed) + (nh_close (file h) >> set_state h HClosed) + dummy <- nh_errno + ioError (IOError msg) + +stdin + = Handle { + name = "stdin", + file = unsafePerformIO nh_stdin, + mut = unsafePerformIO (newIORef (Handle_Mut { state = HOpen })), + mode = ReadMode + } + +stdout + = Handle { + name = "stdout", + file = unsafePerformIO nh_stdout, + mut = unsafePerformIO (newIORef (Handle_Mut { state = HOpen })), + mode = WriteMode + } + +stderr + = Handle { + name = "stderr", + file = unsafePerformIO nh_stderr, + mut = unsafePerformIO (newIORef (Handle_Mut { state = HOpen })), + mode = WriteMode + } -%********************************************************* -%* * -\subsection{Getting the entire contents of a handle} -%* * -%********************************************************* - -@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. +instance Eq Handle where + h1 == h2 = file h1 == file h2 + +instance Show Handle where + showsPrec _ h = showString ("`" ++ name h ++ "'") + +data HandlePosn + = HandlePosn + deriving (Eq, Show) + + +data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode + deriving (Eq, Ord, Ix, Bounded, Enum, Read, Show) + +data BufferMode = NoBuffering | LineBuffering + | BlockBuffering (Maybe Int) + deriving (Eq, Ord, Read, Show) + +data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd + deriving (Eq, Ord, Ix, Bounded, Enum, Read, Show) + +data HState = HOpen | HSemiClosed | HClosed + deriving (Show, Eq) + + +-- A global variable holding a list of all open handles. +-- Each handle is present as many times as it has been opened. +-- Any given file is allowed to have _either_ one writeable handle +-- or many readable handles in this list. The list is used to +-- enforce single-writer multiple reader semantics. It also +-- provides a list of handles for System.exitWith to flush and +-- close. In order not to have to put all this stuff in the +-- Prelude, System.exitWith merely runs prelExitWithAction, +-- which is originally Nothing, but which we set to Just ... +-- once handles appear in the list. + +allHandles :: IORef [Handle] +allHandles = unsafePerformIO (newIORef []) + +elemWriterHandles :: FilePath -> IO Bool +elemAllHandles :: FilePath -> IO Bool +addHandle :: Handle -> IO () +delHandle :: Handle -> IO () +cleanupHandles :: IO () + +cleanupHandles + = do hdls <- readIORef allHandles + mapM_ cleanupHandle hdls + where + cleanupHandle h + | mode h == ReadMode + = nh_close (file h) + >> nh_errno >>= \_ -> return () + | otherwise + = nh_flush (file h) >> nh_close (file h) + >> nh_errno >>= \_ -> return () + +elemWriterHandles fname + = do hdls <- readIORef allHandles + let hdls_w = filter ((/= ReadMode).mode) hdls + return (fname `elem` (map name hdls_w)) + +elemAllHandles fname + = do hdls <- readIORef allHandles + return (fname `elem` (map name hdls)) + +addHandle hdl + = do cleanup_action <- readIORef prelCleanupAfterRunAction + case cleanup_action of + Nothing + -> writeIORef prelCleanupAfterRunAction (Just cleanupHandles) + Just xx + -> return () + hdls <- readIORef allHandles + writeIORef allHandles (hdl : hdls) + +delHandle hdl + = do hdls <- readIORef allHandles + let hdls' = takeWhile (/= hdl) hdls + ++ drop 1 (dropWhile (/= hdl) hdls) + writeIORef allHandles hdls' + + + +openFile :: FilePath -> IOMode -> IO Handle +openFile f mode + + | null f + = (ioError.IOError) "openFile: empty file name" + + | mode == ReadMode + = do not_ok <- elemWriterHandles f + if not_ok + then (ioError.IOError) + ("openFile: `" ++ f ++ "' in " ++ show mode + ++ ": is already open for writing") + else openFile_main f mode + + | mode /= ReadMode + = do not_ok <- elemAllHandles f + if not_ok + then (ioError.IOError) + ("openFile: `" ++ f ++ "' in " ++ show mode + ++ ": is already open for reading or writing") + else openFile_main f mode + + | otherwise + = openFile_main f mode + +openFile_main f mode + = copy_String_to_cstring f >>= \nameptr -> + nh_open nameptr (mode2num mode) >>= \fh -> + nh_free nameptr >> + if fh == nULL + then (ioError.IOError) + ("openFile: can't open <<" ++ f ++ ">> in " ++ show mode) + else do r <- newIORef (Handle_Mut { state = HOpen }) + let hdl = Handle { name = f, file = fh, + mut = r, mode = mode } + addHandle hdl + return hdl + where + mode2num :: IOMode -> Int + mode2num ReadMode = 0 + mode2num WriteMode = 1 + mode2num AppendMode = 2 + mode2num ReadWriteMode + = error + ("openFile <<" ++ f ++ ">>: ReadWriteMode not supported") + +hClose :: Handle -> IO () +hClose h + = do mut <- readIORef (mut h) + if state mut == HClosed + then mkErr h + ("hClose on closed handle " ++ show h) + else + do set_state h HClosed + delHandle h + nh_close (file h) + err <- nh_errno + if err == 0 + then return () + else mkErr h + ("hClose: error closing " ++ name h) -\begin{code} hGetContents :: Handle -> IO String -hGetContents handle = - wantReadableHandle "hGetContents" handle $ \ handle_ -> do - {- - To avoid introducing an extra layer of buffering here, - we provide three lazy read methods, based on character, - line, and block buffering. - -} - 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 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} -#ifndef __PARALLEL_HASKELL__ -lazyReadBlock :: Handle -> ForeignObj -> IO String -lazyReadLine :: Handle -> ForeignObj -> IO String -lazyReadChar :: Handle -> ForeignObj -> IO String -#else -lazyReadBlock :: Handle -> Addr -> IO String -lazyReadLine :: Handle -> Addr -> IO String -lazyReadChar :: Handle -> Addr -> IO String -#endif - -lazyReadBlock handle fo = do - buf <- CCALL(getBufStart) fo (0::Int) - bytes <- mayBlock fo (CCALL(readBlock) fo) -- ConcHask: UNSAFE, may block. - case (bytes::Int) of - -3 -> -- buffering has been turned off, use lazyReadChar instead - lazyReadChar handle fo - -2 -> return "" - -1 -> -- an error occurred, close the handle - withHandle handle $ \ handle_ -> do - CCALL(closeFile) (haFO__ handle_) (0::Int){-don't bother flushing-} -- ConcHask: SAFE, won't block. - writeHandle handle (handle_ { haType__ = ClosedHandle, - haFO__ = nullFile__ }) - return "" - _ -> 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::Int) of - -3 -> -- buffering has been turned off, use lazyReadChar instead - lazyReadChar handle fo - -2 -> return "" -- handle closed by someone else, stop reading. - -1 -> -- an error occurred, close the handle - withHandle handle $ \ handle_ -> do - CCALL(closeFile) (haFO__ handle_) (0::Int){- 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::Int) 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 -> -- error, silently close handle. - withHandle handle $ \ handle_ -> do - CCALL(closeFile) (haFO__ handle_) (0::Int){-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} - - -%********************************************************* -%* * -\subsection{Simple output functions} -%* * -%********************************************************* - -@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 c = - wantWriteableHandle "hPutChar" handle $ \ handle_ -> do - let fo = haFO__ handle_ - flushConnectedBuf fo - rc <- mayBlock fo (CCALL(filePutc) fo c) -- ConcHask: UNSAFE, may block. - writeHandle handle handle_ - if rc == 0 - then return () - else constructErrorAndFail "hPutChar" - -\end{code} - -@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 str = - wantWriteableHandle "hPutStr" handle $ \ handle_ -> do - let fo = haFO__ handle_ - flushConnectedBuf fo - 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_ - -\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} -#ifdef __HUGS__ - -#ifdef __CONCURRENT_HASKELL__ -/* See comment in shoveString below for explanation */ -#warning delayed update of buffer disnae work with killThread -#endif - -#ifndef __PARALLEL_HASKELL__ -writeLines :: ForeignObj -> Addr -> Int -> Int -> String -> IO () -#else -writeLines :: Addr -> Addr -> Int -> Int -> String -> IO () -#endif -writeLines obj buf bufLen initPos s = - let - 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 n - - (x:xs) -> do - primWriteCharOffAddr buf n x - {- Flushing on buffer exhaustion or newlines (even if it isn't the last one) -} - if n == bufLen || x == '\n' - then do - rc <- mayBlock obj (CCALL(writeFileObject) obj (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 -#else /* ndef __HUGS__ */ -#ifndef __PARALLEL_HASKELL__ -writeLines :: ForeignObj -> Addr -> Int -> Int -> String -> IO () -#else -writeLines :: Addr -> Addr -> Int -> Int -> String -> IO () -#endif -writeLines obj buf (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# -> (# 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" +hGetContents h + | mode h /= ReadMode + = mkErr h ("hGetContents on non-ReadMode handle " ++ show h) + | otherwise + = do mut <- readIORef (mut h) + if state mut /= HOpen + then mkErr h + ("hGetContents on closed/semiclosed handle " ++ show h) else - shoveString (n +# 1#) xs - in - shoveString initPos# s -#endif /* ndef __HUGS__ */ - -#ifdef __HUGS__ -#ifndef __PARALLEL_HASKELL__ -writeBlocks :: ForeignObj -> Addr -> Int -> Int -> String -> IO () -#else -writeBlocks :: Addr -> Addr -> Int -> Int -> String -> IO () -#endif -writeBlocks obj buf bufLen initPos s = - let - 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. 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 n - - (x:xs) -> do - primWriteCharOffAddr buf n x - if n == bufLen - then do - rc <- mayBlock obj (CCALL(writeFileObject) obj (n + 1)) -- ConcHask: UNSAFE, may block. - if rc == 0 - then shoveString 0 xs - else constructErrorAndFail "writeChunks" - else - shoveString (n + 1) xs - in - shoveString initPos s -#else /* ndef __HUGS__ */ -#ifndef __PARALLEL_HASKELL__ -writeBlocks :: ForeignObj -> Addr -> Int -> Int -> String -> IO () -#else -writeBlocks :: Addr -> Addr -> Int -> Int -> String -> IO () -#endif -writeBlocks obj buf (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# -> (# 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. 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 buf n x - if n ==# bufLen - then do - rc <- mayBlock obj (CCALL(writeFileObject) obj (I# (n +# 1#))) -- ConcHask: UNSAFE, may block. - if rc == 0 - then shoveString 0# xs - else constructErrorAndFail "writeChunks" - else - shoveString (n +# 1#) xs - in - shoveString initPos# s -#endif /* ndef __HUGS__ */ - -#ifndef __PARALLEL_HASKELL__ -writeChars :: ForeignObj -> String -> IO () -#else -writeChars :: Addr -> String -> IO () -#endif -writeChars _fo "" = return () -writeChars fo (c:cs) = do - rc <- mayBlock fo (CCALL(filePutc) fo c) -- ConcHask: UNSAFE, may block. - if rc == 0 - then writeChars fo cs - else constructErrorAndFail "writeChars" - -\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 -hdl}. - -[ Seem to have disappeared from the 1.4 interface - SOF 2/97 ] - -\begin{code} -hPrint :: Show a => Handle -> a -> IO () -hPrint hdl = hPutStrLn hdl . show -\end{code} - -Derived action @hPutStrLn hdl str@ writes the string \tr{str} to -the handle \tr{hdl}, adding a newline at the end. - -\begin{code} -hPutStrLn :: Handle -> String -> IO () -hPutStrLn hndl str = do - hPutStr hndl str - hPutChar hndl '\n' - -\end{code} + do set_state h HSemiClosed + read_all (file h) + where + read_all f + = nh_read f >>= \ci -> + if ci == -1 + then return [] + else read_all f >>= \rest -> + return ((primIntToChar ci):rest) - -%********************************************************* -%* * -\subsection{Try and bracket} -%* * -%********************************************************* - -The construct @try comp@ exposes errors which occur within a -computation, and which are not fully handled. It always succeeds. - -\begin{code} -try :: IO a -> IO (Either IOError a) -try f = catch (do r <- f - return (Right r)) - (return . Left) +hPutStr :: Handle -> String -> IO () +hPutStr h s + | mode h == ReadMode + = mkErr h ("hPutStr on ReadMode handle " ++ show h) + | otherwise + = do mut <- readIORef (mut h) + if state mut /= HOpen + then mkErr h + ("hPutStr on closed/semiclosed handle " ++ show h) + else write_all (file h) s + where + write_all f [] + = return () + write_all f (c:cs) + = nh_write f c >> write_all f cs + +hFileSize :: Handle -> IO Integer +hFileSize h + = do sz <- nh_filesize (file h) + er <- nh_errno + if er == 0 + then return (fromIntegral sz) + else mkErr h ("hFileSize on " ++ show h) + +hIsEOF :: Handle -> IO Bool +hIsEOF h + = do iseof <- nh_iseof (file h) + er <- nh_errno + if er == 0 + then return (iseof /= 0) + else mkErr h ("hIsEOF on " ++ show h) + +isEOF :: IO Bool +isEOF = hIsEOF stdin + +hSetBuffering :: Handle -> BufferMode -> IO () +hSetBuffering = unimp "IO.hSetBuffering" +hGetBuffering :: Handle -> IO BufferMode +hGetBuffering = unimp "IO.hGetBuffering" + +hFlush :: Handle -> IO () +hFlush h + = do mut <- readIORef (mut h) + if state mut /= HOpen + then mkErr h + ("hFlush on closed/semiclosed file " ++ name h) + else nh_flush (file h) + +hGetPosn :: Handle -> IO HandlePosn +hGetPosn = unimp "IO.hGetPosn" +hSetPosn :: HandlePosn -> IO () +hSetPosn = unimp "IO.hSetPosn" +hSeek :: Handle -> SeekMode -> Integer -> IO () +hSeek = unimp "IO.hSeek" +hWaitForInput :: Handle -> Int -> IO Bool +hWaitForInput = unimp "hWaitForInput" +hReady :: Handle -> IO Bool +hReady h = unimp "hReady" -- hWaitForInput h 0 + +hGetChar :: Handle -> IO Char +hGetChar h + = nh_read (file h) >>= \ci -> + return (primIntToChar ci) + +hGetLine :: Handle -> IO String +hGetLine h = do c <- hGetChar h + if c=='\n' then return "" + else do cs <- hGetLine h + return (c:cs) + +hLookAhead :: Handle -> IO Char +hLookAhead = unimp "IO.hLookAhead" + + +hPutChar :: Handle -> Char -> IO () +hPutChar h c = hPutStr h [c] + +hPutStrLn :: Handle -> String -> IO () +hPutStrLn h s = do { hPutStr h s; hPutChar h '\n' } + +hPrint :: Show a => Handle -> a -> IO () +hPrint h = hPutStrLn h . show + +hIsOpen, hIsClosed, hIsReadable, hIsWritable :: Handle -> IO Bool +hIsOpen h = do { s <- get_state h; return (s == HOpen) } +hIsClosed h = do { s <- get_state h; return (s == HClosed) } +hIsReadable h = return (mode h == ReadMode) +hIsWritable h = return (mode h `elem` [WriteMode, AppendMode]) + +hIsSeekable :: Handle -> IO Bool +hIsSeekable = unimp "IO.hIsSeekable" + +isIllegalOperation, + isAlreadyExistsError, + isDoesNotExistError, + isAlreadyInUseError, + isFullError, + isEOFError, + isPermissionError, + isUserError :: IOError -> Bool + +isIllegalOperation = unimp "IO.isIllegalOperation" +isAlreadyExistsError = unimp "IO.isAlreadyExistsError" +isDoesNotExistError = unimp "IO.isDoesNotExistError" +isAlreadyInUseError = unimp "IO.isAlreadyInUseError" +isFullError = unimp "IO.isFullError" +isEOFError = unimp "IO.isEOFError" +isPermissionError = unimp "IO.isPermissionError" +isUserError = unimp "IO.isUserError" + + +ioeGetErrorString :: IOError -> String +ioeGetErrorString = unimp "IO.ioeGetErrorString" +ioeGetHandle :: IOError -> Maybe Handle +ioeGetHandle = unimp "IO.ioeGetHandle" +ioeGetFileName :: IOError -> Maybe FilePath +ioeGetFileName = unimp "IO.ioeGetFileName" + +try :: IO a -> IO (Either IOError a) +try p = catch (p >>= (return . Right)) (return . Left) bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c bracket before after m = do @@ -662,65 +496,9 @@ bracket_ before after m = do case rs of Right r -> return r Left e -> ioError e -\end{code} - -%********************************************************* -%* * -\subsection{Standard IO} -%* * -%********************************************************* - -The Prelude has from Day 1 provided a collection of common -IO functions. We define these here, but let the Prelude -export them. - -\begin{code} -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 - -#endif /* ndef HEAD */ +-- TODO: Hugs/slurpFile +slurpFile = unimp "IO.slurpFile" \end{code} + +#endif /* #ifndef __HUGS__ */