diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,13 @@ +# Version 0.1.2 + +* Faster `ULEB128` and `SLEB128` encoding and decoding. + +* Added `ZLEB128`. That is, ZigZag encoding of signed numbers in combination + with `ULEB128`. + +* Added benchmarks. + + # Version 0.1.1 * COMPILER ASSISTED BREAKING CHANGE on `ULEB128`: `getNatural` takes an maximum @@ -10,9 +20,10 @@ `getShortByteString`, `putLazyByteString`, `getLazyByteString`, `getIntegral`, `getInt`, `getInt8`, `getInt16`, `getInt32`, `getInt64`. -* Added on `ULEB128`: `putNatural`, `putWord`, `putWord8`, `putWord16`, - `putWord32`, `putWord64`, `getNatural`, `getWord`, `getWord8`, `getWord16`, +* Added on `ULEB128`: `putNatural`, `putWord`, `putWord8`, `putWord16`, + `putWord32`, `putWord64`, `getNatural`, `getWord`, `getWord8`, `getWord16`, `getWord32`, `getWord64`. + # Version 0.1 diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,297 @@ +module Main where + +import Control.Applicative +import Control.DeepSeq +import Control.Exception +import Data.Binary qualified as Bin +import Data.Binary.Get qualified as Bin +import Data.Binary.Put qualified as Bin +import Data.Bits +import Data.ByteString.Lazy qualified as BL +import Data.Coerce +import Data.Foldable +import Data.Int +import Data.Word +import GHC.Stack +import Numeric.Natural +import Test.Tasty.Bench + +import Data.Binary.SLEB128 qualified as S +import Data.Binary.ULEB128 qualified as U +import Data.Binary.ZLEB128 qualified as Z + +-------------------------------------------------------------------------------- + +interleave :: [a] -> [a] -> [a] +interleave (x : xs) (y : ys) = x : y : interleave xs ys +interleave [] ys = ys +interleave xs [] = xs +{-# INLINE interleave #-} + +enum :: (Num a, Bits a, Enum a) => a -> a -> [a] +enum mn mx = + interleave + (enumFromThenTo mn (mn + 2) (mx - 1)) + (enumFromThenTo mx (mx - 2) (mn + 1)) +{-# INLINE enum #-} + +bounded :: (Num a, Bits a, Enum a, Bounded a) => [a] +bounded = enum minBound maxBound +{-# INLINE bounded #-} + +runGetFull :: HasCallStack => Bin.Get a -> BL.ByteString -> a +runGetFull ga = \b -> case Bin.runGetOrFail ga b of + Right (l, _, a) + | BL.null l -> a + | otherwise -> error "Unexpected leftovers" + Left (_, _, e) -> error e + +-------------------------------------------------------------------------------- + +takeInts :: Int -> [Int] +takeInts = flip take (cycle bounded) + +takeUInts :: Int -> [Word] +takeUInts = flip take (cycle (enum minBound (fromIntegral (maxBound :: Int)))) + +takeInt8s :: Int -> [Int8] +takeInt8s = flip take (cycle bounded) + +takeUInt8s :: Int -> [Word8] +takeUInt8s = flip take (cycle (enum minBound (fromIntegral (maxBound :: Int8)))) + +takeWords :: Int -> [Word] +takeWords = flip take (cycle bounded) + +takeWord8s :: Int -> [Word8] +takeWord8s = flip take (cycle bounded) + +takeIntegers :: Int -> Int -> [Integer] +takeIntegers bits = + flip take (cycle (enum (-(2 ^ (bits - 1))) (2 ^ (bits - 1) - 1))) + +takeUIntegers :: Int -> Int -> [Natural] +takeUIntegers bits = flip take (cycle (enum 0 (2 ^ (bits - 1) - 1))) + +takeNaturals :: Int -> Int -> [Natural] +takeNaturals bits = flip take (cycle (enum 0 (2 ^ bits - 1))) + +-------------------------------------------------------------------------------- + +putManyU :: forall a. Bin.Binary (U.ULEB128 a) => [a] -> BL.ByteString +putManyU = + let pa = coerce (Bin.put :: U.ULEB128 a -> Bin.Put) :: a -> Bin.Put + in Bin.runPut . traverse_ pa + +getInt8sU :: BL.ByteString -> [Int8] +getInt8sU = runGetFull (some U.getInt8) + +getIntsU :: BL.ByteString -> [Int] +getIntsU = runGetFull (some U.getInt) + +getIntegersU :: BL.ByteString -> [Integer] +getIntegersU = runGetFull (some (U.getInteger 100)) + +getAllU + :: forall a + . (HasCallStack, Bin.Binary (U.ULEB128 a)) + => BL.ByteString + -> [a] +getAllU = + let ga = coerce (Bin.get :: Bin.Get (U.ULEB128 a)) :: Bin.Get a + in runGetFull (some ga) + +-------------------------------------------------------------------------------- + +putManyZ :: forall a. Bin.Binary (Z.ZLEB128 a) => [a] -> BL.ByteString +putManyZ = + let pa = coerce (Bin.put :: Z.ZLEB128 a -> Bin.Put) :: a -> Bin.Put + in Bin.runPut . traverse_ pa + +getAllZ + :: forall a + . (HasCallStack, Bin.Binary (Z.ZLEB128 a)) + => BL.ByteString + -> [a] +getAllZ = + let ga = coerce (Bin.get :: Bin.Get (Z.ZLEB128 a)) :: Bin.Get a + in runGetFull (some ga) + +-------------------------------------------------------------------------------- + +putManyS :: forall a. Bin.Binary (S.SLEB128 a) => [a] -> BL.ByteString +putManyS = + let pa = coerce (Bin.put :: S.SLEB128 a -> Bin.Put) :: a -> Bin.Put + in Bin.runPut . traverse_ pa + +getAllS + :: forall a + . (HasCallStack, Bin.Binary (S.SLEB128 a)) + => BL.ByteString + -> [a] +getAllS = + let ga = coerce (Bin.get :: Bin.Get (S.SLEB128 a)) :: Bin.Get a + in runGetFull (some ga) + +-------------------------------------------------------------------------------- + +ntests :: Int +ntests = 1_000_000 + +envPure :: NFData e => e -> (e -> Benchmark) -> Benchmark +envPure e k = env (evaluate (force e)) k + +main :: IO () +main = + defaultMain + [ bgroup + ("Generate " <> show ntests) + [ bench "Word8" $ nf takeWord8s ntests + , bench "Int8" $ nf takeInt8s ntests + , bench "Word" $ nf takeWords ntests + , bench "Int" $ nf takeInts ntests + , bench "Natural32" $ nf (takeNaturals 32) ntests + , bench "Integer32" $ nf (takeIntegers 32) ntests + , bench "Natural64" $ nf (takeNaturals 64) ntests + , bench "Integer64" $ nf (takeIntegers 64) ntests + , bench "Natural256" $ nf (takeNaturals 256) ntests + , bench "Integer256" $ nf (takeIntegers 256) ntests + ] + , bgroup + "ULEB128" + [ bgroup + ("Encode " <> show ntests) + [ envPure (takeWord8s ntests) $ \e -> + bench "Word8" $ nf (putManyU @Word8) e + , envPure (takeWords ntests) $ \e -> + bench "Word" $ nf (putManyU @Word) e + , envPure (takeNaturals 32 ntests) $ \e -> + bench "Natural32" $ nf (putManyU @Natural) e + , envPure (takeNaturals 64 ntests) $ \e -> + bench "Natural64" $ nf (putManyU @Natural) e + , envPure (takeNaturals 256 ntests) $ \e -> + bench "Natural256" $ nf (putManyU @Natural) e + ] + , bgroup + ("Decode " <> show ntests) + [ envPure (putManyU @Word8 (takeWord8s ntests)) $ \e -> + bench "Word8" $ nf (getAllU @Word8) e + , envPure (putManyU @Word8 (takeUInt8s ntests)) $ \e -> + bench "Int8" $ nf getInt8sU e + , envPure (putManyU @Word (takeWords ntests)) $ \e -> + bench "Word" $ nf (getAllU @Word) e + , envPure (putManyU @Word (takeUInts ntests)) $ \e -> + bench "Int" $ nf getIntsU e + , envPure (putManyU @Natural (takeNaturals 32 ntests)) $ \e -> + bench "Natural32" $ nf (getAllU @Natural) e + , envPure (putManyU @Natural (takeUIntegers 32 ntests)) $ \e -> + bench "Integer32" $ nf getIntegersU e + , envPure (putManyU @Natural (takeNaturals 64 ntests)) $ \e -> + bench "Natural64" $ nf (getAllU @Natural) e + , envPure (putManyU @Natural (takeUIntegers 64 ntests)) $ \e -> + bench "Integer64" $ nf getIntegersU e + , envPure (putManyU @Natural (takeNaturals 256 ntests)) $ \e -> + bench "Natural256" $ nf (getAllU @Natural) e + , envPure (putManyU @Natural (takeUIntegers 256 ntests)) $ \e -> + bench "Integer256" $ nf getIntegersU e + ] + ] + , bgroup + "ZLEB128" + [ bgroup + ("Encode " <> show ntests) + [ envPure (takeWord8s ntests) $ \e -> + bench "Word8" $ nf (putManyZ @Word8) e + , envPure (takeInt8s ntests) $ \e -> + bench "Int8" $ nf (putManyZ @Int8) e + , envPure (takeWords ntests) $ \e -> + bench "Word" $ nf (putManyZ @Word) e + , envPure (takeInts ntests) $ \e -> + bench "Int" $ nf (putManyZ @Int) e + , envPure (takeNaturals 32 ntests) $ \e -> + bench "Natural32" $ nf (putManyZ @Natural) e + , envPure (takeIntegers 32 ntests) $ \e -> + bench "Integer32" $ nf (putManyZ @Integer) e + , envPure (takeNaturals 64 ntests) $ \e -> + bench "Natural64" $ nf (putManyZ @Natural) e + , envPure (takeIntegers 64 ntests) $ \e -> + bench "Integer64" $ nf (putManyZ @Integer) e + , envPure (takeNaturals 256 ntests) $ \e -> + bench "Natural256" $ nf (putManyZ @Natural) e + , envPure (takeIntegers 256 ntests) $ \e -> + bench "Integer256" $ nf (putManyZ @Integer) e + ] + , bgroup + ("Decode " <> show ntests) + [ envPure (putManyZ @Word8 (takeWord8s ntests)) $ \e -> + bench "Word8" $ nf (getAllZ @Word8) e + , envPure (putManyZ @Int8 (takeInt8s ntests)) $ \e -> + bench "Int8" $ nf (getAllZ @Int8) e + , envPure (putManyZ @Word (takeWords ntests)) $ \e -> + bench "Word" $ nf (getAllZ @Word) e + , envPure (putManyZ @Int (takeInts ntests)) $ \e -> + bench "Int" $ nf (getAllZ @Int) e + , envPure (putManyZ @Natural (takeNaturals 32 ntests)) $ \e -> + bench "Natural32" $ nf (getAllZ @Natural) e + , envPure (putManyZ @Integer (takeIntegers 32 ntests)) $ \e -> + bench "Integer32" $ nf (getAllZ @Integer) e + , envPure (putManyZ @Natural (takeNaturals 64 ntests)) $ \e -> + bench "Natural64" $ nf (getAllZ @Natural) e + , envPure (putManyZ @Integer (takeIntegers 64 ntests)) $ \e -> + bench "Integer64" $ nf (getAllZ @Integer) e + , envPure (putManyZ @Natural (takeNaturals 256 ntests)) $ \e -> + bench "Natural256" $ nf (getAllZ @Natural) e + , envPure (putManyZ @Integer (takeIntegers 256 ntests)) $ \e -> + bench "Integer256" $ nf (getAllZ @Integer) e + ] + ] + , bgroup + "SLEB128" + [ bgroup + ("Encode " <> show ntests) + [ envPure (takeWord8s ntests) $ \e -> + bench "Word8" $ nf (putManyS @Word8) e + , envPure (takeInt8s ntests) $ \e -> + bench "Int8" $ nf (putManyS @Int8) e + , envPure (takeWords ntests) $ \e -> + bench "Word" $ nf (putManyS @Word) e + , envPure (takeInts ntests) $ \e -> + bench "Int" $ nf (putManyS @Int) e + , envPure (takeNaturals 32 ntests) $ \e -> + bench "Natural32" $ nf (putManyS @Natural) e + , envPure (takeIntegers 32 ntests) $ \e -> + bench "Integer32" $ nf (putManyS @Integer) e + , envPure (takeNaturals 64 ntests) $ \e -> + bench "Natural64" $ nf (putManyS @Natural) e + , envPure (takeIntegers 64 ntests) $ \e -> + bench "Integer64" $ nf (putManyS @Integer) e + , envPure (takeNaturals 256 ntests) $ \e -> + bench "Natural256" $ nf (putManyS @Natural) e + , envPure (takeIntegers 256 ntests) $ \e -> + bench "Integer256" $ nf (putManyS @Integer) e + ] + , bgroup + ("Decode " <> show ntests) + [ envPure (putManyS @Word8 (takeWord8s ntests)) $ \e -> + bench "Word8" $ nf (getAllS @Word8) e + , envPure (putManyS @Int8 (takeInt8s ntests)) $ \e -> + bench "Int8" $ nf (getAllS @Int8) e + , envPure (putManyS @Word (takeWords ntests)) $ \e -> + bench "Word" $ nf (getAllS @Word) e + , envPure (putManyS @Int (takeInts ntests)) $ \e -> + bench "Int" $ nf (getAllS @Int) e + , envPure (putManyS @Natural (takeNaturals 32 ntests)) $ \e -> + bench "Natural32" $ nf (getAllS @Natural) e + , envPure (putManyS @Integer (takeIntegers 32 ntests)) $ \e -> + bench "Integer32" $ nf (getAllS @Integer) e + , envPure (putManyS @Natural (takeNaturals 64 ntests)) $ \e -> + bench "Natural64" $ nf (getAllS @Natural) e + , envPure (putManyS @Integer (takeIntegers 64 ntests)) $ \e -> + bench "Integer64" $ nf (getAllS @Integer) e + , envPure (putManyS @Natural (takeNaturals 256 ntests)) $ \e -> + bench "Natural256" $ nf (getAllS @Natural) e + , envPure (putManyS @Integer (takeIntegers 256 ntests)) $ \e -> + bench "Integer256" $ nf (getAllS @Integer) e + ] + ] + ] 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.1 +version: 0.1.2 license: Apache-2.0 license-file: LICENSE extra-source-files: README.md CHANGELOG.md @@ -13,30 +13,54 @@ description: Signed and unsigned LEB128 codec for @binary@ library. homepage: https://gitlab.com/k0001/leb128-binary bug-reports: https://gitlab.com/k0001/leb128-binary/issues -tested-with: GHC == 9.0.1 +tested-with: GHC == 9.6.2 +extra-source-files: + README.md + CHANGELOG.md common basic - default-language: Haskell2010 - ghc-options: -O2 -Wall - build-depends: base == 4.*, binary, bytestring + default-language: GHC2021 + ghc-options: -O2 -Wall + build-depends: + base == 4.*, + binary, + bytestring, + default-extensions: + DataKinds + LambdaCase + MagicHash + MultiWayIf + TypeFamilies -library +library import: basic hs-source-dirs: lib - exposed-modules: - Data.Binary.ULEB128 + exposed-modules: Data.Binary.SLEB128 + Data.Binary.ULEB128 + Data.Binary.ZLEB128 + other-modules: test-suite test import: basic - ghc-options: -O2 -threaded + ghc-options: -threaded type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs build-depends: - bytestring, hedgehog, leb128-binary, tasty, tasty-hedgehog, tasty-hunit, + +benchmark bench + import: basic + ghc-options: -O2 -threaded -with-rtsopts=-A32m -fproc-alignment=64 + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Main.hs + build-depends: + deepseq, + leb128-binary, + tasty-bench, 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 @@ -1,13 +1,22 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -ddump-simpl -ddump-to-file #-} --- | Signed LEB128 codec. +#include + +-- | __Signed LEB128 codec__. This codec encodes the two's complement +-- of a signed number +-- [as described here](https://en.wikipedia.org/wiki/LEB128#Signed_LEB128). -- --- Any /getXXX/ decoder can decode bytes generated using any of the /putXXX/ +-- Any /getXXX/ decoder can decode bytes generated using any of the /putXXX/ -- encoders, provided the encoded number fits in the target type. +-- +-- __WARNING__: This is not compatible with the /Unsigned LEB128/ codec at +-- "Data.Binary.ULEB128" nor with the /ZigZag LEB128/ codec at +-- "Data.Binary.ZLEB128". module Data.Binary.SLEB128 - ( -- * Put - putInteger + ( SLEB128(..) + -- * Put + , putInteger , putInt64 , putInt32 , putInt16 @@ -34,158 +43,335 @@ , getWord ) where -import Control.Monad -import qualified Data.Binary.Get as Bin -import qualified Data.Binary.Put as Bin +import Data.Binary qualified as Bin +import Data.Binary.Get qualified as Bin +import Data.Binary.Put qualified as Bin +import Data.ByteString.Builder.Prim qualified as BB +import Data.ByteString.Builder.Prim.Internal qualified as BB import Data.Bits -import Data.Int -import Data.Word -import Numeric.Natural +import Data.Coerce +import GHC.Exts +import GHC.Int +import GHC.Word +import GHC.Num.BigNat +import GHC.Num.Natural +import GHC.Num.Integer +import Foreign.Ptr +import Foreign.Storable -------------------------------------------------------------------------------- +-- | Newtype wrapper for 'Bin.Binary' encoding and decoding @x@ using the +-- /Signed LEB128/ codec. Useful in conjunction with @DerivingVia@. +newtype SLEB128 x = SLEB128 x + +-- | Note: Maximum allowed number of input bytes is restricted to 1000. +-- Use 'putNatural' if you want a greater limit. +instance Bin.Binary (SLEB128 Integer) where + put = coerce putInteger + {-# INLINE put #-} + get = coerce (getInteger 1000) + {-# INLINE get #-} + +-- | Note: Maximum allowed number of input bytes is restricted to 1000. +-- Use 'putNatural' if you want a greater limit. +instance Bin.Binary (SLEB128 Natural) where + put = coerce putNatural + {-# INLINE put #-} + get = coerce (getNatural 1000) + {-# INLINE get #-} + +instance Bin.Binary (SLEB128 Int) where + put = coerce putInt + {-# INLINE put #-} + get = coerce getInt + {-# INLINE get #-} + +instance Bin.Binary (SLEB128 Word) where + put = coerce putWord + {-# INLINE put #-} + get = coerce getWord + {-# INLINE get #-} + +instance Bin.Binary (SLEB128 Int8) where + put = coerce putInt8 + {-# INLINE put #-} + get = coerce getInt8 + {-# INLINE get #-} + +instance Bin.Binary (SLEB128 Word8) where + put = coerce putWord8 + {-# INLINE put #-} + get = coerce getWord8 + {-# INLINE get #-} + +instance Bin.Binary (SLEB128 Int16) where + put = coerce putInt16 + {-# INLINE put #-} + get = coerce getInt16 + {-# INLINE get #-} + +instance Bin.Binary (SLEB128 Word16) where + put = coerce putWord16 + {-# INLINE put #-} + get = coerce getWord16 + {-# INLINE get #-} + +instance Bin.Binary (SLEB128 Int32) where + put = coerce putInt32 + {-# INLINE put #-} + get = coerce getInt32 + {-# INLINE get #-} + +instance Bin.Binary (SLEB128 Word32) where + put = coerce putWord32 + {-# INLINE put #-} + get = coerce getWord32 + {-# INLINE get #-} + +instance Bin.Binary (SLEB128 Int64) where + put = coerce putInt64 + {-# INLINE put #-} + get = coerce getInt64 + {-# INLINE get #-} + +instance Bin.Binary (SLEB128 Word64) where + put = coerce putWord64 + {-# INLINE put #-} + get = coerce getWord64 + {-# INLINE get #-} + +-------------------------------------------------------------------------------- + +{-# INLINE putInteger #-} putInteger :: Integer -> Bin.Put -putInteger = \a -> do - let w8 = fromIntegral (a .&. 0x7f) :: Word8 - b = unsafeShiftR a 7 - w8s = w8 .&. 0x40 - if (w8s == 0 && b == 0) || (w8s /= 0 && b == -1) - then Bin.putWord8 w8 - else do Bin.putWord8 $! w8 .|. 0x80 - putInteger b +putInteger = \case + IS x -> putInt (I# x) + IP x -> putIP x $ fromIntegral (bigNatSizeInBase 2 x) + IN x -> putIN x + where + {-# INLINE putIP #-} + putIP :: BigNat# -> Int -> Bin.Put + putIP !a !m = do + Bin.putWord8 (W8# (wordToWord8# (or# (bigNatIndex# a 0#) 0x80##))) + let b = bigNatShiftR# a 7## :: BigNat# + n = m - 7 + if n > WORD_SIZE_IN_BITS - 1 + then putIP b n + else putInt (I# (word2Int# (bigNatIndex# b 0#))) + -- TODO: Faster 'putIN' implementation, similar to 'putIP' + {-# INLINE putIN #-} + putIN :: BigNat# -> Bin.Put + putIN !a = do + let b = unsafeShiftR (IN a) 7 :: Integer + c = fromIntegral (IN a .&. 0x7f) :: Word8 + d = c .&. 0x40 + if d /= 0 && b == -1 + then Bin.putWord8 c + else do Bin.putWord8 $! c .|. 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 +putInt8 = Bin.putBuilder . BB.primBounded (BB.boundedPrim 2 unsafePoke) {-# INLINE putInt8 #-} putInt16 :: Int16 -> Bin.Put -putInt16 = putInteger . fromIntegral +putInt16 = Bin.putBuilder . BB.primBounded (BB.boundedPrim 3 unsafePoke) {-# INLINE putInt16 #-} putInt32 :: Int32 -> Bin.Put -putInt32 = putInteger . fromIntegral +putInt32 = Bin.putBuilder . BB.primBounded (BB.boundedPrim 5 unsafePoke) {-# INLINE putInt32 #-} putInt64 :: Int64 -> Bin.Put -putInt64 = putInteger . fromIntegral +putInt64 = Bin.putBuilder . BB.primBounded (BB.boundedPrim 10 unsafePoke) {-# INLINE putInt64 #-} putInt :: Int -> Bin.Put -putInt = putInteger . fromIntegral +putInt = +#if WORD_SIZE_IN_BITS == 64 + Bin.putBuilder . BB.primBounded (BB.boundedPrim 10 unsafePoke) +#elif WORD_SIZE_IN_BITS == 32 + Bin.putBuilder . BB.primBounded (BB.boundedPrim 5 unsafePoke) +#endif {-# INLINE putInt #-} putWord8 :: Word8 -> Bin.Put -putWord8 = putInteger . fromIntegral +putWord8 = Bin.putBuilder . BB.primBounded (BB.boundedPrim 2 unsafePoke) {-# INLINE putWord8 #-} putWord16 :: Word16 -> Bin.Put -putWord16 = putInteger . fromIntegral +putWord16 = Bin.putBuilder . BB.primBounded (BB.boundedPrim 3 unsafePoke) {-# INLINE putWord16 #-} putWord32 :: Word32 -> Bin.Put -putWord32 = putInteger . fromIntegral +putWord32 = Bin.putBuilder . BB.primBounded (BB.boundedPrim 5 unsafePoke) {-# INLINE putWord32 #-} putWord64 :: Word64 -> Bin.Put -putWord64 = putInteger . fromIntegral +putWord64 = Bin.putBuilder . BB.primBounded (BB.boundedPrim 10 unsafePoke) {-# INLINE putWord64 #-} putWord :: Word -> Bin.Put -putWord = putInteger . fromIntegral +putWord = +#if WORD_SIZE_IN_BITS == 64 + Bin.putBuilder . BB.primBounded (BB.boundedPrim 10 unsafePoke) +#elif WORD_SIZE_IN_BITS == 32 + Bin.putBuilder . BB.primBounded (BB.boundedPrim 5 unsafePoke) +#endif {-# INLINE putWord #-} -------------------------------------------------------------------------------- -getInteger - :: Word +getInteger + :: Int -- ^ /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. + -- 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, + -- 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) +getInteger = unsafeGetSigned toInteger +{-# INLINE getInteger #-} + +-- | Like 'getInteger', except it's offered here so that other parsers can use +-- this specilized to types other than 'Integer'. This is unsafe because it +-- only works for signed numbers whose SLEB128 representation is at most as +-- long as the specified 'Int', but none of that is checked by this parser. +{-# INLINE unsafeGetSigned #-} +unsafeGetSigned + :: forall a. (Bits a, Num a) => (Word8 -> a) -> Int -> Bin.Get a +unsafeGetSigned fromWord8 = \m -> Bin.label "SLEB128" (go m 0 0) where - 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 (n - 1) (p + 7) b + {-# INLINE go #-} + go :: Int -> Int -> a -> Bin.Get a + go m i o | i < m = do + w <- Bin.getWord8 + let !a = o .|. unsafeShiftL (fromWord8 (w .&. 0x7f)) (i * 7) + if w >= 0x80 then go m (i + 1) a + else pure $! a - bit ((i + 1) * 7) + * fromWord8 (unsafeShiftR (w .&. 0x40) 6) + go _ _ _ = fail "input exceeds maximum allowed bytes" 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. + :: Int + -- ^ /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, + -- 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. +getNatural = \m -> do + i <- getInteger m + Bin.label "SLEB128" (naturalFromInteger i) +{-# INLINE getNatural #-} -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) +getBoundedIntegral + :: forall a b + . (Bits a, Integral a, Bits b, Integral b) + => Bin.Get a + -> Bin.Get b +getBoundedIntegral = \ga -> do + a <- ga + maybe (fail "underflow or overflow") pure (toIntegralSized a) {-# INLINE getBoundedIntegral #-} getInt8 :: Bin.Get Int8 -getInt8 = getBoundedIntegral +getInt8 = unsafeGetSigned fromIntegral 2 {-# INLINE getInt8 #-} getInt16 :: Bin.Get Int16 -getInt16 = getBoundedIntegral +getInt16 = unsafeGetSigned fromIntegral 3 {-# INLINE getInt16 #-} getInt32 :: Bin.Get Int32 -getInt32 = getBoundedIntegral +getInt32 = unsafeGetSigned fromIntegral 5 {-# INLINE getInt32 #-} getInt64 :: Bin.Get Int64 -getInt64 = getBoundedIntegral +getInt64 = unsafeGetSigned fromIntegral 10 {-# INLINE getInt64 #-} getInt :: Bin.Get Int -getInt = getBoundedIntegral +getInt = +#if WORD_SIZE_IN_BITS == 64 + unsafeGetSigned fromIntegral 10 +#elif WORD_SIZE_IN_BITS == 32 + unsafeGetSigned fromIntegral 5 +#endif {-# INLINE getInt #-} getWord8 :: Bin.Get Word8 -getWord8 = getBoundedIntegral +getWord8 = getBoundedIntegral (unsafeGetSigned @Int16 fromIntegral 2) {-# INLINE getWord8 #-} getWord16 :: Bin.Get Word16 -getWord16 = getBoundedIntegral +getWord16 = getBoundedIntegral (unsafeGetSigned @Int32 fromIntegral 3) {-# INLINE getWord16 #-} getWord32 :: Bin.Get Word32 -getWord32 = getBoundedIntegral +getWord32 = getBoundedIntegral (unsafeGetSigned @Int64 fromIntegral 5) {-# INLINE getWord32 #-} getWord64 :: Bin.Get Word64 -getWord64 = getBoundedIntegral +getWord64 = getBoundedIntegral (getInteger 10) {-# INLINE getWord64 #-} getWord :: Bin.Get Word -getWord = getBoundedIntegral +getWord = +#if WORD_SIZE_IN_BITS == 64 + getBoundedIntegral (getInteger 10) +#elif WORD_SIZE_IN_BITS == 32 + getBoundedIntegral (unsafeGetSigned @Int64 fromIntegral 5) +#endif {-# INLINE getWord #-} + +-------------------------------------------------------------------------------- + +-- | SLEB128-encodes @a@ and writes it into 'Ptr'. Returns one past the last +-- written address. None of this is not checked. +{-# INLINE unsafePoke #-} +unsafePoke + :: forall a. (Bits a, Integral a) => a -> Ptr Word8 -> IO (Ptr Word8) +unsafePoke = \a p -> + -- We split neg and pos so that their internal 'if' checks for less things. + if a < 0 then neg a p else pos a p + where + {-# INLINE neg #-} + neg :: a -> Ptr Word8 -> IO (Ptr Word8) + neg = \ !a !p -> do + let b = unsafeShiftR a 7 :: a + c = fromIntegral (a .&. 0x7f) :: Word8 + d = c .&. 0x40 :: Word8 + if d == 0 || b /= -1 then do + poke p $! c .|. 0x80 + neg b $! plusPtr p 1 + else do + poke p $! c .|. 0x40 + pure $! plusPtr p 1 + {-# INLINE pos #-} + pos :: a -> Ptr Word8 -> IO (Ptr Word8) + pos = \ !a !p -> do + let b = unsafeShiftR a 7 :: a + c = fromIntegral a :: Word8 + d = c .&. 0x40 :: Word8 + if d /= 0 || b /= 0 then do + poke p $! c .|. 0x80 + pos b $! plusPtr p 1 + else do + poke p $! c + pure $! plusPtr p 1 + +{-# INLINE naturalFromInteger #-} +naturalFromInteger :: MonadFail m => Integer -> m Natural +naturalFromInteger = \case + IS x | isTrue# (0# <=# x) -> pure $ naturalFromWord# (int2Word# x) + IP x -> pure $ naturalFromBigNat# x + _ -> fail "underflow" + 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 @@ -1,177 +1,297 @@ -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE UndecidableInstances #-} --- | Unsigned LEB128 codec. +#include + +-- | __Unsigned LEB128 codec__. This codec encodes an unsigned number +-- [as described here](https://en.wikipedia.org/wiki/LEB128#Unsigned_LEB128). -- --- Any /getXXX/ decoder can decode bytes generated using any of the /putXXX/ +-- Any /getXXX/ decoder can decode bytes generated using any of the /putXXX/ -- encoders, provided the encoded number fits in the target type. -module Data.Binary.ULEB128 - ( -- * Put - putNatural - , putWord64 - , putWord32 - , putWord16 - , putWord8 - , putWord +-- +-- __WARNING__: This is not compatible with the /Signed LEB128/ codec at +-- "Data.Binary.SLEB128" nor with the /ZigZag LEB128/ codec at +-- "Data.Binary.ZLEB128". +module Data.Binary.ULEB128 {--} + ( ULEB128 (..) - -- * Get - , getNatural - , getWord64 - , getWord32 - , getWord16 - , getWord8 - , getWord - , getInteger - , getInt64 - , getInt32 - , getInt16 - , getInt8 - , getInt - - -- * ByteString - , putByteString - , getByteString - -- ** Lazy - , putLazyByteString - , getLazyByteString - -- ** Short - , putShortByteString - , getShortByteString - ) where + -- * Put + , putNatural + , putWord64 + , putWord32 + , putWord16 + , putWord8 + , putWord -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 + -- * Get + , getNatural + , getWord64 + , getWord32 + , getWord16 + , getWord8 + , getWord + , getInteger + , getInt64 + , getInt32 + , getInt16 + , getInt8 + , getInt + + -- * ByteString + , putByteString + , getByteString + + -- ** Lazy + , putLazyByteString + , getLazyByteString + + -- ** Short + , putShortByteString + , getShortByteString + ) -- } +where + +import Data.Binary qualified as Bin +import Data.Binary.Get qualified as Bin +import Data.Binary.Put qualified as Bin import Data.Bits +import Data.ByteString qualified as B +import Data.ByteString.Builder.Prim qualified as BB +import Data.ByteString.Builder.Prim.Internal qualified as BB +import Data.ByteString.Lazy qualified as BL +import Data.ByteString.Short qualified as BS import Data.Int -import Data.Word -import Numeric.Natural +import Foreign.Ptr +import Foreign.Storable +import GHC.Exts +import GHC.TypeLits qualified as GHC +import GHC.Num.Natural +import GHC.Word -------------------------------------------------------------------------------- -putNatural :: Natural -> Bin.Put -putNatural = \a -> - let w8 = fromIntegral a - in case unsafeShiftR a 7 of - 0 -> Bin.putWord8 (w8 .&. 0x7f) - b -> Bin.putWord8 (w8 .|. 0x80) >> putNatural b +-- | Newtype wrapper for 'Bin.Binary' encoding and decoding @x@ using the +-- /Unsigned LEB128/ codec. Useful in conjunction with @DerivingVia@. +newtype ULEB128 x = ULEB128 x --- TODO: The following dispatch to 'putNatural'. Make faster. +-- | Note: Maximum allowed number of input bytes is restricted to 1024. +-- Use 'putNatural' if you want a greater limit. +instance Bin.Binary (ULEB128 Natural) where + put = coerce putNatural + {-# INLINE put #-} + get = coerce (getNatural 1024) + {-# INLINE get #-} +instance Bin.Binary (ULEB128 Word) where + put = coerce putWord + {-# INLINE put #-} + get = coerce getWord + {-# INLINE get #-} + +instance Bin.Binary (ULEB128 Word8) where + put = coerce putWord8 + {-# INLINE put #-} + get = coerce getWord8 + {-# INLINE get #-} + +instance Bin.Binary (ULEB128 Word16) where + put = coerce putWord16 + {-# INLINE put #-} + get = coerce getWord16 + {-# INLINE get #-} + +instance Bin.Binary (ULEB128 Word32) where + put = coerce putWord32 + {-# INLINE put #-} + get = coerce getWord32 + {-# INLINE get #-} + +instance Bin.Binary (ULEB128 Word64) where + put = coerce putWord64 + {-# INLINE put #-} + get = coerce getWord64 + {-# INLINE get #-} + +instance DecodeOnly "getInt8" => Bin.Binary (ULEB128 Int8) where + put = undefined + get = undefined + +instance DecodeOnly "getInt16" => Bin.Binary (ULEB128 Int16) where + put = undefined + get = undefined + +instance DecodeOnly "getInt32" => Bin.Binary (ULEB128 Int32) where + put = undefined + get = undefined + +instance DecodeOnly "getInt64" => Bin.Binary (ULEB128 Int64) where + put = undefined + get = undefined + +instance DecodeOnly "getInt" => Bin.Binary (ULEB128 Int) where + put = undefined + get = undefined + +instance DecodeOnly "getInteger" => Bin.Binary (ULEB128 Integer) where + put = undefined + get = undefined + +type family DecodeOnly s where + DecodeOnly s = GHC.TypeError ( + 'GHC.Text "ULEB128 can't encode signed numbers, " 'GHC.:<>: + 'GHC.Text "use SLEB128 or ZLEB128 instead." 'GHC.:$$: + 'GHC.Text "To decode, use “ULEB128." 'GHC.:<>: 'GHC.Text s 'GHC.:<>: + 'GHC.Text "”.") + +-------------------------------------------------------------------------------- + +putNatural :: Natural -> Bin.Put +putNatural (NS w#) = putWord (W# w#) +putNatural a = + let b = fromIntegral a :: Word8 + in case unsafeShiftR a 7 of + c | c /= 0 -> Bin.putWord8 (b .|. 0x80) >> putNatural c + | otherwise -> Bin.putWord8 b +{-# INLINE putNatural #-} + putWord8 :: Word8 -> Bin.Put -putWord8 = putNatural . fromIntegral +putWord8 = Bin.putBuilder + . BB.primBounded (BB.boundedPrim 2 unsafePokeUnsigned) {-# INLINE putWord8 #-} putWord16 :: Word16 -> Bin.Put -putWord16 = putNatural . fromIntegral +putWord16 = Bin.putBuilder + . BB.primBounded (BB.boundedPrim 3 unsafePokeUnsigned) {-# INLINE putWord16 #-} putWord32 :: Word32 -> Bin.Put -putWord32 = putNatural . fromIntegral +putWord32 = Bin.putBuilder + . BB.primBounded (BB.boundedPrim 5 unsafePokeUnsigned) {-# INLINE putWord32 #-} putWord64 :: Word64 -> Bin.Put -putWord64 = putNatural . fromIntegral +putWord64 = Bin.putBuilder + . BB.primBounded (BB.boundedPrim 10 unsafePokeUnsigned) {-# INLINE putWord64 #-} putWord :: Word -> Bin.Put -putWord = putNatural . fromIntegral +putWord = +#if WORD_SIZE_IN_BITS == 64 + Bin.putBuilder . BB.primBounded (BB.boundedPrim 10 unsafePokeUnsigned) +#elif WORD_SIZE_IN_BITS == 32 + Bin.putBuilder . BB.primBounded (BB.boundedPrim 5 unsafePokeUnsigned) +#endif {-# INLINE putWord #-} -------------------------------------------------------------------------------- -getNatural - :: Word +getNatural + :: Int -- ^ /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. + -- 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, + -- 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) +getNatural = unsafeGetUnsigned word8ToNatural +{-# INLINE getNatural #-} -getInteger - :: Word +-- | Like 'getNatural', except it's offered here so that other parsers can use +-- this specilized to types other than 'Natural'. This is unsafe because it +-- only works for unsigned numbers whose ULEB128 representation is at most as +-- long as the specified 'Int', but none of that is checked by this parser. +{-# INLINE unsafeGetUnsigned #-} +unsafeGetUnsigned + :: forall a. (Bits a, Num a) => (Word8 -> a) -> Int -> Bin.Get a +unsafeGetUnsigned fromWord8 = \m -> Bin.label "ULEB128" (go m 0 0) + where + {-# INLINE go #-} + go :: Int -> Int -> a -> Bin.Get a + go m i o | i < m = do + w <- Bin.getWord8 + if w >= 0x80 + then go m (i + 1) $! o .|. unsafeShiftL (fromWord8 (w .&. 0x7f)) (7 * i) + else pure $! o .|. unsafeShiftL (fromWord8 w) (7 * i) + go _ _ _ = fail "input exceeds maximum allowed bytes" + +getInteger + :: Int -- ^ /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. + -- 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, + -- 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 +getInteger = fmap toInteger . getNatural {-# INLINE getInteger #-} --- TODO: The following dispatch to 'getNatural'. Make faster. - -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) +getBoundedIntegral + :: forall s u + . (Bits s, Integral s, Bits u, Integral u) + => Bin.Get s + -> Bin.Get u +getBoundedIntegral = \gs -> do + s <- gs + Bin.label "ULEB128" $ case toIntegralSized s of + Just u -> pure u + Nothing -> fail "underflow or overflow" {-# INLINE getBoundedIntegral #-} getWord8 :: Bin.Get Word8 -getWord8 = getBoundedIntegral +getWord8 = unsafeGetUnsigned id 2 {-# INLINE getWord8 #-} getWord16 :: Bin.Get Word16 -getWord16 = getBoundedIntegral +getWord16 = unsafeGetUnsigned fromIntegral 3 {-# INLINE getWord16 #-} getWord32 :: Bin.Get Word32 -getWord32 = getBoundedIntegral +getWord32 = unsafeGetUnsigned fromIntegral 5 {-# INLINE getWord32 #-} getWord64 :: Bin.Get Word64 -getWord64 = getBoundedIntegral +getWord64 = unsafeGetUnsigned fromIntegral 10 {-# INLINE getWord64 #-} getWord :: Bin.Get Word -getWord = getBoundedIntegral +getWord = +#if WORD_SIZE_IN_BITS == 64 + unsafeGetUnsigned fromIntegral 10 +#elif WORD_SIZE_IN_BITS == 32 + unsafeGetUnsigned fromIntegral 5 +#endif {-# INLINE getWord #-} getInt8 :: Bin.Get Int8 -getInt8 = getBoundedIntegral +getInt8 = getBoundedIntegral (unsafeGetUnsigned @Word8 fromIntegral 1) {-# INLINE getInt8 #-} getInt16 :: Bin.Get Int16 -getInt16 = getBoundedIntegral +getInt16 = getBoundedIntegral getWord16 {-# INLINE getInt16 #-} getInt32 :: Bin.Get Int32 -getInt32 = getBoundedIntegral +getInt32 = getBoundedIntegral getWord32 {-# INLINE getInt32 #-} getInt64 :: Bin.Get Int64 -getInt64 = getBoundedIntegral +getInt64 = getBoundedIntegral getWord64 {-# INLINE getInt64 #-} getInt :: Bin.Get Int -getInt = getBoundedIntegral +getInt = getBoundedIntegral getWord {-# 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)) + putWord (fromIntegral (B.length a :: Int)) Bin.putByteString a {-# INLINE putByteString #-} @@ -187,7 +307,7 @@ -- See 'getLazyByteString'. putLazyByteString :: BL.ByteString -> Bin.Put putLazyByteString = \a -> do - putNatural (fromIntegral (BL.length a :: Int64)) + putWord64 (fromIntegral (BL.length a :: Int64)) Bin.putLazyByteString a {-# INLINE putLazyByteString #-} @@ -203,7 +323,7 @@ -- See 'getShortByteString'. putShortByteString :: BS.ShortByteString -> Bin.Put putShortByteString = \a -> do - putNatural (fromIntegral (BS.length a :: Int)) + putWord (fromIntegral (BS.length a :: Int)) Bin.putShortByteString a {-# INLINE putShortByteString #-} @@ -213,4 +333,25 @@ getShortByteString :: Bin.Get BS.ShortByteString getShortByteString = fmap BS.toShort (Bin.getByteString =<< getInt) {-# INLINE getShortByteString #-} + +-------------------------------------------------------------------------------- + +-- | ULEB128-encodes @a@ and writes it into 'Ptr'. Returns one past the last +-- written address. Only works with unsigned types. None of this is not checked. +unsafePokeUnsigned :: (Bits a, Integral a) => a -> Ptr Word8 -> IO (Ptr Word8) +unsafePokeUnsigned = \ !a !p -> + case unsafeShiftR a 7 of + b | b /= 0 -> do + poke p $! 0x80 .|. fromIntegral a + unsafePokeUnsigned b $! plusPtr p 1 + | otherwise -> do + poke p $! fromIntegral a + pure $! plusPtr p 1 +{-# INLINE unsafePokeUnsigned #-} + + +-- | This is faster than 'fromIntegral', which goes through 'Integer'. +word8ToNatural :: Word8 -> Natural +word8ToNatural (W8# a) = NS (word8ToWord# a) +{-# INLINE word8ToNatural #-} diff --git a/lib/Data/Binary/ZLEB128.hs b/lib/Data/Binary/ZLEB128.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Binary/ZLEB128.hs @@ -0,0 +1,355 @@ +{-# LANGUAGE CPP #-} + +#include + +-- | __ZigZag LEB128 codec__. This codec encodes the [ZigZag] +-- (https://en.wikipedia.org/wiki/Variable-length_quantity#Zigzag_encoding) +-- representation of a signed number through +-- [ULEB128](https://en.wikipedia.org/wiki/LEB128#Unsigned_LEB128). +-- +-- Any /getXXX/ decoder can decode bytes generated using any of the /putXXX/ +-- encoders, provided the encoded number fits in the target type. +-- +-- __WARNING__: This is not compatible with the /Unsigned LEB128/ codec at +-- "Data.Binary.ULEB128" nor with the /Signed LEB128/ codec at +-- "Data.Binary.SLEB128". +module Data.Binary.ZLEB128 {--} + ( ZLEB128(..) + -- * Put + , putInteger + , putInt64 + , putInt32 + , putInt16 + , putInt8 + , putInt + , putNatural + , putWord64 + , putWord32 + , putWord16 + , putWord8 + , putWord + -- * Get + , getInteger + , getInt64 + , getInt32 + , getInt16 + , getInt8 + , getInt + , getNatural + , getWord64 + , getWord32 + , getWord16 + , getWord8 + , getWord + ) --} + where + +import Data.Binary qualified as Bin +import Data.Binary.Get qualified as Bin +import Data.Bits +import GHC.Num.BigNat +import GHC.Num.Integer +import GHC.Num.Natural +import GHC.Int +import GHC.Word +import GHC.Exts + +import Data.Binary.ULEB128 qualified as U + +-------------------------------------------------------------------------------- + +-- | Newtype wrapper for 'Bin.Binary' encoding and decoding @x@ using the +-- /ZigZag LEB128/ codec. Useful in conjunction with @DerivingVia@. +newtype ZLEB128 x = ZLEB128 x + +-- | Note: Maximum allowed number of input bytes is restricted to 1024. +-- Use 'putNatural' if you want a greater limit. +instance Bin.Binary (ZLEB128 Integer) where + put = coerce putInteger + {-# INLINE put #-} + get = coerce (getInteger 1024) + {-# INLINE get #-} + +-- | Note: Maximum allowed number of input bytes is restricted to 1024. +-- Use 'putNatural' if you want a greater limit. +instance Bin.Binary (ZLEB128 Natural) where + put = coerce putNatural + {-# INLINE put #-} + get = coerce (getNatural 1024) + {-# INLINE get #-} + +instance Bin.Binary (ZLEB128 Int) where + put = coerce putInt + {-# INLINE put #-} + get = coerce getInt + {-# INLINE get #-} + +instance Bin.Binary (ZLEB128 Word) where + put = coerce putWord + {-# INLINE put #-} + get = coerce getWord + {-# INLINE get #-} + +instance Bin.Binary (ZLEB128 Int8) where + put = coerce putInt8 + {-# INLINE put #-} + get = coerce getInt8 + {-# INLINE get #-} + +instance Bin.Binary (ZLEB128 Word8) where + put = coerce putWord8 + {-# INLINE put #-} + get = coerce getWord8 + {-# INLINE get #-} + +instance Bin.Binary (ZLEB128 Int16) where + put = coerce putInt16 + {-# INLINE put #-} + get = coerce getInt16 + {-# INLINE get #-} + +instance Bin.Binary (ZLEB128 Word16) where + put = coerce putWord16 + {-# INLINE put #-} + get = coerce getWord16 + {-# INLINE get #-} + +instance Bin.Binary (ZLEB128 Int32) where + put = coerce putInt32 + {-# INLINE put #-} + get = coerce getInt32 + {-# INLINE get #-} + +instance Bin.Binary (ZLEB128 Word32) where + put = coerce putWord32 + {-# INLINE put #-} + get = coerce getWord32 + {-# INLINE get #-} + +instance Bin.Binary (ZLEB128 Int64) where + put = coerce putInt64 + {-# INLINE put #-} + get = coerce getInt64 + {-# INLINE get #-} + +instance Bin.Binary (ZLEB128 Word64) where + put = coerce putWord64 + {-# INLINE put #-} + get = coerce getWord64 + {-# INLINE get #-} + +-------------------------------------------------------------------------------- + +putInteger :: Integer -> Bin.Put +-- putInteger = U.putNatural . _zigZagInteger +putInteger = \case + IS x | y <- zigZagInt (I# x) -> U.putWord y + IP x -> U.putNatural (NB (bigNatShiftL# x 1##)) + IN x -> U.putNatural (NB (bigNatShiftL# x 1## `bigNatSubWordUnsafe#` 1##)) +{-# INLINE putInteger #-} + +putNatural :: Natural -> Bin.Put +putNatural = \n -> U.putNatural (unsafeShiftL n 1) +{-# INLINE putNatural #-} + +putWord8 :: Word8 -> Bin.Put +putWord8 = putInt16 . fromIntegral +{-# INLINE putWord8 #-} + +putWord16 :: Word16 -> Bin.Put +putWord16 = putInt32 . fromIntegral +{-# INLINE putWord16 #-} + +putWord32 :: Word32 -> Bin.Put +putWord32 = putInt64 . fromIntegral +{-# INLINE putWord32 #-} + +putWord64 :: Word64 -> Bin.Put +putWord64 = putInteger . fromIntegral +{-# INLINE putWord64 #-} + +putWord :: Word -> Bin.Put +putWord = putInteger . fromIntegral +{-# INLINE putWord #-} + +putInt8 :: Int8 -> Bin.Put +putInt8 = U.putWord8 . zigZagInt8 +{-# INLINE putInt8 #-} + +putInt16 :: Int16 -> Bin.Put +putInt16 = U.putWord16 . zigZagInt16 +{-# INLINE putInt16 #-} + +putInt32 :: Int32 -> Bin.Put +putInt32 = U.putWord32 . zigZagInt32 +{-# INLINE putInt32 #-} + +putInt64 :: Int64 -> Bin.Put +putInt64 = U.putWord64 . zigZagInt64 +{-# INLINE putInt64 #-} + +putInt :: Int -> Bin.Put +putInt = U.putWord . zigZagInt +{-# INLINE putInt #-} + +-------------------------------------------------------------------------------- + +getInteger + :: Int + -- ^ /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 zagZigInteger . U.getNatural +{-# INLINE getInteger #-} + +getNatural + :: Int + -- ^ /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 = \m -> do + i <- getInteger m + Bin.label "ZLEB128" $ naturalFromInteger i +{-# INLINE getNatural #-} + +getBoundedIntegral + :: forall s u + . (Bits s, Integral s, Bits u, Integral u) + => Bin.Get s + -> Bin.Get u +getBoundedIntegral = \gs -> do + s <- gs + Bin.label "ZLEB128" $ case toIntegralSized s of + Just u -> pure u + Nothing -> fail "underflow or overflow" +{-# INLINE getBoundedIntegral #-} + +getInt8 :: Bin.Get Int8 +getInt8 = zagZigInt8 <$> U.getWord8 +{-# INLINE getInt8 #-} + +getInt16 :: Bin.Get Int16 +getInt16 = zagZigInt16 <$> U.getWord16 +{-# INLINE getInt16 #-} + +getInt32 :: Bin.Get Int32 +getInt32 = zagZigInt32 <$> U.getWord32 +{-# INLINE getInt32 #-} + +getInt64 :: Bin.Get Int64 +getInt64 = zagZigInt64 <$> U.getWord64 +{-# INLINE getInt64 #-} + +getInt :: Bin.Get Int +getInt = zagZigInt <$> U.getWord +{-# INLINE getInt #-} + +getWord8 :: Bin.Get Word8 +getWord8 = getBoundedIntegral getInt16 +{-# INLINE getWord8 #-} + +getWord16 :: Bin.Get Word16 +getWord16 = getBoundedIntegral getInt32 +{-# INLINE getWord16 #-} + +getWord32 :: Bin.Get Word32 +getWord32 = getBoundedIntegral getInt64 +{-# INLINE getWord32 #-} + +getWord64 :: Bin.Get Word64 +getWord64 = getBoundedIntegral (getInteger 10) +{-# INLINE getWord64 #-} + +getWord :: Bin.Get Word +getWord = getBoundedIntegral (getInteger 10) +{-# INLINE getWord #-} + +-------------------------------------------------------------------------------- + +-- | OK, but not used. See putInteger. +{-# INLINE _zigZagInteger #-} +_zigZagInteger :: Integer -> Natural +_zigZagInteger = \case + IS x | W# y <- zigZagInt (I# x) -> NS y + IP x -> NB (bigNatShiftL# x 1##) + IN x -> NB (bigNatShiftL# x 1## `bigNatSubWordUnsafe#` 1##) + +{-# INLINE zagZigInteger #-} +zagZigInteger :: Natural -> Integer +zagZigInteger = \case + NS x | I# y <- zagZigInt (W# x) -> IS y + NB x -- Unnecessary check because of Natural invariant: + -- | bigNatIsZero x -> IS 0# + | 0## <- and# 1## (indexWordArray# x 0#) -> IP (bigNatShiftR# x 1##) + | otherwise -> IN (bigNatShiftR# (bigNatAddWord# x 1##) 1##) + +-- | @s@ is expected to be the signed version of @u@. This is not checked. +{-# INLINE unsafeZigZagFixed #-} +unsafeZigZagFixed + :: forall s u. (FiniteBits s, FiniteBits u, Integral s, Integral u) => s -> u +unsafeZigZagFixed = + let !n = finiteBitSize (undefined :: s) - 1 + in \s -> fromIntegral $! xor (unsafeShiftL s 1) (unsafeShiftR s n) + +-- | @u@ is expected to be the unsigned version of @s@. This is not checked. +{-# INLINE unsafeZagZigFixed #-} +unsafeZagZigFixed + :: forall u s. (FiniteBits u, FiniteBits s, Integral u, Integral s) => u -> s +unsafeZagZigFixed = \u -> + fromIntegral $! xor (unsafeShiftR u 1) (negate (u .&. 1)) + +{-# INLINE zigZagInt8 #-} +zigZagInt8 :: Int8 -> Word8 +zigZagInt8 = unsafeZigZagFixed + +{-# INLINE zagZigInt8 #-} +zagZigInt8 :: Word8 -> Int8 +zagZigInt8 = unsafeZagZigFixed + +{-# INLINE zigZagInt16 #-} +zigZagInt16 :: Int16 -> Word16 +zigZagInt16 = unsafeZigZagFixed + +{-# INLINE zagZigInt16 #-} +zagZigInt16 :: Word16 -> Int16 +zagZigInt16 = unsafeZagZigFixed + +{-# INLINE zigZagInt32 #-} +zigZagInt32 :: Int32 -> Word32 +zigZagInt32 = unsafeZigZagFixed + +{-# INLINE zagZigInt32 #-} +zagZigInt32 :: Word32 -> Int32 +zagZigInt32 = unsafeZagZigFixed + +{-# INLINE zigZagInt64 #-} +zigZagInt64 :: Int64 -> Word64 +zigZagInt64 = unsafeZigZagFixed + +{-# INLINE zagZigInt64 #-} +zagZigInt64 :: Word64 -> Int64 +zagZigInt64 = unsafeZagZigFixed + +{-# INLINE zigZagInt #-} +zigZagInt :: Int -> Word +zigZagInt = unsafeZigZagFixed + +{-# INLINE zagZigInt #-} +zagZigInt :: Word -> Int +zagZigInt = unsafeZagZigFixed + +{-# INLINE naturalFromInteger #-} +naturalFromInteger :: MonadFail m => Integer -> m Natural +naturalFromInteger = \case + IS x | isTrue# (0# <=# x) -> pure $ naturalFromWord# (int2Word# x) + IP x -> pure $ naturalFromBigNat# x + _ -> fail "underflow" + diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -18,12 +18,13 @@ import Test.Tasty.HUnit (testCase, (@?=), Assertion) import Test.Tasty.Hedgehog (HedgehogTestLimit (..), testProperty) import qualified Test.Tasty.Runners as Tasty -import Hedgehog (MonadTest, forAll, property, (===)) +import Hedgehog (MonadTest, forAll, property, (===), (/==)) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import qualified Data.Binary.ULEB128 as U import qualified Data.Binary.SLEB128 as S +import qualified Data.Binary.ZLEB128 as Z -------------------------------------------------------------------------------- @@ -31,26 +32,218 @@ main = Tasty.defaultMainWithIngredients [Tasty.consoleTestReporter, Tasty.listingTests] - $ Tasty.localOption (HedgehogTestLimit (Just 1000)) tt + $ Tasty.localOption (HedgehogTestLimit (Just 10000)) tt tt :: TestTree -tt = testGroup "leb128-binary" - [ tt_ULEB128 - , tt_SLEB128 +tt = testGroup "leb128-binary" + [ tt_ZigZag + , tt_ULEB128 + , tt_ZLEB128 + , tt_SLEB128 ] +tt_ZigZag :: TestTree +tt_ZigZag = testGroup "ZigZag" + [ testGroup "Round trip" + [ testProperty "ZigZag(ZagZig(x))" $ property $ do + n <- forAll $ Gen.integral rangeNatural512 + n === zigZag (zagZig n) + , testProperty "ZagZig(ZigZag(x))" $ property $ do + i <- forAll $ Gen.integral rangeInteger512 + i === zagZig (zigZag i) + ] + , testGroup "Not identity" + [ testProperty "ZagZig" $ property $ do + n <- forAll $ Gen.integral rangeNatural512 + toInteger n /== zagZig n + , testProperty "ZagZig" $ property $ do + i <- forAll $ Gen.integral rangeInteger512 + i /== toInteger (zigZag i) + ] + , testGroup "Known" + [ testCase "0" $ zigZag 0 @?= 0 + , testCase "1" $ zigZag 1 @?= 2 + , testCase "2" $ zigZag 2 @?= 4 + , testCase "127" $ zigZag 127 @?= 254 + , testCase "32767" $ zigZag 32767 @?= 65534 + , testCase "2147483647" $ zigZag 2147483647 @?= 4294967294 + , testCase "9223372036854775807" $ + zigZag 9223372036854775807 @?= 18446744073709551614 + , testCase "170141183460469231731687303715884105727" $ + zigZag 170141183460469231731687303715884105727 + @?= 340282366920938463463374607431768211454 + , testCase "111111111111111111111111111111111111111111" $ + zigZag 111111111111111111111111111111111111111111 + @?= 222222222222222222222222222222222222222222 + , testCase "-1" $ zigZag (-1) @?= 1 + , testCase "-2" $ zigZag (-2) @?= 3 + , testCase "-127" $ zigZag (-127) @?= 253 + , testCase "-128" $ zigZag (-128) @?= 255 + , testCase "-32767" $ zigZag (-32767) @?= 65533 + , testCase "-32768" $ zigZag (-32768) @?= 65535 + , testCase "-2147483647" $ zigZag (-2147483647) @?= 4294967293 + , testCase "-2147483648" $ zigZag (-2147483648) @?= 4294967295 + , testCase "-9223372036854775808" $ + zigZag (-9223372036854775808) @?= 18446744073709551615 + , testCase "-9223372036854775807" $ + zigZag (-9223372036854775807) @?= 18446744073709551613 + , testCase "-170141183460469231731687303715884105728" $ + zigZag (-170141183460469231731687303715884105728) + @?= 340282366920938463463374607431768211455 + , testCase "-170141183460469231731687303715884105727" $ + zigZag (-170141183460469231731687303715884105727) + @?= 340282366920938463463374607431768211453 + , testCase "-111111111111111111111111111111111111111111" $ + zigZag (-111111111111111111111111111111111111111111) + @?= 222222222222222222222222222222222222222221 + , testCase "-111111111111111111111111111111111111111112" $ + zigZag (-111111111111111111111111111111111111111112) + @?= 222222222222222222222222222222222222222223 + ] + ] + +tt_ZLEB128 :: TestTree +tt_ZLEB128 = testGroup "ZLEB128" + [ testGroup "Round trip" + [ testProperty "putInt" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + Right n === dec Z.getInt (enc (Z.putInt n)) + , testProperty "putInt8" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + Right n === dec Z.getInt8 (enc (Z.putInt8 n)) + , testProperty "putInt16" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + Right n === dec Z.getInt16 (enc (Z.putInt16 n)) + , testProperty "putInt32" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + Right n === dec Z.getInt32 (enc (Z.putInt32 n)) + , testProperty "putInt64" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + Right n === dec Z.getInt64 (enc (Z.putInt64 n)) + , testProperty "putWord" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + Right n === dec Z.getWord (enc (Z.putWord n)) + , testProperty "putWord8" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + Right n === dec Z.getWord8 (enc (Z.putWord8 n)) + , testProperty "putWord16" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + Right n === dec Z.getWord16 (enc (Z.putWord16 n)) + , testProperty "putWord32" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + Right n === dec Z.getWord32 (enc (Z.putWord32 n)) + , testProperty "putWord64" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + Right n === dec Z.getWord64 (enc (Z.putWord64 n)) + , testProperty "putNatural" $ property $ do + n <- forAll $ Gen.integral rangeNatural512 + Right n === dec (Z.getNatural 74) (enc (Z.putNatural n)) + , testProperty "putInteger" $ property $ do + n <- forAll $ Gen.integral rangeInteger512 + Right n === dec (Z.getInteger 74) (enc (Z.putInteger n)) + ] + , testGroup "unZLEB128(ULEB128(ZigZag(x))))" + [ testProperty "putInt" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + Right n === dec Z.getInt (enc (U.putNatural (zigZag (toInteger n)))) + , testProperty "putInt8" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + Right n === dec Z.getInt8 (enc (U.putNatural (zigZag (toInteger n)))) + , testProperty "putInt16" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + Right n === dec Z.getInt16 (enc (U.putNatural (zigZag (toInteger n)))) + , testProperty "putInt32" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + Right n === dec Z.getInt32 (enc (U.putNatural (zigZag (toInteger n)))) + , testProperty "putInt64" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + Right n === dec Z.getInt64 (enc (U.putNatural (zigZag (toInteger n)))) + , testProperty "putWord" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + Right n === dec Z.getWord (enc (U.putNatural (zigZag (toInteger n)))) + , testProperty "putWord8" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + Right n === dec Z.getWord8 (enc (U.putNatural (zigZag (toInteger n)))) + , testProperty "putWord16" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + Right n === dec Z.getWord16 (enc (U.putNatural (zigZag (toInteger n)))) + , testProperty "putWord32" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + Right n === dec Z.getWord32 (enc (U.putNatural (zigZag (toInteger n)))) + , testProperty "putWord64" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + Right n === dec Z.getWord64 (enc (U.putNatural (zigZag (toInteger n)))) + , testProperty "putNatural" $ property $ do + n <- forAll $ Gen.integral rangeNatural512 + Right n === dec (Z.getNatural 74) (enc (U.putNatural (zigZag (toInteger n)))) + , testProperty "putInteger" $ property $ do + n <- forAll $ Gen.integral rangeInteger512 + Right n === dec (Z.getInteger 74) (enc (U.putNatural (zigZag n))) + ] + , testGroup "ZigZag(unULEB128(ZLEB128(x)))" + [ testProperty "putInt" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + Right (Just n) === dec (fmap (toIntegralSized . zagZig) (U.getNatural 10)) + (enc (Z.putInt n)) + , testProperty "putInt8" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + Right (Just n) === dec (fmap (toIntegralSized . zagZig) (U.getNatural 2)) + (enc (Z.putInt8 n)) + , testProperty "putInt16" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + Right (Just n) === dec (fmap (toIntegralSized . zagZig) (U.getNatural 3)) + (enc (Z.putInt16 n)) + , testProperty "putInt32" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + Right (Just n) === dec (fmap (toIntegralSized . zagZig) (U.getNatural 5)) + (enc (Z.putInt32 n)) + , testProperty "putInt64" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + Right (Just n) === dec (fmap (toIntegralSized . zagZig) (U.getNatural 10)) + (enc (Z.putInt64 n)) + , testProperty "putWord" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + Right (Just n) === dec (fmap (toIntegralSized . zagZig) (U.getNatural 10)) + (enc (Z.putWord n)) + , testProperty "putWord8" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + Right (Just n) === dec (fmap (toIntegralSized . zagZig) (U.getNatural 2)) + (enc (Z.putWord8 n)) + , testProperty "putWord16" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + Right (Just n) === dec (fmap (toIntegralSized . zagZig) (U.getNatural 3)) + (enc (Z.putWord16 n)) + , testProperty "putWord32" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + Right (Just n) === dec (fmap (toIntegralSized . zagZig) (U.getNatural 5)) + (enc (Z.putWord32 n)) + , testProperty "putWord64" $ property $ do + n <- forAll $ Gen.integral Range.constantBounded + Right (Just n) === dec (fmap (toIntegralSized . zagZig) (U.getNatural 10)) + (enc (Z.putWord64 n)) + , testProperty "putNatural" $ property $ do + n <- forAll $ Gen.integral rangeNatural512 + Right (Just n) === dec (fmap (toIntegralSized . zagZig) (U.getNatural 74)) + (enc (Z.putNatural n)) + , testProperty "putInteger" $ property $ do + n <- forAll $ Gen.integral rangeInteger512 + Right (Just n) === dec (fmap (toIntegralSized . zagZig) (U.getNatural 74)) + (enc (Z.putInteger n)) + ] + ] + tt_ULEB128 :: TestTree -tt_ULEB128 = testGroup "ULEB128" +tt_ULEB128 = testGroup "ULEB128" [ 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" + [ testCase "0, 0" $ dec (U.getNatural 0) "" @?= Left "input exceeds maximum allowed bytes\nULEB128" + , testCase "0, 1" $ dec (U.getNatural 0) "\x00" @?= Left "input exceeds maximum allowed bytes\nULEB128" + , testCase "0, 1.5" $ dec (U.getNatural 0) "\x80" @?= Left "input exceeds maximum allowed bytes\nULEB128" + , testCase "1, 1.5" $ dec (U.getNatural 1) "\x80" @?= Left "input exceeds maximum allowed bytes\nULEB128" + , testCase "1, 2" $ dec (U.getNatural 1) "\x80\x01" @?= Left "input exceeds maximum allowed bytes\nULEB128" + , testCase "1, 3" $ dec (U.getNatural 1) "\xfd\x82\x01" @?= Left "input exceeds maximum allowed bytes\nULEB128" + , testCase "2, 3" $ dec (U.getNatural 2) "\xfd\x82\x01" @?= Left "input exceeds maximum allowed bytes\nULEB128" ] - , testGroup "Known" + , testGroup "Known" [ tt_ULEB128_known 0 "\x00" , tt_ULEB128_known 1 "\x01" , tt_ULEB128_known 6 "\x06" @@ -849,7 +1042,7 @@ , 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 @@ -884,29 +1077,29 @@ 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) + 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) +tt_ULEB128_known n bl = testGroup (show n) [ testCase "put" $ enc (U.putNatural n) @?= bl , testCase "get" $ assertDecULEB128 n bl ] tt_SLEB128 :: TestTree -tt_SLEB128 = testGroup "SLEB128" - [ 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" +tt_SLEB128 = testGroup "SLEB128" + [ testGroup "Too big" + [ testCase "0, 0" $ dec (S.getInteger 0) "" @?= Left "input exceeds maximum allowed bytes\nSLEB128" + , testCase "0, 1" $ dec (S.getInteger 0) "\x00" @?= Left "input exceeds maximum allowed bytes\nSLEB128" + , testCase "0, 1.5" $ dec (S.getInteger 0) "\x80" @?= Left "input exceeds maximum allowed bytes\nSLEB128" + , testCase "1, 1.5" $ dec (S.getInteger 1) "\x80" @?= Left "input exceeds maximum allowed bytes\nSLEB128" + , testCase "1, 2" $ dec (S.getInteger 1) "\x89\x3b" @?= Left "input exceeds maximum allowed bytes\nSLEB128" + , testCase "1, 3" $ dec (S.getInteger 1) "\xc9\xc1\x00" @?= Left "input exceeds maximum allowed bytes\nSLEB128" + , testCase "2, 3" $ dec (S.getInteger 2) "\xc9\xc1\x00" @?= Left "input exceeds maximum allowed bytes\nSLEB128" ] - , testGroup "Known" + , 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" @@ -1869,31 +2062,31 @@ , 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) +tt_SLEB128_known i bl = testGroup (show i) [ testCase "put" $ enc (S.putInteger i) @?= bl , testCase "get" $ assertDecSLEB128 i bl ] -propDecULEB128 +propDecULEB128 :: (Integral a, Bits a, MonadTest m) => a -> BL.ByteString -> m () propDecULEB128 = decULEB128 (===) -assertDecULEB128 - :: (Integral a, Bits a) => a -> BL.ByteString -> Assertion +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 + :: (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 + let l = ceiling (8 * fromIntegral (BL.length bl) / 7 :: Double) :: Int 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) @@ -1907,23 +2100,23 @@ for_ (toIntegralSized a) $ \b -> eq (dec U.getInt32 bl) (Right b) for_ (toIntegralSized a) $ \b -> eq (dec U.getInt64 bl) (Right b) -propDecSLEB128 +propDecSLEB128 :: (Integral a, Bits a, MonadTest m) => a -> BL.ByteString -> m () propDecSLEB128 = decSLEB128 (===) -assertDecSLEB128 - :: (Integral a, Bits a) => a -> BL.ByteString -> Assertion +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 + :: (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 + l = fromIntegral (BL.length bl) :: Int 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) @@ -1938,12 +2131,12 @@ for_ (toIntegralSized i) $ \b -> eq (dec S.getInt64 bl) (Right b) rangeInteger512 :: Range.Range Integer -rangeInteger512 = - let x = 2 ^ (511 :: Int) :: Integer - in Range.constantFrom 0 (negate x) (x - 1) +rangeInteger512 = + let x = 2 ^ (512 :: Int) :: Integer + in Range.constant (negate x) (x - 1) rangeNatural512 :: Range.Range Natural -rangeNatural512 = Range.constantFrom 0 0 ((2 ^ (512 :: Int)) - 1) +rangeNatural512 = Range.constant 0 ((2 ^ (512 :: Int)) - 1) enc :: Bin.Put -> BL.ByteString enc = Bin.runPut @@ -1953,4 +2146,12 @@ Left (_, _, e) -> Left e Right (l, _, a) | BL.null l -> Right a | otherwise -> Left "parsed successfully, but got leftovers" + +zigZag :: Integer -> Natural +zigZag i = if i < 0 then fromInteger (i * (-2) - 1) + else fromInteger (i * 2) + +zagZig :: Natural -> Integer +zagZig n = if even n then toInteger (div n 2) + else negate (toInteger (div (n + 1) 2))