diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for leb128 + +## 0.1.0.0 -- 2020-04-23 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -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)) + ] + + ] + diff --git a/leb128.cabal b/leb128.cabal new file mode 100644 --- /dev/null +++ b/leb128.cabal @@ -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 diff --git a/src/Codec/LEB128.hs b/src/Codec/LEB128.hs new file mode 100644 --- /dev/null +++ b/src/Codec/LEB128.hs @@ -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 diff --git a/src/Codec/LEB128/Constraints.hs b/src/Codec/LEB128/Constraints.hs new file mode 100644 --- /dev/null +++ b/src/Codec/LEB128/Constraints.hs @@ -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 + diff --git a/src/Codec/LEB128/Generic.hs b/src/Codec/LEB128/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Codec/LEB128/Generic.hs @@ -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 diff --git a/src/Codec/LEB128/Internal/BS.hs b/src/Codec/LEB128/Internal/BS.hs new file mode 100644 --- /dev/null +++ b/src/Codec/LEB128/Internal/BS.hs @@ -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 + + diff --git a/src/Codec/LEB128/List.hs b/src/Codec/LEB128/List.hs new file mode 100644 --- /dev/null +++ b/src/Codec/LEB128/List.hs @@ -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) diff --git a/test/LEB128/Props.hs b/test/LEB128/Props.hs new file mode 100644 --- /dev/null +++ b/test/LEB128/Props.hs @@ -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) + diff --git a/test/TestLEB.hs b/test/TestLEB.hs new file mode 100644 --- /dev/null +++ b/test/TestLEB.hs @@ -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