<commit_before>{-# OPTIONS_GHC -fno-implicit-prelude -#include "HsBase.h" #-}
{-# OPTIONS_HADDOCK hide #-}

#undef DEBUG_DUMP
#undef DEBUG

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.Handle
-- Copyright   :  (c) The University of Glasgow, 1994-2001
-- License     :  see libraries/base/LICENSE
-- 
-- Maintainer  :  <EMAIL>
-- Stability   :  internal
-- Portability :  non-portable
--
-- This module defines the basic operations on I\/O \"handles\".
--
-----------------------------------------------------------------------------

-- #hide
module GHC.Handle (
  withHandle, withHandle', withHandle_,
  wantWritableHandle, wantReadableHandle, wantSeekableHandle,

  newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer,
  flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer,
  fillReadBuffer, fillReadBufferWithoutBlocking,
  readRawBuffer, readRawBufferPtr,
  readRawBufferNoBlock, readRawBufferPtrNoBlock,
  writeRawBuffer, writeRawBufferPtr,

#ifndef mingw32_HOST_OS
  unlockFile,
#endif

  ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,

  stdin, stdout, stderr,
  IOMode(..), openFile, openBinaryFile, fdToHandle_stat, fdToHandle, fdToHandle',
  hFileSize, hSetFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode,
  hFlush, hDuplicate, hDuplicateTo,

  hClose, hClose_help,

  HandlePosition, HandlePosn(..), hGetPosn, hSetPosn,
  SeekMode(..), hSeek, hTell,

  hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable,
  hSetEcho, hGetEcho, hIsTerminalDevice,

  hShow,

#ifdef DEBUG_DUMP
  puts,
#endif

 ) where

import Control.Monad
import Data.Bits
import Data.Maybe
import Foreign
import Foreign.C
import System.IO.Error
import System.Posix.Internals
import System.Posix.Types

import GHC.Real

import GHC.Arr
import GHC.Base
import GHC.Read         ( Read )
import GHC.List
import GHC.IOBase
import GHC.Exception
import GHC.Enum
import GHC.Num          ( Integer(..), Num(..) )
import GHC.Show
import GHC.Real         ( toInteger )
#if defined(DEBUG_DUMP)
import GHC.Pack
#endif

import GHC.Conc

-- -----------------------------------------------------------------------------
-- TODO:

-- hWaitForInput blocks (should use a timeout)

-- unbuffered hGetLine is a bit dodgy

-- hSetBuffering: can't change buffering on a stream, 
--      when the read buffer is non-empty? (no way to flush the buffer)

-- ---------------------------------------------------------------------------
-- Are files opened by default in text or binary mode, if the user doesn't
-- specify?

dEFAULT_OPEN_IN_BINARY_MODE = False :: Bool

-- ---------------------------------------------------------------------------
-- Creating a new handle

newFileHandle :: FilePath -> (MVar Handle__ -> IO ()) -> Handle__ -> IO Handle
newFileHandle filepath finalizer hc = do
  m <- newMVar hc
  addMVarFinalizer m (finalizer m)
  return (FileHandle filepath m)

-- ---------------------------------------------------------------------------
-- Working with Handles

{-
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
original handle is always replaced [ this is the case at the moment,
but we might want to revisit this in the future --SDM ].
-}

{-# INLINE withHandle #-}
withHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
withHandle fun h@(FileHandle _ m)     act = withHandle' fun h m act
withHandle fun h@(DuplexHandle _ m _) act = withHandle' fun h m act

withHandle' :: String -> Handle -> MVar Handle__
   -> (Handle__ -> IO (Handle__,a)) -> IO a
withHandle' fun h m act =
   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)
   checkBufferInvariants h'
   putMVar m h'
   return v

{-# INLINE withHandle_ #-}
withHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a
withHandle_ fun h@(FileHandle _ m)     act = withHandle_' fun h m act
withHandle_ fun h@(DuplexHandle _ m _) act = withHandle_' fun h m act

withHandle_' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO a) -> IO a
withHandle_' fun h m act =
   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)
   checkBufferInvariants h_
   putMVar m h_
   return v

withAllHandles__ :: String -> Handle -> (Handle__ -> IO Handle__) -> IO ()
withAllHandles__ fun h@(FileHandle _ m)     act = withHandle__' fun h m act
withAllHandles__ fun h@(DuplexHandle _ r w) act = do
  withHandle__' fun h r act
  withHandle__' fun h w act

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)
   checkBufferInvariants h'
   putMVar m h'
   return ()

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

-- ---------------------------------------------------------------------------
-- Wrapper for write operations.

wantWritableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
wantWritableHandle fun h@(FileHandle _ m) act
  = wantWritableHandle' fun h m act
wantWritableHandle fun h@(DuplexHandle _ _ m) act
  = wantWritableHandle' fun h m act
  -- ToDo: in the Duplex case, we don't need to checkWritableHandle

wantWritableHandle'
        :: String -> Handle -> MVar Handle__
        -> (Handle__ -> IO a) -> IO a
wantWritableHandle' fun h m act
   = withHandle_' fun h m (checkWritableHandle act)

checkWritableHandle act handle_
  = case haType handle_ of
      ClosedHandle         -> ioe_closedHandle
      SemiClosedHandle     -> ioe_closedHandle
      ReadHandle           -> ioe_notWritable
      ReadWriteHandle      -> do
                let ref = haBuffer handle_
                buf <- readIORef ref
                new_buf <-
                  if not (bufferIsWritable buf)
                     then do b <- flushReadBuffer (haFD handle_) buf
                             return b{ bufState=WriteBuffer }
                     else return buf
                writeIORef ref new_buf
                act handle_
      _other               -> act handle_

-- ---------------------------------------------------------------------------
-- Wrapper for read operations.

wantReadableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
wantReadableHandle fun h@(FileHandle  _ m)   act
  = wantReadableHandle' fun h m act
wantReadableHandle fun h@(DuplexHandle _ m _) act
  = wantReadableHandle' fun h m act
  -- ToDo: in the Duplex case, we don't need to checkReadableHandle

wantReadableHandle'
        :: String -> Handle -> MVar Handle__
        -> (Handle__ -> IO a) -> IO a
wantReadableHandle' fun h m act
  = withHandle_' fun h m (checkReadableHandle act)

checkReadableHandle act handle_ =
    case haType handle_ of
      ClosedHandle         -> ioe_closedHandle
      SemiClosedHandle     -> ioe_closedHandle
      AppendHandle         -> ioe_notReadable
      WriteHandle          -> ioe_notReadable
      ReadWriteHandle      -> do
        let ref = haBuffer handle_
        buf <- readIORef ref
        when (bufferIsWritable buf) $ do
           new_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
           writeIORef ref new_buf{ bufState=ReadBuffer }
        act handle_
      _other               -> act handle_

-- ---------------------------------------------------------------------------
-- Wrapper for seek operations.

wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
wantSeekableHandle fun h@(DuplexHandle _ _ _) _act =
  ioException (IOError (Just h) IllegalOperation fun
                   "handle is not seekable" Nothing)
wantSeekableHandle fun h@(FileHandle _ m) act =
  withHandle_' fun h m (checkSeekableHandle act)

checkSeekableHandle act handle_ =
    case haType handle_ of
      ClosedHandle      -> ioe_closedHandle
      SemiClosedHandle  -> ioe_closedHandle
      AppendHandle      -> ioe_notSeekable
      _  | haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED -> act handle_
         | otherwise                                 -> ioe_notSeekable_notBin

-- -----------------------------------------------------------------------------
-- Handy IOErrors

ioe_closedHandle, ioe_EOF,
  ioe_notReadable, ioe_notWritable,
  ioe_notSeekable, ioe_notSeekable_notBin :: IO a

ioe_closedHandle = ioException
   (IOError Nothing IllegalOperation ""
        "handle is closed" Nothing)
ioe_EOF = ioException
   (IOError Nothing EOF "" "" Nothing)
ioe_notReadable = ioException
   (IOError Nothing IllegalOperation ""
        "handle is not open for reading" Nothing)
ioe_notWritable = ioException
   (IOError Nothing IllegalOperation ""
        "handle is not open for writing" Nothing)
ioe_notSeekable = ioException
   (IOError Nothing IllegalOperation ""
        "handle is not seekable" Nothing)
ioe_notSeekable_notBin = ioException
   (IOError Nothing IllegalOperation ""
      "seek operations on text-mode handles are not allowed on this platform"
        Nothing)

ioe_finalizedHandle fp = throw (IOException
   (IOError Nothing IllegalOperation ""
        "handle is finalized" (Just fp)))

ioe_bufsiz :: Int -> IO a
ioe_bufsiz n = ioException
   (IOError Nothing InvalidArgument "hSetBuffering"
        ("illegal buffer size " ++ showsPrec 9 n []) Nothing)
                                -- 9 => should be parens'ified.

-- -----------------------------------------------------------------------------
-- Handle Finalizers

-- For a duplex handle, we arrange that the read side points to the write side
-- (and hence keeps it alive if the read side is alive).  This is done by
-- having the haOtherSide field of the read side point to the read side.
-- The finalizer is then placed on the write side, and the handle only gets
-- finalized once, when both sides are no longer required.

-- NOTE about finalized handles: It's possible that a handle can be
-- finalized and then we try to use it later, for example if the
-- handle is referenced from another finalizer, or from a thread that
-- has become unreferenced and then resurrected (arguably in the
-- latter case we shouldn't finalize the Handle...).  Anyway,
-- we try to emit a helpful message which is better than nothing.

stdHandleFinalizer :: FilePath -> MVar Handle__ -> IO ()
stdHandleFinalizer fp m = do
  h_ <- takeMVar m
  flushWriteBufferOnly h_
  putMVar m (ioe_finalizedHandle fp)

handleFinalizer :: FilePath -> MVar Handle__ -> IO ()
handleFinalizer fp m = do
  handle_ <- takeMVar m
  case haType handle_ of
      ClosedHandle -> return ()
      _ -> do flushWriteBufferOnly handle_ `catchException` \_ -> return ()
                -- ignore errors and async exceptions, and close the
                -- descriptor anyway...
              hClose_handle_ handle_
              return ()
  putMVar m (ioe_finalizedHandle fp)

-- ---------------------------------------------------------------------------
-- Grimy buffer operations

#ifdef DEBUG
checkBufferInvariants h_ = do
 let ref = haBuffer h_
 Buffer{ bufWPtr=w, bufRPtr=r, bufSize=size, bufState=state } <- readIORef ref
 if not (
        size > 0
        && r <= w
        && w <= size
        && ( r /= w || (r == 0 && w == 0) )
        && ( state /= WriteBuffer || r == 0 )
        && ( state /= WriteBuffer || w < size ) -- write buffer is never full
     )
   then error "buffer invariant violation"
   else return ()
#else
checkBufferInvariants h_ = return ()
#endif

newEmptyBuffer :: RawBuffer -> BufferState -> Int -> Buffer
newEmptyBuffer b state size
  = Buffer{ bufBuf=b, bufRPtr=0, bufWPtr=0, bufSize=size, bufState=state }

allocateBuffer :: Int -> BufferState -> IO 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 #) }

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#) #)

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#)) #)

getBuffer :: FD -> BufferState -> IO (IORef Buffer, BufferMode)
getBuffer fd state = do
  buffer <- allocateBuffer dEFAULT_BUFFER_SIZE state
  ioref  <- newIORef buffer
  is_tty <- fdIsTTY fd

  let buffer_mode 
         | is_tty    = LineBuffering 
         | otherwise = BlockBuffering Nothing

  return (ioref, buffer_mode)

mkUnBuffer :: IO (IORef Buffer)
mkUnBuffer = do
  buffer <- allocateBuffer 1 ReadBuffer
  newIORef buffer

-- flushWriteBufferOnly flushes the buffer iff it contains pending write data.
flushWriteBufferOnly :: Handle__ -> IO ()
flushWriteBufferOnly h_ = do
  let fd = haFD h_
      ref = haBuffer h_
  buf <- readIORef ref
  new_buf <- if bufferIsWritable buf 
                then flushWriteBuffer fd (haIsStream h_) buf 
                else return buf
  writeIORef ref new_buf

-- flushBuffer syncs the file with the buffer, including moving the
-- file pointer backwards in the case of a read buffer.
flushBuffer :: Handle__ -> IO ()
flushBuffer h_ = do
  let ref = haBuffer h_
  buf <- readIORef ref

  flushed_buf <-
    case bufState buf of
      ReadBuffer  -> flushReadBuffer  (haFD h_) buf
      WriteBuffer -> flushWriteBuffer (haFD h_) (haIsStream h_) buf

  writeIORef ref flushed_buf

-- When flushing a read buffer, we seek backwards by the number of
-- characters in the buffer.  The file descriptor must therefore be
-- seekable: attempting to flush the read buffer on an unseekable
-- handle is not allowed.

flushReadBuffer :: FD -> Buffer -> IO Buffer
flushReadBuffer fd buf
  | bufferEmpty buf = return buf
  | otherwise = do
     let off = negate (bufWPtr buf - bufRPtr buf)
#    ifdef DEBUG_DUMP
     puts ("flushReadBuffer: new file offset = " ++ show off ++ "\n")
#    endif
     throwErrnoIfMinus1Retry "flushReadBuffer"
         (c_lseek fd (fromIntegral off) sEEK_CUR)
     return buf{ bufWPtr=0, bufRPtr=0 }

flushWriteBuffer :: FD -> Bool -> Buffer -> IO Buffer
flushWriteBuffer fd is_stream buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w }  =
  seq fd $ do -- strictness hack
  let bytes = w - r
#ifdef DEBUG_DUMP
  puts ("flushWriteBuffer, fd=" ++ show fd ++ ", bytes=" ++ show bytes ++ "\n")
#endif
  if bytes == 0
     then return (buf{ bufRPtr=0, bufWPtr=0 })
     else do
  res <- writeRawBuffer "flushWriteBuffer" fd is_stream b 
                        (fromIntegral r) (fromIntegral bytes)
  let res' = fromIntegral res
  if res' < bytes 
     then flushWriteBuffer fd is_stream (buf{ bufRPtr = r + res' })
     else return buf{ bufRPtr=0, bufWPtr=0 }

fillReadBuffer :: FD -> Bool -> Bool -> Buffer -> IO Buffer
fillReadBuffer fd is_line is_stream
      buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } =
  -- buffer better be empty:
  assert (r == 0 && w == 0) $ do
  fillReadBufferLoop fd is_line is_stream buf b w size

-- For a line buffer, we just get the first chunk of data to arrive,
-- and don't wait for the whole buffer to be full (but we *do* wait
-- until some data arrives).  This isn't really line buffering, but it
-- 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 is_line is_stream buf b w size = do
  let bytes = size - w
  if bytes == 0  -- buffer full?
     then return buf{ bufRPtr=0, bufWPtr=w }
     else do
#ifdef DEBUG_DUMP
  puts ("fillReadBufferLoop: bytes = " ++ show bytes ++ "\n")
#endif
  res <- readRawBuffer "fillReadBuffer" fd is_stream b
                       (fromIntegral w) (fromIntegral bytes)
  let res' = fromIntegral res
#ifdef DEBUG_DUMP
  puts ("fillReadBufferLoop:  res' = " ++ show res' ++ "\n")
#endif
  if res' == 0
     then if w == 0
             then ioe_EOF
             else return buf{ bufRPtr=0, bufWPtr=w }
     else if res' < bytes && not is_line
             then fillReadBufferLoop fd is_line is_stream buf b (w+res') size
             else return buf{ bufRPtr=0, bufWPtr=w+res' }
 

fillReadBufferWithoutBlocking :: FD -> Bool -> Buffer -> IO Buffer
fillReadBufferWithoutBlocking fd is_stream
      buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } =
  -- buffer better be empty:
  assert (r == 0 && w == 0) $ do
#ifdef DEBUG_DUMP
  puts ("fillReadBufferLoopNoBlock: bytes = " ++ show size ++ "\n")
#endif
  res <- readRawBufferNoBlock "fillReadBuffer" fd is_stream b
                       0 (fromIntegral size)
  let res' = fromIntegral res
#ifdef DEBUG_DUMP
  puts ("fillReadBufferLoopNoBlock:  res' = " ++ show res' ++ "\n")
#endif
  return buf{ bufRPtr=0, bufWPtr=res' }
 
-- Low level routines for reading/writing to (raw)buffers:

#ifndef mingw32_HOST_OS

{-
NOTE [nonblock]:

Unix has broken semantics when it comes to non-blocking I/O: you can
set the O_NONBLOCK flag on an FD, but it applies to the all other FDs
attached to the same underlying file, pipe or TTY; there's no way to
have private non-blocking behaviour for an FD.  See bug #724.

We fix this by only setting O_NONBLOCK on FDs that we create; FDs that
come from external sources or are exposed externally are left in
blocking mode.  This solution has some problems though.  We can't
completely simulate a non-blocking read without O_NONBLOCK: several
cases are wrong here.  The cases that are wrong:

  * reading/writing to a blocking FD in non-threaded mode.
    In threaded mode, we just make a safe call to read().  
    In non-threaded mode we call select() before attempting to read,
    but that leaves a small race window where the data can be read
    from the file descriptor before we issue our blocking read().
  * readRawBufferNoBlock for a blocking FD
-}

readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
readRawBuffer loc fd is_nonblock buf off len
  | is_nonblock  = unsafe_read
  | threaded     = safe_read
  | otherwise    = do r <- throwErrnoIfMinus1 loc 
                                (fdReady (fromIntegral fd) 0 0 False)
                      if r /= 0
                        then unsafe_read
                        else do threadWaitRead (fromIntegral fd); unsafe_read
  where
    do_read call = throwErrnoIfMinus1RetryMayBlock loc call 
                            (threadWaitRead (fromIntegral fd))
    unsafe_read = do_read (read_rawBuffer fd buf off len)
    safe_read   = do_read (safe_read_rawBuffer fd buf off len)

readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
readRawBufferPtr loc fd is_nonblock buf off len
  | is_nonblock  = unsafe_read
  | threaded     = safe_read
  | otherwise    = do r <- throwErrnoIfMinus1 loc 
                                (fdReady (fromIntegral fd) 0 0 False)
                      if r /= 0 
                        then unsafe_read
                        else do threadWaitRead (fromIntegral fd); unsafe_read
  where
        do_read call = throwErrnoIfMinus1RetryMayBlock loc call 
                                (threadWaitRead (fromIntegral fd))
        unsafe_read = do_read (read_off fd buf off len)
        safe_read   = do_read (safe_read_off fd buf off len)

readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
readRawBufferNoBlock loc fd is_nonblock buf off len
  | is_nonblock  = unsafe_read
  | otherwise    = do r <- fdReady (fromIntegral fd) 0 0 False
                      if r /= 0 then safe_read
                                else return 0
       -- XXX see note [nonblock]
 where
   do_read call = throwErrnoIfMinus1RetryOnBlock loc call (return 0)
   unsafe_read  = do_read (read_rawBuffer fd buf off len)
   safe_read    = do_read (safe_read_rawBuffer fd buf off len)

readRawBufferPtrNoBlock :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
readRawBufferPtrNoBlock loc fd is_nonblock buf off len
  | is_nonblock  = unsafe_read
  | otherwise    = do r <- fdReady (fromIntegral fd) 0 0 False
                      if r /= 0 then safe_read
                                else return 0
       -- XXX see note [nonblock]
 where
   do_read call = throwErrnoIfMinus1RetryOnBlock loc call (return 0)
   unsafe_read  = do_read (read_off fd buf off len)
   safe_read    = do_read (safe_read_off fd buf off len)

writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
writeRawBuffer loc fd is_nonblock buf off len
  | is_nonblock = unsafe_write
  | threaded    = safe_write
  | otherwise   = do r <- fdReady (fromIntegral fd) 1 0 False
                     if r /= 0 
                        then safe_write
                        else do threadWaitWrite (fromIntegral fd); unsafe_write
  where  
    do_write call = throwErrnoIfMinus1RetryMayBlock loc call
                        (threadWaitWrite (fromIntegral fd)) 
    unsafe_write = do_write (write_rawBuffer fd buf off len)
    safe_write   = do_write (safe_write_rawBuffer (fromIntegral fd) buf off len)

writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
writeRawBufferPtr loc fd is_nonblock buf off len
  | is_nonblock = unsafe_write
  | threaded    = safe_write
  | otherwise   = do r <- fdReady (fromIntegral fd) 1 0 False
                     if r /= 0 
                        then safe_write
                        else do threadWaitWrite (fromIntegral fd); unsafe_write
  where
    do_write call = throwErrnoIfMinus1RetryMayBlock loc call
                        (threadWaitWrite (fromIntegral fd)) 
    unsafe_write  = do_write (write_off fd buf off len)
    safe_write    = do_write (safe_write_off (fromIntegral fd) buf off len)

foreign import ccall unsafe "__hscore_PrelHandle_read"
   read_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt

foreign import ccall unsafe "__hscore_PrelHandle_read"
   read_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt

foreign import ccall unsafe "__hscore_PrelHandle_write"
   write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt

foreign import ccall unsafe "__hscore_PrelHandle_write"
   write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt

foreign import ccall safe "fdReady"
  fdReady :: CInt -> CInt -> CInt -> Bool -> IO CInt

#else /* mingw32_HOST_OS.... */

readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
readRawBuffer loc fd is_stream buf off len
  | threaded  = blockingReadRawBuffer loc fd is_stream buf off len
  | otherwise = asyncReadRawBuffer loc fd is_stream buf off len

readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
readRawBufferPtr loc fd is_stream buf off len
  | threaded  = blockingReadRawBufferPtr loc fd is_stream buf off len
  | otherwise = asyncReadRawBufferPtr loc fd is_stream buf off len

writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
writeRawBuffer loc fd is_stream buf off len
  | threaded =  blockingWriteRawBuffer loc fd is_stream buf off len
  | otherwise = asyncWriteRawBuffer    loc fd is_stream buf off len

writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
writeRawBufferPtr loc fd is_stream buf off len
  | threaded  = blockingWriteRawBufferPtr loc fd is_stream buf off len
  | otherwise = asyncWriteRawBufferPtr    loc fd is_stream buf off len

-- ToDo: we don't have a non-blocking primitve read on Win32
readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
readRawBufferNoBlock = readRawBuffer

readRawBufferPtrNoBlock :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
readRawBufferPtrNoBlock = readRawBufferPtr
-- Async versions of the read/write primitives, for the non-threaded RTS

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
    if l == (-1)
      then 
        ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
      else return (fromIntegral l)

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)
    if l == (-1)
      then 
        ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
      else return (fromIntegral l)

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
    if l == (-1)
      then 
        ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
      else return (fromIntegral l)

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)
    if l == (-1)
      then 
        ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
      else return (fromIntegral l)

-- Blocking versions of the read/write primitives, for the threaded RTS

blockingReadRawBuffer loc fd True buf off len = 
  throwErrnoIfMinus1Retry loc $
    safe_recv_rawBuffer fd buf off len
blockingReadRawBuffer loc fd False buf off len = 
  throwErrnoIfMinus1Retry loc $
    safe_read_rawBuffer fd buf off len

blockingReadRawBufferPtr loc fd True buf off len = 
  throwErrnoIfMinus1Retry loc $
    safe_recv_off fd buf off len
blockingReadRawBufferPtr loc fd False buf off len = 
  throwErrnoIfMinus1Retry loc $
    safe_read_off fd buf off len

blockingWriteRawBuffer loc fd True buf off len = 
  throwErrnoIfMinus1Retry loc $
    safe_send_rawBuffer fd buf off len
blockingWriteRawBuffer loc fd False buf off len = 
  throwErrnoIfMinus1Retry loc $
    safe_write_rawBuffer fd buf off len

blockingWriteRawBufferPtr loc fd True buf off len = 
  throwErrnoIfMinus1Retry loc $
    safe_send_off fd buf off len
blockingWriteRawBufferPtr loc fd False buf off len = 
  throwErrnoIfMinus1Retry loc $
    safe_write_off fd buf off len

-- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.
-- These calls may block, but that's ok.

foreign import ccall safe "__hscore_PrelHandle_recv"
   safe_recv_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt

foreign import ccall safe "__hscore_PrelHandle_recv"
   safe_recv_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt

foreign import ccall safe "__hscore_PrelHandle_send"
   safe_send_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt

foreign import ccall safe "__hscore_PrelHandle_send"
   safe_send_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt

#endif

foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool

foreign import ccall safe "__hscore_PrelHandle_read"
   safe_read_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt

foreign import ccall safe "__hscore_PrelHandle_read"
   safe_read_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt

foreign import ccall safe "__hscore_PrelHandle_write"
   safe_write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt

foreign import ccall safe "__hscore_PrelHandle_write"
   safe_write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt

-- ---------------------------------------------------------------------------
-- Standard Handles

-- Three handles are allocated during program initialisation.  The first
-- 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.

fd_stdin  = 0 :: FD
fd_stdout = 1 :: FD
fd_stderr = 2 :: FD

-- | A handle managing input from the Haskell program's standard input channel.
stdin :: Handle
stdin = unsafePerformIO $ do
   -- ToDo: acquire lock
   -- We don't set non-blocking mode on standard handles, because it may
   -- confuse other applications attached to the same TTY/pipe
   -- see Note [nonblock]
   (buf, bmode) <- getBuffer fd_stdin ReadBuffer
   mkStdHandle fd_stdin "<stdin>" ReadHandle buf bmode

-- | A handle managing output to the Haskell program's standard output channel.
stdout :: Handle
stdout = unsafePerformIO $ do
   -- ToDo: acquire lock
   -- We don't set non-blocking mode on standard handles, because it may
   -- confuse other applications attached to the same TTY/pipe
   -- see Note [nonblock]
   (buf, bmode) <- getBuffer fd_stdout WriteBuffer
   mkStdHandle fd_stdout "<stdout>" WriteHandle buf bmode

-- | A handle managing output to the Haskell program's standard error channel.
stderr :: Handle
stderr = unsafePerformIO $ do
    -- ToDo: acquire lock
   -- We don't set non-blocking mode on standard handles, because it may
   -- confuse other applications attached to the same TTY/pipe
   -- see Note [nonblock]
   buf <- mkUnBuffer
   mkStdHandle fd_stderr "<stderr>" WriteHandle buf NoBuffering

-- ---------------------------------------------------------------------------
-- Opening and Closing Files

addFilePathToIOError fun fp (IOError h iot _ str _)
  = IOError h iot fun str (Just fp)

-- | Computation 'openFile' @file mode@ allocates and returns a new, open
-- handle to manage the file @file@.  It manages input if @mode@
-- is 'ReadMode', output if @mode@ is 'WriteMode' or 'AppendMode',
-- and both input and output if mode is 'ReadWriteMode'.
--
-- If the file does not exist and it is opened for output, it should be
-- created as a new file.  If @mode@ is 'WriteMode' and the file
-- already exists, then it should be truncated to zero length.
-- Some operating systems delete empty files, so there is no guarantee
-- that the file will exist following an 'openFile' with @mode@
-- 'WriteMode' unless it is subsequently written to successfully.
-- The handle is positioned at the end of the file if @mode@ is
-- 'AppendMode', and otherwise at the beginning (in which case its
-- internal position is 0).
-- The initial buffer mode is implementation-dependent.
--
-- This operation may fail with:
--
--  * 'isAlreadyInUseError' if the file is already open and cannot be reopened;
--
--  * 'isDoesNotExistError' if the file does not exist; or
--
--  * 'isPermissionError' if the user does not have permission to open the file.
--
-- Note: if you will be working with files containing binary data, you'll want to
-- be using 'openBinaryFile'.
openFile :: FilePath -> IOMode -> IO Handle
openFile fp im = 
  catch 
    (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE)
    (\e -> ioError (addFilePathToIOError "openFile" fp e))

-- | Like 'openFile', but open the file in binary mode.
-- On Windows, reading a file in text mode (which is the default)
-- will translate CRLF to LF, and writing will translate LF to CRLF.
-- This is usually what you want with text files.  With binary files
-- this is undesirable; also, as usual under Microsoft operating systems,
-- text mode treats control-Z as EOF.  Binary mode turns off all special
-- treatment of end-of-line and end-of-file characters.
-- (See also 'hSetBinaryMode'.)

openBinaryFile :: FilePath -> IOMode -> IO Handle
openBinaryFile fp m =
  catch
    (openFile' fp m True)
    (\e -> ioError (addFilePathToIOError "openBinaryFile" fp e))

openFile' filepath mode binary =
  withCString filepath $ \ f ->

    let 
      oflags1 = case mode of
                  ReadMode      -> read_flags
#ifdef mingw32_HOST_OS
                  WriteMode     -> write_flags .|. o_TRUNC
#else
                  WriteMode     -> write_flags
#endif
                  ReadWriteMode -> rw_flags
                  AppendMode    -> append_flags

      binary_flags
          | binary    = o_BINARY
          | otherwise = 0

      oflags = oflags1 .|. binary_flags
    in do

    -- the old implementation had a complicated series of three opens,
    -- which is perhaps because we have to be careful not to open
    -- directories.  However, the man pages I've read say that open()
    -- always returns EISDIR if the file is a directory and was opened
    -- for writing, so I think we're ok with a single open() here...
    fd <- throwErrnoIfMinus1Retry "openFile"
                (c_open f (fromIntegral oflags) 0o666)

    stat@(fd_type,_,_) <- fdStat fd

    h <- fdToHandle_stat fd (Just stat) False filepath mode binary
            `catchException` \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
        -- (so we don't need to worry about removing the newly created file
        --  in the event of an error).

#ifndef mingw32_HOST_OS
        -- we want to truncate() if this is an open in WriteMode, but only
        -- if the target is a RegularFile.  ftruncate() fails on special files
        -- like /dev/null.
    if mode == WriteMode && fd_type == RegularFile
      then throwErrnoIf (/=0) "openFile" 
              (c_ftruncate fd 0)
      else return 0
#endif
    return h


std_flags    = o_NONBLOCK   .|. o_NOCTTY
output_flags = std_flags    .|. o_CREAT
read_flags   = std_flags    .|. o_RDONLY 
write_flags  = output_flags .|. o_WRONLY
rw_flags     = output_flags .|. o_RDWR
append_flags = write_flags  .|. o_APPEND

-- ---------------------------------------------------------------------------
-- fdToHandle

fdToHandle_stat :: FD
            -> Maybe (FDType, CDev, CIno)
            -> Bool
            -> FilePath
            -> IOMode
            -> Bool
            -> IO Handle

fdToHandle_stat fd mb_stat is_socket filepath mode binary = do
    -- turn on non-blocking mode
    setNonBlockingFD fd

#ifdef mingw32_HOST_OS
    -- On Windows, the is_stream flag indicates that the Handle is a socket
    let is_stream = is_socket 
#else
    -- On Unix, the is_stream flag indicates that the FD is non-blocking
    let is_stream = True
#endif

    let (ha_type, write) =
          case mode of
            ReadMode      -> ( ReadHandle,      False )
            WriteMode     -> ( WriteHandle,     True )
            ReadWriteMode -> ( ReadWriteHandle, True )
            AppendMode    -> ( AppendHandle,    True )

    -- open() won't tell us if it was a directory if we only opened for
    -- reading, so check again.
    (fd_type,dev,ino) <- 
      case mb_stat of
        Just x  -> return x
        Nothing -> fdStat fd

    case fd_type of
        Directory -> 
           ioException (IOError Nothing InappropriateType "openFile"
                           "is a directory" Nothing) 

        -- regular files need to be locked
        RegularFile -> do
#ifndef mingw32_HOST_OS
           r <- lockFile fd dev ino (fromBool write)
           when (r == -1)  $
                ioException (IOError Nothing ResourceBusy "openFile"
                                   "file is locked" Nothing)
#endif
           mkFileHandle fd is_stream filepath ha_type binary

        Stream
           -- only *Streams* can be DuplexHandles.  Other read/write
           -- Handles must share a buffer.
           | ReadWriteHandle <- ha_type -> 
                mkDuplexHandle fd is_stream filepath binary
           | otherwise ->
                mkFileHandle   fd is_stream filepath ha_type binary

        RawDevice -> 
                mkFileHandle fd is_stream filepath ha_type binary

-- | Old API kept to avoid breaking clients
fdToHandle' :: FD -> Maybe FDType -> Bool -> FilePath  -> IOMode -> Bool
            -> IO Handle
fdToHandle' fd mb_type is_socket filepath mode binary
 = do
       let mb_stat = case mb_type of
                        Nothing          -> Nothing
                          -- fdToHandle_stat will do the stat:
                        Just RegularFile -> Nothing
                          -- no stat required for streams etc.:
                        Just other       -> Just (other,0,0)
       fdToHandle_stat fd mb_stat is_socket filepath mode binary

fdToHandle :: FD -> IO Handle
fdToHandle fd = do
   mode <- fdGetMode fd
   let fd_str = "<file descriptor: " ++ show fd ++ ">"
   fdToHandle_stat fd Nothing False{-XXX!-} fd_str mode True{-bin mode-}


#ifndef mingw32_HOST_OS
foreign import ccall unsafe "lockFile"
  lockFile :: CInt -> CDev -> CIno -> CInt -> IO CInt

foreign import ccall unsafe "unlockFile"
  unlockFile :: CInt -> IO CInt
#endif

mkStdHandle :: FD -> FilePath -> HandleType -> IORef Buffer -> BufferMode
        -> IO Handle
mkStdHandle fd filepath ha_type buf bmode = do
   spares <- newIORef BufferListNil
   newFileHandle filepath (stdHandleFinalizer filepath)
            (Handle__ { haFD = fd,
                        haType = ha_type,
                        haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
                        haIsStream = False, -- means FD is blocking on Unix
                        haBufferMode = bmode,
                        haBuffer = buf,
                        haBuffers = spares,
                        haOtherSide = Nothing
                      })

mkFileHandle :: FD -> Bool -> FilePath -> HandleType -> Bool -> IO Handle
mkFileHandle fd is_stream filepath ha_type binary = do
  (buf, bmode) <- getBuffer fd (initBufferState ha_type)

#ifdef mingw32_HOST_OS<commit_msg>don't set O_NONBLOCK on FDs passed to fdToHandle<commit_after>{-# OPTIONS_GHC -fno-implicit-prelude -#include "HsBase.h" #-}
{-# OPTIONS_HADDOCK hide #-}

#undef DEBUG_DUMP
#undef DEBUG

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.Handle
-- Copyright   :  (c) The University of Glasgow, 1994-2001
-- License     :  see libraries/base/LICENSE
-- 
-- Maintainer  :  <EMAIL>
-- Stability   :  internal
-- Portability :  non-portable
--
-- This module defines the basic operations on I\/O \"handles\".
--
-----------------------------------------------------------------------------

-- #hide
module GHC.Handle (
  withHandle, withHandle', withHandle_,
  wantWritableHandle, wantReadableHandle, wantSeekableHandle,

  newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer,
  flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer,
  fillReadBuffer, fillReadBufferWithoutBlocking,
  readRawBuffer, readRawBufferPtr,
  readRawBufferNoBlock, readRawBufferPtrNoBlock,
  writeRawBuffer, writeRawBufferPtr,

#ifndef mingw32_HOST_OS
  unlockFile,
#endif

  ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,

  stdin, stdout, stderr,
  IOMode(..), openFile, openBinaryFile, fdToHandle_stat, fdToHandle, fdToHandle',
  hFileSize, hSetFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode,
  hFlush, hDuplicate, hDuplicateTo,

  hClose, hClose_help,

  HandlePosition, HandlePosn(..), hGetPosn, hSetPosn,
  SeekMode(..), hSeek, hTell,

  hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable,
  hSetEcho, hGetEcho, hIsTerminalDevice,

  hShow,

#ifdef DEBUG_DUMP
  puts,
#endif

 ) where

import Control.Monad
import Data.Bits
import Data.Maybe
import Foreign
import Foreign.C
import System.IO.Error
import System.Posix.Internals
import System.Posix.Types

import GHC.Real

import GHC.Arr
import GHC.Base
import GHC.Read         ( Read )
import GHC.List
import GHC.IOBase
import GHC.Exception
import GHC.Enum
import GHC.Num          ( Integer(..), Num(..) )
import GHC.Show
import GHC.Real         ( toInteger )
#if defined(DEBUG_DUMP)
import GHC.Pack
#endif

import GHC.Conc

-- -----------------------------------------------------------------------------
-- TODO:

-- hWaitForInput blocks (should use a timeout)

-- unbuffered hGetLine is a bit dodgy

-- hSetBuffering: can't change buffering on a stream, 
--      when the read buffer is non-empty? (no way to flush the buffer)

-- ---------------------------------------------------------------------------
-- Are files opened by default in text or binary mode, if the user doesn't
-- specify?

dEFAULT_OPEN_IN_BINARY_MODE = False :: Bool

-- ---------------------------------------------------------------------------
-- Creating a new handle

newFileHandle :: FilePath -> (MVar Handle__ -> IO ()) -> Handle__ -> IO Handle
newFileHandle filepath finalizer hc = do
  m <- newMVar hc
  addMVarFinalizer m (finalizer m)
  return (FileHandle filepath m)

-- ---------------------------------------------------------------------------
-- Working with Handles

{-
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
original handle is always replaced [ this is the case at the moment,
but we might want to revisit this in the future --SDM ].
-}

{-# INLINE withHandle #-}
withHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
withHandle fun h@(FileHandle _ m)     act = withHandle' fun h m act
withHandle fun h@(DuplexHandle _ m _) act = withHandle' fun h m act

withHandle' :: String -> Handle -> MVar Handle__
   -> (Handle__ -> IO (Handle__,a)) -> IO a
withHandle' fun h m act =
   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)
   checkBufferInvariants h'
   putMVar m h'
   return v

{-# INLINE withHandle_ #-}
withHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a
withHandle_ fun h@(FileHandle _ m)     act = withHandle_' fun h m act
withHandle_ fun h@(DuplexHandle _ m _) act = withHandle_' fun h m act

withHandle_' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO a) -> IO a
withHandle_' fun h m act =
   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)
   checkBufferInvariants h_
   putMVar m h_
   return v

withAllHandles__ :: String -> Handle -> (Handle__ -> IO Handle__) -> IO ()
withAllHandles__ fun h@(FileHandle _ m)     act = withHandle__' fun h m act
withAllHandles__ fun h@(DuplexHandle _ r w) act = do
  withHandle__' fun h r act
  withHandle__' fun h w act

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)
   checkBufferInvariants h'
   putMVar m h'
   return ()

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

-- ---------------------------------------------------------------------------
-- Wrapper for write operations.

wantWritableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
wantWritableHandle fun h@(FileHandle _ m) act
  = wantWritableHandle' fun h m act
wantWritableHandle fun h@(DuplexHandle _ _ m) act
  = wantWritableHandle' fun h m act
  -- ToDo: in the Duplex case, we don't need to checkWritableHandle

wantWritableHandle'
        :: String -> Handle -> MVar Handle__
        -> (Handle__ -> IO a) -> IO a
wantWritableHandle' fun h m act
   = withHandle_' fun h m (checkWritableHandle act)

checkWritableHandle act handle_
  = case haType handle_ of
      ClosedHandle         -> ioe_closedHandle
      SemiClosedHandle     -> ioe_closedHandle
      ReadHandle           -> ioe_notWritable
      ReadWriteHandle      -> do
                let ref = haBuffer handle_
                buf <- readIORef ref
                new_buf <-
                  if not (bufferIsWritable buf)
                     then do b <- flushReadBuffer (haFD handle_) buf
                             return b{ bufState=WriteBuffer }
                     else return buf
                writeIORef ref new_buf
                act handle_
      _other               -> act handle_

-- ---------------------------------------------------------------------------
-- Wrapper for read operations.

wantReadableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
wantReadableHandle fun h@(FileHandle  _ m)   act
  = wantReadableHandle' fun h m act
wantReadableHandle fun h@(DuplexHandle _ m _) act
  = wantReadableHandle' fun h m act
  -- ToDo: in the Duplex case, we don't need to checkReadableHandle

wantReadableHandle'
        :: String -> Handle -> MVar Handle__
        -> (Handle__ -> IO a) -> IO a
wantReadableHandle' fun h m act
  = withHandle_' fun h m (checkReadableHandle act)

checkReadableHandle act handle_ =
    case haType handle_ of
      ClosedHandle         -> ioe_closedHandle
      SemiClosedHandle     -> ioe_closedHandle
      AppendHandle         -> ioe_notReadable
      WriteHandle          -> ioe_notReadable
      ReadWriteHandle      -> do
        let ref = haBuffer handle_
        buf <- readIORef ref
        when (bufferIsWritable buf) $ do
           new_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
           writeIORef ref new_buf{ bufState=ReadBuffer }
        act handle_
      _other               -> act handle_

-- ---------------------------------------------------------------------------
-- Wrapper for seek operations.

wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
wantSeekableHandle fun h@(DuplexHandle _ _ _) _act =
  ioException (IOError (Just h) IllegalOperation fun
                   "handle is not seekable" Nothing)
wantSeekableHandle fun h@(FileHandle _ m) act =
  withHandle_' fun h m (checkSeekableHandle act)

checkSeekableHandle act handle_ =
    case haType handle_ of
      ClosedHandle      -> ioe_closedHandle
      SemiClosedHandle  -> ioe_closedHandle
      AppendHandle      -> ioe_notSeekable
      _  | haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED -> act handle_
         | otherwise                                 -> ioe_notSeekable_notBin

-- -----------------------------------------------------------------------------
-- Handy IOErrors

ioe_closedHandle, ioe_EOF,
  ioe_notReadable, ioe_notWritable,
  ioe_notSeekable, ioe_notSeekable_notBin :: IO a

ioe_closedHandle = ioException
   (IOError Nothing IllegalOperation ""
        "handle is closed" Nothing)
ioe_EOF = ioException
   (IOError Nothing EOF "" "" Nothing)
ioe_notReadable = ioException
   (IOError Nothing IllegalOperation ""
        "handle is not open for reading" Nothing)
ioe_notWritable = ioException
   (IOError Nothing IllegalOperation ""
        "handle is not open for writing" Nothing)
ioe_notSeekable = ioException
   (IOError Nothing IllegalOperation ""
        "handle is not seekable" Nothing)
ioe_notSeekable_notBin = ioException
   (IOError Nothing IllegalOperation ""
      "seek operations on text-mode handles are not allowed on this platform"
        Nothing)

ioe_finalizedHandle fp = throw (IOException
   (IOError Nothing IllegalOperation ""
        "handle is finalized" (Just fp)))

ioe_bufsiz :: Int -> IO a
ioe_bufsiz n = ioException
   (IOError Nothing InvalidArgument "hSetBuffering"
        ("illegal buffer size " ++ showsPrec 9 n []) Nothing)
                                -- 9 => should be parens'ified.

-- -----------------------------------------------------------------------------
-- Handle Finalizers

-- For a duplex handle, we arrange that the read side points to the write side
-- (and hence keeps it alive if the read side is alive).  This is done by
-- having the haOtherSide field of the read side point to the read side.
-- The finalizer is then placed on the write side, and the handle only gets
-- finalized once, when both sides are no longer required.

-- NOTE about finalized handles: It's possible that a handle can be
-- finalized and then we try to use it later, for example if the
-- handle is referenced from another finalizer, or from a thread that
-- has become unreferenced and then resurrected (arguably in the
-- latter case we shouldn't finalize the Handle...).  Anyway,
-- we try to emit a helpful message which is better than nothing.

stdHandleFinalizer :: FilePath -> MVar Handle__ -> IO ()
stdHandleFinalizer fp m = do
  h_ <- takeMVar m
  flushWriteBufferOnly h_
  putMVar m (ioe_finalizedHandle fp)

handleFinalizer :: FilePath -> MVar Handle__ -> IO ()
handleFinalizer fp m = do
  handle_ <- takeMVar m
  case haType handle_ of
      ClosedHandle -> return ()
      _ -> do flushWriteBufferOnly handle_ `catchException` \_ -> return ()
                -- ignore errors and async exceptions, and close the
                -- descriptor anyway...
              hClose_handle_ handle_
              return ()
  putMVar m (ioe_finalizedHandle fp)

-- ---------------------------------------------------------------------------
-- Grimy buffer operations

#ifdef DEBUG
checkBufferInvariants h_ = do
 let ref = haBuffer h_
 Buffer{ bufWPtr=w, bufRPtr=r, bufSize=size, bufState=state } <- readIORef ref
 if not (
        size > 0
        && r <= w
        && w <= size
        && ( r /= w || (r == 0 && w == 0) )
        && ( state /= WriteBuffer || r == 0 )
        && ( state /= WriteBuffer || w < size ) -- write buffer is never full
     )
   then error "buffer invariant violation"
   else return ()
#else
checkBufferInvariants h_ = return ()
#endif

newEmptyBuffer :: RawBuffer -> BufferState -> Int -> Buffer
newEmptyBuffer b state size
  = Buffer{ bufBuf=b, bufRPtr=0, bufWPtr=0, bufSize=size, bufState=state }

allocateBuffer :: Int -> BufferState -> IO 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 #) }

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#) #)

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#)) #)

getBuffer :: FD -> BufferState -> IO (IORef Buffer, BufferMode)
getBuffer fd state = do
  buffer <- allocateBuffer dEFAULT_BUFFER_SIZE state
  ioref  <- newIORef buffer
  is_tty <- fdIsTTY fd

  let buffer_mode 
         | is_tty    = LineBuffering 
         | otherwise = BlockBuffering Nothing

  return (ioref, buffer_mode)

mkUnBuffer :: IO (IORef Buffer)
mkUnBuffer = do
  buffer <- allocateBuffer 1 ReadBuffer
  newIORef buffer

-- flushWriteBufferOnly flushes the buffer iff it contains pending write data.
flushWriteBufferOnly :: Handle__ -> IO ()
flushWriteBufferOnly h_ = do
  let fd = haFD h_
      ref = haBuffer h_
  buf <- readIORef ref
  new_buf <- if bufferIsWritable buf 
                then flushWriteBuffer fd (haIsStream h_) buf 
                else return buf
  writeIORef ref new_buf

-- flushBuffer syncs the file with the buffer, including moving the
-- file pointer backwards in the case of a read buffer.
flushBuffer :: Handle__ -> IO ()
flushBuffer h_ = do
  let ref = haBuffer h_
  buf <- readIORef ref

  flushed_buf <-
    case bufState buf of
      ReadBuffer  -> flushReadBuffer  (haFD h_) buf
      WriteBuffer -> flushWriteBuffer (haFD h_) (haIsStream h_) buf

  writeIORef ref flushed_buf

-- When flushing a read buffer, we seek backwards by the number of
-- characters in the buffer.  The file descriptor must therefore be
-- seekable: attempting to flush the read buffer on an unseekable
-- handle is not allowed.

flushReadBuffer :: FD -> Buffer -> IO Buffer
flushReadBuffer fd buf
  | bufferEmpty buf = return buf
  | otherwise = do
     let off = negate (bufWPtr buf - bufRPtr buf)
#    ifdef DEBUG_DUMP
     puts ("flushReadBuffer: new file offset = " ++ show off ++ "\n")
#    endif
     throwErrnoIfMinus1Retry "flushReadBuffer"
         (c_lseek fd (fromIntegral off) sEEK_CUR)
     return buf{ bufWPtr=0, bufRPtr=0 }

flushWriteBuffer :: FD -> Bool -> Buffer -> IO Buffer
flushWriteBuffer fd is_stream buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w }  =
  seq fd $ do -- strictness hack
  let bytes = w - r
#ifdef DEBUG_DUMP
  puts ("flushWriteBuffer, fd=" ++ show fd ++ ", bytes=" ++ show bytes ++ "\n")
#endif
  if bytes == 0
     then return (buf{ bufRPtr=0, bufWPtr=0 })
     else do
  res <- writeRawBuffer "flushWriteBuffer" fd is_stream b 
                        (fromIntegral r) (fromIntegral bytes)
  let res' = fromIntegral res
  if res' < bytes 
     then flushWriteBuffer fd is_stream (buf{ bufRPtr = r + res' })
     else return buf{ bufRPtr=0, bufWPtr=0 }

fillReadBuffer :: FD -> Bool -> Bool -> Buffer -> IO Buffer
fillReadBuffer fd is_line is_stream
      buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } =
  -- buffer better be empty:
  assert (r == 0 && w == 0) $ do
  fillReadBufferLoop fd is_line is_stream buf b w size

-- For a line buffer, we just get the first chunk of data to arrive,
-- and don't wait for the whole buffer to be full (but we *do* wait
-- until some data arrives).  This isn't really line buffering, but it
-- 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 is_line is_stream buf b w size = do
  let bytes = size - w
  if bytes == 0  -- buffer full?
     then return buf{ bufRPtr=0, bufWPtr=w }
     else do
#ifdef DEBUG_DUMP
  puts ("fillReadBufferLoop: bytes = " ++ show bytes ++ "\n")
#endif
  res <- readRawBuffer "fillReadBuffer" fd is_stream b
                       (fromIntegral w) (fromIntegral bytes)
  let res' = fromIntegral res
#ifdef DEBUG_DUMP
  puts ("fillReadBufferLoop:  res' = " ++ show res' ++ "\n")
#endif
  if res' == 0
     then if w == 0
             then ioe_EOF
             else return buf{ bufRPtr=0, bufWPtr=w }
     else if res' < bytes && not is_line
             then fillReadBufferLoop fd is_line is_stream buf b (w+res') size
             else return buf{ bufRPtr=0, bufWPtr=w+res' }
 

fillReadBufferWithoutBlocking :: FD -> Bool -> Buffer -> IO Buffer
fillReadBufferWithoutBlocking fd is_stream
      buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } =
  -- buffer better be empty:
  assert (r == 0 && w == 0) $ do
#ifdef DEBUG_DUMP
  puts ("fillReadBufferLoopNoBlock: bytes = " ++ show size ++ "\n")
#endif
  res <- readRawBufferNoBlock "fillReadBuffer" fd is_stream b
                       0 (fromIntegral size)
  let res' = fromIntegral res
#ifdef DEBUG_DUMP
  puts ("fillReadBufferLoopNoBlock:  res' = " ++ show res' ++ "\n")
#endif
  return buf{ bufRPtr=0, bufWPtr=res' }
 
-- Low level routines for reading/writing to (raw)buffers:

#ifndef mingw32_HOST_OS

{-
NOTE [nonblock]:

Unix has broken semantics when it comes to non-blocking I/O: you can
set the O_NONBLOCK flag on an FD, but it applies to the all other FDs
attached to the same underlying file, pipe or TTY; there's no way to
have private non-blocking behaviour for an FD.  See bug #724.

We fix this by only setting O_NONBLOCK on FDs that we create; FDs that
come from external sources or are exposed externally are left in
blocking mode.  This solution has some problems though.  We can't
completely simulate a non-blocking read without O_NONBLOCK: several
cases are wrong here.  The cases that are wrong:

  * reading/writing to a blocking FD in non-threaded mode.
    In threaded mode, we just make a safe call to read().  
    In non-threaded mode we call select() before attempting to read,
    but that leaves a small race window where the data can be read
    from the file descriptor before we issue our blocking read().
  * readRawBufferNoBlock for a blocking FD
-}

readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
readRawBuffer loc fd is_nonblock buf off len
  | is_nonblock  = unsafe_read
  | threaded     = safe_read
  | otherwise    = do r <- throwErrnoIfMinus1 loc 
                                (fdReady (fromIntegral fd) 0 0 False)
                      if r /= 0
                        then unsafe_read
                        else do threadWaitRead (fromIntegral fd); unsafe_read
  where
    do_read call = throwErrnoIfMinus1RetryMayBlock loc call 
                            (threadWaitRead (fromIntegral fd))
    unsafe_read = do_read (read_rawBuffer fd buf off len)
    safe_read   = do_read (safe_read_rawBuffer fd buf off len)

readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
readRawBufferPtr loc fd is_nonblock buf off len
  | is_nonblock  = unsafe_read
  | threaded     = safe_read
  | otherwise    = do r <- throwErrnoIfMinus1 loc 
                                (fdReady (fromIntegral fd) 0 0 False)
                      if r /= 0 
                        then unsafe_read
                        else do threadWaitRead (fromIntegral fd); unsafe_read
  where
        do_read call = throwErrnoIfMinus1RetryMayBlock loc call 
                                (threadWaitRead (fromIntegral fd))
        unsafe_read = do_read (read_off fd buf off len)
        safe_read   = do_read (safe_read_off fd buf off len)

readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
readRawBufferNoBlock loc fd is_nonblock buf off len
  | is_nonblock  = unsafe_read
  | otherwise    = do r <- fdReady (fromIntegral fd) 0 0 False
                      if r /= 0 then safe_read
                                else return 0
       -- XXX see note [nonblock]
 where
   do_read call = throwErrnoIfMinus1RetryOnBlock loc call (return 0)
   unsafe_read  = do_read (read_rawBuffer fd buf off len)
   safe_read    = do_read (safe_read_rawBuffer fd buf off len)

readRawBufferPtrNoBlock :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
readRawBufferPtrNoBlock loc fd is_nonblock buf off len
  | is_nonblock  = unsafe_read
  | otherwise    = do r <- fdReady (fromIntegral fd) 0 0 False
                      if r /= 0 then safe_read
                                else return 0
       -- XXX see note [nonblock]
 where
   do_read call = throwErrnoIfMinus1RetryOnBlock loc call (return 0)
   unsafe_read  = do_read (read_off fd buf off len)
   safe_read    = do_read (safe_read_off fd buf off len)

writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
writeRawBuffer loc fd is_nonblock buf off len
  | is_nonblock = unsafe_write
  | threaded    = safe_write
  | otherwise   = do r <- fdReady (fromIntegral fd) 1 0 False
                     if r /= 0 
                        then safe_write
                        else do threadWaitWrite (fromIntegral fd); unsafe_write
  where  
    do_write call = throwErrnoIfMinus1RetryMayBlock loc call
                        (threadWaitWrite (fromIntegral fd)) 
    unsafe_write = do_write (write_rawBuffer fd buf off len)
    safe_write   = do_write (safe_write_rawBuffer (fromIntegral fd) buf off len)

writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
writeRawBufferPtr loc fd is_nonblock buf off len
  | is_nonblock = unsafe_write
  | threaded    = safe_write
  | otherwise   = do r <- fdReady (fromIntegral fd) 1 0 False
                     if r /= 0 
                        then safe_write
                        else do threadWaitWrite (fromIntegral fd); unsafe_write
  where
    do_write call = throwErrnoIfMinus1RetryMayBlock loc call
                        (threadWaitWrite (fromIntegral fd)) 
    unsafe_write  = do_write (write_off fd buf off len)
    safe_write    = do_write (safe_write_off (fromIntegral fd) buf off len)

foreign import ccall unsafe "__hscore_PrelHandle_read"
   read_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt

foreign import ccall unsafe "__hscore_PrelHandle_read"
   read_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt

foreign import ccall unsafe "__hscore_PrelHandle_write"
   write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt

foreign import ccall unsafe "__hscore_PrelHandle_write"
   write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt

foreign import ccall safe "fdReady"
  fdReady :: CInt -> CInt -> CInt -> Bool -> IO CInt

#else /* mingw32_HOST_OS.... */

readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
readRawBuffer loc fd is_stream buf off len
  | threaded  = blockingReadRawBuffer loc fd is_stream buf off len
  | otherwise = asyncReadRawBuffer loc fd is_stream buf off len

readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
readRawBufferPtr loc fd is_stream buf off len
  | threaded  = blockingReadRawBufferPtr loc fd is_stream buf off len
  | otherwise = asyncReadRawBufferPtr loc fd is_stream buf off len

writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
writeRawBuffer loc fd is_stream buf off len
  | threaded =  blockingWriteRawBuffer loc fd is_stream buf off len
  | otherwise = asyncWriteRawBuffer    loc fd is_stream buf off len

writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
writeRawBufferPtr loc fd is_stream buf off len
  | threaded  = blockingWriteRawBufferPtr loc fd is_stream buf off len
  | otherwise = asyncWriteRawBufferPtr    loc fd is_stream buf off len

-- ToDo: we don't have a non-blocking primitve read on Win32
readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
readRawBufferNoBlock = readRawBuffer

readRawBufferPtrNoBlock :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
readRawBufferPtrNoBlock = readRawBufferPtr
-- Async versions of the read/write primitives, for the non-threaded RTS

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
    if l == (-1)
      then 
        ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
      else return (fromIntegral l)

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)
    if l == (-1)
      then 
        ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
      else return (fromIntegral l)

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
    if l == (-1)
      then 
        ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
      else return (fromIntegral l)

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)
    if l == (-1)
      then 
        ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
      else return (fromIntegral l)

-- Blocking versions of the read/write primitives, for the threaded RTS

blockingReadRawBuffer loc fd True buf off len = 
  throwErrnoIfMinus1Retry loc $
    safe_recv_rawBuffer fd buf off len
blockingReadRawBuffer loc fd False buf off len = 
  throwErrnoIfMinus1Retry loc $
    safe_read_rawBuffer fd buf off len

blockingReadRawBufferPtr loc fd True buf off len = 
  throwErrnoIfMinus1Retry loc $
    safe_recv_off fd buf off len
blockingReadRawBufferPtr loc fd False buf off len = 
  throwErrnoIfMinus1Retry loc $
    safe_read_off fd buf off len

blockingWriteRawBuffer loc fd True buf off len = 
  throwErrnoIfMinus1Retry loc $
    safe_send_rawBuffer fd buf off len
blockingWriteRawBuffer loc fd False buf off len = 
  throwErrnoIfMinus1Retry loc $
    safe_write_rawBuffer fd buf off len

blockingWriteRawBufferPtr loc fd True buf off len = 
  throwErrnoIfMinus1Retry loc $
    safe_send_off fd buf off len
blockingWriteRawBufferPtr loc fd False buf off len = 
  throwErrnoIfMinus1Retry loc $
    safe_write_off fd buf off len

-- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.
-- These calls may block, but that's ok.

foreign import ccall safe "__hscore_PrelHandle_recv"
   safe_recv_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt

foreign import ccall safe "__hscore_PrelHandle_recv"
   safe_recv_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt

foreign import ccall safe "__hscore_PrelHandle_send"
   safe_send_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt

foreign import ccall safe "__hscore_PrelHandle_send"
   safe_send_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt

#endif

foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool

foreign import ccall safe "__hscore_PrelHandle_read"
   safe_read_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt

foreign import ccall safe "__hscore_PrelHandle_read"
   safe_read_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt

foreign import ccall safe "__hscore_PrelHandle_write"
   safe_write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt

foreign import ccall safe "__hscore_PrelHandle_write"
   safe_write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt

-- ---------------------------------------------------------------------------
-- Standard Handles

-- Three handles are allocated during program initialisation.  The first
-- 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.

fd_stdin  = 0 :: FD
fd_stdout = 1 :: FD
fd_stderr = 2 :: FD

-- | A handle managing input from the Haskell program's standard input channel.
stdin :: Handle
stdin = unsafePerformIO $ do
   -- ToDo: acquire lock
   -- We don't set non-blocking mode on standard handles, because it may
   -- confuse other applications attached to the same TTY/pipe
   -- see Note [nonblock]
   (buf, bmode) <- getBuffer fd_stdin ReadBuffer
   mkStdHandle fd_stdin "<stdin>" ReadHandle buf bmode

-- | A handle managing output to the Haskell program's standard output channel.
stdout :: Handle
stdout = unsafePerformIO $ do
   -- ToDo: acquire lock
   -- We don't set non-blocking mode on standard handles, because it may
   -- confuse other applications attached to the same TTY/pipe
   -- see Note [nonblock]
   (buf, bmode) <- getBuffer fd_stdout WriteBuffer
   mkStdHandle fd_stdout "<stdout>" WriteHandle buf bmode

-- | A handle managing output to the Haskell program's standard error channel.
stderr :: Handle
stderr = unsafePerformIO $ do
    -- ToDo: acquire lock
   -- We don't set non-blocking mode on standard handles, because it may
   -- confuse other applications attached to the same TTY/pipe
   -- see Note [nonblock]
   buf <- mkUnBuffer
   mkStdHandle fd_stderr "<stderr>" WriteHandle buf NoBuffering

-- ---------------------------------------------------------------------------
-- Opening and Closing Files

addFilePathToIOError fun fp (IOError h iot _ str _)
  = IOError h iot fun str (Just fp)

-- | Computation 'openFile' @file mode@ allocates and returns a new, open
-- handle to manage the file @file@.  It manages input if @mode@
-- is 'ReadMode', output if @mode@ is 'WriteMode' or 'AppendMode',
-- and both input and output if mode is 'ReadWriteMode'.
--
-- If the file does not exist and it is opened for output, it should be
-- created as a new file.  If @mode@ is 'WriteMode' and the file
-- already exists, then it should be truncated to zero length.
-- Some operating systems delete empty files, so there is no guarantee
-- that the file will exist following an 'openFile' with @mode@
-- 'WriteMode' unless it is subsequently written to successfully.
-- The handle is positioned at the end of the file if @mode@ is
-- 'AppendMode', and otherwise at the beginning (in which case its
-- internal position is 0).
-- The initial buffer mode is implementation-dependent.
--
-- This operation may fail with:
--
--  * 'isAlreadyInUseError' if the file is already open and cannot be reopened;
--
--  * 'isDoesNotExistError' if the file does not exist; or
--
--  * 'isPermissionError' if the user does not have permission to open the file.
--
-- Note: if you will be working with files containing binary data, you'll want to
-- be using 'openBinaryFile'.
openFile :: FilePath -> IOMode -> IO Handle
openFile fp im = 
  catch 
    (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE)
    (\e -> ioError (addFilePathToIOError "openFile" fp e))

-- | Like 'openFile', but open the file in binary mode.
-- On Windows, reading a file in text mode (which is the default)
-- will translate CRLF to LF, and writing will translate LF to CRLF.
-- This is usually what you want with text files.  With binary files
-- this is undesirable; also, as usual under Microsoft operating systems,
-- text mode treats control-Z as EOF.  Binary mode turns off all special
-- treatment of end-of-line and end-of-file characters.
-- (See also 'hSetBinaryMode'.)

openBinaryFile :: FilePath -> IOMode -> IO Handle
openBinaryFile fp m =
  catch
    (openFile' fp m True)
    (\e -> ioError (addFilePathToIOError "openBinaryFile" fp e))

openFile' filepath mode binary =
  withCString filepath $ \ f ->

    let 
      oflags1 = case mode of
                  ReadMode      -> read_flags
#ifdef mingw32_HOST_OS
                  WriteMode     -> write_flags .|. o_TRUNC
#else
                  WriteMode     -> write_flags
#endif
                  ReadWriteMode -> rw_flags
                  AppendMode    -> append_flags

      binary_flags
          | binary    = o_BINARY
          | otherwise = 0

      oflags = oflags1 .|. binary_flags
    in do

    -- the old implementation had a complicated series of three opens,
    -- which is perhaps because we have to be careful not to open
    -- directories.  However, the man pages I've read say that open()
    -- always returns EISDIR if the file is a directory and was opened
    -- for writing, so I think we're ok with a single open() here...
    fd <- throwErrnoIfMinus1Retry "openFile"
                (c_open f (fromIntegral oflags) 0o666)

    stat@(fd_type,_,_) <- fdStat fd

    h <- fdToHandle_stat fd (Just stat) False filepath mode binary
            `catchException` \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
        -- (so we don't need to worry about removing the newly created file
        --  in the event of an error).

#ifndef mingw32_HOST_OS
        -- we want to truncate() if this is an open in WriteMode, but only
        -- if the target is a RegularFile.  ftruncate() fails on special files
        -- like /dev/null.
    if mode == WriteMode && fd_type == RegularFile
      then throwErrnoIf (/=0) "openFile" 
              (c_ftruncate fd 0)
      else return 0
#endif
    return h


std_flags    = o_NONBLOCK   .|. o_NOCTTY
output_flags = std_flags    .|. o_CREAT
read_flags   = std_flags    .|. o_RDONLY 
write_flags  = output_flags .|. o_WRONLY
rw_flags     = output_flags .|. o_RDWR
append_flags = write_flags  .|. o_APPEND

-- ---------------------------------------------------------------------------
-- fdToHandle

fdToHandle_stat :: FD
            -> Maybe (FDType, CDev, CIno)
            -> Bool
            -> FilePath
            -> IOMode
            -> Bool
            -> IO Handle

fdToHandle_stat fd mb_stat is_socket filepath mode binary = do

#ifdef mingw32_HOST_OS
    -- On Windows, the is_socket flag indicates that the Handle is a socket
#else
    -- On Unix, the is_socket flag indicates that the FD can be made non-blocking
    let non_blocking = is_socket

    when non_blocking $ setNonBlockingFD fd
    -- turn on non-blocking mode
#endif

    let (ha_type, write) =
          case mode of
            ReadMode      -> ( ReadHandle,      False )
            WriteMode     -> ( WriteHandle,     True )
            ReadWriteMode -> ( ReadWriteHandle, True )
            AppendMode    -> ( AppendHandle,    True )

    -- open() won't tell us if it was a directory if we only opened for
    -- reading, so check again.
    (fd_type,dev,ino) <- 
      case mb_stat of
        Just x  -> return x
        Nothing -> fdStat fd

    case fd_type of
        Directory -> 
           ioException (IOError Nothing InappropriateType "openFile"
                           "is a directory" Nothing) 

        -- regular files need to be locked
        RegularFile -> do
#ifndef mingw32_HOST_OS
           r <- lockFile fd dev ino (fromBool write)
           when (r == -1)  $
                ioException (IOError Nothing ResourceBusy "openFile"
                                   "file is locked" Nothing)
#endif
           mkFileHandle fd is_socket filepath ha_type binary

        Stream
           -- only *Streams* can be DuplexHandles.  Other read/write
           -- Handles must share a buffer.
           | ReadWriteHandle <- ha_type -> 
                mkDuplexHandle fd is_socket filepath binary
           | otherwise ->
                mkFileHandle   fd is_socket filepath ha_type binary

        RawDevice -> 
                mkFileHandle fd is_socket filepath ha_type binary

-- | Old API kept to avoid breaking clients
fdToHandle' :: FD -> Maybe FDType -> Bool -> FilePath  -> IOMode -> Bool
            -> IO Handle
fdToHandle' fd mb_type is_socket filepath mode binary
 = do
       let mb_stat = case mb_type of
                        Nothing          -> Nothing
                          -- fdToHandle_stat will do the stat:
                        Just RegularFile -> Nothing
                          -- no stat required for streams etc.:
                        Just other       -> Just (other,0,0)
       fdToHandle_stat fd mb_stat is_socket filepath mode binary

fdToHandle :: FD -> IO Handle
fdToHandle fd = do
   mode <- fdGetMode fd
   let fd_str = "<file descriptor: " ++ show fd ++ ">"
   fdToHandle_stat fd Nothing False fd_str mode True{-bin mode-}
        -- NB. the is_socket flag is False, meaning that:
        --  on Unix the file descriptor will *not* be put in non-blocking mode
        --  on Windows we're guessing this is not a socket (XXX)

#ifndef mingw32_HOST_OS
foreign import ccall unsafe "lockFile"
  lockFile :: CInt -> CDev -> CIno -> CInt -> IO CInt

foreign import ccall unsafe "unlockFile"
  unlockFile :: CInt -> IO CInt
#endif

mkStdHandle :: FD -> FilePath -> HandleType -> IORef Buffer -> BufferMode
        -> IO Handle
mkStdHandle fd filepath ha_type buf bmode = do
   spares <- newIORef BufferListNil
   newFileHandle filepath (stdHandleFinalizer filepath)
            (Handle__ { haFD = fd,
                        haType = ha_type,
                        haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
                        haIsStream = False, -- means FD is blocking on Unix
                        haBufferMode = bmode,
                        haBuffer = buf,
                        haBuffers = spares,
                        haOtherSide = Nothing
                      })

mkFileHandle :: FD -> Bool -> FilePath -> HandleType -> Bool -> IO Handle
mkFileHandle fd is_stream filepath ha_type binary = do
  (buf, bmode) <- getBuffer fd (initBufferState ha_type)

#ifdef mingw32_HOST_OS
{'fraction_non_alphanumeric': 0.10638955022199344, 'fraction_numerical': 0.0033459880316581946, 'mean_word_length': 2.2966781214203893, 'pattern_counts': {'":': 0, '<': 121, '<?xml version=': 0, '>': 621, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 6, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '4200103', 'n_tokens_mistral': 23132, 'n_tokens_neox': 22126, 'n_words': 8531}