{-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Trustworthy #-}
#endif
module Data.ByteString.Builder.Prim (
BoundedPrim
, emptyB
, (>*<)
, (>$<)
, eitherB
, condB
, primBounded
, primMapListBounded
, primUnfoldrBounded
, primMapByteStringBounded
, primMapLazyByteStringBounded
, FixedPrim
, emptyF
, liftFixedToBounded
, primFixed
, primMapListFixed
, primUnfoldrFixed
, primMapByteStringFixed
, primMapLazyByteStringFixed
, module Data.ByteString.Builder.Prim.Binary
, module Data.ByteString.Builder.Prim.ASCII
, char8
, charUtf8
) where
import Data.ByteString.Builder.Internal
import Data.ByteString.Builder.Prim.Internal.UncheckedShifts
import qualified Data.ByteString as S
import qualified Data.ByteString.Internal as S
import qualified Data.ByteString.Lazy.Internal as L
import Data.Monoid
import Data.List (unfoldr)
import Data.Char (chr, ord)
import Control.Monad ((<=<), unless)
import Data.ByteString.Builder.Prim.Internal hiding (size, sizeBound)
import qualified Data.ByteString.Builder.Prim.Internal as I (size, sizeBound)
import Data.ByteString.Builder.Prim.Binary
import Data.ByteString.Builder.Prim.ASCII
#if MIN_VERSION_base(4,4,0)
#if MIN_VERSION_base(4,7,0)
import Foreign
#else
import Foreign hiding (unsafeForeignPtrToPtr)
#endif
import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
#else
import Foreign
#endif
{-# INLINE primFixed #-}
primFixed :: FixedPrim a -> (a -> Builder)
primFixed = primBounded . toB
{-# INLINE primMapListFixed #-}
primMapListFixed :: FixedPrim a -> ([a] -> Builder)
primMapListFixed = primMapListBounded . toB
{-# INLINE primUnfoldrFixed #-}
primUnfoldrFixed :: FixedPrim b -> (a -> Maybe (b, a)) -> a -> Builder
primUnfoldrFixed = primUnfoldrBounded . toB
{-# INLINE primMapByteStringFixed #-}
primMapByteStringFixed :: FixedPrim Word8 -> (S.ByteString -> Builder)
primMapByteStringFixed = primMapByteStringBounded . toB
{-# INLINE primMapLazyByteStringFixed #-}
primMapLazyByteStringFixed :: FixedPrim Word8 -> (L.ByteString -> Builder)
primMapLazyByteStringFixed = primMapLazyByteStringBounded . toB
{-# INLINE[1] primBounded #-}
primBounded :: BoundedPrim a -> (a -> Builder)
primBounded w x =
ensureFree (I.sizeBound w) `mappend` builder step
where
step k (BufferRange op ope) = do
op' <- runB w x op
let !br' = BufferRange op' ope
k br'
{-# RULES
"append/primBounded" forall w1 w2 x1 x2.
append (primBounded w1 x1) (primBounded w2 x2)
= primBounded (pairB w1 w2) (x1, x2)
"append/primBounded/assoc_r" forall w1 w2 x1 x2 b.
append (primBounded w1 x1) (append (primBounded w2 x2) b)
= append (primBounded (pairB w1 w2) (x1, x2)) b
"append/primBounded/assoc_l" forall w1 w2 x1 x2 b.
append (append b (primBounded w1 x1)) (primBounded w2 x2)
= append b (primBounded (pairB w1 w2) (x1, x2))
#-}
{-# INLINE primMapListBounded #-}
primMapListBounded :: BoundedPrim a -> [a] -> Builder
primMapListBounded w xs0 =
builder $ step xs0
where
step xs1 k (BufferRange op0 ope0) =
go xs1 op0
where
go [] !op = k (BufferRange op ope0)
go xs@(x':xs') !op
| op `plusPtr` bound <= ope0 = runB w x' op >>= go xs'
| otherwise =
return $ bufferFull bound op (step xs k)
bound = I.sizeBound w
{-# INLINE primUnfoldrBounded #-}
primUnfoldrBounded :: BoundedPrim b -> (a -> Maybe (b, a)) -> a -> Builder
primUnfoldrBounded w f x0 =
builder $ fillWith x0
where
fillWith x k !(BufferRange op0 ope0) =
go (f x) op0
where
go !Nothing !op = do let !br' = BufferRange op ope0
k br'
go !(Just (y, x')) !op
| op `plusPtr` bound <= ope0 = runB w y op >>= go (f x')
| otherwise = return $ bufferFull bound op $
\(BufferRange opNew opeNew) -> do
!opNew' <- runB w y opNew
fillWith x' k (BufferRange opNew' opeNew)
bound = I.sizeBound w
{-# INLINE primMapByteStringBounded #-}
primMapByteStringBounded :: BoundedPrim Word8 -> S.ByteString -> Builder
primMapByteStringBounded w =
\bs -> builder $ step bs
where
bound = I.sizeBound w
step (S.PS ifp ioff isize) !k =
goBS (unsafeForeignPtrToPtr ifp `plusPtr` ioff)
where
!ipe = unsafeForeignPtrToPtr ifp `plusPtr` (ioff + isize)
goBS !ip0 !br@(BufferRange op0 ope)
| ip0 >= ipe = do
touchForeignPtr ifp
k br
| op0 `plusPtr` bound < ope =
goPartial (ip0 `plusPtr` min outRemaining inpRemaining)
| otherwise = return $ bufferFull bound op0 (goBS ip0)
where
outRemaining = (ope `minusPtr` op0) `div` bound
inpRemaining = ipe `minusPtr` ip0
goPartial !ipeTmp = go ip0 op0
where
go !ip !op
| ip < ipeTmp = do
x <- peek ip
op' <- runB w x op
go (ip `plusPtr` 1) op'
| otherwise =
goBS ip (BufferRange op ope)
{-# INLINE primMapLazyByteStringBounded #-}
primMapLazyByteStringBounded :: BoundedPrim Word8 -> L.ByteString -> Builder
primMapLazyByteStringBounded w =
L.foldrChunks (\x b -> primMapByteStringBounded w x `mappend` b) mempty
{-# INLINE char8 #-}
char8 :: FixedPrim Char
char8 = (fromIntegral . ord) >$< word8
{-# INLINE charUtf8 #-}
charUtf8 :: BoundedPrim Char
charUtf8 = boudedPrim 4 (encodeCharUtf8 f1 f2 f3 f4)
where
pokeN n io op = io op >> return (op `plusPtr` n)
f1 x1 = pokeN 1 $ \op -> do pokeByteOff op 0 x1
f2 x1 x2 = pokeN 2 $ \op -> do pokeByteOff op 0 x1
pokeByteOff op 1 x2
f3 x1 x2 x3 = pokeN 3 $ \op -> do pokeByteOff op 0 x1
pokeByteOff op 1 x2
pokeByteOff op 2 x3
f4 x1 x2 x3 x4 = pokeN 4 $ \op -> do pokeByteOff op 0 x1
pokeByteOff op 1 x2
pokeByteOff op 2 x3
pokeByteOff op 3 x4
{-# INLINE encodeCharUtf8 #-}
encodeCharUtf8 :: (Word8 -> a)
-> (Word8 -> Word8 -> a)
-> (Word8 -> Word8 -> Word8 -> a)
-> (Word8 -> Word8 -> Word8 -> Word8 -> a)
-> Char
-> a
encodeCharUtf8 f1 f2 f3 f4 c = case ord c of
x | x <= 0x7F -> f1 $ fromIntegral x
| x <= 0x07FF ->
let x1 = fromIntegral $ (x `shiftR` 6) + 0xC0
x2 = fromIntegral $ (x .&. 0x3F) + 0x80
in f2 x1 x2
| x <= 0xFFFF ->
let x1 = fromIntegral $ (x `shiftR` 12) + 0xE0
x2 = fromIntegral $ ((x `shiftR` 6) .&. 0x3F) + 0x80
x3 = fromIntegral $ (x .&. 0x3F) + 0x80
in f3 x1 x2 x3
| otherwise ->
let x1 = fromIntegral $ (x `shiftR` 18) + 0xF0
x2 = fromIntegral $ ((x `shiftR` 12) .&. 0x3F) + 0x80
x3 = fromIntegral $ ((x `shiftR` 6) .&. 0x3F) + 0x80
x4 = fromIntegral $ (x .&. 0x3F) + 0x80
in f4 x1 x2 x3 x4