{-# LANGUAGE CPP #-}
module Util.Binary
    ( runGetA
    , BinaryGetError(..)
    , runPutA
    , putFloatbe
    , putFloatle
    , putFloathost
    , putDoublebe
    , putDoublele
    , putDoublehost
    , putLength16beByteString
    , putLength32beByteString
    , putWithLength16be
    , putWithLength32be
    , putChar8
    , getChar8
    , getFloatbe
    , getFloatle
    , getFloathost
    , getDoublebe
    , getDoublele
    , getDoublehost
    , getLength8ByteString
    , getLength16beByteString
    , getLength32beByteString
    , getWithLength16be
    , matchWord8
    , matchChar8
    ) where

import           Data.Binary.Get
import           Data.Binary.Put
import qualified Data.ByteString      as BS
import qualified Data.ByteString.Lazy as LBS
import           Data.Char
import           Data.Int             (Int64)
import           Data.Word

#if !MIN_VERSION_binary(0,8,5)
import           Util.FloatCast
#endif
import           Util.IOExtra
import GHC.Stack (HasCallStack)

--------------------------------------------------------------------------------
runGetA :: (HasCallStack, Monad m)
        => (Int -> m BS.ByteString)
        -> (BS.ByteString -> m ())
        -> Get a
        -> m (Either BinaryGetError a)
runGetA :: (Int -> m ByteString)
-> (ByteString -> m ()) -> Get a -> m (Either BinaryGetError a)
runGetA Int -> m ByteString
readA ByteString -> m ()
unreadA Get a
getA =
    Decoder a -> m ByteString -> m (Either BinaryGetError a)
forall b. Decoder b -> m ByteString -> m (Either BinaryGetError b)
feed (Get a -> Decoder a
forall a. Get a -> Decoder a
runGetIncremental Get a
getA) (Int -> m ByteString
readA Int
2048)
  where
    feed :: Decoder b -> m ByteString -> m (Either BinaryGetError b)
feed (Done ByteString
unused ByteOffset
_pos b
output) m ByteString
_input = do
        ByteString -> m ()
unreadA ByteString
unused
        Either BinaryGetError b -> m (Either BinaryGetError b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either BinaryGetError b -> m (Either BinaryGetError b))
-> Either BinaryGetError b -> m (Either BinaryGetError b)
forall a b. (a -> b) -> a -> b
$ b -> Either BinaryGetError b
forall a b. b -> Either a b
Right b
output
    feed (Fail ByteString
unused ByteOffset
pos String
msg) m ByteString
_input = do
        ByteString -> m ()
unreadA ByteString
unused
        Either BinaryGetError b -> m (Either BinaryGetError b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either BinaryGetError b -> m (Either BinaryGetError b))
-> Either BinaryGetError b -> m (Either BinaryGetError b)
forall a b. (a -> b) -> a -> b
$ BinaryGetError -> Either BinaryGetError b
forall a b. a -> Either a b
Left (BinaryGetError -> Either BinaryGetError b)
-> BinaryGetError -> Either BinaryGetError b
forall a b. (a -> b) -> a -> b
$ ByteOffset -> String -> BinaryGetError
BinaryGetError ByteOffset
pos String
msg
    feed (Partial Maybe ByteString -> Decoder b
k) m ByteString
input = do
        ByteString
chunk <- m ByteString
input
        if ByteString -> Bool
BS.null ByteString
chunk then Decoder b -> m ByteString -> m (Either BinaryGetError b)
feed (Maybe ByteString -> Decoder b
k Maybe ByteString
forall a. Maybe a
Nothing) m ByteString
input else Decoder b -> m ByteString -> m (Either BinaryGetError b)
feed (Maybe ByteString -> Decoder b
k (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
chunk)) m ByteString
input

data BinaryGetError = BinaryGetError { BinaryGetError -> ByteOffset
position :: Int64
                                     , BinaryGetError -> String
message  :: String
                                     }
    deriving Int -> BinaryGetError -> ShowS
[BinaryGetError] -> ShowS
BinaryGetError -> String
(Int -> BinaryGetError -> ShowS)
-> (BinaryGetError -> String)
-> ([BinaryGetError] -> ShowS)
-> Show BinaryGetError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BinaryGetError] -> ShowS
$cshowList :: [BinaryGetError] -> ShowS
show :: BinaryGetError -> String
$cshow :: BinaryGetError -> String
showsPrec :: Int -> BinaryGetError -> ShowS
$cshowsPrec :: Int -> BinaryGetError -> ShowS
Show

instance Exception BinaryGetError

runPutA :: HasCallStack => (LBS.ByteString -> m ()) -> Put -> m ()
runPutA :: (ByteString -> m ()) -> Put -> m ()
runPutA = ((ByteString -> m ()) -> (Put -> ByteString) -> Put -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPut)

#if !MIN_VERSION_binary(0,8,5)
--------------------------------------------------------------------------------
------------------------------------------------------------------------
-- Floats/Doubles
-- | Write a 'Float' in big endian IEEE-754 format.
putFloatbe :: HasCallStack => Float -> Put
putFloatbe = putWord32be . floatToWord

{-# INLINE putFloatbe #-}

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

{-# INLINE putFloatle #-}

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

{-# INLINE putFloathost #-}

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

{-# INLINE putDoublebe #-}

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

{-# INLINE putDoublele #-}

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

{-# INLINE putDoublehost #-}
#endif

--------------------------------------------------------------------------------
putLength16beByteString :: HasCallStack => BS.ByteString -> Put
putLength16beByteString :: ByteString -> Put
putLength16beByteString ByteString
bs = do
    Word16 -> Put
putWord16be (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
bs))
    ByteString -> Put
putByteString ByteString
bs

putLength32beByteString :: HasCallStack => BS.ByteString -> Put
putLength32beByteString :: ByteString -> Put
putLength32beByteString ByteString
bs = do
    Word32 -> Put
putWord32be (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
bs))
    ByteString -> Put
putByteString ByteString
bs

--------------------------------------------------------------------------------
putWithLength16be :: HasCallStack => Put -> Put
putWithLength16be :: Put -> Put
putWithLength16be Put
putA = do
    let bl :: ByteString
bl = Put -> ByteString
runPut Put
putA
        len :: ByteOffset
len = ByteString -> ByteOffset
LBS.length ByteString
bl
    Word16 -> Put
putWord16be (ByteOffset -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral ByteOffset
len)
    ByteString -> Put
putLazyByteString ByteString
bl

putWithLength32be :: HasCallStack => Put -> Put
putWithLength32be :: Put -> Put
putWithLength32be Put
putA = do
    let bl :: ByteString
bl = Put -> ByteString
runPut Put
putA
        len :: ByteOffset
len = ByteString -> ByteOffset
LBS.length ByteString
bl
    Word32 -> Put
putWord32be (ByteOffset -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral ByteOffset
len)
    ByteString -> Put
putLazyByteString ByteString
bl

--------------------------------------------------------------------------------
putChar8 :: HasCallStack => Char -> Put
putChar8 :: Char -> Put
putChar8 = Word8 -> Put
putWord8 (Word8 -> Put) -> (Char -> Word8) -> Char -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord

getChar8 :: HasCallStack => Get Char
getChar8 :: Get Char
getChar8 = Int -> Char
chr (Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Char) -> Get Word8 -> Get Char
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
getWord8

#if !MIN_VERSION_binary(0,8,5)
------------------------------------------------------------------------
-- Double/Float reads
-- | Read a 'Float' in big endian IEEE-754 format.
getFloatbe :: HasCallStack => Get Float
getFloatbe = wordToFloat <$> getWord32be

{-# INLINE getFloatbe #-}

-- | Read a 'Float' in little endian IEEE-754 format.
getFloatle :: HasCallStack => Get Float
getFloatle = wordToFloat <$> getWord32le

{-# INLINE getFloatle #-}

-- | Read a 'Float' in IEEE-754 format and host endian.
getFloathost :: HasCallStack => Get Float
getFloathost = wordToFloat <$> getWord32host

{-# INLINE getFloathost #-}

-- | Read a 'Double' in big endian IEEE-754 format.
getDoublebe :: HasCallStack => Get Double
getDoublebe = wordToDouble <$> getWord64be

{-# INLINE getDoublebe #-}

-- | Read a 'Double' in little endian IEEE-754 format.
getDoublele :: HasCallStack => Get Double
getDoublele = wordToDouble <$> getWord64le

{-# INLINE getDoublele #-}

-- | Read a 'Double' in IEEE-754 format and host endian.
getDoublehost :: HasCallStack => Get Double
getDoublehost = wordToDouble <$> getWord64host

{-# INLINE getDoublehost #-}
#endif

--------------------------------------------------------------------------------
getLength8ByteString :: HasCallStack => Get BS.ByteString
getLength8ByteString :: Get ByteString
getLength8ByteString = Get Word8
getWord8 Get Word8 -> (Word8 -> Get ByteString) -> Get ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Get ByteString
getByteString (Int -> Get ByteString)
-> (Word8 -> Int) -> Word8 -> Get ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral

getLength16beByteString :: HasCallStack => Get BS.ByteString
getLength16beByteString :: Get ByteString
getLength16beByteString =
    Get Word16
getWord16be Get Word16 -> (Word16 -> Get ByteString) -> Get ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Get ByteString
getByteString (Int -> Get ByteString)
-> (Word16 -> Int) -> Word16 -> Get ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral

getLength32beByteString :: HasCallStack => Get BS.ByteString
getLength32beByteString :: Get ByteString
getLength32beByteString =
    Get Word32
getWord32be Get Word32 -> (Word32 -> Get ByteString) -> Get ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Get ByteString
getByteString (Int -> Get ByteString)
-> (Word32 -> Int) -> Word32 -> Get ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral

--------------------------------------------------------------------------------
getWithLength16be :: HasCallStack => Get a -> Get (a, Word16)
getWithLength16be :: Get a -> Get (a, Word16)
getWithLength16be Get a
getA = do
    ByteOffset
pos0 <- Get ByteOffset
bytesRead
    a
res <- Get a
getA
    ByteOffset
pos1 <- Get ByteOffset
bytesRead
    (a, Word16) -> Get (a, Word16)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
res, ByteOffset -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteOffset
pos1 ByteOffset -> ByteOffset -> ByteOffset
forall a. Num a => a -> a -> a
- ByteOffset
pos0))

--------------------------------------------------------------------------------
matchWord8 :: HasCallStack => Word8 -> Get ()
matchWord8 :: Word8 -> Get ()
matchWord8 Word8
expected = do
    Word8
actual <- Get Word8
getWord8
    if Word8
expected Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
actual then () -> Get ()
forall (m :: * -> *) a. Monad m => a -> m a
return () else String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get ()) -> String -> Get ()
forall a b. (a -> b) -> a -> b
$ String
"expected " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
expected String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", actual " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
actual

matchChar8 :: HasCallStack => Char -> Get ()
matchChar8 :: Char -> Get ()
matchChar8 = HasCallStack => Word8 -> Get ()
Word8 -> Get ()
matchWord8 (Word8 -> Get ()) -> (Char -> Word8) -> Char -> Get ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord