{-# LANGUAGE MagicHash, CPP, UnboxedTuples #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE LambdaCase #-}
module Mason.Builder
( Builder
, BuilderFor
, Buildable
, toStrictByteString
, toLazyByteString
, hPutBuilderLen
, hPutBuilder
, sendBuilder
, flush
, byteString
, lazyByteString
, shortByteString
, textUtf8
, encodeUtf8Builder
, encodeUtf8BuilderEscaped
, char7
, string7
, char8
, string8
, charUtf8
, stringUtf8
, storable
, int8
, word8
, int16LE
, int32LE
, int64LE
, word16LE
, word32LE
, word64LE
, floatLE
, doubleLE
, int16BE
, int32BE
, int64BE
, word16BE
, word32BE
, word64BE
, floatBE
, doubleBE
, floatDec
, doubleDec
, doubleSI
, doubleExp
, doubleFixed
, word8Dec
, word16Dec
, word32Dec
, word64Dec
, wordDec
, int8Dec
, int16Dec
, int32Dec
, int64Dec
, intDec
, integerDec
, word8Hex
, word16Hex
, word32Hex
, word64Hex
, wordHex
, int8HexFixed
, int16HexFixed
, int32HexFixed
, int64HexFixed
, word8HexFixed
, word16HexFixed
, word32HexFixed
, word64HexFixed
, floatHexFixed
, doubleHexFixed
, byteStringHex
, lazyByteStringHex
, intVLQ
, intVLQBP
, wordVLQ
, wordVLQBP
, prefixVarInt
, prefixVarIntBP
, paddedBoundedPrim
, zeroPaddedBoundedPrim
, primFixed
, primBounded
, lengthPrefixedWithin
) where
import Control.Monad
import qualified Data.Array as A
import Data.Bits
import Data.Word
import Data.Int
import qualified Data.Text as T
import Foreign.C.Types
import Foreign.Ptr (Ptr, plusPtr, castPtr)
import Foreign.Storable
import qualified Data.ByteString as B
import qualified Data.ByteString.Internal as B
import qualified Data.ByteString.Lazy as BL
import Mason.Builder.Internal as B
import qualified Data.ByteString.Builder.Prim as P
import qualified Data.ByteString.Builder.Prim.Internal as P
import GHC.Integer.GMP.Internals
import GHC.Types (Int(..))
import System.IO (Handle)
hPutBuilder :: Handle -> BuilderFor PutEnv -> IO ()
hPutBuilder h b = void $ hPutBuilderLen h b
{-# INLINE hPutBuilder #-}
lazyByteString :: BL.ByteString -> Builder
lazyByteString = foldMap byteString . BL.toChunks
{-# INLINE lazyByteString #-}
{-# INLINE int8 #-}
int8 :: Int8 -> Builder
int8 = B.primFixed P.int8
{-# INLINE word8 #-}
word8 :: Word8 -> Builder
word8 = B.primFixed P.word8
{-# INLINE int16LE #-}
int16LE :: Int16 -> Builder
int16LE = B.primFixed P.int16LE
{-# INLINE int32LE #-}
int32LE :: Int32 -> Builder
int32LE = B.primFixed P.int32LE
{-# INLINE int64LE #-}
int64LE :: Int64 -> Builder
int64LE = B.primFixed P.int64LE
{-# INLINE word16LE #-}
word16LE :: Word16 -> Builder
word16LE = B.primFixed P.word16LE
{-# INLINE word32LE #-}
word32LE :: Word32 -> Builder
word32LE = B.primFixed P.word32LE
{-# INLINE word64LE #-}
word64LE :: Word64 -> Builder
word64LE = B.primFixed P.word64LE
{-# INLINE floatLE #-}
floatLE :: Float -> Builder
floatLE = B.primFixed P.floatLE
{-# INLINE doubleLE #-}
doubleLE :: Double -> Builder
doubleLE = B.primFixed P.doubleLE
{-# INLINE int16BE #-}
int16BE :: Int16 -> Builder
int16BE = B.primFixed P.int16BE
{-# INLINE int32BE #-}
int32BE :: Int32 -> Builder
int32BE = B.primFixed P.int32BE
{-# INLINE int64BE #-}
int64BE :: Int64 -> Builder
int64BE = B.primFixed P.int64BE
{-# INLINE word16BE #-}
word16BE :: Word16 -> Builder
word16BE = B.primFixed P.word16BE
{-# INLINE word32BE #-}
word32BE :: Word32 -> Builder
word32BE = B.primFixed P.word32BE
{-# INLINE word64BE #-}
word64BE :: Word64 -> Builder
word64BE = B.primFixed P.word64BE
{-# INLINE floatBE #-}
floatBE :: Float -> Builder
floatBE = B.primFixed P.floatBE
{-# INLINE doubleBE #-}
doubleBE :: Double -> Builder
doubleBE = B.primFixed P.doubleBE
{-# INLINE char7 #-}
char7 :: Char -> Builder
char7 = B.primFixed P.char7
{-# INLINE string7 #-}
string7 :: String -> Builder
string7 = B.primMapListFixed P.char7
{-# INLINE char8 #-}
char8 :: Char -> Builder
char8 = B.primFixed P.char8
{-# INLINE string8 #-}
string8 :: String -> Builder
string8 = B.primMapListFixed P.char8
{-# INLINE charUtf8 #-}
charUtf8 :: Char -> Builder
charUtf8 = B.primBounded P.charUtf8
encodeUtf8Builder :: T.Text -> Builder
encodeUtf8Builder = textUtf8
{-# INLINE encodeUtf8Builder #-}
textUtf8 :: T.Text -> Builder
textUtf8 = B.encodeUtf8BuilderEscaped (P.liftFixedToBounded P.word8)
{-# INLINE textUtf8 #-}
{-# INLINE word8Dec #-}
word8Dec :: Word8 -> Builder
word8Dec = B.primBounded P.word8Dec
{-# INLINE word16Dec #-}
word16Dec :: Word16 -> Builder
word16Dec = B.primBounded P.word16Dec
{-# INLINE word32Dec #-}
word32Dec :: Word32 -> Builder
word32Dec = B.primBounded P.word32Dec
{-# INLINE word64Dec #-}
word64Dec :: Word64 -> Builder
word64Dec = B.primBounded P.word64Dec
{-# INLINE wordDec #-}
wordDec :: Word -> Builder
wordDec = B.primBounded P.wordDec
{-# INLINE floatDec #-}
floatDec :: Float -> Builder
floatDec = string7 . show
wrapDoubleDec :: (Double -> Builder) -> Double -> Builder
wrapDoubleDec k x
| isNaN x = string7 "NaN"
| isInfinite x = if x < 0 then string7 "-Infinity" else string7 "Infinity"
| isNegativeZero x = char7 '-' <> k 0.0
| x < 0 = char7 '-' <> k (-x)
| otherwise = k x
{-# INLINE wrapDoubleDec #-}
{-# INLINE doubleDec #-}
doubleDec :: Double -> Builder
doubleDec = wrapDoubleDec $ \case
0 -> string7 "0.0"
x -> grisu x
where
grisu v = withPtr 24 $ \ptr -> do
n <- dtoa_grisu3 v ptr
return $ plusPtr ptr (fromIntegral n)
foreign import ccall unsafe "static dtoa_grisu3"
dtoa_grisu3 :: Double -> Ptr Word8 -> IO CInt
doubleSI :: Int
-> Double
-> Builder
doubleSI prec | prec < 3 = error "Mason.Builder.doubleSI: precision less than 3"
doubleSI prec = wrapDoubleDec $ \case
0 -> zeroes prec
val -> Builder $ \env buf -> withGrisu3Rounded prec val $ \ptr len e -> do
let (pindex, dp) = divMod (e - 1) 3
print (dp, prec, len)
let mantissa
| dp + 1 == prec = withPtr (prec + dp - 2) $ \dst -> do
_ <- B.memset dst 48 $ fromIntegral (prec + dp - 2)
B.memcpy dst ptr $ min len prec
return $ dst `plusPtr` (prec + dp - 2)
| otherwise = withPtr (prec + 1) $ \dst -> do
_ <- B.memset dst 48 $ fromIntegral (prec + 1)
B.memcpy dst ptr $ min len $ dp + 1
pokeElemOff dst (dp + 1) 46
B.memcpy (dst `plusPtr` (dp + 2)) (ptr `plusPtr` (dp + 1)) $ max 0 $ len - dp - 1
return $ dst `plusPtr` (prec + 1)
let prefix
| pindex == 0 = mempty
| pindex > 8 || pindex < (-8) = char7 'e' <> intDec (3 * pindex)
| otherwise = charUtf8 (prefices A.! pindex)
unBuilder (mantissa <> prefix) env buf
where
prefices = A.listArray (-8,8) "yzafpnμm\NULkMGTPEZY"
zeroes :: Int -> Builder
zeroes n = withPtr (n + 1) $ \dst -> do
_ <- B.memset dst 48 $ fromIntegral $ n + 1
pokeElemOff dst 1 46
return $ dst `plusPtr` (n + 1)
doubleExp :: Int
-> Double
-> Builder
doubleExp prec | prec < 1 = error "Mason.Builder.doubleFixed: precision too small"
doubleExp prec = wrapDoubleDec $ \case
0 -> zeroes prec <> string7 "e0"
val -> Builder $ \env buf -> withGrisu3Rounded prec val $ \ptr len dp -> do
let len' = 1 + prec
firstDigit <- peek ptr
unBuilder (withPtr len' (\dst -> do
_ <- B.memset dst 48 $ fromIntegral len'
poke dst firstDigit
poke (dst `plusPtr` 1) (46 :: Word8)
B.memcpy (dst `plusPtr` 2) (ptr `plusPtr` 1) (min (len - 1) len')
return (dst `plusPtr` len'))
<> char7 'e' <> intDec (dp - 1)) env buf
doubleFixed :: Int
-> Double
-> Builder
doubleFixed 0 = intDec . round
doubleFixed prec | prec < 0 = error "Mason.Builder.doubleFixed: negative precision"
doubleFixed prec = wrapDoubleDec $ \case
0 -> zeroes (prec + 1)
val -> Builder $ \env buf -> withGrisu3 val (unBuilder (doubleDec val) env buf) $ \ptr0 len e0 -> do
bump <- roundDigit (prec + e0) len ptr0
let dp
| bump = e0 + 1
| otherwise = e0
let ptr
| bump = ptr0
| otherwise = ptr0 `plusPtr` 1
let len' = 1 + prec + max 1 dp
unBuilder (withPtr len' $ \dst -> do
_ <- B.memset dst 48 $ fromIntegral len'
if dp >= 1
then do
B.memcpy dst ptr $ min len dp
pokeElemOff dst dp 46
B.memcpy (dst `plusPtr` (dp + 1)) (ptr `plusPtr` dp) $ max 0 (len - dp)
else do
pokeElemOff dst 1 46
B.memcpy (dst `plusPtr` (2 - dp)) ptr len
return $ dst `plusPtr` len'
) env buf
{-# INLINE int8Dec #-}
int8Dec :: Int8 -> Builder
int8Dec = B.primBounded P.int8Dec
{-# INLINE int16Dec #-}
int16Dec :: Int16 -> Builder
int16Dec = B.primBounded P.int16Dec
{-# INLINE int32Dec #-}
int32Dec :: Int32 -> Builder
int32Dec = B.primBounded P.int32Dec
{-# INLINE int64Dec #-}
int64Dec :: Int64 -> Builder
int64Dec = B.primBounded P.int64Dec
{-# INLINE intDec #-}
intDec :: Int -> Builder
intDec = B.primBounded P.intDec
{-# INLINE word8Hex #-}
word8Hex :: Word8 -> Builder
word8Hex = B.primBounded P.word8Hex
{-# INLINE word16Hex #-}
word16Hex :: Word16 -> Builder
word16Hex = B.primBounded P.word16Hex
{-# INLINE word32Hex #-}
word32Hex :: Word32 -> Builder
word32Hex = B.primBounded P.word32Hex
{-# INLINE word64Hex #-}
word64Hex :: Word64 -> Builder
word64Hex = B.primBounded P.word64Hex
{-# INLINE wordHex #-}
wordHex :: Word -> Builder
wordHex = B.primBounded P.wordHex
{-# INLINE int8HexFixed #-}
int8HexFixed :: Int8 -> Builder
int8HexFixed = B.primFixed P.int8HexFixed
{-# INLINE int16HexFixed #-}
int16HexFixed :: Int16 -> Builder
int16HexFixed = B.primFixed P.int16HexFixed
{-# INLINE int32HexFixed #-}
int32HexFixed :: Int32 -> Builder
int32HexFixed = B.primFixed P.int32HexFixed
{-# INLINE int64HexFixed #-}
int64HexFixed :: Int64 -> Builder
int64HexFixed = B.primFixed P.int64HexFixed
{-# INLINE word8HexFixed #-}
word8HexFixed :: Word8 -> Builder
word8HexFixed = B.primFixed P.word8HexFixed
{-# INLINE word16HexFixed #-}
word16HexFixed :: Word16 -> Builder
word16HexFixed = B.primFixed P.word16HexFixed
{-# INLINE word32HexFixed #-}
word32HexFixed :: Word32 -> Builder
word32HexFixed = B.primFixed P.word32HexFixed
{-# INLINE word64HexFixed #-}
word64HexFixed :: Word64 -> Builder
word64HexFixed = B.primFixed P.word64HexFixed
{-# INLINE floatHexFixed #-}
floatHexFixed :: Float -> Builder
floatHexFixed = B.primFixed P.floatHexFixed
{-# INLINE doubleHexFixed #-}
doubleHexFixed :: Double -> Builder
doubleHexFixed = B.primFixed P.doubleHexFixed
{-# NOINLINE byteStringHex #-}
byteStringHex :: B.ByteString -> Builder
byteStringHex = B.primMapByteStringFixed P.word8HexFixed
{-# NOINLINE lazyByteStringHex #-}
lazyByteStringHex :: BL.ByteString -> Builder
lazyByteStringHex = B.primMapLazyByteStringFixed P.word8HexFixed
#define PAIR(a,b) (# a,b #)
{-# INLINE caseWordSize_32_64 #-}
caseWordSize_32_64 :: a
-> a
-> a
caseWordSize_32_64 f32 f64 =
#if MIN_VERSION_base(4,7,0)
case finiteBitSize (undefined :: Word) of
#else
case bitSize (undefined :: Word) of
#endif
32 -> f32
64 -> f64
s -> error $ "caseWordSize_32_64: unsupported Word bit-size " ++ show s
maxPow10 :: Integer
maxPow10 = toInteger $ (10 :: Int) ^ caseWordSize_32_64 (9 :: Int) 18
integerDec :: Integer -> Builder
integerDec (S# i#) = intDec (I# i#)
integerDec i
| i < 0 = B.primFixed P.char8 '-' `mappend` go (-i)
| otherwise = go ( i)
where
errImpossible fun =
error $ "integerDec: " ++ fun ++ ": the impossible happened."
go :: Integer -> Builder
go n | n < maxPow10 = intDec (fromInteger n)
| otherwise =
case putH (splitf (maxPow10 * maxPow10) n) of
(x:xs) -> intDec x `mappend` B.primMapListBounded intDecPadded xs
[] -> errImpossible "integerDec: go"
splitf :: Integer -> Integer -> [Integer]
splitf pow10 n0
| pow10 > n0 = [n0]
| otherwise = splith (splitf (pow10 * pow10) n0)
where
splith [] = errImpossible "splith"
splith (n:ns) =
case n `quotRemInteger` pow10 of
PAIR(q,r) | q > 0 -> q : r : splitb ns
| otherwise -> r : splitb ns
splitb [] = []
splitb (n:ns) = case n `quotRemInteger` pow10 of
PAIR(q,r) -> q : r : splitb ns
putH :: [Integer] -> [Int]
putH [] = errImpossible "putH"
putH (n:ns) = case n `quotRemInteger` maxPow10 of
PAIR(x,y)
| q > 0 -> q : r : putB ns
| otherwise -> r : putB ns
where q = fromInteger x
r = fromInteger y
putB :: [Integer] -> [Int]
putB [] = []
putB (n:ns) = case n `quotRemInteger` maxPow10 of
PAIR(q,r) -> fromInteger q : fromInteger r : putB ns
foreign import ccall unsafe "static _hs_bytestring_int_dec_padded9"
c_int_dec_padded9 :: CInt -> Ptr Word8 -> IO ()
foreign import ccall unsafe "static _hs_bytestring_long_long_int_dec_padded18"
c_long_long_int_dec_padded18 :: CLLong -> Ptr Word8 -> IO ()
{-# INLINE intDecPadded #-}
intDecPadded :: P.BoundedPrim Int
intDecPadded = P.liftFixedToBounded $ caseWordSize_32_64
(P.fixedPrim 9 $ c_int_dec_padded9 . fromIntegral)
(P.fixedPrim 18 $ c_long_long_int_dec_padded18 . fromIntegral)
intVLQ :: Int -> Builder
intVLQ = primBounded intVLQBP
{-# INLINE intVLQ #-}
intVLQBP :: P.BoundedPrim Int
intVLQBP = P.boudedPrim 10 writeIntFinite
{-# INLINE CONLIKE intVLQBP #-}
wordVLQ :: Word -> Builder
wordVLQ = primBounded wordVLQBP
wordVLQBP :: P.BoundedPrim Word
wordVLQBP = P.boudedPrim 10 (writeUnsignedFinite pure)
writeWord8 :: Word8 -> Ptr Word8 -> IO (Ptr Word8)
writeWord8 w p = do
poke p w
return $! plusPtr p 1
writeIntFinite :: Int -> Ptr Word8 -> IO (Ptr Word8)
writeIntFinite n
| n < 0 = case negate n of
n'
| n' < 0x40 -> writeWord8 (fromIntegral n' `setBit` 6)
| otherwise ->
writeWord8 (0xc0 .|. fromIntegral n') >=>
writeUnsignedFinite pure (unsafeShiftR n' 6)
| n < 0x40 = writeWord8 (fromIntegral n)
| otherwise = writeWord8 (fromIntegral n `setBit` 7 `clearBit` 6) >=>
writeUnsignedFinite pure (unsafeShiftR n 6)
{-# INLINE writeIntFinite #-}
writeUnsignedFinite :: (Bits a, Integral a) => (Ptr Word8 -> IO r) -> a -> Ptr Word8 -> IO r
writeUnsignedFinite k = go
where
go m
| m < 0x80 = writeWord8 (fromIntegral m) >=> k
| otherwise = writeWord8 (setBit (fromIntegral m) 7) >=> go (unsafeShiftR m 7)
{-# INLINE writeUnsignedFinite #-}
prefixVarInt :: Word -> Builder
prefixVarInt = primBounded prefixVarIntBP
prefixVarIntBP :: P.BoundedPrim Word
prefixVarIntBP = P.boudedPrim 9 $ \x ptr0 -> do
let bits = 64 - countLeadingZeros (x .|. 1)
if bits > 56
then do
poke ptr0 0
poke (castPtr ptr0 `plusPtr` 1) x
return $! ptr0 `plusPtr` 9
else do
let bytes = 1 + (bits - 1) `div` 7
let end = ptr0 `plusPtr` bytes
let go ptr n
| ptr == end = pure ptr
| otherwise = do
poke ptr (fromIntegral n .&. 0xff)
go (ptr `plusPtr` 1) (n `shiftR` 8)
go ptr0 $! (2 * x + 1) `shiftL` (bytes - 1)
{-# INLINE CONLIKE prefixVarIntBP #-}