bytesmith 0.3.6.0 → 0.3.7.0
raw patch · 9 files changed
+451/−6 lines, 9 filesdep ~contiguousPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: contiguous
API changes (from Hackage documentation)
+ Data.Bytes.Parser.Ascii: charInsensitive :: e -> Char -> Parser e s ()
+ Data.Bytes.Parser.Base128: word16 :: e -> Parser e s Word16
+ Data.Bytes.Parser.Base128: word32 :: e -> Parser e s Word32
+ Data.Bytes.Parser.Base128: word64 :: e -> Parser e s Word64
+ Data.Bytes.Parser.Latin: endOfInput :: e -> Parser e s ()
+ Data.Bytes.Parser.Latin: isEndOfInput :: Parser e s Bool
+ Data.Bytes.Parser.Latin: skipWhile :: (Char -> Bool) -> Parser e s ()
+ Data.Bytes.Parser.Leb128: int16 :: e -> Parser e s Int16
+ Data.Bytes.Parser.Leb128: int32 :: e -> Parser e s Int32
+ Data.Bytes.Parser.Leb128: int64 :: e -> Parser e s Int64
+ Data.Bytes.Parser.Leb128: word16 :: e -> Parser e s Word16
+ Data.Bytes.Parser.Leb128: word32 :: e -> Parser e s Word32
+ Data.Bytes.Parser.Leb128: word64 :: e -> Parser e s Word64
+ Data.Bytes.Parser.Rebindable: instance Data.Bytes.Parser.Rebindable.Bind 'GHC.Types.IntRep ('GHC.Types.TupleRep '[ 'GHC.Types.IntRep, 'GHC.Types.IntRep, 'GHC.Types.IntRep, 'GHC.Types.IntRep, 'GHC.Types.IntRep])
+ Data.Bytes.Parser.Rebindable: instance Data.Bytes.Parser.Rebindable.Bind 'GHC.Types.LiftedRep ('GHC.Types.TupleRep '[ 'GHC.Types.IntRep, 'GHC.Types.IntRep, 'GHC.Types.IntRep, 'GHC.Types.IntRep, 'GHC.Types.IntRep])
+ Data.Bytes.Parser.Rebindable: instance Data.Bytes.Parser.Rebindable.Bind ('GHC.Types.TupleRep '[ 'GHC.Types.IntRep, 'GHC.Types.IntRep, 'GHC.Types.IntRep, 'GHC.Types.IntRep, 'GHC.Types.IntRep]) 'GHC.Types.LiftedRep
+ Data.Bytes.Parser.Rebindable: instance Data.Bytes.Parser.Rebindable.Bind ('GHC.Types.TupleRep '[ 'GHC.Types.IntRep, 'GHC.Types.IntRep]) ('GHC.Types.TupleRep '[ 'GHC.Types.IntRep, 'GHC.Types.IntRep, 'GHC.Types.IntRep, 'GHC.Types.IntRep, 'GHC.Types.IntRep])
+ Data.Bytes.Parser.Rebindable: instance Data.Bytes.Parser.Rebindable.Pure ('GHC.Types.TupleRep '[ 'GHC.Types.IntRep, 'GHC.Types.IntRep, 'GHC.Types.IntRep, 'GHC.Types.IntRep, 'GHC.Types.IntRep])
Files
- CHANGELOG.md +10/−0
- bytesmith.cabal +3/−1
- src/Data/Bytes/Parser.hs +2/−2
- src/Data/Bytes/Parser/Ascii.hs +19/−0
- src/Data/Bytes/Parser/Base128.hs +35/−0
- src/Data/Bytes/Parser/Latin.hs +31/−2
- src/Data/Bytes/Parser/Leb128.hs +103/−0
- src/Data/Bytes/Parser/Rebindable.hs +155/−0
- test/Main.hs +93/−1
CHANGELOG.md view
@@ -1,5 +1,15 @@ # Revision history for bytesmith +## 0.3.7.0 -- 2020-07-27++* Add `Data.Bytes.Parser.Base128` module for Base-128 encoding.+* Add `Data.Bytes.Parser.Leb128` module for LEB-128 encoding.+ Supports signed integers with zig-zag encoding.+* Add `skipWhile` to `Data.Bytes.Parser.Latin`.+* Reexport `endOfInput` and `isEndOfInput` from `Latin`.+* Add `charInsensitive` to ASCII module.+* Correct implementation of `peek` and `peek'`.+ ## 0.3.6.0 -- 2020-03-04 * Add `char12`
bytesmith.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: bytesmith-version: 0.3.6.0+version: 0.3.7.0 synopsis: Nonresumable byte parser description: Parse bytes as fast as possible. This is a nonresumable parser@@ -22,7 +22,9 @@ Data.Bytes.Parser.BigEndian Data.Bytes.Parser.LittleEndian Data.Bytes.Parser.Ascii+ Data.Bytes.Parser.Base128 Data.Bytes.Parser.Latin+ Data.Bytes.Parser.Leb128 Data.Bytes.Parser.Rebindable Data.Bytes.Parser.Unsafe Data.Bytes.Parser.Utf8
src/Data/Bytes/Parser.hs view
@@ -248,7 +248,7 @@ peek :: Parser e s (Maybe Word8) peek = uneffectful $ \chunk -> let v = if length chunk > 0- then Just (B.unsafeIndex chunk 1)+ then Just (B.unsafeIndex chunk 0) else Nothing in InternalSuccess v (offset chunk) (length chunk) @@ -256,7 +256,7 @@ -- input, but will fail if end of input has been reached. peek' :: e -> Parser e s Word8 peek' e = uneffectful $ \chunk -> if length chunk > 0- then InternalSuccess (B.unsafeIndex chunk 1) (offset chunk) (length chunk)+ then InternalSuccess (B.unsafeIndex chunk 0) (offset chunk) (length chunk) else InternalFailure e -- | A stateful scanner. The predicate consumes and transforms a
src/Data/Bytes/Parser/Ascii.hs view
@@ -26,6 +26,8 @@ , Latin.char2 , Latin.char3 , Latin.char4+ -- * Case-Insensitive Matching+ , charInsensitive -- * Get Character , any , any#@@ -52,9 +54,11 @@ import Prelude hiding (length,any,fail,takeWhile) +import Data.Bits (clearBit) import Data.Bytes.Types (Bytes(..)) import Data.Bytes.Parser.Internal (Parser(..),uneffectful,Result#,uneffectful#) import Data.Bytes.Parser.Internal (InternalResult(..),indexLatinCharArray,upcastUnitSuccess)+import Data.Char (ord) import Data.Word (Word8) import Data.Text.Short (ShortText) import Control.Monad.ST.Run (runByteArrayST)@@ -67,6 +71,21 @@ import qualified Data.Bytes.Parser.Latin as Latin import qualified Data.Bytes.Parser.Unsafe as Unsafe import qualified Data.Primitive as PM++-- | Consume the next character, failing if it does not match the expected+-- value or if there is no more input. This check for equality is case+-- insensitive.+--+-- Precondition: The argument must be a letter (@[a-zA-Z]@). Behavior is+-- undefined if it is not.+charInsensitive :: e -> Char -> Parser e s ()+charInsensitive e !c = uneffectful $ \chunk -> if length chunk > 0+ then if clearBit (PM.indexByteArray (array chunk) (offset chunk) :: Word8) 5 == w+ then InternalSuccess () (offset chunk + 1) (length chunk - 1)+ else InternalFailure e+ else InternalFailure e+ where+ w = clearBit (fromIntegral @Int @Word8 (ord c)) 5 -- | Consume input until the trailer is found. Then, consume -- the trailer as well. This fails if the trailer is not
+ src/Data/Bytes/Parser/Base128.hs view
@@ -0,0 +1,35 @@+{-# language BangPatterns #-}+{-# language TypeApplications #-}++module Data.Bytes.Parser.Base128+ ( -- * Unsigned+ word16+ , word32+ , word64+ ) where++import Control.Monad (when)+import Data.Bits (testBit,unsafeShiftL,(.|.),bit,clearBit)+import Data.Bytes.Parser (Parser)+import Data.Word (Word8,Word16,Word32,Word64)++import qualified Data.Bytes.Parser as P++word16 :: e -> Parser e s Word16+word16 e = fromIntegral @Word64 @Word16 <$> stepBoundedWord e 16 0++word32 :: e -> Parser e s Word32+word32 e = fromIntegral @Word64 @Word32 <$> stepBoundedWord e 32 0++word64 :: e -> Parser e s Word64+word64 e = fromIntegral @Word64 @Word64 <$> stepBoundedWord e 64 0++stepBoundedWord :: e -> Int -> Word64 -> Parser e s Word64+stepBoundedWord e !bitLimit !acc = do+ when (acc >= bit (bitLimit - 7)) $ P.fail e+ raw <- P.any e+ let content = clearBit raw 7+ acc' = unsafeShiftL acc 7 .|. fromIntegral @Word8 @Word64 content+ if testBit raw 7+ then stepBoundedWord e bitLimit acc'+ else pure acc'
src/Data/Bytes/Parser/Latin.hs view
@@ -50,6 +50,10 @@ , skipChar1 , skipTrailedBy , skipUntil+ , skipWhile+ -- * End of Input+ , endOfInput+ , isEndOfInput -- * Numbers -- ** Decimal -- *** Unsigned@@ -92,8 +96,8 @@ import Data.Bytes.Parser.Internal (Parser(..),ST#,uneffectful,Result#,uneffectful#) import Data.Bytes.Parser.Internal (InternalResult(..),indexLatinCharArray,upcastUnitSuccess) import Data.Bytes.Parser.Internal (boxBytes)-import Data.Bytes.Parser (bindFromLiftedToInt)-import Data.Bytes.Parser.Unsafe (expose,cursor)+import Data.Bytes.Parser (bindFromLiftedToInt,isEndOfInput,endOfInput)+import Data.Bytes.Parser.Unsafe (expose,cursor,unconsume) import Data.Word (Word8) import Data.Char (ord) import Data.Kind (Type)@@ -1160,3 +1164,28 @@ !cb = int2Word# (ltWord# r1 r0) !c = ca `or#` cb in (case c of { 0## -> False; _ -> True }, W# r1)++-- | Skip while the predicate is matched. This is always inlined.+skipWhile :: (Char -> Bool) -> Parser e s ()+{-# inline skipWhile #-}+skipWhile f = go where+ go = isEndOfInput >>= \case+ True -> pure ()+ False -> do+ w <- anyUnsafe+ if f w+ then go+ else unconsume 1++-- Interpret the next byte as an Latin1-encoded character.+-- Does not check to see if any characters are left. This+-- is not exported.+anyUnsafe :: Parser e s Char+{-# inline anyUnsafe #-}+anyUnsafe = uneffectful $ \chunk ->+ let w = indexCharArray (array chunk) (offset chunk) :: Char+ in InternalSuccess w (offset chunk + 1) (length chunk - 1)++-- Reads one byte and interprets it as Latin1-encoded character.+indexCharArray :: PM.ByteArray -> Int -> Char+indexCharArray (PM.ByteArray x) (I# i) = C# (indexCharArray# x i)
+ src/Data/Bytes/Parser/Leb128.hs view
@@ -0,0 +1,103 @@+{-# language BangPatterns #-}+{-# language BinaryLiterals #-}+{-# language TypeApplications #-}++-- | Parse numbers that have been encoded with <https://en.wikipedia.org/wiki/LEB128 LEB-128>.+-- LEB-128 allows arbitrarily large numbers to be encoded. Parsers in this+-- module will fail if the number they attempt to parse is outside the+-- range of what their target type can handle. The parsers for signed+-- numbers assume that the numbers have been+-- <https://developers.google.com/protocol-buffers/docs/encoding zigzig encoded>.+module Data.Bytes.Parser.Leb128+ ( -- * Unsigned+ word16+ , word32+ , word64+ -- * Signed (Zig-zag)+ , int16+ , int32+ , int64+ ) where++import Data.Bits (testBit,(.&.),unsafeShiftR,xor,complement)+import Data.Bits (unsafeShiftL,(.|.))+import Data.Bytes.Parser (Parser)+import Data.Int (Int16,Int32,Int64)+import Data.Word (Word8,Word16,Word32,Word64)++import qualified Data.Bytes.Parser as P++-- | Parse a LEB-128-encoded number. If the number is larger+-- than @0xFFFF@, fails with the provided error.+word16 :: e -> Parser e s Word16+word16 e = do+ w <- stepBoundedWord e 16 0 0+ pure (fromIntegral @Word64 @Word16 w)++-- | Parse a LEB-128-encoded number. If the number is larger+-- than @0xFFFFFFFF@, fails with the provided error.+word32 :: e -> Parser e s Word32+word32 e = do+ w <- stepBoundedWord e 32 0 0+ pure (fromIntegral @Word64 @Word32 w)++-- | Parse a LEB-128-encoded number. If the number is larger+-- than @0xFFFFFFFFFFFFFFFF@, fails with the provided error.+word64 :: e -> Parser e s Word64+word64 e = stepBoundedWord e 64 0 0++-- | Parse a LEB-128-zigzag-encoded signed number. If the encoded+-- number is outside the range @[-32768,32767]@, this fails with+-- the provided error.+int16 :: e -> Parser e s Int16+int16 = fmap zigzagDecode16 . word16++-- | Parse a LEB-128-zigzag-encoded signed number. If the encoded+-- number is outside the range @[-2147483648,2147483647]@, this+-- fails with the provided error.+int32 :: e -> Parser e s Int32+int32 = fmap zigzagDecode32 . word32++-- | Parse a LEB-128-zigzag-encoded signed number. If the encoded+-- number is outside the range @[-9223372036854775808,9223372036854775807]@,+-- this fails with the provided error.+int64 :: e -> Parser e s Int64+int64 = fmap zigzagDecode64 . word64++-- What these parameters are:+--+-- bitLimit: number of bits in the target word size+-- accShift: shift amount, increases by 7 at a time+stepBoundedWord :: e -> Int -> Word64 -> Int -> Parser e s Word64+stepBoundedWord e !bitLimit !acc0 !accShift = do+ raw <- P.any e+ let number = raw .&. 0x7F+ acc1 = acc0 .|.+ unsafeShiftL (fromIntegral @Word8 @Word64 number) accShift+ accShift' = accShift + 7+ if accShift' <= bitLimit+ then if testBit raw 7+ then stepBoundedWord e bitLimit acc1 accShift'+ else pure acc1+ else if fromIntegral @Word8 @Word raw < twoExp (bitLimit - accShift)+ then pure acc1 -- TODO: no need to mask upper bit in number+ else P.fail e++twoExp :: Int -> Word+twoExp x = unsafeShiftL 1 x++-- Zigzag decode strategy taken from https://stackoverflow.com/a/2211086/1405768+-- The accepted answer is a little bit, so an answer further down was used:+--+-- > zigzag_decode(value) = ( value >> 1 ) ^ ( ~( value & 1 ) + 1 )+zigzagDecode16 :: Word16 -> Int16+zigzagDecode16 n =+ fromIntegral ((unsafeShiftR n 1) `xor` (complement (n .&. 1) + 1))++zigzagDecode32 :: Word32 -> Int32+zigzagDecode32 n =+ fromIntegral ((unsafeShiftR n 1) `xor` (complement (n .&. 1) + 1))++zigzagDecode64 :: Word64 -> Int64+zigzagDecode64 n =+ fromIntegral ((unsafeShiftR n 1) `xor` (complement (n .&. 1) + 1))
src/Data/Bytes/Parser/Rebindable.hs view
@@ -102,6 +102,33 @@ runParser (g y) (# arr, b, c #) s1 ) +pureInt5Parser :: forall (a :: TYPE ('TupleRep '[ 'IntRep, 'IntRep, 'IntRep, 'IntRep, 'IntRep])) e s.+ a -> Parser e s a+{-# inline pureInt5Parser #-}+pureInt5Parser a = Parser+ (\(# _, b, c #) s -> (# s, (# | (# a, b, c #) #) #))++bindInt5Parser :: forall (a :: TYPE ('TupleRep '[ 'IntRep, 'IntRep, 'IntRep, 'IntRep, 'IntRep])) e s b.+ Parser e s a -> (a -> Parser e s b) -> Parser e s b+{-# inline bindInt5Parser #-}+bindInt5Parser (Parser f) g = Parser+ (\x@(# arr, _, _ #) s0 -> case f x s0 of+ (# s1, r0 #) -> case r0 of+ (# e | #) -> (# s1, (# e | #) #)+ (# | (# y, b, c #) #) ->+ runParser (g y) (# arr, b, c #) s1+ )++sequenceInt5Parser :: forall (a :: TYPE ('TupleRep '[ 'IntRep, 'IntRep, 'IntRep, 'IntRep, 'IntRep])) e s b.+ Parser e s a -> Parser e s b -> Parser e s b+{-# inline sequenceInt5Parser #-}+sequenceInt5Parser (Parser f) (Parser g) = Parser+ (\x@(# arr, _, _ #) s0 -> case f x s0 of+ (# s1, r0 #) -> case r0 of+ (# e | #) -> (# s1, (# e | #) #)+ (# | (# _, b, c #) #) -> g (# arr, b, c #) s1+ )+ sequenceIntPairParser :: forall (a :: TYPE ('TupleRep '[ 'IntRep, 'IntRep])) e s b. Parser e s a -> Parser e s b -> Parser e s b {-# inline sequenceIntPairParser #-}@@ -112,6 +139,33 @@ (# | (# _, b, c #) #) -> g (# arr, b, c #) s1 ) +bindInt2to5Parser :: forall + (a :: TYPE ('TupleRep '[ 'IntRep, 'IntRep])) + (b :: TYPE ('TupleRep '[ 'IntRep, 'IntRep, 'IntRep, 'IntRep, 'IntRep]))+ e s.+ Parser e s a -> (a -> Parser e s b) -> Parser e s b+{-# inline bindInt2to5Parser #-}+bindInt2to5Parser (Parser f) g = Parser+ (\x@(# arr, _, _ #) s0 -> case f x s0 of+ (# s1, r0 #) -> case r0 of+ (# e | #) -> (# s1, (# e | #) #)+ (# | (# y, b, c #) #) ->+ runParser (g y) (# arr, b, c #) s1+ )++sequenceInt2to5Parser :: forall + (a :: TYPE ('TupleRep '[ 'IntRep, 'IntRep]))+ (b :: TYPE ('TupleRep '[ 'IntRep, 'IntRep, 'IntRep, 'IntRep, 'IntRep]))+ e s.+ Parser e s a -> Parser e s b -> Parser e s b+{-# inline sequenceInt2to5Parser #-}+sequenceInt2to5Parser (Parser f) (Parser g) = Parser+ (\x@(# arr, _, _ #) s0 -> case f x s0 of+ (# s1, r0 #) -> case r0 of+ (# e | #) -> (# s1, (# e | #) #)+ (# | (# _, b, c #) #) -> g (# arr, b, c #) s1+ )+ instance Bind 'LiftedRep 'LiftedRep where {-# inline (>>=) #-} {-# inline (>>) #-}@@ -130,12 +184,46 @@ (>>=) = bindIntPairParser (>>) = sequenceIntPairParser ++instance Bind ('TupleRep '[ 'IntRep, 'IntRep])+ ('TupleRep '[ 'IntRep, 'IntRep, 'IntRep, 'IntRep, 'IntRep]) + where+ {-# inline (>>=) #-}+ {-# inline (>>) #-}+ (>>=) = bindInt2to5Parser+ (>>) = sequenceInt2to5Parser++instance Bind ('TupleRep '[ 'IntRep, 'IntRep, 'IntRep, 'IntRep, 'IntRep]) + 'LiftedRep+ where+ {-# inline (>>=) #-}+ {-# inline (>>) #-}+ (>>=) = bindInt5Parser+ (>>) = sequenceInt5Parser+++instance Bind 'IntRep+ ('TupleRep '[ 'IntRep, 'IntRep, 'IntRep, 'IntRep, 'IntRep]) + where+ {-# inline (>>=) #-}+ {-# inline (>>) #-}+ (>>=) = bindFromIntToInt5+ (>>) = sequenceIntToInt5+ instance Bind 'LiftedRep ('TupleRep '[ 'IntRep, 'IntRep]) where {-# inline (>>=) #-} {-# inline (>>) #-} (>>=) = bindFromLiftedToIntPair (>>) = sequenceLiftedToIntPair +instance Bind 'LiftedRep+ ('TupleRep '[ 'IntRep, 'IntRep, 'IntRep, 'IntRep, 'IntRep]) + where+ {-# inline (>>=) #-}+ {-# inline (>>) #-}+ (>>=) = bindFromLiftedToInt5+ (>>) = sequenceLiftedToInt5+ instance Bind 'IntRep ('TupleRep '[ 'IntRep, 'IntRep]) where {-# inline (>>=) #-} {-# inline (>>) #-}@@ -160,6 +248,10 @@ {-# inline pure #-} pure = pureIntPairParser +instance Pure ('TupleRep '[ 'IntRep, 'IntRep, 'IntRep, 'IntRep, 'IntRep]) where+ {-# inline pure #-}+ pure = pureInt5Parser+ bindFromIntToIntPair :: forall s e (a :: TYPE 'IntRep)@@ -191,6 +283,37 @@ (# | (# _, b, c #) #) -> g (# arr, b, c #) s1 ) +bindFromIntToInt5 ::+ forall s e+ (a :: TYPE 'IntRep)+ (b :: TYPE ('TupleRep '[ 'IntRep, 'IntRep, 'IntRep, 'IntRep, 'IntRep ])).+ Parser s e a+ -> (a -> Parser s e b)+ -> Parser s e b+{-# inline bindFromIntToInt5 #-}+bindFromIntToInt5 (Parser f) g = Parser+ (\x@(# arr, _, _ #) s0 -> case f x s0 of+ (# s1, r0 #) -> case r0 of+ (# e | #) -> (# s1, (# e | #) #)+ (# | (# y, b, c #) #) ->+ runParser (g y) (# arr, b, c #) s1+ )++sequenceIntToInt5 ::+ forall s e+ (a :: TYPE 'IntRep)+ (b :: TYPE ('TupleRep '[ 'IntRep, 'IntRep, 'IntRep, 'IntRep, 'IntRep ])).+ Parser s e a+ -> Parser s e b+ -> Parser s e b+{-# inline sequenceIntToInt5 #-}+sequenceIntToInt5 (Parser f) (Parser g) = Parser+ (\x@(# arr, _, _ #) s0 -> case f x s0 of+ (# s1, r0 #) -> case r0 of+ (# e | #) -> (# s1, (# e | #) #)+ (# | (# _, b, c #) #) -> g (# arr, b, c #) s1+ )+ bindFromLiftedToIntPair :: forall s e (a :: TYPE 'LiftedRep)@@ -216,6 +339,38 @@ -> Parser s e b {-# inline sequenceLiftedToIntPair #-} sequenceLiftedToIntPair (Parser f) (Parser g) = Parser+ (\x@(# arr, _, _ #) s0 -> case f x s0 of+ (# s1, r0 #) -> case r0 of+ (# e | #) -> (# s1, (# e | #) #)+ (# | (# _, b, c #) #) -> g (# arr, b, c #) s1+ )+++bindFromLiftedToInt5 ::+ forall s e+ (a :: TYPE 'LiftedRep)+ (b :: TYPE ('TupleRep '[ 'IntRep, 'IntRep, 'IntRep, 'IntRep, 'IntRep])).+ Parser s e a+ -> (a -> Parser s e b)+ -> Parser s e b+{-# inline bindFromLiftedToInt5 #-}+bindFromLiftedToInt5 (Parser f) g = Parser+ (\x@(# arr, _, _ #) s0 -> case f x s0 of+ (# s1, r0 #) -> case r0 of+ (# e | #) -> (# s1, (# e | #) #)+ (# | (# y, b, c #) #) ->+ runParser (g y) (# arr, b, c #) s1+ )++sequenceLiftedToInt5 ::+ forall s e+ (a :: TYPE 'LiftedRep)+ (b :: TYPE ('TupleRep '[ 'IntRep, 'IntRep, 'IntRep, 'IntRep, 'IntRep ])).+ Parser s e a+ -> Parser s e b+ -> Parser s e b+{-# inline sequenceLiftedToInt5 #-}+sequenceLiftedToInt5 (Parser f) (Parser g) = Parser (\x@(# arr, _, _ #) s0 -> case f x s0 of (# s1, r0 #) -> case r0 of (# e | #) -> (# s1, (# e | #) #)
test/Main.hs view
@@ -15,21 +15,27 @@ import Data.Bytes.Types (Bytes(Bytes)) import Data.Char (ord) import Data.Coerce (coerce)+import Data.Int (Int16,Int32) import Data.Primitive (ByteArray(..),PrimArray(..)) import Data.Text.Short (ShortText) import Data.WideWord (Word128(Word128)) import Data.Word (Word8,Word64,Word16,Word32)+import Numeric.Natural (Natural) import System.ByteOrder (Fixed(..),ByteOrder(BigEndian,LittleEndian)) import Test.Tasty (defaultMain,testGroup,TestTree) import Test.Tasty.HUnit ((@=?),testCase) import Test.Tasty.QuickCheck ((===),testProperty) import qualified Data.Bits as Bits+import qualified Data.Bytes as Bytes import qualified Data.Bytes.Parser as P import qualified Data.Bytes.Parser.Ascii as Ascii-import qualified Data.Bytes.Parser.Latin as Latin+import qualified Data.Bytes.Parser.Base128 as Base128 import qualified Data.Bytes.Parser.BigEndian as BigEndian+import qualified Data.Bytes.Parser.Latin as Latin+import qualified Data.Bytes.Parser.Leb128 as Leb128 import qualified Data.Bytes.Parser.LittleEndian as LittleEndian+import qualified Data.List as List import qualified Data.Primitive as PM import qualified GHC.Exts as Exts import qualified Test.Tasty.QuickCheck as QC@@ -358,6 +364,70 @@ @=? P.Success (Slice 17 0 0xABCD01235678BCDE) ]+ , testGroup "base128-w32"+ [ testCase "A" $+ P.Success (Slice 2 0 0x7E)+ @=?+ P.parseBytes (Base128.word32 ()) (bytes "\x7E")+ , testCase "B" $+ P.Success (Slice 5 0 0x200000)+ @=?+ P.parseBytes (Base128.word32 ()) (bytes "\x81\x80\x80\x00")+ , testCase "C" $+ P.Success (Slice 4 0 1656614)+ @=?+ P.parseBytes (Base128.word32 ()) (bytes "\xE5\x8E\x26")+ -- , testProperty "iso" $ \w -> -- TODO+ -- P.parseBytesMaybe (Base.word32 ()) (encodeBase128 (fromIntegral w))+ -- ===+ -- Just w+ ]+ , testGroup "leb128-w32"+ [ testCase "A" $+ P.Success (Slice 2 0 0x7E)+ @=?+ P.parseBytes (Leb128.word32 ()) (bytes "\x7E")+ , testCase "B" $+ P.Success (Slice 5 0 0x200000)+ @=?+ P.parseBytes (Leb128.word32 ()) (bytes "\x80\x80\x80\x01")+ , testCase "C" $+ P.Success (Slice 4 0 624485)+ @=?+ P.parseBytes (Leb128.word32 ()) (bytes "\xE5\x8E\x26")+ , testProperty "iso" $ \w -> + P.parseBytesMaybe (Leb128.word32 ()) (encodeLeb128 (fromIntegral w))+ ===+ Just w+ ]+ , testGroup "leb128-w16"+ [ testCase "A" $+ P.Failure ()+ @=?+ P.parseBytes (Leb128.word16 ()) (bytes "\x80\x80\x04")+ , testCase "B" $+ P.Success (Slice 4 0 0xFFFF)+ @=?+ P.parseBytes (Leb128.word16 ()) (bytes "\xFF\xFF\x03")+ , testProperty "iso" $ \w -> + P.parseBytesMaybe (Leb128.word16 ()) (encodeLeb128 (fromIntegral w))+ ===+ Just w+ ]+ , testGroup "leb128-i16"+ [ testProperty "iso" $ \(w :: Int16) -> + P.parseBytesMaybe (Leb128.int16 ())+ (encodeLeb128 (fromIntegral @Word16 @Natural (zigzag16 w)))+ ===+ Just w+ ]+ , testGroup "leb128-i32"+ [ testProperty "iso" $ \(w :: Int32) -> + P.parseBytesMaybe (Leb128.int32 ())+ (encodeLeb128 (fromIntegral @Word32 @Natural (zigzag32 w)))+ ===+ Just w+ ] ] bytes :: String -> Bytes@@ -471,4 +541,26 @@ untype :: PrimArray a -> ByteArray untype (PrimArray x) = ByteArray x +encodeLeb128 :: Natural -> Bytes+encodeLeb128 x = Bytes.unsafeDrop 1 (Exts.fromList (0xFF : go [] x)) where+ go !xs !n =+ let (q,r) = quotRem n 128+ r' = fromIntegral @Natural @Word8 r+ w = if q == 0+ then r'+ else Bits.setBit r' 7+ xs' = w : xs+ in if q == 0 + then List.reverse xs'+ else go xs' q +-- x zigzagInteger :: Integer -> Natural+-- x zigzagInteger x+-- x | x>=0 = fromInteger (x `Bits.shiftL` 1)+-- x | otherwise = fromInteger (negate (x `Bits.shiftL` 1) - 1)++zigzag16 :: Int16 -> Word16+zigzag16 x = fromIntegral ((x `Bits.shiftL` 1) `Bits.xor` (x `Bits.shiftR` 15))++zigzag32 :: Int32 -> Word32+zigzag32 x = fromIntegral ((x `Bits.shiftL` 1) `Bits.xor` (x `Bits.shiftR` 31))