{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE Safe #-}
#if MIN_VERSION_base(4,9,0)
#define HAS_SEMIGROUP
#endif
module Data.Binary.Put (
    
      Put
    , PutM(..)
    , runPut
    , runPutM
    , putBuilder
    , execPut
    
    , flush
    
    , putWord8
    , putInt8
    , putByteString
    , putLazyByteString
#if MIN_VERSION_bytestring(0,10,4)
    , putShortByteString
#endif
    
    , putWord16be
    , putWord32be
    , putWord64be
    , putInt16be
    , putInt32be
    , putInt64be
    , putFloatbe
    , putDoublebe
    
    , putWord16le
    , putWord32le
    , putWord64le
    , putInt16le
    , putInt32le
    , putInt64le
    , putFloatle
    , putDoublele
    
    , putWordhost           
    , putWord16host         
    , putWord32host         
    , putWord64host         
    , putInthost            
    , putInt16host          
    , putInt32host          
    , putInt64host          
    , putFloathost
    , putDoublehost
    
    , putCharUtf8
    , putStringUtf8
  ) where
import qualified Data.Monoid as Monoid
import Data.Binary.Builder (Builder, toLazyByteString)
import qualified Data.Binary.Builder as B
import Data.Int
import Data.Word
import qualified Data.ByteString      as S
import qualified Data.ByteString.Lazy as L
#if MIN_VERSION_bytestring(0,10,4)
import Data.ByteString.Short
#endif
#ifdef HAS_SEMIGROUP
import Data.Semigroup
#endif
import Control.Applicative
import Prelude 
import Data.Binary.FloatCast (floatToWord, doubleToWord)
data PairS a = PairS a !Builder
sndS :: PairS a -> Builder
sndS :: forall a. PairS a -> Builder
sndS (PairS a
_ Builder
b) = Builder
b
newtype PutM a = Put { forall a. PutM a -> PairS a
unPut :: PairS a }
type Put = PutM ()
instance Functor PutM where
        fmap :: forall a b. (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 Applicative PutM where
        pure :: forall a. a -> PutM a
pure a
a  = PairS a -> PutM a
forall a. PairS a -> PutM a
Put (PairS a -> PutM a) -> PairS a -> PutM a
forall a b. (a -> b) -> a -> b
$ a -> Builder -> PairS a
forall a. a -> Builder -> PairS a
PairS a
a Builder
forall a. Monoid a => a
Monoid.mempty
        {-# INLINE pure #-}
        PutM (a -> b)
m <*> :: forall a b. 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
`Monoid.mappend` Builder
w')
        PutM a
m *> :: forall a b. 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
`Monoid.mappend` Builder
w')
        {-# INLINE (*>) #-}
instance Monad PutM where
    PutM a
m >>= :: forall a b. 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
`Monoid.mappend` Builder
w')
    {-# INLINE (>>=) #-}
    return :: forall a. a -> PutM a
return = a -> PutM a
forall a. a -> PutM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    {-# INLINE return #-}
    >> :: forall a b. PutM a -> PutM b -> PutM b
(>>) = PutM a -> PutM b -> PutM b
forall a b. PutM a -> PutM b -> PutM b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)
    {-# INLINE (>>) #-}
instance Monoid.Monoid (PutM ()) where
    mempty :: PutM ()
mempty = () -> PutM ()
forall a. a -> PutM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    {-# INLINE mempty #-}
#ifdef HAS_SEMIGROUP
    mappend :: PutM () -> PutM () -> PutM ()
mappend = PutM () -> PutM () -> PutM ()
forall a. Semigroup a => a -> a -> a
(<>)
#else
    mappend = mappend'
#endif
    {-# INLINE mappend #-}
mappend' :: Put -> Put -> Put
mappend' :: PutM () -> PutM () -> PutM ()
mappend' PutM ()
m PutM ()
k = PairS () -> PutM ()
forall a. PairS a -> PutM a
Put (PairS () -> PutM ()) -> PairS () -> PutM ()
forall a b. (a -> b) -> a -> b
$
    let PairS ()
_ Builder
w  = PutM () -> PairS ()
forall a. PutM a -> PairS a
unPut PutM ()
m
        PairS ()
_ Builder
w' = PutM () -> PairS ()
forall a. PutM a -> PairS a
unPut PutM ()
k
    in () -> Builder -> PairS ()
forall a. a -> Builder -> PairS a
PairS () (Builder
w Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`Monoid.mappend` Builder
w')
{-# INLINE mappend' #-}
#ifdef HAS_SEMIGROUP
instance Semigroup (PutM ()) where
    <> :: PutM () -> PutM () -> PutM ()
(<>) = PutM () -> PutM () -> PutM ()
mappend'
    {-# INLINE (<>) #-}
#endif
tell :: Builder -> Put
tell :: Builder -> PutM ()
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 :: Builder -> Put
putBuilder :: Builder -> PutM ()
putBuilder = Builder -> PutM ()
tell
{-# INLINE putBuilder #-}
execPut :: PutM a -> Builder
execPut :: forall a. 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 #-}
runPut :: Put -> L.ByteString
runPut :: PutM () -> ByteString
runPut = 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 runPut #-}
runPutM :: PutM a -> (a, L.ByteString)
runPutM :: forall a. PutM a -> (a, ByteString)
runPutM (Put (PairS a
f Builder
s)) = (a
f, Builder -> ByteString
toLazyByteString Builder
s)
{-# INLINE runPutM #-}
flush               :: Put
flush :: PutM ()
flush               = Builder -> PutM ()
tell Builder
B.flush
{-# INLINE flush #-}
putWord8            :: Word8 -> Put
putWord8 :: Word8 -> PutM ()
putWord8            = Builder -> PutM ()
tell (Builder -> PutM ()) -> (Word8 -> Builder) -> Word8 -> PutM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Builder
B.singleton
{-# INLINE putWord8 #-}
putInt8            :: Int8 -> Put
putInt8 :: Int8 -> PutM ()
putInt8            = Builder -> PutM ()
tell (Builder -> PutM ()) -> (Int8 -> Builder) -> Int8 -> PutM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Builder
B.singleton (Word8 -> Builder) -> (Int8 -> Word8) -> Int8 -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int8 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral
{-# INLINE putInt8 #-}
putByteString       :: S.ByteString -> Put
putByteString :: ByteString -> PutM ()
putByteString       = Builder -> PutM ()
tell (Builder -> PutM ())
-> (ByteString -> Builder) -> ByteString -> PutM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
B.fromByteString
{-# INLINE putByteString #-}
putLazyByteString   :: L.ByteString -> Put
putLazyByteString :: ByteString -> PutM ()
putLazyByteString   = Builder -> PutM ()
tell (Builder -> PutM ())
-> (ByteString -> Builder) -> ByteString -> PutM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
B.fromLazyByteString
{-# INLINE putLazyByteString #-}
#if MIN_VERSION_bytestring(0,10,4)
putShortByteString :: ShortByteString -> Put
putShortByteString :: ShortByteString -> PutM ()
putShortByteString = Builder -> PutM ()
tell (Builder -> PutM ())
-> (ShortByteString -> Builder) -> ShortByteString -> PutM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortByteString -> Builder
B.fromShortByteString
{-# INLINE putShortByteString #-}
#endif
putWord16be         :: Word16 -> Put
putWord16be :: Word16 -> PutM ()
putWord16be         = Builder -> PutM ()
tell (Builder -> PutM ()) -> (Word16 -> Builder) -> Word16 -> PutM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Builder
B.putWord16be
{-# INLINE putWord16be #-}
putWord16le         :: Word16 -> Put
putWord16le :: Word16 -> PutM ()
putWord16le         = Builder -> PutM ()
tell (Builder -> PutM ()) -> (Word16 -> Builder) -> Word16 -> PutM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Builder
B.putWord16le
{-# INLINE putWord16le #-}
putWord32be         :: Word32 -> Put
putWord32be :: Word32 -> PutM ()
putWord32be         = Builder -> PutM ()
tell (Builder -> PutM ()) -> (Word32 -> Builder) -> Word32 -> PutM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Builder
B.putWord32be
{-# INLINE putWord32be #-}
putWord32le         :: Word32 -> Put
putWord32le :: Word32 -> PutM ()
putWord32le         = Builder -> PutM ()
tell (Builder -> PutM ()) -> (Word32 -> Builder) -> Word32 -> PutM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Builder
B.putWord32le
{-# INLINE putWord32le #-}
putWord64be         :: Word64 -> Put
putWord64be :: Word64 -> PutM ()
putWord64be         = Builder -> PutM ()
tell (Builder -> PutM ()) -> (Word64 -> Builder) -> Word64 -> PutM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Builder
B.putWord64be
{-# INLINE putWord64be #-}
putWord64le         :: Word64 -> Put
putWord64le :: Word64 -> PutM ()
putWord64le         = Builder -> PutM ()
tell (Builder -> PutM ()) -> (Word64 -> Builder) -> Word64 -> PutM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Builder
B.putWord64le
{-# INLINE putWord64le #-}
putInt16be         :: Int16 -> Put
putInt16be :: Int16 -> PutM ()
putInt16be         = Builder -> PutM ()
tell (Builder -> PutM ()) -> (Int16 -> Builder) -> Int16 -> PutM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int16 -> Builder
B.putInt16be
{-# INLINE putInt16be #-}
putInt16le         :: Int16 -> Put
putInt16le :: Int16 -> PutM ()
putInt16le         = Builder -> PutM ()
tell (Builder -> PutM ()) -> (Int16 -> Builder) -> Int16 -> PutM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int16 -> Builder
B.putInt16le
{-# INLINE putInt16le #-}
putInt32be         :: Int32 -> Put
putInt32be :: Int32 -> PutM ()
putInt32be         = Builder -> PutM ()
tell (Builder -> PutM ()) -> (Int32 -> Builder) -> Int32 -> PutM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Builder
B.putInt32be
{-# INLINE putInt32be #-}
putInt32le         :: Int32 -> Put
putInt32le :: Int32 -> PutM ()
putInt32le         = Builder -> PutM ()
tell (Builder -> PutM ()) -> (Int32 -> Builder) -> Int32 -> PutM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Builder
B.putInt32le
{-# INLINE putInt32le #-}
putInt64be         :: Int64 -> Put
putInt64be :: Int64 -> PutM ()
putInt64be         = Builder -> PutM ()
tell (Builder -> PutM ()) -> (Int64 -> Builder) -> Int64 -> PutM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Builder
B.putInt64be
{-# INLINE putInt64be #-}
putInt64le         :: Int64 -> Put
putInt64le :: Int64 -> PutM ()
putInt64le         = Builder -> PutM ()
tell (Builder -> PutM ()) -> (Int64 -> Builder) -> Int64 -> PutM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Builder
B.putInt64le
{-# INLINE putInt64le #-}
putWordhost         :: Word -> Put
putWordhost :: Word -> PutM ()
putWordhost         = Builder -> PutM ()
tell (Builder -> PutM ()) -> (Word -> Builder) -> Word -> PutM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Builder
B.putWordhost
{-# INLINE putWordhost #-}
putWord16host       :: Word16 -> Put
putWord16host :: Word16 -> PutM ()
putWord16host       = Builder -> PutM ()
tell (Builder -> PutM ()) -> (Word16 -> Builder) -> Word16 -> PutM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Builder
B.putWord16host
{-# INLINE putWord16host #-}
putWord32host       :: Word32 -> Put
putWord32host :: Word32 -> PutM ()
putWord32host       = Builder -> PutM ()
tell (Builder -> PutM ()) -> (Word32 -> Builder) -> Word32 -> PutM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Builder
B.putWord32host
{-# INLINE putWord32host #-}
putWord64host       :: Word64 -> Put
putWord64host :: Word64 -> PutM ()
putWord64host       = Builder -> PutM ()
tell (Builder -> PutM ()) -> (Word64 -> Builder) -> Word64 -> PutM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Builder
B.putWord64host
{-# INLINE putWord64host #-}
putInthost         :: Int -> Put
putInthost :: Int -> PutM ()
putInthost         = Builder -> PutM ()
tell (Builder -> PutM ()) -> (Int -> Builder) -> Int -> PutM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Builder
B.putInthost
{-# INLINE putInthost #-}
putInt16host       :: Int16 -> Put
putInt16host :: Int16 -> PutM ()
putInt16host       = Builder -> PutM ()
tell (Builder -> PutM ()) -> (Int16 -> Builder) -> Int16 -> PutM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int16 -> Builder
B.putInt16host
{-# INLINE putInt16host #-}
putInt32host       :: Int32 -> Put
putInt32host :: Int32 -> PutM ()
putInt32host       = Builder -> PutM ()
tell (Builder -> PutM ()) -> (Int32 -> Builder) -> Int32 -> PutM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Builder
B.putInt32host
{-# INLINE putInt32host #-}
putInt64host       :: Int64 -> Put
putInt64host :: Int64 -> PutM ()
putInt64host       = Builder -> PutM ()
tell (Builder -> PutM ()) -> (Int64 -> Builder) -> Int64 -> PutM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Builder
B.putInt64host
{-# INLINE putInt64host #-}
putFloatbe :: Float -> Put
putFloatbe :: Float -> PutM ()
putFloatbe = Word32 -> PutM ()
putWord32be (Word32 -> PutM ()) -> (Float -> Word32) -> Float -> PutM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Word32
floatToWord
{-# INLINE putFloatbe #-}
putFloatle :: Float -> Put
putFloatle :: Float -> PutM ()
putFloatle = Word32 -> PutM ()
putWord32le (Word32 -> PutM ()) -> (Float -> Word32) -> Float -> PutM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Word32
floatToWord
{-# INLINE putFloatle #-}
putFloathost :: Float -> Put
putFloathost :: Float -> PutM ()
putFloathost = Word32 -> PutM ()
putWord32host (Word32 -> PutM ()) -> (Float -> Word32) -> Float -> PutM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Word32
floatToWord
{-# INLINE putFloathost #-}
putDoublebe :: Double -> Put
putDoublebe :: Double -> PutM ()
putDoublebe = Word64 -> PutM ()
putWord64be (Word64 -> PutM ()) -> (Double -> Word64) -> Double -> PutM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Word64
doubleToWord
{-# INLINE putDoublebe #-}
putDoublele :: Double -> Put
putDoublele :: Double -> PutM ()
putDoublele = Word64 -> PutM ()
putWord64le (Word64 -> PutM ()) -> (Double -> Word64) -> Double -> PutM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Word64
doubleToWord
{-# INLINE putDoublele #-}
putDoublehost :: Double -> Put
putDoublehost :: Double -> PutM ()
putDoublehost = Word64 -> PutM ()
putWord64host (Word64 -> PutM ()) -> (Double -> Word64) -> Double -> PutM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Word64
doubleToWord
{-# INLINE putDoublehost #-}
putCharUtf8 :: Char -> Put
putCharUtf8 :: Char -> PutM ()
putCharUtf8 = Builder -> PutM ()
tell (Builder -> PutM ()) -> (Char -> Builder) -> Char -> PutM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Builder
B.putCharUtf8
{-# INLINE putCharUtf8 #-}
putStringUtf8 :: String -> Put
putStringUtf8 :: String -> PutM ()
putStringUtf8 = Builder -> PutM ()
tell (Builder -> PutM ()) -> (String -> Builder) -> String -> PutM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Builder
B.putStringUtf8
{-# INLINE putStringUtf8 #-}