{-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-}
+{-# OPTIONS_GHC -fno-warn-unused-matches #-}
+{-# OPTIONS_GHC -fno-warn-unused-binds #-}
{-# OPTIONS_HADDOCK hide #-}
#undef DEBUG_DUMP
stdin, stdout, stderr,
IOMode(..), openFile, openBinaryFile, fdToHandle_stat, fdToHandle, fdToHandle',
- hFileSize, hSetFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode,
+ hFileSize, hSetFileSize, hIsEOF, isEOF, hLookAhead, hLookAhead', hSetBuffering, hSetBinaryMode,
hFlush, hDuplicate, hDuplicateTo,
hClose, hClose_help,
) where
import Control.Monad
-import Data.Bits
import Data.Maybe
import Foreign
import Foreign.C
import GHC.IOBase
import GHC.Exception
import GHC.Enum
-import GHC.Num ( Integer(..), Num(..) )
+import GHC.Num ( Integer, Num(..) )
import GHC.Show
-import GHC.Real ( toInteger )
#if defined(DEBUG_DUMP)
import GHC.Pack
#endif
-- Are files opened by default in text or binary mode, if the user doesn't
-- specify?
-dEFAULT_OPEN_IN_BINARY_MODE = False :: Bool
+dEFAULT_OPEN_IN_BINARY_MODE :: Bool
+dEFAULT_OPEN_IN_BINARY_MODE = False
-- ---------------------------------------------------------------------------
-- Creating a new handle
block $ do
h_ <- takeMVar m
checkBufferInvariants h_
- (h',v) <- catchException (act h_)
- (\ err -> putMVar m h_ >>
- case err of
- IOException ex -> ioError (augmentIOError ex fun h)
- _ -> throw err)
+ (h',v) <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err)
+ `catchException` \ex -> ioError (augmentIOError ex fun h)
checkBufferInvariants h'
putMVar m h'
return v
block $ do
h_ <- takeMVar m
checkBufferInvariants h_
- v <- catchException (act h_)
- (\ err -> putMVar m h_ >>
- case err of
- IOException ex -> ioError (augmentIOError ex fun h)
- _ -> throw err)
+ v <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err)
+ `catchException` \ex -> ioError (augmentIOError ex fun h)
checkBufferInvariants h_
putMVar m h_
return v
withHandle__' fun h r act
withHandle__' fun h w act
+withHandle__' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO Handle__)
+ -> IO ()
withHandle__' fun h m act =
block $ do
h_ <- takeMVar m
checkBufferInvariants h_
- h' <- catchException (act h_)
- (\ err -> putMVar m h_ >>
- case err of
- IOException ex -> ioError (augmentIOError ex fun h)
- _ -> throw err)
+ h' <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err)
+ `catchException` \ex -> ioError (augmentIOError ex fun h)
checkBufferInvariants h'
putMVar m h'
return ()
+augmentIOError :: IOException -> String -> Handle -> IOException
augmentIOError (IOError _ iot _ str fp) fun h
= IOError (Just h) iot fun str filepath
where filepath
| Just _ <- fp = fp
| otherwise = case h of
- FileHandle fp _ -> Just fp
- DuplexHandle fp _ _ -> Just fp
+ FileHandle path _ -> Just path
+ DuplexHandle path _ _ -> Just path
-- ---------------------------------------------------------------------------
-- Wrapper for write operations.
wantWritableHandle' fun h m act
= withHandle_' fun h m (checkWritableHandle act)
+checkWritableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a
checkWritableHandle act handle_
= case haType handle_ of
ClosedHandle -> ioe_closedHandle
wantReadableHandle' fun h m act
= withHandle_' fun h m (checkReadableHandle act)
+checkReadableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a
checkReadableHandle act handle_ =
case haType handle_ of
ClosedHandle -> ioe_closedHandle
wantSeekableHandle fun h@(FileHandle _ m) act =
withHandle_' fun h m (checkSeekableHandle act)
+checkSeekableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a
checkSeekableHandle act handle_ =
case haType handle_ of
ClosedHandle -> ioe_closedHandle
"seek operations on text-mode handles are not allowed on this platform"
Nothing)
-ioe_finalizedHandle fp = throw (IOException
+ioe_finalizedHandle :: FilePath -> Handle__
+ioe_finalizedHandle fp = throw
(IOError Nothing IllegalOperation ""
- "handle is finalized" (Just fp)))
+ "handle is finalized" (Just fp))
ioe_bufsiz :: Int -> IO a
ioe_bufsiz n = ioException
handle_ <- takeMVar m
case haType handle_ of
ClosedHandle -> return ()
- _ -> do flushWriteBufferOnly handle_ `catchException` \_ -> return ()
+ _ -> do flushWriteBufferOnly handle_ `catchAny` \_ -> return ()
-- ignore errors and async exceptions, and close the
-- descriptor anyway...
hClose_handle_ handle_
-- ---------------------------------------------------------------------------
-- Grimy buffer operations
+checkBufferInvariants :: Handle__ -> IO ()
#ifdef DEBUG
checkBufferInvariants h_ = do
let ref = haBuffer h_
then error "buffer invariant violation"
else return ()
#else
-checkBufferInvariants h_ = return ()
+checkBufferInvariants _ = return ()
#endif
newEmptyBuffer :: RawBuffer -> BufferState -> Int -> Buffer
allocateBuffer sz@(I# size) state = IO $ \s ->
-- We sometimes need to pass the address of this buffer to
-- a "safe" foreign call, hence it must be immovable.
- case newPinnedByteArray# size s of { (# s, b #) ->
- (# s, newEmptyBuffer b state sz #) }
+ case newPinnedByteArray# size s of { (# s', b #) ->
+ (# s', newEmptyBuffer b state sz #) }
writeCharIntoBuffer :: RawBuffer -> Int -> Char -> IO Int
writeCharIntoBuffer slab (I# off) (C# c)
= IO $ \s -> case writeCharArray# slab off c s of
- s -> (# s, I# (off +# 1#) #)
+ s' -> (# s', I# (off +# 1#) #)
readCharFromBuffer :: RawBuffer -> Int -> IO (Char, Int)
readCharFromBuffer slab (I# off)
= IO $ \s -> case readCharArray# slab off s of
- (# s, c #) -> (# s, (C# c, I# (off +# 1#)) #)
+ (# s', c #) -> (# s', (C# c, I# (off +# 1#)) #)
getBuffer :: FD -> BufferState -> IO (IORef Buffer, BufferMode)
getBuffer fd state = do
-- appears to be what GHC has done for a long time, and I suspect it
-- is more useful than line buffering in most cases.
+fillReadBufferLoop :: FD -> Bool -> Bool -> Buffer -> RawBuffer -> Int -> Int
+ -> IO Buffer
fillReadBufferLoop fd is_line is_stream buf b w size = do
let bytes = size - w
if bytes == 0 -- buffer full?
readRawBufferPtrNoBlock = readRawBufferPtr
-- Async versions of the read/write primitives, for the non-threaded RTS
+asyncReadRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt
+ -> IO CInt
asyncReadRawBuffer loc fd is_stream buf off len = do
(l, rc) <- asyncReadBA (fromIntegral fd) (if is_stream then 1 else 0)
(fromIntegral len) off buf
ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
else return (fromIntegral l)
+asyncReadRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt
+ -> IO CInt
asyncReadRawBufferPtr loc fd is_stream buf off len = do
(l, rc) <- asyncRead (fromIntegral fd) (if is_stream then 1 else 0)
(fromIntegral len) (buf `plusPtr` off)
ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
else return (fromIntegral l)
+asyncWriteRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt
+ -> IO CInt
asyncWriteRawBuffer loc fd is_stream buf off len = do
(l, rc) <- asyncWriteBA (fromIntegral fd) (if is_stream then 1 else 0)
(fromIntegral len) off buf
ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
else return (fromIntegral l)
+asyncWriteRawBufferPtr :: String -> FD -> Bool -> CString -> Int -> CInt
+ -> IO CInt
asyncWriteRawBufferPtr loc fd is_stream buf off len = do
(l, rc) <- asyncWrite (fromIntegral fd) (if is_stream then 1 else 0)
(fromIntegral len) (buf `plusPtr` off)
-- Blocking versions of the read/write primitives, for the threaded RTS
+blockingReadRawBuffer :: String -> CInt -> Bool -> RawBuffer -> Int -> CInt
+ -> IO CInt
blockingReadRawBuffer loc fd True buf off len =
throwErrnoIfMinus1Retry loc $
safe_recv_rawBuffer fd buf off len
throwErrnoIfMinus1Retry loc $
safe_read_rawBuffer fd buf off len
+blockingReadRawBufferPtr :: String -> CInt -> Bool -> CString -> Int -> CInt
+ -> IO CInt
blockingReadRawBufferPtr loc fd True buf off len =
throwErrnoIfMinus1Retry loc $
safe_recv_off fd buf off len
throwErrnoIfMinus1Retry loc $
safe_read_off fd buf off len
+blockingWriteRawBuffer :: String -> CInt -> Bool -> RawBuffer -> Int -> CInt
+ -> IO CInt
blockingWriteRawBuffer loc fd True buf off len =
throwErrnoIfMinus1Retry loc $
safe_send_rawBuffer fd buf off len
throwErrnoIfMinus1Retry loc $
safe_write_rawBuffer fd buf off len
+blockingWriteRawBufferPtr :: String -> CInt -> Bool -> CString -> Int -> CInt
+ -> IO CInt
blockingWriteRawBufferPtr loc fd True buf off len =
throwErrnoIfMinus1Retry loc $
safe_send_off fd buf off len
-- or output channel respectively. The third manages output to the
-- standard error channel. These handles are initially open.
-fd_stdin = 0 :: FD
-fd_stdout = 1 :: FD
-fd_stderr = 2 :: FD
+fd_stdin, fd_stdout, fd_stderr :: FD
+fd_stdin = 0
+fd_stdout = 1
+fd_stderr = 2
-- | A handle managing input from the Haskell program's standard input channel.
stdin :: Handle
-- ---------------------------------------------------------------------------
-- Opening and Closing Files
+addFilePathToIOError :: String -> FilePath -> IOException -> IOException
addFilePathToIOError fun fp (IOError h iot _ str _)
= IOError h iot fun str (Just fp)
(openFile' fp m True)
(\e -> ioError (addFilePathToIOError "openBinaryFile" fp e))
+openFile' :: String -> IOMode -> Bool -> IO Handle
openFile' filepath mode binary =
withCString filepath $ \ f ->
stat@(fd_type,_,_) <- fdStat fd
h <- fdToHandle_stat fd (Just stat) False filepath mode binary
- `catchException` \e -> do c_close fd; throw e
+ `catchAny` \e -> do c_close fd; throw e
-- NB. don't forget to close the FD if fdToHandle' fails, otherwise
-- this FD leaks.
-- ASSERT: if we just created the file, then fdToHandle' won't fail
return h
+std_flags, output_flags, read_flags, write_flags, rw_flags,
+ append_flags :: CInt
std_flags = o_NONBLOCK .|. o_NOCTTY
output_flags = std_flags .|. o_CREAT
read_flags = std_flags .|. o_RDONLY
-- turn off buffering. We don't correctly handle the case of switching
-- from read mode to write mode on a buffered text-mode handle, see bug
-- \#679.
- bmode <- case ha_type of
- ReadWriteHandle | not binary -> return NoBuffering
- _other -> return bmode
+ bmode2 <- case ha_type of
+ ReadWriteHandle | not binary -> return NoBuffering
+ _other -> return bmode
+#else
+ let bmode2 = bmode
#endif
spares <- newIORef BufferListNil
haType = ha_type,
haIsBin = binary,
haIsStream = is_stream,
- haBufferMode = bmode,
+ haBufferMode = bmode2,
haBuffer = buf,
haBuffers = spares,
haOtherSide = Nothing
addMVarFinalizer write_side (handleFinalizer filepath write_side)
return (DuplexHandle filepath read_side write_side)
-
+initBufferState :: HandleType -> BufferState
initBufferState ReadHandle = ReadBuffer
initBufferState _ = WriteBuffer
Nothing -> return ()
Just e -> throwIO e
+hClose' :: Handle -> MVar Handle__ -> IO (Maybe SomeException)
hClose' h m = withHandle' "hClose" h m $ hClose_help
-- hClose_help is also called by lazyRead (in PrelIO) when EOF is read
-- then closed immediately. We have to be careful with DuplexHandles
-- though: we have to leave the closing to the finalizer in that case,
-- because the write side may still be in use.
-hClose_help :: Handle__ -> IO (Handle__, Maybe Exception)
+hClose_help :: Handle__ -> IO (Handle__, Maybe SomeException)
hClose_help handle_ =
case haType handle_ of
ClosedHandle -> return (handle_,Nothing)
_ -> do flushWriteBufferOnly handle_ -- interruptible
hClose_handle_ handle_
+hClose_handle_ :: Handle__ -> IO (Handle__, Maybe SomeException)
hClose_handle_ handle_ = do
let fd = haFD handle_
maybe_exception)
{-# NOINLINE noBuffer #-}
+noBuffer :: Buffer
noBuffer = unsafePerformIO $ allocateBuffer 1 ReadBuffer
-----------------------------------------------------------------------------
-- * 'isEOFError' if the end of file has been reached.
hLookAhead :: Handle -> IO Char
-hLookAhead handle = do
- wantReadableHandle "hLookAhead" handle $ \handle_ -> do
+hLookAhead handle =
+ wantReadableHandle "hLookAhead" handle hLookAhead'
+
+hLookAhead' :: Handle__ -> IO Char
+hLookAhead' handle_ = do
let ref = haBuffer handle_
fd = haFD handle_
- is_line = haBufferMode handle_ == LineBuffering
buf <- readIORef ref
-- fill up the read buffer if necessary
new_buf <- if bufferEmpty buf
then fillReadBuffer fd True (haIsStream handle_) buf
else return buf
-
+
writeIORef ref new_buf
(c,_) <- readCharFromBuffer (bufBuf buf) (bufRPtr buf)
Just r -> withHandle_' "dupHandle" h r (return . haFD)
dupHandle_ other_side h_ new_fd
+dupHandleTo :: Maybe (MVar Handle__) -> Handle__ -> Handle__
+ -> IO (Handle__, Handle__)
dupHandleTo other_side hto_ h_ = do
flushBuffer h_
-- Windows' dup2 does not return the new descriptor, unlike Unix
hShow h@(FileHandle path _) = showHandle' path False h
hShow h@(DuplexHandle path _ _) = showHandle' path True h
+showHandle' :: String -> Bool -> Handle -> IO String
showHandle' filepath is_duplex h =
withHandle_ "showHandle" h $ \hdl_ ->
let
projects / ghc-base.git / blobdiff