{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP, NoImplicitPrelude #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.IO.Handle.FD
-- Copyright   :  (c) The University of Glasgow, 1994-2008
-- License     :  see libraries/base/LICENSE
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  internal
-- Portability :  non-portable
--
-- Handle operations implemented by file descriptors (FDs)
--
-----------------------------------------------------------------------------

module GHC.IO.Handle.FD (
  stdin, stdout, stderr,
  openFile, openBinaryFile, openFileBlocking,
  mkHandleFromFD, fdToHandle, fdToHandle', handleToFd
 ) where

import GHC.Base
import GHC.Show
import Data.Maybe
import Data.Typeable
import Foreign.C.Types
import GHC.MVar
import GHC.IO
import GHC.IO.Encoding
import GHC.IO.Device as IODevice
import GHC.IO.Exception
import GHC.IO.IOMode
import GHC.IO.Handle.Types
import GHC.IO.Handle.Internals
import qualified GHC.IO.FD as FD
import qualified System.Posix.Internals as Posix

-- ---------------------------------------------------------------------------
-- 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.

-- | A handle managing input from the Haskell program's standard input channel.
stdin :: Handle
{-# NOINLINE stdin #-}
stdin = unsafePerformIO $ do
   -- ToDo: acquire lock
   setBinaryMode FD.stdin
   enc <- getLocaleEncoding
   mkHandle FD.stdin "<stdin>" ReadHandle True (Just enc)
                nativeNewlineMode{-translate newlines-}
                (Just stdHandleFinalizer) Nothing

-- | A handle managing output to the Haskell program's standard output channel.
stdout :: Handle
{-# NOINLINE stdout #-}
stdout = unsafePerformIO $ do
   -- ToDo: acquire lock
   setBinaryMode FD.stdout
   enc <- getLocaleEncoding
   mkHandle FD.stdout "<stdout>" WriteHandle True (Just enc)
                nativeNewlineMode{-translate newlines-}
                (Just stdHandleFinalizer) Nothing

-- | A handle managing output to the Haskell program's standard error channel.
stderr :: Handle
{-# NOINLINE stderr #-}
stderr = unsafePerformIO $ do
    -- ToDo: acquire lock
   setBinaryMode FD.stderr
   enc <- getLocaleEncoding
   mkHandle FD.stderr "<stderr>" WriteHandle False{-stderr is unbuffered-}
                (Just enc)
                nativeNewlineMode{-translate newlines-}
                (Just stdHandleFinalizer) Nothing

stdHandleFinalizer :: FilePath -> MVar Handle__ -> IO ()
stdHandleFinalizer fp m = do
  h_ <- takeMVar m
  flushWriteBuffer h_
  case haType h_ of
      ClosedHandle -> return ()
      _other       -> closeTextCodecs h_
  putMVar m (ioe_finalizedHandle fp)

-- We have to put the FDs into binary mode on Windows to avoid the newline
-- translation that the CRT IO library does.
setBinaryMode :: FD.FD -> IO ()
#if defined(mingw32_HOST_OS)
setBinaryMode fd = do _ <- setmode (FD.fdFD fd) True
                      return ()
#else
setBinaryMode _ = return ()
#endif

#if defined(mingw32_HOST_OS)
foreign import ccall unsafe "__hscore_setmode"
  setmode :: CInt -> Bool -> IO CInt
#endif

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

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@
-- 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:
--
--  * 'System.IO.Error.isAlreadyInUseError' if the file is already open and
--    cannot be reopened;
--
--  * 'System.IO.Error.isDoesNotExistError' if the file does not exist or
--    (on POSIX systems) is a FIFO without a reader and 'WriteMode' was
--    requested; or
--
--  * 'System.IO.Error.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 =
  catchException
    (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE True)
    (\e -> ioError (addFilePathToIOError "openFile" fp e))

-- | Like 'openFile', but opens the file in ordinary blocking mode.
-- This can be useful for opening a FIFO for writing: if we open in
-- non-blocking mode then the open will fail if there are no readers,
-- whereas a blocking open will block until a reader appear.
--
-- @since 4.4.0.0
openFileBlocking :: FilePath -> IOMode -> IO Handle
openFileBlocking fp im =
  catchException
    (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE False)
    (\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 'System.IO.hSetBinaryMode'.)

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

openFile' :: String -> IOMode -> Bool -> Bool -> IO Handle
openFile' filepath iomode binary non_blocking = do
  -- first open the file to get an FD
  (fd, fd_type) <- FD.openFile filepath iomode non_blocking

  mb_codec <- if binary then return Nothing else fmap Just getLocaleEncoding

  -- then use it to make a Handle
  mkHandleFromFD fd fd_type filepath iomode
                   False {- do not *set* non-blocking mode -}
                   mb_codec
            `onException` IODevice.close fd
        -- NB. don't forget to close the FD if mkHandleFromFD 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).

-- ---------------------------------------------------------------------------
-- Converting file descriptors from/to Handles

mkHandleFromFD
   :: FD.FD
   -> IODeviceType
   -> FilePath  -- a string describing this file descriptor (e.g. the filename)
   -> IOMode
   -> Bool      --  *set* non-blocking mode on the FD
   -> Maybe TextEncoding
   -> IO Handle

mkHandleFromFD fd0 fd_type filepath iomode set_non_blocking mb_codec
  = do
#if !defined(mingw32_HOST_OS)
    -- turn on non-blocking mode
    fd <- if set_non_blocking
             then FD.setNonBlockingMode fd0 True
             else return fd0
#else
    let _ = set_non_blocking -- warning suppression
    fd <- return fd0
#endif

    let nl | isJust mb_codec = nativeNewlineMode
           | otherwise       = noNewlineTranslation

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

        Stream
           -- only *Streams* can be DuplexHandles.  Other read/write
           -- Handles must share a buffer.
           | ReadWriteMode <- iomode ->
                mkDuplexHandle fd filepath mb_codec nl

        _other ->
           mkFileHandle fd filepath iomode mb_codec nl

-- | Old API kept to avoid breaking clients
fdToHandle' :: CInt
            -> Maybe IODeviceType
            -> Bool -- is_socket on Win, non-blocking on Unix
            -> FilePath
            -> IOMode
            -> Bool -- binary
            -> IO Handle
fdToHandle' fdint mb_type is_socket filepath iomode binary = do
  let mb_stat = case mb_type of
                        Nothing          -> Nothing
                          -- mkFD will do the stat:
                        Just RegularFile -> Nothing
                          -- no stat required for streams etc.:
                        Just other       -> Just (other,0,0)
  (fd,fd_type) <- FD.mkFD fdint iomode mb_stat
                       is_socket
                       is_socket
  enc <- if binary then return Nothing else fmap Just getLocaleEncoding
  mkHandleFromFD fd fd_type filepath iomode is_socket enc

-- | Turn an existing file descriptor into a Handle.  This is used by
-- various external libraries to make Handles.
--
-- Makes a binary Handle.  This is for historical reasons; it should
-- probably be a text Handle with the default encoding and newline
-- translation instead.
fdToHandle :: Posix.FD -> IO Handle
fdToHandle fdint = do
   iomode <- Posix.fdGetMode fdint
   (fd,fd_type) <- FD.mkFD fdint iomode Nothing
            False{-is_socket-}
              -- NB. the is_socket flag is False, meaning that:
              --  on Windows we're guessing this is not a socket (XXX)
            False{-is_nonblock-}
              -- file descriptors that we get from external sources are
              -- not put into non-blocking mode, because that would affect
              -- other users of the file descriptor
   let fd_str = "<file descriptor: " ++ show fd ++ ">"
   mkHandleFromFD fd fd_type fd_str iomode False{-non-block-}
                  Nothing -- bin mode

-- | Turn an existing Handle into a file descriptor. This function throws an
-- IOError if the Handle does not reference a file descriptor.
handleToFd :: Handle -> IO FD.FD
handleToFd h = case h of
  FileHandle _ mv -> do
    Handle__{haDevice = dev} <- readMVar mv
    case cast dev of
      Just fd -> return fd
      Nothing -> throwErr "not a file descriptor"
  DuplexHandle{} -> throwErr "not a file handle"
  where
    throwErr msg = ioException $ IOError (Just h)
      InappropriateType "handleToFd" msg Nothing Nothing

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

dEFAULT_OPEN_IN_BINARY_MODE :: Bool
dEFAULT_OPEN_IN_BINARY_MODE = False


{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude
           , RecordWildCards
           , BangPatterns
           , NondecreasingIndentation
           , RankNTypes
  #-}
{-# OPTIONS_GHC -Wno-unused-matches #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# OPTIONS_HADDOCK not-home #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.IO.Handle.Internals
-- Copyright   :  (c) The University of Glasgow, 1994-2001
-- License     :  see libraries/base/LICENSE
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  internal
-- Portability :  non-portable
--
-- This module defines the basic operations on I\/O \"handles\".  All
-- of the operations defined here are independent of the underlying
-- device.
--
-----------------------------------------------------------------------------

module GHC.IO.Handle.Internals (
  withHandle, withHandle', withHandle_,
  withHandle__', withHandle_', withAllHandles__,
  wantWritableHandle, wantReadableHandle, wantReadableHandle_,
  wantSeekableHandle,

  mkHandle, mkFileHandle, mkDuplexHandle,
  openTextEncoding, closeTextCodecs, initBufferState,
  dEFAULT_CHAR_BUFFER_SIZE,

  flushBuffer, flushWriteBuffer, flushCharReadBuffer,
  flushCharBuffer, flushByteReadBuffer, flushByteWriteBuffer,

  readTextDevice, writeCharBuffer, readTextDeviceNonBlocking,
  decodeByteBuf,

  augmentIOError,
  ioe_closedHandle, ioe_semiclosedHandle,
  ioe_EOF, ioe_notReadable, ioe_notWritable,
  ioe_finalizedHandle, ioe_bufsiz,

  hClose_help, hLookAhead_,

  HandleFinalizer, handleFinalizer,

  debugIO,
 ) where

import GHC.IO
import GHC.IO.IOMode
import GHC.IO.Encoding as Encoding
import GHC.IO.Encoding.Types (CodeBuffer)
import GHC.IO.Handle.Types
import GHC.IO.Buffer
import GHC.IO.BufferedIO (BufferedIO)
import GHC.IO.Exception
import GHC.IO.Device (IODevice, SeekMode(..))
import qualified GHC.IO.Device as IODevice
import qualified GHC.IO.BufferedIO as Buffered

import GHC.Conc.Sync
import GHC.Real
import GHC.Base
import GHC.Exception
import GHC.Num          ( Num(..) )
import GHC.Show
import GHC.IORef
import GHC.MVar
import Data.Typeable
import Data.Maybe
import Foreign
import System.Posix.Internals hiding (FD)

import Foreign.C

c_DEBUG_DUMP :: Bool
c_DEBUG_DUMP = False

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

type HandleFinalizer = FilePath -> MVar Handle__ -> IO ()

newFileHandle :: FilePath -> Maybe HandleFinalizer -> Handle__ -> IO Handle
newFileHandle filepath mb_finalizer hc = do
  m <- newMVar hc
  case mb_finalizer of
    Just finalizer -> addMVarFinalizer m (finalizer filepath m)
    Nothing        -> return ()
  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.
-}

{-# 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 =
 mask_ $ do
   (h',v)  <- do_operation fun h act m
   checkHandleInvariants 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 = withHandle' fun h m $ \h_ -> do
                              a <- act h_
                              return (h_,a)

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__' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO Handle__)
              -> IO ()
withHandle__' fun h m act =
 mask_ $ do
   h'  <- do_operation fun h act m
   checkHandleInvariants h'
   putMVar m h'
   return ()

do_operation :: String -> Handle -> (Handle__ -> IO a) -> MVar Handle__ -> IO a
do_operation fun h act m = do
  h_ <- takeMVar m
  checkHandleInvariants h_
  act h_ `catchException` handler h_
  where
    handler h_ e = do
      putMVar m h_
      case () of
        _ | Just ioe <- fromException e ->
            ioError (augmentIOError ioe fun h)
        _ | Just async_ex <- fromException e -> do -- see Note [async]
            let _ = async_ex :: SomeAsyncException
            t <- myThreadId
            throwTo t e
            do_operation fun h act m
        _otherwise ->
            throwIO e

-- Note [async]
--
-- If an asynchronous exception is raised during an I/O operation,
-- normally it is fine to just re-throw the exception synchronously.
-- However, if we are inside an unsafePerformIO or an
-- unsafeInterleaveIO, this would replace the enclosing thunk with the
-- exception raised, which is wrong (#3997).  We have to release the
-- lock on the Handle, but what do we replace the thunk with?  What
-- should happen when the thunk is subsequently demanded again?
--
-- The only sensible choice we have is to re-do the IO operation on
-- resumption, but then we have to be careful in the IO library that
-- this is always safe to do.  In particular we should
--
--    never perform any side-effects before an interruptible operation
--
-- because the interruptible operation may raise an asynchronous
-- exception, which may cause the operation and its side effects to be
-- subsequently performed again.
--
-- Re-doing the IO operation is achieved by:
--   - using throwTo to re-throw the asynchronous exception asynchronously
--     in the current thread
--   - on resumption, it will be as if throwTo returns.  In that case, we
--     recursively invoke the original operation (see do_operation above).
--
-- Interruptible operations in the I/O library are:
--    - threadWaitRead/threadWaitWrite
--    - fillReadBuffer/flushWriteBuffer
--    - readTextDevice/writeTextDevice

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 path _     -> Just path
                          DuplexHandle path _ _ -> Just path

-- ---------------------------------------------------------------------------
-- 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
    -- we know it's not a ReadHandle or ReadWriteHandle, but we have to
    -- check for ClosedHandle/SemiClosedHandle. (#4808)

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

checkWritableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a
checkWritableHandle act h_@Handle__{..}
  = case haType of
      ClosedHandle         -> ioe_closedHandle
      SemiClosedHandle     -> ioe_semiclosedHandle
      ReadHandle           -> ioe_notWritable
      ReadWriteHandle      -> do
        buf <- readIORef haCharBuffer
        when (not (isWriteBuffer buf)) $ do
           flushCharReadBuffer h_
           flushByteReadBuffer h_
           buf <- readIORef haCharBuffer
           writeIORef haCharBuffer buf{ bufState = WriteBuffer }
           buf <- readIORef haByteBuffer
           buf' <- Buffered.emptyWriteBuffer haDevice buf
           writeIORef haByteBuffer buf'
        act h_
      _other               -> act h_

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

wantReadableHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
wantReadableHandle fun h act = withHandle fun h (checkReadableHandle act)

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
    -- we know it's not a WriteHandle or ReadWriteHandle, but we have to
    -- check for ClosedHandle/SemiClosedHandle. (#4808)

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

checkReadableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a
checkReadableHandle act h_@Handle__{..} =
    case haType of
      ClosedHandle         -> ioe_closedHandle
      SemiClosedHandle     -> ioe_semiclosedHandle
      AppendHandle         -> ioe_notReadable
      WriteHandle          -> ioe_notReadable
      ReadWriteHandle      -> do
          -- a read/write handle and we want to read from it.  We must
          -- flush all buffered write data first.
          bbuf <- readIORef haByteBuffer
          when (isWriteBuffer bbuf) $ do
             when (not (isEmptyBuffer bbuf)) $ flushByteWriteBuffer h_
             cbuf' <- readIORef haCharBuffer
             writeIORef haCharBuffer cbuf'{ bufState = ReadBuffer }
             bbuf <- readIORef haByteBuffer
             writeIORef haByteBuffer bbuf{ bufState = ReadBuffer }
          act h_
      _other               -> act h_

-- ---------------------------------------------------------------------------
-- 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 Nothing)
wantSeekableHandle fun h@(FileHandle _ m) act =
  withHandle_' fun h m (checkSeekableHandle act)

checkSeekableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a
checkSeekableHandle act handle_@Handle__{haDevice=dev} =
    case haType handle_ of
      ClosedHandle      -> ioe_closedHandle
      SemiClosedHandle  -> ioe_semiclosedHandle
      AppendHandle      -> ioe_notSeekable
      _ -> do b <- IODevice.isSeekable dev
              if b then act handle_
                   else ioe_notSeekable

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

ioe_closedHandle, ioe_semiclosedHandle, ioe_EOF,
  ioe_notReadable, ioe_notWritable, ioe_cannotFlushNotSeekable,
  ioe_notSeekable :: IO a

ioe_closedHandle = ioException
   (IOError Nothing IllegalOperation ""
        "handle is closed" Nothing Nothing)
ioe_semiclosedHandle = ioException
   (IOError Nothing IllegalOperation ""
        "handle is semi-closed" Nothing Nothing)
ioe_EOF = ioException
   (IOError Nothing EOF "" "" Nothing Nothing)
ioe_notReadable = ioException
   (IOError Nothing IllegalOperation ""
        "handle is not open for reading" Nothing Nothing)
ioe_notWritable = ioException
   (IOError Nothing IllegalOperation ""
        "handle is not open for writing" Nothing Nothing)
ioe_notSeekable = ioException
   (IOError Nothing IllegalOperation ""
        "handle is not seekable" Nothing Nothing)
ioe_cannotFlushNotSeekable = ioException
   (IOError Nothing IllegalOperation ""
      "cannot flush the read buffer: underlying device is not seekable"
        Nothing Nothing)

ioe_finalizedHandle :: FilePath -> Handle__
ioe_finalizedHandle fp = throw
   (IOError Nothing IllegalOperation ""
        "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 Nothing)
                                -- 9 => should be parens'ified.

-- ---------------------------------------------------------------------------
-- Wrapper for Handle encoding/decoding.

-- The interface for TextEncoding changed so that a TextEncoding doesn't raise
-- an exception if it encounters an invalid sequnce. Furthermore, encoding
-- returns a reason as to why encoding stopped, letting us know if it was due
-- to input/output underflow or an invalid sequence.
--
-- This code adapts this elaborated interface back to the original TextEncoding
-- interface.
--
-- FIXME: it is possible that Handle code using the haDecoder/haEncoder fields
-- could be made clearer by using the 'encode' interface directly. I have not
-- looked into this.

streamEncode :: BufferCodec from to state
             -> Buffer from -> Buffer to
             -> IO (Buffer from, Buffer to)
streamEncode codec from to = fmap (\(_, from', to') -> (from', to')) $ recoveringEncode codec from to

-- | Just like 'encode', but interleaves calls to 'encode' with calls to 'recover' in order to make as much progress as possible
recoveringEncode :: BufferCodec from to state -> CodeBuffer from to
recoveringEncode codec from to = go from to
  where
    go from to = do
      (why, from', to') <- encode codec from to
      -- When we are dealing with Handles, we don't care about input/output
      -- underflow particularly, and we want to delay errors about invalid
      -- sequences as far as possible.
      case why of
        InvalidSequence | bufL from == bufL from' -> do
          -- NB: it is OK to call recover here. Because we saw InvalidSequence, by the invariants
          -- on "encode" it must be the case that there is at least one elements available in the output
          -- buffer. Furthermore, clearly there is at least one element in the input buffer since we found
          -- something invalid there!
          (from', to') <- recover codec from' to'
          go from' to'
        _ -> return (why, from', to')

-- -----------------------------------------------------------------------------
-- 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.
--
-- [later; 8/2010] However, a program like this can yield a strange
-- error message:
--
--   main = writeFile "out" loop
--   loop = let x = x in x
--
-- because the main thread and the Handle are both unreachable at the
-- same time, the Handle may get finalized before the main thread
-- receives the NonTermination exception, and the exception handler
-- will then report an error.  We'd rather this was not an error and
-- the program just prints "<<loop>>".

handleFinalizer :: FilePath -> MVar Handle__ -> IO ()
handleFinalizer fp m = do
  handle_ <- takeMVar m
  (handle_', _) <- hClose_help handle_
  putMVar m handle_'
  return ()

-- ---------------------------------------------------------------------------
-- Allocating buffers

-- using an 8k char buffer instead of 32k improved performance for a
-- basic "cat" program by ~30% for me.  --SDM
dEFAULT_CHAR_BUFFER_SIZE :: Int
dEFAULT_CHAR_BUFFER_SIZE = 2048 -- 8k/sizeof(HsChar)

getCharBuffer :: IODevice dev => dev -> BufferState
              -> IO (IORef CharBuffer, BufferMode)
getCharBuffer dev state = do
  buffer <- newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state
  ioref  <- newIORef buffer
  is_tty <- IODevice.isTerminal dev

  let buffer_mode
         | is_tty    = LineBuffering
         | otherwise = BlockBuffering Nothing

  return (ioref, buffer_mode)

mkUnBuffer :: BufferState -> IO (IORef CharBuffer, BufferMode)
mkUnBuffer state = do
  buffer <- newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state
              --  See [note Buffer Sizing], GHC.IO.Handle.Types
  ref <- newIORef buffer
  return (ref, NoBuffering)

-- -----------------------------------------------------------------------------
-- Flushing buffers

-- | syncs the file with the buffer, including moving the
-- file pointer backwards in the case of a read buffer.  This can fail
-- on a non-seekable read Handle.
flushBuffer :: Handle__ -> IO ()
flushBuffer h_@Handle__{..} = do
  buf <- readIORef haCharBuffer
  case bufState buf of
    ReadBuffer  -> do
        flushCharReadBuffer h_
        flushByteReadBuffer h_
    WriteBuffer -> do
        flushByteWriteBuffer h_

-- | flushes the Char buffer only.  Works on all Handles.
flushCharBuffer :: Handle__ -> IO ()
flushCharBuffer h_@Handle__{..} = do
  cbuf <- readIORef haCharBuffer
  case bufState cbuf of
    ReadBuffer  -> do
        flushCharReadBuffer h_
    WriteBuffer ->
        -- Nothing to do here. Char buffer on a write Handle is always empty
        -- between Handle operations.
        -- See [note Buffer Flushing], GHC.IO.Handle.Types.
        when (not (isEmptyBuffer cbuf)) $
           error "internal IO library error: Char buffer non-empty"

-- -----------------------------------------------------------------------------
-- Writing data (flushing write buffers)

-- flushWriteBuffer flushes the byte buffer iff it contains pending write
-- data. Because the Char buffer on a write Handle is always empty between
-- Handle operations (see [note Buffer Flushing], GHC.IO.Handle.Types),
-- both buffers are empty after this.
flushWriteBuffer :: Handle__ -> IO ()
flushWriteBuffer h_@Handle__{..} = do
  buf <- readIORef haByteBuffer
  when (isWriteBuffer buf) $ flushByteWriteBuffer h_

flushByteWriteBuffer :: Handle__ -> IO ()
flushByteWriteBuffer h_@Handle__{..} = do
  bbuf <- readIORef haByteBuffer
  when (not (isEmptyBuffer bbuf)) $ do
    bbuf' <- Buffered.flushWriteBuffer haDevice bbuf
    writeIORef haByteBuffer bbuf'

-- write the contents of the CharBuffer to the Handle__.
-- The data will be encoded and pushed to the byte buffer,
-- flushing if the buffer becomes full.
writeCharBuffer :: Handle__ -> CharBuffer -> IO ()
writeCharBuffer h_@Handle__{..} !cbuf = do
  --
  bbuf <- readIORef haByteBuffer

  debugIO ("writeCharBuffer: cbuf=" ++ summaryBuffer cbuf ++
        " bbuf=" ++ summaryBuffer bbuf)

  (cbuf',bbuf') <- case haEncoder of
    Nothing      -> latin1_encode cbuf bbuf
    Just encoder -> (streamEncode encoder) cbuf bbuf

  debugIO ("writeCharBuffer after encoding: cbuf=" ++ summaryBuffer cbuf' ++
        " bbuf=" ++ summaryBuffer bbuf')

          -- flush the byte buffer if it is full
  if isFullBuffer bbuf'
          --  or we made no progress
     || not (isEmptyBuffer cbuf') && bufL cbuf' == bufL cbuf
          -- or the byte buffer has more elements than the user wanted buffered
     || (case haBufferMode of
          BlockBuffering (Just s) -> bufferElems bbuf' >= s
          NoBuffering -> True
          _other -> False)
    then do
      bbuf'' <- Buffered.flushWriteBuffer haDevice bbuf'
      writeIORef haByteBuffer bbuf''
    else
      writeIORef haByteBuffer bbuf'

  if not (isEmptyBuffer cbuf')
     then writeCharBuffer h_ cbuf'
     else return ()

-- -----------------------------------------------------------------------------
-- Flushing read buffers

-- It is always possible to flush the Char buffer back to the byte buffer.
flushCharReadBuffer :: Handle__ -> IO ()
flushCharReadBuffer Handle__{..} = do
  cbuf <- readIORef haCharBuffer
  if isWriteBuffer cbuf || isEmptyBuffer cbuf then return () else do

  -- haLastDecode is the byte buffer just before we did our last batch of
  -- decoding.  We're going to re-decode the bytes up to the current char,
  -- to find out where we should revert the byte buffer to.
  (codec_state, bbuf0) <- readIORef haLastDecode

  cbuf0 <- readIORef haCharBuffer
  writeIORef haCharBuffer cbuf0{ bufL=0, bufR=0 }

  -- if we haven't used any characters from the char buffer, then just
  -- re-install the old byte buffer.
  if bufL cbuf0 == 0
     then do writeIORef haByteBuffer bbuf0
             return ()
     else do

  case haDecoder of
    Nothing -> do
      writeIORef haByteBuffer bbuf0 { bufL = bufL bbuf0 + bufL cbuf0 }
      -- no decoder: the number of bytes to decode is the same as the
      -- number of chars we have used up.

    Just decoder -> do
      debugIO ("flushCharReadBuffer re-decode, bbuf=" ++ summaryBuffer bbuf0 ++
               " cbuf=" ++ summaryBuffer cbuf0)

      -- restore the codec state
      setState decoder codec_state

      (bbuf1,cbuf1) <- (streamEncode decoder) bbuf0
                               cbuf0{ bufL=0, bufR=0, bufSize = bufL cbuf0 }

      debugIO ("finished, bbuf=" ++ summaryBuffer bbuf1 ++
               " cbuf=" ++ summaryBuffer cbuf1)

      writeIORef haByteBuffer bbuf1

-- When flushing the byte 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.

flushByteReadBuffer :: Handle__ -> IO ()
flushByteReadBuffer h_@Handle__{..} = do
  bbuf <- readIORef haByteBuffer

  if isEmptyBuffer bbuf then return () else do

  seekable <- IODevice.isSeekable haDevice
  when (not seekable) $ ioe_cannotFlushNotSeekable

  let seek = negate (bufR bbuf - bufL bbuf)

  debugIO ("flushByteReadBuffer: new file offset = " ++ show seek)
  IODevice.seek haDevice RelativeSeek (fromIntegral seek)

  writeIORef haByteBuffer bbuf{ bufL=0, bufR=0 }

-- ----------------------------------------------------------------------------
-- Making Handles

mkHandle :: (IODevice dev, BufferedIO dev, Typeable dev) => dev
            -> FilePath
            -> HandleType
            -> Bool                     -- buffered?
            -> Maybe TextEncoding
            -> NewlineMode
            -> Maybe HandleFinalizer
            -> Maybe (MVar Handle__)
            -> IO Handle

mkHandle dev filepath ha_type buffered mb_codec nl finalizer other_side = do
   openTextEncoding mb_codec ha_type $ \ mb_encoder mb_decoder -> do

   let buf_state = initBufferState ha_type
   bbuf <- Buffered.newBuffer dev buf_state
   bbufref <- newIORef bbuf
   last_decode <- newIORef (errorWithoutStackTrace "codec_state", bbuf)

   (cbufref,bmode) <-
         if buffered then getCharBuffer dev buf_state
                     else mkUnBuffer buf_state

   spares <- newIORef BufferListNil
   newFileHandle filepath finalizer
            (Handle__ { haDevice = dev,
                        haType = ha_type,
                        haBufferMode = bmode,
                        haByteBuffer = bbufref,
                        haLastDecode = last_decode,
                        haCharBuffer = cbufref,
                        haBuffers = spares,
                        haEncoder = mb_encoder,
                        haDecoder = mb_decoder,
                        haCodec = mb_codec,
                        haInputNL = inputNL nl,
                        haOutputNL = outputNL nl,
                        haOtherSide = other_side
                      })

-- | makes a new 'Handle'
mkFileHandle :: (IODevice dev, BufferedIO dev, Typeable dev)
             => dev -- ^ the underlying IO device, which must support
                    -- 'IODevice', 'BufferedIO' and 'Typeable'
             -> FilePath
                    -- ^ a string describing the 'Handle', e.g. the file
                    -- path for a file.  Used in error messages.
             -> IOMode
                    -- The mode in which the 'Handle' is to be used
             -> Maybe TextEncoding
                    -- Create the 'Handle' with no text encoding?
             -> NewlineMode
                    -- Translate newlines?
             -> IO Handle
mkFileHandle dev filepath iomode mb_codec tr_newlines = do
   mkHandle dev filepath (ioModeToHandleType iomode) True{-buffered-} mb_codec
            tr_newlines
            (Just handleFinalizer) Nothing{-other_side-}

-- | like 'mkFileHandle', except that a 'Handle' is created with two
-- independent buffers, one for reading and one for writing.  Used for
-- full-duplex streams, such as network sockets.
mkDuplexHandle :: (IODevice dev, BufferedIO dev, Typeable dev) => dev
               -> FilePath -> Maybe TextEncoding -> NewlineMode -> IO Handle
mkDuplexHandle dev filepath mb_codec tr_newlines = do

  write_side@(FileHandle _ write_m) <-
       mkHandle dev filepath WriteHandle True mb_codec
                        tr_newlines
                        (Just handleFinalizer)
                        Nothing -- no othersie

  read_side@(FileHandle _ read_m) <-
      mkHandle dev filepath ReadHandle True mb_codec
                        tr_newlines
                        Nothing -- no finalizer
                        (Just write_m)

  return (DuplexHandle filepath read_m write_m)

ioModeToHandleType :: IOMode -> HandleType
ioModeToHandleType ReadMode      = ReadHandle
ioModeToHandleType WriteMode     = WriteHandle
ioModeToHandleType ReadWriteMode = ReadWriteHandle
ioModeToHandleType AppendMode    = AppendHandle

initBufferState :: HandleType -> BufferState
initBufferState ReadHandle = ReadBuffer
initBufferState _          = WriteBuffer

openTextEncoding
   :: Maybe TextEncoding
   -> HandleType
   -> (forall es ds . Maybe (TextEncoder es) -> Maybe (TextDecoder ds) -> IO a)
   -> IO a

openTextEncoding Nothing   ha_type cont = cont Nothing Nothing
openTextEncoding (Just TextEncoding{..}) ha_type cont = do
    mb_decoder <- if isReadableHandleType ha_type then do
                     decoder <- mkTextDecoder
                     return (Just decoder)
                  else
                     return Nothing
    mb_encoder <- if isWritableHandleType ha_type then do
                     encoder <- mkTextEncoder
                     return (Just encoder)
                  else
                     return Nothing
    cont mb_encoder mb_decoder

closeTextCodecs :: Handle__ -> IO ()
closeTextCodecs Handle__{..} = do
  case haDecoder of Nothing -> return (); Just d -> Encoding.close d
  case haEncoder of Nothing -> return (); Just d -> Encoding.close d

-- ---------------------------------------------------------------------------
-- closing Handles

-- hClose_help is also called by lazyRead (in GHC.IO.Handle.Text) when
-- EOF is read or an IO error occurs on a lazy stream.  The
-- semi-closed Handle is 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 SomeException)
hClose_help handle_ =
  case haType handle_ of
      ClosedHandle -> return (handle_,Nothing)
      _ -> do mb_exc1 <- trymaybe $ flushWriteBuffer handle_ -- interruptible
                    -- it is important that hClose doesn't fail and
                    -- leave the Handle open (#3128), so we catch
                    -- exceptions when flushing the buffer.
              (h_, mb_exc2) <- hClose_handle_ handle_
              return (h_, if isJust mb_exc1 then mb_exc1 else mb_exc2)

trymaybe :: IO () -> IO (Maybe SomeException)
trymaybe io = (do io; return Nothing) `catchException` \e -> return (Just e)

hClose_handle_ :: Handle__ -> IO (Handle__, Maybe SomeException)
hClose_handle_ h_@Handle__{..} = do

    -- close the file descriptor, but not when this is the read
    -- side of a duplex handle.
    -- If an exception is raised by the close(), we want to continue
    -- to close the handle and release the lock if it has one, then
    -- we return the exception to the caller of hClose_help which can
    -- raise it if necessary.
    maybe_exception <-
      case haOtherSide of
        Nothing -> trymaybe $ IODevice.close haDevice
        Just _  -> return Nothing

    -- free the spare buffers
    writeIORef haBuffers BufferListNil
    writeIORef haCharBuffer noCharBuffer
    writeIORef haByteBuffer noByteBuffer

    -- release our encoder/decoder
    closeTextCodecs h_

    -- we must set the fd to -1, because the finalizer is going
    -- to run eventually and try to close/unlock it.
    -- ToDo: necessary?  the handle will be marked ClosedHandle
    -- XXX GHC won't let us use record update here, hence wildcards
    return (Handle__{ haType = ClosedHandle, .. }, maybe_exception)

{-# NOINLINE noCharBuffer #-}
noCharBuffer :: CharBuffer
noCharBuffer = unsafePerformIO $ newCharBuffer 1 ReadBuffer

{-# NOINLINE noByteBuffer #-}
noByteBuffer :: Buffer Word8
noByteBuffer = unsafePerformIO $ newByteBuffer 1 ReadBuffer

-- ---------------------------------------------------------------------------
-- Looking ahead

hLookAhead_ :: Handle__ -> IO Char
hLookAhead_ handle_@Handle__{..} = do
    buf <- readIORef haCharBuffer

    -- fill up the read buffer if necessary
    new_buf <- if isEmptyBuffer buf
                  then readTextDevice handle_ buf
                  else return buf
    writeIORef haCharBuffer new_buf

    peekCharBuf (bufRaw buf) (bufL buf)

-- ---------------------------------------------------------------------------
-- debugging

debugIO :: String -> IO ()
debugIO s
 | c_DEBUG_DUMP
    = do _ <- withCStringLen (s ++ "\n") $
                  \(p, len) -> c_write 1 (castPtr p) (fromIntegral len)
         return ()
 | otherwise = return ()

-- ----------------------------------------------------------------------------
-- Text input/output

-- Read characters into the provided buffer.  Return when any
-- characters are available; raise an exception if the end of
-- file is reached.
--
-- In uses of readTextDevice within base, the input buffer is either:
--   * empty
--   * or contains a single \r (when doing newline translation)
--
-- The input character buffer must have a capacity at least 1 greater
-- than the number of elements it currently contains.
--
-- Users of this function expect that the buffer returned contains
-- at least 1 more character than the input buffer.
readTextDevice :: Handle__ -> CharBuffer -> IO CharBuffer
readTextDevice h_@Handle__{..} cbuf = do
  --
  bbuf0 <- readIORef haByteBuffer

  debugIO ("readTextDevice: cbuf=" ++ summaryBuffer cbuf ++
        " bbuf=" ++ summaryBuffer bbuf0)

  bbuf1 <- if not (isEmptyBuffer bbuf0)
              then return bbuf0
              else do
                   (r,bbuf1) <- Buffered.fillReadBuffer haDevice bbuf0
                   if r == 0 then ioe_EOF else do  -- raise EOF
                   return bbuf1

  debugIO ("readTextDevice after reading: bbuf=" ++ summaryBuffer bbuf1)

  (bbuf2,cbuf') <-
      case haDecoder of
          Nothing      -> do
               writeIORef haLastDecode (errorWithoutStackTrace "codec_state", bbuf1)
               latin1_decode bbuf1 cbuf
          Just decoder -> do
               state <- getState decoder
               writeIORef haLastDecode (state, bbuf1)
               (streamEncode decoder) bbuf1 cbuf

  debugIO ("readTextDevice after decoding: cbuf=" ++ summaryBuffer cbuf' ++
        " bbuf=" ++ summaryBuffer bbuf2)

  -- We can't return from readTextDevice without reading at least a single extra character,
  -- so check that we have managed to achieve that
  writeIORef haByteBuffer bbuf2
  if bufR cbuf' == bufR cbuf
     -- we need more bytes to make a Char. NB: bbuf2 may be empty (even though bbuf1 wasn't) when we
     -- are using an encoding that can skip bytes without outputting characters, such as UTF8//IGNORE
     then readTextDevice' h_ bbuf2 cbuf
     else return cbuf'

-- we have an incomplete byte sequence at the end of the buffer: try to
-- read more bytes.
readTextDevice' :: Handle__ -> Buffer Word8 -> CharBuffer -> IO CharBuffer
readTextDevice' h_@Handle__{..} bbuf0 cbuf0 = do
  --
  -- copy the partial sequence to the beginning of the buffer, so we have
  -- room to read more bytes.
  bbuf1 <- slideContents bbuf0

  -- readTextDevice only calls us if we got some bytes but not some characters.
  -- This can't occur if haDecoder is Nothing because latin1_decode accepts all bytes.
  let Just decoder = haDecoder

  (r,bbuf2) <- Buffered.fillReadBuffer haDevice bbuf1
  if r == 0
   then do
     -- bbuf2 can be empty here when we encounter an invalid byte sequence at the end of the input
     -- with a //IGNORE codec which consumes bytes without outputting characters
     if isEmptyBuffer bbuf2 then ioe_EOF else do
     (bbuf3, cbuf1) <- recover decoder bbuf2 cbuf0
     debugIO ("readTextDevice' after recovery: bbuf=" ++ summaryBuffer bbuf3 ++ ", cbuf=" ++ summaryBuffer cbuf1)
     writeIORef haByteBuffer bbuf3
     -- We should recursively invoke readTextDevice after recovery,
     -- if recovery did not add at least one new character to the buffer:
     --  1. If we were using IgnoreCodingFailure it might be the case that
     --     cbuf1 is the same length as cbuf0 and we need to raise ioe_EOF
     --  2. If we were using TransliterateCodingFailure we might have *mutated*
     --     the byte buffer without changing the pointers into either buffer.
     --     We need to try and decode it again - it might just go through this time.
     if bufR cbuf1 == bufR cbuf0
      then readTextDevice h_ cbuf1
      else return cbuf1
   else do
    debugIO ("readTextDevice' after reading: bbuf=" ++ summaryBuffer bbuf2)

    (bbuf3,cbuf1) <- do
       state <- getState decoder
       writeIORef haLastDecode (state, bbuf2)
       (streamEncode decoder) bbuf2 cbuf0

    debugIO ("readTextDevice' after decoding: cbuf=" ++ summaryBuffer cbuf1 ++
          " bbuf=" ++ summaryBuffer bbuf3)

    writeIORef haByteBuffer bbuf3
    if bufR cbuf0 == bufR cbuf1
       then readTextDevice' h_ bbuf3 cbuf1
       else return cbuf1

-- Read characters into the provided buffer.  Do not block;
-- return zero characters instead.  Raises an exception on end-of-file.
readTextDeviceNonBlocking :: Handle__ -> CharBuffer -> IO CharBuffer
readTextDeviceNonBlocking h_@Handle__{..} cbuf = do
  --
  bbuf0 <- readIORef haByteBuffer
  when (isEmptyBuffer bbuf0) $ do
     (r,bbuf1) <- Buffered.fillReadBuffer0 haDevice bbuf0
     if isNothing r then ioe_EOF else do  -- raise EOF
     writeIORef haByteBuffer bbuf1

  decodeByteBuf h_ cbuf

-- Decode bytes from the byte buffer into the supplied CharBuffer.
decodeByteBuf :: Handle__ -> CharBuffer -> IO CharBuffer
decodeByteBuf h_@Handle__{..} cbuf = do
  --
  bbuf0 <- readIORef haByteBuffer

  (bbuf2,cbuf') <-
      case haDecoder of
          Nothing      -> do
               writeIORef haLastDecode (errorWithoutStackTrace "codec_state", bbuf0)
               latin1_decode bbuf0 cbuf
          Just decoder -> do
               state <- getState decoder
               writeIORef haLastDecode (state, bbuf0)
               (streamEncode decoder) bbuf0 cbuf

  writeIORef haByteBuffer bbuf2
  return cbuf'


{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP
           , NoImplicitPrelude
           , RecordWildCards
           , BangPatterns
           , NondecreasingIndentation
           , MagicHash
  #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# OPTIONS_GHC -Wno-unused-matches #-}
{-# OPTIONS_HADDOCK not-home #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.IO.Text
-- Copyright   :  (c) The University of Glasgow, 1992-2008
-- License     :  see libraries/base/LICENSE
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  internal
-- Portability :  non-portable
--
-- String I\/O functions
--
-----------------------------------------------------------------------------

module GHC.IO.Handle.Text (
        hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
        commitBuffer',       -- hack, see below
        hGetBuf, hGetBufSome, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking,
        memcpy, hPutStrLn,
    ) where

import GHC.IO
import GHC.IO.FD
import GHC.IO.Buffer
import qualified GHC.IO.BufferedIO as Buffered
import GHC.IO.Exception
import GHC.Exception
import GHC.IO.Handle.Types
import GHC.IO.Handle.Internals
import qualified GHC.IO.Device as IODevice
import qualified GHC.IO.Device as RawIO

import Foreign
import Foreign.C

import qualified Control.Exception as Exception
import Data.Typeable
import System.IO.Error
import Data.Maybe

import GHC.IORef
import GHC.Base
import GHC.Real
import GHC.Num
import GHC.Show
import GHC.List

-- ---------------------------------------------------------------------------
-- Simple input operations

-- If hWaitForInput finds anything in the Handle's buffer, it
-- immediately returns.  If not, it tries to read from the underlying
-- OS handle. Notice that for buffered Handles connected to terminals
-- this means waiting until a complete line is available.

-- | Computation 'hWaitForInput' @hdl t@
-- waits until input is available on handle @hdl@.
-- It returns 'True' as soon as input is available on @hdl@,
-- or 'False' if no input is available within @t@ milliseconds.  Note that
-- 'hWaitForInput' waits until one or more full /characters/ are available,
-- which means that it needs to do decoding, and hence may fail
-- with a decoding error.
--
-- If @t@ is less than zero, then @hWaitForInput@ waits indefinitely.
--
-- This operation may fail with:
--
--  * 'isEOFError' if the end of file has been reached.
--
--  * a decoding error, if the input begins with an invalid byte sequence
--    in this Handle's encoding.
--
-- NOTE for GHC users: unless you use the @-threaded@ flag,
-- @hWaitForInput hdl t@ where @t >= 0@ will block all other Haskell
-- threads for the duration of the call.  It behaves like a
-- @safe@ foreign call in this respect.
--

hWaitForInput :: Handle -> Int -> IO Bool
hWaitForInput h msecs = do
  wantReadableHandle_ "hWaitForInput" h $ \ handle_@Handle__{..} -> do
  cbuf <- readIORef haCharBuffer

  if not (isEmptyBuffer cbuf) then return True else do

  if msecs < 0
        then do cbuf' <- readTextDevice handle_ cbuf
                writeIORef haCharBuffer cbuf'
                return True
        else do
               -- there might be bytes in the byte buffer waiting to be decoded
               cbuf' <- decodeByteBuf handle_ cbuf
               writeIORef haCharBuffer cbuf'

               if not (isEmptyBuffer cbuf') then return True else do

                r <- IODevice.ready haDevice False{-read-} msecs
                if r then do -- Call hLookAhead' to throw an EOF
                             -- exception if appropriate
                             _ <- hLookAhead_ handle_
                             return True
                     else return False
                -- XXX we should only return when there are full characters
                -- not when there are only bytes.  That would mean looping
                -- and re-running IODevice.ready if we don't have any full
                -- characters; but we don't know how long we've waited
                -- so far.

-- ---------------------------------------------------------------------------
-- hGetChar

-- | Computation 'hGetChar' @hdl@ reads a character from the file or
-- channel managed by @hdl@, blocking until a character is available.
--
-- This operation may fail with:
--
--  * 'isEOFError' if the end of file has been reached.

hGetChar :: Handle -> IO Char
hGetChar handle =
  wantReadableHandle_ "hGetChar" handle $ \handle_@Handle__{..} -> do

  -- buffering mode makes no difference: we just read whatever is available
  -- from the device (blocking only if there is nothing available), and then
  -- return the first character.
  -- See [note Buffered Reading] in GHC.IO.Handle.Types
  buf0 <- readIORef haCharBuffer

  buf1 <- if isEmptyBuffer buf0
             then readTextDevice handle_ buf0
             else return buf0

  (c1,i) <- readCharBuf (bufRaw buf1) (bufL buf1)
  let buf2 = bufferAdjustL i buf1

  if haInputNL == CRLF && c1 == '\r'
     then do
            mbuf3 <- if isEmptyBuffer buf2
                      then maybeFillReadBuffer handle_ buf2
                      else return (Just buf2)

            case mbuf3 of
               -- EOF, so just return the '\r' we have
               Nothing -> do
                  writeIORef haCharBuffer buf2
                  return '\r'
               Just buf3 -> do
                  (c2,i2) <- readCharBuf (bufRaw buf2) (bufL buf2)
                  if c2 == '\n'
                     then do
                       writeIORef haCharBuffer (bufferAdjustL i2 buf3)
                       return '\n'
                     else do
                       -- not a \r\n sequence, so just return the \r
                       writeIORef haCharBuffer buf3
                       return '\r'
     else do
            writeIORef haCharBuffer buf2
            return c1

-- ---------------------------------------------------------------------------
-- hGetLine

-- | Computation 'hGetLine' @hdl@ reads a line from the file or
-- channel managed by @hdl@.
--
-- This operation may fail with:
--
--  * 'isEOFError' if the end of file is encountered when reading
--    the /first/ character of the line.
--
-- If 'hGetLine' encounters end-of-file at any other point while reading
-- in a line, it is treated as a line terminator and the (partial)
-- line is returned.

hGetLine :: Handle -> IO String
hGetLine h =
  wantReadableHandle_ "hGetLine" h $ \ handle_ -> do
     hGetLineBuffered handle_

hGetLineBuffered :: Handle__ -> IO String
hGetLineBuffered handle_@Handle__{..} = do
  buf <- readIORef haCharBuffer
  hGetLineBufferedLoop handle_ buf []

hGetLineBufferedLoop :: Handle__
                     -> CharBuffer -> [String]
                     -> IO String
hGetLineBufferedLoop handle_@Handle__{..}
        buf@Buffer{ bufL=r0, bufR=w, bufRaw=raw0 } xss =
  let
        -- find the end-of-line character, if there is one
        loop raw r
           | r == w = return (False, w)
           | otherwise =  do
                (c,r') <- readCharBuf raw r
                if c == '\n'
                   then return (True, r) -- NB. not r': don't include the '\n'
                   else loop raw r'
  in do
  (eol, off) <- loop raw0 r0

  debugIO ("hGetLineBufferedLoop: r=" ++ show r0 ++ ", w=" ++ show w ++ ", off=" ++ show off)

  (xs,r') <- if haInputNL == CRLF
                then unpack_nl raw0 r0 off ""
                else do xs <- unpack raw0 r0 off ""
                        return (xs,off)

  -- if eol == True, then off is the offset of the '\n'
  -- otherwise off == w and the buffer is now empty.
  if eol -- r' == off
        then do writeIORef haCharBuffer (bufferAdjustL (off+1) buf)
                return (concat (reverse (xs:xss)))
        else do
             let buf1 = bufferAdjustL r' buf
             maybe_buf <- maybeFillReadBuffer handle_ buf1
             case maybe_buf of
                -- Nothing indicates we caught an EOF, and we may have a
                -- partial line to return.
                Nothing -> do
                     -- we reached EOF.  There might be a lone \r left
                     -- in the buffer, so check for that and
                     -- append it to the line if necessary.
                     --
                     let pre = if not (isEmptyBuffer buf1) then "\r" else ""
                     writeIORef haCharBuffer buf1{ bufL=0, bufR=0 }
                     let str = concat (reverse (pre:xs:xss))
                     if not (null str)
                        then return str
                        else ioe_EOF
                Just new_buf ->
                     hGetLineBufferedLoop handle_ new_buf (xs:xss)

maybeFillReadBuffer :: Handle__ -> CharBuffer -> IO (Maybe CharBuffer)
maybeFillReadBuffer handle_ buf
  = catchException
     (do buf' <- getSomeCharacters handle_ buf
         return (Just buf')
     )
     (\e -> do if isEOFError e
                  then return Nothing
                  else ioError e)

-- See GHC.IO.Buffer
#define CHARBUF_UTF32
-- #define CHARBUF_UTF16

-- NB. performance-critical code: eyeball the Core.
unpack :: RawCharBuffer -> Int -> Int -> [Char] -> IO [Char]
unpack !buf !r !w acc0
 | r == w    = return acc0
 | otherwise =
  withRawBuffer buf $ \pbuf ->
    let
        unpackRB acc !i
         | i < r  = return acc
         | otherwise = do
              -- Here, we are rather careful to only put an *evaluated* character
              -- in the output string. Due to pointer tagging, this allows the consumer
              -- to avoid ping-ponging between the actual consumer code and the thunk code
#if defined(CHARBUF_UTF16)
              -- reverse-order decoding of UTF-16
              c2 <- peekElemOff pbuf i
              if (c2 < 0xdc00 || c2 > 0xdffff)
                 then unpackRB (unsafeChr (fromIntegral c2) : acc) (i-1)
                 else do c1 <- peekElemOff pbuf (i-1)
                         let c = (fromIntegral c1 - 0xd800) * 0x400 +
                                 (fromIntegral c2 - 0xdc00) + 0x10000
                         case desurrogatifyRoundtripCharacter (unsafeChr c) of
                           { C# c# -> unpackRB (C# c# : acc) (i-2) }
#else
              c <- peekElemOff pbuf i
              unpackRB (c : acc) (i-1)
#endif
     in
     unpackRB acc0 (w-1)

-- NB. performance-critical code: eyeball the Core.
unpack_nl :: RawCharBuffer -> Int -> Int -> [Char] -> IO ([Char],Int)
unpack_nl !buf !r !w acc0
 | r == w    =  return (acc0, 0)
 | otherwise =
  withRawBuffer buf $ \pbuf ->
    let
        unpackRB acc !i
         | i < r  = return acc
         | otherwise = do
              c <- peekElemOff pbuf i
              if (c == '\n' && i > r)
                 then do
                         c1 <- peekElemOff pbuf (i-1)
                         if (c1 == '\r')
                            then unpackRB ('\n':acc) (i-2)
                            else unpackRB ('\n':acc) (i-1)
                 else do
                         unpackRB (c : acc) (i-1)
     in do
     c <- peekElemOff pbuf (w-1)
     if (c == '\r')
        then do
                -- If the last char is a '\r', we need to know whether or
                -- not it is followed by a '\n', so leave it in the buffer
                -- for now and just unpack the rest.
                str <- unpackRB acc0 (w-2)
                return (str, w-1)
        else do
                str <- unpackRB acc0 (w-1)
                return (str, w)

-- Note [#5536]
--
-- We originally had
--
--    let c' = desurrogatifyRoundtripCharacter c in
--    c' `seq` unpackRB (c':acc) (i-1)
--
-- but this resulted in Core like
--
--    case (case x <# y of True -> C# e1; False -> C# e2) of c
--      C# _ -> unpackRB (c:acc) (i-1)
--
-- which compiles into a continuation for the outer case, with each
-- branch of the inner case building a C# and then jumping to the
-- continuation.  We'd rather not have this extra jump, which makes
-- quite a difference to performance (see #5536) It turns out that
-- matching on the C# directly causes GHC to do the case-of-case,
-- giving much straighter code.

-- -----------------------------------------------------------------------------
-- hGetContents

-- hGetContents on a DuplexHandle only affects the read side: you can
-- carry on writing to it afterwards.

-- | Computation 'hGetContents' @hdl@ returns the list of characters
-- corresponding to the unread portion of the channel or file managed
-- by @hdl@, which is put into an intermediate state, /semi-closed/.
-- In this state, @hdl@ is effectively closed,
-- but items are read from @hdl@ on demand and accumulated in a special
-- list returned by 'hGetContents' @hdl@.
--
-- Any operation that fails because a handle is closed,
-- also fails if a handle is semi-closed.  The only exception is
-- 'System.IO.hClose'.  A semi-closed handle becomes closed:
--
--  * if 'System.IO.hClose' is applied to it;
--
--  * if an I\/O error occurs when reading an item from the handle;
--
--  * or once the entire contents of the handle has been read.
--
-- Once a semi-closed handle becomes closed, the contents of the
-- associated list becomes fixed.  The contents of this final list is
-- only partially specified: it will contain at least all the items of
-- the stream that were evaluated prior to the handle becoming closed.
--
-- Any I\/O errors encountered while a handle is semi-closed are simply
-- discarded.
--
-- This operation may fail with:
--
--  * 'isEOFError' if the end of file has been reached.

hGetContents :: Handle -> IO String
hGetContents handle =
   wantReadableHandle "hGetContents" handle $ \handle_ -> do
      xs <- lazyRead handle
      return (handle_{ haType=SemiClosedHandle}, xs )

-- Note that someone may close the semi-closed handle (or change its
-- buffering), so each time these lazy read functions are pulled on,
-- they have to check whether the handle has indeed been closed.

lazyRead :: Handle -> IO String
lazyRead handle =
   unsafeInterleaveIO $
        withHandle "hGetContents" handle $ \ handle_ -> do
        case haType handle_ of
          SemiClosedHandle -> lazyReadBuffered handle handle_
          ClosedHandle
            -> ioException
                  (IOError (Just handle) IllegalOperation "hGetContents"
                        "delayed read on closed handle" Nothing Nothing)
          _ -> ioException
                  (IOError (Just handle) IllegalOperation "hGetContents"
                        "illegal handle type" Nothing Nothing)

lazyReadBuffered :: Handle -> Handle__ -> IO (Handle__, [Char])
lazyReadBuffered h handle_@Handle__{..} = do
   buf <- readIORef haCharBuffer
   Exception.catch
        (do
            buf'@Buffer{..} <- getSomeCharacters handle_ buf
            lazy_rest <- lazyRead h
            (s,r) <- if haInputNL == CRLF
                         then unpack_nl bufRaw bufL bufR lazy_rest
                         else do s <- unpack bufRaw bufL bufR lazy_rest
                                 return (s,bufR)
            writeIORef haCharBuffer (bufferAdjustL r buf')
            return (handle_, s)
        )
        (\e -> do (handle_', _) <- hClose_help handle_
                  debugIO ("hGetContents caught: " ++ show e)
                  -- We might have a \r cached in CRLF mode.  So we
                  -- need to check for that and return it:
                  let r = if isEOFError e
                             then if not (isEmptyBuffer buf)
                                     then "\r"
                                     else ""
                             else
                                  throw (augmentIOError e "hGetContents" h)

                  return (handle_', r)
        )

-- ensure we have some characters in the buffer
getSomeCharacters :: Handle__ -> CharBuffer -> IO CharBuffer
getSomeCharacters handle_@Handle__{..} buf@Buffer{..} =
  case bufferElems buf of

    -- buffer empty: read some more
    0 -> readTextDevice handle_ buf

    -- if the buffer has a single '\r' in it and we're doing newline
    -- translation: read some more
    1 | haInputNL == CRLF -> do
      (c,_) <- readCharBuf bufRaw bufL
      if c == '\r'
         then do -- shuffle the '\r' to the beginning.  This is only safe
                 -- if we're about to call readTextDevice, otherwise it
                 -- would mess up flushCharBuffer.
                 -- See [note Buffer Flushing], GHC.IO.Handle.Types
                 _ <- writeCharBuf bufRaw 0 '\r'
                 let buf' = buf{ bufL=0, bufR=1 }
                 readTextDevice handle_ buf'
         else do
                 return buf

    -- buffer has some chars in it already: just return it
    _otherwise ->
      return buf

-- ---------------------------------------------------------------------------
-- hPutChar

-- | Computation 'hPutChar' @hdl ch@ writes the character @ch@ to the
-- file or channel managed by @hdl@.  Characters may be buffered if
-- buffering is enabled for @hdl@.
--
-- This operation may fail with:
--
--  * 'isFullError' if the device is full; or
--
--  * 'isPermissionError' if another system resource limit would be exceeded.

hPutChar :: Handle -> Char -> IO ()
hPutChar handle c = do
    c `seq` return ()
    wantWritableHandle "hPutChar" handle $ \ handle_  -> do
     hPutcBuffered handle_ c

hPutcBuffered :: Handle__ -> Char -> IO ()
hPutcBuffered handle_@Handle__{..} c = do
  buf <- readIORef haCharBuffer
  if c == '\n'
     then do buf1 <- if haOutputNL == CRLF
                        then do
                          buf1 <- putc buf '\r'
                          putc buf1 '\n'
                        else do
                          putc buf '\n'
             writeCharBuffer handle_ buf1
             when is_line $ flushByteWriteBuffer handle_
      else do
          buf1 <- putc buf c
          writeCharBuffer handle_ buf1
          return ()
  where
    is_line = case haBufferMode of
                LineBuffering -> True
                _             -> False

    putc buf@Buffer{ bufRaw=raw, bufR=w } c = do
       debugIO ("putc: " ++ summaryBuffer buf)
       w'  <- writeCharBuf raw w c
       return buf{ bufR = w' }

-- ---------------------------------------------------------------------------
-- hPutStr

-- We go to some trouble to avoid keeping the handle locked while we're
-- evaluating the string argument to hPutStr, in case doing so triggers another
-- I/O operation on the same handle which would lead to deadlock.  The classic
-- case is
--
--              putStr (trace "hello" "world")
--
-- so the basic scheme is this:
--
--      * copy the string into a fresh buffer,
--      * "commit" the buffer to the handle.
--
-- Committing may involve simply copying the contents of the new
-- buffer into the handle's buffer, flushing one or both buffers, or
-- maybe just swapping the buffers over (if the handle's buffer was
-- empty).  See commitBuffer below.

-- | Computation 'hPutStr' @hdl s@ writes the string
-- @s@ to the file or channel managed by @hdl@.
--
-- This operation may fail with:
--
--  * 'isFullError' if the device is full; or
--
--  * 'isPermissionError' if another system resource limit would be exceeded.

hPutStr :: Handle -> String -> IO ()
hPutStr handle str = hPutStr' handle str False

-- | The same as 'hPutStr', but adds a newline character.
hPutStrLn :: Handle -> String -> IO ()
hPutStrLn handle str = hPutStr' handle str True
  -- An optimisation: we treat hPutStrLn specially, to avoid the
  -- overhead of a single putChar '\n', which is quite high now that we
  -- have to encode eagerly.

{-# NOINLINE hPutStr' #-}
hPutStr' :: Handle -> String -> Bool -> IO ()
hPutStr' handle str add_nl =
  do
    (buffer_mode, nl) <-
         wantWritableHandle "hPutStr" handle $ \h_ -> do
                       bmode <- getSpareBuffer h_
                       return (bmode, haOutputNL h_)

    case buffer_mode of
       (NoBuffering, _) -> do
            hPutChars handle str        -- v. slow, but we don't care
            when add_nl $ hPutChar handle '\n'
       (LineBuffering, buf) -> do
            writeBlocks handle True  add_nl nl buf str
       (BlockBuffering _, buf) -> do
            writeBlocks handle False add_nl nl buf str

hPutChars :: Handle -> [Char] -> IO ()
hPutChars _      [] = return ()
hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs

getSpareBuffer :: Handle__ -> IO (BufferMode, CharBuffer)
getSpareBuffer Handle__{haCharBuffer=ref,
                        haBuffers=spare_ref,
                        haBufferMode=mode}
 = do
   case mode of
     NoBuffering -> return (mode, errorWithoutStackTrace "no buffer!")
     _ -> do
          bufs <- readIORef spare_ref
          buf  <- readIORef ref
          case bufs of
            BufferListCons b rest -> do
                writeIORef spare_ref rest
                return ( mode, emptyBuffer b (bufSize buf) WriteBuffer)
            BufferListNil -> do
                new_buf <- newCharBuffer (bufSize buf) WriteBuffer
                return (mode, new_buf)

-- NB. performance-critical code: eyeball the Core.
writeBlocks :: Handle -> Bool -> Bool -> Newline -> Buffer CharBufElem -> String -> IO ()
writeBlocks hdl line_buffered add_nl nl
            buf@Buffer{ bufRaw=raw, bufSize=len } s =
  let
   shoveString :: Int -> [Char] -> [Char] -> IO ()
   shoveString !n [] [] = do
        commitBuffer hdl raw len n False{-no flush-} True{-release-}
   shoveString !n [] rest = do
        shoveString n rest []
   shoveString !n (c:cs) rest
     -- n+1 so we have enough room to write '\r\n' if necessary
     | n + 1 >= len = do
        commitBuffer hdl raw len n False{-flush-} False
        shoveString 0 (c:cs) rest
     | c == '\n'  =  do
        n' <- if nl == CRLF
                 then do
                    n1 <- writeCharBuf raw n  '\r'
                    writeCharBuf raw n1 '\n'
                 else do
                    writeCharBuf raw n c
        if line_buffered
           then do
                -- end of line, so write and flush
               commitBuffer hdl raw len n' True{-flush-} False
               shoveString 0 cs rest
           else do
               shoveString n' cs rest
     | otherwise = do
        n' <- writeCharBuf raw n c
        shoveString n' cs rest
  in
  shoveString 0 s (if add_nl then "\n" else "")

-- -----------------------------------------------------------------------------
-- commitBuffer handle buf sz count flush release
--
-- Write the contents of the buffer 'buf' ('sz' bytes long, containing
-- 'count' bytes of data) to handle (handle must be block or line buffered).

commitBuffer
        :: Handle                       -- handle to commit to
        -> RawCharBuffer -> Int         -- address and size (in bytes) of buffer
        -> Int                          -- number of bytes of data in buffer
        -> Bool                         -- True <=> flush the handle afterward
        -> Bool                         -- release the buffer?
        -> IO ()

commitBuffer hdl !raw !sz !count flush release =
  wantWritableHandle "commitBuffer" hdl $ \h_@Handle__{..} -> do
      debugIO ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
            ++ ", flush=" ++ show flush ++ ", release=" ++ show release)

      writeCharBuffer h_ Buffer{ bufRaw=raw, bufState=WriteBuffer,
                                 bufL=0, bufR=count, bufSize=sz }

      when flush $ flushByteWriteBuffer h_

      -- release the buffer if necessary
      when release $ do
          -- find size of current buffer
          old_buf@Buffer{ bufSize=size } <- readIORef haCharBuffer
          when (sz == size) $ do
               spare_bufs <- readIORef haBuffers
               writeIORef haBuffers (BufferListCons raw spare_bufs)

      return ()

-- backwards compatibility; the text package uses this
commitBuffer' :: RawCharBuffer -> Int -> Int -> Bool -> Bool -> Handle__
              -> IO CharBuffer
commitBuffer' raw sz@(I# _) count@(I# _) flush release h_@Handle__{..}
   = do
      debugIO ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
            ++ ", flush=" ++ show flush ++ ", release=" ++ show release)

      let this_buf = Buffer{ bufRaw=raw, bufState=WriteBuffer,
                             bufL=0, bufR=count, bufSize=sz }

      writeCharBuffer h_ this_buf

      when flush $ flushByteWriteBuffer h_

      -- release the buffer if necessary
      when release $ do
          -- find size of current buffer
          old_buf@Buffer{ bufSize=size } <- readIORef haCharBuffer
          when (sz == size) $ do
               spare_bufs <- readIORef haBuffers
               writeIORef haBuffers (BufferListCons raw spare_bufs)

      return this_buf

-- ---------------------------------------------------------------------------
-- Reading/writing sequences of bytes.

-- ---------------------------------------------------------------------------
-- hPutBuf

-- | 'hPutBuf' @hdl buf count@ writes @count@ 8-bit bytes from the
-- buffer @buf@ to the handle @hdl@.  It returns ().
--
-- 'hPutBuf' ignores any text encoding that applies to the 'Handle',
-- writing the bytes directly to the underlying file or device.
--
-- 'hPutBuf' ignores the prevailing 'System.IO.TextEncoding' and
-- 'NewlineMode' on the 'Handle', and writes bytes directly.
--
-- This operation may fail with:
--
--  * 'ResourceVanished' if the handle is a pipe or socket, and the
--    reading end is closed.  (If this is a POSIX system, and the program
--    has not asked to ignore SIGPIPE, then a SIGPIPE may be delivered
--    instead, whose default action is to terminate the program).

hPutBuf :: Handle                       -- handle to write to
        -> Ptr a                        -- address of buffer
        -> Int                          -- number of bytes of data in buffer
        -> IO ()
hPutBuf h ptr count = do _ <- hPutBuf' h ptr count True
                         return ()

hPutBufNonBlocking
        :: Handle                       -- handle to write to
        -> Ptr a                        -- address of buffer
        -> Int                          -- number of bytes of data in buffer
        -> IO Int                       -- returns: number of bytes written
hPutBufNonBlocking h ptr count = hPutBuf' h ptr count False

hPutBuf':: Handle                       -- handle to write to
        -> Ptr a                        -- address of buffer
        -> Int                          -- number of bytes of data in buffer
        -> Bool                         -- allow blocking?
        -> IO Int
hPutBuf' handle ptr count can_block
  | count == 0 = return 0
  | count <  0 = illegalBufferSize handle "hPutBuf" count
  | otherwise =
    wantWritableHandle "hPutBuf" handle $
      \ h_@Handle__{..} -> do
          debugIO ("hPutBuf count=" ++ show count)

          r <- bufWrite h_ (castPtr ptr) count can_block

          -- we must flush if this Handle is set to NoBuffering.  If
          -- it is set to LineBuffering, be conservative and flush
          -- anyway (we didn't check for newlines in the data).
          case haBufferMode of
             BlockBuffering _      -> do return ()
             _line_or_no_buffering -> do flushWriteBuffer h_
          return r

bufWrite :: Handle__-> Ptr Word8 -> Int -> Bool -> IO Int
bufWrite h_@Handle__{..} ptr count can_block =
  seq count $ do  -- strictness hack
  old_buf@Buffer{ bufRaw=old_raw, bufR=w, bufSize=size }
     <- readIORef haByteBuffer

  -- TODO: Possible optimisation:
  --       If we know that `w + count > size`, we should write both the
  --       handle buffer and the `ptr` in a single `writev()` syscall.

  -- Need to buffer and enough room in handle buffer?
  -- There's no need to buffer if the data to be written is larger than
  -- the handle buffer (`count >= size`).
  if (count < size && count <= size - w)
        -- We need to buffer and there's enough room in the buffer:
        -- just copy the data in and update bufR.
        then do debugIO ("hPutBuf: copying to buffer, w=" ++ show w)
                copyToRawBuffer old_raw w ptr count
                let copied_buf = old_buf{ bufR = w + count }
                -- If the write filled the buffer completely, we need to flush,
                -- to maintain the "INVARIANTS on Buffers" from
                -- GHC.IO.Buffer.checkBuffer: "a write buffer is never full".
                if (count == size - w)
                  then do
                    debugIO "hPutBuf: flushing full buffer after writing"
                    flushed_buf <- Buffered.flushWriteBuffer haDevice copied_buf
                            -- TODO: we should do a non-blocking flush here
                    writeIORef haByteBuffer flushed_buf
                  else do
                    writeIORef haByteBuffer copied_buf
                return count

        -- else, we have to flush any existing handle buffer data
        -- and can then write out the data in `ptr` directly.
        else do -- No point flushing when there's nothing in the buffer.
                when (w > 0) $ do
                  debugIO "hPutBuf: flushing first"
                  flushed_buf <- Buffered.flushWriteBuffer haDevice old_buf
                          -- TODO: we should do a non-blocking flush here
                  writeIORef haByteBuffer flushed_buf
                -- if we can fit in the buffer, then just loop
                if count < size
                   then bufWrite h_ ptr count can_block
                   else if can_block
                           then do writeChunk h_ (castPtr ptr) count
                                   return count
                           else writeChunkNonBlocking h_ (castPtr ptr) count

writeChunk :: Handle__ -> Ptr Word8 -> Int -> IO ()
writeChunk h_@Handle__{..} ptr bytes
  | Just fd <- cast haDevice  =  RawIO.write (fd::FD) ptr bytes
  | otherwise = error "Todo: hPutBuf"

writeChunkNonBlocking :: Handle__ -> Ptr Word8 -> Int -> IO Int
writeChunkNonBlocking h_@Handle__{..} ptr bytes
  | Just fd <- cast haDevice  =  RawIO.writeNonBlocking (fd::FD) ptr bytes
  | otherwise = error "Todo: hPutBuf"

-- ---------------------------------------------------------------------------
-- hGetBuf

-- | 'hGetBuf' @hdl buf count@ reads data from the handle @hdl@
-- into the buffer @buf@ until either EOF is reached or
-- @count@ 8-bit bytes have been read.
-- It returns the number of bytes actually read.  This may be zero if
-- EOF was reached before any data was read (or if @count@ is zero).
--
-- 'hGetBuf' never raises an EOF exception, instead it returns a value
-- smaller than @count@.
--
-- If the handle is a pipe or socket, and the writing end
-- is closed, 'hGetBuf' will behave as if EOF was reached.
--
-- 'hGetBuf' ignores the prevailing 'System.IO.TextEncoding' and 'NewlineMode'
-- on the 'Handle', and reads bytes directly.

hGetBuf :: Handle -> Ptr a -> Int -> IO Int
hGetBuf h !ptr count
  | count == 0 = return 0
  | count <  0 = illegalBufferSize h "hGetBuf" count
  | otherwise =
      wantReadableHandle_ "hGetBuf" h $ \ h_@Handle__{..} -> do
         flushCharReadBuffer h_
         buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz }
            <- readIORef haByteBuffer
         if isEmptyBuffer buf
            then bufReadEmpty    h_ buf (castPtr ptr) 0 count
            else bufReadNonEmpty h_ buf (castPtr ptr) 0 count

-- small reads go through the buffer, large reads are satisfied by
-- taking data first from the buffer and then direct from the file
-- descriptor.

bufReadNonEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int
bufReadNonEmpty h_@Handle__{..}
                buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz }
                ptr !so_far !count
 = do
        let avail = w - r
        if (count < avail)
           then do
                copyFromRawBuffer ptr raw r count
                writeIORef haByteBuffer buf{ bufL = r + count }
                return (so_far + count)
           else do

        copyFromRawBuffer ptr raw r avail
        let buf' = buf{ bufR=0, bufL=0 }
        writeIORef haByteBuffer buf'
        let remaining = count - avail
            so_far' = so_far + avail
            ptr' = ptr `plusPtr` avail

        if remaining == 0
           then return so_far'
           else bufReadEmpty h_ buf' ptr' so_far' remaining

bufReadEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int
bufReadEmpty h_@Handle__{..}
             buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz }
             ptr so_far count
 | count > sz, Just fd <- cast haDevice = loop fd 0 count
 | otherwise = do
     (r,buf') <- Buffered.fillReadBuffer haDevice buf
     if r == 0
        then return so_far
        else do writeIORef haByteBuffer buf'
                bufReadNonEmpty h_ buf' ptr so_far count
 where
  loop :: FD -> Int -> Int -> IO Int
  loop fd off bytes | bytes <= 0 = return (so_far + off)
  loop fd off bytes = do
    r <- RawIO.read (fd::FD) (ptr `plusPtr` off) bytes
    if r == 0
        then return (so_far + off)
        else loop fd (off + r) (bytes - r)

-- ---------------------------------------------------------------------------
-- hGetBufSome

-- | 'hGetBufSome' @hdl buf count@ reads data from the handle @hdl@
-- into the buffer @buf@.  If there is any data available to read,
-- then 'hGetBufSome' returns it immediately; it only blocks if there
-- is no data to be read.
--
-- It returns the number of bytes actually read.  This may be zero if
-- EOF was reached before any data was read (or if @count@ is zero).
--
-- 'hGetBufSome' never raises an EOF exception, instead it returns a value
-- smaller than @count@.
--
-- If the handle is a pipe or socket, and the writing end
-- is closed, 'hGetBufSome' will behave as if EOF was reached.
--
-- 'hGetBufSome' ignores the prevailing 'System.IO.TextEncoding' and
-- 'NewlineMode' on the 'Handle', and reads bytes directly.

hGetBufSome :: Handle -> Ptr a -> Int -> IO Int
hGetBufSome h !ptr count
  | count == 0 = return 0
  | count <  0 = illegalBufferSize h "hGetBufSome" count
  | otherwise =
      wantReadableHandle_ "hGetBufSome" h $ \ h_@Handle__{..} -> do
         flushCharReadBuffer h_
         buf@Buffer{ bufSize=sz } <- readIORef haByteBuffer
         if isEmptyBuffer buf
            then case count > sz of  -- large read? optimize it with a little special case:
                    True | Just fd <- haFD h_ -> do RawIO.read fd (castPtr ptr) count
                    _ -> do (r,buf') <- Buffered.fillReadBuffer haDevice buf
                            if r == 0
                               then return 0
                               else do writeIORef haByteBuffer buf'
                                       bufReadNBNonEmpty h_ buf' (castPtr ptr) 0 (min r count)
                                        -- new count is  (min r count), so
                                        -- that bufReadNBNonEmpty will not
                                        -- issue another read.
            else
              let count' = min count (bufferElems buf)
              in bufReadNBNonEmpty h_ buf (castPtr ptr) 0 count'

haFD :: Handle__ -> Maybe FD
haFD h_@Handle__{..} = cast haDevice

-- | 'hGetBufNonBlocking' @hdl buf count@ reads data from the handle @hdl@
-- into the buffer @buf@ until either EOF is reached, or
-- @count@ 8-bit bytes have been read, or there is no more data available
-- to read immediately.
--
-- 'hGetBufNonBlocking' is identical to 'hGetBuf', except that it will
-- never block waiting for data to become available, instead it returns
-- only whatever data is available.  To wait for data to arrive before
-- calling 'hGetBufNonBlocking', use 'hWaitForInput'.
--
-- If the handle is a pipe or socket, and the writing end
-- is closed, 'hGetBufNonBlocking' will behave as if EOF was reached.
--
-- 'hGetBufNonBlocking' ignores the prevailing 'System.IO.TextEncoding' and
-- 'NewlineMode' on the 'Handle', and reads bytes directly.
--
-- NOTE: on Windows, this function does not work correctly; it
-- behaves identically to 'hGetBuf'.

hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int
hGetBufNonBlocking h !ptr count
  | count == 0 = return 0
  | count <  0 = illegalBufferSize h "hGetBufNonBlocking" count
  | otherwise =
      wantReadableHandle_ "hGetBufNonBlocking" h $ \ h_@Handle__{..} -> do
         flushCharReadBuffer h_
         buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz }
            <- readIORef haByteBuffer
         if isEmptyBuffer buf
            then bufReadNBEmpty    h_ buf (castPtr ptr) 0 count
            else bufReadNBNonEmpty h_ buf (castPtr ptr) 0 count

bufReadNBEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int
bufReadNBEmpty   h_@Handle__{..}
                 buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz }
                 ptr so_far count
  | count > sz,
    Just fd <- cast haDevice = do
       m <- RawIO.readNonBlocking (fd::FD) ptr count
       case m of
         Nothing -> return so_far
         Just n  -> return (so_far + n)

 | otherwise = do
     buf <- readIORef haByteBuffer
     (r,buf') <- Buffered.fillReadBuffer0 haDevice buf
     case r of
       Nothing -> return so_far
       Just 0  -> return so_far
       Just r  -> do
         writeIORef haByteBuffer buf'
         bufReadNBNonEmpty h_ buf' ptr so_far (min count r)
                          -- NOTE: new count is    min count r
                          -- so we will just copy the contents of the
                          -- buffer in the recursive call, and not
                          -- loop again.

bufReadNBNonEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int
bufReadNBNonEmpty h_@Handle__{..}
                  buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz }
                  ptr so_far count
  = do
        let avail = w - r
        if (count < avail)
           then do
                copyFromRawBuffer ptr raw r count
                writeIORef haByteBuffer buf{ bufL = r + count }
                return (so_far + count)
           else do

        copyFromRawBuffer ptr raw r avail
        let buf' = buf{ bufR=0, bufL=0 }
        writeIORef haByteBuffer buf'
        let remaining = count - avail
            so_far' = so_far + avail
            ptr' = ptr `plusPtr` avail

        if remaining == 0
           then return so_far'
           else bufReadNBEmpty h_ buf' ptr' so_far' remaining

-- ---------------------------------------------------------------------------
-- memcpy wrappers

copyToRawBuffer :: RawBuffer e -> Int -> Ptr e -> Int -> IO ()
copyToRawBuffer raw off ptr bytes =
 withRawBuffer raw $ \praw ->
   do _ <- memcpy (praw `plusPtr` off) ptr (fromIntegral bytes)
      return ()

copyFromRawBuffer :: Ptr e -> RawBuffer e -> Int -> Int -> IO ()
copyFromRawBuffer ptr raw off bytes =
 withRawBuffer raw $ \praw ->
   do _ <- memcpy ptr (praw `plusPtr` off) (fromIntegral bytes)
      return ()

foreign import ccall unsafe "memcpy"
   memcpy :: Ptr a -> Ptr a -> CSize -> IO (Ptr ())

-----------------------------------------------------------------------------
-- Internal Utils

illegalBufferSize :: Handle -> String -> Int -> IO a
illegalBufferSize handle fn sz =
        ioException (IOError (Just handle)
                            InvalidArgument  fn
                            ("illegal buffer size " ++ showsPrec 9 sz [])
                            Nothing Nothing)