diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,19 @@ +# Version 0.1.1 + +* COMPILER ASSISTED BREAKING CHANGE on `ULEB128`: `getNatural` takes an maximum + number of bytes to process as input. See issue #1. + +* COMPILER ASSISTED BREAKING CHANGE on `SLEB128`: `getInteger` takes an maximum + number of bytes to process as input. See issue #1. + +* Added on `ULEB128`: `putByteString`, `getByteString`, `putShortByteString`, + `getShortByteString`, `putLazyByteString`, `getLazyByteString`, `getIntegral`, + `getInt`, `getInt8`, `getInt16`, `getInt32`, `getInt64`. + +* Added on `ULEB128`: `putNatural`, `putWord`, `putWord8`, `putWord16`, + `putWord32`, `putWord64`, `getNatural`, `getWord`, `getWord8`, `getWord16`, + `getWord32`, `getWord64`. + # Version 0.1 * Initial version diff --git a/leb128-binary.cabal b/leb128-binary.cabal --- a/leb128-binary.cabal +++ b/leb128-binary.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: leb128-binary -version: 0.1 +version: 0.1.1 license: Apache-2.0 license-file: LICENSE extra-source-files: README.md CHANGELOG.md @@ -18,7 +18,7 @@ common basic default-language: Haskell2010 ghc-options: -O2 -Wall - build-depends: base == 4.*, binary + build-depends: base == 4.*, binary, bytestring library import: basic @@ -29,7 +29,7 @@ test-suite test import: basic - ghc-options: -threaded + ghc-options: -O2 -threaded type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs diff --git a/lib/Data/Binary/SLEB128.hs b/lib/Data/Binary/SLEB128.hs --- a/lib/Data/Binary/SLEB128.hs +++ b/lib/Data/Binary/SLEB128.hs @@ -13,6 +13,12 @@ , putInt16 , putInt8 , putInt + , putNatural + , putWord64 + , putWord32 + , putWord16 + , putWord8 + , putWord -- * Get , getInteger , getInt64 @@ -20,6 +26,12 @@ , getInt16 , getInt8 , getInt + , getNatural + , getWord64 + , getWord32 + , getWord16 + , getWord8 + , getWord ) where import Control.Monad @@ -28,6 +40,7 @@ import Data.Bits import Data.Int import Data.Word +import Numeric.Natural -------------------------------------------------------------------------------- @@ -41,63 +54,138 @@ else do Bin.putWord8 $! w8 .|. 0x80 putInteger b +putNatural :: Natural -> Bin.Put +putNatural = putInteger . fromIntegral +{-# INLINE putNatural #-} + -- TODO: The following dispatch to 'putInteger'. Make faster. putInt8 :: Int8 -> Bin.Put putInt8 = putInteger . fromIntegral +{-# INLINE putInt8 #-} putInt16 :: Int16 -> Bin.Put putInt16 = putInteger . fromIntegral +{-# INLINE putInt16 #-} putInt32 :: Int32 -> Bin.Put putInt32 = putInteger . fromIntegral +{-# INLINE putInt32 #-} putInt64 :: Int64 -> Bin.Put putInt64 = putInteger . fromIntegral +{-# INLINE putInt64 #-} putInt :: Int -> Bin.Put putInt = putInteger . fromIntegral +{-# INLINE putInt #-} +putWord8 :: Word8 -> Bin.Put +putWord8 = putInteger . fromIntegral +{-# INLINE putWord8 #-} + +putWord16 :: Word16 -> Bin.Put +putWord16 = putInteger . fromIntegral +{-# INLINE putWord16 #-} + +putWord32 :: Word32 -> Bin.Put +putWord32 = putInteger . fromIntegral +{-# INLINE putWord32 #-} + +putWord64 :: Word64 -> Bin.Put +putWord64 = putInteger . fromIntegral +{-# INLINE putWord64 #-} + +putWord :: Word -> Bin.Put +putWord = putInteger . fromIntegral +{-# INLINE putWord #-} + -------------------------------------------------------------------------------- -getInteger :: Bin.Get Integer -getInteger = f 0 0 +getInteger + :: Word + -- ^ /Maximum/ number of bytes to consume. If the 'Integer' number can be + -- determined before consuming this number of bytes, it will be. If @0@, + -- parsing fails. + -- + -- Each ULEB128 byte encodes at most 7 bits of data. That is, + -- \(length(encoded) == \lceil\frac{length(data)}{7}\rceil\). + -> Bin.Get Integer +getInteger mx = Bin.label "SLEB128" (f mx 0 0) where - f :: Int -> Integer -> Bin.Get Integer - f !p !a = do + f :: Word -> Int -> Integer -> Bin.Get Integer + f 0 _ _ = fail "input too big" + f n !p !a = do w8 <- Bin.getWord8 let b :: Integer = a .|. unsafeShiftL (toInteger (w8 .&. 0x7f)) p case w8 .&. 0x80 of 0 -> pure $! case w8 .&. 0x40 of 0 -> b _ -> b - bit (p + 7) - _ -> f (p + 7) b + _ -> f (n - 1) (p + 7) b +getNatural + :: Word + -- ^ /Maximum/ number of bytes to consume. If the 'Integer' number can be + -- determined before consuming this number of bytes, it will be. If @0@, + -- parsing fails. + -- + -- Each ULEB128 byte encodes at most 7 bits of data. That is, + -- \(length(encoded) == \lceil\frac{length(data)}{7}\rceil\). + -> Bin.Get Natural +getNatural mx = do + i <- getInteger mx + when (i < 0) $ Bin.label "SLEB128" (fail "underflow") + pure (fromInteger i) +{-# INLINE getNatural #-} + -- TODO: The following dispatch to 'getInteger'. Make faster. -getBoundedIntegral :: forall a. (Integral a, Bounded a) => String -> Bin.Get a -getBoundedIntegral label = do - i <- getInteger - when (i < minA) (fail erru) - when (i > maxA) (fail erro) - pure $! fromInteger i - where - erru :: String = label <> ": underflow" - erro :: String = label <> ": overflow" - minA :: Integer = toInteger (minBound :: a) - maxA :: Integer = toInteger (maxBound :: a) +getBoundedIntegral + :: forall a. (Integral a, Bounded a, FiniteBits a) => Bin.Get a +getBoundedIntegral = + let bitSizeA :: Word = fromIntegral (finiteBitSize (undefined :: a)) + mxA :: Word = case divMod bitSizeA 7 of (d, m) -> d + min m 1 + in do i <- getInteger mxA + maybe (fail "underflow or overflow") pure (toIntegralSized i) +{-# INLINE getBoundedIntegral #-} getInt8 :: Bin.Get Int8 -getInt8 = getBoundedIntegral "Data.Binary.SLEB128.getInt8" +getInt8 = getBoundedIntegral +{-# INLINE getInt8 #-} getInt16 :: Bin.Get Int16 -getInt16 = getBoundedIntegral "Data.Binary.SLEB128.getInt16" +getInt16 = getBoundedIntegral +{-# INLINE getInt16 #-} getInt32 :: Bin.Get Int32 -getInt32 = getBoundedIntegral "Data.Binary.SLEB128.getInt32" +getInt32 = getBoundedIntegral +{-# INLINE getInt32 #-} getInt64 :: Bin.Get Int64 -getInt64 = getBoundedIntegral "Data.Binary.SLEB128.getInt64" +getInt64 = getBoundedIntegral +{-# INLINE getInt64 #-} getInt :: Bin.Get Int -getInt = getBoundedIntegral "Data.Binary.SLEB128.getInt" +getInt = getBoundedIntegral +{-# INLINE getInt #-} + +getWord8 :: Bin.Get Word8 +getWord8 = getBoundedIntegral +{-# INLINE getWord8 #-} + +getWord16 :: Bin.Get Word16 +getWord16 = getBoundedIntegral +{-# INLINE getWord16 #-} + +getWord32 :: Bin.Get Word32 +getWord32 = getBoundedIntegral +{-# INLINE getWord32 #-} + +getWord64 :: Bin.Get Word64 +getWord64 = getBoundedIntegral +{-# INLINE getWord64 #-} + +getWord :: Bin.Get Word +getWord = getBoundedIntegral +{-# INLINE getWord #-} diff --git a/lib/Data/Binary/ULEB128.hs b/lib/Data/Binary/ULEB128.hs --- a/lib/Data/Binary/ULEB128.hs +++ b/lib/Data/Binary/ULEB128.hs @@ -12,6 +12,7 @@ , putWord16 , putWord8 , putWord + -- * Get , getNatural , getWord64 @@ -19,11 +20,31 @@ , getWord16 , getWord8 , getWord + , getInteger + , getInt64 + , getInt32 + , getInt16 + , getInt8 + , getInt + + -- * ByteString + , putByteString + , getByteString + -- ** Lazy + , putLazyByteString + , getLazyByteString + -- ** Short + , putShortByteString + , getShortByteString ) where +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Short as BS import qualified Data.Binary.Get as Bin import qualified Data.Binary.Put as Bin import Data.Bits +import Data.Int import Data.Word import Numeric.Natural @@ -40,55 +61,156 @@ putWord8 :: Word8 -> Bin.Put putWord8 = putNatural . fromIntegral +{-# INLINE putWord8 #-} putWord16 :: Word16 -> Bin.Put putWord16 = putNatural . fromIntegral +{-# INLINE putWord16 #-} putWord32 :: Word32 -> Bin.Put putWord32 = putNatural . fromIntegral +{-# INLINE putWord32 #-} putWord64 :: Word64 -> Bin.Put putWord64 = putNatural . fromIntegral +{-# INLINE putWord64 #-} putWord :: Word -> Bin.Put putWord = putNatural . fromIntegral +{-# INLINE putWord #-} -------------------------------------------------------------------------------- -getNatural :: Bin.Get Natural -getNatural = do - w8 <- Bin.getWord8 - if w8 < 0x80 - then pure $! fromIntegral w8 - else do - a <- getNatural - pure $! unsafeShiftL a 7 .|. fromIntegral (w8 .&. 0x7f) +getNatural + :: Word + -- ^ /Maximum/ number of bytes to consume. If the 'Natural' number can be + -- determined before consuming this number of bytes, it will be. If @0@, + -- parsing fails. + -- + -- Each ULEB128 byte encodes at most 7 bits of data. That is, + -- \(length(encoded) == \lceil\frac{length(data)}{7}\rceil\). + -> Bin.Get Natural +getNatural mx = Bin.label "ULEB128" (go mx) + where + go 0 = fail "input too big" + go n = do + w8 <- Bin.getWord8 + if w8 < 0x80 + then pure $! fromIntegral w8 + else do + a <- go (n - 1) + pure $! unsafeShiftL a 7 .|. fromIntegral (w8 .&. 0x7f) +getInteger + :: Word + -- ^ /Maximum/ number of bytes to consume. If the 'Integer' number can be + -- determined before consuming this number of bytes, it will be. If @0@, + -- parsing fails. + -- + -- Each ULEB128 byte encodes at most 7 bits of data. That is, + -- \(length(encoded) == \lceil\frac{length(data)}{7}\rceil\). + -> Bin.Get Integer +getInteger = fmap toInteger . getNatural +{-# INLINE getInteger #-} + -- TODO: The following dispatch to 'getNatural'. Make faster. -getBoundedIntegral :: forall a. (Integral a, Bounded a) => String -> Bin.Get a -getBoundedIntegral label = do - n <- getNatural - let i = toInteger n - if i <= maxA - then pure $! fromInteger i - else fail err - where - err :: String = label <> ": overflow" - maxA :: Integer = toInteger (maxBound :: a) +getBoundedIntegral + :: forall a. (Integral a, Bounded a, FiniteBits a) => Bin.Get a +getBoundedIntegral = + let bitSizeA :: Word = fromIntegral (finiteBitSize (undefined :: a)) + mxA :: Word = case divMod bitSizeA 7 of (d, m) -> d + min m 1 + in do n <- getNatural mxA + maybe (fail "overflow") pure (toIntegralSized n) +{-# INLINE getBoundedIntegral #-} getWord8 :: Bin.Get Word8 -getWord8 = getBoundedIntegral "Data.Binary.ULEB128.getWord8" +getWord8 = getBoundedIntegral +{-# INLINE getWord8 #-} getWord16 :: Bin.Get Word16 -getWord16 = getBoundedIntegral "Data.Binary.ULEB128.getWord16" +getWord16 = getBoundedIntegral +{-# INLINE getWord16 #-} getWord32 :: Bin.Get Word32 -getWord32 = getBoundedIntegral "Data.Binary.ULEB128.getWord32" +getWord32 = getBoundedIntegral +{-# INLINE getWord32 #-} getWord64 :: Bin.Get Word64 -getWord64 = getBoundedIntegral "Data.Binary.ULEB128.getWord64" +getWord64 = getBoundedIntegral +{-# INLINE getWord64 #-} getWord :: Bin.Get Word -getWord = getBoundedIntegral "Data.Binary.ULEB128.getWord" +getWord = getBoundedIntegral +{-# INLINE getWord #-} + +getInt8 :: Bin.Get Int8 +getInt8 = getBoundedIntegral +{-# INLINE getInt8 #-} + +getInt16 :: Bin.Get Int16 +getInt16 = getBoundedIntegral +{-# INLINE getInt16 #-} + +getInt32 :: Bin.Get Int32 +getInt32 = getBoundedIntegral +{-# INLINE getInt32 #-} + +getInt64 :: Bin.Get Int64 +getInt64 = getBoundedIntegral +{-# INLINE getInt64 #-} + +getInt :: Bin.Get Int +getInt = getBoundedIntegral +{-# INLINE getInt #-} + +-------------------------------------------------------------------------------- + +-- | Puts a strict 'B.ByteString' with its ULEB128-encoded length as prefix. +-- +-- See 'getByteString'. +putByteString :: B.ByteString -> Bin.Put +putByteString = \a -> do + putNatural (fromIntegral (B.length a :: Int)) + Bin.putByteString a +{-# INLINE putByteString #-} + +-- | Gets a strict 'B.ByteString' with its ULEB128-encoded length as prefix. +-- +-- See 'putByteString'. +getByteString :: Bin.Get B.ByteString +getByteString = Bin.getByteString =<< getInt +{-# INLINE getByteString #-} + +-- | Puts a lazy 'B.ByteString' with its ULEB128-encoded length as prefix. +-- +-- See 'getLazyByteString'. +putLazyByteString :: BL.ByteString -> Bin.Put +putLazyByteString = \a -> do + putNatural (fromIntegral (BL.length a :: Int64)) + Bin.putLazyByteString a +{-# INLINE putLazyByteString #-} + +-- | Gets a lazy 'BL.ByteString' with its ULEB128-encoded length as prefix. +-- +-- See 'putLazyByteString'. +getLazyByteString :: Bin.Get BL.ByteString +getLazyByteString = Bin.getLazyByteString =<< getInt64 +{-# INLINE getLazyByteString #-} + +-- | Puts a 'BS.ShortByteString' with its ULEB128-encoded length as prefix. +-- +-- See 'getShortByteString'. +putShortByteString :: BS.ShortByteString -> Bin.Put +putShortByteString = \a -> do + putNatural (fromIntegral (BS.length a :: Int)) + Bin.putShortByteString a +{-# INLINE putShortByteString #-} + +-- | Gets a 'BS.ShortByteString' with its ULEB128-encoded length as prefix. +-- +-- See 'putShortByteString'. +getShortByteString :: Bin.Get BS.ShortByteString +getShortByteString = fmap BS.toShort (Bin.getByteString =<< getInt) +{-# INLINE getShortByteString #-} diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,19 +1,24 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} module Main where +import Control.Monad import qualified Data.Binary.Get as Bin import qualified Data.Binary.Put as Bin +import Data.Bits +import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Short as BS +import Data.Foldable import Data.Int -import Data.Word import Numeric.Natural import Test.Tasty (TestTree, testGroup) import qualified Test.Tasty as Tasty -import Test.Tasty.HUnit (testCase, (@?=)) -import Test.Tasty.Hedgehog (testProperty, HedgehogTestLimit (..)) +import Test.Tasty.HUnit (testCase, (@?=), Assertion) +import Test.Tasty.Hedgehog (HedgehogTestLimit (..), testProperty) import qualified Test.Tasty.Runners as Tasty -import Hedgehog (forAll, property, (===)) +import Hedgehog (MonadTest, forAll, property, (===)) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range @@ -36,7 +41,16 @@ tt_ULEB128 :: TestTree tt_ULEB128 = testGroup "ULEB128" - [ testGroup "Known" + [ testGroup "Too big" + [ testCase "0, 0" $ dec (U.getNatural 0) "" @?= Left "input too big\nULEB128" + , testCase "0, 1" $ dec (U.getNatural 0) "\x00" @?= Left "input too big\nULEB128" + , testCase "0, 1.5" $ dec (U.getNatural 0) "\x80" @?= Left "input too big\nULEB128" + , testCase "1, 1.5" $ dec (U.getNatural 1) "\x80" @?= Left "input too big\nULEB128" + , testCase "1, 2" $ dec (U.getNatural 1) "\x80\x01" @?= Left "input too big\nULEB128" + , testCase "1, 3" $ dec (U.getNatural 1) "\xfd\x82\x01" @?= Left "input too big\nULEB128" + , testCase "2, 3" $ dec (U.getNatural 2) "\xfd\x82\x01" @?= Left "input too big\nULEB128" + ] + , testGroup "Known" [ tt_ULEB128_known 0 "\x00" , tt_ULEB128_known 1 "\x01" , tt_ULEB128_known 6 "\x06" @@ -817,159 +831,82 @@ , tt_ULEB128_known 18247503505561409945 "\x99\xb3\xbb\xb5\xa4\xf8\x89\x9e\xfd\x01" ] , testGroup "Round trip" - [ testGroup "putWord8" - [ testProperty "getWord8" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec U.getWord8 (enc (U.putWord8 n)) === Right n - , testProperty "getWord16" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec U.getWord16 (enc (U.putWord8 n)) === Right (fromIntegral n) - , testProperty "getWord16" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec U.getWord16 (enc (U.putWord8 n)) === Right (fromIntegral n) - , testProperty "getWord32" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec U.getWord32 (enc (U.putWord8 n)) === Right (fromIntegral n) - , testProperty "getWord64" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec U.getWord64 (enc (U.putWord8 n)) === Right (fromIntegral n) - , testProperty "getWord" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec U.getWord (enc (U.putWord8 n)) === Right (fromIntegral n) - , testProperty "getNatural" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec U.getNatural (enc (U.putWord8 n)) === Right (fromIntegral n) - ] - , testGroup "putWord16" - [ testProperty "getWord8" $ property $ do - n <- forAll $ Gen.integral $ Range.constantBounded - let n' = fromIntegral (n :: Word8) - dec U.getWord8 (enc (U.putWord16 n')) === Right n - , testProperty "getWord16" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec U.getWord16 (enc (U.putWord16 n)) === Right n - , testProperty "getWord16" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec U.getWord16 (enc (U.putWord16 n)) === Right (fromIntegral n) - , testProperty "getWord32" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec U.getWord32 (enc (U.putWord16 n)) === Right (fromIntegral n) - , testProperty "getWord64" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec U.getWord64 (enc (U.putWord16 n)) === Right (fromIntegral n) - , testProperty "getWord" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec U.getWord (enc (U.putWord16 n)) === Right (fromIntegral n) - , testProperty "getNatural" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec U.getNatural (enc (U.putWord16 n)) === Right (fromIntegral n) - ] - , testGroup "putWord32" - [ testProperty "getWord8" $ property $ do - n <- forAll $ Gen.integral $ Range.constantBounded - let n' = fromIntegral (n :: Word8) - dec U.getWord8 (enc (U.putWord32 n')) === Right n - , testProperty "getWord16" $ property $ do - n <- forAll $ Gen.integral $ Range.constantBounded - let n' = fromIntegral (n :: Word16) - dec U.getWord16 (enc (U.putWord32 n')) === Right n - , testProperty "getWord32" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec U.getWord32 (enc (U.putWord32 n)) === Right n - , testProperty "getWord64" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec U.getWord64 (enc (U.putWord32 n)) === Right (fromIntegral n) - , testProperty "getWord" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec U.getWord (enc (U.putWord32 n)) === Right (fromIntegral n) - , testProperty "getNatural" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec U.getNatural (enc (U.putWord32 n)) === Right (fromIntegral n) - ] - , testGroup "putWord64" - [ testProperty "getWord8" $ property $ do - n <- forAll $ Gen.integral $ Range.constantBounded - let n' = fromIntegral (n :: Word8) - dec U.getWord8 (enc (U.putWord64 n')) === Right n - , testProperty "getWord16" $ property $ do - n <- forAll $ Gen.integral $ Range.constantBounded - let n' = fromIntegral (n :: Word16) - dec U.getWord16 (enc (U.putWord64 n')) === Right n - , testProperty "getWord32" $ property $ do - n <- forAll $ Gen.integral $ Range.constantBounded - let n' = fromIntegral (n :: Word32) - dec U.getWord32 (enc (U.putWord64 n')) === Right n - , testProperty "getWord64" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec U.getWord64 (enc (U.putWord64 n)) === Right n - , testProperty "getWord" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec U.getWord (enc (U.putWord32 n)) === Right (fromIntegral n) - , testProperty "getNatural" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec U.getNatural (enc (U.putWord64 n)) === Right (fromIntegral n) - ] - , testGroup "putWord" - [ testProperty "getWord8" $ property $ do - n <- forAll $ Gen.integral $ Range.constantBounded - let n' = fromIntegral (n :: Word8) - dec U.getWord8 (enc (U.putWord n')) === Right n - , testProperty "getWord16" $ property $ do - n <- forAll $ Gen.integral $ Range.constantBounded - let n' = fromIntegral (n :: Word16) - dec U.getWord16 (enc (U.putWord n')) === Right n - , testProperty "getWord32" $ property $ do - n <- forAll $ Gen.integral $ Range.constantBounded - let n' = fromIntegral (n :: Word32) - dec U.getWord32 (enc (U.putWord n')) === Right n - , testProperty "getWord64" $ property $ do - n <- forAll $ Gen.integral $ Range.constantBounded - let n' = fromIntegral (n :: Word64) - dec U.getWord64 (enc (U.putWord n')) === Right n - , testProperty "getWord" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec U.getWord (enc (U.putWord n)) === Right n - , testProperty "getNatural" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec U.getNatural (enc (U.putWord n)) === Right (fromIntegral n) - ] - , testGroup "putNatural" - [ testProperty "getWord8" $ property $ do - n <- forAll $ Gen.integral $ Range.constantBounded - let n' = fromIntegral (n :: Word8) - dec U.getWord8 (enc (U.putNatural n')) === Right n - , testProperty "getWord16" $ property $ do - n <- forAll $ Gen.integral $ Range.constantBounded - let n' = fromIntegral (n :: Word16) - dec U.getWord16 (enc (U.putNatural n')) === Right n - , testProperty "getWord32" $ property $ do - n <- forAll $ Gen.integral $ Range.constantBounded - let n' = fromIntegral (n :: Word32) - dec U.getWord32 (enc (U.putNatural n')) === Right n - , testProperty "getWord64" $ property $ do - n <- forAll $ Gen.integral $ Range.constantBounded - let n' = fromIntegral (n :: Word64) - dec U.getWord64 (enc (U.putNatural n')) === Right n - , testProperty "getWord" $ property $ do - n <- forAll $ Gen.integral $ Range.constantBounded - let n' = fromIntegral (n :: Word) - dec U.getWord (enc (U.putNatural n')) === Right n - , testProperty "getNatural" $ property $ do - n <- forAll $ Gen.integral rangeNatural512 - dec U.getNatural (enc (U.putNatural n)) === Right n - ] + [ testProperty "putWord8" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + propDecULEB128 n (enc (U.putWord8 n)) + , testProperty "putWord16" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + propDecULEB128 n (enc (U.putWord16 n)) + , testProperty "putWord32" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + propDecULEB128 n (enc (U.putWord32 n)) + , testProperty "putWord64" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + propDecULEB128 n (enc (U.putWord64 n)) + , testProperty "putWord" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + propDecULEB128 n (enc (U.putWord n)) + , testProperty "putNatural" $ property $ do + n <- forAll $ Gen.integral rangeNatural512 + propDecULEB128 n (enc (U.putNatural n)) ] + , testGroup "ByteString (strict)" + [ testProperty "Round trip" $ property $ do + i <- forAll $ Gen.integral $ Range.constantFrom 0 0 1000 + let raw = B.replicate i 222 + dec U.getByteString (enc (U.putByteString raw)) === Right raw + + , testProperty "Known" $ property $ do + i <- forAll $ Gen.integral $ Range.constantFrom 0 0 1000 + let pre = enc (U.putWord (fromIntegral (i :: Int))) + raw = B.replicate i 222 + enc (U.putByteString raw) === pre <> BL.fromStrict raw + ] + , testGroup "ByteString (lazy)" + [ testProperty "Round trip" $ property $ do + i <- forAll $ Gen.integral $ Range.constantFrom 0 0 1000 + let raw = BL.replicate i 222 + dec U.getLazyByteString (enc (U.putLazyByteString raw)) === Right raw + + , testProperty "Known" $ property $ do + i <- forAll $ Gen.integral $ Range.constantFrom 0 0 1000 + let pre = enc (U.putWord (fromIntegral (i :: Int64))) + raw = BL.replicate i 222 + enc (U.putLazyByteString raw) === pre <> raw + ] + , testGroup "ByteString (strict)" + [ testProperty "Round trip" $ property $ do + i <- forAll $ Gen.integral $ Range.constantFrom 0 0 1000 + let raw = BS.toShort (B.replicate i 222) + dec U.getShortByteString (enc (U.putShortByteString raw)) === Right raw + + , testProperty "Known" $ property $ do + i <- forAll $ Gen.integral $ Range.constantFrom 0 0 1000 + let pre = enc (U.putWord (fromIntegral (i :: Int))) + raw = BS.toShort (B.replicate i 222) + enc (U.putShortByteString raw) + === pre <> BL.fromStrict (BS.fromShort raw) + ] ] tt_ULEB128_known :: Natural -> BL.ByteString -> TestTree tt_ULEB128_known n bl = testGroup (show n) [ testCase "put" $ enc (U.putNatural n) @?= bl - , testCase "get" $ dec U.getNatural bl @?= Right n + , testCase "get" $ assertDecULEB128 n bl ] tt_SLEB128 :: TestTree tt_SLEB128 = testGroup "SLEB128" - [ testGroup "Known" + [ testGroup "Too big" + [ testCase "0, 0" $ dec (S.getInteger 0) "" @?= Left "input too big\nSLEB128" + , testCase "0, 1" $ dec (S.getInteger 0) "\x00" @?= Left "input too big\nSLEB128" + , testCase "0, 1.5" $ dec (S.getInteger 0) "\x80" @?= Left "input too big\nSLEB128" + , testCase "1, 1.5" $ dec (S.getInteger 1) "\x80" @?= Left "input too big\nSLEB128" + , testCase "1, 2" $ dec (S.getInteger 1) "\x89\x3b" @?= Left "input too big\nSLEB128" + , testCase "1, 3" $ dec (S.getInteger 1) "\xc9\xc1\x00" @?= Left "input too big\nSLEB128" + , testCase "2, 3" $ dec (S.getInteger 2) "\xc9\xc1\x00" @?= Left "input too big\nSLEB128" + ] + , testGroup "Known" [ tt_SLEB128_known (-9015451631251509835) "\xb5\xdb\xa6\xec\x9d\xd0\xab\xf1\x82\x7f" , tt_SLEB128_known (-8845873988257394623) "\xc1\xa0\xb3\x90\x9a\x8f\xc9\x9e\x85\x7f" , tt_SLEB128_known (-8842841274936780126) "\xa2\xb5\xec\xd1\xe3\xd6\xfa\xa3\x85\x7f" @@ -1896,157 +1833,110 @@ , tt_SLEB128_known 9159289276857505834 "\xaa\xb0\x8b\xf1\x9b\xa2\x95\x8e\xff\x00" ] , testGroup "Round trip" - [ testGroup "putInt8" - [ testProperty "getInt8" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec S.getInt8 (enc (S.putInt8 n)) === Right n - , testProperty "getInt16" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec S.getInt16 (enc (S.putInt8 n)) === Right (fromIntegral n) - , testProperty "getInt16" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec S.getInt16 (enc (S.putInt8 n)) === Right (fromIntegral n) - , testProperty "getInt32" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec S.getInt32 (enc (S.putInt8 n)) === Right (fromIntegral n) - , testProperty "getInt64" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec S.getInt64 (enc (S.putInt8 n)) === Right (fromIntegral n) - , testProperty "getInt" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec S.getInt (enc (S.putInt8 n)) === Right (fromIntegral n) - , testProperty "getInteger" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec S.getInteger (enc (S.putInt8 n)) === Right (fromIntegral n) - ] - , testGroup "putInt16" - [ testProperty "getInt8" $ property $ do - n <- forAll $ Gen.integral $ Range.constantBounded - let n' = fromIntegral (n :: Int8) - dec S.getInt8 (enc (S.putInt16 n')) === Right n - , testProperty "getInt16" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec S.getInt16 (enc (S.putInt16 n)) === Right n - , testProperty "getInt16" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec S.getInt16 (enc (S.putInt16 n)) === Right (fromIntegral n) - , testProperty "getInt32" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec S.getInt32 (enc (S.putInt16 n)) === Right (fromIntegral n) - , testProperty "getInt64" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec S.getInt64 (enc (S.putInt16 n)) === Right (fromIntegral n) - , testProperty "getInt" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec S.getInt (enc (S.putInt16 n)) === Right (fromIntegral n) - , testProperty "getInteger" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec S.getInteger (enc (S.putInt16 n)) === Right (fromIntegral n) - ] - , testGroup "putInt32" - [ testProperty "getInt8" $ property $ do - n <- forAll $ Gen.integral $ Range.constantBounded - let n' = fromIntegral (n :: Int8) - dec S.getInt8 (enc (S.putInt32 n')) === Right n - , testProperty "getInt16" $ property $ do - n <- forAll $ Gen.integral $ Range.constantBounded - let n' = fromIntegral (n :: Int16) - dec S.getInt16 (enc (S.putInt32 n')) === Right n - , testProperty "getInt32" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec S.getInt32 (enc (S.putInt32 n)) === Right n - , testProperty "getInt64" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec S.getInt64 (enc (S.putInt32 n)) === Right (fromIntegral n) - , testProperty "getInt" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec S.getInt (enc (S.putInt32 n)) === Right (fromIntegral n) - , testProperty "getInteger" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec S.getInteger (enc (S.putInt32 n)) === Right (fromIntegral n) - ] - , testGroup "putInt64" - [ testProperty "getInt8" $ property $ do - n <- forAll $ Gen.integral $ Range.constantBounded - let n' = fromIntegral (n :: Int8) - dec S.getInt8 (enc (S.putInt64 n')) === Right n - , testProperty "getInt16" $ property $ do - n <- forAll $ Gen.integral $ Range.constantBounded - let n' = fromIntegral (n :: Int16) - dec S.getInt16 (enc (S.putInt64 n')) === Right n - , testProperty "getInt32" $ property $ do - n <- forAll $ Gen.integral $ Range.constantBounded - let n' = fromIntegral (n :: Int32) - dec S.getInt32 (enc (S.putInt64 n')) === Right n - , testProperty "getInt64" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec S.getInt64 (enc (S.putInt64 n)) === Right n - , testProperty "getInt" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec S.getInt (enc (S.putInt32 n)) === Right (fromIntegral n) - , testProperty "getInteger" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec S.getInteger (enc (S.putInt64 n)) === Right (fromIntegral n) - ] - , testGroup "putInt" - [ testProperty "getInt8" $ property $ do - n <- forAll $ Gen.integral $ Range.constantBounded - let n' = fromIntegral (n :: Int8) - dec S.getInt8 (enc (S.putInt n')) === Right n - , testProperty "getInt16" $ property $ do - n <- forAll $ Gen.integral $ Range.constantBounded - let n' = fromIntegral (n :: Int16) - dec S.getInt16 (enc (S.putInt n')) === Right n - , testProperty "getInt32" $ property $ do - n <- forAll $ Gen.integral $ Range.constantBounded - let n' = fromIntegral (n :: Int32) - dec S.getInt32 (enc (S.putInt n')) === Right n - , testProperty "getInt64" $ property $ do - n <- forAll $ Gen.integral $ Range.constantBounded - let n' = fromIntegral (n :: Int64) - dec S.getInt64 (enc (S.putInt n')) === Right n - , testProperty "getInt" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec S.getInt (enc (S.putInt n)) === Right n - , testProperty "getInteger" $ property $ do - n <- forAll $ Gen.integral Range.constantBounded - dec S.getInteger (enc (S.putInt n)) === Right (fromIntegral n) - ] - , - testGroup "putInteger" - [ testProperty "getInt8" $ property $ do - n <- forAll $ Gen.integral $ Range.constantBounded - let n' = fromIntegral (n :: Int8) - dec S.getInt8 (enc (S.putInteger n')) === Right n - , testProperty "getInt16" $ property $ do - n <- forAll $ Gen.integral $ Range.constantBounded - let n' = fromIntegral (n :: Int16) - dec S.getInt16 (enc (S.putInteger n')) === Right n - , testProperty "getInt32" $ property $ do - n <- forAll $ Gen.integral $ Range.constantBounded - let n' = fromIntegral (n :: Int32) - dec S.getInt32 (enc (S.putInteger n')) === Right n - , testProperty "getInt64" $ property $ do - n <- forAll $ Gen.integral $ Range.constantBounded - let n' = fromIntegral (n :: Int64) - dec S.getInt64 (enc (S.putInteger n')) === Right n - , testProperty "getInt" $ property $ do - n <- forAll $ Gen.integral $ Range.constantBounded - let n' = fromIntegral (n :: Int) - dec S.getInt (enc (S.putInteger n')) === Right n - , testProperty "getInteger" $ property $ do - n <- forAll $ Gen.integral rangeInteger512 - dec S.getInteger (enc (S.putInteger n)) === Right n - ] + [ testProperty "putInt8" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + propDecSLEB128 n (enc (S.putInt8 n)) + , testProperty "putInt16" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + propDecSLEB128 n (enc (S.putInt16 n)) + , testProperty "putInt32" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + propDecSLEB128 n (enc (S.putInt32 n)) + , testProperty "putInt64" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + propDecSLEB128 n (enc (S.putInt64 n)) + , testProperty "putInt" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + propDecSLEB128 n (enc (S.putInt n)) + , testProperty "putInteger" $ property $ do + i <- forAll $ Gen.integral rangeInteger512 + propDecSLEB128 i (enc (S.putInteger i)) + , testProperty "putWord8" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + propDecSLEB128 n (enc (S.putWord8 n)) + , testProperty "putWord16" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + propDecSLEB128 n (enc (S.putWord16 n)) + , testProperty "putWord32" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + propDecSLEB128 n (enc (S.putWord32 n)) + , testProperty "putWord64" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + propDecSLEB128 n (enc (S.putWord64 n)) + , testProperty "putWord" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + propDecSLEB128 n (enc (S.putWord n)) + , testProperty "putNatural" $ property $ do + n <- forAll $ Gen.integral rangeNatural512 + propDecSLEB128 n (enc (S.putNatural n)) ] ] tt_SLEB128_known :: Integer -> BL.ByteString -> TestTree tt_SLEB128_known i bl = testGroup (show i) [ testCase "put" $ enc (S.putInteger i) @?= bl - , testCase "get" $ dec S.getInteger bl @?= Right i + , testCase "get" $ assertDecSLEB128 i bl ] +propDecULEB128 + :: (Integral a, Bits a, MonadTest m) => a -> BL.ByteString -> m () +propDecULEB128 = decULEB128 (===) + +assertDecULEB128 + :: (Integral a, Bits a) => a -> BL.ByteString -> Assertion +assertDecULEB128 = decULEB128 (@?=) + +decULEB128 + :: (Integral a, Bits a, Monad m) + => (forall x. (Eq x, Show x) => x -> x -> m ()) + -> a + -> BL.ByteString + -> m () +decULEB128 eq = \a bl -> do + let l = fromIntegral (BL.length bl) :: Word + for_ (toIntegralSized a) $ \b -> eq (dec (U.getNatural l) bl) (Right b) + for_ (toIntegralSized a) $ \b -> eq (dec (U.getInteger l) bl) (Right b) + for_ (toIntegralSized a) $ \b -> eq (dec U.getWord bl) (Right b) + for_ (toIntegralSized a) $ \b -> eq (dec U.getWord8 bl) (Right b) + for_ (toIntegralSized a) $ \b -> eq (dec U.getWord16 bl) (Right b) + for_ (toIntegralSized a) $ \b -> eq (dec U.getWord32 bl) (Right b) + for_ (toIntegralSized a) $ \b -> eq (dec U.getWord64 bl) (Right b) + for_ (toIntegralSized a) $ \b -> eq (dec U.getInt bl) (Right b) + for_ (toIntegralSized a) $ \b -> eq (dec U.getInt8 bl) (Right b) + for_ (toIntegralSized a) $ \b -> eq (dec U.getInt16 bl) (Right b) + for_ (toIntegralSized a) $ \b -> eq (dec U.getInt32 bl) (Right b) + for_ (toIntegralSized a) $ \b -> eq (dec U.getInt64 bl) (Right b) + +propDecSLEB128 + :: (Integral a, Bits a, MonadTest m) => a -> BL.ByteString -> m () +propDecSLEB128 = decSLEB128 (===) + +assertDecSLEB128 + :: (Integral a, Bits a) => a -> BL.ByteString -> Assertion +assertDecSLEB128 = decSLEB128 (@?=) + +decSLEB128 + :: (Integral a, Bits a, Monad m) + => (forall x. (Eq x, Show x) => x -> x -> m ()) + -> a + -> BL.ByteString + -> m () +decSLEB128 eq = \a bl -> do + let i = toInteger a + l = fromIntegral (BL.length bl) :: Word + when (a >= 0) $ eq (dec (S.getNatural l) bl) (Right (fromInteger i)) + for_ (toIntegralSized i) $ \b -> eq (dec (S.getInteger l) bl) (Right b) + for_ (toIntegralSized i) $ \b -> eq (dec S.getWord bl) (Right b) + for_ (toIntegralSized i) $ \b -> eq (dec S.getWord8 bl) (Right b) + for_ (toIntegralSized i) $ \b -> eq (dec S.getWord16 bl) (Right b) + for_ (toIntegralSized i) $ \b -> eq (dec S.getWord32 bl) (Right b) + for_ (toIntegralSized i) $ \b -> eq (dec S.getWord64 bl) (Right b) + for_ (toIntegralSized i) $ \b -> eq (dec S.getInt bl) (Right b) + for_ (toIntegralSized i) $ \b -> eq (dec S.getInt8 bl) (Right b) + for_ (toIntegralSized i) $ \b -> eq (dec S.getInt16 bl) (Right b) + for_ (toIntegralSized i) $ \b -> eq (dec S.getInt32 bl) (Right b) + for_ (toIntegralSized i) $ \b -> eq (dec S.getInt64 bl) (Right b) + rangeInteger512 :: Range.Range Integer rangeInteger512 = let x = 2 ^ (511 :: Int) :: Integer @@ -2063,5 +1953,4 @@ Left (_, _, e) -> Left e Right (l, _, a) | BL.null l -> Right a | otherwise -> Left "parsed successfully, but got leftovers" -