leb128-binary 0.1.1 → 0.1.2
raw patch · 7 files changed
+1453/−238 lines, 7 filesdep +deepseqdep +tasty-bench
Dependencies added: deepseq, tasty-bench
Files
- CHANGELOG.md +13/−2
- bench/Main.hs +297/−0
- leb128-binary.cabal +34/−10
- lib/Data/Binary/SLEB128.hs +263/−77
- lib/Data/Binary/ULEB128.hs +239/−98
- lib/Data/Binary/ZLEB128.hs +355/−0
- test/Main.hs +252/−51
CHANGELOG.md view
@@ -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
+ bench/Main.hs view
@@ -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+ ]+ ]+ ]
leb128-binary.cabal view
@@ -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,
lib/Data/Binary/SLEB128.hs view
@@ -1,13 +1,22 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -ddump-simpl -ddump-to-file #-} --- | Signed LEB128 codec.+#include <MachDeps.h>++-- | __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"+
lib/Data/Binary/ULEB128.hs view
@@ -1,177 +1,297 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE UndecidableInstances #-} --- | Unsigned LEB128 codec.+#include <MachDeps.h>++-- | __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 #-}
+ lib/Data/Binary/ZLEB128.hs view
@@ -0,0 +1,355 @@+{-# LANGUAGE CPP #-}++#include <MachDeps.h>++-- | __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"+
test/Main.hs view
@@ -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))