X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FPrelHandle.lhs;h=401870d252aeaf12875f9fed7cd981114aab9772;hb=2ac43a29c516fbba15ced9c4480f94cd05dc39d5;hp=ee00d07cef35e163de4ad16f99fb1a6e5e6d8bd0;hpb=6bfd2f54231675165b3345689f41ab77db0bbba9;p=ghc-hetmet.git diff --git a/ghc/lib/std/PrelHandle.lhs b/ghc/lib/std/PrelHandle.lhs index ee00d07..401870d 100644 --- a/ghc/lib/std/PrelHandle.lhs +++ b/ghc/lib/std/PrelHandle.lhs @@ -1,5 +1,7 @@ +% ------------------------------------------------------------------------------ +% $Id: PrelHandle.lhs,v 1.67 2001/02/22 13:17:58 simonpj Exp $ % -% (c) The AQUA Project, Glasgow University, 1994-1996 +% (c) The AQUA Project, Glasgow University, 1994-2000 % \section[PrelHandle]{Module @PrelHandle@} @@ -9,112 +11,188 @@ which are supported for them. \begin{code} {-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-} -#include "error.h" - +#include "cbits/stgerror.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 PrelArr +import PrelBase +import PrelPtr +import PrelByteArr ( ByteArray(..) ) import PrelRead ( Read ) -import PrelList ( span ) +import PrelList ( break ) import PrelIOBase -import PrelTup -import PrelMaybe -import PrelBase -import PrelAddr -import PrelErr ( error ) -import PrelGHC -import Ix +import PrelMaybe ( Maybe(..) ) +import PrelException +import PrelEnum +import PrelNum ( toBig, Integer(..), Num(..), int2Integer ) +import PrelShow +import PrelReal ( toInteger ) +import PrelPack ( packString ) + +import PrelConc #ifndef __PARALLEL_HASKELL__ -import PrelForeign ( ForeignObj, makeForeignObj, writeForeignObj ) +import PrelForeign ( newForeignPtr, mkForeignPtr, addForeignPtrFinalizer ) #endif -import PrelConc -- concurrent only +#endif /* ndef(__HUGS__) */ + +#ifdef __HUGS__ +#define __CONCURRENT_HASKELL__ +#define stToIO id +#endif + +#ifndef __PARALLEL_HASKELL__ +#define FILE_OBJECT (ForeignPtr ()) +#else +#define FILE_OBJECT (Ptr ()) +#endif \end{code} +\begin{code} +mkBuffer__ :: FILE_OBJECT -> Int -> IO () +mkBuffer__ fo sz_in_bytes = do + chunk <- + case sz_in_bytes of + 0 -> return nullPtr -- this has the effect of overwriting the pointer to the old buffer. + _ -> do + chunk <- malloc sz_in_bytes + if chunk == nullPtr + then ioException (IOError Nothing ResourceExhausted + "mkBuffer__" "not enough virtual memory" Nothing) + else return chunk + setBuf fo chunk sz_in_bytes +\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 () - -#if defined(__CONCURRENT_HASKELL__) +newHandle :: Handle__ -> IO Handle -- Use MVars for concurrent Haskell newHandle hc = newMVar hc >>= \ h -> return (Handle h) +\end{code} + +%********************************************************* +%* * +\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. -readHandle (Handle h) = takeMVar h -writeHandle (Handle h) hc = putMVar h hc +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. -#else +There are three versions of @withHandle@: corresponding to the three +possible combinations of: --- Use ordinary MutableVars for non-concurrent Haskell -newHandle hc = stToIO (newVar hc >>= \ h -> - return (Handle h)) + - the operation may side-effect the handle + - the operation may return a result -readHandle (Handle h) = stToIO (readVar h) -writeHandle (Handle h) hc = stToIO (writeVar h hc) +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} +withHandle :: Handle -> (Handle__ -> IO (Handle__,a)) -> IO a +{-# INLINE withHandle #-} +withHandle (Handle h) act = + block $ 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 +{-# INLINE withHandle_ #-} +withHandle_ (Handle h) act = + block $ 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 () +{-# INLINE withHandle__ #-} +withHandle__ (Handle h) act = + block $ do + h_ <- takeMVar h + h' <- catchException (act h_) (\ ex -> putMVar h h_ >> throw ex) + putMVar h h' + return () +\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__ + unsafePerformIO (newForeignPtr nullPtr (return ())) +#else + nullPtr #endif + + +mkClosedHandle__ :: Handle__ +mkClosedHandle__ = + Handle__ { haFO__ = nullFile__, + haType__ = ClosedHandle, + haBufferMode__ = NoBuffering, + haFilePath__ = "closed file", + haBuffers__ = [] + } \end{code} %********************************************************* %* * -\subsection{Functions} +\subsection{Handle Finalizers} %* * %********************************************************* \begin{code} -#ifndef __PARALLEL_HASKELL__ -filePtr :: Handle__ -> ForeignObj -#else -filePtr :: Handle__ -> Addr -#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 +stdHandleFinalizer :: Handle -> IO () +stdHandleFinalizer (Handle hdl) = do + handle <- takeMVar hdl + let fo = haFO__ handle + freeStdFileObject fo + freeBuffers (haBuffers__ handle) + +handleFinalizer :: Handle -> IO () +handleFinalizer (Handle hdl) = do + handle <- takeMVar hdl + let fo = haFO__ handle + freeFileObject fo + freeBuffers (haBuffers__ handle) + +freeBuffers [] = return () +freeBuffers (b:bs) = do { free b; freeBuffers bs } + +foreign import "libHS_cbits" "freeStdFileObject" unsafe + freeStdFileObject :: FILE_OBJECT -> IO () +foreign import "libHS_cbits" "freeFileObject" unsafe + freeFileObject :: FILE_OBJECT -> IO () +foreign import "free" unsafe + free :: Ptr a -> IO () \end{code} -------------------------------------------- - %********************************************************* %* * \subsection[StdHandles]{Standard handles} @@ -126,52 +204,92 @@ two manage input or output from the Haskell program's standard input 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 <- getLock (1::Int) (1::Int) -- ConcHask: SAFE, won't block + case (rc::Int) of + 0 -> newHandle (mkClosedHandle__) 1 -> do + fo <- openStdFile (1::Int) + (0::Int){-writeable-} -- ConcHask: SAFE, won't block + #ifndef __PARALLEL_HASKELL__ - fp <- makeForeignObj (``stdin''::Addr) (``&freeStdFile''::Addr) - newHandle (ReadHandle fp Nothing False) + fo <- mkForeignPtr fo + -- I know this is deprecated, but I couldn't bring myself + -- to move fixIO into the prelude just so I could use + -- newForeignPtr. --SDM +#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) + hdl <- newHandle (Handle__ fo WriteHandle bm "stdout" []) + +#ifndef __PARALLEL_HASKELL__ + addForeignPtrFinalizer fo (stdHandleFinalizer hdl) +#endif + return hdl + + _ -> constructErrorAndFail "stdout" ) -stdout = unsafePerformIO (do - rc <- _ccall_ getLock (``stdout''::Addr) 1 - case rc of - 0 -> newHandle ClosedHandle +stdin = unsafePerformIO (do + rc <- getLock (0::Int) (0::Int) -- ConcHask: SAFE, won't block + case (rc::Int) of + 0 -> newHandle (mkClosedHandle__) 1 -> do + fo <- openStdFile (0::Int) + (1::Int){-readable-} -- ConcHask: SAFE, won't block + #ifndef __PARALLEL_HASKELL__ - fp <- makeForeignObj (``stdout''::Addr) (``&freeStdFile''::Addr) - newHandle (WriteHandle fp Nothing False) -#else - newHandle (WriteHandle ``stdout'' Nothing False) + fo <- mkForeignPtr 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. +#ifndef __PARALLEL_HASKELL__ + addForeignPtrFinalizer fo (stdHandleFinalizer hdl) #endif - _ -> do ioError <- constructError "stdout" - newHandle (ErrorHandle ioError) + hConnectTerms stdout hdl + return hdl + _ -> constructErrorAndFail "stdin" ) + stderr = unsafePerformIO (do - rc <- _ccall_ getLock (``stderr''::Addr) 1 - case rc of - 0 -> newHandle ClosedHandle + rc <- getLock (2::Int) (1::Int){-writeable-} -- ConcHask: SAFE, won't block + case (rc::Int) of + 0 -> newHandle (mkClosedHandle__) 1 -> do + fo <- openStdFile (2::Int) + (0::Int){-writeable-} -- ConcHask: SAFE, won't block + #ifndef __PARALLEL_HASKELL__ - fp <- makeForeignObj (``stderr''::Addr) (``&freeStdFile''::Addr) - newHandle (WriteHandle fp (Just NoBuffering) False) -#else - newHandle (WriteHandle ``stderr'' (Just NoBuffering) False) + fo <- mkForeignPtr 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. +#ifndef __PARALLEL_HASKELL__ + addForeignPtrFinalizer fo (stdHandleFinalizer hdl) #endif - _ -> do ioError <- constructError "stderr" - newHandle (ErrorHandle ioError) + hConnectTo stdout hdl + return hdl + + _ -> constructErrorAndFail "stderr" ) \end{code} @@ -196,31 +314,34 @@ openFile fp im = openFileEx fp (TextMode im) openFileEx :: FilePath -> IOModeEx -> IO Handle openFileEx f m = do - ptr <- _ccall_ openFile f m' - if ptr /= ``NULL'' then do + fo <- primOpenFile (packString f) + (file_mode::Int) + (binary::Int) -- ConcHask: SAFE, won't block + if fo /= nullPtr then do #ifndef __PARALLEL_HASKELL__ - fp <- makeForeignObj ptr ((``&freeFile'')::Addr) - newHandle (htype fp Nothing False) -#else - newHandle (htype ptr Nothing False) + fo <- mkForeignPtr fo +#endif + (bm, bf_size) <- getBMode__ fo + mkBuffer__ fo bf_size + hdl <- newHandle (Handle__ fo htype bm f []) +#ifndef __PARALLEL_HASKELL__ + addForeignPtrFinalizer fo (handleFinalizer hdl) #endif + return hdl 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' - - imo' = + file_mode = case imo of - ReadMode -> "r" - WriteMode -> "w" - AppendMode -> "a" - ReadWriteMode -> "r+" + AppendMode -> 0 + WriteMode -> 1 + ReadMode -> 2 + ReadWriteMode -> 3 htype = case imo of ReadMode -> ReadHandle @@ -256,55 +377,30 @@ implementation is free to impose stricter conditions. \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 - - 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" +hClose handle = + withHandle__ handle $ \ handle_ -> do + case haType__ handle_ of + ClosedHandle -> return handle_ + _ -> do + rc <- 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 ForeignPtr embedded in the Handle + is still lying around in the heap, so care is taken + to avoid closing the file object when the ForeignPtr + is finalized. (we overwrite the file ptr in the underlying + FileObject with a NULL as part of closeFile()) + -} + + if (rc /= 0) + then constructErrorAndFail "hClose" + + -- free the spare buffers (except the handle buffer) + -- associated with this handle. + else do freeBuffers (haBuffers__ handle_) + return (handle_{ haType__ = ClosedHandle, + haBuffers__ = [] }) \end{code} Computation $hClose hdl$ makes handle {\em hdl} closed. Before the @@ -313,7 +409,7 @@ sent to the operating system are flushed as for $flush$. %********************************************************* %* * -\subsection[EOF]{Detecting the End of Input} +\subsection[FileSize]{Detecting the size of a file} %* * %********************************************************* @@ -324,72 +420,56 @@ which can be read from {\em hdl}. \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 + ClosedHandle -> ioe_closedHandle "hFileSize" handle + SemiClosedHandle -> ioe_closedHandle "hFileSize" handle +#ifdef __HUGS__ + _ -> do + mem <- primNewByteArray 8{-sizeof_int64-} + rc <- 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 -- - -- For some reason, this fails to typecheck if converted to a do - -- 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 + case int2Integer# 1# of + (# s, d #) -> do + rc <- 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 +%********************************************************* +%* * +\subsection[EOF]{Detecting the End of Input} +%* * +%********************************************************* + + +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" + rc <- mayBlockRead "hIsEOF" handle fileEOF + case rc of + 0 -> return False + 1 -> return True + _ -> constructErrorAndFail "hIsEOF" isEOF :: IO Bool isEOF = hIsEOF stdin @@ -433,85 +513,60 @@ hSetBuffering :: Handle -> BufferMode -> IO () 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 -> ioException + (IOError (Just handle) + InvalidArgument + "hSetBuffering" + ("illegal buffer size " ++ showsPrec 9 n []) + -- 9 => should be parens'ified. + Nothing) + _ -> + withHandle__ handle $ \ handle_ -> do + case haType__ handle_ of + 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 (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 (flushFile fo) -- ConcHask: UNSAFE, may block + if rc == 0 then + return () + else + constructErrorAndFail "hFlush" + \end{code} @@ -522,115 +577,102 @@ hFlush handle = do %********************************************************* \begin{code} -data HandlePosn = HandlePosn Handle Int +data HandlePosn + = HandlePosn + Handle -- Q: should this be a weak or strong ref. to the handle? + -- [what's the winning argument for it not being strong? --sof] + HandlePosition + +instance Eq HandlePosn where + (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2 + + -- HandlePosition is the Haskell equivalent of POSIX' off_t. + -- We represent it as an Integer on the Haskell side, but + -- cheat slightly in that hGetPosn calls upon a C helper + -- that reports the position back via (merely) an Int. +type HandlePosition = Integer + +mkHandlePosn :: Handle -> HandlePosition -> HandlePosn +mkHandlePosn h p = HandlePosn h p 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 <- getFilePosn (haFO__ handle_) -- ConcHask: SAFE, won't block + if posn /= -1 then do + return (mkHandlePosn handle (int2Integer 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 i@(S# _)) = hSetPosn (HandlePosn handle (toBig i)) +hSetPosn (HandlePosn handle (J# s# d#)) = + 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 (setFilePosn fo (I# s#) d#) -- 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 -\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 -the current position. -\item[{\bf SeekToEnd}] The position of {\em hdl} is set to offset {\em 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} +The action @hSeek hdl mode i@ sets the position of handle +@hdl@ depending on @mode@. If @mode@ is + + * AbsoluteSeek - The position of @hdl@ is set to @i@. + * RelativeSeek - The position of @hdl@ is set to offset @i@ from + the current position. + * SeekFromEnd - The position of @hdl@ is set to offset @i@ from + the end of the file. -Some handles may not be seekable $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). +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 (seekFile 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 (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} %********************************************************* @@ -651,216 +693,97 @@ $( Just n )$ for block-buffering of {\em n} bytes. \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 + 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 + 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 + 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 + 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 + + +getBMode__ :: FILE_OBJECT -> IO (BufferMode, Int) +getBMode__ fo = do + rc <- 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 +\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 + 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 + ClosedHandle -> ioe_closedHandle "hIsSeekable" handle + SemiClosedHandle -> ioe_closedHandle "hIsSeekable" handle + AppendHandle -> return False + _ -> do + rc <- seekFileP (haFO__ handle_) -- ConcHask: SAFE, won't block + case (rc::Int) of 0 -> return False 1 -> return True _ -> constructErrorAndFail "hIsSeekable" @@ -869,83 +792,501 @@ hIsSeekable handle = do %********************************************************* %* * +\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 + ClosedHandle -> ioe_closedHandle "hSetEcho" handle + _ -> do + rc <- setTerminalEcho (haFO__ handle_) (if on then 1 else 0) -- 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 + ClosedHandle -> ioe_closedHandle "hGetEcho" handle + _ -> do + rc <- 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 + ClosedHandle -> ioe_closedHandle "hIsTerminalDevice" handle + _ -> do + rc <- 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 + setConnectedTo (haFO__ hR_) (haFO__ hW_) is_tty -- ConcHask: SAFE, won't block +\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 <- 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 (Ptr (), 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 <- malloc sz_i + if chunk == nullPtr + then do + hClose handle + constructErrorAndFail "slurpFile" + else do + rc <- withHandle_ handle ( \ handle_ -> do + let fo = haFO__ handle_ + mayBlock fo (readChunk fo chunk 0 sz_i) -- ConcHask: UNSAFE, may block. + ) + hClose handle + if rc < (0::Int) + then constructErrorAndFail "slurpFile" + else return (chunk, rc) + +\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 + ClosedHandle -> ioe_closedHandle "getHandleFd" handle + _ -> do + fd <- 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) = - case iot of - EOF -> "end of file" - _ -> str +ioeGetHandle (IOException (IOError h _ _ _ _)) = h +ioeGetHandle (UserError _) = Nothing +ioeGetHandle _ = error "IO.ioeGetHandle: not an IO error" -ioeGetFileName (IOError _ _ str) = - case span (/=':') str of - (fs,[]) -> Nothing - (fs,_) -> Just fs +ioeGetErrorString (IOException (IOError _ iot _ str _)) = + case iot of + EOF -> "end of file" + _ -> str +ioeGetErrorString (UserError str) = str +ioeGetErrorString _ = error "IO.ioeGetErrorString: not an IO error" +ioeGetFileName (IOException (IOError _ _ _ _ fn)) = fn +ioeGetFileName (UserError _) = Nothing +ioeGetFileName _ = error "IO.ioeGetFileName: not an IO error" \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 import ccall "addrOf_ErrorHdrHook" unsafe + addrOf_ErrorHdrHook :: Ptr () + +foreign import ccall "writeErrString__" unsafe + writeErrString :: Ptr () -> ByteArray Int -> Int -> IO () + +-- SUP: Are the hooks allowed to re-enter Haskell land? If yes, remove the unsafe below. +foreign import ccall "stackOverflow" unsafe + callStackOverflowHook :: IO () + +foreign import ccall "stg_exit" unsafe + 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 + ClosedHandle -> ioe_closedHandle fun handle + SemiClosedHandle -> ioe_closedHandle fun handle + AppendHandle -> ioException not_readable_error + WriteHandle -> ioException not_readable_error + _ -> act handle_ + where + not_readable_error = + IOError (Just handle) IllegalOperation fun + "handle is not open for reading" Nothing + +wantWriteableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a +wantWriteableHandle fun handle act = + withHandle_ handle $ \ handle_ -> + checkWriteableHandle fun handle handle_ (act handle_) + +wantWriteableHandle_ :: String -> Handle -> (Handle__ -> IO (Handle__, a)) -> IO a +wantWriteableHandle_ fun handle act = + withHandle handle $ \ handle_ -> + checkWriteableHandle fun handle handle_ (act handle_) + +checkWriteableHandle fun handle handle_ act + = case haType__ handle_ of + ClosedHandle -> ioe_closedHandle fun handle + SemiClosedHandle -> ioe_closedHandle fun handle + ReadHandle -> ioException not_writeable_error + _ -> act + where + not_writeable_error = + IOError (Just handle) IllegalOperation fun + "handle is not open for writing" Nothing + +wantRWHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a +wantRWHandle fun handle act = + withHandle_ handle $ \ handle_ -> do + case haType__ handle_ of + 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 + ClosedHandle -> ioe_closedHandle fun handle + SemiClosedHandle -> ioe_closedHandle fun handle + _ -> act handle_ +\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 = ioException (IOError (Just h) IllegalOperation fun + "handle is closed" Nothing) +\end{code} + +Internal helper functions for Concurrent Haskell implementation +of IO: + +\begin{code} +mayBlock :: FILE_OBJECT -> IO Int -> IO Int +mayBlock fo act = do + rc <- act + case rc of + -5 -> do -- (possibly blocking) read + fd <- getFileFd fo + threadWaitRead fd + mayBlock fo act -- input available, re-try + -6 -> do -- (possibly blocking) write + fd <- getFileFd fo + threadWaitWrite fd + mayBlock fo act -- output possible + -7 -> do -- (possibly blocking) write on connected handle + fd <- getConnFileFd fo + threadWaitWrite fd + mayBlock fo act -- output possible + _ -> do + return rc + +data MayBlock a + = BlockRead Int + | BlockWrite Int + | NoBlock a + +mayBlockRead :: String -> Handle -> (FILE_OBJECT -> IO Int) -> IO Int +mayBlockRead fname handle fn = do + r <- wantReadableHandle fname handle $ \ handle_ -> do + let fo = haFO__ handle_ + rc <- fn fo + case rc of + -5 -> do -- (possibly blocking) read + fd <- getFileFd fo + return (BlockRead fd) + -6 -> do -- (possibly blocking) write + fd <- getFileFd fo + return (BlockWrite fd) + -7 -> do -- (possibly blocking) write on connected handle + fd <- getConnFileFd fo + return (BlockWrite fd) + _ -> + if rc >= 0 + then return (NoBlock rc) + else constructErrorAndFail fname + case r of + BlockRead fd -> do + threadWaitRead fd + mayBlockRead fname handle fn + BlockWrite fd -> do + threadWaitWrite fd + mayBlockRead fname handle fn + NoBlock c -> return c + +mayBlockRead' :: String -> Handle + -> (FILE_OBJECT -> IO Int) + -> (FILE_OBJECT -> Int -> IO a) + -> IO a +mayBlockRead' fname handle fn io = do + r <- wantReadableHandle fname handle $ \ handle_ -> do + let fo = haFO__ handle_ + rc <- fn fo + case rc of + -5 -> do -- (possibly blocking) read + fd <- getFileFd fo + return (BlockRead fd) + -6 -> do -- (possibly blocking) write + fd <- getFileFd fo + return (BlockWrite fd) + -7 -> do -- (possibly blocking) write on connected handle + fd <- getConnFileFd fo + return (BlockWrite fd) + _ -> + if rc >= 0 + then do a <- io fo rc + return (NoBlock a) + else constructErrorAndFail fname + case r of + BlockRead fd -> do + threadWaitRead fd + mayBlockRead' fname handle fn io + BlockWrite fd -> do + threadWaitWrite fd + mayBlockRead' fname handle fn io + NoBlock c -> return c + +mayBlockWrite :: String -> Handle -> (FILE_OBJECT -> IO Int) -> IO Int +mayBlockWrite fname handle fn = do + r <- wantWriteableHandle fname handle $ \ handle_ -> do + let fo = haFO__ handle_ + rc <- fn fo + case rc of + -5 -> do -- (possibly blocking) read + fd <- getFileFd fo + return (BlockRead fd) + -6 -> do -- (possibly blocking) write + fd <- getFileFd fo + return (BlockWrite fd) + -7 -> do -- (possibly blocking) write on connected handle + fd <- getConnFileFd fo + return (BlockWrite fd) + _ -> + if rc >= 0 + then return (NoBlock rc) + else constructErrorAndFail fname + case r of + BlockRead fd -> do + threadWaitRead fd + mayBlockWrite fname handle fn + BlockWrite fd -> do + threadWaitWrite fd + mayBlockWrite fname handle fn + NoBlock c -> return c +\end{code} + +Foreign import declarations of helper functions: + +\begin{code} + +#ifdef __HUGS__ +type Bytes = PrimByteArray RealWorld +#else +type Bytes = ByteArray# +#endif + +foreign import "libHS_cbits" "inputReady" unsafe + inputReady :: FILE_OBJECT -> Int -> IO Int{-ret code-} +foreign import "libHS_cbits" "fileGetc" unsafe + fileGetc :: FILE_OBJECT -> IO Int +foreign import "libHS_cbits" "fileLookAhead" unsafe + fileLookAhead :: FILE_OBJECT -> IO Int +foreign import "libHS_cbits" "readBlock" unsafe + readBlock :: FILE_OBJECT -> IO Int +foreign import "libHS_cbits" "readLine" unsafe + readLine :: FILE_OBJECT -> IO Int +foreign import "libHS_cbits" "readChar" unsafe + readChar :: FILE_OBJECT -> IO Int +foreign import "libHS_cbits" "writeFileObject" unsafe + writeFileObject :: FILE_OBJECT -> Int -> IO Int{-ret code-} +foreign import "libHS_cbits" "filePutc" unsafe + filePutc :: FILE_OBJECT -> Char -> IO Int{-ret code-} +foreign import "libHS_cbits" "write_" unsafe + write_ :: FILE_OBJECT -> Ptr () -> Int -> IO Int{-ret code-} +foreign import "libHS_cbits" "getBufStart" unsafe + getBufStart :: FILE_OBJECT -> Int -> IO (Ptr ()) +foreign import "libHS_cbits" "getWriteableBuf" unsafe + getWriteableBuf :: FILE_OBJECT -> IO (Ptr ()) +foreign import "libHS_cbits" "getBuf" unsafe + getBuf :: FILE_OBJECT -> IO (Ptr ()) +foreign import "libHS_cbits" "getBufWPtr" unsafe + getBufWPtr :: FILE_OBJECT -> IO Int +foreign import "libHS_cbits" "setBufWPtr" unsafe + setBufWPtr :: FILE_OBJECT -> Int -> IO () +foreign import "libHS_cbits" "closeFile" unsafe + closeFile :: FILE_OBJECT -> Int{-Flush-} -> IO Int{-ret code-} +foreign import "libHS_cbits" "fileEOF" unsafe + fileEOF :: FILE_OBJECT -> IO Int{-ret code-} +foreign import "libHS_cbits" "setBuffering" unsafe + setBuffering :: FILE_OBJECT -> Int -> IO Int{-ret code-} +foreign import "libHS_cbits" "flushFile" unsafe + flushFile :: FILE_OBJECT -> IO Int{-ret code-} +foreign import "libHS_cbits" "flushConnectedBuf" unsafe + flushConnectedBuf :: FILE_OBJECT -> IO () +foreign import "libHS_cbits" "getBufferMode" unsafe + getBufferMode :: FILE_OBJECT -> IO Int{-ret code-} +#ifdef __HUGS__ +foreign import "libHS_cbits" "seekFile_int64" unsafe + seekFile :: FILE_OBJECT -> Int -> Int64 -> IO Int +#else +foreign import "libHS_cbits" "seekFile" unsafe + seekFile :: FILE_OBJECT -> Int -> Int -> Bytes -> IO Int +#endif + +foreign import "libHS_cbits" "seekFileP" unsafe + seekFileP :: FILE_OBJECT -> IO Int{-ret code-} +foreign import "libHS_cbits" "setTerminalEcho" unsafe + setTerminalEcho :: FILE_OBJECT -> Int -> IO Int{-ret code-} +foreign import "libHS_cbits" "getTerminalEcho" unsafe + getTerminalEcho :: FILE_OBJECT -> IO Int{-ret code-} +foreign import "libHS_cbits" "isTerminalDevice" unsafe + isTerminalDevice :: FILE_OBJECT -> IO Int{-ret code-} +foreign import "libHS_cbits" "setConnectedTo" unsafe + setConnectedTo :: FILE_OBJECT -> FILE_OBJECT -> Int -> IO () +foreign import "libHS_cbits" "ungetChar" unsafe + ungetChar :: FILE_OBJECT -> Char -> IO Int{-ret code-} +foreign import "libHS_cbits" "readChunk" unsafe + readChunk :: FILE_OBJECT -> Ptr a -> Int -> Int -> IO Int{-ret code-} +foreign import "libHS_cbits" "getFileFd" unsafe + getFileFd :: FILE_OBJECT -> IO Int{-fd-} +#ifdef __HUGS__ +foreign import "libHS_cbits" "fileSize_int64" unsafe + fileSize_int64 :: FILE_OBJECT -> Bytes -> IO Int{-ret code-} +#else +foreign import "libHS_cbits" "fileSize" unsafe + fileSize :: FILE_OBJECT -> Bytes -> IO Int{-ret code-} +#endif +foreign import "libHS_cbits" "getFilePosn" unsafe + getFilePosn :: FILE_OBJECT -> IO Int +foreign import "libHS_cbits" "setFilePosn" unsafe + setFilePosn :: FILE_OBJECT -> Int -> ByteArray# -> IO Int +foreign import "libHS_cbits" "getConnFileFd" unsafe + getConnFileFd :: FILE_OBJECT -> IO Int{-fd-} +foreign import "libHS_cbits" "getLock" unsafe + getLock :: Int{-Fd-} -> Int{-exclusive-} -> IO Int{-return code-} +foreign import "libHS_cbits" "openStdFile" unsafe + openStdFile :: Int{-fd-} + -> Int{-Readable?-} + -> IO (Ptr ()){-file object-} +foreign import "libHS_cbits" "openFile" unsafe + primOpenFile :: ByteArray Int{-CString-} + -> Int{-How-} + -> Int{-Binary-} + -> IO (Ptr ()){-file object-} +foreign import "libHS_cbits" "const_BUFSIZ" unsafe + const_BUFSIZ :: Int + +foreign import "libHS_cbits" "setBinaryMode__" unsafe + setBinaryMode :: FILE_OBJECT -> Int -> IO Int \end{code}