{-# LANGUAGE CPP, BangPatterns #-}
module Blaze.ByteString.Builder.Internal.Write (
Poke(..)
, pokeN
, Write(..)
, runWrite
, getBound
, getBound'
, getPoke
, exactWrite
, boundedWrite
, writeLiftIO
, writeIf
, writeEq
, writeOrdering
, writeOrd
, fromWrite
, fromWriteSingleton
, fromWriteList
, writeStorable
, fromStorable
, fromStorables
) where
import Foreign
import qualified Data.Foldable as F
import Control.Monad
import Data.ByteString.Builder.Internal
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid (Monoid(..))
#endif
import Data.Semigroup (Semigroup(..))
newtype Poke =
Poke { Poke -> Ptr Word8 -> IO (Ptr Word8)
runPoke :: Ptr Word8 -> IO (Ptr Word8) }
data Write = Write {-# UNPACK #-} !Int Poke
{-# INLINE getPoke #-}
getPoke :: Write -> Poke
getPoke :: Write -> Poke
getPoke (Write Int
_ Poke
wio) = Poke
wio
{-# INLINE runWrite #-}
runWrite :: Write -> Ptr Word8 -> IO (Ptr Word8)
runWrite :: Write -> Ptr Word8 -> IO (Ptr Word8)
runWrite = Poke -> Ptr Word8 -> IO (Ptr Word8)
runPoke (Poke -> Ptr Word8 -> IO (Ptr Word8))
-> (Write -> Poke) -> Write -> Ptr Word8 -> IO (Ptr Word8)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Write -> Poke
getPoke
{-# INLINE getBound #-}
getBound :: Write -> Int
getBound :: Write -> Int
getBound (Write Int
bound Poke
_) = Int
bound
{-# INLINE getBound' #-}
getBound' :: String
-> (a -> Write)
-> Int
getBound' :: forall a. String -> (a -> Write) -> Int
getBound' String
msg a -> Write
write =
Write -> Int
getBound (Write -> Int) -> Write -> Int
forall a b. (a -> b) -> a -> b
$ a -> Write
write (a -> Write) -> a -> Write
forall a b. (a -> b) -> a -> b
$ String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$
String
"getBound' called from " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": write bound is not data-independent."
instance Semigroup Poke where
{-# INLINE (<>) #-}
(Poke Ptr Word8 -> IO (Ptr Word8)
po1) <> :: Poke -> Poke -> Poke
<> (Poke Ptr Word8 -> IO (Ptr Word8)
po2) = (Ptr Word8 -> IO (Ptr Word8)) -> Poke
Poke ((Ptr Word8 -> IO (Ptr Word8)) -> Poke)
-> (Ptr Word8 -> IO (Ptr Word8)) -> Poke
forall a b. (a -> b) -> a -> b
$ Ptr Word8 -> IO (Ptr Word8)
po1 (Ptr Word8 -> IO (Ptr Word8))
-> (Ptr Word8 -> IO (Ptr Word8)) -> Ptr Word8 -> IO (Ptr Word8)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Ptr Word8 -> IO (Ptr Word8)
po2
{-# INLINE sconcat #-}
sconcat :: NonEmpty Poke -> Poke
sconcat = (Poke -> Poke -> Poke) -> Poke -> NonEmpty Poke -> Poke
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
F.foldr Poke -> Poke -> Poke
forall a. Semigroup a => a -> a -> a
(<>) Poke
forall a. Monoid a => a
mempty
instance Monoid Poke where
{-# INLINE mempty #-}
mempty :: Poke
mempty = (Ptr Word8 -> IO (Ptr Word8)) -> Poke
Poke ((Ptr Word8 -> IO (Ptr Word8)) -> Poke)
-> (Ptr Word8 -> IO (Ptr Word8)) -> Poke
forall a b. (a -> b) -> a -> b
$ Ptr Word8 -> IO (Ptr Word8)
forall (m :: * -> *) a. Monad m => a -> m a
return
#if !(MIN_VERSION_base(4,11,0))
{-# INLINE mappend #-}
(Poke po1) `mappend` (Poke po2) = Poke $ po1 >=> po2
{-# INLINE mconcat #-}
mconcat = F.foldr mappend mempty
#endif
instance Semigroup Write where
{-# INLINE (<>) #-}
(Write Int
bound1 Poke
w1) <> :: Write -> Write -> Write
<> (Write Int
bound2 Poke
w2) =
Int -> Poke -> Write
Write (Int
bound1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
bound2) (Poke
w1 Poke -> Poke -> Poke
forall a. Semigroup a => a -> a -> a
<> Poke
w2)
{-# INLINE sconcat #-}
sconcat :: NonEmpty Write -> Write
sconcat = (Write -> Write -> Write) -> Write -> NonEmpty Write -> Write
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
F.foldr Write -> Write -> Write
forall a. Semigroup a => a -> a -> a
(<>) Write
forall a. Monoid a => a
mempty
instance Monoid Write where
{-# INLINE mempty #-}
mempty :: Write
mempty = Int -> Poke -> Write
Write Int
0 Poke
forall a. Monoid a => a
mempty
#if !(MIN_VERSION_base(4,11,0))
{-# INLINE mappend #-}
(Write bound1 w1) `mappend` (Write bound2 w2) =
Write (bound1 + bound2) (w1 `mappend` w2)
{-# INLINE mconcat #-}
mconcat = F.foldr mappend mempty
#endif
{-# INLINE pokeN #-}
pokeN :: Int
-> (Ptr Word8 -> IO ()) -> Poke
pokeN :: Int -> (Ptr Word8 -> IO ()) -> Poke
pokeN Int
size Ptr Word8 -> IO ()
io = (Ptr Word8 -> IO (Ptr Word8)) -> Poke
Poke ((Ptr Word8 -> IO (Ptr Word8)) -> Poke)
-> (Ptr Word8 -> IO (Ptr Word8)) -> Poke
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
op -> Ptr Word8 -> IO ()
io Ptr Word8
op IO () -> IO (Ptr Word8) -> IO (Ptr Word8)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (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
op Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
size))
{-# INLINE exactWrite #-}
exactWrite :: Int
-> (Ptr Word8 -> IO ())
-> Write
exactWrite :: Int -> (Ptr Word8 -> IO ()) -> Write
exactWrite Int
size Ptr Word8 -> IO ()
io = Int -> Poke -> Write
Write Int
size (Int -> (Ptr Word8 -> IO ()) -> Poke
pokeN Int
size Ptr Word8 -> IO ()
io)
{-# INLINE boundedWrite #-}
boundedWrite :: Int -> Poke -> Write
boundedWrite :: Int -> Poke -> Write
boundedWrite = Int -> Poke -> Write
Write
{-# INLINE writeLiftIO #-}
writeLiftIO :: (a -> Write) -> IO a -> Write
writeLiftIO :: forall a. (a -> Write) -> IO a -> Write
writeLiftIO a -> Write
write IO a
io =
Int -> Poke -> Write
Write (String -> (a -> Write) -> Int
forall a. String -> (a -> Write) -> Int
getBound' String
"writeLiftIO" a -> Write
write)
((Ptr Word8 -> IO (Ptr Word8)) -> Poke
Poke ((Ptr Word8 -> IO (Ptr Word8)) -> Poke)
-> (Ptr Word8 -> IO (Ptr Word8)) -> Poke
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
pf -> do a
x <- IO a
io; Write -> Ptr Word8 -> IO (Ptr Word8)
runWrite (a -> Write
write a
x) Ptr Word8
pf)
{-# INLINE writeIf #-}
writeIf :: (a -> Bool) -> (a -> Write) -> (a -> Write) -> (a -> Write)
writeIf :: forall a. (a -> Bool) -> (a -> Write) -> (a -> Write) -> a -> Write
writeIf a -> Bool
p a -> Write
wTrue a -> Write
wFalse a
x =
Int -> Poke -> Write
boundedWrite (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (Write -> Int
getBound (Write -> Int) -> Write -> Int
forall a b. (a -> b) -> a -> b
$ a -> Write
wTrue a
x) (Write -> Int
getBound (Write -> Int) -> Write -> Int
forall a b. (a -> b) -> a -> b
$ a -> Write
wFalse a
x))
(if a -> Bool
p a
x then Write -> Poke
getPoke (Write -> Poke) -> Write -> Poke
forall a b. (a -> b) -> a -> b
$ a -> Write
wTrue a
x else Write -> Poke
getPoke (Write -> Poke) -> Write -> Poke
forall a b. (a -> b) -> a -> b
$ a -> Write
wFalse a
x)
{-# INLINE writeEq #-}
writeEq :: Eq a => a -> (a -> Write) -> (a -> Write) -> (a -> Write)
writeEq :: forall a. Eq a => a -> (a -> Write) -> (a -> Write) -> a -> Write
writeEq a
test = (a -> Bool) -> (a -> Write) -> (a -> Write) -> a -> Write
forall a. (a -> Bool) -> (a -> Write) -> (a -> Write) -> a -> Write
writeIf (a
test a -> a -> Bool
forall a. Eq a => a -> a -> Bool
==)
{-# INLINE writeOrdering #-}
writeOrdering :: (a -> Ordering)
-> (a -> Write) -> (a -> Write) -> (a -> Write)
-> (a -> Write)
writeOrdering :: forall a.
(a -> Ordering)
-> (a -> Write) -> (a -> Write) -> (a -> Write) -> a -> Write
writeOrdering a -> Ordering
ord a -> Write
wLT a -> Write
wEQ a -> Write
wGT a
x =
Int -> Poke -> Write
boundedWrite Int
bound (case a -> Ordering
ord a
x of Ordering
LT -> Write -> Poke
getPoke (Write -> Poke) -> Write -> Poke
forall a b. (a -> b) -> a -> b
$ a -> Write
wLT a
x;
Ordering
EQ -> Write -> Poke
getPoke (Write -> Poke) -> Write -> Poke
forall a b. (a -> b) -> a -> b
$ a -> Write
wEQ a
x;
Ordering
GT -> Write -> Poke
getPoke (Write -> Poke) -> Write -> Poke
forall a b. (a -> b) -> a -> b
$ a -> Write
wGT a
x)
where
bound :: Int
bound = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (Write -> Int
getBound (Write -> Int) -> Write -> Int
forall a b. (a -> b) -> a -> b
$ a -> Write
wLT a
x) (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (Write -> Int
getBound (Write -> Int) -> Write -> Int
forall a b. (a -> b) -> a -> b
$ a -> Write
wEQ a
x) (Write -> Int
getBound (Write -> Int) -> Write -> Int
forall a b. (a -> b) -> a -> b
$ a -> Write
wGT a
x))
{-# INLINE writeOrd #-}
writeOrd :: Ord a
=> a
-> (a -> Write) -> (a -> Write) -> (a -> Write)
-> (a -> Write)
writeOrd :: forall a.
Ord a =>
a -> (a -> Write) -> (a -> Write) -> (a -> Write) -> a -> Write
writeOrd a
test = (a -> Ordering)
-> (a -> Write) -> (a -> Write) -> (a -> Write) -> a -> Write
forall a.
(a -> Ordering)
-> (a -> Write) -> (a -> Write) -> (a -> Write) -> a -> Write
writeOrdering (a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` a
test)
{-# INLINE fromWrite #-}
fromWrite :: Write -> Builder
fromWrite :: Write -> Builder
fromWrite (Write Int
maxSize Poke
wio) =
(forall r. BuildStep r -> BuildStep r) -> Builder
builder forall r. BuildStep r -> BuildStep r
step
where
step :: (BufferRange -> IO (BuildSignal a))
-> BufferRange -> IO (BuildSignal a)
step BufferRange -> IO (BuildSignal a)
k (BufferRange Ptr Word8
op Ptr Word8
ope)
| Ptr Word8
op Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
maxSize Ptr Word8 -> Ptr Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Ptr Word8
ope = do
Ptr Word8
op' <- Poke -> Ptr Word8 -> IO (Ptr Word8)
runPoke Poke
wio Ptr Word8
op
let !br' :: BufferRange
br' = Ptr Word8 -> Ptr Word8 -> BufferRange
BufferRange Ptr Word8
op' Ptr Word8
ope
BufferRange -> IO (BuildSignal a)
k BufferRange
br'
| Bool
otherwise = BuildSignal a -> IO (BuildSignal a)
forall (m :: * -> *) a. Monad m => a -> m a
return (BuildSignal a -> IO (BuildSignal a))
-> BuildSignal a -> IO (BuildSignal a)
forall a b. (a -> b) -> a -> b
$ Int
-> Ptr Word8
-> (BufferRange -> IO (BuildSignal a))
-> BuildSignal a
forall a. Int -> Ptr Word8 -> BuildStep a -> BuildSignal a
bufferFull Int
maxSize Ptr Word8
op ((BufferRange -> IO (BuildSignal a))
-> BufferRange -> IO (BuildSignal a)
step BufferRange -> IO (BuildSignal a)
k)
{-# INLINE fromWriteSingleton #-}
fromWriteSingleton :: (a -> Write) -> (a -> Builder)
fromWriteSingleton :: forall a. (a -> Write) -> a -> Builder
fromWriteSingleton a -> Write
write =
a -> Builder
mkBuilder
where
mkBuilder :: a -> Builder
mkBuilder a
x = (forall r. BuildStep r -> BuildStep r) -> Builder
builder forall r. BuildStep r -> BuildStep r
step
where
step :: (BufferRange -> IO (BuildSignal a))
-> BufferRange -> IO (BuildSignal a)
step BufferRange -> IO (BuildSignal a)
k (BufferRange Ptr Word8
op Ptr Word8
ope)
| Ptr Word8
op Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
maxSize Ptr Word8 -> Ptr Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Ptr Word8
ope = do
Ptr Word8
op' <- Poke -> Ptr Word8 -> IO (Ptr Word8)
runPoke Poke
wio Ptr Word8
op
let !br' :: BufferRange
br' = Ptr Word8 -> Ptr Word8 -> BufferRange
BufferRange Ptr Word8
op' Ptr Word8
ope
BufferRange -> IO (BuildSignal a)
k BufferRange
br'
| Bool
otherwise = BuildSignal a -> IO (BuildSignal a)
forall (m :: * -> *) a. Monad m => a -> m a
return (BuildSignal a -> IO (BuildSignal a))
-> BuildSignal a -> IO (BuildSignal a)
forall a b. (a -> b) -> a -> b
$ Int
-> Ptr Word8
-> (BufferRange -> IO (BuildSignal a))
-> BuildSignal a
forall a. Int -> Ptr Word8 -> BuildStep a -> BuildSignal a
bufferFull Int
maxSize Ptr Word8
op ((BufferRange -> IO (BuildSignal a))
-> BufferRange -> IO (BuildSignal a)
step BufferRange -> IO (BuildSignal a)
k)
where
Write Int
maxSize Poke
wio = a -> Write
write a
x
fromWriteList :: (a -> Write) -> [a] -> Builder
fromWriteList :: forall a. (a -> Write) -> [a] -> Builder
fromWriteList a -> Write
write =
[a] -> Builder
makeBuilder
where
makeBuilder :: [a] -> Builder
makeBuilder [a]
xs0 = (forall r. BuildStep r -> BuildStep r) -> Builder
builder ((forall r. BuildStep r -> BuildStep r) -> Builder)
-> (forall r. BuildStep r -> BuildStep r) -> Builder
forall a b. (a -> b) -> a -> b
$ [a]
-> (BufferRange -> IO (BuildSignal r))
-> BufferRange
-> IO (BuildSignal r)
forall {a}.
[a]
-> (BufferRange -> IO (BuildSignal a))
-> BufferRange
-> IO (BuildSignal a)
step [a]
xs0
where
step :: [a]
-> (BufferRange -> IO (BuildSignal a))
-> BufferRange
-> IO (BuildSignal a)
step [a]
xs1 BufferRange -> IO (BuildSignal a)
k !(BufferRange Ptr Word8
op0 Ptr Word8
ope0) = [a] -> Ptr Word8 -> IO (BuildSignal a)
go [a]
xs1 Ptr Word8
op0
where
go :: [a] -> Ptr Word8 -> IO (BuildSignal a)
go [] !Ptr Word8
op = do
let !br' :: BufferRange
br' = Ptr Word8 -> Ptr Word8 -> BufferRange
BufferRange Ptr Word8
op Ptr Word8
ope0
BufferRange -> IO (BuildSignal a)
k BufferRange
br'
go xs :: [a]
xs@(a
x':[a]
xs') !Ptr Word8
op
| Ptr Word8
op Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
maxSize Ptr Word8 -> Ptr Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Ptr Word8
ope0 = do
!Ptr Word8
op' <- Poke -> Ptr Word8 -> IO (Ptr Word8)
runPoke Poke
wio Ptr Word8
op
[a] -> Ptr Word8 -> IO (BuildSignal a)
go [a]
xs' Ptr Word8
op'
| Bool
otherwise = BuildSignal a -> IO (BuildSignal a)
forall (m :: * -> *) a. Monad m => a -> m a
return (BuildSignal a -> IO (BuildSignal a))
-> BuildSignal a -> IO (BuildSignal a)
forall a b. (a -> b) -> a -> b
$ Int
-> Ptr Word8
-> (BufferRange -> IO (BuildSignal a))
-> BuildSignal a
forall a. Int -> Ptr Word8 -> BuildStep a -> BuildSignal a
bufferFull Int
maxSize Ptr Word8
op ([a]
-> (BufferRange -> IO (BuildSignal a))
-> BufferRange
-> IO (BuildSignal a)
step [a]
xs BufferRange -> IO (BuildSignal a)
k)
where
Write Int
maxSize Poke
wio = a -> Write
write a
x'
{-# INLINE fromWriteList #-}
{-# INLINE writeStorable #-}
writeStorable :: Storable a => a -> Write
writeStorable :: forall a. Storable a => a -> Write
writeStorable a
x = Int -> (Ptr Word8 -> IO ()) -> Write
exactWrite (a -> Int
forall a. Storable a => a -> Int
sizeOf a
x) (\Ptr Word8
op -> 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
op) a
x)
{-# INLINE fromStorable #-}
fromStorable :: Storable a => a -> Builder
fromStorable :: forall a. Storable a => a -> Builder
fromStorable = (a -> Write) -> a -> Builder
forall a. (a -> Write) -> a -> Builder
fromWriteSingleton a -> Write
forall a. Storable a => a -> Write
writeStorable
fromStorables :: Storable a => [a] -> Builder
fromStorables :: forall a. Storable a => [a] -> Builder
fromStorables = (a -> Write) -> [a] -> Builder
forall a. (a -> Write) -> [a] -> Builder
fromWriteList a -> Write
forall a. Storable a => a -> Write
writeStorable