+\subsection{Changing echo status}
+%* *
+%*********************************************************
+
+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 handle on = do
+ isT <- hIsTerminalDevice handle
+ if not isT
+ then return ()
+ else
+ withHandle_ handle $ \ handle_ -> do
+ case haType__ handle_ of
+ ErrorHandle theError -> ioError theError
+ ClosedHandle -> ioe_closedHandle "hSetEcho" handle
+ _ -> do
+ rc <- CCALL(setTerminalEcho) (haFO__ handle_) ((if on then 1 else 0)::Int) -- ConcHask: SAFE, won't block
+ if rc /= ((-1)::Int)
+ then return ()
+ else constructErrorAndFail "hSetEcho"
+
+hGetEcho :: Handle -> IO Bool
+hGetEcho handle = do
+ isT <- hIsTerminalDevice handle
+ if not isT
+ then return False
+ else
+ withHandle_ handle $ \ handle_ -> do
+ case haType__ handle_ of
+ ErrorHandle theError -> ioError theError
+ ClosedHandle -> ioe_closedHandle "hGetEcho" handle
+ _ -> do
+ rc <- CCALL(getTerminalEcho) (haFO__ handle_) -- ConcHask: SAFE, won't block
+ case (rc::Int) of
+ 1 -> return True
+ 0 -> return False
+ _ -> constructErrorAndFail "hSetEcho"
+
+hIsTerminalDevice :: Handle -> IO Bool
+hIsTerminalDevice handle = do
+ withHandle_ handle $ \ handle_ -> do
+ case haType__ handle_ of
+ ErrorHandle theError -> ioError theError
+ ClosedHandle -> ioe_closedHandle "hIsTerminalDevice" handle
+ _ -> do
+ rc <- CCALL(isTerminalDevice) (haFO__ handle_) -- ConcHask: SAFE, won't block
+ case (rc::Int) 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 =
+ wantRWHandle "hConnectTo" hW $ \ hW_ ->
+ wantRWHandle "hConnectTo" hR $ \ hR_ -> do
+ CCALL(setConnectedTo) (haFO__ hR_) (haFO__ hW_) is_tty -- ConcHask: SAFE, won't block
+
+#ifndef __PARALLEL_HASKELL__
+#define FILE_OBJECT ForeignObj
+#else
+#define FILE_OBJECT Addr
+#endif
+
+flushConnectedBuf :: FILE_OBJECT -> IO ()
+flushConnectedBuf fo = CCALL(flushConnectedBuf) fo
+\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 =
+ wantReadableHandle "hLookAhead" handle $ \ handle_ -> do
+ rc <- CCALL(ungetChar) (haFO__ handle_) c -- ConcHask: SAFE, won't block
+ if rc == ((-1)::Int)
+ 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
+ handle <- openFile fname ReadMode
+ sz <- hFileSize handle
+ if sz > toInteger (maxBound::Int) then
+ ioError (userError "slurpFile: file too big")
+ else do
+ let sz_i = fromInteger sz
+ chunk <- CCALL(allocMemory__) (sz_i::Int)
+ if chunk == nullAddr
+ then do
+ hClose handle
+ constructErrorAndFail "slurpFile"
+ else do
+ rc <- withHandle_ handle ( \ handle_ -> do
+ let fo = haFO__ handle_
+ mayBlock fo (CCALL(readChunk) fo chunk sz_i) -- ConcHask: UNSAFE, may block.
+ )
+ hClose handle
+ if rc < (0::Int)
+ then constructErrorAndFail "slurpFile"
+ else return (chunk, rc)
+
+#ifndef __HUGS__ /* Hugs' Prelude doesn't need this */
+hFillBufBA :: Handle -> ByteArray Int -> Int -> IO Int
+hFillBufBA handle buf sz
+ | sz <= 0 = ioError (IOError (Just handle)
+ InvalidArgument
+ "hFillBufBA"
+ ("illegal buffer size " ++ showsPrec 9 sz [])) -- 9 => should be parens'ified.
+ | otherwise =
+ wantReadableHandle "hFillBufBA" handle $ \ handle_ -> do
+ let fo = haFO__ handle_
+#ifdef __HUGS__
+ rc <- mayBlock fo (CCALL(readChunkBA) fo buf sz) -- ConcHask: UNSAFE, may block.
+#else
+ rc <- mayBlock fo (CCALL(readChunk) fo buf sz) -- ConcHask: UNSAFE, may block.
+#endif
+ if rc >= (0::Int)
+ then return rc
+ else constructErrorAndFail "hFillBufBA"
+#endif
+
+hFillBuf :: Handle -> Addr -> Int -> IO Int
+hFillBuf handle buf sz
+ | sz <= 0 = ioError (IOError (Just handle)
+ InvalidArgument
+ "hFillBuf"
+ ("illegal buffer size " ++ showsPrec 9 sz [])) -- 9 => should be parens'ified.
+ | otherwise =
+ wantReadableHandle "hFillBuf" handle $ \ handle_ -> do
+ let fo = haFO__ handle_
+ rc <- mayBlock fo (CCALL(readChunk) fo buf sz) -- ConcHask: UNSAFE, may block.
+ if rc >= 0
+ then return rc
+ else constructErrorAndFail "hFillBuf"
+
+\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 =
+ wantWriteableHandle "hPutBuf" handle $ \ handle_ -> do
+ let fo = haFO__ handle_
+ rc <- mayBlock fo (CCALL(writeBuf) fo buf len) -- ConcHask: UNSAFE, may block.
+ if rc == (0::Int)
+ then return ()
+ else constructErrorAndFail "hPutBuf"
+
+#ifndef __HUGS__ /* An_ one Hugs doesn't provide */
+hPutBufBA :: Handle -> ByteArray Int -> Int -> IO ()
+hPutBufBA handle buf len =
+ wantWriteableHandle "hPutBufBA" handle $ \ handle_ -> do
+ let fo = haFO__ handle_
+ rc <- mayBlock fo (CCALL(writeBufBA) fo buf len) -- ConcHask: UNSAFE, may block.
+ if rc == (0::Int)
+ then return ()
+ else constructErrorAndFail "hPutBuf"
+#endif
+\end{code}
+
+Sometimes it's useful to get at the file descriptor that
+the Handle contains..
+
+\begin{code}
+getHandleFd :: Handle -> IO Int
+getHandleFd handle =
+ withHandle_ handle $ \ handle_ -> do
+ case (haType__ handle_) of
+ ErrorHandle theError -> ioError theError
+ ClosedHandle -> ioe_closedHandle "getHandleFd" handle
+ _ -> do
+ fd <- CCALL(getFileFd) (haFO__ handle_)
+ return fd
+\end{code}
+
+
+%*********************************************************
+%* *