{-# LANGUAGE CPP, MagicHash #-}
-- for unboxed shifts

-----------------------------------------------------------------------------
-- |
-- Module      : Data.Binary.Builder
-- Copyright   : Lennart Kolmodin, Ross Paterson
-- License     : BSD3-style (see LICENSE)
-- 
-- Maintainer  : Lennart Kolmodin <kolmodin@dtek.chalmers.se>
-- Stability   : experimental
-- Portability : portable to Hugs and GHC
--
-- Efficient construction of lazy bytestrings.
--
-----------------------------------------------------------------------------

#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
#include "MachDeps.h"
#endif

module Data.Binary.Builder (

    -- * The Builder type
      Builder
    , toLazyByteString

    -- * Constructing Builders
    , empty
    , singleton
    , append
    , fromByteString        -- :: S.ByteString -> Builder
    , fromLazyByteString    -- :: L.ByteString -> Builder

    -- * Flushing the buffer state
    , flush

    -- * Derived Builders
    -- ** Big-endian writes
    , putWord16be           -- :: Word16 -> Builder
    , putWord32be           -- :: Word32 -> Builder
    , putWord64be           -- :: Word64 -> Builder

    -- ** Little-endian writes
    , putWord16le           -- :: Word16 -> Builder
    , putWord32le           -- :: Word32 -> Builder
    , putWord64le           -- :: Word64 -> Builder

    -- ** Host-endian, unaligned writes
    , putWordhost           -- :: Word -> Builder
    , putWord16host         -- :: Word16 -> Builder
    , putWord32host         -- :: Word32 -> Builder
    , putWord64host         -- :: Word64 -> Builder

  ) where

#if MIN_VERSION_base(4,8,0)
import Prelude hiding (empty)
#endif
import Foreign(Word,Word8,Ptr,Storable,ForeignPtr,withForeignPtr,poke,plusPtr,sizeOf)
import System.IO.Unsafe(unsafePerformIO)
import Data.Monoid
--import Data.Word
import qualified Data.ByteString      as S
import qualified Data.ByteString.Lazy as L

#ifdef BYTESTRING_IN_BASE
import Data.ByteString.Base (inlinePerformIO)
import qualified Data.ByteString.Base as S
#else
import Data.ByteString.Internal (accursedUnutterablePerformIO)
import qualified Data.ByteString.Internal as S
--import qualified Data.ByteString.Lazy.Internal as L
#endif

#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
import GHC.Base(Int(..),uncheckedShiftRL# )
import GHC.Word (Word32(..),Word16(..),Word64(..))

#if WORD_SIZE_IN_BITS < 64 && __GLASGOW_HASKELL__ >= 608
import GHC.Word (uncheckedShiftRL64#)
#endif
#endif

------------------------------------------------------------------------

-- | A 'Builder' is an efficient way to build lazy 'L.ByteString's.
-- There are several functions for constructing 'Builder's, but only one
-- to inspect them: to extract any data, you have to turn them into lazy
-- 'L.ByteString's using 'toLazyByteString'.
--
-- Internally, a 'Builder' constructs a lazy 'L.Bytestring' by filling byte
-- arrays piece by piece.  As each buffer is filled, it is \'popped\'
-- off, to become a new chunk of the resulting lazy 'L.ByteString'.
-- All this is hidden from the user of the 'Builder'.

newtype Builder = Builder {
        -- Invariant (from Data.ByteString.Lazy):
        --      The lists include no null ByteStrings.
        Builder -> (Buffer -> [ByteString]) -> Buffer -> [ByteString]
runBuilder :: (Buffer -> [S.ByteString]) -> Buffer -> [S.ByteString]
    }

#if MIN_VERSION_base(4,11,0)
instance Semigroup Builder where
  <> :: Builder -> Builder -> Builder
(<>) = Builder -> Builder -> Builder
append
#endif

instance Monoid Builder where
    mempty :: Builder
mempty  = Builder
empty
    {-# INLINE mempty #-}
    mappend :: Builder -> Builder -> Builder
mappend = Builder -> Builder -> Builder
append
    {-# INLINE mappend #-}

------------------------------------------------------------------------

-- | /O(1)./ The empty Builder, satisfying
--
--  * @'toLazyByteString' 'empty' = 'L.empty'@
--
empty :: Builder
empty :: Builder
empty = ((Buffer -> [ByteString]) -> Buffer -> [ByteString]) -> Builder
Builder (Buffer -> [ByteString]) -> Buffer -> [ByteString]
forall a. a -> a
id
{-# INLINE empty #-}

-- | /O(1)./ A Builder taking a single byte, satisfying
--
--  * @'toLazyByteString' ('singleton' b) = 'L.singleton' b@
--
singleton :: Word8 -> Builder
singleton :: Word8 -> Builder
singleton = Int -> (Ptr Word8 -> IO ()) -> Builder
writeN Int
1 ((Ptr Word8 -> IO ()) -> Builder)
-> (Word8 -> Ptr Word8 -> IO ()) -> Word8 -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ptr Word8 -> Word8 -> IO ()) -> Word8 -> Ptr Word8 -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke
{-# INLINE singleton #-}

------------------------------------------------------------------------

-- | /O(1)./ The concatenation of two Builders, an associative operation
-- with identity 'empty', satisfying
--
--  * @'toLazyByteString' ('append' x y) = 'L.append' ('toLazyByteString' x) ('toLazyByteString' y)@
--
append :: Builder -> Builder -> Builder
append :: Builder -> Builder -> Builder
append (Builder (Buffer -> [ByteString]) -> Buffer -> [ByteString]
f) (Builder (Buffer -> [ByteString]) -> Buffer -> [ByteString]
g) = ((Buffer -> [ByteString]) -> Buffer -> [ByteString]) -> Builder
Builder ((Buffer -> [ByteString]) -> Buffer -> [ByteString]
f ((Buffer -> [ByteString]) -> Buffer -> [ByteString])
-> ((Buffer -> [ByteString]) -> Buffer -> [ByteString])
-> (Buffer -> [ByteString])
-> Buffer
-> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Buffer -> [ByteString]) -> Buffer -> [ByteString]
g)
{-# INLINE append #-}

-- | /O(1)./ A Builder taking a 'S.ByteString', satisfying
--
--  * @'toLazyByteString' ('fromByteString' bs) = 'L.fromChunks' [bs]@
--
fromByteString :: S.ByteString -> Builder
fromByteString :: ByteString -> Builder
fromByteString ByteString
bs
  | ByteString -> Bool
S.null ByteString
bs = Builder
empty
  | Bool
otherwise = Builder
flush Builder -> Builder -> Builder
`append` ([ByteString] -> [ByteString]) -> Builder
mapBuilder (ByteString
bs ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:)
{-# INLINE fromByteString #-}

-- | /O(1)./ A Builder taking a lazy 'L.ByteString', satisfying
--
--  * @'toLazyByteString' ('fromLazyByteString' bs) = bs@
--
fromLazyByteString :: L.ByteString -> Builder
fromLazyByteString :: ByteString -> Builder
fromLazyByteString ByteString
bss = Builder
flush Builder -> Builder -> Builder
`append` ([ByteString] -> [ByteString]) -> Builder
mapBuilder (ByteString -> [ByteString]
L.toChunks ByteString
bss [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++)
{-# INLINE fromLazyByteString #-}

------------------------------------------------------------------------

-- Our internal buffer type
data Buffer = Buffer {-# UNPACK #-} !(ForeignPtr Word8)
                     {-# UNPACK #-} !Int                -- offset
                     {-# UNPACK #-} !Int                -- used bytes
                     {-# UNPACK #-} !Int                -- length left

------------------------------------------------------------------------

-- | /O(n)./ Extract a lazy 'L.ByteString' from a 'Builder'.
-- The construction work takes place if and when the relevant part of
-- the lazy 'L.ByteString' is demanded.
--
toLazyByteString :: Builder -> L.ByteString
toLazyByteString :: Builder -> ByteString
toLazyByteString Builder
m = [ByteString] -> ByteString
L.fromChunks ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ IO [ByteString] -> [ByteString]
forall a. IO a -> a
unsafePerformIO (IO [ByteString] -> [ByteString])
-> IO [ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ do
    Buffer
buf <- Int -> IO Buffer
newBuffer Int
defaultSize
    [ByteString] -> IO [ByteString]
forall (m :: * -> *) a. Monad m => a -> m a
return (Builder -> (Buffer -> [ByteString]) -> Buffer -> [ByteString]
runBuilder (Builder
m Builder -> Builder -> Builder
`append` Builder
flush) ([ByteString] -> Buffer -> [ByteString]
forall a b. a -> b -> a
const []) Buffer
buf)

-- | /O(1)./ Pop the 'S.ByteString' we have constructed so far, if any,
-- yielding a new chunk in the result lazy 'L.ByteString'.
flush :: Builder
flush :: Builder
flush = ((Buffer -> [ByteString]) -> Buffer -> [ByteString]) -> Builder
Builder (((Buffer -> [ByteString]) -> Buffer -> [ByteString]) -> Builder)
-> ((Buffer -> [ByteString]) -> Buffer -> [ByteString]) -> Builder
forall a b. (a -> b) -> a -> b
$ \ Buffer -> [ByteString]
k buf :: Buffer
buf@(Buffer ForeignPtr Word8
p Int
o Int
u Int
l) ->
    if Int
u Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
      then Buffer -> [ByteString]
k Buffer
buf
      else ForeignPtr Word8 -> Int -> Int -> ByteString
S.PS ForeignPtr Word8
p Int
o Int
u ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: Buffer -> [ByteString]
k (ForeignPtr Word8 -> Int -> Int -> Int -> Buffer
Buffer ForeignPtr Word8
p (Int
oInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
u) Int
0 Int
l)

------------------------------------------------------------------------

--
-- copied from Data.ByteString.Lazy
--
defaultSize :: Int
defaultSize :: Int
defaultSize = Int
32 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
overhead
    where k :: Int
k = Int
1024
          overhead :: Int
overhead = Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int -> Int
forall a. Storable a => a -> Int
sizeOf (Int
forall a. HasCallStack => a
undefined :: Int)

------------------------------------------------------------------------

-- | Sequence an IO operation on the buffer
unsafeLiftIO :: (Buffer -> IO Buffer) -> Builder
unsafeLiftIO :: (Buffer -> IO Buffer) -> Builder
unsafeLiftIO Buffer -> IO Buffer
f =  ((Buffer -> [ByteString]) -> Buffer -> [ByteString]) -> Builder
Builder (((Buffer -> [ByteString]) -> Buffer -> [ByteString]) -> Builder)
-> ((Buffer -> [ByteString]) -> Buffer -> [ByteString]) -> Builder
forall a b. (a -> b) -> a -> b
$ \ Buffer -> [ByteString]
k Buffer
buf -> IO [ByteString] -> [ByteString]
forall a. IO a -> a
accursedUnutterablePerformIO (IO [ByteString] -> [ByteString])
-> IO [ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ do
    Buffer
buf' <- Buffer -> IO Buffer
f Buffer
buf
    [ByteString] -> IO [ByteString]
forall (m :: * -> *) a. Monad m => a -> m a
return (Buffer -> [ByteString]
k Buffer
buf')
{-# INLINE unsafeLiftIO #-}

-- | Get the size of the buffer
withSize :: (Int -> Builder) -> Builder
withSize :: (Int -> Builder) -> Builder
withSize Int -> Builder
f = ((Buffer -> [ByteString]) -> Buffer -> [ByteString]) -> Builder
Builder (((Buffer -> [ByteString]) -> Buffer -> [ByteString]) -> Builder)
-> ((Buffer -> [ByteString]) -> Buffer -> [ByteString]) -> Builder
forall a b. (a -> b) -> a -> b
$ \ Buffer -> [ByteString]
k buf :: Buffer
buf@(Buffer ForeignPtr Word8
_ Int
_ Int
_ Int
l) ->
    Builder -> (Buffer -> [ByteString]) -> Buffer -> [ByteString]
runBuilder (Int -> Builder
f Int
l) Buffer -> [ByteString]
k Buffer
buf

-- | Map the resulting list of bytestrings.
mapBuilder :: ([S.ByteString] -> [S.ByteString]) -> Builder
mapBuilder :: ([ByteString] -> [ByteString]) -> Builder
mapBuilder [ByteString] -> [ByteString]
f = ((Buffer -> [ByteString]) -> Buffer -> [ByteString]) -> Builder
Builder ([ByteString] -> [ByteString]
f ([ByteString] -> [ByteString])
-> (Buffer -> [ByteString]) -> Buffer -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.)

------------------------------------------------------------------------

-- | Ensure that there are at least @n@ many bytes available.
ensureFree :: Int -> Builder
ensureFree :: Int -> Builder
ensureFree Int
n = Int
n Int -> Builder -> Builder
`seq` (Int -> Builder) -> Builder
withSize ((Int -> Builder) -> Builder) -> (Int -> Builder) -> Builder
forall a b. (a -> b) -> a -> b
$ \ Int
l ->
    if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
l then Builder
empty else
        Builder
flush Builder -> Builder -> Builder
`append` (Buffer -> IO Buffer) -> Builder
unsafeLiftIO (IO Buffer -> Buffer -> IO Buffer
forall a b. a -> b -> a
const (Int -> IO Buffer
newBuffer (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
n Int
defaultSize)))
{-# INLINE ensureFree #-}

-- | Ensure that @n@ many bytes are available, and then use @f@ to write some
-- bytes into the memory.
writeN :: Int -> (Ptr Word8 -> IO ()) -> Builder
writeN :: Int -> (Ptr Word8 -> IO ()) -> Builder
writeN Int
n Ptr Word8 -> IO ()
f = Int -> Builder
ensureFree Int
n Builder -> Builder -> Builder
`append` (Buffer -> IO Buffer) -> Builder
unsafeLiftIO (Int -> (Ptr Word8 -> IO ()) -> Buffer -> IO Buffer
writeNBuffer Int
n Ptr Word8 -> IO ()
f)
{-# INLINE writeN #-}

writeNBuffer :: Int -> (Ptr Word8 -> IO ()) -> Buffer -> IO Buffer
writeNBuffer :: Int -> (Ptr Word8 -> IO ()) -> Buffer -> IO Buffer
writeNBuffer Int
n Ptr Word8 -> IO ()
f (Buffer ForeignPtr Word8
fp Int
o Int
u Int
l) = do
    ForeignPtr Word8 -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fp (\Ptr Word8
p -> Ptr Word8 -> IO ()
f (Ptr Word8
p Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (Int
oInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
u)))
    Buffer -> IO Buffer
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignPtr Word8 -> Int -> Int -> Int -> Buffer
Buffer ForeignPtr Word8
fp Int
o (Int
uInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
n) (Int
lInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
n))
{-# INLINE writeNBuffer #-}

newBuffer :: Int -> IO Buffer
newBuffer :: Int -> IO Buffer
newBuffer Int
size = do
    ForeignPtr Word8
fp <- Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
S.mallocByteString Int
size
    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
$! ForeignPtr Word8 -> Int -> Int -> Int -> Buffer
Buffer ForeignPtr Word8
fp Int
0 Int
0 Int
size
{-# INLINE newBuffer #-}

------------------------------------------------------------------------
-- Aligned, host order writes of storable values

-- | Ensure that @n@ many bytes are available, and then use @f@ to write some
-- storable values into the memory.
writeNbytes :: Storable a => Int -> (Ptr a -> IO ()) -> Builder
writeNbytes :: Int -> (Ptr a -> IO ()) -> Builder
writeNbytes Int
n Ptr a -> IO ()
f = Int -> Builder
ensureFree Int
n Builder -> Builder -> Builder
`append` (Buffer -> IO Buffer) -> Builder
unsafeLiftIO (Int -> (Ptr a -> IO ()) -> Buffer -> IO Buffer
forall a.
Storable a =>
Int -> (Ptr a -> IO ()) -> Buffer -> IO Buffer
writeNBufferBytes Int
n Ptr a -> IO ()
f)
{-# INLINE writeNbytes #-}

writeNBufferBytes :: Storable a => Int -> (Ptr a -> IO ()) -> Buffer -> IO Buffer
writeNBufferBytes :: Int -> (Ptr a -> IO ()) -> Buffer -> IO Buffer
writeNBufferBytes Int
n Ptr a -> IO ()
f (Buffer ForeignPtr Word8
fp Int
o Int
u Int
l) = do
    ForeignPtr Word8 -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fp (\Ptr Word8
p -> Ptr a -> IO ()
f (Ptr Word8
p Ptr Word8 -> Int -> Ptr a
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (Int
oInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
u)))
    Buffer -> IO Buffer
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignPtr Word8 -> Int -> Int -> Int -> Buffer
Buffer ForeignPtr Word8
fp Int
o (Int
uInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
n) (Int
lInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
n))
{-# INLINE writeNBufferBytes #-}

------------------------------------------------------------------------

--
-- We rely on the fromIntegral to do the right masking for us.
-- The inlining here is critical, and can be worth 4x performance
--

-- | Write a Word16 in big endian format
putWord16be :: Word16 -> Builder
putWord16be :: Word16 -> Builder
putWord16be Word16
w = Int -> (Ptr Word8 -> IO ()) -> Builder
writeN Int
2 ((Ptr Word8 -> IO ()) -> Builder)
-> (Ptr Word8 -> IO ()) -> Builder
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p -> do
    Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word8
p               (Word16 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Int -> Word16
shiftr_w16 Word16
w Int
8) :: Word8)
    Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8
p Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
1) (Word16 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
w)              :: Word8)
{-# INLINE putWord16be #-}

-- | Write a Word16 in little endian format
putWord16le :: Word16 -> Builder
putWord16le :: Word16 -> Builder
putWord16le Word16
w = Int -> (Ptr Word8 -> IO ()) -> Builder
writeN Int
2 ((Ptr Word8 -> IO ()) -> Builder)
-> (Ptr Word8 -> IO ()) -> Builder
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p -> do
    Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word8
p               (Word16 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
w)              :: Word8)
    Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8
p Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
1) (Word16 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Int -> Word16
shiftr_w16 Word16
w Int
8) :: Word8)
{-# INLINE putWord16le #-}

-- putWord16le w16 = writeN 2 (\p -> poke (castPtr p) w16)

-- | Write a Word32 in big endian format
putWord32be :: Word32 -> Builder
putWord32be :: Word32 -> Builder
putWord32be Word32
w = Int -> (Ptr Word8 -> IO ()) -> Builder
writeN Int
4 ((Ptr Word8 -> IO ()) -> Builder)
-> (Ptr Word8 -> IO ()) -> Builder
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p -> do
    Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word8
p               (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int -> Word32
shiftr_w32 Word32
w Int
24) :: Word8)
    Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8
p Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
1) (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int -> Word32
shiftr_w32 Word32
w Int
16) :: Word8)
    Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8
p Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
2) (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int -> Word32
shiftr_w32 Word32
w  Int
8) :: Word8)
    Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8
p Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
3) (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
w)               :: Word8)
{-# INLINE putWord32be #-}

--
-- a data type to tag Put/Check. writes construct these which are then
-- inlined and flattened. matching Checks will be more robust with rules.
--

-- | Write a Word32 in little endian format
putWord32le :: Word32 -> Builder
putWord32le :: Word32 -> Builder
putWord32le Word32
w = Int -> (Ptr Word8 -> IO ()) -> Builder
writeN Int
4 ((Ptr Word8 -> IO ()) -> Builder)
-> (Ptr Word8 -> IO ()) -> Builder
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p -> do
    Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word8
p               (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
w)               :: Word8)
    Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8
p Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
1) (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int -> Word32
shiftr_w32 Word32
w  Int
8) :: Word8)
    Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8
p Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
2) (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int -> Word32
shiftr_w32 Word32
w Int
16) :: Word8)
    Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8
p Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
3) (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int -> Word32
shiftr_w32 Word32
w Int
24) :: Word8)
{-# INLINE putWord32le #-}

-- on a little endian machine:
-- putWord32le w32 = writeN 4 (\p -> poke (castPtr p) w32)

-- | Write a Word64 in big endian format
putWord64be :: Word64 -> Builder
#if WORD_SIZE_IN_BITS < 64
--
-- To avoid expensive 64 bit shifts on 32 bit machines, we cast to
-- Word32, and write that
--
putWord64be w =
    let a = fromIntegral (shiftr_w64 w 32) :: Word32
        b = fromIntegral w                 :: Word32
    in writeN 8 $ \p -> do
    poke p               (fromIntegral (shiftr_w32 a 24) :: Word8)
    poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 a 16) :: Word8)
    poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 a  8) :: Word8)
    poke (p `plusPtr` 3) (fromIntegral (a)               :: Word8)
    poke (p `plusPtr` 4) (fromIntegral (shiftr_w32 b 24) :: Word8)
    poke (p `plusPtr` 5) (fromIntegral (shiftr_w32 b 16) :: Word8)
    poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b  8) :: Word8)
    poke (p `plusPtr` 7) (fromIntegral (b)               :: Word8)
#else
putWord64be :: Word64 -> Builder
putWord64be Word64
w = Int -> (Ptr Word8 -> IO ()) -> Builder
writeN Int
8 ((Ptr Word8 -> IO ()) -> Builder)
-> (Ptr Word8 -> IO ()) -> Builder
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p -> do
    Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word8
p               (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int -> Word64
shiftr_w64 Word64
w Int
56) :: Word8)
    Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8
p Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
1) (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int -> Word64
shiftr_w64 Word64
w Int
48) :: Word8)
    Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8
p Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
2) (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int -> Word64
shiftr_w64 Word64
w Int
40) :: Word8)
    Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8
p Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
3) (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int -> Word64
shiftr_w64 Word64
w Int
32) :: Word8)
    Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8
p Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
4) (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int -> Word64
shiftr_w64 Word64
w Int
24) :: Word8)
    Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8
p Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
5) (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int -> Word64
shiftr_w64 Word64
w Int
16) :: Word8)
    Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8
p Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
6) (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int -> Word64
shiftr_w64 Word64
w  Int
8) :: Word8)
    Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8
p Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
7) (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
w)               :: Word8)
#endif
{-# INLINE putWord64be #-}

-- | Write a Word64 in little endian format
putWord64le :: Word64 -> Builder

#if WORD_SIZE_IN_BITS < 64
putWord64le w =
    let b = fromIntegral (shiftr_w64 w 32) :: Word32
        a = fromIntegral w                 :: Word32
    in writeN 8 $ \p -> do
    poke (p)             (fromIntegral (a)               :: Word8)
    poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 a  8) :: Word8)
    poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 a 16) :: Word8)
    poke (p `plusPtr` 3) (fromIntegral (shiftr_w32 a 24) :: Word8)
    poke (p `plusPtr` 4) (fromIntegral (b)               :: Word8)
    poke (p `plusPtr` 5) (fromIntegral (shiftr_w32 b  8) :: Word8)
    poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b 16) :: Word8)
    poke (p `plusPtr` 7) (fromIntegral (shiftr_w32 b 24) :: Word8)
#else
putWord64le :: Word64 -> Builder
putWord64le Word64
w = Int -> (Ptr Word8 -> IO ()) -> Builder
writeN Int
8 ((Ptr Word8 -> IO ()) -> Builder)
-> (Ptr Word8 -> IO ()) -> Builder
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p -> do
    Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word8
p               (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
w)               :: Word8)
    Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8
p Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
1) (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int -> Word64
shiftr_w64 Word64
w  Int
8) :: Word8)
    Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8
p Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
2) (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int -> Word64
shiftr_w64 Word64
w Int
16) :: Word8)
    Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8
p Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
3) (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int -> Word64
shiftr_w64 Word64
w Int
24) :: Word8)
    Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8
p Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
4) (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int -> Word64
shiftr_w64 Word64
w Int
32) :: Word8)
    Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8
p Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
5) (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int -> Word64
shiftr_w64 Word64
w Int
40) :: Word8)
    Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8
p Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
6) (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int -> Word64
shiftr_w64 Word64
w Int
48) :: Word8)
    Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8
p Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
7) (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int -> Word64
shiftr_w64 Word64
w Int
56) :: Word8)
#endif
{-# INLINE putWord64le #-}

-- on a little endian machine:
-- putWord64le w64 = writeN 8 (\p -> poke (castPtr p) w64)

------------------------------------------------------------------------
-- Unaligned, word size ops

-- | /O(1)./ A Builder taking a single native machine word. The word is
-- written in host order, host endian form, for the machine you're on.
-- On a 64 bit machine the Word is an 8 byte value, on a 32 bit machine,
-- 4 bytes. Values written this way are not portable to
-- different endian or word sized machines, without conversion.
--
putWordhost :: Word -> Builder
putWordhost :: Word -> Builder
putWordhost Word
w = Int -> (Ptr Word -> IO ()) -> Builder
forall a. Storable a => Int -> (Ptr a -> IO ()) -> Builder
writeNbytes (Word -> Int
forall a. Storable a => a -> Int
sizeOf (Word
forall a. HasCallStack => a
undefined :: Word)) (\Ptr Word
p -> Ptr Word -> Word -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word
p Word
w)
{-# INLINE putWordhost #-}

-- | Write a Word16 in native host order and host endianness.
-- 2 bytes will be written, unaligned.
putWord16host :: Word16 -> Builder
putWord16host :: Word16 -> Builder
putWord16host Word16
w16 = Int -> (Ptr Word16 -> IO ()) -> Builder
forall a. Storable a => Int -> (Ptr a -> IO ()) -> Builder
writeNbytes (Word16 -> Int
forall a. Storable a => a -> Int
sizeOf (Word16
forall a. HasCallStack => a
undefined :: Word16)) (\Ptr Word16
p -> Ptr Word16 -> Word16 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word16
p Word16
w16)
{-# INLINE putWord16host #-}

-- | Write a Word32 in native host order and host endianness.
-- 4 bytes will be written, unaligned.
putWord32host :: Word32 -> Builder
putWord32host :: Word32 -> Builder
putWord32host Word32
w32 = Int -> (Ptr Word32 -> IO ()) -> Builder
forall a. Storable a => Int -> (Ptr a -> IO ()) -> Builder
writeNbytes (Word32 -> Int
forall a. Storable a => a -> Int
sizeOf (Word32
forall a. HasCallStack => a
undefined :: Word32)) (\Ptr Word32
p -> Ptr Word32 -> Word32 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word32
p Word32
w32)
{-# INLINE putWord32host #-}

-- | Write a Word64 in native host order.
-- On a 32 bit machine we write two host order Word32s, in big endian form.
-- 8 bytes will be written, unaligned.
putWord64host :: Word64 -> Builder
putWord64host :: Word64 -> Builder
putWord64host Word64
w = Int -> (Ptr Word64 -> IO ()) -> Builder
forall a. Storable a => Int -> (Ptr a -> IO ()) -> Builder
writeNbytes (Word64 -> Int
forall a. Storable a => a -> Int
sizeOf (Word64
forall a. HasCallStack => a
undefined :: Word64)) (\Ptr Word64
p -> Ptr Word64 -> Word64 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word64
p Word64
w)
{-# INLINE putWord64host #-}

------------------------------------------------------------------------
-- Unchecked shifts

{-# INLINE shiftr_w16 #-}
shiftr_w16 :: Word16 -> Int -> Word16
{-# INLINE shiftr_w32 #-}
shiftr_w32 :: Word32 -> Int -> Word32
{-# INLINE shiftr_w64 #-}
shiftr_w64 :: Word64 -> Int -> Word64

#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
shiftr_w16 :: Word16 -> Int -> Word16
shiftr_w16 (W16# Word#
w) (I# Int#
i) = Word# -> Word16
W16# (Word#
w Word# -> Int# -> Word#
`uncheckedShiftRL#`   Int#
i)
shiftr_w32 :: Word32 -> Int -> Word32
shiftr_w32 (W32# Word#
w) (I# Int#
i) = Word# -> Word32
W32# (Word#
w Word# -> Int# -> Word#
`uncheckedShiftRL#`   Int#
i)

#if WORD_SIZE_IN_BITS < 64
shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL64#` i)

#if __GLASGOW_HASKELL__ <= 606
-- Exported by GHC.Word in GHC 6.8 and higher
foreign import ccall unsafe "stg_uncheckedShiftRL64"
    uncheckedShiftRL64#     :: Word64# -> Int# -> Word64#
#endif

#else
shiftr_w64 :: Word64 -> Int -> Word64
shiftr_w64 (W64# Word#
w) (I# Int#
i) = Word# -> Word64
W64# (Word#
w Word# -> Int# -> Word#
`uncheckedShiftRL#` Int#
i)
#endif

#else
shiftr_w16 = shiftR
shiftr_w32 = shiftR
shiftr_w64 = shiftR
#endif