{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE CPP #-}
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 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 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 Network.Socket as S
import GHC.Prim (plusAddr#, indexWord8OffAddr#, RealWorld, Addr#, State# )
import GHC.Ptr (Ptr(..))
import GHC.Word (Word8(..))
import GHC.Base (unpackCString#, unpackCStringUtf8#, unpackFoldrCString#, build, IO(..), unIO)

#if MIN_VERSION_text(2,0,0)
#else
-- imports required by 'encodeUtf8BuilderEscaped'

import Data.Bits ((.&.), shiftR)
import Data.Text.Internal.Unsafe.Char (ord)
import qualified Data.Text.Internal.Encoding.Utf16 as U16
#endif

-- https://www.haskell.org/ghc/blog/20210607-the-keepAlive-story.html

unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b
unsafeWithForeignPtr :: forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
unsafeWithForeignPtr ForeignPtr a
fo Ptr a -> IO b
f = do
  b
r <- Ptr a -> IO b
f (forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr ForeignPtr a
fo)
  forall a. ForeignPtr a -> IO ()
touchForeignPtr ForeignPtr a
fo
  forall (m :: * -> *) a. Monad m => a -> m a
return b
r

-- | The Builder type. Requires RankNTypes extension

type Builder = forall s. Buildable s => BuilderFor s

-- | Builder specialised for a backend

newtype BuilderFor s = RawBuilder { forall s. BuilderFor s -> s -> BState -> BState
unRawBuilder :: s -> BState -> BState }

unBuilder :: BuilderFor s -> s -> Buffer -> IO Buffer
unBuilder :: forall s. BuilderFor s -> s -> Buffer -> IO Buffer
unBuilder (RawBuilder s -> BState -> BState
f) = \s
env (Buffer (Ptr Addr#
ptr) (Ptr Addr#
end)) -> 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 (forall a. Addr# -> Ptr a
Ptr Addr#
ptr') (forall a. Addr# -> Ptr a
Ptr Addr#
end') #))
{-# INLINE unBuilder #-}

pattern Builder :: (s -> Buffer -> IO Buffer) -> BuilderFor s
pattern $bBuilder :: forall s. (s -> Buffer -> IO Buffer) -> BuilderFor s
$mBuilder :: forall {r} {s}.
BuilderFor s
-> ((s -> Buffer -> IO Buffer) -> r) -> ((# #) -> r) -> r
Builder f <- (unBuilder -> f) where
  Builder s -> Buffer -> IO Buffer
f = forall s. (s -> BState -> BState) -> BuilderFor s
RawBuilder forall a b. (a -> b) -> a -> b
$ \s
env (# Addr#
ptr, Addr#
end, State# RealWorld
s #) -> case forall a. IO a -> State# RealWorld -> (# State# RealWorld, a #)
unIO (s -> Buffer -> IO Buffer
f s
env (Ptr Word8 -> Ptr Word8 -> Buffer
Buffer (forall a. Addr# -> Ptr a
Ptr Addr#
ptr) (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 = 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 :: forall s. Buildable s => ByteString -> BuilderFor s
byteStringCopy = \(B.PS ForeignPtr Word8
fsrc Int
ofs Int
len) -> forall s.
Buildable s =>
Int -> (Ptr Word8 -> IO (Ptr Word8)) -> BuilderFor s
withPtr Int
len forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr -> do
  forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
unsafeWithForeignPtr ForeignPtr Word8
fsrc forall a b. (a -> b) -> a -> b
$ \Ptr Word8
src -> Ptr Word8 -> Ptr Word8 -> Int -> IO ()
B.memcpy Ptr Word8
ptr (Ptr Word8
src forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
ofs) Int
len
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Ptr Word8
ptr 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 forall s.
Buildable s =>
Int -> (Ptr Word8 -> IO (Ptr Word8)) -> BuilderFor s
withPtr Int
len forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr ->
  forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
ptr Int
len forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ 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 :: forall s.
Buildable s =>
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 forall a b. (a -> b) -> a -> b
$ \(Buffer Ptr Word8
e Ptr Word8
p) -> Ptr Word8 -> Ptr Word8 -> Buffer
Buffer Ptr Word8
e 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 :: forall a. Storable a => a -> Builder
storable a
a = forall s.
Buildable s =>
Int -> (Ptr Word8 -> IO (Ptr Word8)) -> BuilderFor s
withPtr (forall a. Storable a => a -> Int
sizeOf a
a) forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p -> forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
p (forall a. Storable a => a -> Int
sizeOf a
a) forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall a. Storable a => Ptr a -> a -> IO ()
poke (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 = forall s. (s -> Buffer -> IO Buffer) -> BuilderFor s
Builder forall a b. (a -> b) -> a -> b
$ \s
env buf :: Buffer
buf@(Buffer Ptr Word8
end Ptr Word8
ptr) ->
  if Ptr Word8
ptr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
mlen forall a. Ord a => a -> a -> Bool
>= Ptr Word8
end
    then do
      buf' :: Buffer
buf'@(Buffer Ptr Word8
end' Ptr Word8
ptr') <- forall s. BuilderFor s -> s -> Buffer -> IO Buffer
unBuilder Builder
flush s
env Buffer
buf
      if Int
mlen forall a. Ord a => a -> a -> Bool
<= forall a b. Ptr a -> Ptr b -> Int
minusPtr Ptr Word8
end' Ptr Word8
ptr'
        then Buffer -> IO Buffer
cont Buffer
buf'
        else forall s. BuilderFor s -> s -> Buffer -> IO Buffer
unBuilder (forall s. Buildable s => Int -> BuilderFor s
allocate Int
mlen) s
env Buffer
buf' 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 (forall a. BoundedPrim a -> Int
B.sizeBound BoundedPrim Int
bp forall a. Num a => a -> a -> a
+ Int
maxLen) forall a b. (a -> b) -> a -> b
$ \(Buffer Ptr Word8
end Ptr Word8
origin) -> do
  let base :: Ptr Word8
base = Ptr Word8
origin forall a b. Ptr a -> Int -> Ptr b
`plusPtr` forall a. BoundedPrim a -> Int
B.sizeBound BoundedPrim Int
bp
  Buffer Ptr Word8
_ Ptr Word8
base' <- 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 = forall a b. Ptr a -> Ptr b -> Int
minusPtr Ptr Word8
base' Ptr Word8
base
  Ptr Word8
newBase <- 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
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Ptr Word8 -> Ptr Word8 -> Buffer
Buffer Ptr Word8
end (Ptr Word8
newBase 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 = forall s. Buildable s => ByteString -> BuilderFor s
byteStringCopy
  {-# INLINE byteString #-}
  flush :: BuilderFor ()
flush = forall a. Monoid a => a
mempty
  {-# INLINE flush #-}
  allocate :: Int -> BuilderFor ()
allocate Int
_ = forall s. (s -> Buffer -> IO Buffer) -> BuilderFor s
Builder forall a b. (a -> b) -> a -> b
$ \()
_ 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 = forall s. (s -> BState -> BState) -> BuilderFor s
RawBuilder 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 = forall s. (s -> BState -> BState) -> BuilderFor s
RawBuilder (\a
_ BState
s -> BState
s)
  {-# INLINE mempty #-}

-- | UTF-8 encode a 'String'.

stringUtf8 :: Buildable s => String -> BuilderFor s
stringUtf8 :: forall s. Buildable s => String -> BuilderFor s
stringUtf8 = forall s a. Buildable s => BoundedPrim a -> [a] -> BuilderFor s
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) = forall s. (s -> Buffer -> IO Buffer) -> BuilderFor s
Builder forall a b. (a -> b) -> a -> b
$ 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)
      | Word8# -> Word8
W8# Word8#
ch forall a. Eq a => a -> a -> Bool
== Word8
0 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Buffer
br
      | Ptr Word8
ptr forall a. Eq a => a -> a -> Bool
== Ptr Word8
end = forall s. BuilderFor s -> s -> Buffer -> IO Buffer
unBuilder (Int -> (Buffer -> IO Buffer) -> Builder
ensure Int
3 forall a b. (a -> b) -> a -> b
$ Addr# -> s -> Buffer -> IO Buffer
step Addr#
addr s
env) s
env Buffer
br
      | Bool
otherwise = do
          forall a. Storable a => Ptr a -> a -> IO ()
S.poke Ptr Word8
ptr (Word8# -> Word8
W8# Word8#
ch)
          let br' :: Buffer
br' = Ptr Word8 -> Ptr Word8 -> Buffer
Buffer Ptr Word8
end (Ptr Word8
ptr 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 :: Word8#
ch = Addr# -> Int# -> Word8#
indexWord8OffAddr# Addr#
addr Int#
0#
{-# INLINE cstring #-}

cstringUtf8 :: Ptr Word8 -> Builder
cstringUtf8 :: Ptr Word8 -> Builder
cstringUtf8 (Ptr Addr#
addr0) = forall s. (s -> Buffer -> IO Buffer) -> BuilderFor s
Builder forall a b. (a -> b) -> a -> b
$ 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)
      | Word8# -> Word8
W8# Word8#
ch forall a. Eq a => a -> a -> Bool
== Word8
0 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Buffer
br
      | Ptr Word8
ptr forall a. Eq a => a -> a -> Bool
== Ptr Word8
end = forall s. BuilderFor s -> s -> Buffer -> IO Buffer
unBuilder (Int -> (Buffer -> IO Buffer) -> Builder
ensure Int
3 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

      | Word8# -> Word8
W8# Word8#
ch forall a. Eq a => a -> a -> Bool
== Word8
0xc0
      , Word8# -> Word8
W8# (Addr# -> Int# -> Word8#
indexWord8OffAddr# Addr#
addr Int#
1#) forall a. Eq a => a -> a -> Bool
== Word8
0x80 = do
        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 forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
1))
      | Bool
otherwise = do
        forall a. Storable a => Ptr a -> a -> IO ()
S.poke Ptr Word8
ptr (Word8# -> Word8
W8# Word8#
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 forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
1))
      where
        !ch :: Word8#
ch = Addr# -> Int# -> Word8#
indexWord8OffAddr# Addr#
addr Int#
0#
{-# INLINE cstringUtf8 #-}

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

-- | Use 'B.BoundedPrim'

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

-- | Use 'B.FixedPrim'

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

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

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

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

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

paddedBoundedPrim
  :: Word8 -- ^ filler

  -> Int -- ^ pad if shorter than this

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

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

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

  ForeignPtr Word8
fptr <- forall a. IORef a -> IO a
readIORef IORef (ForeignPtr Word8)
bufferRef
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ForeignPtr Word8 -> Int -> Int -> ByteString
B.PS ForeignPtr Word8
fptr Int
0 (Ptr Word8
pos forall a b. Ptr a -> Ptr b -> Int
`minusPtr` 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 forall a. Ord a => a -> a -> Bool
< Int
4096 = forall s. Buildable s => ByteString -> BuilderFor s
byteStringCopy ByteString
bs
    | Bool
otherwise = Builder
flush forall a. Semigroup a => a -> a -> a
<> forall s. (s -> Buffer -> IO Buffer) -> BuilderFor s
Builder (\(Channel MVar ByteString
v IORef (ForeignPtr Word8)
_) Buffer
b -> Buffer
b forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall a. MVar a -> a -> IO ()
putMVar MVar ByteString
v ByteString
bs)
  {-# INLINE byteString #-}
  flush :: BuilderFor Channel
flush = forall s. (s -> Buffer -> IO Buffer) -> BuilderFor s
Builder 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 <- forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef IORef (ForeignPtr Word8)
ref
    let len :: Int
len = forall a b. Ptr a -> Ptr b -> Int
minusPtr Ptr Word8
ptr Ptr Word8
ptr0
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
len forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$ do
      ForeignPtr Word8
bs <- forall a. Int -> IO (ForeignPtr a)
B.mallocByteString Int
len
      forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
unsafeWithForeignPtr ForeignPtr Word8
bs 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
      forall a. MVar a -> a -> IO ()
putMVar MVar ByteString
v forall a b. (a -> b) -> a -> b
$ ForeignPtr Word8 -> Int -> Int -> ByteString
B.PS ForeignPtr Word8
bs Int
0 Int
len
    forall (m :: * -> *) a. Monad m => a -> m a
return 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 = 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 = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. BuilderFor Channel -> (IO ByteString -> IO a) -> IO a
withPopper BuilderFor Channel
body forall a b. (a -> b) -> a -> b
$ \IO ByteString
pop -> do
  let go :: () -> IO ByteString
go ()
_ = do
        ByteString
bs <- IO ByteString
pop
        forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall a b. (a -> b) -> a -> b
$ forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ () -> IO ByteString
go ()
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ () -> IO 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 :: forall a. BuilderFor Channel -> (IO ByteString -> IO a) -> IO a
withPopper BuilderFor Channel
body IO ByteString -> IO a
cont = do
  MVar ByteString
resp <- forall a. IO (MVar a)
newEmptyMVar

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

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

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

-- | Environment for handle output

data PutEnv = PutEnv
  { BufferedIOBackend -> Int
peThreshold :: !Int
  , BufferedIOBackend -> Ptr Word8 -> Ptr Word8 -> IO ()
pePut :: !(Ptr Word8 -> Ptr Word8 -> IO ())
  -- ^ takes a pointer range and returns the number of bytes written

  , BufferedIOBackend -> IORef (ForeignPtr Word8)
peBuffer :: !(IORef (ForeignPtr Word8))
  , BufferedIOBackend -> IORef Int
peTotal :: !(IORef Int)
  }

-- | Allocate a new buffer.

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

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

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

  allocate :: Int -> BuilderFor BufferedIOBackend
allocate = forall s. (s -> IORef (ForeignPtr Word8)) -> Int -> BuilderFor s
allocateConstant BufferedIOBackend -> 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 BufferedIOBackend -> IO Int
hPutBuilderLen Handle
h BuilderFor BufferedIOBackend
b = do
  let initialSize :: Int
initialSize = Int
4096
  ForeignPtr Word8
fptr <- forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
initialSize
  IORef (ForeignPtr Word8)
ref <- forall a. a -> IO (IORef a)
newIORef ForeignPtr Word8
fptr
  let ptr :: Ptr Word8
ptr = forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr ForeignPtr Word8
fptr
  IORef Int
counter <- forall a. a -> IO (IORef a)
newIORef Int
0
  Buffer
_ <- forall s. BuilderFor s -> s -> Buffer -> IO Buffer
unBuilder (BuilderFor BufferedIOBackend
b forall a. Semigroup a => a -> a -> a
<> Builder
flush)
    (Int
-> (Ptr Word8 -> Ptr Word8 -> IO ())
-> IORef (ForeignPtr Word8)
-> IORef Int
-> BufferedIOBackend
PutEnv Int
initialSize (\Ptr Word8
ptr0 Ptr Word8
ptr1 -> forall a. Handle -> Ptr a -> Int -> IO ()
hPutBuf Handle
h Ptr Word8
ptr (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 forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
initialSize) Ptr Word8
ptr)
  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 forall a. Ord a => a -> a -> Bool
>= Ptr Word8
ptr1 = 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 (forall a b. Ptr a -> Ptr b -> Int
minusPtr Ptr Word8
ptr1 Ptr Word8
p)
      forall r. Socket -> (CInt -> IO r) -> IO r
S.withFdSocket Socket
sock forall a b. (a -> b) -> a -> b
$ Fd -> IO ()
threadWaitWrite forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
sent forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$ Ptr Word8 -> IO ()
go forall a b. (a -> b) -> a -> b
$ Ptr Word8
p 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 BufferedIOBackend -> IO Int
sendBuilder Socket
sock BuilderFor BufferedIOBackend
b = do
  let initialSize :: Int
initialSize = Int
4096
  ForeignPtr Word8
fptr <- forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
initialSize
  IORef (ForeignPtr Word8)
ref <- forall a. a -> IO (IORef a)
newIORef ForeignPtr Word8
fptr
  let ptr :: Ptr Word8
ptr = forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr ForeignPtr Word8
fptr
  IORef Int
counter <- forall a. a -> IO (IORef a)
newIORef Int
0
  Buffer
_ <- forall s. BuilderFor s -> s -> Buffer -> IO Buffer
unBuilder (BuilderFor BufferedIOBackend
b forall a. Semigroup a => a -> a -> a
<> Builder
flush)
    (Int
-> (Ptr Word8 -> Ptr Word8 -> IO ())
-> IORef (ForeignPtr Word8)
-> IORef Int
-> BufferedIOBackend
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 forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
initialSize) Ptr Word8
ptr)
  forall a. IORef a -> IO a
readIORef IORef Int
counter
{-# INLINE sendBuilder #-}

{-# INLINE encodeUtf8BuilderEscaped #-}

-- | Encode 'T.Text' with a custom escaping function.

--

-- Note that implementation differs between @text-1.x@ and @text-2.x@ due to the

-- package moving from using UTF-16 to UTF-8 for the internal representation.

encodeUtf8BuilderEscaped :: Buildable s => B.BoundedPrim Word8 -> T.Text -> BuilderFor s

#if MIN_VERSION_text(2,0,0)
encodeUtf8BuilderEscaped be = step where
  bound = max 4 $ B.sizeBound be

  step (T.Text arr off len) = Builder $ loop off where
    iend = off + len
    loop !i0 env !br@(Buffer ope op0)
      | i0 >= iend       = return br
      | outRemaining > 0 = goPartial (i0 + min outRemaining inpRemaining)
      | otherwise        = unBuilder (ensure bound (loop i0 env)) env br
      where
        outRemaining = (ope `minusPtr` op0) `quot` bound
        inpRemaining = iend - i0

        goPartial !iendTmp = go i0 op0
          where
            go !i !op
              | i < iendTmp = do
                let w = A.unsafeIndex arr i
                if w < 0x80
                  then B.runB be w op >>= go (i + 1)
                  else poke op w >> go (i + 1) (op `plusPtr` 1)
              | otherwise = loop i env (Buffer ope op)

#else
encodeUtf8BuilderEscaped :: forall s. Buildable s => BoundedPrim Word8 -> Text -> BuilderFor s
encodeUtf8BuilderEscaped BoundedPrim Word8
be = Text -> BuilderFor s
step where
  bound :: Int
bound = forall a. Ord a => a -> a -> a
max Int
4 forall a b. (a -> b) -> a -> b
$ forall a. BoundedPrim a -> Int
B.sizeBound BoundedPrim Word8
be

  step :: Text -> BuilderFor s
step (T.Text Array
arr Int
off Int
len) = forall s. (s -> Buffer -> IO Buffer) -> BuilderFor s
Builder forall a b. (a -> b) -> a -> b
$ Int -> s -> Buffer -> IO Buffer
loop Int
off where
    iend :: Int
iend = Int
off 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 forall a. Ord a => a -> a -> Bool
>= Int
iend       = forall (m :: * -> *) a. Monad m => a -> m a
return Buffer
br
      | Int
outRemaining forall a. Ord a => a -> a -> Bool
> Int
0 = Int -> IO Buffer
goPartial (Int
i0 forall a. Num a => a -> a -> a
+ forall a. Ord a => a -> a -> a
min Int
outRemaining Int
inpRemaining)
      | Bool
otherwise        = 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 forall a b. Ptr a -> Ptr b -> Int
`minusPtr` Ptr Word8
op0) forall a. Integral a => a -> a -> a
`div` Int
bound
        inpRemaining :: Int
inpRemaining = Int
iend 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 forall a. Ord a => a -> a -> Bool
< Int
iendTmp = case Array -> Int -> Word16
A.unsafeIndex Array
arr Int
i of
                  Word16
w | Word16
w forall a. Ord a => a -> a -> Bool
<= Word16
0x7F -> do
                        forall a. BoundedPrim a -> a -> Ptr Word8 -> IO (Ptr Word8)
B.runB BoundedPrim Word8
be (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
w) Ptr Word8
op forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Ptr Word8 -> IO Buffer
go (Int
i forall a. Num a => a -> a -> a
+ Int
1)
                    | Word16
w forall a. Ord a => a -> a -> Bool
<= Word16
0x7FF -> do
                        forall a. Integral a => Int -> a -> IO ()
poke8 Int
0 forall a b. (a -> b) -> a -> b
$ (Word16
w forall a. Bits a => a -> Int -> a
`shiftR` Int
6) forall a. Num a => a -> a -> a
+ Word16
0xC0
                        forall a. Integral a => Int -> a -> IO ()
poke8 Int
1 forall a b. (a -> b) -> a -> b
$ (Word16
w forall a. Bits a => a -> a -> a
.&. Word16
0x3f) forall a. Num a => a -> a -> a
+ Word16
0x80
                        Int -> Ptr Word8 -> IO Buffer
go (Int
i forall a. Num a => a -> a -> a
+ Int
1) (Ptr Word8
op forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
2)
                    | Word16
0xD800 forall a. Ord a => a -> a -> Bool
<= Word16
w Bool -> Bool -> Bool
&& Word16
w forall a. Ord a => a -> a -> Bool
<= Word16
0xDBFF -> do
                        let c :: Int
c = Char -> Int
ord forall a b. (a -> b) -> a -> b
$ Word16 -> Word16 -> Char
U16.chr2 Word16
w (Array -> Int -> Word16
A.unsafeIndex Array
arr (Int
iforall a. Num a => a -> a -> a
+Int
1))
                        forall a. Integral a => Int -> a -> IO ()
poke8 Int
0 forall a b. (a -> b) -> a -> b
$ (Int
c forall a. Bits a => a -> Int -> a
`shiftR` Int
18) forall a. Num a => a -> a -> a
+ Int
0xF0
                        forall a. Integral a => Int -> a -> IO ()
poke8 Int
1 forall a b. (a -> b) -> a -> b
$ ((Int
c forall a. Bits a => a -> Int -> a
`shiftR` Int
12) forall a. Bits a => a -> a -> a
.&. Int
0x3F) forall a. Num a => a -> a -> a
+ Int
0x80
                        forall a. Integral a => Int -> a -> IO ()
poke8 Int
2 forall a b. (a -> b) -> a -> b
$ ((Int
c forall a. Bits a => a -> Int -> a
`shiftR` Int
6) forall a. Bits a => a -> a -> a
.&. Int
0x3F) forall a. Num a => a -> a -> a
+ Int
0x80
                        forall a. Integral a => Int -> a -> IO ()
poke8 Int
3 forall a b. (a -> b) -> a -> b
$ (Int
c forall a. Bits a => a -> a -> a
.&. Int
0x3F) forall a. Num a => a -> a -> a
+ Int
0x80
                        Int -> Ptr Word8 -> IO Buffer
go (Int
i forall a. Num a => a -> a -> a
+ Int
2) (Ptr Word8
op forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
4)
                    | Bool
otherwise -> do
                        forall a. Integral a => Int -> a -> IO ()
poke8 Int
0 forall a b. (a -> b) -> a -> b
$ (Word16
w forall a. Bits a => a -> Int -> a
`shiftR` Int
12) forall a. Num a => a -> a -> a
+ Word16
0xE0
                        forall a. Integral a => Int -> a -> IO ()
poke8 Int
1 forall a b. (a -> b) -> a -> b
$ ((Word16
w forall a. Bits a => a -> Int -> a
`shiftR` Int
6) forall a. Bits a => a -> a -> a
.&. Word16
0x3F) forall a. Num a => a -> a -> a
+ Word16
0x80
                        forall a. Integral a => Int -> a -> IO ()
poke8 Int
2 forall a b. (a -> b) -> a -> b
$ (Word16
w forall a. Bits a => a -> a -> a
.&. Word16
0x3F) forall a. Num a => a -> a -> a
+ Word16
0x80
                        Int -> Ptr Word8 -> IO Buffer
go (Int
i forall a. Num a => a -> a -> a
+ Int
1) (Ptr Word8
op 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 :: forall a. Integral a => Int -> a -> IO ()
poke8 Int
j a
v = forall a. Storable a => Ptr a -> a -> IO ()
S.poke (Ptr Word8
op forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
j) (forall a b. (Integral a, Num b) => a -> b
fromIntegral a
v :: Word8)
#endif

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

{-# INLINE withGrisu3Rounded #-}
withGrisu3Rounded :: Int -> Double -> (Ptr Word8 -> Int -> Int -> IO r) -> IO r
withGrisu3Rounded :: forall r.
Int -> Double -> (Ptr Word8 -> Int -> Int -> IO r) -> IO r
withGrisu3Rounded Int
prec Double
val Ptr Word8 -> Int -> Int -> IO r
cont = forall r.
Double -> IO r -> (Ptr Word8 -> Int -> Int -> IO r) -> IO r
withGrisu3 Double
val (forall a. HasCallStack => String -> a
error String
"withGrisu3Rounded: failed") forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr Int
len Int
e -> do
  let len' :: Int
len' = 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 forall a. Num a => a -> a -> a
+ Int
1) else Ptr Word8 -> Int -> Int -> IO r
cont (Ptr Word8
ptr 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 forall a. Ord a => a -> a -> Bool
>= Int
len = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
roundDigit Int
prec Int
_ Ptr Word8
ptr = do
  Word8
rd <- forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Word8
ptr (Int
prec forall a. Num a => a -> a -> a
+ Int
1)
  let carry :: Int -> IO Bool
carry Int
0 = do
        forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word8
ptr Word8
49
        forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
      carry Int
i = do
        Word8
d <- forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Word8
ptr Int
i
        if Word8
d forall a. Eq a => a -> a -> Bool
== Word8
57
          then forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word8
ptr Int
i Word8
48 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> IO Bool
carry (Int
i forall a. Num a => a -> a -> a
- Int
1)
          else do
            forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word8
ptr Int
i (Word8
d forall a. Num a => a -> a -> a
+ Word8
1)
            forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  if Word8
rd forall a. Ord a => a -> a -> Bool
>= Word8
53
    then Int -> IO Bool
carry Int
prec
    else 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 forall a. Ord a => a -> a -> Bool
< Int
4096 = forall s. Buildable s => ByteString -> BuilderFor s
byteStringCopy ByteString
bs
    | Bool
otherwise = Builder
flush forall a. Semigroup a => a -> a -> a
<> forall s. (s -> Buffer -> IO Buffer) -> BuilderFor s
Builder (\StreamingBackend
env Buffer
b -> Buffer
b 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 = forall s. (s -> Buffer -> IO Buffer) -> BuilderFor s
Builder 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 <- forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef IORef (ForeignPtr Word8)
ref
    let len :: Int
len = forall a b. Ptr a -> Ptr b -> Int
minusPtr Ptr Word8
ptr Ptr Word8
ptr0
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
len forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$ ByteString -> IO ()
push forall a b. (a -> b) -> a -> b
$! Int -> (Ptr Word8 -> IO ()) -> ByteString
B.unsafeCreate Int
len 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
    forall (m :: * -> *) a. Monad m => a -> m a
return 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 = 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 <- forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
initialSize
  IORef (ForeignPtr Word8)
ref <- forall a. a -> IO (IORef a)
newIORef ForeignPtr Word8
fptr
  let ptr :: Ptr Word8
ptr = forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr ForeignPtr Word8
fptr
  Buffer Ptr Word8
_ Ptr Word8
ptr2 <- forall s. BuilderFor s -> s -> Buffer -> IO Buffer
unBuilder BuilderFor StreamingBackend
body
    ((ByteString -> IO ())
-> IORef (ForeignPtr Word8) -> StreamingBackend
StreamingBackend (Builder -> IO ()
write 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 forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
initialSize) Ptr Word8
ptr)
  ForeignPtr Word8
fptr' <- forall a. IORef a -> IO a
readIORef IORef (ForeignPtr Word8)
ref
  let ptr1 :: Ptr Word8
ptr1 = forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr ForeignPtr Word8
fptr'
  Builder -> IO ()
write forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
BB.byteString forall a b. (a -> b) -> a -> b
$ ForeignPtr Word8 -> Int -> Int -> ByteString
B.PS ForeignPtr Word8
fptr' Int
0 (forall a b. Ptr a -> Ptr b -> Int
minusPtr Ptr Word8
ptr2 Ptr Word8
ptr1)