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