-%
+
% (c) The AQUA Project, Glasgow University, 1994-1996
%
\begin{code}
{-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-}
-#include "error.h"
-
+#include "cbits/error.h"
+#ifndef __HUGS__ /* Hugs just includes this in PreludeBuiltin so no header needed */
module PrelHandle where
-import PrelST
-import PrelArr ( ByteArray(..), newVar, readVar, writeVar )
+import PrelBase
+import PrelAddr ( Addr, nullAddr )
+import PrelArr ( newVar, readVar, writeVar, ByteArray(..) )
import PrelRead ( Read )
import PrelList ( span )
import PrelIOBase
-import PrelTup
-import PrelMaybe
-import PrelBase
-import PrelAddr
-import PrelErr ( error )
-import PrelGHC
+import PrelException
+import PrelMaybe ( Maybe(..) )
+import PrelEnum
+import PrelNum
+import PrelShow
+import PrelAddr ( Addr, nullAddr )
+import PrelNum ( toInteger, toBig )
+import PrelPack ( packString )
+import PrelWeak ( addForeignFinalizer )
import Ix
+#if __CONCURRENT_HASKELL__
+import PrelConc
+#endif
+
#ifndef __PARALLEL_HASKELL__
-import PrelForeign ( ForeignObj, makeForeignObj, writeForeignObj )
+import PrelForeign ( makeForeignObj )
#endif
-import PrelConc -- concurrent only
-\end{code}
+#endif /* ndef(__HUGS__) */
+#ifdef __HUGS__
+#define cat2(x,y) x##y
+#define CCALL(fun) cat2(prim_,fun)
+#define __CONCURRENT_HASKELL__
+#define stToIO id
+#define sizeof_int64 8
+#else
+#define CCALL(fun) _ccall_ fun
+#define const_BUFSIZ ``BUFSIZ''
+#define primPackString
+#endif
+
+#ifndef __PARALLEL_HASKELL__
+#define FILE_OBJECT ForeignObj
+#else
+#define FILE_OBJECT Addr
+#endif
+\end{code}
%*********************************************************
%* *
-\subsection{Types @FilePath@, @Handle@, @Handle__@}
+\subsection{Types @Handle@, @Handle__@}
%* *
%*********************************************************
The @Handle@ and @Handle__@ types are defined in @IOBase@.
\begin{code}
-type FilePath = String
-
{-# INLINE newHandle #-}
-{-# INLINE readHandle #-}
-{-# INLINE writeHandle #-}
-newHandle :: Handle__ -> IO Handle
-readHandle :: Handle -> IO Handle__
-writeHandle :: Handle -> Handle__ -> IO ()
+{-# INLINE withHandle #-}
+newHandle :: Handle__ -> IO Handle
#if defined(__CONCURRENT_HASKELL__)
-- Use MVars for concurrent Haskell
newHandle hc = newMVar hc >>= \ h ->
return (Handle h)
-
-readHandle (Handle h) = takeMVar h
-writeHandle (Handle h) hc = putMVar h hc
-
#else
-- Use ordinary MutableVars for non-concurrent Haskell
newHandle hc = stToIO (newVar hc >>= \ h ->
return (Handle h))
-
-readHandle (Handle h) = stToIO (readVar h)
-writeHandle (Handle h) hc = stToIO (writeVar h hc)
-
#endif
\end{code}
%*********************************************************
%* *
-\subsection{Functions}
+\subsection{@withHandle@ operations}
%* *
%*********************************************************
+In the concurrent world, handles are locked during use. This is done
+by wrapping an MVar around the handle which acts as a mutex over
+operations on the handle.
+
+To avoid races, we use the following bracketing operations. The idea
+is to obtain the lock, do some operation and replace the lock again,
+whether the operation succeeded or failed. We also want to handle the
+case where the thread receives an exception while processing the IO
+operation: in these cases we also want to relinquish the lock.
+
+There are three versions of @withHandle@: corresponding to the three
+possible combinations of:
+
+ - the operation may side-effect the handle
+ - the operation may return a result
+
+If the operation generates an error or an exception is raised, the
+orignal handle is always replaced [ this is the case at the moment,
+but we might want to revisit this in the future --SDM ].
+
\begin{code}
+#ifdef __CONCURRENT_HASKELL__
+withHandle :: Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
+withHandle (Handle h) act = do
+ h_ <- takeMVar h
+ (h',v) <- catchException (act h_) (\ ex -> putMVar h h_ >> throw ex)
+ putMVar h h'
+ return v
+
+withHandle_ :: Handle -> (Handle__ -> IO a) -> IO a
+withHandle_ (Handle h) act = do
+ h_ <- takeMVar h
+ v <- catchException (act h_) (\ ex -> putMVar h h_ >> throw ex)
+ putMVar h h_
+ return v
+
+withHandle__ :: Handle -> (Handle__ -> IO Handle__) -> IO ()
+withHandle__ (Handle h) act = do
+ h_ <- takeMVar h
+ h' <- catchException (act h_) (\ ex -> putMVar h h_ >> throw ex)
+ putMVar h h'
+ return ()
+
+#else
+ -- of questionable value to install this exception
+ -- handler, but let's do it in the non-concurrent
+ -- case too, for now.
+withHandle (Handle h) act = do
+ h_ <- stToIO (readVar h)
+ v <- catchException (act h_) (\ ex -> stToIO (writeVar h h_) >> throw ex)
+ return v
+
+#endif
+\end{code}
+
+nullFile__ is only used for closed handles, plugging it in as a null
+file object reference.
+
+\begin{code}
+nullFile__ :: FILE_OBJECT
+nullFile__ =
#ifndef __PARALLEL_HASKELL__
-filePtr :: Handle__ -> ForeignObj
+ unsafePerformIO (makeForeignObj nullAddr)
#else
-filePtr :: Handle__ -> Addr
+ nullAddr
#endif
-filePtr (SemiClosedHandle fp _) = fp
-filePtr (ReadHandle fp _ _) = fp
-filePtr (WriteHandle fp _ _) = fp
-filePtr (AppendHandle fp _ _) = fp
-filePtr (ReadWriteHandle fp _ _) = fp
-
-bufferMode :: Handle__ -> Maybe BufferMode
-bufferMode (ReadHandle _ m _) = m
-bufferMode (WriteHandle _ m _) = m
-bufferMode (AppendHandle _ m _) = m
-bufferMode (ReadWriteHandle _ m _) = m
-
-markHandle :: Handle__ -> Handle__
-markHandle h@(ReadHandle fp m b)
- | b = h
- | otherwise = ReadHandle fp m True
-markHandle h@(WriteHandle fp m b)
- | b = h
- | otherwise = WriteHandle fp m True
-markHandle h@(AppendHandle fp m b)
- | b = h
- | otherwise = AppendHandle fp m True
-markHandle h@(ReadWriteHandle fp m b)
- | b = h
- | otherwise = ReadWriteHandle fp m True
+
+
+mkClosedHandle__ :: Handle__
+mkClosedHandle__ =
+ Handle__
+ nullFile__
+ ClosedHandle
+ NoBuffering
+ "closed file"
+
+mkErrorHandle__ :: IOError -> Handle__
+mkErrorHandle__ ioe =
+ Handle__
+ nullFile__
+ (ErrorHandle ioe)
+ NoBuffering
+ "error handle"
\end{code}
--------------------------------------------
+%*********************************************************
+%* *
+\subsection{Handle Finalizers}
+%* *
+%*********************************************************
+
+\begin{code}
+#ifndef __HUGS__
+freeStdFileObject :: ForeignObj -> IO ()
+freeStdFileObject fo = CCALL(freeStdFileObject) fo
+
+freeFileObject :: ForeignObj -> IO ()
+freeFileObject fo = CCALL(freeFileObject) fo
+#else
+foreign import stdcall "libHS_cbits.so" "freeStdFileObject" freeStdFileObject :: ForeignObj -> IO ()
+foreign import stdcall "libHS_cbits.so" "freeFileObject" freeFileObject :: ForeignObj -> IO ()
+#endif
+\end{code}
%*********************************************************
%* *
or output channel respectively. The third manages output to the
standard error channel. These handles are initially open.
+
\begin{code}
stdin, stdout, stderr :: Handle
-stdin = unsafePerformIO (do
- rc <- _ccall_ getLock (``stdin''::Addr) 0
- case rc of
- 0 -> newHandle ClosedHandle
+stdout = unsafePerformIO (do
+ rc <- CCALL(getLock) (1::Int) (1::Int) -- ConcHask: SAFE, won't block
+ case (rc::Int) of
+ 0 -> newHandle (mkClosedHandle__)
1 -> do
+#ifndef __CONCURRENT_HASKELL__
+ fo <- CCALL(openStdFile) (1::Int)
+ (1::Int){-flush on close-}
+ (0::Int){-writeable-} -- ConcHask: SAFE, won't block
+#else
+ fo <- CCALL(openStdFile) (1::Int)
+ ((1{-flush on close-} {-+ 128 don't block on I/O-})::Int)
+ (0::Int){-writeable-} -- ConcHask: SAFE, won't block
+#endif
+ -- NOTE: turn off non-blocking I/O until
+ -- we've got proper support for threadWait{Read,Write}
+
#ifndef __PARALLEL_HASKELL__
- fp <- makeForeignObj (``stdin''::Addr) (``&freeStdFile''::Addr)
- newHandle (ReadHandle fp Nothing False)
+ fo <- makeForeignObj fo
+ addForeignFinalizer fo (freeStdFileObject fo)
+#endif
+
+#ifdef __HUGS__
+/* I dont care what the Haskell report says, in an interactive system,
+ * stdout should be unbuffered by default.
+ */
+ let bm = NoBuffering
#else
- newHandle (ReadHandle ``stdin'' Nothing False)
+ (bm, bf_size) <- getBMode__ fo
+ mkBuffer__ fo bf_size
#endif
- _ -> do ioError <- constructError "stdin"
- newHandle (ErrorHandle ioError)
+ newHandle (Handle__ fo WriteHandle bm "stdout")
+ _ -> do ioError <- constructError "stdout"
+ newHandle (mkErrorHandle__ ioError)
)
-stdout = unsafePerformIO (do
- rc <- _ccall_ getLock (``stdout''::Addr) 1
- case rc of
- 0 -> newHandle ClosedHandle
+stdin = unsafePerformIO (do
+ rc <- CCALL(getLock) (0::Int) (0::Int) -- ConcHask: SAFE, won't block
+ case (rc::Int) of
+ 0 -> newHandle (mkClosedHandle__)
1 -> do
-#ifndef __PARALLEL_HASKELL__
- fp <- makeForeignObj (``stdout''::Addr) (``&freeStdFile''::Addr)
- newHandle (WriteHandle fp Nothing False)
+#ifndef __CONCURRENT_HASKELL__
+ fo <- CCALL(openStdFile) (0::Int)
+ (0::Int){-don't flush on close -}
+ (1::Int){-readable-} -- ConcHask: SAFE, won't block
#else
- newHandle (WriteHandle ``stdout'' Nothing False)
+ fo <- CCALL(openStdFile) (0::Int)
+ ((0{-flush on close-} {-+ 128 don't block on I/O-})::Int)
+ (1::Int){-readable-} -- ConcHask: SAFE, won't block
#endif
- _ -> do ioError <- constructError "stdout"
- newHandle (ErrorHandle ioError)
+
+#ifndef __PARALLEL_HASKELL__
+ fo <- makeForeignObj fo
+ addForeignFinalizer fo (freeStdFileObject fo)
+#endif
+ (bm, bf_size) <- getBMode__ fo
+ mkBuffer__ fo bf_size
+ hdl <- newHandle (Handle__ fo ReadHandle bm "stdin")
+ -- when stdin and stdout are both connected to a terminal, ensure
+ -- that anything buffered on stdout is flushed prior to reading from stdin.
+ --
+ hConnectTerms stdout hdl
+ return hdl
+ _ -> do ioError <- constructError "stdin"
+ newHandle (mkErrorHandle__ ioError)
)
+
stderr = unsafePerformIO (do
- rc <- _ccall_ getLock (``stderr''::Addr) 1
- case rc of
- 0 -> newHandle ClosedHandle
+ rc <- CCALL(getLock) (2::Int) (1::Int){-writeable-} -- ConcHask: SAFE, won't block
+ case (rc::Int) of
+ 0 -> newHandle (mkClosedHandle__)
1 -> do
-#ifndef __PARALLEL_HASKELL__
- fp <- makeForeignObj (``stderr''::Addr) (``&freeStdFile''::Addr)
- newHandle (WriteHandle fp (Just NoBuffering) False)
+#ifndef __CONCURRENT_HASKELL__
+ fo <- CCALL(openStdFile) (2::Int)
+ (1::Int){-flush on close-}
+ (0::Int){-writeable-} -- ConcHask: SAFE, won't block
#else
- newHandle (WriteHandle ``stderr'' (Just NoBuffering) False)
+ fo <- CCALL(openStdFile) (2::Int)
+ ((1{-flush on close-} {- + 128 don't block on I/O-})::Int)
+ (0::Int){-writeable-} -- ConcHask: SAFE, won't block
+#endif
+
+#ifndef __PARALLEL_HASKELL__
+ fo <- makeForeignObj fo
+ addForeignFinalizer fo (freeStdFileObject fo)
#endif
+ 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 to
+ -- stderr.
+ hConnectTo stdout hdl
+ return hdl
+
_ -> do ioError <- constructError "stderr"
- newHandle (ErrorHandle ioError)
+ newHandle (mkErrorHandle__ ioError)
)
\end{code}
openFileEx :: FilePath -> IOModeEx -> IO Handle
openFileEx f m = do
- ptr <- _ccall_ openFile f m'
- if ptr /= ``NULL'' then do
+ fo <- CCALL(openFile) (primPackString f) (file_mode::Int)
+ (binary::Int)
+ (file_flags::Int) -- ConcHask: SAFE, won't block
+ if fo /= nullAddr then do
#ifndef __PARALLEL_HASKELL__
- fp <- makeForeignObj ptr ((``&freeFile'')::Addr)
- newHandle (htype fp Nothing False)
-#else
- newHandle (htype ptr Nothing False)
+ fo <- makeForeignObj fo
+ addForeignFinalizer fo (freeFileObject fo)
#endif
+ (bm, bf_size) <- getBMode__ fo
+ mkBuffer__ fo bf_size
+ newHandle (Handle__ fo htype bm f)
else do
constructErrorAndFailWithInfo "openFile" f
where
- imo = case m of
- BinaryMode imo -> imo
- TextMode imo -> imo
+ (imo, binary) =
+ case m of
+ BinaryMode bmo -> (bmo, 1)
+ TextMode tmo -> (tmo, 0)
- m' = case m of
- BinaryMode _ -> imo' ++ "b"
- TextMode imo -> imo'
+#ifndef __CONCURRENT_HASKELL__
+ file_flags = file_flags'
+#else
+ -- See comment next to 'stderr' for why we leave
+ -- non-blocking off for now.
+ file_flags = file_flags' {-+ 128 Don't block on I/O-}
+#endif
- imo' =
+ (file_flags', file_mode) =
case imo of
- ReadMode -> "r"
- WriteMode -> "w"
- AppendMode -> "a"
- ReadWriteMode -> "r+"
+ AppendMode -> (1, 0)
+ WriteMode -> (1, 1)
+ ReadMode -> (0, 2)
+ ReadWriteMode -> (1, 3)
htype = case imo of
ReadMode -> ReadHandle
\begin{code}
hClose :: Handle -> IO ()
-hClose handle = do
- htype <- readHandle handle
- case htype of
- ErrorHandle ioError -> do
- writeHandle handle htype
- fail ioError
- ClosedHandle -> do
- writeHandle handle htype
- ioe_closedHandle handle
- SemiClosedHandle fp (buf,_) -> do
- (if buf /= ``NULL'' then
- _ccall_ free buf
- else
- return ())
- fp_a <- _casm_ `` %r = (char *)%0; '' fp
- if fp_a /= (``NULL''::Addr) then do
- -- Under what condition can this be NULL?
- rc <- _ccall_ closeFile fp
- {- We explicitly close a file object so that we can be told
- if there were any errors. Note that after @hClose@
- has been performed, the ForeignObj embedded in the Handle
- is still lying around in the heap, so care is taken
- to avoid closing the file object when the ForeignObj
- is finalised. -}
- if rc == 0 then do
-#ifndef __PARALLEL_HASKELL__
- -- Mark the foreign object data value as
- -- gone to the finaliser (freeFile())
- writeForeignObj fp ``NULL''
-#endif
- writeHandle handle ClosedHandle
- else do
- writeHandle handle htype
- constructErrorAndFail "hClose"
-
- else writeHandle handle htype
+hClose handle =
+ withHandle__ handle $ \ handle_ -> do
+ case haType__ handle_ of
+ ErrorHandle theError -> ioError theError
+ ClosedHandle -> return handle_
+ _ -> do
+ rc <- CCALL(closeFile) (haFO__ handle_) (1::Int){-flush if you can-} -- ConcHask: SAFE, won't block
+ {- We explicitly close a file object so that we can be told
+ if there were any errors. Note that after @hClose@
+ has been performed, the ForeignObj embedded in the Handle
+ is still lying around in the heap, so care is taken
+ to avoid closing the file object when the ForeignObj
+ is finalized. (we overwrite the file ptr in the underlying
+ FileObject with a NULL as part of closeFile())
+ -}
+ if rc == (0::Int)
+ then return (handle_{ haType__ = ClosedHandle,
+ haFO__ = nullFile__ })
+ else constructErrorAndFail "hClose"
- other -> do
- let fp = filePtr other
- rc <- _ccall_ closeFile fp
- if rc == 0 then do
-#ifndef __PARALLEL_HASKELL__
- -- Mark the foreign object data
- writeForeignObj fp ``NULL''
-#endif
- writeHandle handle ClosedHandle
- else do
- writeHandle handle htype
- constructErrorAndFail "hClose"
\end{code}
Computation $hClose hdl$ makes handle {\em hdl} closed. Before the
\begin{code}
hFileSize :: Handle -> IO Integer
-hFileSize handle = do
- htype <- readHandle handle
- case htype of
- ErrorHandle ioError -> do
- writeHandle handle htype
- fail ioError
- ClosedHandle -> do
- writeHandle handle htype
- ioe_closedHandle handle
- SemiClosedHandle _ _ -> do
- writeHandle handle htype
- ioe_closedHandle handle
- other ->
+hFileSize handle =
+ withHandle_ handle $ \ handle_ -> do
+ case haType__ handle_ of
+ ErrorHandle theError -> ioError theError
+ ClosedHandle -> ioe_closedHandle "hFileSize" handle
+ SemiClosedHandle -> ioe_closedHandle "hFileSize" handle
+#ifdef __HUGS__
+ _ -> do
+ mem <- primNewByteArray sizeof_int64
+ rc <- CCALL(fileSize_int64) (haFO__ handle_) mem -- ConcHask: SAFE, won't block
+ if rc == 0 then do
+ result <- primReadInt64Array mem 0
+ return (primInt64ToInteger result)
+ else
+ constructErrorAndFail "hFileSize"
+#else
+ _ ->
-- HACK! We build a unique MP_INT of the right shape to hold
-- a single unsigned word, and we let the C routine
-- change the data bits
-- expression --SDM
_casm_ ``%r = 1;'' >>= \(I# hack#) ->
case int2Integer# hack# of
- result@(J# _ _ d#) -> do
- let bogus_bounds = (error "fileSize"::(Int,Int))
- rc <- _ccall_ fileSize (filePtr other)
- (ByteArray bogus_bounds d#)
- writeHandle handle htype
- if rc == 0 then
- return result
+ (# s, d #) -> do
+ rc <- CCALL(fileSize) (haFO__ handle_) d -- ConcHask: SAFE, won't block
+ if rc == (0::Int) then
+ return (J# s d)
else
constructErrorAndFail "hFileSize"
+#endif
\end{code}
-For a readable handle {\em hdl}, computation $hIsEOF hdl$ returns
-$True$ if no further input can be taken from {\em hdl} or for a
+For a readable handle {\em hdl}, @hIsEOF hdl@ returns
+@True@ if no further input can be taken from @hdl@ or for a
physical file, if the current I/O position is equal to the length of
-the file. Otherwise, it returns $False$.
+the file. Otherwise, it returns @False@.
\begin{code}
hIsEOF :: Handle -> IO Bool
-hIsEOF handle = do
- htype <- readHandle handle
- case htype of
- ErrorHandle ioError -> do
- writeHandle handle htype
- fail ioError
- ClosedHandle -> do
- writeHandle handle htype
- ioe_closedHandle handle
- SemiClosedHandle _ _ -> do
- writeHandle handle htype
- ioe_closedHandle handle
- WriteHandle _ _ _ -> do
- writeHandle handle htype
- fail (IOError (Just handle) IllegalOperation
- "handle is not open for reading")
- AppendHandle _ _ _ -> do
- writeHandle handle htype
- fail (IOError (Just handle) IllegalOperation
- "handle is not open for reading")
- other -> do
- rc <- _ccall_ fileEOF (filePtr other)
- writeHandle handle (markHandle htype)
- case rc of
- 0 -> return False
- 1 -> return True
- _ -> constructErrorAndFail "hIsEOF"
+hIsEOF handle =
+ wantReadableHandle "hIsEOF" handle $ \ handle_ -> do
+ let fo = haFO__ handle_
+ rc <- mayBlock fo (CCALL(fileEOF) fo) -- ConcHask: UNSAFE, may block
+ case rc of
+ 0 -> return False
+ 1 -> return True
+ _ -> constructErrorAndFail "hIsEOF"
isEOF :: IO Bool
isEOF = hIsEOF stdin
hSetBuffering handle mode =
case mode of
BlockBuffering (Just n)
- | n <= 0 -> fail (IOError (Just handle) InvalidArgument
- "illegal buffer size")
- other -> do
- htype <- readHandle handle
- if isMarked htype then do
- writeHandle handle htype
- fail (IOError (Just handle)
- UnsupportedOperation
- "can't set buffering for a dirty handle")
- else
- case htype of
- ErrorHandle ioError -> do
- writeHandle handle htype
- fail ioError
- ClosedHandle -> do
- writeHandle handle htype
- ioe_closedHandle handle
- SemiClosedHandle _ _ -> do
- writeHandle handle htype
- ioe_closedHandle handle
- other -> do
- rc <- _ccall_ setBuffering (filePtr other) bsize
- if rc == 0 then
- writeHandle handle ((hcon other) (filePtr other)
- (Just mode) True)
- else do
- writeHandle handle htype
- constructErrorAndFail "hSetBuffering"
-
+ | n <= 0 -> ioError
+ (IOError (Just handle)
+ InvalidArgument
+ "hSetBuffering"
+ ("illegal buffer size " ++ showsPrec 9 n [])) -- 9 => should be parens'ified.
+ _ ->
+ withHandle__ handle $ \ handle_ -> do
+ case haType__ handle_ of
+ ErrorHandle theError -> ioError theError
+ ClosedHandle -> ioe_closedHandle "hSetBuffering" handle
+ _ -> do
+ {- Note:
+ - we flush the old buffer regardless of whether
+ the new buffer could fit the contents of the old buffer
+ or not.
+ - allow a handle's buffering to change even if IO has
+ occurred (ANSI C spec. does not allow this, nor did
+ the previous implementation of IO.hSetBuffering).
+ - a non-standard extension is to allow the buffering
+ of semi-closed handles to change [sof 6/98]
+ -}
+ let fo = haFO__ handle_
+ rc <- mayBlock fo (CCALL(setBuffering) fo bsize) -- ConcHask: UNSAFE, may block
+ if rc == 0
+ then do
+ return (handle_{ haBufferMode__ = mode })
+ else do
+ -- Note: failure to change the buffer size will cause old buffer to be flushed.
+ constructErrorAndFail "hSetBuffering"
where
- isMarked :: Handle__ -> Bool
- isMarked (ReadHandle fp m b) = b
- isMarked (WriteHandle fp m b) = b
- isMarked (AppendHandle fp m b) = b
- isMarked (ReadWriteHandle fp m b) = b
- isMarked _ = False
-
bsize :: Int
bsize = case mode of
- NoBuffering -> 0
- LineBuffering -> -1
- BlockBuffering Nothing -> -2
- BlockBuffering (Just n) -> n
-
-#ifndef __PARALLEL_HASKELL__
- hcon :: Handle__ -> (ForeignObj -> (Maybe BufferMode) -> Bool -> Handle__)
-#else
- hcon :: Handle__ -> (Addr -> (Maybe BufferMode) -> Bool -> Handle__)
-#endif
- hcon (ReadHandle _ _ _) = ReadHandle
- hcon (WriteHandle _ _ _) = WriteHandle
- hcon (AppendHandle _ _ _) = AppendHandle
- hcon (ReadWriteHandle _ _ _) = ReadWriteHandle
+ NoBuffering -> 0
+ LineBuffering -> -1
+ BlockBuffering Nothing -> -2
+ BlockBuffering (Just n) -> n
\end{code}
-Computation $flush hdl$ causes any items buffered for output in handle
-{\em hdl} to be sent immediately to the operating system.
+The action @hFlush hdl@ causes any items buffered for output
+in handle {\em hdl} to be sent immediately to the operating
+system.
\begin{code}
hFlush :: Handle -> IO ()
-hFlush handle = do
- htype <- readHandle handle
- case htype of
- ErrorHandle ioError -> do
- writeHandle handle htype
- fail ioError
- ClosedHandle -> do
- writeHandle handle htype
- ioe_closedHandle handle
- SemiClosedHandle _ _ -> do
- writeHandle handle htype
- ioe_closedHandle handle
- other -> do
- rc <- _ccall_ flushFile (filePtr other)
- writeHandle handle (markHandle htype)
- if rc == 0 then
- return ()
- else
- constructErrorAndFail "hFlush"
+hFlush handle =
+ wantWriteableHandle "hFlush" handle $ \ handle_ -> do
+ let fo = haFO__ handle_
+ rc <- mayBlock fo (CCALL(flushFile) fo) -- ConcHask: UNSAFE, may block
+ if rc == 0 then
+ return ()
+ else
+ constructErrorAndFail "hFlush"
+
\end{code}
%*********************************************************
\begin{code}
-data HandlePosn = HandlePosn Handle Int
+data HandlePosn
+ = HandlePosn
+ Handle -- Q: should this be a weak or strong ref. to the handle?
+ Int
data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd
deriving (Eq, Ord, Ix, Enum, Read, Show)
\end{code}
-Computation $hGetPosn hdl$ returns the current I/O
+Computation @hGetPosn hdl@ returns the current I/O
position of {\em hdl} as an abstract position. Computation
$hSetPosn p$ sets the position of {\em hdl}
to a previously obtained position {\em p}.
\begin{code}
hGetPosn :: Handle -> IO HandlePosn
-hGetPosn handle = do
- htype <- readHandle handle
- case htype of
- ErrorHandle ioError -> do
- writeHandle handle htype
- fail ioError
- ClosedHandle -> do
- writeHandle handle htype
- ioe_closedHandle handle
- SemiClosedHandle _ _ -> do
- writeHandle handle htype
- ioe_closedHandle handle
- other -> do
- posn <- _ccall_ getFilePosn (filePtr other)
- writeHandle handle htype
- if posn /= -1 then
- return (HandlePosn handle posn)
- else
- constructErrorAndFail "hGetPosn"
+hGetPosn handle =
+ wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
+ posn <- CCALL(getFilePosn) (haFO__ handle_) -- ConcHask: SAFE, won't block
+ if posn /= -1 then do
+ return (HandlePosn handle posn)
+ else
+ constructErrorAndFail "hGetPosn"
hSetPosn :: HandlePosn -> IO ()
-hSetPosn (HandlePosn handle posn) = do
- htype <- readHandle handle
- case htype of
- ErrorHandle ioError -> do
- writeHandle handle htype
- fail ioError
- ClosedHandle -> do
- writeHandle handle htype
- ioe_closedHandle handle
- SemiClosedHandle _ _ -> do
- writeHandle handle htype
- ioe_closedHandle handle
- AppendHandle _ _ _ -> do
- writeHandle handle htype
- fail (IOError (Just handle) IllegalOperation "handle is not seekable")
- other -> do
- rc <- _ccall_ setFilePosn (filePtr other) posn
- writeHandle handle (markHandle htype)
- if rc == 0 then
- return ()
- else
- constructErrorAndFail "hSetPosn"
+hSetPosn (HandlePosn handle posn) =
+ wantSeekableHandle "hSetPosn" handle $ \ handle_ -> do -- not as silly as it looks: the handle may have been closed in the meantime.
+ let fo = haFO__ handle_
+ rc <- mayBlock fo (CCALL(setFilePosn) fo posn) -- ConcHask: UNSAFE, may block
+ if rc == 0 then do
+ return ()
+ else
+ constructErrorAndFail "hSetPosn"
\end{code}
-Computation $hSeek hdl mode i$ sets the position of handle
-{\em hdl} depending on $mode$. If {\em mode} is
+The action @hSeek hdl mode i@ sets the position of handle
+@hdl@ depending on @mode@. If @mode@ is
\begin{itemize}
-\item[{\bf AbsoluteSeek}] The position of {\em hdl} is set to {\em i}.
-\item[{\bf RelativeSeek}] The position of {\em hdl} is set to offset {\em i} from
+\item[{\bf AbsoluteSeek}] The position of @hdl@ is set to @i@.
+\item[{\bf RelativeSeek}] The position of @hdl@ is set to offset @i@ from
the current position.
-\item[{\bf SeekToEnd}] The position of {\em hdl} is set to offset {\em i} from
+\item[{\bf SeekFromEnd}] The position of @hdl@ is set to offset @i@ from
the end of the file.
-\item[{\bf SeekFromBeginning}] The position of {\em hdl} is set to offset {\em i} from
-the beginning of the file.
\end{itemize}
-Some handles may not be seekable $hIsSeekable$, or only support a
+Some handles may not be seekable (see @hIsSeekable@), or only support a
subset of the possible positioning operations (e.g. it may only be
possible to seek to the end of a tape, or to a positive offset from
the beginning or current position).
It is not possible to set a negative I/O position, or for a physical
file, an I/O position beyond the current end-of-file.
+Note:
+ - when seeking using @SeekFromEnd@, positive offsets (>=0) means seeking
+ at or past EOF.
+ - relative seeking on buffered handles can lead to non-obvious results.
+
\begin{code}
hSeek :: Handle -> SeekMode -> Integer -> IO ()
-hSeek handle mode offset@(J# _ s# d#) = do
- htype <- readHandle handle
- case htype of
- ErrorHandle ioError -> do
- writeHandle handle htype
- fail ioError
- ClosedHandle -> do
- writeHandle handle htype
- ioe_closedHandle handle
- SemiClosedHandle _ _ -> do
- writeHandle handle htype
- ioe_closedHandle handle
- AppendHandle _ _ _ -> do
- writeHandle handle htype
- fail (IOError (Just handle) IllegalOperation "handle is not seekable")
- other -> do
- rc <- _ccall_ seekFile (filePtr other) whence (I# s#)
- (ByteArray (0,0) d#)
- writeHandle handle (markHandle htype)
- if rc == 0 then
- return ()
- else
- constructErrorAndFail "hSeek"
+#ifdef __HUGS__
+hSeek handle mode offset =
+ wantSeekableHandle "hSeek" handle $ \ handle_ -> do
+ let fo = haFO__ handle_
+ rc <- mayBlock fo (CCALL(seekFile_int64) fo whence (primIntegerToInt64 offset)) -- ConcHask: UNSAFE, may block
+#else
+hSeek handle mode i@(S# _) = hSeek handle mode (toBig i)
+hSeek handle mode (J# s# d#) =
+ wantSeekableHandle "hSeek" handle $ \ handle_ -> do
+ let fo = haFO__ handle_
+ rc <- mayBlock fo (CCALL(seekFile) fo whence (I# s#) d#) -- ConcHask: UNSAFE, may block
+#endif
+ if rc == 0 then do
+ return ()
+ else
+ constructErrorAndFail "hSeek"
where
whence :: Int
whence = case mode of
- AbsoluteSeek -> ``SEEK_SET''
- RelativeSeek -> ``SEEK_CUR''
- SeekFromEnd -> ``SEEK_END''
+ AbsoluteSeek -> 0
+ RelativeSeek -> 1
+ SeekFromEnd -> 2
\end{code}
%*********************************************************
\begin{code}
hIsOpen :: Handle -> IO Bool
-hIsOpen handle = do
- htype <- readHandle handle
- case htype of
- ErrorHandle ioError -> do
- writeHandle handle htype
- fail ioError
- ClosedHandle -> do
- writeHandle handle htype
- return False
- SemiClosedHandle _ _ -> do
- writeHandle handle htype
- return False
- other -> do
- writeHandle handle htype
- return True
+hIsOpen handle =
+ withHandle_ handle $ \ handle_ -> do
+ case haType__ handle_ of
+ ErrorHandle theError -> ioError theError
+ ClosedHandle -> return False
+ SemiClosedHandle -> return False
+ _ -> return True
hIsClosed :: Handle -> IO Bool
-hIsClosed handle = do
- htype <- readHandle handle
- case htype of
- ErrorHandle ioError -> do
- writeHandle handle htype
- fail ioError
- ClosedHandle -> do
- writeHandle handle htype
- return True
- other -> do
- writeHandle handle htype
- return False
+hIsClosed handle =
+ withHandle_ handle $ \ handle_ -> do
+ case haType__ handle_ of
+ ErrorHandle theError -> ioError theError
+ ClosedHandle -> return True
+ _ -> return False
+
+{- not defined, nor exported, but mentioned
+ here for documentation purposes:
+
+ hSemiClosed :: Handle -> IO Bool
+ hSemiClosed h = do
+ ho <- hIsOpen h
+ hc <- hIsClosed h
+ return (not (ho || hc))
+-}
hIsReadable :: Handle -> IO Bool
-hIsReadable handle = do
- htype <- readHandle handle
- case htype of
- ErrorHandle ioError -> do
- writeHandle handle htype
- fail ioError
- ClosedHandle -> do
- writeHandle handle htype
- ioe_closedHandle handle
- SemiClosedHandle _ _ -> do
- writeHandle handle htype
- ioe_closedHandle handle
- other -> do
- writeHandle handle htype
- return (isReadable other)
+hIsReadable handle =
+ withHandle_ handle $ \ handle_ -> do
+ case haType__ handle_ of
+ ErrorHandle theError -> ioError theError
+ ClosedHandle -> ioe_closedHandle "hIsReadable" handle
+ SemiClosedHandle -> ioe_closedHandle "hIsReadable" handle
+ htype -> return (isReadable htype)
where
- isReadable (ReadHandle _ _ _) = True
- isReadable (ReadWriteHandle _ _ _) = True
- isReadable _ = False
+ isReadable ReadHandle = True
+ isReadable ReadWriteHandle = True
+ isReadable _ = False
hIsWritable :: Handle -> IO Bool
-hIsWritable handle = do
- htype <- readHandle handle
- case htype of
- ErrorHandle ioError -> do
- writeHandle handle htype
- fail ioError
- ClosedHandle -> do
- writeHandle handle htype
- ioe_closedHandle handle
- SemiClosedHandle _ _ -> do
- writeHandle handle htype
- ioe_closedHandle handle
- other -> do
- writeHandle handle htype
- return (isWritable other)
+hIsWritable handle =
+ withHandle_ handle $ \ handle_ -> do
+ case haType__ handle_ of
+ ErrorHandle theError -> ioError theError
+ ClosedHandle -> ioe_closedHandle "hIsWritable" handle
+ SemiClosedHandle -> ioe_closedHandle "hIsWritable" handle
+ htype -> return (isWritable htype)
where
- isWritable (AppendHandle _ _ _) = True
- isWritable (WriteHandle _ _ _) = True
- isWritable (ReadWriteHandle _ _ _) = True
- isWritable _ = False
-
-getBufferMode :: Handle__ -> IO Handle__
-getBufferMode htype =
- case bufferMode htype of
- Just x -> return htype
- Nothing -> do
- rc <- _ccall_ getBufferMode (filePtr htype)
- let
- mode =
- case rc of
- 0 -> Just NoBuffering
- -1 -> Just LineBuffering
- -2 -> Just (BlockBuffering Nothing)
- -3 -> Nothing
- n -> Just (BlockBuffering (Just n))
- return (case htype of
- ReadHandle fp _ b -> ReadHandle fp mode b
- WriteHandle fp _ b -> WriteHandle fp mode b
- AppendHandle fp _ b -> AppendHandle fp mode b
- ReadWriteHandle fp _ b -> ReadWriteHandle fp mode b)
-
-hIsBlockBuffered :: Handle -> IO (Bool,Maybe Int)
-hIsBlockBuffered handle = do
- htype <- readHandle handle
- case htype of
- ErrorHandle ioError -> do
- writeHandle handle htype
- fail ioError
- ClosedHandle -> do
- writeHandle handle htype
- ioe_closedHandle handle
- SemiClosedHandle _ _ -> do
- writeHandle handle htype
- ioe_closedHandle handle
- other -> do
- other <- getBufferMode other
- case bufferMode other of
- Just (BlockBuffering size) -> do
- writeHandle handle other
- return (True, size)
- Just _ -> do
- writeHandle handle other
- return (False, Nothing)
- Nothing ->
- constructErrorAndFail "hIsBlockBuffered"
-
-hIsLineBuffered :: Handle -> IO Bool
-hIsLineBuffered handle = do
- htype <- readHandle handle
- case htype of
- ErrorHandle ioError -> do
- writeHandle handle htype
- fail ioError
- ClosedHandle -> do
- writeHandle handle htype
- ioe_closedHandle handle
- SemiClosedHandle _ _ -> do
- writeHandle handle htype
- ioe_closedHandle handle
- other -> do
- other <- getBufferMode other
- case bufferMode other of
- Just LineBuffering -> do
- writeHandle handle other
- return True
- Just _ -> do
- writeHandle handle other
- return False
- Nothing ->
- constructErrorAndFail "hIsLineBuffered"
-
-hIsNotBuffered :: Handle -> IO Bool
-hIsNotBuffered handle = do
- htype <- readHandle handle
- case htype of
- ErrorHandle ioError -> do
- writeHandle handle htype
- fail ioError
- ClosedHandle -> do
- writeHandle handle htype
- ioe_closedHandle handle
- SemiClosedHandle _ _ -> do
- writeHandle handle htype
- ioe_closedHandle handle
- other -> do
- other <- getBufferMode other
- case bufferMode other of
- Just NoBuffering -> do
- writeHandle handle other
- return True
- Just _ -> do
- writeHandle handle other
- return False
- Nothing ->
- constructErrorAndFail "hIsNotBuffered"
+ isWritable AppendHandle = True
+ isWritable WriteHandle = True
+ isWritable ReadWriteHandle = True
+ isWritable _ = False
+
+
+#ifndef __PARALLEL_HASKELL__
+getBMode__ :: ForeignObj -> IO (BufferMode, Int)
+#else
+getBMode__ :: Addr -> IO (BufferMode, Int)
+#endif
+getBMode__ fo = do
+ rc <- CCALL(getBufferMode) fo -- ConcHask: SAFE, won't block
+ case (rc::Int) of
+ 0 -> return (NoBuffering, 0)
+ -1 -> return (LineBuffering, default_buffer_size)
+ -2 -> return (BlockBuffering Nothing, default_buffer_size)
+ -3 -> return (NoBuffering, 0) -- only happens on un-stat()able files.
+ n -> return (BlockBuffering (Just n), n)
+ where
+ default_buffer_size :: Int
+ default_buffer_size = (const_BUFSIZ - 1)
+\end{code}
+
+Querying how a handle buffers its data:
+\begin{code}
hGetBuffering :: Handle -> IO BufferMode
-hGetBuffering handle = do
- htype <- readHandle handle
- case htype of
- ErrorHandle ioError -> do
- writeHandle handle htype
- fail ioError
- ClosedHandle -> do
- writeHandle handle htype
- ioe_closedHandle handle
- SemiClosedHandle _ _ -> do
- writeHandle handle htype
- ioe_closedHandle handle
- other -> do
- other <- getBufferMode other
- case bufferMode other of
- Just v -> do
- writeHandle handle other
- return v
- Nothing ->
- constructErrorAndFail "hGetBuffering"
+hGetBuffering handle =
+ withHandle_ handle $ \ handle_ -> do
+ case haType__ handle_ of
+ ErrorHandle theError -> ioError theError
+ ClosedHandle -> ioe_closedHandle "hGetBuffering" handle
+ _ ->
+ {-
+ We're being non-standard here, and allow the buffering
+ of a semi-closed handle to be queried. -- sof 6/98
+ -}
+ return (haBufferMode__ handle_) -- could be stricter..
+\end{code}
+\begin{code}
hIsSeekable :: Handle -> IO Bool
-hIsSeekable handle = do
- htype <- readHandle handle
- case htype of
- ErrorHandle ioError -> do
- writeHandle handle htype
- fail ioError
- ClosedHandle -> do
- writeHandle handle htype
- ioe_closedHandle handle
- SemiClosedHandle _ _ -> do
- writeHandle handle htype
- ioe_closedHandle handle
- AppendHandle _ _ _ -> do
- writeHandle handle htype
- return False
- other -> do
- rc <- _ccall_ seekFileP (filePtr other)
- writeHandle handle htype
- case rc of
+hIsSeekable handle =
+ withHandle_ handle $ \ handle_ -> do
+ case haType__ handle_ of
+ ErrorHandle theError -> ioError theError
+ ClosedHandle -> ioe_closedHandle "hIsSeekable" handle
+ SemiClosedHandle -> ioe_closedHandle "hIsSeekable" handle
+ AppendHandle -> return False
+ _ -> do
+ rc <- CCALL(seekFileP) (haFO__ handle_) -- ConcHask: SAFE, won't block
+ case (rc::Int) of
0 -> return False
1 -> return True
_ -> constructErrorAndFail "hIsSeekable"
%*********************************************************
%* *
+\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}
+
+
+%*********************************************************
+%* *
\subsection{Miscellaneous}
%* *
%*********************************************************
-These two functions are meant to get things out of @IOErrors@. They don't!
+These three functions are meant to get things out of @IOErrors@.
+
+(ToDo: improve!)
\begin{code}
ioeGetFileName :: IOError -> Maybe FilePath
ioeGetErrorString :: IOError -> String
ioeGetHandle :: IOError -> Maybe Handle
-ioeGetHandle (IOError h _ _) = h
-ioeGetErrorString (IOError _ iot str) =
+ioeGetHandle (IOError h _ _ _) = h
+ioeGetErrorString (IOError _ iot _ str) =
case iot of
EOF -> "end of file"
_ -> str
-ioeGetFileName (IOError _ _ str) =
+ioeGetFileName (IOError _ _ _ str) =
case span (/=':') str of
- (fs,[]) -> Nothing
+ (_,[]) -> Nothing
(fs,_) -> Just fs
\end{code}
-Internal function for creating an @IOError@ representing the
-access of a closed file.
+'Top-level' IO actions want to catch exceptions (e.g., forkIO and
+PrelMain.mainIO) and report them - topHandler is the exception
+handler they should use for this:
\begin{code}
-
-ioe_closedHandle :: Handle -> IO a
-ioe_closedHandle h = fail (IOError (Just h) IllegalOperation "handle is closed")
+-- make sure we handle errors while reporting the error!
+-- (e.g. evaluating the string passed to 'error' might generate
+-- another error, etc.)
+topHandler :: Bool -> Exception -> IO ()
+topHandler bombOut err = catchException (real_handler bombOut err) (topHandler bombOut)
+
+real_handler :: Bool -> Exception -> IO ()
+real_handler bombOut ex =
+ case ex of
+ AsyncException StackOverflow -> reportStackOverflow bombOut
+ ErrorCall s -> reportError bombOut s
+ other -> reportError bombOut (showsPrec 0 other "\n")
+
+reportStackOverflow :: Bool -> IO ()
+reportStackOverflow bombOut = do
+ (hFlush stdout) `catchException` (\ _ -> return ())
+ callStackOverflowHook
+ if bombOut then
+ stg_exit 2
+ else
+ return ()
+
+reportError :: Bool -> String -> IO ()
+reportError bombOut str = do
+ (hFlush stdout) `catchException` (\ _ -> return ())
+ let bs@(ByteArray (_,len) _) = packString str
+ writeErrString addrOf_ErrorHdrHook bs len
+ if bombOut then
+ stg_exit 1
+ else
+ return ()
+
+foreign label "ErrorHdrHook"
+ addrOf_ErrorHdrHook :: Addr
+
+foreign import ccall "writeErrString__"
+ writeErrString :: Addr -> ByteArray Int -> Int -> IO ()
+
+foreign import ccall "stackOverflow"
+ callStackOverflowHook :: IO ()
+
+foreign import ccall "stg_exit"
+ stg_exit :: Int -> IO ()
\end{code}
+
A number of operations want to get at a readable or writeable handle, and fail
if it isn't:
\begin{code}
-wantReadableHandle :: Handle -> IO Handle__
-wantReadableHandle handle = do
- htype <- readHandle handle
- case htype of
- ErrorHandle ioError -> do
- writeHandle handle htype
- fail ioError
- ClosedHandle -> do
- writeHandle handle htype
- ioe_closedHandle handle
- SemiClosedHandle _ _ -> do
- writeHandle handle htype
- ioe_closedHandle handle
- AppendHandle _ _ _ -> do
- writeHandle handle htype
- fail (IOError (Just handle) IllegalOperation
- "handle is not open for reading")
- WriteHandle _ _ _ -> do
- writeHandle handle htype
- fail (IOError (Just handle) IllegalOperation
- "handle is not open for reading")
- other -> return other
-
-wantWriteableHandle :: Handle
- -> IO Handle__
-wantWriteableHandle handle = do
- htype <- readHandle handle
- case htype of
- ErrorHandle ioError -> do
- writeHandle handle htype
- fail ioError
- ClosedHandle -> do
- writeHandle handle htype
- ioe_closedHandle handle
- SemiClosedHandle _ _ -> do
- writeHandle handle htype
- ioe_closedHandle handle
- ReadHandle _ _ _ -> do
- writeHandle handle htype
- fail (IOError (Just handle) IllegalOperation "handle is not open for writing")
- other -> return other
+wantReadableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
+wantReadableHandle fun handle act =
+ withHandle_ handle $ \ handle_ -> do
+ case haType__ handle_ of
+ ErrorHandle theError -> ioError theError
+ ClosedHandle -> ioe_closedHandle fun handle
+ SemiClosedHandle -> ioe_closedHandle fun handle
+ AppendHandle -> ioError not_readable_error
+ WriteHandle -> ioError not_readable_error
+ _ -> act handle_
+ where
+ not_readable_error =
+ IOError (Just handle) IllegalOperation fun
+ ("handle is not open for reading")
+
+wantWriteableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
+wantWriteableHandle fun handle act =
+ withHandle_ handle $ \ handle_ -> do
+ case haType__ handle_ of
+ ErrorHandle theError -> ioError theError
+ ClosedHandle -> ioe_closedHandle fun handle
+ SemiClosedHandle -> ioe_closedHandle fun handle
+ ReadHandle -> ioError not_writeable_error
+ _ -> act handle_
+ where
+ not_writeable_error =
+ IOError (Just handle) IllegalOperation fun
+ ("handle is not open for writing")
+
+wantRWHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
+wantRWHandle fun handle act =
+ withHandle_ handle $ \ handle_ -> do
+ case haType__ handle_ of
+ ErrorHandle theError -> ioError theError
+ ClosedHandle -> ioe_closedHandle fun handle
+ SemiClosedHandle -> ioe_closedHandle fun handle
+ _ -> act handle_
+
+wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
+wantSeekableHandle fun handle act =
+ withHandle_ handle $ \ handle_ -> do
+ case haType__ handle_ of
+ ErrorHandle theError -> ioError theError
+ ClosedHandle -> ioe_closedHandle fun handle
+ SemiClosedHandle -> ioe_closedHandle fun handle
+ AppendHandle -> ioError not_seekable_error
+ _ -> act handle_
+ where
+ not_seekable_error =
+ IOError (Just handle)
+ IllegalOperation fun
+ ("handle is not seekable")
+
+\end{code}
+
+Internal function for creating an @IOError@ representing the
+access to a closed file.
+
+\begin{code}
+ioe_closedHandle :: String -> Handle -> IO a
+ioe_closedHandle fun h = ioError (IOError (Just h) IllegalOperation fun "handle is closed")
+\end{code}
+
+Internal helper functions for Concurrent Haskell implementation
+of IO:
+
+\begin{code}
+#ifndef __PARALLEL_HASKELL__
+mayBlock :: ForeignObj -> IO Int -> IO Int
+#else
+mayBlock :: Addr -> IO Int -> IO Int
+#endif
+
+#ifndef notyet /*__CONCURRENT_HASKELL__*/
+mayBlock _ act = act
+#else
+mayBlock fo act = do
+ rc <- act
+ case rc of
+ -5 -> do -- (possibly blocking) read
+ fd <- CCALL(getFileFd) fo
+ threadWaitRead fd
+ CCALL(clearNonBlockingIOFlag__) fo -- force read to happen this time.
+ mayBlock fo act -- input available, re-try
+ -6 -> do -- (possibly blocking) write
+ fd <- CCALL(getFileFd) fo
+ threadWaitWrite fd
+ CCALL(clearNonBlockingIOFlag__) fo -- force write to happen this time.
+ mayBlock fo act -- output possible
+ -7 -> do -- (possibly blocking) write on connected handle
+ fd <- CCALL(getConnFileFd) fo
+ threadWaitWrite fd
+ CCALL(clearConnNonBlockingIOFlag__) fo -- force write to happen this time.
+ mayBlock fo act -- output possible
+ _ -> do
+ CCALL(setNonBlockingIOFlag__) fo -- reset file object.
+ CCALL(setConnNonBlockingIOFlag__) fo -- reset (connected) file object.
+ return rc
+
+#endif
+
+-- #ifdef __HUGS__
+#if 1
+threadDelay, threadWaitRead, threadWaitWrite :: Int -> IO ()
+
+-- Hugs does actually have the primops needed to implement these
+-- but, like GHC, the primops don't actually do anything...
+threadDelay _ = return ()
+threadWaitRead _ = return ()
+threadWaitWrite _ = return ()
+#endif
+
+\end{code}
+
+
+\begin{code}
+#ifdef __HUGS__
+type FD = Int
+type Exclusive = Int -- really Bool
+type How = Int
+type Binary = Int
+type OpenStdFlags = Int
+type OpenFlags = Int
+type Readable = Int -- really Bool
+type Flush = Int -- really Bool
+type RC = Int -- standard return code
+
+type IOFileAddr = Addr -- as returned from functions
+type CString = PrimByteArray
+type Bytes = PrimMutableByteArray RealWorld
+
+#ifndef __PARALLEL_HASKELL__
+type FILE_OBJ = ForeignObj -- as passed into functions
+#else
+type FILE_OBJ = Addr
+#endif
+
+foreign import ccall "libHS_cbits.so" "setBuf" unsafe prim_setBuf :: FILE_OBJ -> Addr -> Int -> IO ()
+foreign import ccall "libHS_cbits.so" "getBufSize" unsafe prim_getBufSize :: FILE_OBJ -> IO Int
+foreign import ccall "libHS_cbits.so" "inputReady" unsafe prim_inputReady :: FILE_OBJ -> Int -> IO RC
+foreign import ccall "libHS_cbits.so" "fileGetc" unsafe prim_fileGetc :: FILE_OBJ -> IO Int
+foreign import ccall "libHS_cbits.so" "fileLookAhead" unsafe prim_fileLookAhead :: FILE_OBJ -> IO Int
+foreign import ccall "libHS_cbits.so" "readBlock" unsafe prim_readBlock :: FILE_OBJ -> IO Int
+foreign import ccall "libHS_cbits.so" "readLine" unsafe prim_readLine :: FILE_OBJ -> IO Int
+foreign import ccall "libHS_cbits.so" "readChar" unsafe prim_readChar :: FILE_OBJ -> IO Int
+foreign import ccall "libHS_cbits.so" "writeFileObject" unsafe prim_writeFileObject :: FILE_OBJ -> Int -> IO RC
+foreign import ccall "libHS_cbits.so" "filePutc" unsafe prim_filePutc :: FILE_OBJ -> Char -> IO RC
+foreign import ccall "libHS_cbits.so" "getBufStart" unsafe prim_getBufStart :: FILE_OBJ -> Int -> IO Addr
+foreign import ccall "libHS_cbits.so" "getWriteableBuf" unsafe prim_getWriteableBuf :: FILE_OBJ -> IO Addr
+foreign import ccall "libHS_cbits.so" "getBufWPtr" unsafe prim_getBufWPtr :: FILE_OBJ -> IO Int
+foreign import ccall "libHS_cbits.so" "setBufWPtr" unsafe prim_setBufWPtr :: FILE_OBJ -> Int -> IO ()
+foreign import ccall "libHS_cbits.so" "closeFile" unsafe prim_closeFile :: FILE_OBJ -> Flush -> IO RC
+foreign import ccall "libHS_cbits.so" "fileEOF" unsafe prim_fileEOF :: FILE_OBJ -> IO RC
+foreign import ccall "libHS_cbits.so" "setBuffering" unsafe prim_setBuffering :: FILE_OBJ -> Int -> IO RC
+foreign import ccall "libHS_cbits.so" "flushFile" unsafe prim_flushFile :: FILE_OBJ -> IO RC
+foreign import ccall "libHS_cbits.so" "flushConnectedBuf" unsafe prim_flushConnectedBuf :: FILE_OBJ -> IO RC
+foreign import ccall "libHS_cbits.so" "getBufferMode" unsafe prim_getBufferMode :: FILE_OBJ -> IO RC
+foreign import ccall "libHS_cbits.so" "seekFile_int64" unsafe prim_seekFile_int64 :: FILE_OBJ -> Int -> Int64 -> IO RC
+foreign import ccall "libHS_cbits.so" "seekFileP" unsafe prim_seekFileP :: FILE_OBJ -> IO RC
+foreign import ccall "libHS_cbits.so" "setTerminalEcho" unsafe prim_setTerminalEcho :: FILE_OBJ -> Int -> IO RC
+foreign import ccall "libHS_cbits.so" "getTerminalEcho" unsafe prim_getTerminalEcho :: FILE_OBJ -> IO RC
+foreign import ccall "libHS_cbits.so" "isTerminalDevice" unsafe prim_isTerminalDevice :: FILE_OBJ -> IO RC
+foreign import ccall "libHS_cbits.so" "setConnectedTo" unsafe prim_setConnectedTo :: FILE_OBJ -> FILE_OBJ -> Int -> IO ()
+foreign import ccall "libHS_cbits.so" "ungetChar" unsafe prim_ungetChar :: FILE_OBJ -> Char -> IO RC
+foreign import ccall "libHS_cbits.so" "readChunk" unsafe prim_readChunk :: FILE_OBJ -> Addr -> Int -> IO RC
+foreign import ccall "libHS_cbits.so" "writeBuf" unsafe prim_writeBuf :: FILE_OBJ -> Addr -> Int -> IO RC
+foreign import ccall "libHS_cbits.so" "getFileFd" unsafe prim_getFileFd :: FILE_OBJ -> IO FD
+foreign import ccall "libHS_cbits.so" "fileSize_int64" unsafe prim_fileSize_int64 :: FILE_OBJ -> Bytes -> IO RC
+foreign import ccall "libHS_cbits.so" "getFilePosn" unsafe prim_getFilePosn :: FILE_OBJ -> IO Int
+foreign import ccall "libHS_cbits.so" "setFilePosn" unsafe prim_setFilePosn :: FILE_OBJ -> Int -> IO Int
+foreign import ccall "libHS_cbits.so" "getConnFileFd" unsafe prim_getConnFileFd :: FILE_OBJ -> IO FD
+foreign import ccall "libHS_cbits.so" "allocMemory__" unsafe prim_allocMemory__ :: Int -> IO Addr
+foreign import ccall "libHS_cbits.so" "getLock" unsafe prim_getLock :: FD -> Exclusive -> IO RC
+foreign import ccall "libHS_cbits.so" "openStdFile" unsafe prim_openStdFile :: FD -> OpenStdFlags -> Readable -> IO IOFileAddr
+foreign import ccall "libHS_cbits.so" "openFile" unsafe prim_openFile :: CString -> How -> Binary -> OpenFlags -> IO IOFileAddr
+foreign import ccall "libHS_cbits.so" "freeFileObject" unsafe prim_freeFileObject :: FILE_OBJ -> IO ()
+foreign import ccall "libHS_cbits.so" "freeStdFileObject" unsafe prim_freeStdFileObject :: FILE_OBJ -> IO ()
+foreign import ccall "libHS_cbits.so" "const_BUFSIZ" unsafe const_BUFSIZ :: Int
+
+foreign import ccall "libHS_cbits.so" "setConnNonBlockingIOFlag__" unsafe prim_setConnNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
+foreign import ccall "libHS_cbits.so" "clearConnNonBlockingIOFlag__" unsafe prim_clearConnNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
+foreign import ccall "libHS_cbits.so" "setNonBlockingIOFlag__" unsafe prim_setNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
+foreign import ccall "libHS_cbits.so" "clearNonBlockingIOFlag__" unsafe prim_clearNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
+
+foreign import ccall "libHS_cbits.so" "getErrStr__" unsafe prim_getErrStr__ :: IO Addr
+foreign import ccall "libHS_cbits.so" "getErrNo__" unsafe prim_getErrNo__ :: IO Int
+foreign import ccall "libHS_cbits.so" "getErrType__" unsafe prim_getErrType__ :: IO Int
+#endif
\end{code}
+
+
projects / ghc-hetmet.git / blobdiff