{-# 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)
putFloatbe :: HasCallStack => Float -> Put
putFloatbe = putWord32be . floatToWord
{-# INLINE putFloatbe #-}
putFloatle :: HasCallStack => Float -> Put
putFloatle = putWord32le . floatToWord
{-# INLINE putFloatle #-}
putFloathost :: HasCallStack => Float -> Put
putFloathost = putWord32host . floatToWord
{-# INLINE putFloathost #-}
putDoublebe :: HasCallStack => Double -> Put
putDoublebe = putWord64be . doubleToWord
{-# INLINE putDoublebe #-}
putDoublele :: HasCallStack => Double -> Put
putDoublele = putWord64le . doubleToWord
{-# INLINE putDoublele #-}
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)
getFloatbe :: HasCallStack => Get Float
getFloatbe = wordToFloat <$> getWord32be
{-# INLINE getFloatbe #-}
getFloatle :: HasCallStack => Get Float
getFloatle = wordToFloat <$> getWord32le
{-# INLINE getFloatle #-}
getFloathost :: HasCallStack => Get Float
getFloathost = wordToFloat <$> getWord32host
{-# INLINE getFloathost #-}
getDoublebe :: HasCallStack => Get Double
getDoublebe = wordToDouble <$> getWord64be
{-# INLINE getDoublebe #-}
getDoublele :: HasCallStack => Get Double
getDoublele = wordToDouble <$> getWord64le
{-# INLINE getDoublele #-}
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