{-# 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
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
putMVar m h'
return ()
-augmentIOError (IOError _ iot _ str fp) fun h
- = IOError (Just h) iot fun str filepath
+augmentIOError :: IOException -> String -> Handle -> IOException
+augmentIOError ioe@IOError{ ioe_filename = fp } fun h
+ = ioe { ioe_handle = Just h, ioe_location = fun, ioe_filename = 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 :: String -> Handle -> (Handle__ -> IO a) -> IO a
wantSeekableHandle fun h@(DuplexHandle _ _ _) _act =
ioException (IOError (Just h) IllegalOperation fun
- "handle is not seekable" Nothing)
+ "handle is not seekable" Nothing Nothing)
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
ioe_closedHandle = ioException
(IOError Nothing IllegalOperation ""
- "handle is closed" Nothing)
+ "handle is closed" Nothing Nothing)
ioe_EOF = ioException
- (IOError Nothing EOF "" "" Nothing)
+ (IOError Nothing EOF "" "" Nothing Nothing)
ioe_notReadable = ioException
(IOError Nothing IllegalOperation ""
- "handle is not open for reading" Nothing)
+ "handle is not open for reading" Nothing Nothing)
ioe_notWritable = ioException
(IOError Nothing IllegalOperation ""
- "handle is not open for writing" Nothing)
+ "handle is not open for writing" Nothing Nothing)
ioe_notSeekable = ioException
(IOError Nothing IllegalOperation ""
- "handle is not seekable" Nothing)
+ "handle is not seekable" Nothing Nothing)
ioe_notSeekable_notBin = ioException
(IOError Nothing IllegalOperation ""
"seek operations on text-mode handles are not allowed on this platform"
- Nothing)
+ Nothing Nothing)
+ioe_finalizedHandle :: FilePath -> Handle__
ioe_finalizedHandle fp = throw
(IOError Nothing IllegalOperation ""
- "handle is finalized" (Just fp))
+ "handle is finalized" Nothing (Just fp))
ioe_bufsiz :: Int -> IO a
ioe_bufsiz n = ioException
(IOError Nothing InvalidArgument "hSetBuffering"
- ("illegal buffer size " ++ showsPrec 9 n []) Nothing)
+ ("illegal buffer size " ++ showsPrec 9 n []) Nothing Nothing)
-- 9 => should be parens'ified.
-- -----------------------------------------------------------------------------
-- ---------------------------------------------------------------------------
-- 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 fun fp (IOError h iot _ str _)
- = IOError h iot fun str (Just fp)
+addFilePathToIOError :: String -> FilePath -> IOException -> IOException
+addFilePathToIOError fun fp ioe
+ = ioe{ ioe_location = fun, ioe_filename = Just fp }
-- | Computation 'openFile' @file mode@ allocates and returns a new, open
-- handle to manage the file @file@. It manages input if @mode@
(openFile' fp m True)
(\e -> ioError (addFilePathToIOError "openBinaryFile" fp e))
+openFile' :: String -> IOMode -> Bool -> IO Handle
openFile' filepath mode binary =
withCString filepath $ \ f ->
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
case fd_type of
Directory ->
ioException (IOError Nothing InappropriateType "openFile"
- "is a directory" Nothing)
+ "is a directory" Nothing Nothing)
-- regular files need to be locked
RegularFile -> do
r <- lockFile fd dev ino (fromBool write)
when (r == -1) $
ioException (IOError Nothing ResourceBusy "openFile"
- "file is locked" Nothing)
+ "file is locked" Nothing Nothing)
#endif
mkFileHandle fd is_socket filepath ha_type binary
-- 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
maybe_exception)
{-# NOINLINE noBuffer #-}
+noBuffer :: Buffer
noBuffer = unsafePerformIO $ allocateBuffer 1 ReadBuffer
-----------------------------------------------------------------------------
if r /= -1
then return r
else ioException (IOError Nothing InappropriateType "hFileSize"
- "not a regular file" Nothing)
+ "not a regular file" Nothing Nothing)
-- | 'hSetFileSize' @hdl@ @size@ truncates the physical file with handle @hdl@ to @size@ bytes.
-- * '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
withHandle' "hDuplicateTo" h1 r1 (dupHandleTo (Just w1) r2_)
hDuplicateTo h1 _ =
ioException (IOError (Just h1) IllegalOperation "hDuplicateTo"
- "handles are incompatible" Nothing)
+ "handles are incompatible" Nothing Nothing)
-- ---------------------------------------------------------------------------
-- showing Handles.
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