src/Data/Binary/Put.hs

    {-# LANGUAGE CPP #-}
    {-# LANGUAGE FlexibleInstances #-}
    {-# LANGUAGE Safe #-}

    #if MIN_VERSION_base(4,9,0)
    #define HAS_SEMIGROUP
    #endif

    -----------------------------------------------------------------------------
    -- |
    -- Module      : Data.Binary.Put
    -- Copyright   : Lennart Kolmodin
    -- License     : BSD3-style (see LICENSE)
    --
    -- Maintainer  : Lennart Kolmodin <kolmodin@gmail.com>
    -- Stability   : stable
    -- Portability : Portable to Hugs and GHC. Requires MPTCs
    --
    -- The Put monad. A monad for efficiently constructing lazy bytestrings.
    --
    -----------------------------------------------------------------------------

    module Data.Binary.Put (

        -- * The Put type
          Put
        , PutM(..)
        , runPut
        , runPutM
        , putBuilder
        , execPut

        -- * Flushing the implicit parse state
        , flush

        -- * Primitives
        , putWord8
        , putInt8
        , putByteString
        , putLazyByteString
    #if MIN_VERSION_bytestring(0,10,4)
        , putShortByteString
    #endif

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

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

        -- * Host-endian, unaligned writes
        , putWordhost           -- :: Word   -> Put
        , putWord16host         -- :: Word16 -> Put
        , putWord32host         -- :: Word32 -> Put
        , putWord64host         -- :: Word64 -> Put
        , putInthost            -- :: Int    -> Put
        , putInt16host          -- :: Int16  -> Put
        , putInt32host          -- :: Int32  -> Put
        , putInt64host          -- :: Int64  -> Put
        , putFloathost
        , putDoublehost

        -- * Unicode
        , 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 -- Silence AMP warning.

    -- needed for casting Floats/Doubles to words.
    import Data.Binary.FloatCast (floatToWord, doubleToWord)

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

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

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

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

    -- | Put merely lifts Builder into a Writer monad, applied to ().
    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 (*>) #-}

    -- Standard Writer monad, with aggressive inlining
    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 #-}

    -- | Run the 'Put' monad
    execPut :: PutM a -> Builder
    execPut = sndS . unPut
    {-# INLINE execPut #-}

    -- | Run the 'Put' monad with a serialiser
    runPut :: Put -> L.ByteString
    runPut = toLazyByteString . sndS . unPut
    {-# INLINE runPut #-}

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

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

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

    -- | Efficiently write a byte into the output buffer
    putWord8            :: Word8 -> Put
    putWord8            = tell . B.singleton
    {-# INLINE putWord8 #-}

    -- | Efficiently write a signed byte into the output buffer
    putInt8            :: Int8 -> Put
    putInt8            = tell . B.singleton . fromIntegral
    {-# 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       :: S.ByteString -> Put
    putByteString       = tell . B.fromByteString
    {-# INLINE putByteString #-}

    -- | Write a lazy ByteString efficiently, simply appending the lazy
    -- ByteString chunks to the output buffer
    putLazyByteString   :: L.ByteString -> Put
    putLazyByteString   = tell . B.fromLazyByteString
    {-# INLINE putLazyByteString #-}

    #if MIN_VERSION_bytestring(0,10,4)
    -- | Write 'ShortByteString' to the buffer
    putShortByteString :: ShortByteString -> Put
    putShortByteString = tell . B.fromShortByteString
    {-# INLINE putShortByteString #-}
    #endif

    -- | Write a Word16 in big endian format
    putWord16be         :: Word16 -> Put
    putWord16be         = tell . B.putWord16be
    {-# INLINE putWord16be #-}

    -- | Write a Word16 in little endian format
    putWord16le         :: Word16 -> Put
    putWord16le         = tell . B.putWord16le
    {-# INLINE putWord16le #-}

    -- | Write a Word32 in big endian format
    putWord32be         :: Word32 -> Put
    putWord32be         = tell . B.putWord32be
    {-# INLINE putWord32be #-}

    -- | Write a Word32 in little endian format
    putWord32le         :: Word32 -> Put
    putWord32le         = tell . B.putWord32le
    {-# INLINE putWord32le #-}

    -- | Write a Word64 in big endian format
    putWord64be         :: Word64 -> Put
    putWord64be         = tell . B.putWord64be
    {-# INLINE putWord64be #-}

    -- | Write a Word64 in little endian format
    putWord64le         :: Word64 -> Put
    putWord64le         = tell . B.putWord64le
    {-# INLINE putWord64le #-}

    -- | Write an Int16 in big endian format
    putInt16be         :: Int16 -> Put
    putInt16be         = tell . B.putInt16be
    {-# INLINE putInt16be #-}

    -- | Write an Int16 in little endian format
    putInt16le         :: Int16 -> Put
    putInt16le         = tell . B.putInt16le
    {-# INLINE putInt16le #-}

    -- | Write an Int32 in big endian format
    putInt32be         :: Int32 -> Put
    putInt32be         = tell . B.putInt32be
    {-# INLINE putInt32be #-}

    -- | Write an Int32 in little endian format
    putInt32le         :: Int32 -> Put
    putInt32le         = tell . B.putInt32le
    {-# INLINE putInt32le #-}

    -- | Write an Int64 in big endian format
    putInt64be         :: Int64 -> Put
    putInt64be         = tell . B.putInt64be
    {-# INLINE putInt64be #-}

    -- | Write an Int64 in little endian format
    putInt64le         :: Int64 -> Put
    putInt64le         = tell . B.putInt64le
    {-# INLINE putInt64le #-}

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

    -- | /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         :: Word -> Put
    putWordhost         = tell . B.putWordhost
    {-# INLINE putWordhost #-}

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

    -- | /O(1)./ Write a Word32 in native host order and host endianness.
    -- For portability issues see @putWordhost@.
    putWord32host       :: Word32 -> Put
    putWord32host       = tell . B.putWord32host
    {-# 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       :: Word64 -> Put
    putWord64host       = tell . B.putWord64host
    {-# INLINE putWord64host #-}

    -- | /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 Int 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.
    --
    putInthost         :: Int -> Put
    putInthost         = tell . B.putInthost
    {-# INLINE putInthost #-}

    -- | /O(1)./ Write an Int16 in native host order and host endianness.
    -- For portability issues see @putInthost@.
    putInt16host       :: Int16 -> Put
    putInt16host       = tell . B.putInt16host
    {-# INLINE putInt16host #-}

    -- | /O(1)./ Write an Int32 in native host order and host endianness.
    -- For portability issues see @putInthost@.
    putInt32host       :: Int32 -> Put
    putInt32host       = tell . B.putInt32host
    {-# INLINE putInt32host #-}

    -- | /O(1)./ Write an 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       :: Int64 -> Put
    putInt64host       = tell . B.putInt64host
    {-# INLINE putInt64host #-}

    ------------------------------------------------------------------------
    -- Floats/Doubles

    -- | Write a 'Float' in big endian IEEE-754 format.
    putFloatbe :: Float -> Put
    putFloatbe = putWord32be . floatToWord
    {-# INLINE putFloatbe #-}

    -- | Write a 'Float' in little endian IEEE-754 format.
    putFloatle :: Float -> Put
    putFloatle = putWord32le . floatToWord
    {-# INLINE putFloatle #-}

    -- | Write a 'Float' in native in IEEE-754 format and host endian.
    putFloathost :: Float -> Put
    putFloathost = putWord32host . floatToWord
    {-# INLINE putFloathost #-}

    -- | Write a 'Double' in big endian IEEE-754 format.
    putDoublebe :: Double -> Put
    putDoublebe = putWord64be . doubleToWord
    {-# INLINE putDoublebe #-}

    -- | Write a 'Double' in little endian IEEE-754 format.
    putDoublele :: Double -> Put
    putDoublele = putWord64le . doubleToWord
    {-# INLINE putDoublele #-}

    -- | Write a 'Double' in native in IEEE-754 format and host endian.
    putDoublehost :: Double -> Put
    putDoublehost = putWord64host . doubleToWord
    {-# INLINE putDoublehost #-}

    ------------------------------------------------------------------------
    -- Unicode

    -- | Write a character using UTF-8 encoding.
    putCharUtf8 :: Char -> Put
    putCharUtf8 = tell . B.putCharUtf8
    {-# INLINE putCharUtf8 #-}

    -- | Write a String using UTF-8 encoding.
    putStringUtf8 :: String -> Put
    putStringUtf8 = tell . B.putStringUtf8
    {-# INLINE putStringUtf8 #-}