putbuf.hs

{-# LANGUAGE MagicHash #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UnboxedTuples #-}

import GHC.IO.Handle.Internals
import GHC.IO.Exception
import GHC.Ptr
import GHC.IO
import GHC.IO.Handle.Types
import GHC.Exts
import Data.Word
import GHC.IO.Buffer
import GHC.IORef

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

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

          r <- bufWrite h_ (castPtr ptr) count can_block

          case haBufferMode of
            BlockBuffering _ -> pure ()
            _line_or_no_buffering -> flushWriteBuffer h_
          
          pure r

bufWrite ::
     Handle__
  -> Ptr Word8
  -> Int
  -> Bool
  -> IO Int
bufWrite h_@Handle__{..} ptr count can_block =
  seq count $ do
  old_buf@Buffer
    { bufRaw = (old_raw :: RawBuffer Word8)
    , bufR = (w :: Int)
    , bufSize = (size :: Int)
    }
    <- readIORef haByteBuffer
    
  if (count < size && count <= size - w)
    then do
      debugIO ("hPutBuf: copying to buffer, w=" ++ show w)
      pure 0
    else pure 0
  pure 0

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

class Monad m => PrimMonad m where
  type PrimState m

  primitive :: (State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a

primitive_ :: PrimMonad m
  => (State# (PrimState m) -> State# (PrimState m))
  -> m ()
primitive_ f = primitive (\s# ->
  case f s# of
    s'# -> (# s'#, () #))

copyByteArrayToAddr :: (PrimMonad m)
  => Addr# -- ^ destination
  -> ByteArray# -- ^ source array
  -> Int -- ^ offset into source array
  -> Int -- ^ number of bytes to copy
  ->  m ()
copyByteArrayToAddr dst# src# (I# soff#) (I# sz#) =
  primitive_ (copyByteArrayToAddr# src# soff# dst# sz#)