hPutChar handle c = do
handle_ <- wantWriteableHandle "hPutChar" handle
let fo = haFO__ handle_
+ flushConnectedHandle fo
rc <- mayBlock fo (_ccall_ filePutc fo c) -- ConcHask: UNSAFE, may block.
writeHandle handle handle_
if rc == 0
hPutStr handle str = do
handle_ <- wantWriteableHandle "hPutStr" handle
let fo = haFO__ handle_
+ flushConnectedHandle fo
case haBufferMode__ handle_ of
LineBuffering -> do
buf <- _ccall_ getWriteableBuf fo
#ifndef __PARALLEL_HASKELL__
fo <- makeForeignObj fo (``&freeStdFileObject''::Addr)
#endif
- newHandle (Handle__ fo WriteHandle NoBuffering "stderr")
+ hdl <- newHandle (Handle__ fo WriteHandle NoBuffering "stderr")
+ -- when stderr and stdout are both connected to a terminal, ensure
+ -- that anything buffered on stdout is flushed prior to writing on stderr.
+ --
+ hConnectTo stdout hdl
+ return hdl
_ -> do ioError <- constructError "stderr"
newHandle (mkErrorHandle__ ioError)
)
hConnectHdl_ :: Handle -> Handle -> Int -> IO ()
hConnectHdl_ hW hR is_tty = do
- hW_ <- wantWriteableHandle "hConnectTo" hW
- hR_ <- wantReadableHandle "hConnectTo" hR
+ hW_ <- wantRWHandle "hConnectTo" hW
+ hR_ <- wantRWHandle "hConnectTo" hR
_ccall_ setConnectedTo (haFO__ hR_) (haFO__ hW_) is_tty -- ConcHask: SAFE, won't block
writeHandle hR hR_
writeHandle hW hW_
+#ifndef __PARALLEL_HASKELL__
+#define FILE_OBJECT ForeignObj
+#else
+#define FILE_OBJECT Addr
+#endif
+
+flushConnectedHandle :: FILE_OBJECT -> IO ()
+flushConnectedHandle fo = _ccall_ flushConnectedHandle fo
\end{code}
As an extension, we also allow characters to be pushed back.
IOError (Just handle) IllegalOperation fun
("handle is not open for writing")
+-- either R or W.
+wantRWHandle :: String -> Handle -> IO Handle__
+wantRWHandle 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
+ other -> return handle_
+ where
+ not_readable_error =
+ IOError (Just handle) IllegalOperation fun
+ ("handle is not open for reading or writing")
+
wantSeekableHandle :: String -> Handle -> IO Handle__
wantSeekableHandle fun handle = do
handle_ <- readHandle handle
return 0;
}
-
-\end{code}
+void
+flushConnectedHandle(ptr)
+StgForeignObj ptr;
+{
+ StgInt rc;
+ IOFileObject* fo = (IOFileObject*)ptr;
+ /* if the stream is connected to an output stream, flush it first */
+ if ( fo->connectedTo != NULL && fo->connectedTo->fd != -1 &&
+ (fo->connectedTo->flags & FILEOBJ_WRITE) ) {
+ rc = flushBuffer((StgForeignObj)fo->connectedTo);
+ }
+ /* Willfully ignore return code for now */
+ return;
+}
+\end{code}