X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FIO.lhs;h=ad656a5f8b9949cca7d74911c459daf90794b5c6;hb=f608faec774d5d2cd895240c1e0e66a48aa6cbe3;hp=5c8c9fb0b126a224229a386c67df9da768fb056f;hpb=c48ad065803b3766767713cb3866893713dade2b;p=ghc-hetmet.git diff --git a/ghc/lib/std/IO.lhs b/ghc/lib/std/IO.lhs index 5c8c9fb..ad656a5 100644 --- a/ghc/lib/std/IO.lhs +++ b/ghc/lib/std/IO.lhs @@ -62,6 +62,14 @@ module IO ( -- Non-standard extension (but will hopefully become standard with 1.5) is -- to export the Prelude io functions via IO (in addition to exporting them -- from the prelude...for now.) + IO, + FilePath, -- :: String + IOError, + ioError, -- :: IOError -> IO a + userError, -- :: String -> IOError + catch, -- :: IO a -> (IOError -> IO a) -> IO a + interact, -- :: (String -> String) -> IO () + putChar, -- :: Char -> IO () putStr, -- :: String -> IO () putStrLn, -- :: String -> IO () @@ -69,27 +77,25 @@ module IO ( getChar, -- :: IO Char getLine, -- :: IO String getContents, -- :: IO String - interact, -- :: (String -> String) -> IO () readFile, -- :: FilePath -> IO String writeFile, -- :: FilePath -> String -> IO () appendFile, -- :: FilePath -> String -> IO () readIO, -- :: Read a => String -> IO a readLn, -- :: Read a => IO a - FilePath, -- :: String - fail, -- :: IOError -> IO a - catch, -- :: IO a -> (IOError -> IO a) -> IO a - userError, -- :: String -> IOError - - IO, -- non-standard, amazingly enough. - IOError, -- ditto +#ifndef __HUGS__ -- extensions hPutBuf, hPutBufBA, +#endif slurpFile ) where +#ifdef __HUGS__ +import Ix(Ix) +#else +--import PrelST import PrelBase import PrelIOBase @@ -98,12 +104,12 @@ 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 PrelShow +import PrelMaybe ( Either(..), Maybe(..) ) import PrelAddr ( Addr(..), nullAddr ) import PrelArr ( ByteArray ) import PrelPack ( unpackNBytesAccST ) +import PrelException ( ioError, catch ) #ifndef __PARALLEL_HASKELL__ import PrelForeign ( ForeignObj ) @@ -111,8 +117,11 @@ import PrelForeign ( ForeignObj ) import Char ( ord, chr ) +#endif /* ndef __HUGS__ */ \end{code} +#ifndef __HUGS__ + Standard instances for @Handle@: \begin{code} @@ -130,7 +139,7 @@ instance Eq HandlePosn where -- Type declared in IOBase, instance here because it -- depends on PrelRead.(Read Maybe) instance. instance Read BufferMode where - readsPrec p = + readsPrec _ = readParen False (\r -> let lr = lex r in @@ -163,11 +172,10 @@ hReady :: Handle -> IO Bool hReady h = hWaitForInput h 0 hWaitForInput :: Handle -> Int -> IO Bool -hWaitForInput handle msecs = do - handle_ <- wantReadableHandle "hWaitForInput" handle - rc <- _ccall_ inputReady (haFO__ handle_) (msecs::Int) -- ConcHask: SAFE, won't block - writeHandle handle handle_ - case rc of +hWaitForInput handle msecs = + wantReadableHandle "hWaitForInput" handle $ \ handle_ -> do + rc <- inputReady (haFO__ handle_) (msecs::Int) -- ConcHask: SAFE, won't block + case (rc::Int) of 0 -> return False 1 -> return True _ -> constructErrorAndFail "hWaitForInput" @@ -178,23 +186,42 @@ blocking until a character is available. \begin{code} hGetChar :: Handle -> IO Char -hGetChar handle = do - handle_ <- wantReadableHandle "hGetChar" handle +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) + intc <- mayBlock fo (fileGetc fo) -- ConcHask: UNSAFE, may block + if intc /= ((-1)::Int) then return (chr intc) else constructErrorAndFail "hGetChar" +{- + If EOF is reached before EOL is encountered, ignore the + EOF and return the partial line. Next attempt at calling + hGetLine on the handle will yield an EOF IO exception though. +-} hGetLine :: Handle -> IO String hGetLine h = do c <- hGetChar h - if c == '\n' - then return "" + if c == '\n' then + return "" else do - s <- hGetLine h - return (c:s) + l <- getRest + return (c:l) + where + getRest = do + c <- + catch + (hGetChar h) + (\ err -> do + if isEOFError err then + return '\n' + else + ioError err) + if c == '\n' then + return "" + else do + s <- getRest + return (c:s) \end{code} @@ -204,11 +231,10 @@ character is available. \begin{code} hLookAhead :: Handle -> IO Char -hLookAhead handle = do - handle_ <- wantReadableHandle "hLookAhead" handle +hLookAhead handle = + wantReadableHandle "hLookAhead" handle $ \ handle_ -> do let fo = haFO__ handle_ - intc <- mayBlock fo (_ccall_ fileLookAhead fo) -- ConcHask: UNSAFE, may block - writeHandle handle handle_ + intc <- mayBlock fo (fileLookAhead fo) -- ConcHask: UNSAFE, may block if intc /= (-1) then return (chr intc) else constructErrorAndFail "hLookAhead" @@ -228,19 +254,37 @@ which is made semi-closed. \begin{code} hGetContents :: Handle -> IO String -hGetContents handle = do - 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. - -} - 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_)) - +hGetContents handle = + -- can't use wantReadableHandle here, because we want to side effect + -- the handle. + withHandle handle $ \ handle_ -> do + case haType__ handle_ of + ErrorHandle theError -> ioError theError + ClosedHandle -> ioe_closedHandle "hGetContents" handle + SemiClosedHandle -> ioe_closedHandle "hGetContents" handle + AppendHandle -> ioError not_readable_error + WriteHandle -> ioError not_readable_error + _ -> do + {- + To avoid introducing an extra layer of buffering here, + we provide three lazy read methods, based on character, + line, and block buffering. + -} + let handle_' = handle_{ haType__ = SemiClosedHandle } + case (haBufferMode__ handle_) of + LineBuffering -> do + str <- unsafeInterleaveIO (lazyReadLine handle (haFO__ handle_)) + return (handle_', str) + BlockBuffering _ -> do + str <- unsafeInterleaveIO (lazyReadBlock handle (haFO__ handle_)) + return (handle_', str) + NoBuffering -> do + str <- unsafeInterleaveIO (lazyReadChar handle (haFO__ handle_)) + return (handle_', str) + where + not_readable_error = + IOError (Just handle) IllegalOperation "hGetContents" + ("handle is not open for reading") \end{code} Note that someone may close the semi-closed handle (or change its buffering), @@ -259,54 +303,54 @@ 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 of + buf <- getBufStart fo 0 + bytes <- mayBlock fo (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 -> 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 "" + -1 -> -- an error occurred, close the handle + withHandle handle $ \ handle_ -> do + closeFile (haFO__ handle_) 0{-don't bother flushing-} -- ConcHask: SAFE, won't block. + return (handle_ { haType__ = ClosedHandle, + haFO__ = nullFile__ }, + "") _ -> 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 + bytes <- mayBlock fo (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 -> 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 "" + -1 -> -- an error occurred, close the handle + withHandle handle $ \ handle_ -> do + closeFile (haFO__ handle_) 0{- don't bother flushing-} -- ConcHask: SAFE, won't block + return (handle_ { haType__ = ClosedHandle, + haFO__ = nullFile__ }, + "") _ -> do more <- unsafeInterleaveIO (lazyReadLine handle fo) - buf <- _ccall_ getBufStart fo bytes -- ConcHask: won't block + buf <- 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 + char <- mayBlock fo (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 -> 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 "" + -1 -> -- error, silently close handle. + withHandle handle $ \ handle_ -> do + closeFile (haFO__ handle_) 0{-don't bother flusing-} -- ConcHask: SAFE, won't block + return (handle_{ haType__ = ClosedHandle, + haFO__ = nullFile__ }, + "") _ -> do more <- unsafeInterleaveIO (lazyReadChar handle fo) return (chr char : more) @@ -326,11 +370,11 @@ buffering is enabled for @hdl@ \begin{code} hPutChar :: Handle -> Char -> IO () -hPutChar handle c = do - handle_ <- wantWriteableHandle "hPutChar" handle +hPutChar handle c = + wantWriteableHandle "hPutChar" handle $ \ handle_ -> do let fo = haFO__ handle_ - rc <- mayBlock fo (_ccall_ filePutc fo c) -- ConcHask: UNSAFE, may block. - writeHandle handle handle_ + flushConnectedBuf fo + rc <- mayBlock fo (filePutc fo c) -- ConcHask: UNSAFE, may block. if rc == 0 then return () else constructErrorAndFail "hPutChar" @@ -342,24 +386,23 @@ channel managed by @hdl@, buffering the output if needs be. \begin{code} hPutStr :: Handle -> String -> IO () -hPutStr handle str = do - handle_ <- wantWriteableHandle "hPutStr" handle +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 + buf <- getWriteableBuf fo + pos <- getBufWPtr fo + bsz <- getBufSize fo writeLines fo buf bsz pos str BlockBuffering _ -> do - buf <- _ccall_ getWriteableBuf fo - pos <- _ccall_ getBufWPtr fo - bsz <- _ccall_ getBufSize fo + buf <- getWriteableBuf fo + pos <- getBufWPtr fo + bsz <- 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, @@ -367,25 +410,74 @@ 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 + setBufWPtr obj 0{-new pos-} + 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. + + -} + 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 (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 bf@(I# bufLen) (I# initPos#) s = +writeLines obj buf (I# bufLen) (I# initPos#) s = let write_char :: Addr -> Int# -> Char# -> IO () - write_char (A# buf) n# c# = + write_char (A# buf#) n# c# = IO $ \ s# -> - case (writeCharOffAddr# buf n# c# s#) of s2# -> IOok s2# () + 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) + setBufWPtr obj 0 else do {- At the end of a buffer write, update the buffer position @@ -400,14 +492,14 @@ writeLines obj buf bf@(I# bufLen) (I# initPos#) s = that killing of threads is supported at the moment. -} - _ccall_ setBufWPtr obj (I# n) + 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. + rc <- mayBlock obj (writeFileObject obj (I# (n +# 1#))) -- ConcHask: UNSAFE, may block. if rc == 0 then shoveString 0# xs else constructErrorAndFail "writeLines" @@ -415,25 +507,71 @@ writeLines obj buf bf@(I# bufLen) (I# initPos#) s = 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 + 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. + -} + setBufWPtr obj n + + (x:xs) -> do + primWriteCharOffAddr buf n x + if n == bufLen + then do + rc <- mayBlock obj (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 bf@(I# bufLen) (I# initPos#) s = +writeBlocks obj buf (I# bufLen) (I# initPos#) s = let write_char :: Addr -> Int# -> Char# -> IO () - write_char (A# buf) n# c# = + write_char (A# buf#) n# c# = IO $ \ s# -> - case (writeCharOffAddr# buf n# c# s#) of s2# -> IOok s2# () + 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) + setBufWPtr obj (0::Int) else do {- At the end of a buffer write, update the buffer position @@ -450,13 +588,13 @@ writeBlocks obj buf bf@(I# bufLen) (I# initPos#) s = alltogether. -} - _ccall_ setBufWPtr obj (I# n) + 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. + rc <- mayBlock obj (writeFileObject obj (I# (n +# 1#))) -- ConcHask: UNSAFE, may block. if rc == 0 then shoveString 0# xs else constructErrorAndFail "writeChunks" @@ -464,15 +602,16 @@ writeBlocks obj buf bf@(I# bufLen) (I# initPos#) s = 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 "" = return () writeChars fo (c:cs) = do - rc <- mayBlock fo (_ccall_ filePutc fo c) -- ConcHask: UNSAFE, may block. + rc <- mayBlock fo (filePutc fo c) -- ConcHask: UNSAFE, may block. if rc == 0 then writeChars fo cs else constructErrorAndFail "writeChars" @@ -487,7 +626,7 @@ hdl}. \begin{code} hPrint :: Show a => Handle -> a -> IO () -hPrint hdl = hPutStr hdl . show +hPrint hdl = hPutStrLn hdl . show \end{code} Derived action @hPutStrLn hdl str@ writes the string \tr{str} to @@ -524,7 +663,7 @@ bracket before after m = do after x case rs of Right r -> return r - Left e -> fail e + Left e -> ioError e -- variant of the above where middle computation doesn't want x bracket_ :: IO a -> (a -> IO b) -> IO c -> IO c @@ -534,7 +673,7 @@ bracket_ before after m = do after x case rs of Right r -> return r - Left e -> fail e + Left e -> ioError e \end{code} %********************************************************* @@ -593,4 +732,222 @@ readLn :: Read a => IO a readLn = do l <- getLine r <- readIO l return r + + +\end{code} + +#else +\begin{code} +unimp :: String -> a +unimp s = error ("function not implemented: " ++ s) + +type FILE_STAR = Int +type Ptr = Int +nULL = 0 :: Int + +data Handle + = Handle { name :: FilePath, + file :: FILE_STAR, -- C handle + state :: HState, -- open/closed/semiclosed + mode :: IOMode, + --seekable :: Bool, + bmode :: BufferMode, + buff :: Ptr, + buffSize :: Int + } + +instance Eq Handle where + h1 == h2 = file h1 == file h2 + +instance Show Handle where + showsPrec _ h = showString ("<>") + +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 + deriving (Eq, Ord, Read, Show) + +data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd + deriving (Eq, Ord, Ix, Bounded, Enum, Read, Show) + +data HState = HOpen | HSemiClosed | HClosed + deriving Eq + +stdin = Handle "stdin" (primRunST nh_stdin) HOpen ReadMode NoBuffering nULL 0 +stdout = Handle "stdout" (primRunST nh_stdout) HOpen WriteMode LineBuffering nULL 0 +stderr = Handle "stderr" (primRunST nh_stderr) HOpen WriteMode NoBuffering nULL 0 + +openFile :: FilePath -> IOMode -> IO Handle +openFile 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 return (Handle f fh HOpen mode BlockBuffering nULL 0) + where + mode2num :: IOMode -> Int + mode2num ReadMode = 0 + mode2num WriteMode = 1 + mode2num AppendMode = 2 + +hClose :: Handle -> IO () +hClose h + | not (state h == HOpen) + = (ioError.IOError) ("hClose on non-open handle " ++ show h) + | otherwise + = nh_close (file h) >> + nh_errno >>= \err -> + if err == 0 + then return () + else (ioError.IOError) ("hClose: error closing " ++ name h) + +hFileSize :: Handle -> IO Integer +hFileSize = unimp "IO.hFileSize" +hIsEOF :: Handle -> IO Bool +hIsEOF = unimp "IO.hIsEOF" +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 + = if state h /= HOpen + then (ioError.IOError) ("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 = 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" + +hGetContents :: Handle -> IO String +hGetContents h + | not (state h == HOpen && mode h == ReadMode) + = (ioError.IOError) ("hGetContents on invalid handle " ++ show h) + | otherwise + = read_all (file h) + where + read_all f + = unsafeInterleaveIO ( + nh_read f >>= \ci -> + if ci == -1 + then hClose h >> return [] + else read_all f >>= \rest -> + return ((primIntToChar ci):rest) + ) + +hPutStr :: Handle -> String -> IO () +hPutStr h s + | not (state h == HOpen && mode h /= ReadMode) + = (ioError.IOError) ("hPutStr on invalid handle " ++ show h) + | otherwise + = write_all (file h) s + where + write_all f [] + = return () + write_all f (c:cs) + = nh_write f (primCharToInt c) >> + write_all f cs + +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 = return (state h == HOpen) +hIsClosed h = return (state h == HClosed) +hIsReadable h = return (mode h == ReadMode) +hIsWritable h = return (mode h == WriteMode) + +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 "ioeGetErrorString" +ioeGetHandle :: IOError -> Maybe Handle +ioeGetHandle = unimp "ioeGetHandle" +ioeGetFileName :: IOError -> Maybe FilePath +ioeGetFileName = unimp "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 + x <- before + rs <- try (m x) + after x + case rs of + Right r -> return r + Left e -> ioError e + +-- variant of the above where middle computation doesn't want x +bracket_ :: IO a -> (a -> IO b) -> IO c -> IO c +bracket_ before after m = do + x <- before + rs <- try m + after x + case rs of + Right r -> return r + Left e -> ioError e + +-- TODO: Hugs/slurbFile +slurpFile = unimp "slurpFile" \end{code} +#endif