leb128 (empty) → 0.1.0.0

raw patch · 13 files changed

+862/−0 lines, 13 filesdep +QuickCheckdep +basedep +bytestringsetup-changed

Dependencies added: QuickCheck, base, bytestring, criterion, deepseq, ghc-prim, leb128, test-framework, test-framework-quickcheck2, transformers

Files

CHANGELOG.md +5/−0
LICENSE +30/−0
README.md +16/−0
Setup.hs +2/−0
bench/Bench.hs +98/−0
leb128.cabal +69/−0
src/Codec/LEB128.hs +133/−0
src/Codec/LEB128/Constraints.hs +62/−0
src/Codec/LEB128/Generic.hs +141/−0
src/Codec/LEB128/Internal/BS.hs +108/−0
src/Codec/LEB128/List.hs +65/−0
test/LEB128/Props.hs +30/−0
test/TestLEB.hs +103/−0

+ CHANGELOG.md view

@@ -0,0 +1,5 @@+# Revision history for leb128
+
+## 0.1.0.0 -- 2020-04-23
+
+* First version. Released on an unsuspecting world.

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2019, Andreas Klebinger
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Andreas Klebinger nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ README.md view

@@ -0,0 +1,16 @@+# General purpose library for encoding values to LEB128 encoded byte sequences.
+
+This library provides a generic interface to the core (S)LEB128 encoding
+algorithm.
+
+## Provided specific interfaces:
+
+* A specializations based on `bytestring` in "Codec.LEB128".
+* A specialization over lists in "Codec.LEB128.List".
+* Other implementations should be easy to derive from the interface provided
+in "Codec.LEB128.Generic"
+
+## Alternative implementations
+
+The package `leb128-cereal` provides a way to decode using a
+cereal parser using the same algorithm.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple
+main = defaultMain

+ bench/Bench.hs view

@@ -0,0 +1,98 @@+{-# LANGUAGE BangPatterns #-}++module Main (main) where++import Criterion.Main+import GHC.Exts++-- import Data.LEB+import Codec.LEB128.List+import qualified Codec.LEB128 as BS+import Data.Int+import Data.Word+import Data.ByteString (pack, ByteString)+import Control.DeepSeq+import Data.ByteString.Builder+import Data.ByteString.Builder.Internal (toLazyByteStringWith, safeStrategy, untrimmedStrategy)+import Data.ByteString.Lazy (toStrict)++bytes_maxBoundInt = [255,255,255,255,255,255,255,255,127] :: [Word8]+bytes_minBoundInt = [128,128,128,128,128,128,128,128,128,127] :: [Word8]+bytes_1 = [1] :: [Word8]++-- Going through the BS.Builder interface comes with a good deal+-- of overhead. Decoding a large integer can take as much as 4x+-- as long as decoding to a list directly for example.+-- However in exchange we get a fair bit of flexibility.+{-# INLINE build_bs #-}+build_bs :: Builder -> ByteString+build_bs = toStrict .+    (toLazyByteStringWith+        (untrimmedStrategy 11 123)+        mempty+    )++benchPut :: NFData a => (Word64 -> a) -> Benchmark+benchPut encoder = bgroup "putOutlined"+    [   bench "w64_0" $ nf encoder (0 :: Word64)+    ,   bench "w64_1" $ nf encoder (1 :: Word64)+    ,   bench "w64_255" $ nf encoder (255 :: Word64)+    ,   bench "w64_max" $ nf encoder (maxBound :: Word64)+    ]++benchGetBS :: NFData b => String -> (ByteString -> b) -> Benchmark+benchGetBS name decoder =+    bgroup name+        [   bench "w64_1  " $ nf (decoder) bs_1+        ,   bench "w64_max" $ nf (decoder) bs_maxBoundInt+        ]++bs_1 :: ByteString+bs_1 = pack [1]+bs_maxBoundInt :: ByteString+bs_maxBoundInt = pack $ toSLEB128 (maxBound :: Int) :: ByteString++main = do+  return $! force bs_1+  return $! force bs_maxBoundInt++  defaultMain+    [   bench "benchmark_overhead" $ nf (:[]) (0 :: Word64)+    ,   bgroup "list" [+            bgroup "unsigned"+            [   bgroup "put"+                    [   bench "w64_0" $ nf (toULEB128) (0 :: Word64)+                    ,   bench "w64_1" $ nf (toULEB128) (1 :: Word64)+                    ,   bench "w64_255" $ nf (toULEB128) (255 :: Word64)+                    ,   bench "w64_max" $ nf (toULEB128) (maxBound :: Word64)+                    ]+            ,   bgroup "get"+                    [   bench "w64_1  " $ whnf (fst . fromULEB128 :: [Word8] -> Word) bytes_1+                    ,   bench "w64_max" $ whnf (fst . fromULEB128 :: [Word8] -> Word) bytes_maxBoundInt+                    ]+            ]+        ,   bgroup "signed"+            [   bgroup "put"+                    [   bench "i64_0" $ whnf (sum . toSLEB128) (0 :: Int64)+                    ,   bench "i64_1" $ whnf (sum . toSLEB128) (1 :: Int64)+                    ,   bench "i64_255" $ whnf (sum . toSLEB128) (255 :: Int64)+                    ,   bench "i64_max" $ whnf (sum . toSLEB128) (maxBound :: Int64)+                    ]+            ,   bgroup "get"+                    [   bench "w64_1  " $ whnf (fst . fromSLEB128 :: [Word8] -> Int) bytes_1+                    ,   bench "w64_max" $ whnf (fst . fromSLEB128 :: [Word8] -> Int) bytes_maxBoundInt+                    ,   bench "w64_max" $ whnf (fst . fromSLEB128 :: [Word8] -> Int) bytes_minBoundInt+                    ]+            ]+        ]+    ,   bgroup "bs"+            [   benchPut BS.toULEB128ByteString+            ,   benchPut BS.toULEB128ByteString+            ,   benchGetBS "getInt" (BS.fromSLEB128ByteString :: ByteString -> (Maybe Int,ByteString))+            ,   benchGetBS "getInteger" (BS.fromSLEB128ByteString :: ByteString -> (Maybe Integer,ByteString))+            ,   benchGetBS "getIntUnsafe" (BS.fromSLEB128ByteStringUnsafe :: ByteString -> (Int,ByteString))+            ,   benchGetBS "getIntegerUnsafe" (BS.fromSLEB128ByteStringUnsafe :: ByteString -> (Integer,ByteString))+            ]++    ]+

+ leb128.cabal view

@@ -0,0 +1,69 @@+cabal-version:       1.22++name:                leb128+version:             0.1.0.0+synopsis:            LEB128 encoding logic for and in Haskell+description:         Encode and decode integral numbers to and from sequences of bytes using LEB128.+homepage:            https://github.com/AndreasPK/leb128/issues++-- bug-reports:+license:             BSD3+license-file:        LICENSE+author:              Andreas Klebinger+maintainer:          klebinger.andreas@gmx.at+-- copyright:+category:            Codec+build-type:          Simple+extra-source-files:  CHANGELOG.md, README.md++source-repository head+  type:     git+  location: https://github.com/AndreasPK/leb128++library+  exposed-modules:+    Codec.LEB128.List+    Codec.LEB128.Generic+    Codec.LEB128.Internal.BS+    Codec.LEB128+    Codec.LEB128.Constraints+  build-depends:+      base >= 4.8 && < 4.15+    , bytestring >= 0.10.6 && < 0.10.11+    , ghc-prim+    , transformers+  hs-source-dirs:      src+  default-language:    Haskell2010+  ghc-options: -Wall+  -- ghc-options: -ddump-stg-final -ddump-simpl -ddump-to-file+              --  -dno-typeable-binds+++test-suite leb128-test+  default-language:    Haskell2010+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:+      TestLEB.hs+  other-modules:+      LEB128.Props++  build-depends:+      base+    , leb128 -any+    , QuickCheck >= 2.13 && < 2.15+    , test-framework >= 0.8 && < 0.9+    , test-framework-quickcheck2 >= 0.3 && < 0.4+    , bytestring++benchmark leb128-bench+  default-language:    Haskell2010+  type:                exitcode-stdio-1.0+  hs-source-dirs:      bench+  main-is:             Bench.hs+  build-depends:+      base+    , leb128 -any+    , criterion >= 1.5 && < 1.6+    , bytestring+    , deepseq

+ src/Codec/LEB128.hs view

@@ -0,0 +1,133 @@+{- | Encode numbers to and from bytestrings using the (S)LEB128 encoding.
+
+     The implementation is backed by the generic algorithms defined
+     in "Codec.LEB128.Generic".
+
+-}
+
+module Codec.LEB128
+    (
+    -- * Encode values as bytestring builder.
+      toULEB128Builder
+    , toSLEB128Builder
+    -- * Encode value as bytestring.
+    , toULEB128ByteString
+    , toSLEB128ByteString
+
+    -- * Encode value from bytestring.
+    , fromULEB128ByteString
+    , fromSLEB128ByteString
+    , fromULEB128ByteStringN
+    , fromSLEB128ByteStringI
+
+    -- * Encode value from bytestring. Throws an error if not enough bytes are provided.
+    , fromULEB128ByteStringUnsafe
+    , fromSLEB128ByteStringUnsafe
+    , fromULEB128ByteStringNUnsafe
+    , fromSLEB128ByteStringIUnsafe
+    )
+where
+
+import Numeric.Natural
+import Data.Word
+import Data.Int
+
+import Data.ByteString.Builder.Extra (toLazyByteStringWith, safeStrategy, AllocationStrategy)
+import Data.ByteString.Builder as B(Builder)
+import Data.ByteString.Lazy (toStrict)
+import Data.ByteString (ByteString)
+
+import Codec.LEB128.Constraints
+import Codec.LEB128.Internal.BS as B
+
+-- Builders
+
+{-# SPECIALIZE toULEB128Builder :: Natural -> Builder #-}
+{-# SPECIALIZE toULEB128Builder :: Word -> Builder #-}
+{-# SPECIALIZE toULEB128Builder :: Word64 -> Builder #-}
+{-# SPECIALIZE toULEB128Builder :: Word32 -> Builder #-}
+-- | Encode values as bytestring builder.
+{-# INLINEABLE toULEB128Builder #-}
+toULEB128Builder :: LEB128 a => a -> B.Builder
+toULEB128Builder = B.toULEB128
+
+{-# SPECIALIZE toSLEB128Builder :: Integer -> Builder #-}
+{-# SPECIALIZE toSLEB128Builder :: Int -> Builder #-}
+{-# SPECIALIZE toSLEB128Builder :: Int64 -> Builder #-}
+{-# SPECIALIZE toSLEB128Builder :: Int32 -> Builder #-}
+{-# INLINEABLE toSLEB128Builder #-}
+toSLEB128Builder :: SLEB128 a => a -> B.Builder
+toSLEB128Builder = B.toSLEB128
+
+smallChunks :: AllocationStrategy
+smallChunks = safeStrategy 12 64
+
+-- Conversion to encodede ByteString
+
+{-# SPECIALIZE toULEB128ByteString :: Natural -> ByteString #-}
+{-# SPECIALIZE toULEB128ByteString :: Word -> ByteString #-}
+{-# SPECIALIZE toULEB128ByteString :: Word64 -> ByteString #-}
+{-# SPECIALIZE toULEB128ByteString :: Word32 -> ByteString #-}
+{-# INLINEABLE toULEB128ByteString #-}
+toULEB128ByteString :: LEB128 a => a -> ByteString
+toULEB128ByteString = toStrict . toLazyByteStringWith smallChunks mempty . toULEB128Builder
+
+{-# SPECIALIZE toSLEB128ByteString :: Integer -> ByteString #-}
+{-# SPECIALIZE toSLEB128ByteString :: Int -> ByteString #-}
+{-# SPECIALIZE toSLEB128ByteString :: Int64 -> ByteString #-}
+{-# SPECIALIZE toSLEB128ByteString :: Int32 -> ByteString #-}
+{-# INLINEABLE toSLEB128ByteString #-}
+toSLEB128ByteString :: SLEB128 a => a -> ByteString
+toSLEB128ByteString = toStrict . toLazyByteStringWith smallChunks mempty . toSLEB128Builder
+
+-- Conversion from encoded ByteString
+
+{-# SPECIALIZE fromULEB128ByteString :: ByteString-> (Maybe Natural,ByteString) #-}
+{-# SPECIALIZE fromULEB128ByteString :: ByteString-> (Maybe Word,ByteString) #-}
+{-# SPECIALIZE fromULEB128ByteString :: ByteString-> (Maybe Word64,ByteString) #-}
+{-# SPECIALIZE fromULEB128ByteString :: ByteString-> (Maybe Word32,ByteString) #-}
+{-# INLINEABLE fromULEB128ByteString #-}
+fromULEB128ByteString :: LEB128 a => ByteString -> (Maybe a,ByteString)
+fromULEB128ByteString = B.fromULEB128
+
+{-# SPECIALIZE fromSLEB128ByteString :: ByteString-> (Maybe Integer,ByteString) #-}
+{-# SPECIALIZE fromSLEB128ByteString :: ByteString-> (Maybe Int,ByteString) #-}
+{-# SPECIALIZE fromSLEB128ByteString :: ByteString-> (Maybe Int64,ByteString) #-}
+{-# SPECIALIZE fromSLEB128ByteString :: ByteString-> (Maybe Int32,ByteString) #-}
+{-# INLINEABLE fromSLEB128ByteString #-}
+fromSLEB128ByteString :: SLEB128 a => ByteString -> (Maybe a,ByteString)
+fromSLEB128ByteString = B.fromSLEB128
+
+{-# NOINLINE fromULEB128ByteStringN #-}
+fromULEB128ByteStringN :: ByteString -> (Maybe Natural,ByteString)
+fromULEB128ByteStringN = B.fromULEB128
+
+{-# NOINLINE fromSLEB128ByteStringI #-}
+fromSLEB128ByteStringI :: ByteString -> (Maybe Integer,ByteString)
+fromSLEB128ByteStringI = B.fromSLEB128
+
+-- Be partial if not enough bytes are provided.
+
+{-# SPECIALIZE fromULEB128ByteStringUnsafe :: ByteString-> (Natural,ByteString) #-}
+{-# SPECIALIZE fromULEB128ByteStringUnsafe :: ByteString-> (Word,ByteString) #-}
+{-# SPECIALIZE fromULEB128ByteStringUnsafe :: ByteString-> (Word64,ByteString) #-}
+{-# SPECIALIZE fromULEB128ByteStringUnsafe :: ByteString-> (Word32,ByteString) #-}
+{-# INLINEABLE fromULEB128ByteStringUnsafe #-}
+fromULEB128ByteStringUnsafe :: LEB128 a => ByteString -> (a,ByteString)
+fromULEB128ByteStringUnsafe = B.fromULEB128Unsafe
+
+{-# SPECIALIZE fromSLEB128ByteStringUnsafe :: ByteString-> (Integer,ByteString) #-}
+{-# SPECIALIZE fromSLEB128ByteStringUnsafe :: ByteString-> (Int,ByteString) #-}
+{-# SPECIALIZE fromSLEB128ByteStringUnsafe :: ByteString-> (Int64,ByteString) #-}
+{-# SPECIALIZE fromSLEB128ByteStringUnsafe :: ByteString-> (Int32,ByteString) #-}
+{-# INLINEABLE fromSLEB128ByteStringUnsafe #-}
+fromSLEB128ByteStringUnsafe :: SLEB128 a => ByteString -> (a,ByteString)
+fromSLEB128ByteStringUnsafe = B.fromSLEB128Unsafe
+
+{-# NOINLINE fromULEB128ByteStringNUnsafe #-}
+fromULEB128ByteStringNUnsafe :: ByteString -> (Natural,ByteString)
+fromULEB128ByteStringNUnsafe = B.fromULEB128Unsafe
+
+{-# NOINLINE fromSLEB128ByteStringIUnsafe #-}
+fromSLEB128ByteStringIUnsafe :: ByteString -> (Integer,ByteString)
+fromSLEB128ByteStringIUnsafe = B.fromSLEB128Unsafe

+ src/Codec/LEB128/Constraints.hs view

@@ -0,0 +1,62 @@+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+{- |
+    Module      : Codec.LEB128.Constraints
+    Description : Constrain encoding to compatible types.
+    Copyright   : (c) Andreas Klebinger 2020
+    License     : BSD3
+    Maintainer  : Andreas Klebinger
+    Portability : GHC >= 7.10
+
+    SLEB128 is a synonym for the required constraints to encode values
+    in the signed version of LEB128.
+
+    LEB128 is a typeclass which by default limits encoding in unsigned LEB128
+    format to GHC-Provided untyped valued.
+
+    UnsafeAnyLEB128 is a newtype providing an explicit way to avoid this
+    restriction for cases where the type is signed, but values are not.
+-}
+
+module Codec.LEB128.Constraints
+    ( LEB128
+    , SLEB128
+    , UnsafeAnyLEB128(..)
+    )
+where
+
+import Numeric.Natural
+import Data.Word
+import Data.Int
+import Data.Bits
+
+newtype UnsafeAnyLEB128 a = UnsafeAnyLEB128 a deriving (Eq,Bits,Num,Ord,Real,Enum,Integral)
+
+-- | Indicates that a type can safely be encoded as (unsigned) LEB128.
+class (Bits a, Integral a) => LEB128 a where
+-- | Indicates that a type can safely be encoded as (signed) SLEB128.
+class (Bits a, Integral a) => SLEB128 a where
+
+-- | Unsafe escape hatch to force a particular encoding.
+instance (Bits a, Integral a) => LEB128  (UnsafeAnyLEB128 a)
+-- | Unsafe escape hatch to force a particular encoding.
+instance (Bits a, Integral a) => SLEB128 (UnsafeAnyLEB128 a)
+
+-- Some instances
+instance LEB128 Natural
+instance LEB128 Word
+instance LEB128 Word8
+instance LEB128 Word16
+instance LEB128 Word32
+instance LEB128 Word64
+
+-- Some instances
+instance SLEB128 Integer
+instance SLEB128 Int
+instance SLEB128 Int8
+instance SLEB128 Int16
+instance SLEB128 Int32
+instance SLEB128 Int64
+

+ src/Codec/LEB128/Generic.hs view

@@ -0,0 +1,141 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns #-}+++{- |+    Module      : Codec.LEB128.Generic+    Description : Encode values via (S)LEB128+    Copyright   : (c) Andreas Klebinger 2020+    License     : BSD3+    Maintainer  : Andreas Klebinger+    Portability : GHC >= 7.10++     This module provides a generic interface over the encoding+     and decoding algorithm. It can be instantiated to a wide+     variate of types.++     Instantiations based on bytestring and lists are provided in the+     "Codec.LEB128.List" and "Codec.LEB128.Internal.BS" modules.++     Size checks for inputs or output types are not performed by default.+     However they can be included in the put/get functions if desired.++-}++module Codec.LEB128.Generic+  (+    -- * Generic encoding functions+    encodeLEB128+  , encodeSLEB128+    -- * Generic decoding functions+  , decodeLEB128+  , decodeSLEB128)+where++-- import Control.Applicative+import Data.Bits ((.|.), unsafeShiftR, unsafeShiftL,+                  testBit, clearBit, setBit, bit)+import Data.Word+import Data.Monoid ((<>))+import Prelude hiding ((<>))+import GHC.Magic++import Codec.LEB128.Constraints++-- | LEB128-encode a unsigned value into a sequence of bytes.+--+-- For example to encode a integer into a list of words you might use.+--+-- > encodeLEB128 pure :: Integer -> [Word8]+--+-- To do the same using a serialization library like bytestrings builder:+--+-- > encodeLEB128 (B.word8)+--+-- For performance reasons it can be important to make sure @encodeLEB128@+-- is sufficiently specialized. One way to achieve this is to force inlining+-- using the @inline@ function from GHC.Magic (defined in the ghc-prim package).+-- For an efficient example generic over the value type this gives us for lists:+--+-- @+--    toULEB128 :: (Integral a, Bits a) => a -> [Word8]+--    toULEB128 = (inline G.encodeLEB128) pure+-- @+--+-- Results are undefined for negative numbers.+{-# INLINE encodeLEB128 #-}+encodeLEB128 :: forall a m. (Monoid m, LEB128 a) => (Word8 -> m) -> a -> m+encodeLEB128 !putWord8 = go+  where+    go !i+      | i <= 127+      = (inline putWord8) $! (fromIntegral i :: Word8)+      | otherwise =+        -- bit 7 (8th bit) indicates more to come.+        let !byte = (setBit (fromIntegral i) 7)+        in (inline putWord8) byte <> go (i `unsafeShiftR` 7)++-- | SLEB128-encodes an singed value into a sequence of bytes.+--+-- Works the same as @encodeLEB128@ but supports negative values.+{-# INLINE encodeSLEB128 #-}+encodeSLEB128 :: forall a m. (Monoid m, SLEB128 a) => (Word8 -> m) -> a -> m+encodeSLEB128 putWord8 = go+  where+    go val = do+        let !byte = fromIntegral (clearBit val 7) :: Word8+        let !val' = val `unsafeShiftR` 7+        let !signBit = testBit byte 6+        let !done =+                -- Unsigned value, val' == 0 and last value can+                -- be discriminated from a negative number.+                (val' == 0 && not signBit) ||+                -- Signed value,+                (val' == -1 && signBit)+        let !byte' = if done then byte else setBit byte 7+        putWord8 byte' <> if done then mempty else go val'++-- | LEB128-decodes a unsigned value given a monadic way to request bytes.+--+-- For example a implementation over a state monad might look like:+--+-- > execState . decodeLEB128 getByte+--+-- This pattern is used by the bytestring based decoder in this package.+-- See there for a complete example.+{-# INLINE decodeLEB128 #-}+decodeLEB128 :: forall a m. (Monad m, LEB128 a) => m Word8 -> m a+decodeLEB128 getWord8 = go 0 0+  where+    go :: Int -> a -> m a+    go !shift !w = do+        byte <- getWord8+        let !byteVal = fromIntegral (clearBit byte 7)+        let !hasMore = testBit byte 7+        let !val = w .|. (byteVal `unsafeShiftL` shift)+        let !shift' = shift+7+        if hasMore+            then go shift' val+            else return $! val++-- | SLEB128-decodes a unsigned number given a monadic way to request bytes.+--+-- Same as decodeLEB128 but for the signed encoding.+{-# INLINE decodeSLEB128 #-}+decodeSLEB128 :: forall a m. (Monad m, SLEB128 a) => m Word8 -> m a+decodeSLEB128 getWord8 = go 0 0+  where+    go :: Int -> a -> m a+    go !shift !w = do+        byte <- getWord8 :: m Word8+        let !byteVal = fromIntegral (clearBit byte 7)+        let !hasMore = testBit byte 7+        let !val = w .|. (byteVal `unsafeShiftL` shift)+        let !shift' = shift+7+        if hasMore+            then go shift' val+            else do+                let !signed = testBit byte 6+                if signed+                then pure $! val - bit shift'+                else pure $! val

+ src/Codec/LEB128/Internal/BS.hs view

@@ -0,0 +1,108 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleInstances #-}++{- |+    Module      : Codec.LEB128.Internal.BS+    Description : Encode values via (S)LEB128 using bytestring.+    Copyright   : (c) Andreas Klebinger 2020+    License     : BSD3+    Maintainer  : Andreas Klebinger+    Portability : GHC >= 7.10++     This module specializes the generic algorithms defined+     in "Codec.LEB128.Generic" to use ByteString as byte+     sequence representation.+-}++module Codec.LEB128.Internal.BS+  ( fromULEB128+  , fromSLEB128+  , fromULEB128Unsafe+  , fromSLEB128Unsafe+  , toULEB128+  , toSLEB128+  )+where++import Data.Word (Word8)+import Data.Maybe+import GHC.Magic+import qualified Data.ByteString.Builder as B+import qualified Data.ByteString as BS++import Control.Monad.Trans.State.Strict+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Class+import Control.Monad++import Codec.LEB128.Constraints+import Codec.LEB128.Generic as G++-- | Encode a unsigned value as bytestring builder in LEB128 encoding.+{-# INLINEABLE toULEB128 #-}+toULEB128 :: LEB128 a => a -> B.Builder+toULEB128 = (inline G.encodeLEB128) (B.word8)++-- | Encode a signed value as bytestring builder in SLEB128 encoding.+{-# INLINEABLE toSLEB128 #-}+toSLEB128 :: SLEB128 a => a -> B.Builder+toSLEB128 = (inline G.encodeSLEB128) (B.word8)++type UnsafeByteProvider = State (BS.ByteString)++{-# INLINABLE getByteUnsafe #-}+getByteUnsafe :: UnsafeByteProvider Word8+getByteUnsafe = do+    (bs) <- get+    let (!byte,!bs') = fromMaybe (error "Not enough bytes") $ BS.uncons bs+    put $! bs'+    return byte++{-# INLINABLE fromULEB128Unsafe #-}+-- | Decode a value in unsigned LEB128 encoding and return remaining bytes.+fromULEB128Unsafe :: LEB128 a => BS.ByteString -> (a,BS.ByteString)+fromULEB128Unsafe bytes = runState+                    ((inline G.decodeLEB128) getByteUnsafe)+                    bytes++{-# INLINABLE fromSLEB128Unsafe #-}+-- | Decode a value in (signed) SLEB128 encoding and return remaining bytes.+fromSLEB128Unsafe :: SLEB128 a => BS.ByteString -> (a,BS.ByteString)+fromSLEB128Unsafe bytes = runState+                    ((inline G.decodeSLEB128) getByteUnsafe)+                    bytes++type ByteProvider a = MaybeT (State BS.ByteString) a++{-# INLINE runByteProvider #-}+runByteProvider :: ByteProvider a -> BS.ByteString -> (Maybe a, BS.ByteString)+runByteProvider action = runState (runMaybeT action)++{-# INLINE liftMaybe #-}+liftMaybe :: (MonadPlus m) => Maybe a -> m a+liftMaybe = maybe mzero return++{-# INLINABLE getByte #-}+getByte :: (ByteProvider Word8)+getByte = do+    (bs) <- lift get+    (!byte,!bs') <- liftMaybe (BS.uncons bs)+    lift $! put $! bs'+    return byte++{-# INLINABLE fromULEB128 #-}+-- | Decode a value in unsigned LEB128 encoding and return remaining bytes.+fromULEB128 :: forall a. LEB128 a => BS.ByteString -> (Maybe a,BS.ByteString)+fromULEB128 =+    let decode = (inline G.decodeLEB128) getByte :: MaybeT (State BS.ByteString) a+    in runByteProvider decode++{-# INLINABLE fromSLEB128 #-}+-- | Decode a value in (signed) SLEB128 encoding and return remaining bytes.+fromSLEB128 :: forall a. SLEB128 a => BS.ByteString -> (Maybe a,BS.ByteString)+fromSLEB128 =+    let decode = (inline G.decodeSLEB128) getByte :: MaybeT (State BS.ByteString) a+    in runByteProvider decode++

+ src/Codec/LEB128/List.hs view

@@ -0,0 +1,65 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE InstanceSigs #-}++{- |+    Module      : Codec.LEB128.Generic+    Description : Encode values via (S)LEB128 to/from lists.+    Copyright   : (c) Andreas Klebinger 2020+    License     : BSD3+    Maintainer  : Andreas Klebinger+    Portability : GHC >= 7.10++   The implementation is backed by the generic algorithms defined+   in "Codec.LEB128.Generic".++   The code is quite fast but does not fuse.+-}++module Codec.LEB128.List+  ( fromULEB128+  , fromSLEB128+  , toULEB128+  , toSLEB128+  )+where++import Data.Word+import GHC.Magic++import Control.Monad.Trans.State.Strict++import Codec.LEB128.Constraints+import Codec.LEB128.Generic as G++-- | Encode a __unsigned__ value in LEB128.+{-# INLINEABLE toULEB128 #-}+toULEB128 :: LEB128 a => a -> [Word8]+toULEB128 = (inline G.encodeLEB128) pure++-- | Encode a __signed__ value in LEB128.+{-# INLINEABLE toSLEB128 #-}+toSLEB128 :: SLEB128 a => a -> [Word8]+toSLEB128 = (inline G.encodeSLEB128) pure++type ByteProvider a = State [Word8] a++{-# INLINE getByte #-}+getByte :: ByteProvider Word8+getByte = do+  wds <- get+  case wds of+    [] -> error "decode LEB128: Not enough bytes"+    (x:xs) -> put xs >> return x++{-# INLINEABLE fromULEB128 #-}+-- | Decode a __unsigned__ value from LEB128 encoding.+fromULEB128 :: LEB128 a => [Word8] -> (a,[Word8])+fromULEB128 = runState ((inline G.decodeLEB128) getByte)++{-# INLINEABLE fromSLEB128 #-}+-- | Decode a __signed__ value from SLEB128 encoding.+fromSLEB128 :: SLEB128 a => [Word8] -> (a,[Word8])+fromSLEB128 = runState ((inline G.decodeSLEB128) getByte)

+ test/LEB128/Props.hs view

@@ -0,0 +1,30 @@+{-# LANGUAGE TemplateHaskell #-}
+
+module LEB128.Props
+
+where
+
+import Data.Monoid (mempty)
+import Test.Framework (defaultMain, defaultMainWithOpts, testGroup)
+import Test.Framework.Options (TestOptions, TestOptions'(..))
+import Test.Framework.Runners.Options (RunnerOptions, RunnerOptions'(..))
+import Test.Framework.Providers.QuickCheck2 (testProperty)
+
+import Test.QuickCheck
+import Test.QuickCheck.All
+
+import Codec.LEB128
+
+import Data.Int
+import Data.Word
+import Data.ByteString (ByteString)
+
+
+prop_roundtrip_bs :: Large Word -> Bool
+prop_roundtrip_bs (Large w) =
+    w == (fst (fromULEB128ByteStringUnsafe $ toULEB128ByteString w))
+
+prop_roundtrip_bs_2 :: Large Word -> Bool
+prop_roundtrip_bs_2 (Large w) =
+    toULEB128ByteString w == ((toULEB128ByteString :: Word -> ByteString) . fst . fromULEB128ByteStringUnsafe $ toULEB128ByteString w)
+

+ test/TestLEB.hs view

@@ -0,0 +1,103 @@+{-# LANGUAGE TemplateHaskell #-}
+
+module Main
+where
+
+import Data.Monoid (mempty)
+import Test.Framework (defaultMain, defaultMainWithOpts, testGroup)
+import Test.Framework.Options (TestOptions, TestOptions'(..))
+import Test.Framework.Runners.Options (RunnerOptions, RunnerOptions'(..))
+import Test.Framework.Providers.QuickCheck2 (testProperty)
+
+import Test.QuickCheck
+import Test.QuickCheck.All
+
+import Codec.LEB128.Constraints
+import Codec.LEB128.List as L
+import Codec.LEB128.Generic as G
+
+import Data.Int
+import Data.Word
+
+import LEB128.Props
+
+main = defaultMain tests
+
+mainWithOpts = do
+  -- Test options can also be specified in the code. The TestOptions
+  -- type is an instance of the Monoid type class, so the easiest way
+  -- to get an empty set of options is with `mempty`.
+  let empty_test_opts = mempty :: TestOptions
+
+  -- We update the empty TestOptions with our desired values.
+  let my_test_opts = empty_test_opts {
+    topt_maximum_generated_tests = Just 5000
+  }
+
+  -- Now we create an empty RunnerOptions in the same way, and add
+  -- our TestOptions to it.
+  let empty_runner_opts = mempty :: RunnerOptions
+  let my_runner_opts = empty_runner_opts {
+    ropt_test_options = Just my_test_opts
+  }
+
+  defaultMainWithOpts tests my_runner_opts
+
+tests = [
+        testGroup "Roundtrips" [
+                testProperty "unsigned_w32" prop_roundTripUW32,
+                testProperty "unsigned_i16" prop_roundTripUW16,
+                testProperty "signed_i32" prop_roundTripSI32,
+                testProperty "signed_i16" prop_roundTripSI16,
+                testProperty "uleb128/=leb128" (expectFailure prop_uleb_eq_leb)
+            ],
+        testGroup "ByteString"
+            [ testProperty "rountrip_1" prop_roundtrip_bs
+            , testProperty "rountrip_2" prop_roundtrip_bs_2
+            ]
+        -- testGroup "Sorting Group 2" [
+        --         testGroup "Nested Group 1" [
+        --               testProperty "sort4" prop_sort4,
+        --               testProperty "sort5" prop_sort5,
+        --               testProperty "sort6" prop_sort6
+        --             ],
+        --         testProperty "sort7" prop_sort7,
+        --         testCase "sort8" test_sort8,
+        --         testCase "sort9" test_sort9
+        --     ]
+    ]
+
+prop_roundTripUW32 :: Word32 -> Bool
+prop_roundTripUW32 w =
+  w == fst (L.fromULEB128 (L.toULEB128 w))
+
+prop_roundTripUW16 :: Word16 -> Bool
+prop_roundTripUW16 w =
+  w == fst ( L.fromULEB128 (L.toULEB128 w))
+
+prop_roundTripSI32 :: Int32 -> Bool
+prop_roundTripSI32 w =
+  w  == fst ( L.fromSLEB128 (L.toSLEB128 w))
+
+prop_roundTripSI16 :: Int16 -> Bool
+prop_roundTripSI16 w =
+  w  == fst (fromSLEB128 (toSLEB128 w))
+
+prop_roundTripBytes :: Bool
+prop_roundTripBytes =
+    let bytes = [201,202,203,1]
+    in bytes == toSLEB128 (fst . fromSLEB128 $ bytes :: Int)
+
+-- This is supposed to fail!
+prop_uleb_eq_leb :: Int16 -> Bool
+prop_uleb_eq_leb x = ((toSLEB128 $ UnsafeAnyLEB128 x) == toULEB128 (UnsafeAnyLEB128 x))
+
+
+
+
+-- --------------------------
+-- return []
+-- runTests :: IO Bool
+-- runTests = $verboseCheckAll
+
+-- main = runTests