{-# LANGUAGE BangPatterns #-}
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)
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
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
forall a. Ptr a -> Word8 -> Int -> IO ()
fillBytes Ptr Word8
buf Word8
oc Int
buf_size
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 ()