{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
module Mason.Builder.Internal (Builder
  , BuilderFor(..)
  , BState
  , Buildable(..)
  , GrowingBuffer(..)
  , Buffer(..)
  , pattern Builder
  , unBuilder
  , byteStringCopy
  , shortByteString
  , StrictByteStringBackend
  , toStrictByteString
  , Channel(..)
  , LazyByteStringBackend
  , toLazyByteString
  , withPopper
  , StreamingBackend(..)
  , toStreamingBody
  , stringUtf8
  , lengthPrefixedWithin
  , primBounded
  , primFixed
  , primMapListFixed
  , primMapListBounded
  , primMapByteStringFixed
  , primMapLazyByteStringFixed
  , PutEnv(..)
  , BufferedIOBackend
  , hPutBuilderLen
  , encodeUtf8BuilderEscaped
  , sendBuilder
  , cstring
  , cstringUtf8
  , withPtr
  , storable
  , paddedBoundedPrim
  , zeroPaddedBoundedPrim
  -- * Internal
  , ensure
  , allocateConstant
  , withGrisu3
  , withGrisu3Rounded
  , roundDigit
  ) where

import Control.Concurrent
import Control.Exception (throw)
import Control.Monad
import Data.Bits ((.&.))
import qualified Data.ByteString as B
import qualified Data.ByteString.Short.Internal as SB
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Internal as BL
import qualified Data.ByteString.Internal as B
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Builder.Prim as P
import qualified Data.ByteString.Builder.Prim.Internal as B
import Data.Text.Internal.Unsafe.Shift (shiftR)
import Data.Text.Internal.Unsafe.Char (ord)
import System.IO
import Foreign.C.Types
import Foreign.Ptr
import Foreign.ForeignPtr.Unsafe
import Foreign.ForeignPtr
import Foreign.Marshal.Array (allocaArray)
import Data.IORef
import Data.Word (Word8)
import Data.String
import Foreign.Storable as S
import System.IO.Unsafe
import qualified Data.Text.Array as A
import qualified Data.Text.Internal as T
import qualified Data.Text.Internal.Encoding.Utf16 as U16
import qualified Network.Socket as S
import GHC.Prim (eqWord#, plusAddr#, indexWord8OffAddr#, RealWorld, Addr#, State# )
import GHC.Ptr (Ptr(..))
import GHC.Word (Word8(..))
import GHC.Types (isTrue#)
import GHC.Base (unpackCString#, unpackCStringUtf8#, unpackFoldrCString#, build, IO(..), unIO)

-- | The Builder type. Requires RankNTypes extension
type Builder = forall s. Buildable s => BuilderFor s

-- | Builder specialised for a backend
newtype BuilderFor s = RawBuilder { BuilderFor s -> s -> BState -> BState
unRawBuilder :: s -> BState -> BState }

unBuilder :: BuilderFor s -> s -> Buffer -> IO Buffer
unBuilder :: BuilderFor s -> s -> Buffer -> IO Buffer
unBuilder (RawBuilder s -> BState -> BState
f) = \s
env (Buffer (Ptr Addr#
ptr) (Ptr Addr#
end)) -> (State# RealWorld -> (# State# RealWorld, Buffer #)) -> IO Buffer
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO (\State# RealWorld
s -> case s -> BState -> BState
f s
env (# Addr#
ptr, Addr#
end, State# RealWorld
s #) of
   (# Addr#
ptr', Addr#
end', State# RealWorld
s' #) -> (# State# RealWorld
s', Ptr Word8 -> Ptr Word8 -> Buffer
Buffer (Addr# -> Ptr Word8
forall a. Addr# -> Ptr a
Ptr Addr#
ptr') (Addr# -> Ptr Word8
forall a. Addr# -> Ptr a
Ptr Addr#
end') #))
{-# INLINE unBuilder #-}

pattern Builder :: (s -> Buffer -> IO Buffer) -> BuilderFor s
pattern $bBuilder :: (s -> Buffer -> IO Buffer) -> BuilderFor s
$mBuilder :: forall r s.
BuilderFor s
-> ((s -> Buffer -> IO Buffer) -> r) -> (Void# -> r) -> r
Builder f <- (unBuilder -> f) where
  Builder s -> Buffer -> IO Buffer
f = (s -> BState -> BState) -> BuilderFor s
forall s. (s -> BState -> BState) -> BuilderFor s
RawBuilder ((s -> BState -> BState) -> BuilderFor s)
-> (s -> BState -> BState) -> BuilderFor s
forall a b. (a -> b) -> a -> b
$ \s
env (# Addr#
ptr, Addr#
end, State# RealWorld
s #) -> case IO Buffer -> State# RealWorld -> (# State# RealWorld, Buffer #)
forall a. IO a -> State# RealWorld -> (# State# RealWorld, a #)
unIO (s -> Buffer -> IO Buffer
f s
env (Ptr Word8 -> Ptr Word8 -> Buffer
Buffer (Addr# -> Ptr Word8
forall a. Addr# -> Ptr a
Ptr Addr#
ptr) (Addr# -> Ptr Word8
forall a. Addr# -> Ptr a
Ptr Addr#
end))) State# RealWorld
s of
    (# State# RealWorld
s', Buffer (Ptr Addr#
ptr') (Ptr Addr#
end') #) -> (# Addr#
ptr', Addr#
end', State# RealWorld
s' #)

{-# COMPLETE Builder #-}

type BState = (#Addr#, Addr#, State# RealWorld #)

-- | This class is used to provide backend-specific operations for running a 'Builder'.
class Buildable s where
  -- | Put a 'B.ByteString'.
  byteString :: B.ByteString -> BuilderFor s
  byteString = ByteString -> BuilderFor s
forall s. Buildable s => ByteString -> BuilderFor s
byteStringCopy
  {-# INLINE byteString #-}
  -- | Flush the content of the internal buffer.
  flush :: BuilderFor s
  -- | Allocate a buffer with at least the given length.
  allocate :: Int -> BuilderFor s

-- | Buffer pointers
data Buffer = Buffer
  { Buffer -> Ptr Word8
bEnd :: {-# UNPACK #-} !(Ptr Word8) -- ^ end of the buffer (next to the last byte)
  , Buffer -> Ptr Word8
bCur :: {-# UNPACK #-} !(Ptr Word8) -- ^ current position
  }

-- | Copy a 'B.ByteString' to a buffer.
byteStringCopy :: Buildable s => B.ByteString -> BuilderFor s
byteStringCopy :: ByteString -> BuilderFor s
byteStringCopy = \(B.PS ForeignPtr Word8
fsrc Int
ofs Int
len) -> Int -> (Ptr Word8 -> IO (Ptr Word8)) -> BuilderFor s
forall s.
Buildable s =>
Int -> (Ptr Word8 -> IO (Ptr Word8)) -> BuilderFor s
withPtr Int
len ((Ptr Word8 -> IO (Ptr Word8)) -> BuilderFor s)
-> (Ptr Word8 -> IO (Ptr Word8)) -> BuilderFor s
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr -> do
  ForeignPtr Word8 -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fsrc ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
src -> Ptr Word8 -> Ptr Word8 -> Int -> IO ()
B.memcpy Ptr Word8
ptr (Ptr Word8
src Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
ofs) Int
len
  Ptr Word8 -> IO (Ptr Word8)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr Word8 -> IO (Ptr Word8)) -> Ptr Word8 -> IO (Ptr Word8)
forall a b. (a -> b) -> a -> b
$ Ptr Word8
ptr Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
len
{-# INLINE byteStringCopy #-}

-- | Copy a 'SB.ShortByteString' to a buffer.
shortByteString :: SB.ShortByteString -> Builder
shortByteString :: ShortByteString -> Builder
shortByteString = \ShortByteString
src -> let len :: Int
len = ShortByteString -> Int
SB.length ShortByteString
src in Int -> (Ptr Word8 -> IO (Ptr Word8)) -> BuilderFor s
forall s.
Buildable s =>
Int -> (Ptr Word8 -> IO (Ptr Word8)) -> BuilderFor s
withPtr Int
len ((Ptr Word8 -> IO (Ptr Word8)) -> BuilderFor s)
-> (Ptr Word8 -> IO (Ptr Word8)) -> BuilderFor s
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr ->
  Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
ptr Int
len Ptr Word8 -> IO () -> IO (Ptr Word8)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ShortByteString -> Int -> Ptr Word8 -> Int -> IO ()
forall a. ShortByteString -> Int -> Ptr a -> Int -> IO ()
SB.copyToPtr ShortByteString
src Int
0 Ptr Word8
ptr Int
len
{-# INLINE shortByteString #-}

-- | Construct a 'Builder' from a "poke" function.
withPtr :: Buildable s
  => Int -- ^ number of bytes to allocate (if needed)
  -> (Ptr Word8 -> IO (Ptr Word8)) -- ^ return a next pointer after writing
  -> BuilderFor s
withPtr :: Int -> (Ptr Word8 -> IO (Ptr Word8)) -> BuilderFor s
withPtr Int
n Ptr Word8 -> IO (Ptr Word8)
f = Int -> (Buffer -> IO Buffer) -> Builder
ensure Int
n ((Buffer -> IO Buffer) -> Builder)
-> (Buffer -> IO Buffer) -> Builder
forall a b. (a -> b) -> a -> b
$ \(Buffer Ptr Word8
e Ptr Word8
p) -> Ptr Word8 -> Ptr Word8 -> Buffer
Buffer Ptr Word8
e (Ptr Word8 -> Buffer) -> IO (Ptr Word8) -> IO Buffer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Word8 -> IO (Ptr Word8)
f Ptr Word8
p
{-# INLINE withPtr #-}

-- | Turn a 'Storable' value into a 'Builder'
storable :: Storable a => a -> Builder
storable :: a -> Builder
storable a
a = Int -> (Ptr Word8 -> IO (Ptr Word8)) -> BuilderFor s
forall s.
Buildable s =>
Int -> (Ptr Word8 -> IO (Ptr Word8)) -> BuilderFor s
withPtr (a -> Int
forall a. Storable a => a -> Int
sizeOf a
a) ((Ptr Word8 -> IO (Ptr Word8)) -> BuilderFor s)
-> (Ptr Word8 -> IO (Ptr Word8)) -> BuilderFor s
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p -> Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
p (a -> Int
forall a. Storable a => a -> Int
sizeOf a
a) Ptr Word8 -> IO () -> IO (Ptr Word8)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Ptr a -> a -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8 -> Ptr a
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
p) a
a
{-# INLINE storable #-}

-- | Ensure that the given number of bytes is available in the buffer. Subject to semigroup fusion
ensure :: Int -> (Buffer -> IO Buffer) -> Builder
ensure :: Int -> (Buffer -> IO Buffer) -> Builder
ensure Int
mlen Buffer -> IO Buffer
cont = (s -> Buffer -> IO Buffer) -> BuilderFor s
forall s. (s -> Buffer -> IO Buffer) -> BuilderFor s
Builder ((s -> Buffer -> IO Buffer) -> BuilderFor s)
-> (s -> Buffer -> IO Buffer) -> BuilderFor s
forall a b. (a -> b) -> a -> b
$ \s
env buf :: Buffer
buf@(Buffer Ptr Word8
end Ptr Word8
ptr) ->
  if Ptr Word8
ptr Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
mlen Ptr Word8 -> Ptr Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Ptr Word8
end
    then do
      buf' :: Buffer
buf'@(Buffer Ptr Word8
end' Ptr Word8
ptr') <- BuilderFor s -> s -> Buffer -> IO Buffer
forall s. BuilderFor s -> s -> Buffer -> IO Buffer
unBuilder BuilderFor s
Builder
flush s
env Buffer
buf
      if Int
mlen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Ptr Word8 -> Ptr Word8 -> Int
forall a b. Ptr a -> Ptr b -> Int
minusPtr Ptr Word8
end' Ptr Word8
ptr'
        then Buffer -> IO Buffer
cont Buffer
buf'
        else BuilderFor s -> s -> Buffer -> IO Buffer
forall s. BuilderFor s -> s -> Buffer -> IO Buffer
unBuilder (Int -> BuilderFor s
forall s. Buildable s => Int -> BuilderFor s
allocate Int
mlen) s
env Buffer
buf' IO Buffer -> (Buffer -> IO Buffer) -> IO Buffer
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Buffer -> IO Buffer
cont
    else Buffer -> IO Buffer
cont Buffer
buf
{-# INLINE[1] ensure #-}

{-# RULES "<>/ensure" forall m n f g. ensure m f <> ensure n g = ensure (m + n) (f >=> g) #-}

-- | Run a builder within a buffer and prefix it by the length.
lengthPrefixedWithin :: Int -- ^ maximum length
  -> B.BoundedPrim Int -- ^ prefix encoder
  -> BuilderFor () -> Builder
lengthPrefixedWithin :: Int -> BoundedPrim Int -> BuilderFor () -> Builder
lengthPrefixedWithin Int
maxLen BoundedPrim Int
bp BuilderFor ()
builder = Int -> (Buffer -> IO Buffer) -> Builder
ensure (BoundedPrim Int -> Int
forall a. BoundedPrim a -> Int
B.sizeBound BoundedPrim Int
bp Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
maxLen) ((Buffer -> IO Buffer) -> Builder)
-> (Buffer -> IO Buffer) -> Builder
forall a b. (a -> b) -> a -> b
$ \(Buffer Ptr Word8
end Ptr Word8
origin) -> do
  let base :: Ptr Word8
base = Ptr Word8
origin Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` BoundedPrim Int -> Int
forall a. BoundedPrim a -> Int
B.sizeBound BoundedPrim Int
bp
  Buffer Ptr Word8
_ Ptr Word8
base' <- BuilderFor () -> () -> Buffer -> IO Buffer
forall s. BuilderFor s -> s -> Buffer -> IO Buffer
unBuilder BuilderFor ()
builder () (Ptr Word8 -> Ptr Word8 -> Buffer
Buffer Ptr Word8
end Ptr Word8
base)
  let len :: Int
len = Ptr Word8 -> Ptr Word8 -> Int
forall a b. Ptr a -> Ptr b -> Int
minusPtr Ptr Word8
base' Ptr Word8
base
  Ptr Word8
newBase <- BoundedPrim Int -> Int -> Ptr Word8 -> IO (Ptr Word8)
forall a. BoundedPrim a -> a -> Ptr Word8 -> IO (Ptr Word8)
B.runB BoundedPrim Int
bp Int
len Ptr Word8
origin
  Ptr Word8 -> Ptr Word8 -> Int -> IO ()
c_memmove Ptr Word8
newBase Ptr Word8
base Int
len
  Buffer -> IO Buffer
forall (m :: * -> *) a. Monad m => a -> m a
return (Buffer -> IO Buffer) -> Buffer -> IO Buffer
forall a b. (a -> b) -> a -> b
$ Ptr Word8 -> Ptr Word8 -> Buffer
Buffer Ptr Word8
end (Ptr Word8
newBase Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
len)
{-# INLINE lengthPrefixedWithin #-}

-- | Work with a constant buffer. 'allocate' will always fail.
instance Buildable () where
  byteString :: ByteString -> BuilderFor ()
byteString = ByteString -> BuilderFor ()
forall s. Buildable s => ByteString -> BuilderFor s
byteStringCopy
  {-# INLINE byteString #-}
  flush :: BuilderFor ()
flush = BuilderFor ()
forall a. Monoid a => a
mempty
  {-# INLINE flush #-}
  allocate :: Int -> BuilderFor ()
allocate Int
_ = (() -> Buffer -> IO Buffer) -> BuilderFor ()
forall s. (s -> Buffer -> IO Buffer) -> BuilderFor s
Builder ((() -> Buffer -> IO Buffer) -> BuilderFor ())
-> (() -> Buffer -> IO Buffer) -> BuilderFor ()
forall a b. (a -> b) -> a -> b
$ \()
_ Buffer
_ -> String -> IO Buffer
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Mason.Builder.Internal.allocate: can't allocate"
  {-# INLINE allocate #-}

instance Semigroup (BuilderFor s) where
  RawBuilder s -> BState -> BState
f <> :: BuilderFor s -> BuilderFor s -> BuilderFor s
<> RawBuilder s -> BState -> BState
g = (s -> BState -> BState) -> BuilderFor s
forall s. (s -> BState -> BState) -> BuilderFor s
RawBuilder ((s -> BState -> BState) -> BuilderFor s)
-> (s -> BState -> BState) -> BuilderFor s
forall a b. (a -> b) -> a -> b
$ \s
e BState
s -> s -> BState -> BState
g s
e (s -> BState -> BState
f s
e BState
s)
  {-# INLINE[1] (<>) #-}

instance Monoid (BuilderFor a) where
  mempty :: BuilderFor a
mempty = (a -> BState -> BState) -> BuilderFor a
forall s. (s -> BState -> BState) -> BuilderFor s
RawBuilder (\a
_ BState
s -> BState
s)
  {-# INLINE mempty #-}

-- | UTF-8 encode a 'String'.
stringUtf8 :: String -> Builder
stringUtf8 :: String -> Builder
stringUtf8 = BoundedPrim Char -> String -> Builder
forall a. BoundedPrim a -> [a] -> Builder
primMapListBounded BoundedPrim Char
P.charUtf8
{-# INLINE [1] stringUtf8 #-}

{-# RULES
"stringUtf8/unpackCStringUtf8#" forall s.
  stringUtf8 (unpackCStringUtf8# s) = cstringUtf8 (Ptr s)

"stringUtf8/unpackCString#" forall s.
  stringUtf8 (unpackCString# s) = cstring (Ptr s)

"stringUtf8/unpackFoldrCString#" forall s.
  stringUtf8 (build (unpackFoldrCString# s)) = cstring (Ptr s)
 #-}

cstring :: Ptr Word8 -> Builder
cstring :: Ptr Word8 -> Builder
cstring (Ptr Addr#
addr0) = (s -> Buffer -> IO Buffer) -> BuilderFor s
forall s. (s -> Buffer -> IO Buffer) -> BuilderFor s
Builder ((s -> Buffer -> IO Buffer) -> BuilderFor s)
-> (s -> Buffer -> IO Buffer) -> BuilderFor s
forall a b. (a -> b) -> a -> b
$ Addr# -> s -> Buffer -> IO Buffer
forall s. Buildable s => Addr# -> s -> Buffer -> IO Buffer
step Addr#
addr0
  where
    step :: Addr# -> s -> Buffer -> IO Buffer
step Addr#
addr s
env br :: Buffer
br@(Buffer Ptr Word8
end Ptr Word8
ptr)
      | Int# -> Bool
isTrue# (Word#
ch Word# -> Word# -> Int#
`eqWord#` Word#
0##) = Buffer -> IO Buffer
forall (f :: * -> *) a. Applicative f => a -> f a
pure Buffer
br
      | Ptr Word8
ptr Ptr Word8 -> Ptr Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr Word8
end = BuilderFor s -> s -> Buffer -> IO Buffer
forall s. BuilderFor s -> s -> Buffer -> IO Buffer
unBuilder (Int -> (Buffer -> IO Buffer) -> Builder
ensure Int
3 ((Buffer -> IO Buffer) -> Builder)
-> (Buffer -> IO Buffer) -> Builder
forall a b. (a -> b) -> a -> b
$ Addr# -> s -> Buffer -> IO Buffer
step Addr#
addr s
env) s
env Buffer
br
      | Bool
otherwise = do
          Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
S.poke Ptr Word8
ptr (Word# -> Word8
W8# Word#
ch)
          let br' :: Buffer
br' = Ptr Word8 -> Ptr Word8 -> Buffer
Buffer Ptr Word8
end (Ptr Word8
ptr Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
1)
          Addr# -> s -> Buffer -> IO Buffer
step (Addr#
addr Addr# -> Int# -> Addr#
`plusAddr#` Int#
1#) s
env Buffer
br'
      where
        !ch :: Word#
ch = Addr# -> Int# -> Word#
indexWord8OffAddr# Addr#
addr Int#
0#
{-# INLINE cstring #-}

cstringUtf8 :: Ptr Word8 -> Builder
cstringUtf8 :: Ptr Word8 -> Builder
cstringUtf8 (Ptr Addr#
addr0) = (s -> Buffer -> IO Buffer) -> BuilderFor s
forall s. (s -> Buffer -> IO Buffer) -> BuilderFor s
Builder ((s -> Buffer -> IO Buffer) -> BuilderFor s)
-> (s -> Buffer -> IO Buffer) -> BuilderFor s
forall a b. (a -> b) -> a -> b
$ Addr# -> s -> Buffer -> IO Buffer
forall s. Buildable s => Addr# -> s -> Buffer -> IO Buffer
step Addr#
addr0
  where
    step :: Addr# -> s -> Buffer -> IO Buffer
step Addr#
addr s
env br :: Buffer
br@(Buffer Ptr Word8
end Ptr Word8
ptr)
      | Int# -> Bool
isTrue# (Word#
ch Word# -> Word# -> Int#
`eqWord#` Word#
0##) = Buffer -> IO Buffer
forall (f :: * -> *) a. Applicative f => a -> f a
pure Buffer
br
      | Ptr Word8
ptr Ptr Word8 -> Ptr Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr Word8
end = BuilderFor s -> s -> Buffer -> IO Buffer
forall s. BuilderFor s -> s -> Buffer -> IO Buffer
unBuilder (Int -> (Buffer -> IO Buffer) -> Builder
ensure Int
3 ((Buffer -> IO Buffer) -> Builder)
-> (Buffer -> IO Buffer) -> Builder
forall a b. (a -> b) -> a -> b
$ Addr# -> s -> Buffer -> IO Buffer
step Addr#
addr s
env) s
env Buffer
br
        -- NULL is encoded as 0xc0 0x80
      | Int# -> Bool
isTrue# (Word#
ch Word# -> Word# -> Int#
`eqWord#` Word#
0xc0##)
      , Int# -> Bool
isTrue# (Addr# -> Int# -> Word#
indexWord8OffAddr# Addr#
addr Int#
1# Word# -> Word# -> Int#
`eqWord#` Word#
0x80##) = do
        Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
S.poke Ptr Word8
ptr Word8
0
        Addr# -> s -> Buffer -> IO Buffer
step (Addr#
addr Addr# -> Int# -> Addr#
`plusAddr#` Int#
2#) s
env (Ptr Word8 -> Ptr Word8 -> Buffer
Buffer Ptr Word8
end (Ptr Word8
ptr Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
1))
      | Bool
otherwise = do
        Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
S.poke Ptr Word8
ptr (Word# -> Word8
W8# Word#
ch)
        Addr# -> s -> Buffer -> IO Buffer
step (Addr#
addr Addr# -> Int# -> Addr#
`plusAddr#` Int#
1#) s
env (Ptr Word8 -> Ptr Word8 -> Buffer
Buffer Ptr Word8
end (Ptr Word8
ptr Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
1))
      where
        !ch :: Word#
ch = Addr# -> Int# -> Word#
indexWord8OffAddr# Addr#
addr Int#
0#
{-# INLINE cstringUtf8 #-}

instance Buildable s => IsString (BuilderFor s) where
  fromString :: String -> BuilderFor s
fromString = String -> BuilderFor s
String -> Builder
stringUtf8
  {-# INLINE fromString #-}

-- | Use 'B.BoundedPrim'
primBounded :: B.BoundedPrim a -> a -> Builder
primBounded :: BoundedPrim a -> a -> Builder
primBounded BoundedPrim a
bp = Int -> (Ptr Word8 -> IO (Ptr Word8)) -> BuilderFor s
forall s.
Buildable s =>
Int -> (Ptr Word8 -> IO (Ptr Word8)) -> BuilderFor s
withPtr (BoundedPrim a -> Int
forall a. BoundedPrim a -> Int
B.sizeBound BoundedPrim a
bp) ((Ptr Word8 -> IO (Ptr Word8)) -> BuilderFor s)
-> (a -> Ptr Word8 -> IO (Ptr Word8)) -> a -> BuilderFor s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BoundedPrim a -> a -> Ptr Word8 -> IO (Ptr Word8)
forall a. BoundedPrim a -> a -> Ptr Word8 -> IO (Ptr Word8)
B.runB BoundedPrim a
bp
{-# INLINE primBounded #-}

-- | Use 'B.FixedPrim'
primFixed :: B.FixedPrim a -> a -> Builder
primFixed :: FixedPrim a -> a -> Builder
primFixed FixedPrim a
fp a
a = Int -> (Ptr Word8 -> IO (Ptr Word8)) -> BuilderFor s
forall s.
Buildable s =>
Int -> (Ptr Word8 -> IO (Ptr Word8)) -> BuilderFor s
withPtr (FixedPrim a -> Int
forall a. FixedPrim a -> Int
B.size FixedPrim a
fp) ((Ptr Word8 -> IO (Ptr Word8)) -> BuilderFor s)
-> (Ptr Word8 -> IO (Ptr Word8)) -> BuilderFor s
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr -> (Ptr Word8
ptr Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` FixedPrim a -> Int
forall a. FixedPrim a -> Int
B.size FixedPrim a
fp) Ptr Word8 -> IO () -> IO (Ptr Word8)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ FixedPrim a -> a -> Ptr Word8 -> IO ()
forall a. FixedPrim a -> a -> Ptr Word8 -> IO ()
B.runF FixedPrim a
fp a
a Ptr Word8
ptr
{-# INLINE primFixed #-}

primMapListFixed :: B.FixedPrim a -> [a] -> Builder
primMapListFixed :: FixedPrim a -> [a] -> Builder
primMapListFixed FixedPrim a
fp = (a -> BuilderFor s) -> [a] -> BuilderFor s
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (FixedPrim a -> a -> Builder
forall a. FixedPrim a -> a -> Builder
primFixed FixedPrim a
fp)
{-# INLINE primMapListFixed #-}

primMapListBounded :: B.BoundedPrim a -> [a] -> Builder
primMapListBounded :: BoundedPrim a -> [a] -> Builder
primMapListBounded BoundedPrim a
bp = (a -> BuilderFor s) -> [a] -> BuilderFor s
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (BoundedPrim a -> a -> Builder
forall a. BoundedPrim a -> a -> Builder
primBounded BoundedPrim a
bp)
{-# INLINE primMapListBounded #-}

primMapByteStringFixed :: B.FixedPrim Word8 -> B.ByteString -> Builder
primMapByteStringFixed :: FixedPrim Word8 -> ByteString -> Builder
primMapByteStringFixed FixedPrim Word8
fp = (Word8 -> BuilderFor s -> BuilderFor s)
-> BuilderFor s -> ByteString -> BuilderFor s
forall a. (Word8 -> a -> a) -> a -> ByteString -> a
B.foldr (BuilderFor s -> BuilderFor s -> BuilderFor s
forall a. Monoid a => a -> a -> a
mappend (BuilderFor s -> BuilderFor s -> BuilderFor s)
-> (Word8 -> BuilderFor s) -> Word8 -> BuilderFor s -> BuilderFor s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FixedPrim Word8 -> Word8 -> Builder
forall a. FixedPrim a -> a -> Builder
primFixed FixedPrim Word8
fp) BuilderFor s
forall a. Monoid a => a
mempty
{-# INLINE primMapByteStringFixed #-}

primMapLazyByteStringFixed :: B.FixedPrim Word8 -> BL.ByteString -> Builder
primMapLazyByteStringFixed :: FixedPrim Word8 -> ByteString -> Builder
primMapLazyByteStringFixed FixedPrim Word8
fp = (Word8 -> BuilderFor s -> BuilderFor s)
-> BuilderFor s -> ByteString -> BuilderFor s
forall a. (Word8 -> a -> a) -> a -> ByteString -> a
BL.foldr (BuilderFor s -> BuilderFor s -> BuilderFor s
forall a. Monoid a => a -> a -> a
mappend (BuilderFor s -> BuilderFor s -> BuilderFor s)
-> (Word8 -> BuilderFor s) -> Word8 -> BuilderFor s -> BuilderFor s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FixedPrim Word8 -> Word8 -> Builder
forall a. FixedPrim a -> a -> Builder
primFixed FixedPrim Word8
fp) BuilderFor s
forall a. Monoid a => a
mempty
{-# INLINE primMapLazyByteStringFixed #-}

paddedBoundedPrim
  :: Word8 -- ^ filler
  -> Int -- ^ pad if shorter than this
  -> B.BoundedPrim a
  -> a
  -> Builder
paddedBoundedPrim :: Word8 -> Int -> BoundedPrim a -> a -> Builder
paddedBoundedPrim Word8
ch Int
size BoundedPrim a
bp a
a = Int -> (Buffer -> IO Buffer) -> Builder
ensure (BoundedPrim a -> Int
forall a. BoundedPrim a -> Int
B.sizeBound BoundedPrim a
bp) ((Buffer -> IO Buffer) -> Builder)
-> (Buffer -> IO Buffer) -> Builder
forall a b. (a -> b) -> a -> b
$ \(Buffer Ptr Word8
end Ptr Word8
ptr) -> do
  Ptr Word8
ptr' <- BoundedPrim a -> a -> Ptr Word8 -> IO (Ptr Word8)
forall a. BoundedPrim a -> a -> Ptr Word8 -> IO (Ptr Word8)
B.runB BoundedPrim a
bp a
a Ptr Word8
ptr
  let len :: Int
len = Ptr Word8
ptr' Ptr Word8 -> Ptr Word8 -> Int
forall a b. Ptr a -> Ptr b -> Int
`minusPtr` Ptr Word8
ptr
  let pad :: Int
pad = Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
len
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
pad Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Ptr Word8 -> Ptr Word8 -> Int -> IO ()
c_memmove (Ptr Word8
ptr Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
pad) Ptr Word8
ptr Int
len
    IO (Ptr Word8) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Ptr Word8) -> IO ()) -> IO (Ptr Word8) -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr Word8 -> Word8 -> CSize -> IO (Ptr Word8)
B.memset Ptr Word8
ptr Word8
ch (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
pad)
  Buffer -> IO Buffer
forall (m :: * -> *) a. Monad m => a -> m a
return (Buffer -> IO Buffer) -> Buffer -> IO Buffer
forall a b. (a -> b) -> a -> b
$ Ptr Word8 -> Ptr Word8 -> Buffer
Buffer Ptr Word8
end (Ptr Word8 -> Buffer) -> Ptr Word8 -> Buffer
forall a b. (a -> b) -> a -> b
$ Ptr Word8
ptr' Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
pad Int
0

zeroPaddedBoundedPrim :: Int -> B.BoundedPrim a -> a -> Builder
zeroPaddedBoundedPrim :: Int -> BoundedPrim a -> a -> Builder
zeroPaddedBoundedPrim = Word8 -> Int -> BoundedPrim a -> a -> Builder
forall a. Word8 -> Int -> BoundedPrim a -> a -> Builder
paddedBoundedPrim Word8
48

newtype GrowingBuffer = GrowingBuffer (IORef (ForeignPtr Word8))

instance Buildable GrowingBuffer where
  byteString :: ByteString -> BuilderFor GrowingBuffer
byteString = ByteString -> BuilderFor GrowingBuffer
forall s. Buildable s => ByteString -> BuilderFor s
byteStringCopy
  {-# INLINE byteString #-}
  flush :: BuilderFor GrowingBuffer
flush = BuilderFor GrowingBuffer
forall a. Monoid a => a
mempty
  {-# INLINE flush #-}
  allocate :: Int -> BuilderFor GrowingBuffer
allocate Int
len = (GrowingBuffer -> Buffer -> IO Buffer) -> BuilderFor GrowingBuffer
forall s. (s -> Buffer -> IO Buffer) -> BuilderFor s
Builder ((GrowingBuffer -> Buffer -> IO Buffer)
 -> BuilderFor GrowingBuffer)
-> (GrowingBuffer -> Buffer -> IO Buffer)
-> BuilderFor GrowingBuffer
forall a b. (a -> b) -> a -> b
$ \(GrowingBuffer IORef (ForeignPtr Word8)
bufferRef) (Buffer Ptr Word8
_ Ptr Word8
dst) -> do
    ForeignPtr Word8
fptr0 <- IORef (ForeignPtr Word8) -> IO (ForeignPtr Word8)
forall a. IORef a -> IO a
readIORef IORef (ForeignPtr Word8)
bufferRef
    let ptr0 :: Ptr Word8
ptr0 = ForeignPtr Word8 -> Ptr Word8
forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr ForeignPtr Word8
fptr0
    let !pos :: Int
pos = Ptr Word8
dst Ptr Word8 -> Ptr Word8 -> Int
forall a b. Ptr a -> Ptr b -> Int
`minusPtr` Ptr Word8
ptr0
    let !size' :: Int
size' = Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
len Int
pos
    ForeignPtr Word8
fptr <- Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
size'
    let !dst' :: Ptr Word8
dst' = ForeignPtr Word8 -> Ptr Word8
forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr ForeignPtr Word8
fptr
    Ptr Word8 -> Ptr Word8 -> Int -> IO ()
B.memcpy Ptr Word8
dst' Ptr Word8
ptr0 Int
pos
    IORef (ForeignPtr Word8) -> ForeignPtr Word8 -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (ForeignPtr Word8)
bufferRef ForeignPtr Word8
fptr
    Buffer -> IO Buffer
forall (m :: * -> *) a. Monad m => a -> m a
return (Buffer -> IO Buffer) -> Buffer -> IO Buffer
forall a b. (a -> b) -> a -> b
$ Ptr Word8 -> Ptr Word8 -> Buffer
Buffer (Ptr Word8
dst' Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
size') (Ptr Word8
dst' Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
pos)
  {-# INLINE allocate #-}

type StrictByteStringBackend = GrowingBuffer

-- | Create a strict 'B.ByteString'
toStrictByteString :: BuilderFor StrictByteStringBackend -> B.ByteString
toStrictByteString :: BuilderFor GrowingBuffer -> ByteString
toStrictByteString BuilderFor GrowingBuffer
b = IO ByteString -> ByteString
forall a. IO a -> a
unsafePerformIO (IO ByteString -> ByteString) -> IO ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ do
  ForeignPtr Word8
fptr0 <- Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
initialSize
  IORef (ForeignPtr Word8)
bufferRef <- ForeignPtr Word8 -> IO (IORef (ForeignPtr Word8))
forall a. a -> IO (IORef a)
newIORef ForeignPtr Word8
fptr0
  let ptr0 :: Ptr Word8
ptr0 = ForeignPtr Word8 -> Ptr Word8
forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr ForeignPtr Word8
fptr0

  Buffer Ptr Word8
_ Ptr Word8
pos <- BuilderFor GrowingBuffer -> GrowingBuffer -> Buffer -> IO Buffer
forall s. BuilderFor s -> s -> Buffer -> IO Buffer
unBuilder BuilderFor GrowingBuffer
b (IORef (ForeignPtr Word8) -> GrowingBuffer
GrowingBuffer IORef (ForeignPtr Word8)
bufferRef)
    (Buffer -> IO Buffer) -> Buffer -> IO Buffer
forall a b. (a -> b) -> a -> b
$ Ptr Word8 -> Ptr Word8 -> Buffer
Buffer (Ptr Word8
ptr0 Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
initialSize) Ptr Word8
ptr0

  ForeignPtr Word8
fptr <- IORef (ForeignPtr Word8) -> IO (ForeignPtr Word8)
forall a. IORef a -> IO a
readIORef IORef (ForeignPtr Word8)
bufferRef
  ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ ForeignPtr Word8 -> Int -> Int -> ByteString
B.PS ForeignPtr Word8
fptr Int
0 (Ptr Word8
pos Ptr Word8 -> Ptr Word8 -> Int
forall a b. Ptr a -> Ptr b -> Int
`minusPtr` ForeignPtr Word8 -> Ptr Word8
forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr ForeignPtr Word8
fptr)

  where
    initialSize :: Int
initialSize = Int
128
{-# INLINE toStrictByteString #-}

data Channel = Channel
  { Channel -> MVar ByteString
chResp :: !(MVar B.ByteString)
  , Channel -> IORef (ForeignPtr Word8)
chBuffer :: !(IORef (ForeignPtr Word8))
  }

instance Buildable Channel where
  byteString :: ByteString -> BuilderFor Channel
byteString ByteString
bs
    | ByteString -> Int
B.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
4096 = ByteString -> BuilderFor Channel
forall s. Buildable s => ByteString -> BuilderFor s
byteStringCopy ByteString
bs
    | Bool
otherwise = BuilderFor Channel
Builder
flush BuilderFor Channel -> BuilderFor Channel -> BuilderFor Channel
forall a. Semigroup a => a -> a -> a
<> (Channel -> Buffer -> IO Buffer) -> BuilderFor Channel
forall s. (s -> Buffer -> IO Buffer) -> BuilderFor s
Builder (\(Channel MVar ByteString
v IORef (ForeignPtr Word8)
_) Buffer
b -> Buffer
b Buffer -> IO () -> IO Buffer
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ MVar ByteString -> ByteString -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ByteString
v ByteString
bs)
  {-# INLINE byteString #-}
  flush :: BuilderFor Channel
flush = (Channel -> Buffer -> IO Buffer) -> BuilderFor Channel
forall s. (s -> Buffer -> IO Buffer) -> BuilderFor s
Builder ((Channel -> Buffer -> IO Buffer) -> BuilderFor Channel)
-> (Channel -> Buffer -> IO Buffer) -> BuilderFor Channel
forall a b. (a -> b) -> a -> b
$ \(Channel MVar ByteString
v IORef (ForeignPtr Word8)
ref) (Buffer Ptr Word8
end Ptr Word8
ptr) -> do
    Ptr Word8
ptr0 <- ForeignPtr Word8 -> Ptr Word8
forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr (ForeignPtr Word8 -> Ptr Word8)
-> IO (ForeignPtr Word8) -> IO (Ptr Word8)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (ForeignPtr Word8) -> IO (ForeignPtr Word8)
forall a. IORef a -> IO a
readIORef IORef (ForeignPtr Word8)
ref
    let len :: Int
len = Ptr Word8 -> Ptr Word8 -> Int
forall a b. Ptr a -> Ptr b -> Int
minusPtr Ptr Word8
ptr Ptr Word8
ptr0
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar ByteString -> ByteString -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ByteString
v (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$! Int -> (Ptr Word8 -> IO ()) -> ByteString
B.unsafeCreate Int
len ((Ptr Word8 -> IO ()) -> ByteString)
-> (Ptr Word8 -> IO ()) -> ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
dst -> Ptr Word8 -> Ptr Word8 -> Int -> IO ()
B.memcpy Ptr Word8
dst Ptr Word8
ptr0 Int
len
    Buffer -> IO Buffer
forall (m :: * -> *) a. Monad m => a -> m a
return (Buffer -> IO Buffer) -> Buffer -> IO Buffer
forall a b. (a -> b) -> a -> b
$! Ptr Word8 -> Ptr Word8 -> Buffer
Buffer Ptr Word8
end Ptr Word8
ptr0
  {-# INLINE flush #-}
  allocate :: Int -> BuilderFor Channel
allocate = (Channel -> IORef (ForeignPtr Word8)) -> Int -> BuilderFor Channel
forall s. (s -> IORef (ForeignPtr Word8)) -> Int -> BuilderFor s
allocateConstant Channel -> IORef (ForeignPtr Word8)
chBuffer
  {-# INLINE allocate #-}

type LazyByteStringBackend = Channel

-- | Create a lazy 'BL.ByteString'. Threaded runtime is required.
toLazyByteString :: BuilderFor LazyByteStringBackend -> BL.ByteString
toLazyByteString :: BuilderFor Channel -> ByteString
toLazyByteString BuilderFor Channel
body = IO ByteString -> ByteString
forall a. IO a -> a
unsafePerformIO (IO ByteString -> ByteString) -> IO ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ BuilderFor Channel
-> (IO ByteString -> IO ByteString) -> IO ByteString
forall a. BuilderFor Channel -> (IO ByteString -> IO a) -> IO a
withPopper BuilderFor Channel
body ((IO ByteString -> IO ByteString) -> IO ByteString)
-> (IO ByteString -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \IO ByteString
pop -> do
  let go :: () -> ByteString
go ()
_ = IO ByteString -> ByteString
forall a. IO a -> a
unsafePerformIO (IO ByteString -> ByteString) -> IO ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ do
        ByteString
bs <- IO ByteString
pop
        ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$! if ByteString -> Bool
B.null ByteString
bs
          then ByteString
BL.empty
          else ByteString -> ByteString -> ByteString
BL.Chunk ByteString
bs (() -> ByteString
go ())
  ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ () -> ByteString
go ()
{-# INLINE toLazyByteString #-}

-- | Use 'Builder' as a <http://hackage.haskell.org/package/http-client-0.7.1/docs/Network-HTTP-Client.html#t:GivesPopper GivesPopper'
withPopper :: BuilderFor LazyByteStringBackend -> (IO B.ByteString -> IO a) -> IO a
withPopper :: BuilderFor Channel -> (IO ByteString -> IO a) -> IO a
withPopper BuilderFor Channel
body IO ByteString -> IO a
cont = do
  MVar ByteString
resp <- IO (MVar ByteString)
forall a. IO (MVar a)
newEmptyMVar

  let initialSize :: Int
initialSize = Int
4080
  ForeignPtr Word8
fptr <- Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
initialSize
  IORef (ForeignPtr Word8)
ref <- ForeignPtr Word8 -> IO (IORef (ForeignPtr Word8))
forall a. a -> IO (IORef a)
newIORef ForeignPtr Word8
fptr
  let ptr :: Ptr Word8
ptr = ForeignPtr Word8 -> Ptr Word8
forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr ForeignPtr Word8
fptr

  let final :: Either SomeException Buffer -> IO ()
final (Left SomeException
e) = SomeException -> IO ()
forall a e. Exception e => e -> a
throw SomeException
e
      final (Right Buffer
_) = MVar ByteString -> ByteString -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ByteString
resp ByteString
B.empty
  ThreadId
_ <- (IO Buffer
 -> (Either SomeException Buffer -> IO ()) -> IO ThreadId)
-> (Either SomeException Buffer -> IO ())
-> IO Buffer
-> IO ThreadId
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO Buffer -> (Either SomeException Buffer -> IO ()) -> IO ThreadId
forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally Either SomeException Buffer -> IO ()
final (IO Buffer -> IO ThreadId) -> IO Buffer -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ BuilderFor Channel -> Channel -> Buffer -> IO Buffer
forall s. BuilderFor s -> s -> Buffer -> IO Buffer
unBuilder (BuilderFor Channel
body BuilderFor Channel -> BuilderFor Channel -> BuilderFor Channel
forall a. Semigroup a => a -> a -> a
<> BuilderFor Channel
Builder
flush) (MVar ByteString -> IORef (ForeignPtr Word8) -> Channel
Channel MVar ByteString
resp IORef (ForeignPtr Word8)
ref)
    (Buffer -> IO Buffer) -> Buffer -> IO Buffer
forall a b. (a -> b) -> a -> b
$ Ptr Word8 -> Ptr Word8 -> Buffer
Buffer (Ptr Word8
ptr Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
initialSize) Ptr Word8
ptr

  IO ByteString -> IO a
cont (IO ByteString -> IO a) -> IO ByteString -> IO a
forall a b. (a -> b) -> a -> b
$ MVar ByteString -> IO ByteString
forall a. MVar a -> IO a
takeMVar MVar ByteString
resp
{-# INLINE withPopper #-}

-- | Environment for handle output
data PutEnv = PutEnv
  { PutEnv -> Int
peThreshold :: !Int
  , PutEnv -> Ptr Word8 -> Ptr Word8 -> IO ()
pePut :: !(Ptr Word8 -> Ptr Word8 -> IO ())
  -- ^ takes a pointer range and returns the number of bytes written
  , PutEnv -> IORef (ForeignPtr Word8)
peBuffer :: !(IORef (ForeignPtr Word8))
  , PutEnv -> IORef Int
peTotal :: !(IORef Int)
  }

-- | Allocate a new buffer.
allocateConstant :: (s -> IORef (ForeignPtr Word8)) -> Int -> BuilderFor s
allocateConstant :: (s -> IORef (ForeignPtr Word8)) -> Int -> BuilderFor s
allocateConstant s -> IORef (ForeignPtr Word8)
f Int
len = (s -> Buffer -> IO Buffer) -> BuilderFor s
forall s. (s -> Buffer -> IO Buffer) -> BuilderFor s
Builder ((s -> Buffer -> IO Buffer) -> BuilderFor s)
-> (s -> Buffer -> IO Buffer) -> BuilderFor s
forall a b. (a -> b) -> a -> b
$ \s
env (Buffer Ptr Word8
_ Ptr Word8
_) -> do
  ForeignPtr Word8
fptr <- Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
len
  IORef (ForeignPtr Word8) -> ForeignPtr Word8 -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (s -> IORef (ForeignPtr Word8)
f s
env) ForeignPtr Word8
fptr
  let ptr1 :: Ptr Word8
ptr1 = ForeignPtr Word8 -> Ptr Word8
forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr ForeignPtr Word8
fptr
  Buffer -> IO Buffer
forall (m :: * -> *) a. Monad m => a -> m a
return (Buffer -> IO Buffer) -> Buffer -> IO Buffer
forall a b. (a -> b) -> a -> b
$! Ptr Word8 -> Ptr Word8 -> Buffer
Buffer (Ptr Word8
ptr1 Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
len) Ptr Word8
ptr1
{-# INLINE allocateConstant #-}

instance Buildable PutEnv where
  byteString :: ByteString -> BuilderFor PutEnv
byteString bs :: ByteString
bs@(B.PS ForeignPtr Word8
fptr Int
ofs Int
len) = (PutEnv -> Buffer -> IO Buffer) -> BuilderFor PutEnv
forall s. (s -> Buffer -> IO Buffer) -> BuilderFor s
Builder ((PutEnv -> Buffer -> IO Buffer) -> BuilderFor PutEnv)
-> (PutEnv -> Buffer -> IO Buffer) -> BuilderFor PutEnv
forall a b. (a -> b) -> a -> b
$ \env :: PutEnv
env@PutEnv{Int
IORef Int
IORef (ForeignPtr Word8)
Ptr Word8 -> Ptr Word8 -> IO ()
peTotal :: IORef Int
peBuffer :: IORef (ForeignPtr Word8)
pePut :: Ptr Word8 -> Ptr Word8 -> IO ()
peThreshold :: Int
peTotal :: PutEnv -> IORef Int
peBuffer :: PutEnv -> IORef (ForeignPtr Word8)
pePut :: PutEnv -> Ptr Word8 -> Ptr Word8 -> IO ()
peThreshold :: PutEnv -> Int
..} Buffer
buf -> if Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
peThreshold
    then do
      Buffer
buf' <- BuilderFor PutEnv -> PutEnv -> Buffer -> IO Buffer
forall s. BuilderFor s -> s -> Buffer -> IO Buffer
unBuilder BuilderFor PutEnv
Builder
flush PutEnv
env Buffer
buf
      ForeignPtr Word8 -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fptr ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr -> do
        let ptr0 :: Ptr Word8
ptr0 = Ptr Word8
ptr Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
ofs
        Ptr Word8 -> Ptr Word8 -> IO ()
pePut Ptr Word8
ptr0 (Ptr Word8
ptr0 Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
len)
      Buffer -> IO Buffer
forall (f :: * -> *) a. Applicative f => a -> f a
pure Buffer
buf'
    else BuilderFor PutEnv -> PutEnv -> Buffer -> IO Buffer
forall s. BuilderFor s -> s -> Buffer -> IO Buffer
unBuilder (ByteString -> BuilderFor PutEnv
forall s. Buildable s => ByteString -> BuilderFor s
byteStringCopy ByteString
bs) PutEnv
env Buffer
buf
  {-# INLINE byteString #-}

  flush :: BuilderFor PutEnv
flush = (PutEnv -> Buffer -> IO Buffer) -> BuilderFor PutEnv
forall s. (s -> Buffer -> IO Buffer) -> BuilderFor s
Builder ((PutEnv -> Buffer -> IO Buffer) -> BuilderFor PutEnv)
-> (PutEnv -> Buffer -> IO Buffer) -> BuilderFor PutEnv
forall a b. (a -> b) -> a -> b
$ \PutEnv{Int
IORef Int
IORef (ForeignPtr Word8)
Ptr Word8 -> Ptr Word8 -> IO ()
peTotal :: IORef Int
peBuffer :: IORef (ForeignPtr Word8)
pePut :: Ptr Word8 -> Ptr Word8 -> IO ()
peThreshold :: Int
peTotal :: PutEnv -> IORef Int
peBuffer :: PutEnv -> IORef (ForeignPtr Word8)
pePut :: PutEnv -> Ptr Word8 -> Ptr Word8 -> IO ()
peThreshold :: PutEnv -> Int
..} (Buffer Ptr Word8
end Ptr Word8
ptr) -> do
    Ptr Word8
ptr0 <- ForeignPtr Word8 -> Ptr Word8
forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr (ForeignPtr Word8 -> Ptr Word8)
-> IO (ForeignPtr Word8) -> IO (Ptr Word8)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (ForeignPtr Word8) -> IO (ForeignPtr Word8)
forall a. IORef a -> IO a
readIORef IORef (ForeignPtr Word8)
peBuffer
    let len :: Int
len = Ptr Word8 -> Ptr Word8 -> Int
forall a b. Ptr a -> Ptr b -> Int
minusPtr Ptr Word8
ptr Ptr Word8
ptr0
    IORef Int -> (Int -> Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Int
peTotal (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
len)
    Ptr Word8 -> Ptr Word8 -> IO ()
pePut Ptr Word8
ptr0 Ptr Word8
ptr
    Buffer -> IO Buffer
forall (m :: * -> *) a. Monad m => a -> m a
return (Buffer -> IO Buffer) -> Buffer -> IO Buffer
forall a b. (a -> b) -> a -> b
$! Ptr Word8 -> Ptr Word8 -> Buffer
Buffer Ptr Word8
end Ptr Word8
ptr0
  {-# INLINE flush #-}

  allocate :: Int -> BuilderFor PutEnv
allocate = (PutEnv -> IORef (ForeignPtr Word8)) -> Int -> BuilderFor PutEnv
forall s. (s -> IORef (ForeignPtr Word8)) -> Int -> BuilderFor s
allocateConstant PutEnv -> IORef (ForeignPtr Word8)
peBuffer
  {-# INLINE allocate #-}

type BufferedIOBackend = PutEnv

-- | Write a 'Builder' into a handle and obtain the number of bytes written.
-- 'flush' does not imply actual disk operations. Set 'NoBuffering' if you want
-- it to write the content immediately.
hPutBuilderLen :: Handle -> BuilderFor BufferedIOBackend -> IO Int
hPutBuilderLen :: Handle -> BuilderFor PutEnv -> IO Int
hPutBuilderLen Handle
h BuilderFor PutEnv
b = do
  let initialSize :: Int
initialSize = Int
4096
  ForeignPtr Word8
fptr <- Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
initialSize
  IORef (ForeignPtr Word8)
ref <- ForeignPtr Word8 -> IO (IORef (ForeignPtr Word8))
forall a. a -> IO (IORef a)
newIORef ForeignPtr Word8
fptr
  let ptr :: Ptr Word8
ptr = ForeignPtr Word8 -> Ptr Word8
forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr ForeignPtr Word8
fptr
  IORef Int
counter <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0
  Buffer
_ <- BuilderFor PutEnv -> PutEnv -> Buffer -> IO Buffer
forall s. BuilderFor s -> s -> Buffer -> IO Buffer
unBuilder (BuilderFor PutEnv
b BuilderFor PutEnv -> BuilderFor PutEnv -> BuilderFor PutEnv
forall a. Semigroup a => a -> a -> a
<> BuilderFor PutEnv
Builder
flush)
    (Int
-> (Ptr Word8 -> Ptr Word8 -> IO ())
-> IORef (ForeignPtr Word8)
-> IORef Int
-> PutEnv
PutEnv Int
initialSize (\Ptr Word8
ptr0 Ptr Word8
ptr1 -> Handle -> Ptr Word8 -> Int -> IO ()
forall a. Handle -> Ptr a -> Int -> IO ()
hPutBuf Handle
h Ptr Word8
ptr (Ptr Word8 -> Ptr Word8 -> Int
forall a b. Ptr a -> Ptr b -> Int
minusPtr Ptr Word8
ptr1 Ptr Word8
ptr0)) IORef (ForeignPtr Word8)
ref IORef Int
counter)
    (Ptr Word8 -> Ptr Word8 -> Buffer
Buffer (Ptr Word8
ptr Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
initialSize) Ptr Word8
ptr)
  IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
counter
{-# INLINE hPutBuilderLen #-}

sendBufRange :: S.Socket -> Ptr Word8 -> Ptr Word8 -> IO ()
sendBufRange :: Socket -> Ptr Word8 -> Ptr Word8 -> IO ()
sendBufRange Socket
sock Ptr Word8
ptr0 Ptr Word8
ptr1 = Ptr Word8 -> IO ()
go Ptr Word8
ptr0 where
  go :: Ptr Word8 -> IO ()
go Ptr Word8
p
    | Ptr Word8
p Ptr Word8 -> Ptr Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Ptr Word8
ptr1 = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    | Bool
otherwise = do
      Int
sent <- Socket -> Ptr Word8 -> Int -> IO Int
S.sendBuf Socket
sock Ptr Word8
p (Ptr Word8 -> Ptr Word8 -> Int
forall a b. Ptr a -> Ptr b -> Int
minusPtr Ptr Word8
ptr1 Ptr Word8
p)
      Socket -> (CInt -> IO ()) -> IO ()
forall r. Socket -> (CInt -> IO r) -> IO r
S.withFdSocket Socket
sock ((CInt -> IO ()) -> IO ()) -> (CInt -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Fd -> IO ()
threadWaitWrite (Fd -> IO ()) -> (CInt -> Fd) -> CInt -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CInt -> Fd
forall a b. (Integral a, Num b) => a -> b
fromIntegral
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
sent Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr Word8 -> IO ()
go (Ptr Word8 -> IO ()) -> Ptr Word8 -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr Word8
p Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
sent

-- | Write a 'Builder' into a handle and obtain the number of bytes written.
sendBuilder :: S.Socket -> BuilderFor BufferedIOBackend -> IO Int
sendBuilder :: Socket -> BuilderFor PutEnv -> IO Int
sendBuilder Socket
sock BuilderFor PutEnv
b = do
  let initialSize :: Int
initialSize = Int
4096
  ForeignPtr Word8
fptr <- Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
initialSize
  IORef (ForeignPtr Word8)
ref <- ForeignPtr Word8 -> IO (IORef (ForeignPtr Word8))
forall a. a -> IO (IORef a)
newIORef ForeignPtr Word8
fptr
  let ptr :: Ptr Word8
ptr = ForeignPtr Word8 -> Ptr Word8
forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr ForeignPtr Word8
fptr
  IORef Int
counter <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0
  Buffer
_ <- BuilderFor PutEnv -> PutEnv -> Buffer -> IO Buffer
forall s. BuilderFor s -> s -> Buffer -> IO Buffer
unBuilder (BuilderFor PutEnv
b BuilderFor PutEnv -> BuilderFor PutEnv -> BuilderFor PutEnv
forall a. Semigroup a => a -> a -> a
<> BuilderFor PutEnv
Builder
flush)
    (Int
-> (Ptr Word8 -> Ptr Word8 -> IO ())
-> IORef (ForeignPtr Word8)
-> IORef Int
-> PutEnv
PutEnv Int
initialSize (Socket -> Ptr Word8 -> Ptr Word8 -> IO ()
sendBufRange Socket
sock) IORef (ForeignPtr Word8)
ref IORef Int
counter)
    (Ptr Word8 -> Ptr Word8 -> Buffer
Buffer (Ptr Word8
ptr Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
initialSize) Ptr Word8
ptr)
  IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
counter
{-# INLINE sendBuilder #-}

{-# INLINE encodeUtf8BuilderEscaped #-}

-- | Encode 'T.Text' with a custom escaping function
encodeUtf8BuilderEscaped :: B.BoundedPrim Word8 -> T.Text -> Builder
encodeUtf8BuilderEscaped :: BoundedPrim Word8 -> Text -> Builder
encodeUtf8BuilderEscaped BoundedPrim Word8
be = Text -> BuilderFor s
step where
  bound :: Int
bound = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
4 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ BoundedPrim Word8 -> Int
forall a. BoundedPrim a -> Int
B.sizeBound BoundedPrim Word8
be

  step :: Text -> BuilderFor s
step (T.Text Array
arr Int
off Int
len) = (s -> Buffer -> IO Buffer) -> BuilderFor s
forall s. (s -> Buffer -> IO Buffer) -> BuilderFor s
Builder ((s -> Buffer -> IO Buffer) -> BuilderFor s)
-> (s -> Buffer -> IO Buffer) -> BuilderFor s
forall a b. (a -> b) -> a -> b
$ Int -> s -> Buffer -> IO Buffer
loop Int
off where
    iend :: Int
iend = Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
len
    loop :: Int -> s -> Buffer -> IO Buffer
loop !Int
i0 s
env !br :: Buffer
br@(Buffer Ptr Word8
ope Ptr Word8
op0)
      | Int
i0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
iend       = Buffer -> IO Buffer
forall (m :: * -> *) a. Monad m => a -> m a
return Buffer
br
      | Int
outRemaining Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = Int -> IO Buffer
goPartial (Int
i0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
outRemaining Int
inpRemaining)
      | Bool
otherwise        = BuilderFor s -> s -> Buffer -> IO Buffer
forall s. BuilderFor s -> s -> Buffer -> IO Buffer
unBuilder (Int -> (Buffer -> IO Buffer) -> Builder
ensure Int
bound (Int -> s -> Buffer -> IO Buffer
loop Int
i0 s
env)) s
env Buffer
br
      where
        outRemaining :: Int
outRemaining = (Ptr Word8
ope Ptr Word8 -> Ptr Word8 -> Int
forall a b. Ptr a -> Ptr b -> Int
`minusPtr` Ptr Word8
op0) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
bound
        inpRemaining :: Int
inpRemaining = Int
iend Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i0

        goPartial :: Int -> IO Buffer
goPartial !Int
iendTmp = Int -> Ptr Word8 -> IO Buffer
go Int
i0 Ptr Word8
op0
          where
            go :: Int -> Ptr Word8 -> IO Buffer
go !Int
i !Ptr Word8
op
              | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
iendTmp = case Array -> Int -> Word16
A.unsafeIndex Array
arr Int
i of
                  Word16
w | Word16
w Word16 -> Word16 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word16
0x7F -> do
                        BoundedPrim Word8 -> Word8 -> Ptr Word8 -> IO (Ptr Word8)
forall a. BoundedPrim a -> a -> Ptr Word8 -> IO (Ptr Word8)
B.runB BoundedPrim Word8
be (Word16 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
w) Ptr Word8
op IO (Ptr Word8) -> (Ptr Word8 -> IO Buffer) -> IO Buffer
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Ptr Word8 -> IO Buffer
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                    | Word16
w Word16 -> Word16 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word16
0x7FF -> do
                        Int -> Word16 -> IO ()
forall a. Integral a => Int -> a -> IO ()
poke8 Int
0 (Word16 -> IO ()) -> Word16 -> IO ()
forall a b. (a -> b) -> a -> b
$ (Word16
w Word16 -> Int -> Word16
forall a. UnsafeShift a => a -> Int -> a
`shiftR` Int
6) Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
+ Word16
0xC0
                        Int -> Word16 -> IO ()
forall a. Integral a => Int -> a -> IO ()
poke8 Int
1 (Word16 -> IO ()) -> Word16 -> IO ()
forall a b. (a -> b) -> a -> b
$ (Word16
w Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16
0x3f) Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
+ Word16
0x80
                        Int -> Ptr Word8 -> IO Buffer
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Ptr Word8
op Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
2)
                    | Word16
0xD800 Word16 -> Word16 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word16
w Bool -> Bool -> Bool
&& Word16
w Word16 -> Word16 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word16
0xDBFF -> do
                        let c :: Int
c = Char -> Int
ord (Char -> Int) -> Char -> Int
forall a b. (a -> b) -> a -> b
$ Word16 -> Word16 -> Char
U16.chr2 Word16
w (Array -> Int -> Word16
A.unsafeIndex Array
arr (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1))
                        Int -> Int -> IO ()
forall a. Integral a => Int -> a -> IO ()
poke8 Int
0 (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int
c Int -> Int -> Int
forall a. UnsafeShift a => a -> Int -> a
`shiftR` Int
18) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
0xF0
                        Int -> Int -> IO ()
forall a. Integral a => Int -> a -> IO ()
poke8 Int
1 (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ ((Int
c Int -> Int -> Int
forall a. UnsafeShift a => a -> Int -> a
`shiftR` Int
12) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x3F) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
0x80
                        Int -> Int -> IO ()
forall a. Integral a => Int -> a -> IO ()
poke8 Int
2 (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ ((Int
c Int -> Int -> Int
forall a. UnsafeShift a => a -> Int -> a
`shiftR` Int
6) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x3F) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
0x80
                        Int -> Int -> IO ()
forall a. Integral a => Int -> a -> IO ()
poke8 Int
3 (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int
c Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x3F) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
0x80
                        Int -> Ptr Word8 -> IO Buffer
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) (Ptr Word8
op Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
4)
                    | Bool
otherwise -> do
                        Int -> Word16 -> IO ()
forall a. Integral a => Int -> a -> IO ()
poke8 Int
0 (Word16 -> IO ()) -> Word16 -> IO ()
forall a b. (a -> b) -> a -> b
$ (Word16
w Word16 -> Int -> Word16
forall a. UnsafeShift a => a -> Int -> a
`shiftR` Int
12) Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
+ Word16
0xE0
                        Int -> Word16 -> IO ()
forall a. Integral a => Int -> a -> IO ()
poke8 Int
1 (Word16 -> IO ()) -> Word16 -> IO ()
forall a b. (a -> b) -> a -> b
$ ((Word16
w Word16 -> Int -> Word16
forall a. UnsafeShift a => a -> Int -> a
`shiftR` Int
6) Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16
0x3F) Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
+ Word16
0x80
                        Int -> Word16 -> IO ()
forall a. Integral a => Int -> a -> IO ()
poke8 Int
2 (Word16 -> IO ()) -> Word16 -> IO ()
forall a b. (a -> b) -> a -> b
$ (Word16
w Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16
0x3F) Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
+ Word16
0x80
                        Int -> Ptr Word8 -> IO Buffer
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Ptr Word8
op Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
3)
              | Bool
otherwise = Int -> s -> Buffer -> IO Buffer
loop Int
i s
env (Ptr Word8 -> Ptr Word8 -> Buffer
Buffer Ptr Word8
ope Ptr Word8
op)
              where
                poke8 :: Integral a => Int -> a -> IO ()
                poke8 :: Int -> a -> IO ()
poke8 Int
j a
v = Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
S.poke (Ptr Word8
op Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
j) (a -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
v :: Word8)

foreign import ccall unsafe "memmove"
    c_memmove :: Ptr Word8 -> Ptr Word8 -> Int -> IO ()

-- | Decimal encoding of a positive 'Double'.
{-# INLINE withGrisu3 #-}
withGrisu3 :: Double -> IO r -> (Ptr Word8 -> Int -> Int -> IO r) -> IO r
withGrisu3 :: Double -> IO r -> (Ptr Word8 -> Int -> Int -> IO r) -> IO r
withGrisu3 Double
d IO r
contFail Ptr Word8 -> Int -> Int -> IO r
cont = Int -> (Ptr CInt -> IO r) -> IO r
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
2 ((Ptr CInt -> IO r) -> IO r) -> (Ptr CInt -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ \Ptr CInt
plen -> Int -> (Ptr Word8 -> IO r) -> IO r
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
19 ((Ptr Word8 -> IO r) -> IO r) -> (Ptr Word8 -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr -> do
  let pexp :: Ptr CInt
pexp = Ptr CInt -> Int -> Ptr CInt
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr CInt
plen (CInt -> Int
forall a. Storable a => a -> Int
S.sizeOf (CInt
forall a. HasCallStack => a
undefined :: CInt))
  CInt
success <- CDouble -> Ptr Word8 -> Ptr CInt -> Ptr CInt -> IO CInt
c_grisu3 (Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
d) (Ptr Word8
ptr Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
1) Ptr CInt
plen Ptr CInt
pexp
  if CInt
success CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0
    then IO r
contFail
    else do
      Int
len <- CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Int) -> IO CInt -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
S.peek Ptr CInt
plen
      Int
e <- CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Int) -> IO CInt -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
S.peek Ptr CInt
pexp
      Ptr Word8 -> Int -> Int -> IO r
cont Ptr Word8
ptr Int
len (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
e)

{-# INLINE withGrisu3Rounded #-}
withGrisu3Rounded :: Int -> Double -> (Ptr Word8 -> Int -> Int -> IO r) -> IO r
withGrisu3Rounded :: Int -> Double -> (Ptr Word8 -> Int -> Int -> IO r) -> IO r
withGrisu3Rounded Int
prec Double
val Ptr Word8 -> Int -> Int -> IO r
cont = Double -> IO r -> (Ptr Word8 -> Int -> Int -> IO r) -> IO r
forall r.
Double -> IO r -> (Ptr Word8 -> Int -> Int -> IO r) -> IO r
withGrisu3 Double
val (String -> IO r
forall a. HasCallStack => String -> a
error String
"withGrisu3Rounded: failed") ((Ptr Word8 -> Int -> Int -> IO r) -> IO r)
-> (Ptr Word8 -> Int -> Int -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr Int
len Int
e -> do
  let len' :: Int
len' = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
prec Int
len
  Bool
bump <- Int -> Int -> Ptr Word8 -> IO Bool
roundDigit Int
prec Int
len Ptr Word8
ptr
  if Bool
bump then Ptr Word8 -> Int -> Int -> IO r
cont Ptr Word8
ptr Int
len' (Int
e Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) else Ptr Word8 -> Int -> Int -> IO r
cont (Ptr Word8
ptr Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
1) Int
len' Int
e

-- | Round up to the supplied precision inplace.
roundDigit
  :: Int -- ^ precision
  -> Int -- ^ available digits
  -> Ptr Word8 -- ^ content
  -> IO Bool
roundDigit :: Int -> Int -> Ptr Word8 -> IO Bool
roundDigit Int
prec Int
len Ptr Word8
_ | Int
prec Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
len = Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
roundDigit Int
prec Int
_ Ptr Word8
ptr = do
  Word8
rd <- Ptr Word8 -> Int -> IO Word8
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Word8
ptr (Int
prec Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  let carry :: Int -> IO Bool
carry Int
0 = do
        Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word8
ptr Word8
49
        Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
      carry Int
i = do
        Word8
d <- Ptr Word8 -> Int -> IO Word8
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Word8
ptr Int
i
        if Word8
d Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
57
          then Ptr Word8 -> Int -> Word8 -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word8
ptr Int
i Word8
48 IO () -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> IO Bool
carry (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
          else do
            Ptr Word8 -> Int -> Word8 -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word8
ptr Int
i (Word8
d Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
1)
            Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  if Word8
rd Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
53
    then Int -> IO Bool
carry Int
prec
    else Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

foreign import ccall unsafe "static grisu3"
  c_grisu3 :: CDouble -> Ptr Word8 -> Ptr CInt -> Ptr CInt -> IO CInt

data StreamingBackend = StreamingBackend
  { StreamingBackend -> ByteString -> IO ()
sePush :: !(B.ByteString -> IO ())
  , StreamingBackend -> IORef (ForeignPtr Word8)
seBuffer :: !(IORef (ForeignPtr Word8))
  }

instance Buildable StreamingBackend where
  byteString :: ByteString -> BuilderFor StreamingBackend
byteString ByteString
bs
    | ByteString -> Int
B.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
4096 = ByteString -> BuilderFor StreamingBackend
forall s. Buildable s => ByteString -> BuilderFor s
byteStringCopy ByteString
bs
    | Bool
otherwise = BuilderFor StreamingBackend
Builder
flush BuilderFor StreamingBackend
-> BuilderFor StreamingBackend -> BuilderFor StreamingBackend
forall a. Semigroup a => a -> a -> a
<> (StreamingBackend -> Buffer -> IO Buffer)
-> BuilderFor StreamingBackend
forall s. (s -> Buffer -> IO Buffer) -> BuilderFor s
Builder (\StreamingBackend
env Buffer
b -> Buffer
b Buffer -> IO () -> IO Buffer
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ StreamingBackend -> ByteString -> IO ()
sePush StreamingBackend
env ByteString
bs)
  {-# INLINE byteString #-}
  flush :: BuilderFor StreamingBackend
flush = (StreamingBackend -> Buffer -> IO Buffer)
-> BuilderFor StreamingBackend
forall s. (s -> Buffer -> IO Buffer) -> BuilderFor s
Builder ((StreamingBackend -> Buffer -> IO Buffer)
 -> BuilderFor StreamingBackend)
-> (StreamingBackend -> Buffer -> IO Buffer)
-> BuilderFor StreamingBackend
forall a b. (a -> b) -> a -> b
$ \(StreamingBackend ByteString -> IO ()
push IORef (ForeignPtr Word8)
ref) (Buffer Ptr Word8
end Ptr Word8
ptr) -> do
    Ptr Word8
ptr0 <- ForeignPtr Word8 -> Ptr Word8
forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr (ForeignPtr Word8 -> Ptr Word8)
-> IO (ForeignPtr Word8) -> IO (Ptr Word8)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (ForeignPtr Word8) -> IO (ForeignPtr Word8)
forall a. IORef a -> IO a
readIORef IORef (ForeignPtr Word8)
ref
    let len :: Int
len = Ptr Word8 -> Ptr Word8 -> Int
forall a b. Ptr a -> Ptr b -> Int
minusPtr Ptr Word8
ptr Ptr Word8
ptr0
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> IO ()
push (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$! Int -> (Ptr Word8 -> IO ()) -> ByteString
B.unsafeCreate Int
len ((Ptr Word8 -> IO ()) -> ByteString)
-> (Ptr Word8 -> IO ()) -> ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
dst -> Ptr Word8 -> Ptr Word8 -> Int -> IO ()
B.memcpy Ptr Word8
dst Ptr Word8
ptr0 Int
len
    Buffer -> IO Buffer
forall (m :: * -> *) a. Monad m => a -> m a
return (Buffer -> IO Buffer) -> Buffer -> IO Buffer
forall a b. (a -> b) -> a -> b
$! Ptr Word8 -> Ptr Word8 -> Buffer
Buffer Ptr Word8
end Ptr Word8
ptr0
  {-# INLINE flush #-}
  allocate :: Int -> BuilderFor StreamingBackend
allocate = (StreamingBackend -> IORef (ForeignPtr Word8))
-> Int -> BuilderFor StreamingBackend
forall s. (s -> IORef (ForeignPtr Word8)) -> Int -> BuilderFor s
allocateConstant StreamingBackend -> IORef (ForeignPtr Word8)
seBuffer
  {-# INLINE allocate #-}

-- | Convert a 'Builder' into a <http://hackage.haskell.org/package/wai-3.2.2.1/docs/Network-Wai.html#t:StreamingBody StreamingBody>.
toStreamingBody :: BuilderFor StreamingBackend -> (BB.Builder -> IO ()) -> IO () -> IO ()
toStreamingBody :: BuilderFor StreamingBackend -> (Builder -> IO ()) -> IO () -> IO ()
toStreamingBody BuilderFor StreamingBackend
body = \Builder -> IO ()
write IO ()
_ -> do
  let initialSize :: Int
initialSize = Int
4080
  ForeignPtr Word8
fptr <- Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
initialSize
  IORef (ForeignPtr Word8)
ref <- ForeignPtr Word8 -> IO (IORef (ForeignPtr Word8))
forall a. a -> IO (IORef a)
newIORef ForeignPtr Word8
fptr
  let ptr :: Ptr Word8
ptr = ForeignPtr Word8 -> Ptr Word8
forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr ForeignPtr Word8
fptr
  Buffer Ptr Word8
_ Ptr Word8
ptr2 <- BuilderFor StreamingBackend
-> StreamingBackend -> Buffer -> IO Buffer
forall s. BuilderFor s -> s -> Buffer -> IO Buffer
unBuilder BuilderFor StreamingBackend
body
    ((ByteString -> IO ())
-> IORef (ForeignPtr Word8) -> StreamingBackend
StreamingBackend (Builder -> IO ()
write (Builder -> IO ())
-> (ByteString -> Builder) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
BB.byteString) IORef (ForeignPtr Word8)
ref)
    (Ptr Word8 -> Ptr Word8 -> Buffer
Buffer (Ptr Word8
ptr Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
initialSize) Ptr Word8
ptr)
  ForeignPtr Word8
fptr' <- IORef (ForeignPtr Word8) -> IO (ForeignPtr Word8)
forall a. IORef a -> IO a
readIORef IORef (ForeignPtr Word8)
ref
  let ptr1 :: Ptr Word8
ptr1 = ForeignPtr Word8 -> Ptr Word8
forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr ForeignPtr Word8
fptr'
  Builder -> IO ()
write (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
BB.byteString (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ ForeignPtr Word8 -> Int -> Int -> ByteString
B.PS ForeignPtr Word8
fptr' Int
0 (Ptr Word8 -> Ptr Word8 -> Int
forall a b. Ptr a -> Ptr b -> Int
minusPtr Ptr Word8
ptr2 Ptr Word8
ptr1)