{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP, MagicHash, UnboxedTuples, NoImplicitPrelude #-}
{-# OPTIONS_HADDOCK not-home #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.Float.RealFracMethods
-- Copyright   :  (c) Daniel Fischer 2010
-- License     :  see libraries/base/LICENSE
--
-- Maintainer  :  cvs-ghc@haskell.org
-- Stability   :  internal
-- Portability :  non-portable (GHC Extensions)
--
-- Methods for the RealFrac instances for 'Float' and 'Double',
-- with specialised versions for 'Int'.
--
-- Moved to their own module to not bloat GHC.Float further.
--
-----------------------------------------------------------------------------

#include "MachDeps.h"

module GHC.Float.RealFracMethods
    ( -- * Double methods
      -- ** Integer results
      properFractionDoubleInteger
    , truncateDoubleInteger
    , floorDoubleInteger
    , ceilingDoubleInteger
    , roundDoubleInteger
      -- ** Int results
    , properFractionDoubleInt
    , floorDoubleInt
    , ceilingDoubleInt
    , roundDoubleInt
      -- * Double/Int conversions, wrapped primops
    , double2Int
    , int2Double
      -- * Float methods
      -- ** Integer results
    , properFractionFloatInteger
    , truncateFloatInteger
    , floorFloatInteger
    , ceilingFloatInteger
    , roundFloatInteger
      -- ** Int results
    , properFractionFloatInt
    , floorFloatInt
    , ceilingFloatInt
    , roundFloatInt
      -- * Float/Int conversions, wrapped primops
    , float2Int
    , int2Float
    ) where

import GHC.Integer

import GHC.Base
import GHC.Num ()

#if WORD_SIZE_IN_BITS < 64

import GHC.IntWord64

#define TO64 integerToInt64
#define FROM64 int64ToInteger
#define MINUS64 minusInt64#
#define NEGATE64 negateInt64#

#else

#define TO64 integerToInt
#define FROM64 smallInteger
#define MINUS64 ( -# )
#define NEGATE64 negateInt#

uncheckedIShiftRA64# :: Int# -> Int# -> Int#
uncheckedIShiftRA64# = uncheckedIShiftRA#

uncheckedIShiftL64# :: Int# -> Int# -> Int#
uncheckedIShiftL64# = uncheckedIShiftL#

#endif

default ()

------------------------------------------------------------------------------
--                              Float Methods                               --
------------------------------------------------------------------------------

-- Special Functions for Int, nice, easy and fast.
-- They should be small enough to be inlined automatically.

-- We have to test for Â±0.0 to avoid returning -0.0 in the second
-- component of the pair. Unfortunately the branching costs a lot
-- of performance.
properFractionFloatInt :: Float -> (Int, Float)
properFractionFloatInt (F# x) =
    if isTrue# (x `eqFloat#` 0.0#)
        then (I# 0#, F# 0.0#)
        else case float2Int# x of
                n -> (I# n, F# (x `minusFloat#` int2Float# n))

-- truncateFloatInt = float2Int

floorFloatInt :: Float -> Int
floorFloatInt (F# x) =
    case float2Int# x of
      n | isTrue# (x `ltFloat#` int2Float# n) -> I# (n -# 1#)
        | otherwise                           -> I# n

ceilingFloatInt :: Float -> Int
ceilingFloatInt (F# x) =
    case float2Int# x of
      n | isTrue# (int2Float# n `ltFloat#` x) -> I# (n +# 1#)
        | otherwise                           -> I# n

roundFloatInt :: Float -> Int
roundFloatInt x = float2Int (c_rintFloat x)

-- Functions with Integer results

-- With the new code generator in GHC 7, the explicit bit-fiddling is
-- slower than the old code for values of small modulus, but when the
-- 'Int' range is left, the bit-fiddling quickly wins big, so we use that.
-- If the methods are called on smallish values, hopefully people go
-- through Int and not larger types.

-- Note: For negative exponents, we must check the validity of the shift
-- distance for the right shifts of the mantissa.

{-# INLINE properFractionFloatInteger #-}
properFractionFloatInteger :: Float -> (Integer, Float)
properFractionFloatInteger v@(F# x) =
    case decodeFloat_Int# x of
      (# m, e #)
        | isTrue# (e <# 0#) ->
          case negateInt# e of
            s | isTrue# (s ># 23#) -> (0, v)
              | isTrue# (m <#  0#) ->
                case negateInt# (negateInt# m `uncheckedIShiftRA#` s) of
                  k -> (smallInteger k,
                            case m -# (k `uncheckedIShiftL#` s) of
                              r -> F# (encodeFloatInteger (smallInteger r) e))
              | otherwise           ->
                case m `uncheckedIShiftRL#` s of
                  k -> (smallInteger k,
                            case m -# (k `uncheckedIShiftL#` s) of
                              r -> F# (encodeFloatInteger (smallInteger r) e))
        | otherwise -> (shiftLInteger (smallInteger m) e, F# 0.0#)

{-# INLINE truncateFloatInteger #-}
truncateFloatInteger :: Float -> Integer
truncateFloatInteger x =
    case properFractionFloatInteger x of
      (n, _) -> n

-- floor is easier for negative numbers than truncate, so this gets its
-- own implementation, it's a little faster.
{-# INLINE floorFloatInteger #-}
floorFloatInteger :: Float -> Integer
floorFloatInteger (F# x) =
    case decodeFloat_Int# x of
      (# m, e #)
        | isTrue# (e <# 0#) ->
          case negateInt# e of
            s | isTrue# (s ># 23#) -> if isTrue# (m <# 0#) then (-1) else 0
              | otherwise          -> smallInteger (m `uncheckedIShiftRA#` s)
        | otherwise -> shiftLInteger (smallInteger m) e

-- ceiling x = -floor (-x)
-- If giving this its own implementation is faster at all,
-- it's only marginally so, hence we keep it short.
{-# INLINE ceilingFloatInteger #-}
ceilingFloatInteger :: Float -> Integer
ceilingFloatInteger (F# x) =
    negateInteger (floorFloatInteger (F# (negateFloat# x)))

{-# INLINE roundFloatInteger #-}
roundFloatInteger :: Float -> Integer
roundFloatInteger x = float2Integer (c_rintFloat x)

------------------------------------------------------------------------------
--                              Double Methods                              --
------------------------------------------------------------------------------

-- Special Functions for Int, nice, easy and fast.
-- They should be small enough to be inlined automatically.

-- We have to test for Â±0.0 to avoid returning -0.0 in the second
-- component of the pair. Unfortunately the branching costs a lot
-- of performance.
properFractionDoubleInt :: Double -> (Int, Double)
properFractionDoubleInt (D# x) =
    if isTrue# (x ==## 0.0##)
        then (I# 0#, D# 0.0##)
        else case double2Int# x of
                n -> (I# n, D# (x -## int2Double# n))

-- truncateDoubleInt = double2Int

floorDoubleInt :: Double -> Int
floorDoubleInt (D# x) =
    case double2Int# x of
      n | isTrue# (x <## int2Double# n) -> I# (n -# 1#)
        | otherwise                     -> I# n

ceilingDoubleInt :: Double -> Int
ceilingDoubleInt (D# x) =
    case double2Int# x of
      n | isTrue# (int2Double# n <## x) -> I# (n +# 1#)
        | otherwise                     -> I# n

roundDoubleInt :: Double -> Int
roundDoubleInt x = double2Int (c_rintDouble x)

-- Functions with Integer results

-- The new Code generator isn't quite as good for the old 'Double' code
-- as for the 'Float' code, so for 'Double' the bit-fiddling also wins
-- when the values have small modulus.

-- When the exponent is negative, all mantissae have less than 64 bits
-- and the right shifting of sized types is much faster than that of
-- 'Integer's, especially when we can

-- Note: For negative exponents, we must check the validity of the shift
-- distance for the right shifts of the mantissa.

{-# INLINE properFractionDoubleInteger #-}
properFractionDoubleInteger :: Double -> (Integer, Double)
properFractionDoubleInteger v@(D# x) =
    case decodeDoubleInteger x of
      (# m, e #)
        | isTrue# (e <# 0#) ->
          case negateInt# e of
            s | isTrue# (s ># 52#) -> (0, v)
              | m < 0                 ->
                case TO64 (negateInteger m) of
                  n ->
                    case n `uncheckedIShiftRA64#` s of
                      k ->
                        (FROM64 (NEGATE64 k),
                          case MINUS64 n (k `uncheckedIShiftL64#` s) of
                            r ->
                              D# (encodeDoubleInteger (FROM64 (NEGATE64 r)) e))
              | otherwise           ->
                case TO64 m of
                  n ->
                    case n `uncheckedIShiftRA64#` s of
                      k -> (FROM64 k,
                            case MINUS64 n (k `uncheckedIShiftL64#` s) of
                              r -> D# (encodeDoubleInteger (FROM64 r) e))
        | otherwise -> (shiftLInteger m e, D# 0.0##)

{-# INLINE truncateDoubleInteger #-}
truncateDoubleInteger :: Double -> Integer
truncateDoubleInteger x =
    case properFractionDoubleInteger x of
      (n, _) -> n

-- floor is easier for negative numbers than truncate, so this gets its
-- own implementation, it's a little faster.
{-# INLINE floorDoubleInteger #-}
floorDoubleInteger :: Double -> Integer
floorDoubleInteger (D# x) =
    case decodeDoubleInteger x of
      (# m, e #)
        | isTrue# (e <# 0#) ->
          case negateInt# e of
            s | isTrue# (s ># 52#) -> if m < 0 then (-1) else 0
              | otherwise          ->
                case TO64 m of
                  n -> FROM64 (n `uncheckedIShiftRA64#` s)
        | otherwise -> shiftLInteger m e

{-# INLINE ceilingDoubleInteger #-}
ceilingDoubleInteger :: Double -> Integer
ceilingDoubleInteger (D# x) =
    negateInteger (floorDoubleInteger (D# (negateDouble# x)))

{-# INLINE roundDoubleInteger #-}
roundDoubleInteger :: Double -> Integer
roundDoubleInteger x = double2Integer (c_rintDouble x)

-- Wrappers around double2Int#, int2Double#, float2Int# and int2Float#,
-- we need them here, so we move them from GHC.Float and re-export them
-- explicitly from there.

double2Int :: Double -> Int
double2Int (D# x) = I# (double2Int# x)

int2Double :: Int -> Double
int2Double (I# i) = D# (int2Double# i)

float2Int :: Float -> Int
float2Int (F# x) = I# (float2Int# x)

int2Float :: Int -> Float
int2Float (I# i) = F# (int2Float# i)

-- Quicker conversions from 'Double' and 'Float' to 'Integer',
-- assuming the floating point value is integral.
--
-- Note: Since the value is integral, the exponent can't be less than
-- (-TYP_MANT_DIG), so we need not check the validity of the shift
-- distance for the right shfts here.

{-# INLINE double2Integer #-}
double2Integer :: Double -> Integer
double2Integer (D# x) =
    case decodeDoubleInteger x of
      (# m, e #)
        | isTrue# (e <# 0#) ->
          case TO64 m of
            n -> FROM64 (n `uncheckedIShiftRA64#` negateInt# e)
        | otherwise -> shiftLInteger m e

{-# INLINE float2Integer #-}
float2Integer :: Float -> Integer
float2Integer (F# x) =
    case decodeFloat_Int# x of
      (# m, e #)
        | isTrue# (e <# 0#) -> smallInteger (m `uncheckedIShiftRA#` negateInt# e)
        | otherwise         -> shiftLInteger (smallInteger m) e

-- Foreign imports, the rounding is done faster in C when the value
-- isn't integral, so we call out for rounding. For values of large
-- modulus, calling out to C is slower than staying in Haskell, but
-- presumably 'round' is mostly called for values with smaller modulus,
-- when calling out to C is a major win.
-- For all other functions, calling out to C gives at most a marginal
-- speedup for values of small modulus and is much slower than staying
-- in Haskell for values of large modulus, so those are done in Haskell.

foreign import ccall unsafe "rintDouble"
    c_rintDouble :: Double -> Double

foreign import ccall unsafe "rintFloat"
    c_rintFloat :: Float -> Float


{-# LANGUAGE Trustworthy, BangPatterns #-}
{-# LANGUAGE CPP, NoImplicitPrelude #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.IO.Buffer
-- Copyright   :  (c) The University of Glasgow 2008
-- License     :  see libraries/base/LICENSE
--
-- Maintainer  :  cvs-ghc@haskell.org
-- Stability   :  internal
-- Portability :  non-portable (GHC Extensions)
--
-- Buffers used in the IO system
--
-----------------------------------------------------------------------------

module GHC.IO.Buffer (
    -- * Buffers of any element
    Buffer(..), BufferState(..), CharBuffer, CharBufElem,

    -- ** Creation
    newByteBuffer,
    newCharBuffer,
    newBuffer,
    emptyBuffer,

    -- ** Insertion/removal
    bufferRemove,
    bufferAdd,
    slideContents,
    bufferAdjustL,

    -- ** Inspecting
    isEmptyBuffer,
    isFullBuffer,
    isFullCharBuffer,
    isWriteBuffer,
    bufferElems,
    bufferAvailable,
    summaryBuffer,

    -- ** Operating on the raw buffer as a Ptr
    withBuffer,
    withRawBuffer,

    -- ** Assertions
    checkBuffer,

    -- * Raw buffers
    RawBuffer,
    readWord8Buf,
    writeWord8Buf,
    RawCharBuffer,
    peekCharBuf,
    readCharBuf,
    writeCharBuf,
    readCharBufPtr,
    writeCharBufPtr,
    charSize,
 ) where

import GHC.Base
-- import GHC.IO
import GHC.Num
import GHC.Ptr
import GHC.Word
import GHC.Show
import GHC.Real
import Foreign.C.Types
import Foreign.ForeignPtr
import Foreign.Storable

-- Char buffers use either UTF-16 or UTF-32, with the endianness matching
-- the endianness of the host.
--
-- Invariants:
--   * a Char buffer consists of *valid* UTF-16 or UTF-32
--   * only whole characters: no partial surrogate pairs

#define CHARBUF_UTF32

-- #define CHARBUF_UTF16
--
-- NB. it won't work to just change this to CHARBUF_UTF16.  Some of
-- the code to make this work is there, and it has been tested with
-- the Iconv codec, but there are some pieces that are known to be
-- broken.  In particular, the built-in codecs
-- e.g. GHC.IO.Encoding.UTF{8,16,32} need to use isFullCharBuffer or
-- similar in place of the ow >= os comparisons.

-- ---------------------------------------------------------------------------
-- Raw blocks of data

type RawBuffer e = ForeignPtr e

readWord8Buf :: RawBuffer Word8 -> Int -> IO Word8
readWord8Buf arr ix = withForeignPtr arr $ \p -> peekByteOff p ix

writeWord8Buf :: RawBuffer Word8 -> Int -> Word8 -> IO ()
writeWord8Buf arr ix w = withForeignPtr arr $ \p -> pokeByteOff p ix w

#if defined(CHARBUF_UTF16)
type CharBufElem = Word16
#else
type CharBufElem = Char
#endif

type RawCharBuffer = RawBuffer CharBufElem

peekCharBuf :: RawCharBuffer -> Int -> IO Char
peekCharBuf arr ix = withForeignPtr arr $ \p -> do
                        (c,_) <- readCharBufPtr p ix
                        return c

{-# INLINE readCharBuf #-}
readCharBuf :: RawCharBuffer -> Int -> IO (Char, Int)
readCharBuf arr ix = withForeignPtr arr $ \p -> readCharBufPtr p ix

{-# INLINE writeCharBuf #-}
writeCharBuf :: RawCharBuffer -> Int -> Char -> IO Int
writeCharBuf arr ix c = withForeignPtr arr $ \p -> writeCharBufPtr p ix c

{-# INLINE readCharBufPtr #-}
readCharBufPtr :: Ptr CharBufElem -> Int -> IO (Char, Int)
#if defined(CHARBUF_UTF16)
readCharBufPtr p ix = do
  c1 <- peekElemOff p ix
  if (c1 < 0xd800 || c1 > 0xdbff)
     then return (chr (fromIntegral c1), ix+1)
     else do c2 <- peekElemOff p (ix+1)
             return (unsafeChr ((fromIntegral c1 - 0xd800)*0x400 +
                                (fromIntegral c2 - 0xdc00) + 0x10000), ix+2)
#else
readCharBufPtr p ix = do c <- peekElemOff (castPtr p) ix; return (c, ix+1)
#endif

{-# INLINE writeCharBufPtr #-}
writeCharBufPtr :: Ptr CharBufElem -> Int -> Char -> IO Int
#if defined(CHARBUF_UTF16)
writeCharBufPtr p ix ch
  | c < 0x10000 = do pokeElemOff p ix (fromIntegral c)
                     return (ix+1)
  | otherwise   = do let c' = c - 0x10000
                     pokeElemOff p ix (fromIntegral (c' `div` 0x400 + 0xd800))
                     pokeElemOff p (ix+1) (fromIntegral (c' `mod` 0x400 + 0xdc00))
                     return (ix+2)
  where
    c = ord ch
#else
writeCharBufPtr p ix ch = do pokeElemOff (castPtr p) ix ch; return (ix+1)
#endif

charSize :: Int
#if defined(CHARBUF_UTF16)
charSize = 2
#else
charSize = 4
#endif

-- ---------------------------------------------------------------------------
-- Buffers

-- | A mutable array of bytes that can be passed to foreign functions.
--
-- The buffer is represented by a record, where the record contains
-- the raw buffer and the start/end points of the filled portion.  The
-- buffer contents itself is mutable, but the rest of the record is
-- immutable.  This is a slightly odd mix, but it turns out to be
-- quite practical: by making all the buffer metadata immutable, we
-- can have operations on buffer metadata outside of the IO monad.
--
-- The "live" elements of the buffer are those between the 'bufL' and
-- 'bufR' offsets.  In an empty buffer, 'bufL' is equal to 'bufR', but
-- they might not be zero: for example, the buffer might correspond to
-- a memory-mapped file and in which case 'bufL' will point to the
-- next location to be written, which is not necessarily the beginning
-- of the file.
data Buffer e
  = Buffer {
        bufRaw   :: !(RawBuffer e),
        bufState :: BufferState,
        bufSize  :: !Int,          -- in elements, not bytes
        bufL     :: !Int,          -- offset of first item in the buffer
        bufR     :: !Int           -- offset of last item + 1
  }

#if defined(CHARBUF_UTF16)
type CharBuffer = Buffer Word16
#else
type CharBuffer = Buffer Char
#endif

data BufferState = ReadBuffer | WriteBuffer
  deriving Eq -- ^ @since 4.2.0.0

withBuffer :: Buffer e -> (Ptr e -> IO a) -> IO a
withBuffer Buffer{ bufRaw=raw } f = withForeignPtr (castForeignPtr raw) f

withRawBuffer :: RawBuffer e -> (Ptr e -> IO a) -> IO a
withRawBuffer raw f = withForeignPtr (castForeignPtr raw) f

isEmptyBuffer :: Buffer e -> Bool
isEmptyBuffer Buffer{ bufL=l, bufR=r } = l == r

isFullBuffer :: Buffer e -> Bool
isFullBuffer Buffer{ bufR=w, bufSize=s } = s == w

-- if a Char buffer does not have room for a surrogate pair, it is "full"
isFullCharBuffer :: Buffer e -> Bool
#if defined(CHARBUF_UTF16)
isFullCharBuffer buf = bufferAvailable buf < 2
#else
isFullCharBuffer = isFullBuffer
#endif

isWriteBuffer :: Buffer e -> Bool
isWriteBuffer buf = case bufState buf of
                        WriteBuffer -> True
                        ReadBuffer  -> False

bufferElems :: Buffer e -> Int
bufferElems Buffer{ bufR=w, bufL=r } = w - r

bufferAvailable :: Buffer e -> Int
bufferAvailable Buffer{ bufR=w, bufSize=s } = s - w

bufferRemove :: Int -> Buffer e -> Buffer e
bufferRemove i buf@Buffer{ bufL=r } = bufferAdjustL (r+i) buf

bufferAdjustL :: Int -> Buffer e -> Buffer e
bufferAdjustL l buf@Buffer{ bufR=w }
  | l == w    = buf{ bufL=0, bufR=0 }
  | otherwise = buf{ bufL=l, bufR=w }

bufferAdd :: Int -> Buffer e -> Buffer e
bufferAdd i buf@Buffer{ bufR=w } = buf{ bufR=w+i }

emptyBuffer :: RawBuffer e -> Int -> BufferState -> Buffer e
emptyBuffer raw sz state =
  Buffer{ bufRaw=raw, bufState=state, bufR=0, bufL=0, bufSize=sz }

newByteBuffer :: Int -> BufferState -> IO (Buffer Word8)
newByteBuffer c st = newBuffer c c st

newCharBuffer :: Int -> BufferState -> IO CharBuffer
newCharBuffer c st = newBuffer (c * charSize) c st

newBuffer :: Int -> Int -> BufferState -> IO (Buffer e)
newBuffer bytes sz state = do
  fp <- mallocForeignPtrBytes bytes
  return (emptyBuffer fp sz state)

-- | slides the contents of the buffer to the beginning
slideContents :: Buffer Word8 -> IO (Buffer Word8)
slideContents buf@Buffer{ bufL=l, bufR=r, bufRaw=raw } = do
  let elems = r - l
  withRawBuffer raw $ \p ->
      do _ <- memmove p (p `plusPtr` l) (fromIntegral elems)
         return ()
  return buf{ bufL=0, bufR=elems }

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

summaryBuffer :: Buffer a -> String
summaryBuffer !buf  -- Strict => slightly better code
   = "buf" ++ show (bufSize buf) ++ "(" ++ show (bufL buf) ++ "-" ++ show (bufR buf) ++ ")"

-- INVARIANTS on Buffers:
--   * r <= w
--   * if r == w, and the buffer is for reading, then r == 0 && w == 0
--   * a write buffer is never full.  If an operation
--     fills up the buffer, it will always flush it before
--     returning.
--   * a read buffer may be full as a result of hLookAhead.  In normal
--     operation, a read buffer always has at least one character of space.

checkBuffer :: Buffer a -> IO ()
checkBuffer buf@Buffer{ bufState = state, bufL=r, bufR=w, bufSize=size } = do
     check buf (
        size > 0
        && r <= w
        && w <= size
        && ( r /= w || state == WriteBuffer || (r == 0 && w == 0) )
        && ( state /= WriteBuffer || w < size ) -- write buffer is never full
      )

check :: Buffer a -> Bool -> IO ()
check _   True  = return ()
check buf False = errorWithoutStackTrace ("buffer invariant violation: " ++ summaryBuffer buf)


{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.IO.BufferedIO
-- Copyright   :  (c) The University of Glasgow 2008
-- License     :  see libraries/base/LICENSE
--
-- Maintainer  :  cvs-ghc@haskell.org
-- Stability   :  internal
-- Portability :  non-portable (GHC Extensions)
--
-- Class of buffered IO devices
--
-----------------------------------------------------------------------------

module GHC.IO.BufferedIO (
        BufferedIO(..),
        readBuf, readBufNonBlocking, writeBuf, writeBufNonBlocking
    ) where

import GHC.Base
import GHC.Ptr
import Data.Word
import GHC.Num
import GHC.IO.Device as IODevice
import GHC.IO.Device as RawIO
import GHC.IO.Buffer

-- | The purpose of 'BufferedIO' is to provide a common interface for I/O
-- devices that can read and write data through a buffer.  Devices that
-- implement 'BufferedIO' include ordinary files, memory-mapped files,
-- and bytestrings.  The underlying device implementing a 'System.IO.Handle'
-- must provide 'BufferedIO'.
--
class BufferedIO dev where
  -- | allocate a new buffer.  The size of the buffer is at the
  -- discretion of the device; e.g. for a memory-mapped file the
  -- buffer will probably cover the entire file.
  newBuffer         :: dev -> BufferState -> IO (Buffer Word8)

  -- | reads bytes into the buffer, blocking if there are no bytes
  -- available.  Returns the number of bytes read (zero indicates
  -- end-of-file), and the new buffer.
  fillReadBuffer    :: dev -> Buffer Word8 -> IO (Int, Buffer Word8)

  -- | reads bytes into the buffer without blocking.  Returns the
  -- number of bytes read (Nothing indicates end-of-file), and the new
  -- buffer.
  fillReadBuffer0   :: dev -> Buffer Word8 -> IO (Maybe Int, Buffer Word8)

  -- | Prepares an empty write buffer.  This lets the device decide
  -- how to set up a write buffer: the buffer may need to point to a
  -- specific location in memory, for example.  This is typically used
  -- by the client when switching from reading to writing on a
  -- buffered read/write device.
  --
  -- There is no corresponding operation for read buffers, because before
  -- reading the client will always call 'fillReadBuffer'.
  emptyWriteBuffer  :: dev -> Buffer Word8 -> IO (Buffer Word8)
  emptyWriteBuffer _dev buf
    = return buf{ bufL=0, bufR=0, bufState = WriteBuffer }

  -- | Flush all the data from the supplied write buffer out to the device.
  -- The returned buffer should be empty, and ready for writing.
  flushWriteBuffer  :: dev -> Buffer Word8 -> IO (Buffer Word8)

  -- | Flush data from the supplied write buffer out to the device
  -- without blocking.  Returns the number of bytes written and the
  -- remaining buffer.
  flushWriteBuffer0 :: dev -> Buffer Word8 -> IO (Int, Buffer Word8)

-- for an I/O device, these operations will perform reading/writing
-- to/from the device.

-- for a memory-mapped file, the buffer will be the whole file in
-- memory.  fillReadBuffer sets the pointers to encompass the whole
-- file, and flushWriteBuffer needs to do no I/O.  A memory-mapped
-- file has to maintain its own file pointer.

-- for a bytestring, again the buffer should match the bytestring in
-- memory.

-- ---------------------------------------------------------------------------
-- Low-level read/write to/from buffers

-- These operations make it easy to implement an instance of 'BufferedIO'
-- for an object that supports 'RawIO'.

readBuf :: RawIO dev => dev -> Buffer Word8 -> IO (Int, Buffer Word8)
readBuf dev bbuf = do
  let bytes = bufferAvailable bbuf
  res <- withBuffer bbuf $ \ptr ->
             RawIO.read dev (ptr `plusPtr` bufR bbuf) bytes
  return (res, bbuf{ bufR = bufR bbuf + res })
         -- zero indicates end of file

readBufNonBlocking :: RawIO dev => dev -> Buffer Word8
                     -> IO (Maybe Int,   -- Nothing ==> end of file
                                         -- Just n  ==> n bytes were read (n>=0)
                            Buffer Word8)
readBufNonBlocking dev bbuf = do
  let bytes = bufferAvailable bbuf
  res <- withBuffer bbuf $ \ptr ->
           IODevice.readNonBlocking dev (ptr `plusPtr` bufR bbuf) bytes
  case res of
     Nothing -> return (Nothing, bbuf)
     Just n  -> return (Just n, bbuf{ bufR = bufR bbuf + n })

writeBuf :: RawIO dev => dev -> Buffer Word8 -> IO (Buffer Word8)
writeBuf dev bbuf = do
  let bytes = bufferElems bbuf
  withBuffer bbuf $ \ptr ->
      IODevice.write dev (ptr `plusPtr` bufL bbuf) bytes
  return bbuf{ bufL=0, bufR=0 }

-- XXX ToDo
writeBufNonBlocking :: RawIO dev => dev -> Buffer Word8 -> IO (Int, Buffer Word8)
writeBufNonBlocking dev bbuf = do
  let bytes = bufferElems bbuf
  res <- withBuffer bbuf $ \ptr ->
            IODevice.writeNonBlocking dev (ptr `plusPtr` bufL bbuf) bytes
  return (res, bufferAdjustL (bufL bbuf + res) bbuf)


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

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.IO.Device
-- Copyright   :  (c) The University of Glasgow, 1994-2008
-- License     :  see libraries/base/LICENSE
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  internal
-- Portability :  non-portable
--
-- Type classes for I/O providers.
--
-----------------------------------------------------------------------------

module GHC.IO.Device (
        RawIO(..),
        IODevice(..),
        IODeviceType(..),
        SeekMode(..)
    ) where

import GHC.Base
import GHC.Word
import GHC.Arr
import GHC.Enum
import GHC.Read
import GHC.Show
import GHC.Ptr
import GHC.Num
import GHC.IO
import {-# SOURCE #-} GHC.IO.Exception ( unsupportedOperation )

-- | A low-level I/O provider where the data is bytes in memory.
class RawIO a where
  -- | Read up to the specified number of bytes, returning the number
  -- of bytes actually read.  This function should only block if there
  -- is no data available.  If there is not enough data available,
  -- then the function should just return the available data. A return
  -- value of zero indicates that the end of the data stream (e.g. end
  -- of file) has been reached.
  read                :: a -> Ptr Word8 -> Int -> IO Int

  -- | Read up to the specified number of bytes, returning the number
  -- of bytes actually read, or 'Nothing' if the end of the stream has
  -- been reached.
  readNonBlocking     :: a -> Ptr Word8 -> Int -> IO (Maybe Int)

  -- | Write the specified number of bytes.
  write               :: a -> Ptr Word8 -> Int -> IO ()

  -- | Write up to the specified number of bytes without blocking.  Returns
  -- the actual number of bytes written.
  writeNonBlocking    :: a -> Ptr Word8 -> Int -> IO Int

-- | I/O operations required for implementing a 'System.IO.Handle'.
class IODevice a where
  -- | @ready dev write msecs@ returns 'True' if the device has data
  -- to read (if @write@ is 'False') or space to write new data (if
  -- @write@ is 'True').  @msecs@ specifies how long to wait, in
  -- milliseconds.
  --
  ready :: a -> Bool -> Int -> IO Bool

  -- | closes the device.  Further operations on the device should
  -- produce exceptions.
  close :: a -> IO ()

  -- | returns 'True' if the device is a terminal or console.
  isTerminal :: a -> IO Bool
  isTerminal _ = return False

  -- | returns 'True' if the device supports 'seek' operations.
  isSeekable :: a -> IO Bool
  isSeekable _ = return False

  -- | seek to the specified position in the data.
  seek :: a -> SeekMode -> Integer -> IO ()
  seek _ _ _ = ioe_unsupportedOperation

  -- | return the current position in the data.
  tell :: a -> IO Integer
  tell _ = ioe_unsupportedOperation

  -- | return the size of the data.
  getSize :: a -> IO Integer
  getSize _ = ioe_unsupportedOperation

  -- | change the size of the data.
  setSize :: a -> Integer -> IO ()
  setSize _ _ = ioe_unsupportedOperation

  -- | for terminal devices, changes whether characters are echoed on
  -- the device.
  setEcho :: a -> Bool -> IO ()
  setEcho _ _ = ioe_unsupportedOperation

  -- | returns the current echoing status.
  getEcho :: a -> IO Bool
  getEcho _ = ioe_unsupportedOperation

  -- | some devices (e.g. terminals) support a "raw" mode where
  -- characters entered are immediately made available to the program.
  -- If available, this operations enables raw mode.
  setRaw :: a -> Bool -> IO ()
  setRaw _ _ = ioe_unsupportedOperation

  -- | returns the 'IODeviceType' corresponding to this device.
  devType :: a -> IO IODeviceType

  -- | duplicates the device, if possible.  The new device is expected
  -- to share a file pointer with the original device (like Unix @dup@).
  dup :: a -> IO a
  dup _ = ioe_unsupportedOperation

  -- | @dup2 source target@ replaces the target device with the source
  -- device.  The target device is closed first, if necessary, and then
  -- it is made into a duplicate of the first device (like Unix @dup2@).
  dup2 :: a -> a -> IO a
  dup2 _ _ = ioe_unsupportedOperation

ioe_unsupportedOperation :: IO a
ioe_unsupportedOperation = throwIO unsupportedOperation

-- | Type of a device that can be used to back a
-- 'GHC.IO.Handle.Handle' (see also 'GHC.IO.Handle.mkFileHandle'). The
-- standard libraries provide creation of 'GHC.IO.Handle.Handle's via
-- Posix file operations with file descriptors (see
-- 'GHC.IO.Handle.FD.mkHandleFromFD') with FD being the underlying
-- 'GHC.IO.Device.IODevice' instance.
--
-- Users may provide custom instances of 'GHC.IO.Device.IODevice'
-- which are expected to conform the following rules:

data IODeviceType
  = Directory -- ^ The standard libraries do not have direct support
              -- for this device type, but a user implementation is
              -- expected to provide a list of file names in
              -- the directory, in any order, separated by @\'\\0\'@
              -- characters, excluding the @"."@ and @".."@ names. See
              -- also 'System.Directory.getDirectoryContents'.  Seek
              -- operations are not supported on directories (other
              -- than to the zero position).
  | Stream    -- ^ A duplex communications channel (results in
              -- creation of a duplex 'GHC.IO.Handle.Handle'). The
              -- standard libraries use this device type when
              -- creating 'GHC.IO.Handle.Handle's for open sockets.
  | RegularFile -- ^ A file that may be read or written, and also
                -- may be seekable.
  | RawDevice -- ^ A "raw" (disk) device which supports block binary
              -- read and write operations and may be seekable only
              -- to positions of certain granularity (block-
              -- aligned).
  deriving ( Eq -- ^ @since 4.2.0.0
           )

-- -----------------------------------------------------------------------------
-- SeekMode type

-- | A mode that determines the effect of 'System.IO.hSeek' @hdl mode i@.
data SeekMode
  = AbsoluteSeek        -- ^ the position of @hdl@ is set to @i@.
  | RelativeSeek        -- ^ the position of @hdl@ is set to offset @i@
                        -- from the current position.
  | SeekFromEnd         -- ^ the position of @hdl@ is set to offset @i@
                        -- from the end of the file.
    deriving ( Eq   -- ^ @since 4.2.0.0
             , Ord  -- ^ @since 4.2.0.0
             , Ix   -- ^ @since 4.2.0.0
             , Enum -- ^ @since 4.2.0.0
             , Read -- ^ @since 4.2.0.0
             , Show -- ^ @since 4.2.0.0
             )


{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP, NoImplicitPrelude #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}

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

module GHC.IO.Encoding (
        BufferCodec(..), TextEncoding(..), TextEncoder, TextDecoder, CodingProgress(..),
        latin1, latin1_encode, latin1_decode,
        utf8, utf8_bom,
        utf16, utf16le, utf16be,
        utf32, utf32le, utf32be,
        initLocaleEncoding,
        getLocaleEncoding, getFileSystemEncoding, getForeignEncoding,
        setLocaleEncoding, setFileSystemEncoding, setForeignEncoding,
        char8,
        mkTextEncoding,
        argvEncoding
    ) where

import GHC.Base
import GHC.IO.Exception
import GHC.IO.Buffer
import GHC.IO.Encoding.Failure
import GHC.IO.Encoding.Types
#if !defined(mingw32_HOST_OS)
import qualified GHC.IO.Encoding.Iconv as Iconv
#else
import qualified GHC.IO.Encoding.CodePage as CodePage
import Text.Read (reads)
#endif
import qualified GHC.IO.Encoding.Latin1 as Latin1
import qualified GHC.IO.Encoding.UTF8   as UTF8
import qualified GHC.IO.Encoding.UTF16  as UTF16
import qualified GHC.IO.Encoding.UTF32  as UTF32
import GHC.List
import GHC.Word

import Data.IORef
import Data.Char (toUpper)
import System.IO.Unsafe (unsafePerformIO)

-- -----------------------------------------------------------------------------

-- | The Latin1 (ISO8859-1) encoding.  This encoding maps bytes
-- directly to the first 256 Unicode code points, and is thus not a
-- complete Unicode encoding.  An attempt to write a character greater than
-- @\'\\255\'@ to a 'System.IO.Handle' using the 'latin1' encoding will result in an
-- error.
latin1  :: TextEncoding
latin1 = Latin1.latin1_checked

-- | The UTF-8 Unicode encoding
utf8  :: TextEncoding
utf8 = UTF8.utf8

-- | The UTF-8 Unicode encoding, with a byte-order-mark (BOM; the byte
-- sequence 0xEF 0xBB 0xBF).  This encoding behaves like 'utf8',
-- except that on input, the BOM sequence is ignored at the beginning
-- of the stream, and on output, the BOM sequence is prepended.
--
-- The byte-order-mark is strictly unnecessary in UTF-8, but is
-- sometimes used to identify the encoding of a file.
--
utf8_bom  :: TextEncoding
utf8_bom = UTF8.utf8_bom

-- | The UTF-16 Unicode encoding (a byte-order-mark should be used to
-- indicate endianness).
utf16  :: TextEncoding
utf16 = UTF16.utf16

-- | The UTF-16 Unicode encoding (litte-endian)
utf16le  :: TextEncoding
utf16le = UTF16.utf16le

-- | The UTF-16 Unicode encoding (big-endian)
utf16be  :: TextEncoding
utf16be = UTF16.utf16be

-- | The UTF-32 Unicode encoding (a byte-order-mark should be used to
-- indicate endianness).
utf32  :: TextEncoding
utf32 = UTF32.utf32

-- | The UTF-32 Unicode encoding (litte-endian)
utf32le  :: TextEncoding
utf32le = UTF32.utf32le

-- | The UTF-32 Unicode encoding (big-endian)
utf32be  :: TextEncoding
utf32be = UTF32.utf32be

-- | The Unicode encoding of the current locale
--
-- @since 4.5.0.0
getLocaleEncoding :: IO TextEncoding

-- | The Unicode encoding of the current locale, but allowing arbitrary
-- undecodable bytes to be round-tripped through it.
--
-- This 'TextEncoding' is used to decode and encode command line arguments
-- and environment variables on non-Windows platforms.
--
-- On Windows, this encoding *should not* be used if possible because
-- the use of code pages is deprecated: Strings should be retrieved
-- via the "wide" W-family of UTF-16 APIs instead
--
-- @since 4.5.0.0
getFileSystemEncoding :: IO TextEncoding

-- | The Unicode encoding of the current locale, but where undecodable
-- bytes are replaced with their closest visual match. Used for
-- the 'Foreign.C.String.CString' marshalling functions in "Foreign.C.String"
--
-- @since 4.5.0.0
getForeignEncoding :: IO TextEncoding

-- | @since 4.5.0.0
setLocaleEncoding, setFileSystemEncoding, setForeignEncoding :: TextEncoding -> IO ()

(getLocaleEncoding, setLocaleEncoding)         = mkGlobal initLocaleEncoding
(getFileSystemEncoding, setFileSystemEncoding) = mkGlobal initFileSystemEncoding
(getForeignEncoding, setForeignEncoding)       = mkGlobal initForeignEncoding

mkGlobal :: a -> (IO a, a -> IO ())
mkGlobal x = unsafePerformIO $ do
    x_ref <- newIORef x
    return (readIORef x_ref, writeIORef x_ref)

-- | @since 4.5.0.0
initLocaleEncoding, initFileSystemEncoding, initForeignEncoding :: TextEncoding

#if !defined(mingw32_HOST_OS)
-- It is rather important that we don't just call Iconv.mkIconvEncoding here
-- because some iconvs (in particular GNU iconv) will brokenly UTF-8 encode
-- lone surrogates without complaint.
--
-- By going through our Haskell implementations of those encodings, we are
-- guaranteed to catch such errors.
--
-- FIXME: this is not a complete solution because if the locale encoding is one
-- which we don't have a Haskell-side decoder for, iconv might still ignore the
-- lone surrogate in the input.
initLocaleEncoding     = unsafePerformIO $ mkTextEncoding' ErrorOnCodingFailure Iconv.localeEncodingName
initFileSystemEncoding = unsafePerformIO $ mkTextEncoding' RoundtripFailure     Iconv.localeEncodingName
initForeignEncoding    = unsafePerformIO $ mkTextEncoding' IgnoreCodingFailure  Iconv.localeEncodingName
#else
initLocaleEncoding     = CodePage.localeEncoding
initFileSystemEncoding = CodePage.mkLocaleEncoding RoundtripFailure
initForeignEncoding    = CodePage.mkLocaleEncoding IgnoreCodingFailure
#endif

-- See Note [Windows Unicode Arguments] in rts/RtsFlags.c
-- On Windows we assume hs_init argv is in utf8 encoding.

-- | Internal encoding of argv
argvEncoding :: IO TextEncoding
#if defined(mingw32_HOST_OS)
argvEncoding = return utf8
#else
argvEncoding = getFileSystemEncoding
#endif

-- | An encoding in which Unicode code points are translated to bytes
-- by taking the code point modulo 256.  When decoding, bytes are
-- translated directly into the equivalent code point.
--
-- This encoding never fails in either direction.  However, encoding
-- discards information, so encode followed by decode is not the
-- identity.
--
-- @since 4.4.0.0
char8 :: TextEncoding
char8 = Latin1.latin1

-- | Look up the named Unicode encoding.  May fail with
--
--  * 'System.IO.Error.isDoesNotExistError' if the encoding is unknown
--
-- The set of known encodings is system-dependent, but includes at least:
--
--  * @UTF-8@
--
--  * @UTF-16@, @UTF-16BE@, @UTF-16LE@
--
--  * @UTF-32@, @UTF-32BE@, @UTF-32LE@
--
-- There is additional notation (borrowed from GNU iconv) for specifying
-- how illegal characters are handled:
--
--  * a suffix of @\/\/IGNORE@, e.g. @UTF-8\/\/IGNORE@, will cause
--    all illegal sequences on input to be ignored, and on output
--    will drop all code points that have no representation in the
--    target encoding.
--
--  * a suffix of @\/\/TRANSLIT@ will choose a replacement character
--    for illegal sequences or code points.
--
--  * a suffix of @\/\/ROUNDTRIP@ will use a PEP383-style escape mechanism
--    to represent any invalid bytes in the input as Unicode codepoints (specifically,
--    as lone surrogates, which are normally invalid in UTF-32).
--    Upon output, these special codepoints are detected and turned back into the
--    corresponding original byte.
--
--    In theory, this mechanism allows arbitrary data to be roundtripped via
--    a 'String' with no loss of data. In practice, there are two limitations
--    to be aware of:
--
--      1. This only stands a chance of working for an encoding which is an ASCII
--         superset, as for security reasons we refuse to escape any bytes smaller
--         than 128. Many encodings of interest are ASCII supersets (in particular,
--         you can assume that the locale encoding is an ASCII superset) but many
--         (such as UTF-16) are not.
--
--      2. If the underlying encoding is not itself roundtrippable, this mechanism
--         can fail. Roundtrippable encodings are those which have an injective mapping
--         into Unicode. Almost all encodings meet this criteria, but some do not. Notably,
--         Shift-JIS (CP932) and Big5 contain several different encodings of the same
--         Unicode codepoint.
--
-- On Windows, you can access supported code pages with the prefix
-- @CP@; for example, @\"CP1250\"@.
--
mkTextEncoding :: String -> IO TextEncoding
mkTextEncoding e = case mb_coding_failure_mode of
    Nothing -> unknownEncodingErr e
    Just cfm -> mkTextEncoding' cfm enc
  where
    (enc, suffix) = span (/= '/') e
    mb_coding_failure_mode = case suffix of
        ""            -> Just ErrorOnCodingFailure
        "//IGNORE"    -> Just IgnoreCodingFailure
        "//TRANSLIT"  -> Just TransliterateCodingFailure
        "//ROUNDTRIP" -> Just RoundtripFailure
        _             -> Nothing

mkTextEncoding' :: CodingFailureMode -> String -> IO TextEncoding
mkTextEncoding' cfm enc =
  case [toUpper c | c <- enc, c /= '-'] of
  -- UTF-8 and friends we can handle ourselves
    "UTF8"    -> return $ UTF8.mkUTF8 cfm
    "UTF16"   -> return $ UTF16.mkUTF16 cfm
    "UTF16LE" -> return $ UTF16.mkUTF16le cfm
    "UTF16BE" -> return $ UTF16.mkUTF16be cfm
    "UTF32"   -> return $ UTF32.mkUTF32 cfm
    "UTF32LE" -> return $ UTF32.mkUTF32le cfm
    "UTF32BE" -> return $ UTF32.mkUTF32be cfm
    -- On AIX, we want to avoid iconv, because it is either
    -- a) totally broken, or b) non-reentrant, or c) actually works.
    -- Detecting b) is difficult as you'd have to trigger the reentrancy
    -- corruption.
    -- Therefore, on AIX, we handle the popular ASCII and latin1 encodings
    -- ourselves. For consistency, we do the same on other platforms.
    -- We use `mkLatin1_checked` instead of `mkLatin1`, since the latter
    -- completely ignores the CodingFailureMode (TEST=encoding005).
    _ | isAscii -> return (Latin1.mkAscii cfm)
    _ | isLatin1 -> return (Latin1.mkLatin1_checked cfm)
#if defined(mingw32_HOST_OS)
    'C':'P':n | [(cp,"")] <- reads n -> return $ CodePage.mkCodePageEncoding cfm cp
    _ -> unknownEncodingErr (enc ++ codingFailureModeSuffix cfm)
#else
    -- Otherwise, handle other encoding needs via iconv.

    -- Unfortunately there is no good way to determine whether iconv is actually
    -- functional without telling it to do something.
    _ -> do res <- Iconv.mkIconvEncoding cfm enc
            case res of
              Just e -> return e
              Nothing -> unknownEncodingErr (enc ++ codingFailureModeSuffix cfm)
#endif
  where
    isAscii = enc `elem` asciiEncNames
    isLatin1 = enc `elem` latin1EncNames
    asciiEncNames = -- ASCII aliases specified by RFC 1345 and RFC 3808.
      [ "ANSI_X3.4-1968", "iso-ir-6", "ANSI_X3.4-1986", "ISO_646.irv:1991"
      , "US-ASCII", "us", "IBM367", "cp367", "csASCII", "ASCII", "ISO646-US"
      ]
    latin1EncNames = -- latin1 aliases specified by RFC 1345 and RFC 3808.
      [ "ISO_8859-1:1987", "iso-ir-100", "ISO_8859-1", "ISO-8859-1", "latin1",
        "l1", "IBM819", "CP819", "csISOLatin1"
      ]

latin1_encode :: CharBuffer -> Buffer Word8 -> IO (CharBuffer, Buffer Word8)
latin1_encode input output = fmap (\(_why,input',output') -> (input',output')) $ Latin1.latin1_encode input output -- unchecked, used for char8
--latin1_encode = unsafePerformIO $ do mkTextEncoder Iconv.latin1 >>= return.encode

latin1_decode :: Buffer Word8 -> CharBuffer -> IO (Buffer Word8, CharBuffer)
latin1_decode input output = fmap (\(_why,input',output') -> (input',output')) $ Latin1.latin1_decode input output
--latin1_decode = unsafePerformIO $ do mkTextDecoder Iconv.latin1 >>= return.encode

unknownEncodingErr :: String -> IO a
unknownEncodingErr e = ioException (IOError Nothing NoSuchThing "mkTextEncoding"
                                            ("unknown encoding:" ++ e)  Nothing Nothing)


{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE DeriveGeneric, NoImplicitPrelude, MagicHash,
             ExistentialQuantification, ImplicitParams #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}
{-# OPTIONS_HADDOCK not-home #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.IO.Exception
-- Copyright   :  (c) The University of Glasgow, 2009
-- License     :  see libraries/base/LICENSE
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  internal
-- Portability :  non-portable
--
-- IO-related Exception types and functions
--
-----------------------------------------------------------------------------

module GHC.IO.Exception (
  BlockedIndefinitelyOnMVar(..), blockedIndefinitelyOnMVar,
  BlockedIndefinitelyOnSTM(..), blockedIndefinitelyOnSTM,
  Deadlock(..),
  AllocationLimitExceeded(..), allocationLimitExceeded,
  AssertionFailed(..),
  CompactionFailed(..),
  cannotCompactFunction, cannotCompactPinned, cannotCompactMutable,

  SomeAsyncException(..),
  asyncExceptionToException, asyncExceptionFromException,
  AsyncException(..), stackOverflow, heapOverflow,

  ArrayException(..),
  ExitCode(..),
  FixIOException (..),

  ioException,
  ioError,
  IOError,
  IOException(..),
  IOErrorType(..),
  userError,
  assertError,
  unsupportedOperation,
  untangle,
 ) where

import GHC.Base
import GHC.Generics
import GHC.List
import GHC.IO
import GHC.Show
import GHC.Read
import GHC.Exception
import GHC.IO.Handle.Types
import GHC.OldList ( intercalate )
import {-# SOURCE #-} GHC.Stack.CCS
import Foreign.C.Types

import Data.Typeable ( cast )

-- ------------------------------------------------------------------------
-- Exception datatypes and operations

-- |The thread is blocked on an @MVar@, but there are no other references
-- to the @MVar@ so it can't ever continue.
data BlockedIndefinitelyOnMVar = BlockedIndefinitelyOnMVar

-- | @since 4.1.0.0
instance Exception BlockedIndefinitelyOnMVar

-- | @since 4.1.0.0
instance Show BlockedIndefinitelyOnMVar where
    showsPrec _ BlockedIndefinitelyOnMVar = showString "thread blocked indefinitely in an MVar operation"

blockedIndefinitelyOnMVar :: SomeException -- for the RTS
blockedIndefinitelyOnMVar = toException BlockedIndefinitelyOnMVar

-----

-- |The thread is waiting to retry an STM transaction, but there are no
-- other references to any @TVar@s involved, so it can't ever continue.
data BlockedIndefinitelyOnSTM = BlockedIndefinitelyOnSTM

-- | @since 4.1.0.0
instance Exception BlockedIndefinitelyOnSTM

-- | @since 4.1.0.0
instance Show BlockedIndefinitelyOnSTM where
    showsPrec _ BlockedIndefinitelyOnSTM = showString "thread blocked indefinitely in an STM transaction"

blockedIndefinitelyOnSTM :: SomeException -- for the RTS
blockedIndefinitelyOnSTM = toException BlockedIndefinitelyOnSTM

-----

-- |There are no runnable threads, so the program is deadlocked.
-- The @Deadlock@ exception is raised in the main thread only.
data Deadlock = Deadlock

-- | @since 4.1.0.0
instance Exception Deadlock

-- | @since 4.1.0.0
instance Show Deadlock where
    showsPrec _ Deadlock = showString "<<deadlock>>"

-----

-- |This thread has exceeded its allocation limit.  See
-- 'System.Mem.setAllocationCounter' and
-- 'System.Mem.enableAllocationLimit'.
--
-- @since 4.8.0.0
data AllocationLimitExceeded = AllocationLimitExceeded

-- | @since 4.8.0.0
instance Exception AllocationLimitExceeded where
  toException = asyncExceptionToException
  fromException = asyncExceptionFromException

-- | @since 4.7.1.0
instance Show AllocationLimitExceeded where
    showsPrec _ AllocationLimitExceeded =
      showString "allocation limit exceeded"

allocationLimitExceeded :: SomeException -- for the RTS
allocationLimitExceeded = toException AllocationLimitExceeded

-----

-- | Compaction found an object that cannot be compacted.  Functions
-- cannot be compacted, nor can mutable objects or pinned objects.
-- See 'GHC.Compact.compact'.
--
-- @since 4.10.0.0
newtype CompactionFailed = CompactionFailed String

-- | @since 4.10.0.0
instance Exception CompactionFailed where

-- | @since 4.10.0.0
instance Show CompactionFailed where
    showsPrec _ (CompactionFailed why) =
      showString ("compaction failed: " ++ why)

cannotCompactFunction :: SomeException -- for the RTS
cannotCompactFunction =
  toException (CompactionFailed "cannot compact functions")

cannotCompactPinned :: SomeException -- for the RTS
cannotCompactPinned =
  toException (CompactionFailed "cannot compact pinned objects")

cannotCompactMutable :: SomeException -- for the RTS
cannotCompactMutable =
  toException (CompactionFailed "cannot compact mutable objects")

-----

-- |'assert' was applied to 'False'.
newtype AssertionFailed = AssertionFailed String

-- | @since 4.1.0.0
instance Exception AssertionFailed

-- | @since 4.1.0.0
instance Show AssertionFailed where
    showsPrec _ (AssertionFailed err) = showString err

-----

-- |Superclass for asynchronous exceptions.
--
-- @since 4.7.0.0
data SomeAsyncException = forall e . Exception e => SomeAsyncException e

-- | @since 4.7.0.0
instance Show SomeAsyncException where
    show (SomeAsyncException e) = show e

-- | @since 4.7.0.0
instance Exception SomeAsyncException

-- |@since 4.7.0.0
asyncExceptionToException :: Exception e => e -> SomeException
asyncExceptionToException = toException . SomeAsyncException

-- |@since 4.7.0.0
asyncExceptionFromException :: Exception e => SomeException -> Maybe e
asyncExceptionFromException x = do
    SomeAsyncException a <- fromException x
    cast a

-- |Asynchronous exceptions.
data AsyncException
  = StackOverflow
        -- ^The current thread\'s stack exceeded its limit.
        -- Since an exception has been raised, the thread\'s stack
        -- will certainly be below its limit again, but the
        -- programmer should take remedial action
        -- immediately.
  | HeapOverflow
        -- ^The program\'s heap is reaching its limit, and
        -- the program should take action to reduce the amount of
        -- live data it has. Notes:
        --
        --   * It is undefined which thread receives this exception.
        --     GHC currently throws this to the same thread that
        --     receives 'UserInterrupt', but this may change in the
        --     future.
        --
        --   * The GHC RTS currently can only recover from heap overflow
        --     if it detects that an explicit memory limit (set via RTS flags).
        --     has been exceeded.  Currently, failure to allocate memory from
        --     the operating system results in immediate termination of the
        --     program.
  | ThreadKilled
        -- ^This exception is raised by another thread
        -- calling 'Control.Concurrent.killThread', or by the system
        -- if it needs to terminate the thread for some
        -- reason.
  | UserInterrupt
        -- ^This exception is raised by default in the main thread of
        -- the program when the user requests to terminate the program
        -- via the usual mechanism(s) (e.g. Control-C in the console).
  deriving ( Eq  -- ^ @since 4.2.0.0
           , Ord -- ^ @since 4.2.0.0
           )

-- | @since 4.7.0.0
instance Exception AsyncException where
  toException = asyncExceptionToException
  fromException = asyncExceptionFromException

-- | Exceptions generated by array operations
data ArrayException
  = IndexOutOfBounds    String
        -- ^An attempt was made to index an array outside
        -- its declared bounds.
  | UndefinedElement    String
        -- ^An attempt was made to evaluate an element of an
        -- array that had not been initialized.
  deriving ( Eq  -- ^ @since 4.2.0.0
           , Ord -- ^ @since 4.2.0.0
           )

-- | @since 4.1.0.0
instance Exception ArrayException

-- for the RTS
stackOverflow, heapOverflow :: SomeException
stackOverflow = toException StackOverflow
heapOverflow  = toException HeapOverflow

-- | @since 4.1.0.0
instance Show AsyncException where
  showsPrec _ StackOverflow   = showString "stack overflow"
  showsPrec _ HeapOverflow    = showString "heap overflow"
  showsPrec _ ThreadKilled    = showString "thread killed"
  showsPrec _ UserInterrupt   = showString "user interrupt"

-- | @since 4.1.0.0
instance Show ArrayException where
  showsPrec _ (IndexOutOfBounds s)
        = showString "array index out of range"
        . (if not (null s) then showString ": " . showString s
                           else id)
  showsPrec _ (UndefinedElement s)
        = showString "undefined array element"
        . (if not (null s) then showString ": " . showString s
                           else id)

-- | The exception thrown when an infinite cycle is detected in
-- 'System.IO.fixIO'.
--
-- @since 4.11.0.0
data FixIOException = FixIOException

-- | @since 4.11.0.0
instance Exception FixIOException

-- | @since 4.11.0.0
instance Show FixIOException where
  showsPrec _ FixIOException = showString "cyclic evaluation in fixIO"

-- -----------------------------------------------------------------------------
-- The ExitCode type

-- We need it here because it is used in ExitException in the
-- Exception datatype (above).

-- | Defines the exit codes that a program can return.
data ExitCode
  = ExitSuccess -- ^ indicates successful termination;
  | ExitFailure Int
                -- ^ indicates program failure with an exit code.
                -- The exact interpretation of the code is
                -- operating-system dependent.  In particular, some values
                -- may be prohibited (e.g. 0 on a POSIX-compliant system).
  deriving (Eq, Ord, Read, Show, Generic)

-- | @since 4.1.0.0
instance Exception ExitCode

ioException     :: IOException -> IO a
ioException err = throwIO err

-- | Raise an 'IOError' in the 'IO' monad.
ioError         :: IOError -> IO a
ioError         =  ioException

-- ---------------------------------------------------------------------------
-- IOError type

-- | The Haskell 2010 type for exceptions in the 'IO' monad.
-- Any I\/O operation may raise an 'IOError' instead of returning a result.
-- For a more general type of exception, including also those that arise
-- in pure code, see 'Control.Exception.Exception'.
--
-- In Haskell 2010, this is an opaque type.
type IOError = IOException

-- |Exceptions that occur in the @IO@ monad.
-- An @IOException@ records a more specific error type, a descriptive
-- string and maybe the handle that was used when the error was
-- flagged.
data IOException
 = IOError {
     ioe_handle   :: Maybe Handle,   -- the handle used by the action flagging
                                     -- the error.
     ioe_type     :: IOErrorType,    -- what it was.
     ioe_location :: String,         -- location.
     ioe_description :: String,      -- error type specific information.
     ioe_errno    :: Maybe CInt,     -- errno leading to this error, if any.
     ioe_filename :: Maybe FilePath  -- filename the error is related to.
   }

-- | @since 4.1.0.0
instance Exception IOException

-- | @since 4.1.0.0
instance Eq IOException where
  (IOError h1 e1 loc1 str1 en1 fn1) == (IOError h2 e2 loc2 str2 en2 fn2) =
    e1==e2 && str1==str2 && h1==h2 && loc1==loc2 && en1==en2 && fn1==fn2

-- | An abstract type that contains a value for each variant of 'IOError'.
data IOErrorType
  -- Haskell 2010:
  = AlreadyExists
  | NoSuchThing
  | ResourceBusy
  | ResourceExhausted
  | EOF
  | IllegalOperation
  | PermissionDenied
  | UserError
  -- GHC only:
  | UnsatisfiedConstraints
  | SystemError
  | ProtocolError
  | OtherError
  | InvalidArgument
  | InappropriateType
  | HardwareFault
  | UnsupportedOperation
  | TimeExpired
  | ResourceVanished
  | Interrupted

-- | @since 4.1.0.0
instance Eq IOErrorType where
   x == y = isTrue# (getTag x ==# getTag y)

-- | @since 4.1.0.0
instance Show IOErrorType where
  showsPrec _ e =
    showString $
    case e of
      AlreadyExists     -> "already exists"
      NoSuchThing       -> "does not exist"
      ResourceBusy      -> "resource busy"
      ResourceExhausted -> "resource exhausted"
      EOF               -> "end of file"
      IllegalOperation  -> "illegal operation"
      PermissionDenied  -> "permission denied"
      UserError         -> "user error"
      HardwareFault     -> "hardware fault"
      InappropriateType -> "inappropriate type"
      Interrupted       -> "interrupted"
      InvalidArgument   -> "invalid argument"
      OtherError        -> "failed"
      ProtocolError     -> "protocol error"
      ResourceVanished  -> "resource vanished"
      SystemError       -> "system error"
      TimeExpired       -> "timeout"
      UnsatisfiedConstraints -> "unsatisfied constraints" -- ultra-precise!
      UnsupportedOperation -> "unsupported operation"

-- | Construct an 'IOError' value with a string describing the error.
-- The 'fail' method of the 'IO' instance of the 'Monad' class raises a
-- 'userError', thus:
--
-- > instance Monad IO where
-- >   ...
-- >   fail s = ioError (userError s)
--
userError       :: String  -> IOError
userError str   =  IOError Nothing UserError "" str Nothing Nothing

-- ---------------------------------------------------------------------------
-- Showing IOErrors

-- | @since 4.1.0.0
instance Show IOException where
    showsPrec p (IOError hdl iot loc s _ fn) =
      (case fn of
         Nothing -> case hdl of
                        Nothing -> id
                        Just h  -> showsPrec p h . showString ": "
         Just name -> showString name . showString ": ") .
      (case loc of
         "" -> id
         _  -> showString loc . showString ": ") .
      showsPrec p iot .
      (case s of
         "" -> id
         _  -> showString " (" . showString s . showString ")")

-- Note the use of "lazy". This means that
--     assert False (throw e)
-- will throw the assertion failure rather than e. See trac #5561.
assertError :: (?callStack :: CallStack) => Bool -> a -> a
assertError predicate v
  | predicate = lazy v
  | otherwise = unsafeDupablePerformIO $ do
    ccsStack <- currentCallStack
    let
      implicitParamCallStack = prettyCallStackLines ?callStack
      ccsCallStack = showCCSStack ccsStack
      stack = intercalate "\n" $ implicitParamCallStack ++ ccsCallStack
    throwIO (AssertionFailed ("Assertion failed\n" ++ stack))

unsupportedOperation :: IOError
unsupportedOperation =
   (IOError Nothing UnsupportedOperation ""
        "Operation is not supported" Nothing Nothing)

{-
(untangle coded message) expects "coded" to be of the form
        "location|details"
It prints
        location message details
-}
untangle :: Addr# -> String -> String
untangle coded message
  =  location
  ++ ": "
  ++ message
  ++ details
  ++ "\n"
  where
    coded_str = unpackCStringUtf8# coded

    (location, details)
      = case (span not_bar coded_str) of { (loc, rest) ->
        case rest of
          ('|':det) -> (loc, ' ' : det)
          _         -> (loc, "")
        }
    not_bar c = c /= '|'


{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP
           , NoImplicitPrelude
           , BangPatterns
  #-}
{-# OPTIONS_GHC -Wno-identities #-}
-- Whether there are identities depends on the platform
{-# OPTIONS_HADDOCK not-home #-}

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

module GHC.IO.FD (
        FD(..),
        openFile, mkFD, release,
        setNonBlockingMode,
        readRawBufferPtr, readRawBufferPtrNoBlock, writeRawBufferPtr,
        stdin, stdout, stderr
    ) where

import GHC.Base
import GHC.Num
import GHC.Real
import GHC.Show
import GHC.Enum

import GHC.IO
import GHC.IO.IOMode
import GHC.IO.Buffer
import GHC.IO.BufferedIO
import qualified GHC.IO.Device
import GHC.IO.Device (SeekMode(..), IODeviceType(..))
import GHC.Conc.IO
import GHC.IO.Exception
#if defined(mingw32_HOST_OS)
import GHC.Windows
import Data.Bool
#endif

import Foreign
import Foreign.C
import qualified System.Posix.Internals
import System.Posix.Internals hiding (FD, setEcho, getEcho)
import System.Posix.Types

#if defined(mingw32_HOST_OS)
# if defined(i386_HOST_ARCH)
#  define WINDOWS_CCONV stdcall
# elif defined(x86_64_HOST_ARCH)
#  define WINDOWS_CCONV ccall
# else
#  error Unknown mingw32 arch
# endif
#endif

c_DEBUG_DUMP :: Bool
c_DEBUG_DUMP = False

-- -----------------------------------------------------------------------------
-- The file-descriptor IO device

data FD = FD {
  fdFD :: {-# UNPACK #-} !CInt,
#if defined(mingw32_HOST_OS)
  -- On Windows, a socket file descriptor needs to be read and written
  -- using different functions (send/recv).
  fdIsSocket_ :: {-# UNPACK #-} !Int
#else
  -- On Unix we need to know whether this FD has O_NONBLOCK set.
  -- If it has, then we can use more efficient routines to read/write to it.
  -- It is always safe for this to be off.
  fdIsNonBlocking :: {-# UNPACK #-} !Int
#endif
 }

#if defined(mingw32_HOST_OS)
fdIsSocket :: FD -> Bool
fdIsSocket fd = fdIsSocket_ fd /= 0
#endif

-- | @since 4.1.0.0
instance Show FD where
  show fd = show (fdFD fd)

-- | @since 4.1.0.0
instance GHC.IO.Device.RawIO FD where
  read             = fdRead
  readNonBlocking  = fdReadNonBlocking
  write            = fdWrite
  writeNonBlocking = fdWriteNonBlocking

-- | @since 4.1.0.0
instance GHC.IO.Device.IODevice FD where
  ready         = ready
  close         = close
  isTerminal    = isTerminal
  isSeekable    = isSeekable
  seek          = seek
  tell          = tell
  getSize       = getSize
  setSize       = setSize
  setEcho       = setEcho
  getEcho       = getEcho
  setRaw        = setRaw
  devType       = devType
  dup           = dup
  dup2          = dup2

-- We used to use System.Posix.Internals.dEFAULT_BUFFER_SIZE, which is
-- taken from the value of BUFSIZ on the current platform.  This value
-- varies too much though: it is 512 on Windows, 1024 on OS X and 8192
-- on Linux.  So let's just use a decent size on every platform:
dEFAULT_FD_BUFFER_SIZE :: Int
dEFAULT_FD_BUFFER_SIZE = 8192

-- | @since 4.1.0.0
instance BufferedIO FD where
  newBuffer _dev state = newByteBuffer dEFAULT_FD_BUFFER_SIZE state
  fillReadBuffer    fd buf = readBuf' fd buf
  fillReadBuffer0   fd buf = readBufNonBlocking fd buf
  flushWriteBuffer  fd buf = writeBuf' fd buf
  flushWriteBuffer0 fd buf = writeBufNonBlocking fd buf

readBuf' :: FD -> Buffer Word8 -> IO (Int, Buffer Word8)
readBuf' fd buf = do
  when c_DEBUG_DUMP $
      puts ("readBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
  (r,buf') <- readBuf fd buf
  when c_DEBUG_DUMP $
      puts ("after: " ++ summaryBuffer buf' ++ "\n")
  return (r,buf')

writeBuf' :: FD -> Buffer Word8 -> IO (Buffer Word8)
writeBuf' fd buf = do
  when c_DEBUG_DUMP $
      puts ("writeBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
  writeBuf fd buf

-- -----------------------------------------------------------------------------
-- opening files

-- | Open a file and make an 'FD' for it.  Truncates the file to zero
-- size when the `IOMode` is `WriteMode`.
openFile
  :: FilePath -- ^ file to open
  -> IOMode   -- ^ mode in which to open the file
  -> Bool     -- ^ open the file in non-blocking mode?
  -> IO (FD,IODeviceType)

openFile filepath iomode non_blocking =
  withFilePath filepath $ \ f ->

    let
      oflags1 = case iomode of
                  ReadMode      -> read_flags
                  WriteMode     -> write_flags
                  ReadWriteMode -> rw_flags
                  AppendMode    -> append_flags

#if defined(mingw32_HOST_OS)
      binary_flags = o_BINARY
#else
      binary_flags = 0
#endif

      oflags2 = oflags1 .|. binary_flags

      oflags | non_blocking = oflags2 .|. nonblock_flags
             | otherwise    = oflags2
    in do

    -- NB. always use a safe open(), because we don't know whether open()
    -- will be fast or not.  It can be slow on NFS and FUSE filesystems,
    -- for example.
    fd <- throwErrnoIfMinus1Retry "openFile" $ c_safe_open f oflags 0o666

    (fD,fd_type) <- mkFD fd iomode Nothing{-no stat-}
                            False{-not a socket-}
                            non_blocking
            `catchAny` \e -> do _ <- c_close fd
                                throwIO e

    -- 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.
    when (iomode == WriteMode && fd_type == RegularFile) $
      setSize fD 0

    return (fD,fd_type)

std_flags, output_flags, read_flags, write_flags, rw_flags,
    append_flags, nonblock_flags :: CInt
std_flags    = 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
nonblock_flags = o_NONBLOCK

-- | Make a 'FD' from an existing file descriptor.  Fails if the FD
-- refers to a directory.  If the FD refers to a file, `mkFD` locks
-- the file according to the Haskell 2010 single writer/multiple reader
-- locking semantics (this is why we need the `IOMode` argument too).
mkFD :: CInt
     -> IOMode
     -> Maybe (IODeviceType, CDev, CIno)
     -- the results of fdStat if we already know them, or we want
     -- to prevent fdToHandle_stat from doing its own stat.
     -- These are used for:
     --   - we fail if the FD refers to a directory
     --   - if the FD refers to a file, we lock it using (cdev,cino)
     -> Bool   -- ^ is a socket (on Windows)
     -> Bool   -- ^ is in non-blocking mode on Unix
     -> IO (FD,IODeviceType)

mkFD fd iomode mb_stat is_socket is_nonblock = do

    let _ = (is_socket, is_nonblock) -- warning suppression

    (fd_type,dev,ino) <-
        case mb_stat of
          Nothing   -> fdStat fd
          Just stat -> return stat

    let write = case iomode of
                   ReadMode -> False
                   _ -> True

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

        -- regular files need to be locked
        RegularFile -> do
           -- On Windows we need an additional call to get a unique device id
           -- and inode, since fstat just returns 0 for both.
           (unique_dev, unique_ino) <- getUniqueFileInfo fd dev ino
           r <- lockFile fd unique_dev unique_ino (fromBool write)
           when (r == -1)  $
                ioException (IOError Nothing ResourceBusy "openFile"
                                   "file is locked" Nothing Nothing)

        _other_type -> return ()

#if defined(mingw32_HOST_OS)
    when (not is_socket) $ setmode fd True >> return ()
#endif

    return (FD{ fdFD = fd,
#if !defined(mingw32_HOST_OS)
                fdIsNonBlocking = fromEnum is_nonblock
#else
                fdIsSocket_ = fromEnum is_socket
#endif
              },
            fd_type)

getUniqueFileInfo :: CInt -> CDev -> CIno -> IO (Word64, Word64)
#if !defined(mingw32_HOST_OS)
getUniqueFileInfo _ dev ino = return (fromIntegral dev, fromIntegral ino)
#else
getUniqueFileInfo fd _ _ = do
  with 0 $ \devptr -> do
    with 0 $ \inoptr -> do
      c_getUniqueFileInfo fd devptr inoptr
      liftM2 (,) (peek devptr) (peek inoptr)
#endif

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

-- -----------------------------------------------------------------------------
-- Standard file descriptors

stdFD :: CInt -> FD
stdFD fd = FD { fdFD = fd,
#if defined(mingw32_HOST_OS)
                fdIsSocket_ = 0
#else
                fdIsNonBlocking = 0
   -- 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]
#endif
                }

stdin, stdout, stderr :: FD
stdin  = stdFD 0
stdout = stdFD 1
stderr = stdFD 2

-- -----------------------------------------------------------------------------
-- Operations on file descriptors

close :: FD -> IO ()
close fd =
  do let closer realFd =
           throwErrnoIfMinus1Retry_ "GHC.IO.FD.close" $
#if defined(mingw32_HOST_OS)
           if fdIsSocket fd then
             c_closesocket (fromIntegral realFd)
           else
#endif
             c_close (fromIntegral realFd)

     -- release the lock *first*, because otherwise if we're preempted
     -- after closing but before releasing, the FD may have been reused.
     -- (#7646)
     release fd

     closeFdWith closer (fromIntegral (fdFD fd))

release :: FD -> IO ()
release fd = do _ <- unlockFile (fdFD fd)
                return ()

#if defined(mingw32_HOST_OS)
foreign import WINDOWS_CCONV unsafe "HsBase.h closesocket"
   c_closesocket :: CInt -> IO CInt
#endif

isSeekable :: FD -> IO Bool
isSeekable fd = do
  t <- devType fd
  return (t == RegularFile || t == RawDevice)

seek :: FD -> SeekMode -> Integer -> IO ()
seek fd mode off = do
  throwErrnoIfMinus1Retry_ "seek" $
     c_lseek (fdFD fd) (fromIntegral off) seektype
 where
    seektype :: CInt
    seektype = case mode of
                   AbsoluteSeek -> sEEK_SET
                   RelativeSeek -> sEEK_CUR
                   SeekFromEnd  -> sEEK_END

tell :: FD -> IO Integer
tell fd =
 fromIntegral `fmap`
   (throwErrnoIfMinus1Retry "hGetPosn" $
      c_lseek (fdFD fd) 0 sEEK_CUR)

getSize :: FD -> IO Integer
getSize fd = fdFileSize (fdFD fd)

setSize :: FD -> Integer -> IO ()
setSize fd size = do
  throwErrnoIf_ (/=0) "GHC.IO.FD.setSize"  $
     c_ftruncate (fdFD fd) (fromIntegral size)

devType :: FD -> IO IODeviceType
devType fd = do (ty,_,_) <- fdStat (fdFD fd); return ty

dup :: FD -> IO FD
dup fd = do
  newfd <- throwErrnoIfMinus1 "GHC.IO.FD.dup" $ c_dup (fdFD fd)
  return fd{ fdFD = newfd }

dup2 :: FD -> FD -> IO FD
dup2 fd fdto = do
  -- Windows' dup2 does not return the new descriptor, unlike Unix
  throwErrnoIfMinus1_ "GHC.IO.FD.dup2" $
    c_dup2 (fdFD fd) (fdFD fdto)
  return fd{ fdFD = fdFD fdto } -- original FD, with the new fdFD

setNonBlockingMode :: FD -> Bool -> IO FD
setNonBlockingMode fd set = do
  setNonBlockingFD (fdFD fd) set
#if defined(mingw32_HOST_OS)
  return fd
#else
  return fd{ fdIsNonBlocking = fromEnum set }
#endif

ready :: FD -> Bool -> Int -> IO Bool
ready fd write msecs = do
  r <- throwErrnoIfMinus1Retry "GHC.IO.FD.ready" $
          fdReady (fdFD fd) (fromIntegral $ fromEnum $ write)
                            (fromIntegral msecs)
#if defined(mingw32_HOST_OS)
                          (fromIntegral $ fromEnum $ fdIsSocket fd)
#else
                          0
#endif
  return (toEnum (fromIntegral r))

foreign import ccall safe "fdReady"
  fdReady :: CInt -> CBool -> Int64 -> CBool -> IO CInt

-- ---------------------------------------------------------------------------
-- Terminal-related stuff

isTerminal :: FD -> IO Bool
isTerminal fd =
#if defined(mingw32_HOST_OS)
    if fdIsSocket fd then return False
                     else is_console (fdFD fd) >>= return.toBool
#else
    c_isatty (fdFD fd) >>= return.toBool
#endif

setEcho :: FD -> Bool -> IO ()
setEcho fd on = System.Posix.Internals.setEcho (fdFD fd) on

getEcho :: FD -> IO Bool
getEcho fd = System.Posix.Internals.getEcho (fdFD fd)

setRaw :: FD -> Bool -> IO ()
setRaw fd raw = System.Posix.Internals.setCooked (fdFD fd) (not raw)

-- -----------------------------------------------------------------------------
-- Reading and Writing

fdRead :: FD -> Ptr Word8 -> Int -> IO Int
fdRead fd ptr bytes
  = do { r <- readRawBufferPtr "GHC.IO.FD.fdRead" fd ptr 0 (fromIntegral bytes)
       ; return (fromIntegral r) }

fdReadNonBlocking :: FD -> Ptr Word8 -> Int -> IO (Maybe Int)
fdReadNonBlocking fd ptr bytes = do
  r <- readRawBufferPtrNoBlock "GHC.IO.FD.fdReadNonBlocking" fd ptr
           0 (fromIntegral bytes)
  case fromIntegral r of
    (-1) -> return (Nothing)
    n    -> return (Just n)

fdWrite :: FD -> Ptr Word8 -> Int -> IO ()
fdWrite fd ptr bytes = do
  res <- writeRawBufferPtr "GHC.IO.FD.fdWrite" fd ptr 0 (fromIntegral bytes)
  let res' = fromIntegral res
  if res' < bytes
     then fdWrite fd (ptr `plusPtr` res') (bytes - res')
     else return ()

-- XXX ToDo: this isn't non-blocking
fdWriteNonBlocking :: FD -> Ptr Word8 -> Int -> IO Int
fdWriteNonBlocking fd ptr bytes = do
  res <- writeRawBufferPtrNoBlock "GHC.IO.FD.fdWriteNonBlocking" fd ptr 0
            (fromIntegral bytes)
  return (fromIntegral res)

-- -----------------------------------------------------------------------------
-- FD operations

-- Low level routines for reading/writing to (raw)buffers:

#if !defined(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

NOTE [2363]:

In the threaded RTS we could just make safe calls to read()/write()
for file descriptors in blocking mode without worrying about blocking
other threads, but the problem with this is that the thread will be
uninterruptible while it is blocked in the foreign call.  See #2363.
So now we always call fdReady() before reading, and if fdReady
indicates that there's no data, we call threadWaitRead.

-}

readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int
readRawBufferPtr loc !fd !buf !off !len
  | isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block
  | otherwise    = do r <- throwErrnoIfMinus1 loc
                                (unsafe_fdReady (fdFD fd) 0 0 0)
                      if r /= 0
                        then read
                        else do threadWaitRead (fromIntegral (fdFD fd)); read
  where
    do_read call = fromIntegral `fmap`
                      throwErrnoIfMinus1RetryMayBlock loc call
                            (threadWaitRead (fromIntegral (fdFD fd)))
    read        = if threaded then safe_read else unsafe_read
    unsafe_read = do_read (c_read (fdFD fd) (buf `plusPtr` off) len)
    safe_read   = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len)

-- return: -1 indicates EOF, >=0 is bytes read
readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int
readRawBufferPtrNoBlock loc !fd !buf !off !len
  | isNonBlocking fd  = unsafe_read -- unsafe is ok, it can't block
  | otherwise    = do r <- unsafe_fdReady (fdFD fd) 0 0 0
                      if r /= 0 then safe_read
                                else return 0
       -- XXX see note [nonblock]
 where
   do_read call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1))
                     case r of
                       (-1) -> return 0
                       0    -> return (-1)
                       n    -> return (fromIntegral n)
   unsafe_read  = do_read (c_read (fdFD fd) (buf `plusPtr` off) len)
   safe_read    = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len)

writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
writeRawBufferPtr loc !fd !buf !off !len
  | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block
  | otherwise   = do r <- unsafe_fdReady (fdFD fd) 1 0 0
                     if r /= 0
                        then write
                        else do threadWaitWrite (fromIntegral (fdFD fd)); write
  where
    do_write call = fromIntegral `fmap`
                      throwErrnoIfMinus1RetryMayBlock loc call
                        (threadWaitWrite (fromIntegral (fdFD fd)))
    write         = if threaded then safe_write else unsafe_write
    unsafe_write  = do_write (c_write (fdFD fd) (buf `plusPtr` off) len)
    safe_write    = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len)

writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
writeRawBufferPtrNoBlock loc !fd !buf !off !len
  | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block
  | otherwise   = do r <- unsafe_fdReady (fdFD fd) 1 0 0
                     if r /= 0 then write
                               else return 0
  where
    do_write call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1))
                       case r of
                         (-1) -> return 0
                         n    -> return (fromIntegral n)
    write         = if threaded then safe_write else unsafe_write
    unsafe_write  = do_write (c_write (fdFD fd) (buf `plusPtr` off) len)
    safe_write    = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len)

isNonBlocking :: FD -> Bool
isNonBlocking fd = fdIsNonBlocking fd /= 0

foreign import ccall unsafe "fdReady"
  unsafe_fdReady :: CInt -> CBool -> Int64 -> CBool -> IO CInt

#else /* mingw32_HOST_OS.... */

readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
readRawBufferPtr loc !fd !buf !off !len
  | threaded  = blockingReadRawBufferPtr loc fd buf off len
  | otherwise = asyncReadRawBufferPtr    loc fd buf off len

writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
writeRawBufferPtr loc !fd !buf !off !len
  | threaded  = blockingWriteRawBufferPtr loc fd buf off len
  | otherwise = asyncWriteRawBufferPtr    loc fd buf off len

readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
readRawBufferPtrNoBlock = readRawBufferPtr

writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
writeRawBufferPtrNoBlock = writeRawBufferPtr

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

asyncReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
asyncReadRawBufferPtr loc !fd !buf !off !len = do
    (l, rc) <- asyncRead (fromIntegral (fdFD fd)) (fdIsSocket_ fd)
                        (fromIntegral len) (buf `plusPtr` off)
    if l == (-1)
      then let sock_errno = c_maperrno_func (fromIntegral rc)
               non_sock_errno = Errno (fromIntegral rc)
               errno = bool non_sock_errno sock_errno (fdIsSocket fd)
           in  ioError (errnoToIOError loc errno Nothing Nothing)
      else return (fromIntegral l)

asyncWriteRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
asyncWriteRawBufferPtr loc !fd !buf !off !len = do
    (l, rc) <- asyncWrite (fromIntegral (fdFD fd)) (fdIsSocket_ fd)
                  (fromIntegral len) (buf `plusPtr` off)
    if l == (-1)
      then let sock_errno = c_maperrno_func (fromIntegral rc)
               non_sock_errno = Errno (fromIntegral rc)
               errno = bool non_sock_errno sock_errno (fdIsSocket fd)
           in  ioError (errnoToIOError loc errno Nothing Nothing)
      else return (fromIntegral l)

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

blockingReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
blockingReadRawBufferPtr loc !fd !buf !off !len
  = throwErrnoIfMinus1Retry loc $ do
        let start_ptr = buf `plusPtr` off
            recv_ret = c_safe_recv (fdFD fd) start_ptr (fromIntegral len) 0
            read_ret = c_safe_read (fdFD fd) start_ptr (fromIntegral len)
        r <- bool read_ret recv_ret (fdIsSocket fd)
        when ((fdIsSocket fd) && (r == -1)) c_maperrno
        return r
      -- We trust read() to give us the correct errno but recv(), as a
      -- Winsock function, doesn't do the errno conversion so if the fd
      -- is for a socket, we do it from GetLastError() ourselves.

blockingWriteRawBufferPtr :: String -> FD -> Ptr Word8-> Int -> CSize -> IO CInt
blockingWriteRawBufferPtr loc !fd !buf !off !len
  = throwErrnoIfMinus1Retry loc $ do
        let start_ptr = buf `plusPtr` off
            send_ret = c_safe_send  (fdFD fd) start_ptr (fromIntegral len) 0
            write_ret = c_safe_write (fdFD fd) start_ptr (fromIntegral len)
        r <- bool write_ret send_ret (fdIsSocket fd)
        when (r == -1) c_maperrno
        return r
      -- We don't trust write() to give us the correct errno, and
      -- instead do the errno conversion from GetLastError()
      -- ourselves. The main reason is that we treat ERROR_NO_DATA
      -- (pipe is closing) as EPIPE, whereas write() returns EINVAL
      -- for this case. We need to detect EPIPE correctly, because it
      -- shouldn't be reported as an error when it happens on stdout.
      -- As for send()'s case, Winsock functions don't do errno
      -- conversion in any case so we have to do it ourselves.
      -- That means we're doing the errno conversion no matter if the
      -- fd is from a socket or not.

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

foreign import WINDOWS_CCONV safe "recv"
   c_safe_recv :: CInt -> Ptr Word8 -> CInt -> CInt{-flags-} -> IO CInt

foreign import WINDOWS_CCONV safe "send"
   c_safe_send :: CInt -> Ptr Word8 -> CInt -> CInt{-flags-} -> IO CInt

#endif

foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool

-- -----------------------------------------------------------------------------
-- utils

#if !defined(mingw32_HOST_OS)
throwErrnoIfMinus1RetryOnBlock  :: String -> IO CSsize -> IO CSsize -> IO CSsize
throwErrnoIfMinus1RetryOnBlock loc f on_block  =
  do
    res <- f
    if (res :: CSsize) == -1
      then do
        err <- getErrno
        if err == eINTR
          then throwErrnoIfMinus1RetryOnBlock loc f on_block
          else if err == eWOULDBLOCK || err == eAGAIN
                 then do on_block
                 else throwErrno loc
      else return res
#endif

-- -----------------------------------------------------------------------------
-- Locking/unlocking

foreign import ccall unsafe "lockFile"
  lockFile :: CInt -> Word64 -> Word64 -> CInt -> IO CInt

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

#if defined(mingw32_HOST_OS)
foreign import ccall unsafe "get_unique_file_info"
  c_getUniqueFileInfo :: CInt -> Ptr Word64 -> Ptr Word64 -> IO ()
#endif