{-# 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 <[email protected]>
-- 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 #-}