{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}

#ifndef MIN_VERSION_base
#define MIN_VERSION_base(x,y,z) 0
#endif

#ifndef MIN_VERSION_bytestring
#define MIN_VERSION_bytestring(x,y,z) 0
#endif

-----------------------------------------------------------------------------
-- |
-- Module      : Data.Serialize.Put
-- Copyright   : Lennart Kolmodin, Galois Inc. 2009
-- License     : BSD3-style (see LICENSE)
--
-- Maintainer  : Trevor Elliott <trevor@galois.com>
-- Stability   :
-- Portability :
--
-- The Put monad. A monad for efficiently constructing bytestrings.
--
-----------------------------------------------------------------------------

module Data.Serialize.Put (

    -- * The Put type
      Put
    , PutM(..)
    , Putter
    , runPut
    , runPutM
    , runPutLazy
    , runPutMLazy
    , runPutMBuilder
    , putBuilder
    , execPut

    -- * Flushing the implicit parse state
    , flush

    -- * Primitives
    , putWord8
    , putInt8
    , putByteString
    , putLazyByteString
    , putShortByteString

    -- * Big-endian primitives
    , putWord16be
    , putWord32be
    , putWord64be
    , putInt16be
    , putInt32be
    , putInt64be

    -- * Little-endian primitives
    , putWord16le
    , putWord32le
    , putWord64le
    , putInt16le
    , putInt32le
    , putInt64le

    -- * Host-endian, unaligned writes
    , putWordhost
    , putWord16host
    , putWord32host
    , putWord64host
    , putInthost
    , putInt16host
    , putInt32host
    , putInt64host

    -- * Containers
    , putTwoOf
    , putListOf
    , putIArrayOf
    , putSeqOf
    , putTreeOf
    , putMapOf
    , putIntMapOf
    , putSetOf
    , putIntSetOf
    , putMaybeOf
    , putEitherOf
    , putNested

  ) where


import           Data.ByteString.Builder (Builder, toLazyByteString)
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Builder.Extra as B
import qualified Data.ByteString.Short as BS

import qualified Control.Applicative as A
import Data.Array.Unboxed
#if MIN_VERSION_base(4,9,0)
import qualified Data.Semigroup as M
#endif
import qualified Data.Monoid as M
import qualified Data.Foldable as F
import Data.Word
import Data.Int
import qualified Data.ByteString        as S
import qualified Data.ByteString.Lazy   as L
import qualified Data.IntMap            as IntMap
import qualified Data.IntSet            as IntSet
import qualified Data.Map               as Map
import qualified Data.Sequence          as Seq
import qualified Data.Set               as Set
import qualified Data.Tree              as T

#if !(MIN_VERSION_base(4,8,0))
import Control.Applicative
import Data.Foldable (foldMap)
import Data.Monoid
#endif

#if !(MIN_VERSION_bytestring(0,10,0))
import Foreign.ForeignPtr (withForeignPtr)
import Foreign.Marshal.Utils (copyBytes)
import Foreign.Ptr (plusPtr)
import qualified Data.ByteString.Internal as S
import qualified Data.ByteString.Lazy.Internal as L
#endif

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

-- XXX Strict in builder only.
data PairS a = PairS a !Builder

sndS :: PairS a -> Builder
sndS :: PairS a -> Builder
sndS (PairS a
_ Builder
b) = Builder
b

-- | The PutM type. A Writer monad over the efficient Builder monoid.
newtype PutM a = Put { PutM a -> PairS a
unPut :: PairS a }

-- | Put merely lifts Builder into a Writer monad, applied to ().
type Put = PutM ()

type Putter a = a -> Put

instance Functor PutM where
        fmap :: (a -> b) -> PutM a -> PutM b
fmap a -> b
f PutM a
m = PairS b -> PutM b
forall a. PairS a -> PutM a
Put (PairS b -> PutM b) -> PairS b -> PutM b
forall a b. (a -> b) -> a -> b
$ let PairS a
a Builder
w = PutM a -> PairS a
forall a. PutM a -> PairS a
unPut PutM a
m in b -> Builder -> PairS b
forall a. a -> Builder -> PairS a
PairS (a -> b
f a
a) Builder
w
        {-# INLINE fmap #-}


instance A.Applicative PutM where
        pure :: a -> PutM a
pure a
a = PairS a -> PutM a
forall a. PairS a -> PutM a
Put (a -> Builder -> PairS a
forall a. a -> Builder -> PairS a
PairS a
a Builder
forall a. Monoid a => a
M.mempty)
        {-# INLINE pure #-}

        PutM (a -> b)
m <*> :: PutM (a -> b) -> PutM a -> PutM b
<*> PutM a
k = PairS b -> PutM b
forall a. PairS a -> PutM a
Put (PairS b -> PutM b) -> PairS b -> PutM b
forall a b. (a -> b) -> a -> b
$
            let PairS a -> b
f Builder
w  = PutM (a -> b) -> PairS (a -> b)
forall a. PutM a -> PairS a
unPut PutM (a -> b)
m
                PairS a
x Builder
w' = PutM a -> PairS a
forall a. PutM a -> PairS a
unPut PutM a
k
            in b -> Builder -> PairS b
forall a. a -> Builder -> PairS a
PairS (a -> b
f a
x) (Builder
w Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`M.mappend` Builder
w')
        {-# INLINE (<*>) #-}

        PutM a
m *> :: PutM a -> PutM b -> PutM b
*> PutM b
k  = PairS b -> PutM b
forall a. PairS a -> PutM a
Put (PairS b -> PutM b) -> PairS b -> PutM b
forall a b. (a -> b) -> a -> b
$
            let PairS a
_ Builder
w  = PutM a -> PairS a
forall a. PutM a -> PairS a
unPut PutM a
m
                PairS b
b Builder
w' = PutM b -> PairS b
forall a. PutM a -> PairS a
unPut PutM b
k
            in b -> Builder -> PairS b
forall a. a -> Builder -> PairS a
PairS b
b (Builder
w Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`M.mappend` Builder
w')
        {-# INLINE (*>) #-}


instance Monad PutM where
    return :: a -> PutM a
return = a -> PutM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    {-# INLINE return #-}

    PutM a
m >>= :: PutM a -> (a -> PutM b) -> PutM b
>>= a -> PutM b
k  = PairS b -> PutM b
forall a. PairS a -> PutM a
Put (PairS b -> PutM b) -> PairS b -> PutM b
forall a b. (a -> b) -> a -> b
$
        let PairS a
a Builder
w  = PutM a -> PairS a
forall a. PutM a -> PairS a
unPut PutM a
m
            PairS b
b Builder
w' = PutM b -> PairS b
forall a. PutM a -> PairS a
unPut (a -> PutM b
k a
a)
        in b -> Builder -> PairS b
forall a. a -> Builder -> PairS a
PairS b
b (Builder
w Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`M.mappend` Builder
w')
    {-# INLINE (>>=) #-}

    >> :: PutM a -> PutM b -> PutM b
(>>) = PutM a -> PutM b -> PutM b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)
    {-# INLINE (>>) #-}

#if MIN_VERSION_base(4,9,0)
instance M.Semigroup (PutM ()) where
    <> :: PutM () -> PutM () -> PutM ()
(<>) = PutM () -> PutM () -> PutM ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)
    {-# INLINE (<>) #-}
#endif

instance Monoid (PutM ()) where
    mempty :: PutM ()
mempty = () -> PutM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    {-# INLINE mempty #-}

#if !(MIN_VERSION_base(4,11,0))
    mappend = (*>)
    {-# INLINE mappend #-}
#endif

tell :: Putter Builder
tell :: Putter Builder
tell Builder
b = PairS () -> PutM ()
forall a. PairS a -> PutM a
Put (PairS () -> PutM ()) -> PairS () -> PutM ()
forall a b. (a -> b) -> a -> b
$! () -> Builder -> PairS ()
forall a. a -> Builder -> PairS a
PairS () Builder
b
{-# INLINE tell #-}

putBuilder :: Putter Builder
putBuilder :: Putter Builder
putBuilder = Putter Builder
tell
{-# INLINE putBuilder #-}

-- | Run the 'Put' monad
execPut :: PutM a -> Builder
execPut :: PutM a -> Builder
execPut = PairS a -> Builder
forall a. PairS a -> Builder
sndS (PairS a -> Builder) -> (PutM a -> PairS a) -> PutM a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PutM a -> PairS a
forall a. PutM a -> PairS a
unPut
{-# INLINE execPut #-}

-- | Run the 'Put' monad with a serialiser
runPut :: Put -> S.ByteString
runPut :: PutM () -> ByteString
runPut = ByteString -> ByteString
lazyToStrictByteString (ByteString -> ByteString)
-> (PutM () -> ByteString) -> PutM () -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PutM () -> ByteString
runPutLazy
{-# INLINE runPut #-}

-- | Run the 'Put' monad with a serialiser and get its result
runPutM :: PutM a -> (a, S.ByteString)
runPutM :: PutM a -> (a, ByteString)
runPutM (Put (PairS a
f Builder
s)) = (a
f, ByteString -> ByteString
lazyToStrictByteString (Builder -> ByteString
toLazyByteString Builder
s))
{-# INLINE runPutM #-}

-- | Run the 'Put' monad with a serialiser
runPutLazy :: Put -> L.ByteString
runPutLazy :: PutM () -> ByteString
runPutLazy = Builder -> ByteString
toLazyByteString (Builder -> ByteString)
-> (PutM () -> Builder) -> PutM () -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PairS () -> Builder
forall a. PairS a -> Builder
sndS (PairS () -> Builder)
-> (PutM () -> PairS ()) -> PutM () -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PutM () -> PairS ()
forall a. PutM a -> PairS a
unPut
{-# INLINE runPutLazy #-}

-- | Run the 'Put' monad with a serialiser
runPutMLazy :: PutM a -> (a, L.ByteString)
runPutMLazy :: PutM a -> (a, ByteString)
runPutMLazy (Put (PairS a
f Builder
s)) = (a
f, Builder -> ByteString
toLazyByteString Builder
s)
{-# INLINE runPutMLazy #-}

-- | Run the 'Put' monad and get the result and underlying 'Builder'
runPutMBuilder :: PutM a -> (a, Builder)
runPutMBuilder :: PutM a -> (a, Builder)
runPutMBuilder (Put (PairS a
f Builder
s)) = (a
f, Builder
s)
{-# INLINE runPutMBuilder #-}

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

-- | Pop the ByteString we have constructed so far, if any, yielding a
-- new chunk in the result ByteString.
flush               :: Put
flush :: PutM ()
flush               = Putter Builder
tell Builder
B.flush
{-# INLINE flush #-}

-- | Efficiently write a byte into the output buffer
putWord8            :: Putter Word8
putWord8 :: Putter Word8
putWord8            = Putter Builder
tell Putter Builder -> (Word8 -> Builder) -> Putter Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Builder
B.word8
{-# INLINE putWord8 #-}

-- | Efficiently write an int into the output buffer
putInt8             :: Putter Int8
putInt8 :: Putter Int8
putInt8             = Putter Builder
tell Putter Builder -> (Int8 -> Builder) -> Putter Int8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int8 -> Builder
B.int8
{-# INLINE putInt8 #-}

-- | An efficient primitive to write a strict ByteString into the output buffer.
-- It flushes the current buffer, and writes the argument into a new chunk.
putByteString       :: Putter S.ByteString
putByteString :: Putter ByteString
putByteString       = Putter Builder
tell Putter Builder -> (ByteString -> Builder) -> Putter ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
B.byteString
{-# INLINE putByteString #-}

putShortByteString  :: Putter BS.ShortByteString
putShortByteString :: Putter ShortByteString
putShortByteString   = Putter Builder
tell Putter Builder
-> (ShortByteString -> Builder) -> Putter ShortByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortByteString -> Builder
B.shortByteString

-- | Write a lazy ByteString efficiently, simply appending the lazy
-- ByteString chunks to the output buffer
putLazyByteString   :: Putter L.ByteString
putLazyByteString :: Putter ByteString
putLazyByteString   = Putter Builder
tell Putter Builder -> (ByteString -> Builder) -> Putter ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
B.lazyByteString
{-# INLINE putLazyByteString #-}

-- | Write a Word16 in big endian format
putWord16be         :: Putter Word16
putWord16be :: Putter Word16
putWord16be         = Putter Builder
tell Putter Builder -> (Word16 -> Builder) -> Putter Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Builder
B.word16BE
{-# INLINE putWord16be #-}

-- | Write a Word16 in little endian format
putWord16le         :: Putter Word16
putWord16le :: Putter Word16
putWord16le         = Putter Builder
tell Putter Builder -> (Word16 -> Builder) -> Putter Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Builder
B.word16LE
{-# INLINE putWord16le #-}

-- | Write a Word32 in big endian format
putWord32be         :: Putter Word32
putWord32be :: Putter Word32
putWord32be         = Putter Builder
tell Putter Builder -> (Word32 -> Builder) -> Putter Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Builder
B.word32BE
{-# INLINE putWord32be #-}

-- | Write a Word32 in little endian format
putWord32le         :: Putter Word32
putWord32le :: Putter Word32
putWord32le         = Putter Builder
tell Putter Builder -> (Word32 -> Builder) -> Putter Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Builder
B.word32LE
{-# INLINE putWord32le #-}

-- | Write a Word64 in big endian format
putWord64be         :: Putter Word64
putWord64be :: Putter Word64
putWord64be         = Putter Builder
tell Putter Builder -> (Word64 -> Builder) -> Putter Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Builder
B.word64BE
{-# INLINE putWord64be #-}

-- | Write a Word64 in little endian format
putWord64le         :: Putter Word64
putWord64le :: Putter Word64
putWord64le         = Putter Builder
tell Putter Builder -> (Word64 -> Builder) -> Putter Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Builder
B.word64LE
{-# INLINE putWord64le #-}

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

-- | /O(1)./ Write 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         :: Putter Word
putWordhost :: Putter Word
putWordhost         = Putter Builder
tell Putter Builder -> (Word -> Builder) -> Putter Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Builder
B.wordHost
{-# INLINE putWordhost #-}

-- | /O(1)./ Write a Word16 in native host order and host endianness.
-- For portability issues see @putWordhost@.
putWord16host       :: Putter Word16
putWord16host :: Putter Word16
putWord16host       = Putter Builder
tell Putter Builder -> (Word16 -> Builder) -> Putter Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Builder
B.word16Host
{-# INLINE putWord16host #-}

-- | /O(1)./ Write a Word32 in native host order and host endianness.
-- For portability issues see @putWordhost@.
putWord32host       :: Putter Word32
putWord32host :: Putter Word32
putWord32host       = Putter Builder
tell Putter Builder -> (Word32 -> Builder) -> Putter Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Builder
B.word32Host
{-# INLINE putWord32host #-}

-- | /O(1)./ Write a Word64 in native host order
-- On a 32 bit machine we write two host order Word32s, in big endian form.
-- For portability issues see @putWordhost@.
putWord64host       :: Putter Word64
putWord64host :: Putter Word64
putWord64host       = Putter Builder
tell Putter Builder -> (Word64 -> Builder) -> Putter Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Builder
B.word64Host
{-# INLINE putWord64host #-}

-- | Write a Int16 in big endian format
putInt16be         :: Putter Int16
putInt16be :: Putter Int16
putInt16be         = Putter Builder
tell Putter Builder -> (Int16 -> Builder) -> Putter Int16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int16 -> Builder
B.int16BE
{-# INLINE putInt16be #-}

-- | Write a Int16 in little endian format
putInt16le         :: Putter Int16
putInt16le :: Putter Int16
putInt16le         = Putter Builder
tell Putter Builder -> (Int16 -> Builder) -> Putter Int16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int16 -> Builder
B.int16LE
{-# INLINE putInt16le #-}

-- | Write a Int32 in big endian format
putInt32be         :: Putter Int32
putInt32be :: Putter Int32
putInt32be         = Putter Builder
tell Putter Builder -> (Int32 -> Builder) -> Putter Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Builder
B.int32BE
{-# INLINE putInt32be #-}

-- | Write a Int32 in little endian format
putInt32le         :: Putter Int32
putInt32le :: Putter Int32
putInt32le         = Putter Builder
tell Putter Builder -> (Int32 -> Builder) -> Putter Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Builder
B.int32LE
{-# INLINE putInt32le #-}

-- | Write a Int64 in big endian format
putInt64be         :: Putter Int64
putInt64be :: Putter Int64
putInt64be         = Putter Builder
tell Putter Builder -> (Int64 -> Builder) -> Putter Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Builder
B.int64BE
{-# INLINE putInt64be #-}

-- | Write a Int64 in little endian format
putInt64le         :: Putter Int64
putInt64le :: Putter Int64
putInt64le         = Putter Builder
tell Putter Builder -> (Int64 -> Builder) -> Putter Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Builder
B.int64LE
{-# INLINE putInt64le #-}

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

-- | /O(1)./ Write a single native machine int. The int is
-- written in host order, host endian form, for the machine you're on.
-- On a 64 bit machine the Int is an 8 byte value, on a 32 bit machine,
-- 4 bytes. Values written this way are not portable to
-- different endian or int sized machines, without conversion.
--
putInthost         :: Putter Int
putInthost :: Putter Int
putInthost         = Putter Builder
tell Putter Builder -> (Int -> Builder) -> Putter Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Builder
B.intHost
{-# INLINE putInthost #-}

-- | /O(1)./ Write a Int16 in native host order and host endianness.
-- For portability issues see @putInthost@.
putInt16host       :: Putter Int16
putInt16host :: Putter Int16
putInt16host       = Putter Builder
tell Putter Builder -> (Int16 -> Builder) -> Putter Int16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int16 -> Builder
B.int16Host
{-# INLINE putInt16host #-}

-- | /O(1)./ Write a Int32 in native host order and host endianness.
-- For portability issues see @putInthost@.
putInt32host       :: Putter Int32
putInt32host :: Putter Int32
putInt32host       = Putter Builder
tell Putter Builder -> (Int32 -> Builder) -> Putter Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Builder
B.int32Host
{-# INLINE putInt32host #-}

-- | /O(1)./ Write a Int64 in native host order
-- On a 32 bit machine we write two host order Int32s, in big endian form.
-- For portability issues see @putInthost@.
putInt64host       :: Putter Int64
putInt64host :: Putter Int64
putInt64host       = Putter Builder
tell Putter Builder -> (Int64 -> Builder) -> Putter Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Builder
B.int64Host
{-# INLINE putInt64host #-}


-- Containers ------------------------------------------------------------------

encodeListOf :: (a -> Builder) -> [a] -> Builder
encodeListOf :: (a -> Builder) -> [a] -> Builder
encodeListOf a -> Builder
f = -- allow inlining with just a single argument
    \[a]
xs ->  PutM () -> Builder
forall a. PutM a -> Builder
execPut (Putter Word64
putWord64be (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> Int -> Word64
forall a b. (a -> b) -> a -> b
$ [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs)) Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`M.mappend`
            (a -> Builder) -> [a] -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap a -> Builder
f [a]
xs
{-# INLINE encodeListOf #-}

putTwoOf :: Putter a -> Putter b -> Putter (a,b)
putTwoOf :: Putter a -> Putter b -> Putter (a, b)
putTwoOf Putter a
pa Putter b
pb (a
a,b
b) = Putter a
pa a
a PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter b
pb b
b
{-# INLINE putTwoOf #-}

putListOf :: Putter a -> Putter [a]
putListOf :: Putter a -> Putter [a]
putListOf Putter a
pa = \[a]
l -> do
  Putter Word64
putWord64be (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
l))
  Putter a -> Putter [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Putter a
pa [a]
l
{-# INLINE putListOf #-}

putIArrayOf :: (Ix i, IArray a e) => Putter i -> Putter e -> Putter (a i e)
putIArrayOf :: Putter i -> Putter e -> Putter (a i e)
putIArrayOf Putter i
pix Putter e
pe a i e
a = do
  Putter i -> Putter i -> Putter (i, i)
forall a b. Putter a -> Putter b -> Putter (a, b)
putTwoOf Putter i
pix Putter i
pix (a i e -> (i, i)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds a i e
a)
  Putter e -> Putter [e]
forall a. Putter a -> Putter [a]
putListOf Putter e
pe (a i e -> [e]
forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
elems a i e
a)
{-# INLINE putIArrayOf #-}

putSeqOf :: Putter a -> Putter (Seq.Seq a)
putSeqOf :: Putter a -> Putter (Seq a)
putSeqOf Putter a
pa = \Seq a
s -> do
    Putter Word64
putWord64be (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> Int -> Word64
forall a b. (a -> b) -> a -> b
$ Seq a -> Int
forall a. Seq a -> Int
Seq.length Seq a
s)
    Putter a -> Putter (Seq a)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
F.mapM_ Putter a
pa Seq a
s
{-# INLINE putSeqOf #-}

putTreeOf :: Putter a -> Putter (T.Tree a)
putTreeOf :: Putter a -> Putter (Tree a)
putTreeOf Putter a
pa =
    Putter Builder
tell Putter Builder -> (Tree a -> Builder) -> Putter (Tree a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree a -> Builder
go
  where
    go :: Tree a -> Builder
go (T.Node a
x [Tree a]
cs) = PutM () -> Builder
forall a. PutM a -> Builder
execPut (Putter a
pa a
x) Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`M.mappend` (Tree a -> Builder) -> [Tree a] -> Builder
forall a. (a -> Builder) -> [a] -> Builder
encodeListOf Tree a -> Builder
go [Tree a]
cs
{-# INLINE putTreeOf #-}

putMapOf :: Putter k -> Putter a -> Putter (Map.Map k a)
putMapOf :: Putter k -> Putter a -> Putter (Map k a)
putMapOf Putter k
pk Putter a
pa = Putter (k, a) -> Putter [(k, a)]
forall a. Putter a -> Putter [a]
putListOf (Putter k -> Putter a -> Putter (k, a)
forall a b. Putter a -> Putter b -> Putter (a, b)
putTwoOf Putter k
pk Putter a
pa) Putter [(k, a)] -> (Map k a -> [(k, a)]) -> Putter (Map k a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map k a -> [(k, a)]
forall k a. Map k a -> [(k, a)]
Map.toAscList
{-# INLINE putMapOf #-}

putIntMapOf :: Putter Int -> Putter a -> Putter (IntMap.IntMap a)
putIntMapOf :: Putter Int -> Putter a -> Putter (IntMap a)
putIntMapOf Putter Int
pix Putter a
pa = Putter (Int, a) -> Putter [(Int, a)]
forall a. Putter a -> Putter [a]
putListOf (Putter Int -> Putter a -> Putter (Int, a)
forall a b. Putter a -> Putter b -> Putter (a, b)
putTwoOf Putter Int
pix Putter a
pa) Putter [(Int, a)] -> (IntMap a -> [(Int, a)]) -> Putter (IntMap a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap a -> [(Int, a)]
forall a. IntMap a -> [(Int, a)]
IntMap.toAscList
{-# INLINE putIntMapOf #-}

putSetOf :: Putter a -> Putter (Set.Set a)
putSetOf :: Putter a -> Putter (Set a)
putSetOf Putter a
pa = Putter a -> Putter [a]
forall a. Putter a -> Putter [a]
putListOf Putter a
pa Putter [a] -> (Set a -> [a]) -> Putter (Set a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set a -> [a]
forall a. Set a -> [a]
Set.toAscList
{-# INLINE putSetOf #-}

putIntSetOf :: Putter Int -> Putter IntSet.IntSet
putIntSetOf :: Putter Int -> Putter IntSet
putIntSetOf Putter Int
pix = Putter Int -> Putter [Int]
forall a. Putter a -> Putter [a]
putListOf Putter Int
pix Putter [Int] -> (IntSet -> [Int]) -> Putter IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntSet -> [Int]
IntSet.toAscList
{-# INLINE putIntSetOf #-}

putMaybeOf :: Putter a -> Putter (Maybe a)
putMaybeOf :: Putter a -> Putter (Maybe a)
putMaybeOf Putter a
_  Maybe a
Nothing  = Putter Word8
putWord8 Word8
0
putMaybeOf Putter a
pa (Just a
a) = Putter Word8
putWord8 Word8
1 PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter a
pa a
a
{-# INLINE putMaybeOf #-}

putEitherOf :: Putter a -> Putter b -> Putter (Either a b)
putEitherOf :: Putter a -> Putter b -> Putter (Either a b)
putEitherOf Putter a
pa Putter b
_  (Left a
a)  = Putter Word8
putWord8 Word8
0 PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter a
pa a
a
putEitherOf Putter a
_  Putter b
pb (Right b
b) = Putter Word8
putWord8 Word8
1 PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter b
pb b
b
{-# INLINE putEitherOf #-}

-- | Put a nested structure by first putting a length
--   field and then putting the encoded value.
putNested :: Putter Int -> Put -> Put
putNested :: Putter Int -> PutM () -> PutM ()
putNested Putter Int
putLen PutM ()
putVal = do
    let bs :: ByteString
bs = PutM () -> ByteString
runPut PutM ()
putVal
    Putter Int
putLen (ByteString -> Int
S.length ByteString
bs)
    Putter ByteString
putByteString ByteString
bs

-------------------------------------------------------------------------------
-- pre-bytestring-0.10 compatibility
-------------------------------------------------------------------------------

{-# INLINE lazyToStrictByteString #-}
lazyToStrictByteString :: L.ByteString -> S.ByteString
#if MIN_VERSION_bytestring(0,10,0)
lazyToStrictByteString :: ByteString -> ByteString
lazyToStrictByteString = ByteString -> ByteString
L.toStrict
#else
lazyToStrictByteString = packChunks

-- packChunks is taken from the blaze-builder package.

-- | Pack the chunks of a lazy bytestring into a single strict bytestring.
packChunks :: L.ByteString -> S.ByteString
packChunks lbs = S.unsafeCreate (fromIntegral $ L.length lbs) (copyChunks lbs)
  where
    copyChunks !L.Empty                         !_pf = return ()
    copyChunks !(L.Chunk (S.PS fpbuf o l) lbs') !pf  = do
        withForeignPtr fpbuf $ \pbuf ->
            copyBytes pf (pbuf `plusPtr` o) l
        copyChunks lbs' (pf `plusPtr` l)
#endif