{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Haskus.Format.Binary.Serialize
( PutMonad (..)
, GetMonad (..)
, Serializable (..)
, Size (..)
, putWord16BE
, putWord32BE
, putWord64BE
, putWord16LE
, putWord32LE
, putWord64LE
, putWord16BEs
, putWord32BEs
, putWord64BEs
, putWord16LEs
, putWord32LEs
, putWord64LEs
, getWord16BE
, getWord32BE
, getWord64BE
, getWord16LE
, getWord32LE
, getWord64LE
, getWord16BEs
, getWord32BEs
, getWord64BEs
, getWord16LEs
, getWord32LEs
, getWord64LEs
)
where
import Haskus.Memory.Buffer
import Haskus.Format.Binary.Word
import Haskus.Format.Binary.Endianness
import Haskus.Utils.Types
import Haskus.Utils.Monad
import GHC.Exts (IsList(..))
class Monad m => PutMonad m where
putWord8 :: Word8 -> m ()
putWord16 :: Word16 -> m ()
putWord32 :: Word32 -> m ()
putWord64 :: Word64 -> m ()
putWord8s :: [Word8] -> m ()
putWord8s xs = forM_ xs putWord8
putWord16s :: [Word16] -> m ()
putWord16s xs = forM_ xs putWord16
putWord32s :: [Word32] -> m ()
putWord32s xs = forM_ xs putWord32
putWord64s :: [Word64] -> m ()
putWord64s xs = forM_ xs putWord64
putBuffer :: Buffer mut pin gc heap -> m ()
preAllocateAtLeast :: Word -> m ()
preAllocateAtLeast _ = return ()
class Monad m => GetMonad m where
getWord8 :: m Word8
getWord16 :: m Word16
getWord32 :: m Word32
getWord64 :: m Word64
getWord8s :: Word -> m [Word8]
getWord8s n = replicateM (fromIntegral n) getWord8
getWord16s :: Word -> m [Word16]
getWord16s n = replicateM (fromIntegral n) getWord16
getWord32s :: Word -> m [Word32]
getWord32s n = replicateM (fromIntegral n) getWord32
getWord64s :: Word -> m [Word64]
getWord64s n = replicateM (fromIntegral n) getWord64
getBuffer :: Word -> m BufferI
getBuffer n = do
xs <- replicateM (fromIntegral n) getWord8
return (fromListN (fromIntegral n) xs)
getBufferInto :: Word -> Buffer 'Mutable pin gc heap -> m ()
data Size
= Exactly Nat
| AtLeast Nat
| Dynamic
class Serializable a where
type SizeOf a :: Size
type Endian a :: Bool
sizeOf :: a -> Word
put :: PutMonad m => Endianness -> a -> m ()
get :: GetMonad m => Endianness -> Word -> m a
putWord16LE :: PutMonad m => Word16 -> m ()
putWord16LE x = putWord16 (hostToLittleEndian x)
putWord32LE :: PutMonad m => Word32 -> m ()
putWord32LE x = putWord32 (hostToLittleEndian x)
putWord64LE :: PutMonad m => Word64 -> m ()
putWord64LE x = putWord64 (hostToLittleEndian x)
putWord16BE :: PutMonad m => Word16 -> m ()
putWord16BE x = putWord16 (hostToBigEndian x)
putWord32BE :: PutMonad m => Word32 -> m ()
putWord32BE x = putWord32 (hostToBigEndian x)
putWord64BE :: PutMonad m => Word64 -> m ()
putWord64BE x = putWord64 (hostToBigEndian x)
putWord16LEs :: PutMonad m => [Word16] -> m ()
putWord16LEs xs = putWord16s (fmap hostToLittleEndian xs)
putWord32LEs :: PutMonad m => [Word32] -> m ()
putWord32LEs xs = putWord32s (fmap hostToLittleEndian xs)
putWord64LEs :: PutMonad m => [Word64] -> m ()
putWord64LEs xs = putWord64s (fmap hostToLittleEndian xs)
putWord16BEs :: PutMonad m => [Word16] -> m ()
putWord16BEs xs = putWord16s (fmap hostToBigEndian xs)
putWord32BEs :: PutMonad m => [Word32] -> m ()
putWord32BEs xs = putWord32s (fmap hostToBigEndian xs)
putWord64BEs :: PutMonad m => [Word64] -> m ()
putWord64BEs xs = putWord64s (fmap hostToBigEndian xs)
getWord16LE :: GetMonad m => m Word16
getWord16LE = littleEndianToHost <$> getWord16
getWord32LE :: GetMonad m => m Word32
getWord32LE = littleEndianToHost <$> getWord32
getWord64LE :: GetMonad m => m Word64
getWord64LE = littleEndianToHost <$> getWord64
getWord16BE :: GetMonad m => m Word16
getWord16BE = bigEndianToHost <$> getWord16
getWord32BE :: GetMonad m => m Word32
getWord32BE = bigEndianToHost <$> getWord32
getWord64BE :: GetMonad m => m Word64
getWord64BE = bigEndianToHost <$> getWord64
getWord16LEs :: GetMonad m => Word -> m [Word16]
getWord16LEs n = fmap littleEndianToHost <$> getWord16s n
getWord32LEs :: GetMonad m => Word -> m [Word32]
getWord32LEs n = fmap littleEndianToHost <$> getWord32s n
getWord64LEs :: GetMonad m => Word -> m [Word64]
getWord64LEs n = fmap littleEndianToHost <$> getWord64s n
getWord16BEs :: GetMonad m => Word -> m [Word16]
getWord16BEs n = fmap bigEndianToHost <$> getWord16s n
getWord32BEs :: GetMonad m => Word -> m [Word32]
getWord32BEs n = fmap bigEndianToHost <$> getWord32s n
getWord64BEs :: GetMonad m => Word -> m [Word64]
getWord64BEs n = fmap bigEndianToHost <$> getWord64s n
instance Serializable Word8 where
type SizeOf Word8 = 'Exactly 1
type Endian Word8 = 'False
sizeOf _ = 1
put _ x = putWord8 x
get _ _ = getWord8
instance Serializable Word16 where
type SizeOf Word16 = 'Exactly 2
type Endian Word16 = 'True
sizeOf _ = 2
put LittleEndian x = putWord16LE x
put BigEndian x = putWord16BE x
get LittleEndian _ = getWord16LE
get BigEndian _ = getWord16BE
instance Serializable Word32 where
type SizeOf Word32 = 'Exactly 4
type Endian Word32 = 'True
sizeOf _ = 4
put LittleEndian x = putWord32LE x
put BigEndian x = putWord32BE x
get LittleEndian _ = getWord32LE
get BigEndian _ = getWord32BE
instance Serializable Word64 where
type SizeOf Word64 = 'Exactly 8
type Endian Word64 = 'True
sizeOf _ = 8
put LittleEndian x = putWord64LE x
put BigEndian x = putWord64BE x
get LittleEndian _ = getWord64LE
get BigEndian _ = getWord64BE
instance Serializable Int8 where
type SizeOf Int8 = 'Exactly 1
type Endian Int8 = 'False
sizeOf _ = 1
put _ x = putWord8 (fromIntegral x)
get _ _ = fromIntegral <$> getWord8
instance Serializable Int16 where
type SizeOf Int16 = 'Exactly 2
type Endian Int16 = 'True
sizeOf _ = 2
put LittleEndian x = putWord16LE (fromIntegral x)
put BigEndian x = putWord16BE (fromIntegral x)
get LittleEndian _ = fromIntegral <$> getWord16LE
get BigEndian _ = fromIntegral <$> getWord16BE
instance Serializable Int32 where
type SizeOf Int32 = 'Exactly 4
type Endian Int32 = 'True
sizeOf _ = 4
put LittleEndian x = putWord32LE (fromIntegral x)
put BigEndian x = putWord32BE (fromIntegral x)
get LittleEndian _ = fromIntegral <$> getWord32LE
get BigEndian _ = fromIntegral <$> getWord32BE
instance Serializable Int64 where
type SizeOf Int64 = 'Exactly 8
type Endian Int64 = 'True
sizeOf _ = 8
put LittleEndian x = putWord64LE (fromIntegral x)
put BigEndian x = putWord64BE (fromIntegral x)
get LittleEndian _ = fromIntegral <$> getWord64LE
get BigEndian _ = fromIntegral <$> getWord64BE
instance Serializable BufferI where
type SizeOf BufferI = 'Dynamic
type Endian BufferI = 'False
sizeOf b = bufferSize b
put _ x = putBuffer x
get _ sz = getBuffer sz
instance Serializable a => Serializable (AsBigEndian a) where
type SizeOf (AsBigEndian a) = SizeOf a
type Endian (AsBigEndian a) = 'False
sizeOf (AsBigEndian b) = sizeOf b
put _ (AsBigEndian x) = put BigEndian x
get _ sz = AsBigEndian <$> get BigEndian sz
instance Serializable a => Serializable (AsLittleEndian a) where
type SizeOf (AsLittleEndian a) = SizeOf a
type Endian (AsLittleEndian a) = 'False
sizeOf (AsLittleEndian b) = sizeOf b
put _ (AsLittleEndian x) = put LittleEndian x
get _ sz = AsLittleEndian <$> get LittleEndian sz