-- 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 ()
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
-- extensions
hPutBuf,
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 ( fail, catch )
+import PrelException ( ioError, catch )
#ifndef __PARALLEL_HASKELL__
import PrelForeign ( ForeignObj )
#ifndef HEAD
#ifdef __HUGS__
-#define cat2(x,y) x/**/y
+#define cat2(x,y) x##y
#define CCALL(fun) cat2(prim_,fun)
#define __CONCURRENT_HASKELL__
#define stToIO id
-- 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
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 of
+ case (rc::Int) of
0 -> return False
1 -> return True
_ -> constructErrorAndFail "hWaitForInput"
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)
+ 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}
\begin{code}
hLookAhead :: Handle -> IO Char
-hLookAhead handle = do
+hLookAhead handle =
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"
\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_))
-
+ -- 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),
lazyReadBlock handle fo = do
buf <- CCALL(getBufStart) fo (0::Int)
bytes <- mayBlock fo (CCALL(readBlock) fo) -- ConcHask: UNSAFE, may block.
- case bytes of
+ 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{-don't bother flushing-} -- ConcHask: SAFE, won't block.
- writeHandle handle (handle_ { haType__ = ClosedHandle,
- haFO__ = nullFile__ })
- return ""
+ CCALL(closeFile) (haFO__ handle_) (0::Int){-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
+ 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{- don't bother flushing-} -- ConcHask: SAFE, won't block
- writeHandle handle (handle_ { haType__ = ClosedHandle,
- haFO__ = nullFile__ })
- return ""
+ CCALL(closeFile) (haFO__ handle_) (0::Int){- 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
lazyReadChar handle fo = do
char <- mayBlock fo (CCALL(readChar) fo) -- ConcHask: UNSAFE, may block.
- case char of
+ case (char::Int) of
-4 -> -- buffering is now block-buffered, use lazyReadBlock instead
lazyReadBlock handle fo
-2 -> return ""
-1 -> -- error, silently close handle.
withHandle handle $ \ handle_ -> do
- CCALL(closeFile) (haFO__ handle_) 0{-don't bother flusing-} -- ConcHask: SAFE, won't block
- writeHandle handle (handle_{ haType__ = ClosedHandle,
- haFO__ = nullFile__ })
- return ""
+ CCALL(closeFile) (haFO__ handle_) (0::Int){-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)
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"
hPutStr handle str =
wantWriteableHandle "hPutStr" handle $ \ handle_ -> do
let fo = haFO__ handle_
+ flushConnectedBuf fo
case haBufferMode__ handle_ of
LineBuffering -> do
buf <- CCALL(getWriteableBuf) 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,
#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# -> (# s2#, () #)
+ case (writeCharOffAddr# buf# n# c# s#) of s2# -> (# s2#, () #)
shoveString :: Int# -> [Char] -> IO ()
shoveString n ls =
#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# -> (# s2#, () #)
+ case (writeCharOffAddr# buf# n# c# s#) of s2# -> (# s2#, () #)
shoveString :: Int# -> [Char] -> IO ()
shoveString n ls =
#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.
if rc == 0
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
after x
case rs of
Right r -> return r
- Left e -> fail e
+ Left e -> ioError e
\end{code}
%*********************************************************
projects / ghc-hetmet.git / blobdiff