{-# LANGUAGE CPP #-}
{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}

-- | Serialization monoid and serializable types.
module Data.Serializer
  (
  -- * Serialization monoid
    Serializer(..)
  , BinarySerializer(..)
  , CerealSerializer(..)
  -- ** Binary words serialization
  , word16H
  , word32H
  , word64H
  , word
  , wordL
  , wordB
  , wordH
  , int8
  , int16
  , int16L
  , int16B
  , int16H
  , int32
  , int32L
  , int32B
  , int32H
  , int64
  , int64L
  , int64B
  , int64H
  , int
  , intL
  , intB
  , intH
  -- ** Endian serializers
  , LittleEndianSerializer(..)
  , BigEndianSerializer(..)
  , serializeIn
  , serializeH
  -- * Serializable types
  , Serializable(..)
  , putIn
  , putL
  , putB
  , putH
  , SizedSerializable(..)
  , RestSerializable(..)
  ) where

import GHC.Generics (Generic)
import Data.Typeable (Typeable)
import Data.Data (Data)
import Data.Proxy (Proxy(..))
import Data.Semigroup (Semigroup, (<>))
import Data.Monoid (Monoid)
import Data.Endian (Endian(..), swapEndian)
import Data.Word
import Data.Int
import Data.Bits (shiftR)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Short as SBS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Builder as BB
import qualified Data.Binary.Put as B
import qualified Data.Serialize.Put as S

-- | Serialization monoid.
class (Semigroup s, Monoid s)  Serializer s where
  {-# MINIMAL word8 #-}
  -- | Default byte order of the serializer.
  endian  Proxy s  Endian
#ifdef WORDS_BIGENDIAN
  endian _ = BigEndian
#else
  endian _ = LittleEndian
#endif
  {-# INLINE endian #-}
  -- | Serialize a byte. 'word8' /x/ = 'byteString' ('BS.singleton' /x/)
  word8  Word8  s
  -- | Serialize an unsigned 16-bit integer in the default byte order.
  word16  Word16  s
  word16 = putIn (endian (Proxy  Proxy s))
  {-# INLINE word16 #-}
  -- | Serialize an unsigned 32-bit integer in the default byte order.
  word32  Word32  s
  word32 = putIn (endian (Proxy  Proxy s))
  {-# INLINE word32 #-}
  -- | Serialize an unsigned 64-bit integer in the default byte order.
  word64  Word64  s
  word64 = putIn (endian (Proxy  Proxy s))
  {-# INLINE word64 #-}
  -- | Serialize an unsigned 16-bit integer in little endian.
  word16L  Word16  s
  word16L w =  word8 (fromIntegral w)
            <> word8 (fromIntegral (shiftR w 8))
  {-# INLINE word16L #-}
  -- | Serialize an unsigned 16-bit integer in big endian.
  word16B  Word16  s
  word16B = word16L . swapEndian
  {-# INLINE word16B #-}
  -- | Serialize an unsigned 32-bit integer in little endian.
  word32L  Word32  s
  word32L w =  word8 (fromIntegral w)
            <> word8 (fromIntegral (shiftR w 8))
            <> word8 (fromIntegral (shiftR w 16))
            <> word8 (fromIntegral (shiftR w 24))
  {-# INLINE word32L #-}
  -- | Serialize an unsigned 32-bit integer in big endian.
  word32B  Word32  s
  word32B = word32L . swapEndian
  {-# INLINE word32B #-}
  -- | Serialize an unsigned 64-bit integer in little endian.
  word64L  Word64  s
  word64L w =  word8 (fromIntegral w)
            <> word8 (fromIntegral (shiftR w 8))
            <> word8 (fromIntegral (shiftR w 16))
            <> word8 (fromIntegral (shiftR w 24))
            <> word8 (fromIntegral (shiftR w 32))
            <> word8 (fromIntegral (shiftR w 40))
            <> word8 (fromIntegral (shiftR w 48))
            <> word8 (fromIntegral (shiftR w 56))
  {-# INLINE word64L #-}
  -- | Serialize an unsigned 64-bit integer in big endian.
  word64B  Word64  s
  word64B = word64L . swapEndian
  {-# INLINE word64B #-}
  -- | Serialize a 'BS.ByteString'. Must be a monoid homomorphism.
  byteString  BS.ByteString  s
  byteString = mconcat . fmap word8 . BS.unpack
  {-# INLINE byteString #-}
  -- | Serialize a 'SBS.ShortByteString'. Must be a monoid homomorphism.
  shortByteString  SBS.ShortByteString  s
  shortByteString = mconcat . fmap word8 . SBS.unpack
  {-# INLINE shortByteString #-}
  -- | Serialize a lazy 'LBS.ByteString'. Must be a monoid homomorphism.
  lazyByteString  LBS.ByteString  s
  lazyByteString = mconcat . fmap byteString . LBS.toChunks
  {-# INLINE lazyByteString #-}
  -- | Serialize a 'BB.Builder'. Must be a monoid homomorphism.
  builder  BB.Builder  s
  builder = lazyByteString . BB.toLazyByteString
  {-# INLINE builder #-}

instance Serializer [Word8] where
  word8 = pure
  {-# INLINE word8 #-}

instance Serializer BB.Builder where
  word8 = BB.word8
  {-# INLINE word8 #-}
  word16L = BB.word16LE
  {-# INLINE word16L #-}
  word16B = BB.word16BE
  {-# INLINE word16B #-}
  word32L = BB.word32LE
  {-# INLINE word32L #-}
  word32B = BB.word32BE
  {-# INLINE word32B #-}
  word64L = BB.word64LE
  {-# INLINE word64L #-}
  word64B = BB.word64BE
  {-# INLINE word64B #-}
  byteString = BB.byteString
  {-# INLINE byteString #-}
  shortByteString = BB.shortByteString
  {-# INLINE shortByteString #-}
  lazyByteString = BB.lazyByteString
  {-# INLINE lazyByteString #-}
  builder = id
  {-# INLINE builder #-}

#if MIN_VERSION_base(4,9,0) && MIN_VERSION_binary(0,8,3)
instance Serializer B.Put where
  word8 = B.putWord8
  {-# INLINE word8 #-}
  word16L = B.putWord16le
  {-# INLINE word16L #-}
  word16B = B.putWord16be
  {-# INLINE word16B #-}
  word32L = B.putWord32le
  {-# INLINE word32L #-}
  word32B = B.putWord32be
  {-# INLINE word32B #-}
  word64L = B.putWord64le
  {-# INLINE word64L #-}
  word64B = B.putWord64be
  {-# INLINE word64B #-}
  byteString = B.putByteString
  {-# INLINE byteString #-}
  shortByteString = B.putShortByteString
  {-# INLINE shortByteString #-}
  lazyByteString = B.putLazyByteString
  {-# INLINE lazyByteString #-}
  builder = B.putBuilder
  {-# INLINE builder #-}
#endif

-- | A wrapper around the 'B.Put' monoid (to avoid orphan instances).
newtype BinarySerializer = BinarySerializer { binarySerializer  B.Put }
                           deriving ( Typeable, Generic
#if MIN_VERSION_binary(0,8,3)
# if MIN_VERSION_base(4,9,0)
                                    , Semigroup
# endif
                                    , Monoid
#endif
                                    )

#if !MIN_VERSION_base(4,9,0) || !MIN_VERSION_binary(0,8,3)
instance Semigroup BinarySerializer where
  s₁ <> s₂ = BinarySerializer $ binarySerializer s₁ >> binarySerializer s₂
  {-# INLINE (<>) #-}
#endif

#if !MIN_VERSION_binary(0,8,3)
instance Monoid BinarySerializer where
  mempty = BinarySerializer $ return ()
  {-# INLINE mempty #-}
  mappend = (<>)
  {-# INLINE mappend #-}
#endif

instance Serializer BinarySerializer where
  word8 = BinarySerializer . B.putWord8
  {-# INLINE word8 #-}
  word16L = BinarySerializer . B.putWord16le
  {-# INLINE word16L #-}
  word16B = BinarySerializer . B.putWord16be
  {-# INLINE word16B #-}
  word32L = BinarySerializer . B.putWord32le
  {-# INLINE word32L #-}
  word32B = BinarySerializer . B.putWord32be
  {-# INLINE word32B #-}
  word64L = BinarySerializer . B.putWord64le
  {-# INLINE word64L #-}
  word64B = BinarySerializer . B.putWord64be
  {-# INLINE word64B #-}
  byteString = BinarySerializer . B.putByteString
  {-# INLINE byteString #-}
#if MIN_VERSION_binary(0,8,1)
  shortByteString = BinarySerializer . B.putShortByteString
  {-# INLINE shortByteString #-}
#endif
  lazyByteString = BinarySerializer . B.putLazyByteString
  {-# INLINE lazyByteString #-}
#if MIN_VERSION_binary(0,8,3)
  builder = BinarySerializer . B.putBuilder
  {-# INLINE builder #-}
#endif

-- | A wrapper around the 'S.Put' monoid (to avoid orphan instances).
newtype CerealSerializer = CerealSerializer { cerealSerializer  S.Put }
                           deriving ( Typeable, Generic
#if MIN_VERSION_cereal(0,5,3)
                                    , Monoid
#endif
                                    )

instance Semigroup CerealSerializer where
  s₁ <> s₂ = CerealSerializer $ cerealSerializer s₁ >> cerealSerializer s₂
  {-# INLINE (<>) #-}

#if !MIN_VERSION_cereal(0,5,3)
instance Monoid CerealSerializer where
  mempty = CerealSerializer $ return ()
  {-# INLINE mempty #-}
  mappend = (<>)
  {-# INLINE mappend #-}
#endif

instance Serializer CerealSerializer where
  word8 = CerealSerializer . S.putWord8
  {-# INLINE word8 #-}
  word16L = CerealSerializer . S.putWord16le
  {-# INLINE word16L #-}
  word16B = CerealSerializer . S.putWord16be
  {-# INLINE word16B #-}
  word32L = CerealSerializer . S.putWord32le
  {-# INLINE word32L #-}
  word32B = CerealSerializer . S.putWord32be
  {-# INLINE word32B #-}
  word64L = CerealSerializer . S.putWord64le
  {-# INLINE word64L #-}
  word64B = CerealSerializer . S.putWord64be
  {-# INLINE word64B #-}
  byteString = CerealSerializer . S.putByteString
  {-# INLINE byteString #-}
#if MIN_VERSION_cereal(0,5,0)
  shortByteString = CerealSerializer . S.putShortByteString
  {-# INLINE shortByteString #-}
#endif
  lazyByteString = CerealSerializer . S.putLazyByteString
  {-# INLINE lazyByteString #-}
#if MIN_VERSION_cereal(0,5,0)
  builder = CerealSerializer . S.putBuilder
  {-# INLINE builder #-}
#endif

-- | Serialize an usigned 16-bit integer in host byte order.
word16H  Serializer s  Word16  s
#ifdef WORDS_BIGENDIAN
word16H = word16B
#else
word16H = word16L
#endif
{-# INLINE word16H #-}

-- | Serialize an unsigned 32-bit integer in host byte order.
word32H  Serializer s  Word32  s
#ifdef WORDS_BIGENDIAN
word32H = word32B
#else
word32H = word32L
#endif
{-# INLINE word32H #-}

-- | Serialize an unsigned 64-bit integer in host byte order.
word64H  Serializer s  Word64  s
#ifdef WORDS_BIGENDIAN
word64H = word64B
#else
word64H = word64L
#endif
{-# INLINE word64H #-}

-- | Serialize an unsigned native-sized integer in serializer default
--   byte order.
word  Serializer s  Word  s
#ifdef WORDS_BIGENDIAN
word = wordB
#else
word = wordL
#endif
{-# INLINE word #-}

-- | Serialize an unsigned native-sized integer in little endian.
wordL  Serializer s  Word  s
#if WORD_SIZE_IN_BITS == 32
wordL = word32L . fromIntegral
#else
wordL = word64L . fromIntegral
#endif
{-# INLINE wordL #-}

-- | Serialize an unsigned native-sized integer in big endian.
wordB  Serializer s  Word  s
#if WORD_SIZE_IN_BITS == 32
wordB = word32B . fromIntegral
#else
wordB = word64B . fromIntegral
#endif
{-# INLINE wordB #-}

-- | Serialize an unsigned native-sized integer in host byte order.
wordH  Serializer s  Word  s
#if WORD_SIZE_IN_BITS == 32
wordH = word32H . fromIntegral
#else
wordH = word64H . fromIntegral
#endif
{-# INLINE wordH #-}

-- | Serialize a signed 8-bit integer.
int8  Serializer s  Int8  s
int8 = word8 . fromIntegral
{-# INLINE int8 #-}

-- | Serialize a signed 16-bit integer in serializer default byte order.
int16  Serializer s  Int16  s
int16 = word16 . fromIntegral
{-# INLINE int16 #-}

-- | Serialize a signed 16-bit integer in little endian.
int16L  Serializer s  Int16  s
int16L = word16L . fromIntegral
{-# INLINE int16L #-}

-- | Serialize a signed 16-bit integer in big endian.
int16B  Serializer s  Int16  s
int16B = word16B . fromIntegral
{-# INLINE int16B #-}

-- | Serialize a signed 16-bit integer in host byte order.
int16H  Serializer s  Int16  s
#ifdef WORDS_BIGENDIAN
int16H = int16B
#else
int16H = int16L
#endif
{-# INLINE int16H #-}

-- | Serialize a signed 32-bit integer in serializer default byte order.
int32  Serializer s  Int32  s
int32 = word32 . fromIntegral
{-# INLINE int32 #-}

-- | Serialize a signed 32-bit integer in little endian.
int32L  Serializer s  Int32  s
int32L = word32L . fromIntegral
{-# INLINE int32L #-}

-- | Serialize a signed 32-bit integer in big endian.
int32B  Serializer s  Int32  s
int32B = word32B . fromIntegral
{-# INLINE int32B #-}

-- | Serialize a signed 32-bit integer in host byte order.
int32H  Serializer s  Int32  s
#ifdef WORDS_BIGENDIAN
int32H = int32B
#else
int32H = int32L
#endif
{-# INLINE int32H #-}

-- | Serialize a signed 64-bit integer in serializer default byte order.
int64  Serializer s  Int64  s
int64 = word64 . fromIntegral
{-# INLINE int64 #-}

-- | Serialize a signed 64-bit integer in little endian.
int64L  Serializer s  Int64  s
int64L = word64L . fromIntegral
{-# INLINE int64L #-}

-- | Serialize a signed 64-bit integer in big endian.
int64B  Serializer s  Int64  s
int64B = word64B . fromIntegral
{-# INLINE int64B #-}

-- | Serialize a signed 64-bit integer in host byte order.
int64H  Serializer s  Int64  s
#ifdef WORDS_BIGENDIAN
int64H = int64B
#else
int64H = int64L
#endif
{-# INLINE int64H #-}

-- | Serialize a signed native-sized integer in serializer default byte order.
int  Serializer s  Int  s
#ifdef WORDS_BIGENDIAN
int = intB
#else
int = intL
#endif
{-# INLINE int #-}

-- | Serialize a signed native-sized integer in little endian.
intL  Serializer s  Int  s
#if WORD_SIZE_IN_BITS == 32
intL = word32L . fromIntegral
#else
intL = word64L . fromIntegral
#endif
{-# INLINE intL #-}

-- | Serialize a signed native-sized integer in big endian.
intB  Serializer s  Int64  s
#if WORD_SIZE_IN_BITS == 32
intB = word32B . fromIntegral
#else
intB = word64B . fromIntegral
#endif
{-# INLINE intB #-}

-- | Serialize a signed native-sized integer in host byte order.
intH  Serializer s  Int  s
#if WORD_SIZE_IN_BITS == 32
intH = word32H . fromIntegral
#else
intH = word64H . fromIntegral
#endif
{-# INLINE intH #-}

-- | Serializer wrapper with little endian default byte order.
newtype LittleEndianSerializer s = LittleEndianSerializer { serializeL  s }
                                   deriving (Typeable, Data, Generic,
                                             Semigroup, Monoid)

instance Serializer s  Serializer (LittleEndianSerializer s) where
  endian _ = LittleEndian
  {-# INLINE endian #-}
  word8 = LittleEndianSerializer . word8
  {-# INLINE word8 #-}
  word16 = LittleEndianSerializer . word16L
  {-# INLINE word16 #-}
  word32 = LittleEndianSerializer . word32L
  {-# INLINE word32 #-}
  word64 = LittleEndianSerializer . word64L
  {-# INLINE word64 #-}
  word16L = LittleEndianSerializer . word16L
  {-# INLINE word16L #-}
  word16B = LittleEndianSerializer . word16B
  {-# INLINE word16B #-}
  word32L = LittleEndianSerializer . word32L
  {-# INLINE word32L #-}
  word32B = LittleEndianSerializer . word32B
  {-# INLINE word32B #-}
  word64L = LittleEndianSerializer . word64L
  {-# INLINE word64L #-}
  word64B = LittleEndianSerializer . word64B
  {-# INLINE word64B #-}
  byteString = LittleEndianSerializer . byteString
  {-# INLINE byteString #-}
  shortByteString = LittleEndianSerializer . shortByteString
  {-# INLINE shortByteString #-}
  lazyByteString = LittleEndianSerializer . lazyByteString
  {-# INLINE lazyByteString #-}
  builder = LittleEndianSerializer . builder
  {-# INLINE builder #-}

-- | Serializer wrapper with big endian default byte order.
newtype BigEndianSerializer s = BigEndianSerializer { serializeB  s }
                                deriving (Typeable, Data, Generic,
                                          Semigroup, Monoid)

instance Serializer s  Serializer (BigEndianSerializer s) where
  endian _ = BigEndian
  {-# INLINE endian #-}
  word8 = BigEndianSerializer . word8
  {-# INLINE word8 #-}
  word16 = BigEndianSerializer . word16B
  {-# INLINE word16 #-}
  word32 = BigEndianSerializer . word32B
  {-# INLINE word32 #-}
  word64 = BigEndianSerializer . word64B
  {-# INLINE word64 #-}
  word16L = BigEndianSerializer . word16L
  {-# INLINE word16L #-}
  word16B = BigEndianSerializer . word16B
  {-# INLINE word16B #-}
  word32L = BigEndianSerializer . word32L
  {-# INLINE word32L #-}
  word32B = BigEndianSerializer . word32B
  {-# INLINE word32B #-}
  word64L = BigEndianSerializer . word64L
  {-# INLINE word64L #-}
  word64B = BigEndianSerializer . word64B
  {-# INLINE word64B #-}
  byteString = BigEndianSerializer . byteString
  {-# INLINE byteString #-}
  shortByteString = BigEndianSerializer . shortByteString
  {-# INLINE shortByteString #-}
  lazyByteString = BigEndianSerializer . lazyByteString
  {-# INLINE lazyByteString #-}
  builder = BigEndianSerializer . builder
  {-# INLINE builder #-}

-- | Force the default byte order.
serializeIn  Serializer s  Endian  ( s' . (Serializer s')  s')  s
serializeIn LittleEndian = serializeL
serializeIn BigEndian    = serializeB
{-# INLINE serializeIn #-}

-- | Force the default byte order to be the host byte order.
serializeH  Serializer s  ( s' . (Serializer s')  s')  s
#ifdef WORDS_BIGENDIAN
serializeH = serializeB
#else
serializeH = serializeL
#endif
{-# INLINE serializeH #-}

-- | Serializable type. 'put' must work under assumption that it will be
--   followed by more output.
class Serializable α where
  put  Serializer s  α  s

instance Serializable Bool where
  put False = word8 0
  put True  = word8 1
  {-# INLINE put #-}

instance Serializable Word8 where
  put = word8
  {-# INLINE put #-}

instance Serializable Word16 where
  put = word16
  {-# INLINE put #-}

instance Serializable Word32 where
  put = word32
  {-# INLINE put #-}

instance Serializable Word64 where
  put = word64
  {-# INLINE put #-}

instance Serializable Word where
  put = word
  {-# INLINE put #-}

instance Serializable Int8 where
  put = int8
  {-# INLINE put #-}

instance Serializable Int16 where
  put = word16 . fromIntegral
  {-# INLINE put #-}

instance Serializable Int32 where
  put = word32 . fromIntegral
  {-# INLINE put #-}

instance Serializable Int64 where
  put = word64 . fromIntegral
  {-# INLINE put #-}

instance Serializable Int where
  put = int
  {-# INLINE put #-}

instance (Serializable α, Serializable β)  Serializable (α, β) where
  put (a, b) = put a <> put b
  {-# INLINE put #-}

instance Serializable α  Serializable (Maybe α) where
  put Nothing  = word8 0
  put (Just a) = word8 1 <> put a

instance (Serializable α, Serializable β)  Serializable (Either α β) where
  put (Left a)  = word8 0 <> put a
  put (Right b) = word8 1 <> put b

instance Serializable BS.ByteString where
  put bs = int (BS.length bs) <> byteString bs

instance Serializable SBS.ShortByteString where
  put bs = int (SBS.length bs) <> shortByteString bs

-- | Serialize a value using the provided default byte order.
putIn  (Serializer s, Serializable α)  Endian  α  s
putIn e a = serializeIn e (put a)
{-# INLINE putIn #-}

-- | Serialize a value using little endian as the default byte order.
putL  (Serializer s, Serializable α)  α  s
putL a = serializeL (put a)
{-# INLINE putL #-}

-- | Serialize a value using big endian as the default byte order.
putB  (Serializer s, Serializable α)  α  s
putB a = serializeB (put a)
{-# INLINE putB #-}

-- | Serialize a value using host byte order as the default byte order.
putH  (Serializer s, Serializable α)  α  s
putH a = serializeH (put a)
{-# INLINE putH #-}

-- | Types with fixed serialized size.
class Serializable α  SizedSerializable α where
  -- | Serialized size in bytes.
  size  Proxy α  Int

instance SizedSerializable Bool where
  size _ = 1
  {-# INLINE size #-}

instance SizedSerializable Word8 where
  size _ = 1
  {-# INLINE size #-}

instance SizedSerializable Word16 where
  size _ = 2
  {-# INLINE size #-}

instance SizedSerializable Word32 where
  size _ = 4
  {-# INLINE size #-}

instance SizedSerializable Word64 where
  size _ = 8
  {-# INLINE size #-}

instance SizedSerializable Word where
#if WORD_SIZE_IN_BITS == 32
  size _ = 4
#else
  size _ = 8
#endif
  {-# INLINE size #-}

instance SizedSerializable Int8 where
  size _ = 1
  {-# INLINE size #-}

instance SizedSerializable Int16 where
  size _ = 2
  {-# INLINE size #-}

instance SizedSerializable Int32 where
  size _ = 4
  {-# INLINE size #-}

instance SizedSerializable Int64 where
  size _ = 8
  {-# INLINE size #-}

instance SizedSerializable Int where
#if WORD_SIZE_IN_BITS == 32
  size _ = 4
#else
  size _ = 8
#endif
  {-# INLINE size #-}

instance (SizedSerializable α, SizedSerializable β)
          SizedSerializable (α, β) where
  size _ = size (Proxy  Proxy α) + size (Proxy  Proxy β)
  {-# INLINE size #-}

-- | Serializable type. 'putRest' must work under assumption that it will not
--   be followed by any more output.
class RestSerializable α where
  putRest  Serializer s  α  s

instance RestSerializable BS.ByteString where
  putRest = byteString
  {-# INLINE putRest #-}

instance RestSerializable SBS.ShortByteString where
  putRest = shortByteString
  {-# INLINE putRest #-}

instance RestSerializable LBS.ByteString where
  putRest = lazyByteString
  {-# INLINE putRest #-}

instance RestSerializable BB.Builder where
  putRest = builder
  {-# INLINE putRest #-}

instance Serializable α  RestSerializable [α] where
  putRest = mconcat . fmap put
  {-# INLINE putRest #-}

instance (Serializable α, RestSerializable β)  RestSerializable (α, β) where
  putRest (a, b) = put a <> putRest b
  {-# INLINE putRest #-}