module Data.Binary.Put (
Put
, PutM(..)
, runPut
, runPutM
, putBuilder
, execPut
, flush
, putWord8
, putByteString
, putLazyByteString
, putWord16be
, putWord32be
, putWord64be
, putWord16le
, putWord32le
, putWord64le
, putWordhost
, putWord16host
, putWord32host
, putWord64host
) where
import Data.Monoid
import Data.Binary.Builder (Builder, toLazyByteString)
import qualified Data.Binary.Builder as B
import Data.Word
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import Control.Applicative
data PairS a = PairS a !Builder
sndS :: PairS a -> Builder
sndS :: PairS a -> Builder
sndS (PairS a
_ Builder
b) = Builder
b
newtype PutM a = Put { PutM a -> PairS a
unPut :: PairS a }
type Put = PutM ()
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 Applicative PutM where
pure :: a -> PutM a
pure = a -> PutM a
forall (m :: * -> *) a. Monad m => a -> m a
return
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
`mappend` Builder
w')
instance Monad PutM where
return :: a -> PutM a
return 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
mempty
{-# 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
`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
`mappend` Builder
w')
{-# INLINE (>>) #-}
tell :: Builder -> Put
tell :: Builder -> Put
tell Builder
b = PairS () -> Put
forall a. PairS a -> PutM a
Put (PairS () -> Put) -> PairS () -> Put
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 -> Put
putBuilder = Builder -> Put
tell
{-# INLINE putBuilder #-}
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 #-}
runPut :: Put -> L.ByteString
runPut :: Put -> ByteString
runPut = Builder -> ByteString
toLazyByteString (Builder -> ByteString) -> (Put -> Builder) -> Put -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PairS () -> Builder
forall a. PairS a -> Builder
sndS (PairS () -> Builder) -> (Put -> PairS ()) -> Put -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> PairS ()
forall a. PutM a -> PairS a
unPut
{-# INLINE runPut #-}
runPutM :: PutM a -> (a, L.ByteString)
runPutM :: PutM a -> (a, ByteString)
runPutM (Put (PairS a
f Builder
s)) = (a
f, Builder -> ByteString
toLazyByteString Builder
s)
{-# INLINE runPutM #-}
flush :: Put
flush :: Put
flush = Builder -> Put
tell Builder
B.flush
{-# INLINE flush #-}
putWord8 :: Word8 -> Put
putWord8 :: Word8 -> Put
putWord8 = Builder -> Put
tell (Builder -> Put) -> (Word8 -> Builder) -> Word8 -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Builder
B.singleton
{-# INLINE putWord8 #-}
putByteString :: S.ByteString -> Put
putByteString :: ByteString -> Put
putByteString = Builder -> Put
tell (Builder -> Put) -> (ByteString -> Builder) -> ByteString -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
B.fromByteString
{-# INLINE putByteString #-}
putLazyByteString :: L.ByteString -> Put
putLazyByteString :: ByteString -> Put
putLazyByteString = Builder -> Put
tell (Builder -> Put) -> (ByteString -> Builder) -> ByteString -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
B.fromLazyByteString
{-# INLINE putLazyByteString #-}
putWord16be :: Word16 -> Put
putWord16be :: Word16 -> Put
putWord16be = Builder -> Put
tell (Builder -> Put) -> (Word16 -> Builder) -> Word16 -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Builder
B.putWord16be
{-# INLINE putWord16be #-}
putWord16le :: Word16 -> Put
putWord16le :: Word16 -> Put
putWord16le = Builder -> Put
tell (Builder -> Put) -> (Word16 -> Builder) -> Word16 -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Builder
B.putWord16le
{-# INLINE putWord16le #-}
putWord32be :: Word32 -> Put
putWord32be :: Word32 -> Put
putWord32be = Builder -> Put
tell (Builder -> Put) -> (Word32 -> Builder) -> Word32 -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Builder
B.putWord32be
{-# INLINE putWord32be #-}
putWord32le :: Word32 -> Put
putWord32le :: Word32 -> Put
putWord32le = Builder -> Put
tell (Builder -> Put) -> (Word32 -> Builder) -> Word32 -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Builder
B.putWord32le
{-# INLINE putWord32le #-}
putWord64be :: Word64 -> Put
putWord64be :: Word64 -> Put
putWord64be = Builder -> Put
tell (Builder -> Put) -> (Word64 -> Builder) -> Word64 -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Builder
B.putWord64be
{-# INLINE putWord64be #-}
putWord64le :: Word64 -> Put
putWord64le :: Word64 -> Put
putWord64le = Builder -> Put
tell (Builder -> Put) -> (Word64 -> Builder) -> Word64 -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Builder
B.putWord64le
{-# INLINE putWord64le #-}
putWordhost :: Word -> Put
putWordhost :: Word -> Put
putWordhost = Builder -> Put
tell (Builder -> Put) -> (Word -> Builder) -> Word -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Builder
B.putWordhost
{-# INLINE putWordhost #-}
putWord16host :: Word16 -> Put
putWord16host :: Word16 -> Put
putWord16host = Builder -> Put
tell (Builder -> Put) -> (Word16 -> Builder) -> Word16 -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Builder
B.putWord16host
{-# INLINE putWord16host #-}
putWord32host :: Word32 -> Put
putWord32host :: Word32 -> Put
putWord32host = Builder -> Put
tell (Builder -> Put) -> (Word32 -> Builder) -> Word32 -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Builder
B.putWord32host
{-# INLINE putWord32host #-}
putWord64host :: Word64 -> Put
putWord64host :: Word64 -> Put
putWord64host = Builder -> Put
tell (Builder -> Put) -> (Word64 -> Builder) -> Word64 -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Builder
B.putWord64host
{-# INLINE putWord64host #-}