    {-# LANGUAGE BangPatterns #-}

    -----------------------------------------------------------------------------
    --
    -- Fast write-buffered Handles
    --
    -- (c) The University of Glasgow 2005-2006
    --
    -- This is a simple abstraction over Handles that offers very fast write
    -- buffering, but without the thread safety that Handles provide.  It's used
    -- to save time in GHC.Utils.Ppr.printDoc.
    --
    -----------------------------------------------------------------------------

    module GHC.Utils.BufHandle (
            BufHandle(..),
            newBufHandle,
            bPutChar,
            bPutStr,
            bPutFS,
            bPutFZS,
            bPutPtrString,
            bPutReplicate,
            bFlush,
      ) where

    import GHC.Prelude

    import GHC.Data.FastString
    import GHC.Data.FastMutInt

    import Control.Monad    ( when )
    import Data.ByteString (ByteString)
    import qualified Data.ByteString.Unsafe as BS
    import Data.Char        ( ord )
    import Foreign
    import Foreign.C.String
    import System.IO

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

    data BufHandle = BufHandle {-#UNPACK#-}!(Ptr Word8)
                               {-#UNPACK#-}!FastMutInt
                               Handle

    newBufHandle :: Handle -> IO BufHandle
    newBufHandle :: Handle -> IO BufHandle
    newBufHandle Handle
    hdl = do
      Ptr Word8
    ptr <- forall a. Int -> IO (Ptr a)
    mallocBytes Int
    buf_size
      FastMutInt
    r <- Int -> IO FastMutInt
    newFastMutInt Int
    0
      forall (m :: * -> *) a. Monad m => a -> m a
    return (Ptr Word8 -> FastMutInt -> Handle -> BufHandle
    BufHandle Ptr Word8
    ptr FastMutInt
    r Handle
    hdl)

    buf_size :: Int
    buf_size :: Int
    buf_size = Int
    8192

    bPutChar :: BufHandle -> Char -> IO ()
    bPutChar :: BufHandle -> Char -> IO ()
    bPutChar b :: BufHandle
    b@(BufHandle Ptr Word8
    buf FastMutInt
    r Handle
    hdl) !Char
    c = do
      Int
    i <- FastMutInt -> IO Int
    readFastMutInt FastMutInt
    r
      if (Int
    i forall a. Ord a => a -> a -> Bool
    >= Int
    buf_size)
            then do forall a. Handle -> Ptr a -> Int -> IO ()
    hPutBuf Handle
    hdl Ptr Word8
    buf Int
    buf_size
                    FastMutInt -> Int -> IO ()
    writeFastMutInt FastMutInt
    r Int
    0
                    BufHandle -> Char -> IO ()
    bPutChar BufHandle
    b Char
    c
            else do forall a. Storable a => Ptr a -> Int -> a -> IO ()
    pokeElemOff Ptr Word8
    buf Int
    i (forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Char -> Int
    ord Char
    c) :: Word8)
                    FastMutInt -> Int -> IO ()
    writeFastMutInt FastMutInt
    r (Int
    iforall a. Num a => a -> a -> a
    +Int
    1)

    bPutStr :: BufHandle -> String -> IO ()
    bPutStr :: BufHandle -> String -> IO ()
    bPutStr (BufHandle Ptr Word8
    buf FastMutInt
    r Handle
    hdl) !String
    str = do
      Int
    i <- FastMutInt -> IO Int
    readFastMutInt FastMutInt
    r
      String -> Int -> IO ()
    loop String
    str Int
    i
      where loop :: String -> Int -> IO ()
    loop String
    "" !Int
    i = do FastMutInt -> Int -> IO ()
    writeFastMutInt FastMutInt
    r Int
    i; forall (m :: * -> *) a. Monad m => a -> m a
    return ()
            loop (Char
    c:String
    cs) !Int
    i
               | Int
    i forall a. Ord a => a -> a -> Bool
    >= Int
    buf_size = do
                    forall a. Handle -> Ptr a -> Int -> IO ()
    hPutBuf Handle
    hdl Ptr Word8
    buf Int
    buf_size
                    String -> Int -> IO ()
    loop (Char
    cforall a. a -> [a] -> [a]
    :String
    cs) Int
    0
               | Bool
    otherwise = do
                    forall a. Storable a => Ptr a -> Int -> a -> IO ()
    pokeElemOff Ptr Word8
    buf Int
    i (forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Char -> Int
    ord Char
    c))
                    String -> Int -> IO ()
    loop String
    cs (Int
    iforall a. Num a => a -> a -> a
    +Int
    1)

    bPutFS :: BufHandle -> FastString -> IO ()
    bPutFS :: BufHandle -> FastString -> IO ()
    bPutFS BufHandle
    b FastString
    fs = BufHandle -> ByteString -> IO ()
    bPutBS BufHandle
    b forall a b. (a -> b) -> a -> b
    $ FastString -> ByteString
    bytesFS FastString
    fs

    bPutFZS :: BufHandle -> FastZString -> IO ()
    bPutFZS :: BufHandle -> FastZString -> IO ()
    bPutFZS BufHandle
    b FastZString
    fs = BufHandle -> ByteString -> IO ()
    bPutBS BufHandle
    b forall a b. (a -> b) -> a -> b
    $ FastZString -> ByteString
    fastZStringToByteString FastZString
    fs

    bPutBS :: BufHandle -> ByteString -> IO ()
    bPutBS :: BufHandle -> ByteString -> IO ()
    bPutBS BufHandle
    b ByteString
    bs = forall a. ByteString -> (CStringLen -> IO a) -> IO a
    BS.unsafeUseAsCStringLen ByteString
    bs forall a b. (a -> b) -> a -> b
    $ BufHandle -> CStringLen -> IO ()
    bPutCStringLen BufHandle
    b

    bPutCStringLen :: BufHandle -> CStringLen -> IO ()
    bPutCStringLen :: BufHandle -> CStringLen -> IO ()
    bPutCStringLen b :: BufHandle
    b@(BufHandle Ptr Word8
    buf FastMutInt
    r Handle
    hdl) cstr :: CStringLen
    cstr@(Ptr CChar
    ptr, Int
    len) = do
      Int
    i <- FastMutInt -> IO Int
    readFastMutInt FastMutInt
    r
      if (Int
    i forall a. Num a => a -> a -> a
    + Int
    len) forall a. Ord a => a -> a -> Bool
    >= Int
    buf_size
            then do forall a. Handle -> Ptr a -> Int -> IO ()
    hPutBuf Handle
    hdl Ptr Word8
    buf Int
    i
                    FastMutInt -> Int -> IO ()
    writeFastMutInt FastMutInt
    r Int
    0
                    if (Int
    len forall a. Ord a => a -> a -> Bool
    >= Int
    buf_size)
                        then forall a. Handle -> Ptr a -> Int -> IO ()
    hPutBuf Handle
    hdl Ptr CChar
    ptr Int
    len
                        else BufHandle -> CStringLen -> IO ()
    bPutCStringLen BufHandle
    b CStringLen
    cstr
            else do
                    forall a. Ptr a -> Ptr a -> Int -> IO ()
    copyBytes (Ptr Word8
    buf forall a b. Ptr a -> Int -> Ptr b
    `plusPtr` Int
    i) Ptr CChar
    ptr Int
    len
                    FastMutInt -> Int -> IO ()
    writeFastMutInt FastMutInt
    r (Int
    i forall a. Num a => a -> a -> a
    + Int
    len)

    bPutPtrString :: BufHandle -> PtrString -> IO ()
    bPutPtrString :: BufHandle -> PtrString -> IO ()
    bPutPtrString b :: BufHandle
    b@(BufHandle Ptr Word8
    buf FastMutInt
    r Handle
    hdl) l :: PtrString
    l@(PtrString Ptr Word8
    a Int
    len) = PtrString
    l seq :: forall a b. a -> b -> b
    `seq` do
      Int
    i <- FastMutInt -> IO Int
    readFastMutInt FastMutInt
    r
      if (Int
    iforall a. Num a => a -> a -> a
    +Int
    len) forall a. Ord a => a -> a -> Bool
    >= Int
    buf_size
            then do forall a. Handle -> Ptr a -> Int -> IO ()
    hPutBuf Handle
    hdl Ptr Word8
    buf Int
    i
                    FastMutInt -> Int -> IO ()
    writeFastMutInt FastMutInt
    r Int
    0
                    if (Int
    len forall a. Ord a => a -> a -> Bool
    >= Int
    buf_size)
                        then forall a. Handle -> Ptr a -> Int -> IO ()
    hPutBuf Handle
    hdl Ptr Word8
    a Int
    len
                        else BufHandle -> PtrString -> IO ()
    bPutPtrString BufHandle
    b PtrString
    l
            else do
                    forall a. Ptr a -> Ptr a -> Int -> IO ()
    copyBytes (Ptr Word8
    buf forall a b. Ptr a -> Int -> Ptr b
    `plusPtr` Int
    i) Ptr Word8
    a Int
    len
                    FastMutInt -> Int -> IO ()
    writeFastMutInt FastMutInt
    r (Int
    iforall a. Num a => a -> a -> a
    +Int
    len)

    -- | Replicate an 8-bit character
    bPutReplicate :: BufHandle -> Int -> Char -> IO ()
    bPutReplicate :: BufHandle -> Int -> Char -> IO ()
    bPutReplicate (BufHandle Ptr Word8
    buf FastMutInt
    r Handle
    hdl) Int
    len Char
    c = do
      Int
    i <- FastMutInt -> IO Int
    readFastMutInt FastMutInt
    r
      let oc :: Word8
    oc = forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Char -> Int
    ord Char
    c)
      if (Int
    iforall a. Num a => a -> a -> a
    +Int
    len) forall a. Ord a => a -> a -> Bool
    < Int
    buf_size
        then do
          forall a. Ptr a -> Word8 -> Int -> IO ()
    fillBytes (Ptr Word8
    buf forall a b. Ptr a -> Int -> Ptr b
    `plusPtr` Int
    i) Word8
    oc Int
    len
          FastMutInt -> Int -> IO ()
    writeFastMutInt FastMutInt
    r (Int
    iforall a. Num a => a -> a -> a
    +Int
    len)
        else do
          -- flush the current buffer
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Int
    i forall a. Eq a => a -> a -> Bool
    /= Int
    0) forall a b. (a -> b) -> a -> b
    $ forall a. Handle -> Ptr a -> Int -> IO ()
    hPutBuf Handle
    hdl Ptr Word8
    buf Int
    i
          if (Int
    len forall a. Ord a => a -> a -> Bool
    < Int
    buf_size)
            then do
              forall a. Ptr a -> Word8 -> Int -> IO ()
    fillBytes Ptr Word8
    buf Word8
    oc Int
    len
              FastMutInt -> Int -> IO ()
    writeFastMutInt FastMutInt
    r Int
    len
            else do
              -- fill a full buffer
              forall a. Ptr a -> Word8 -> Int -> IO ()
    fillBytes Ptr Word8
    buf Word8
    oc Int
    buf_size
              -- flush it as many times as necessary
              let go :: Int -> IO ()
    go Int
    n | Int
    n forall a. Ord a => a -> a -> Bool
    >= Int
    buf_size = do
                                           forall a. Handle -> Ptr a -> Int -> IO ()
    hPutBuf Handle
    hdl Ptr Word8
    buf Int
    buf_size
                                           Int -> IO ()
    go (Int
    nforall a. Num a => a -> a -> a
    -Int
    buf_size)
                       | Bool
    otherwise     = FastMutInt -> Int -> IO ()
    writeFastMutInt FastMutInt
    r Int
    n
              Int -> IO ()
    go Int
    len

    bFlush :: BufHandle -> IO ()
    bFlush :: BufHandle -> IO ()
    bFlush (BufHandle Ptr Word8
    buf FastMutInt
    r Handle
    hdl) = do
      Int
    i <- FastMutInt -> IO Int
    readFastMutInt FastMutInt
    r
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Int
    i forall a. Ord a => a -> a -> Bool
    > Int
    0) forall a b. (a -> b) -> a -> b
    $ forall a. Handle -> Ptr a -> Int -> IO ()
    hPutBuf Handle
    hdl Ptr Word8
    buf Int
    i
      forall a. Ptr a -> IO ()
    free Ptr Word8
    buf
      forall (m :: * -> *) a. Monad m => a -> m a
    return ()