leb128-cereal (empty) → 1.0

raw patch · 6 files changed

+393/−0 lines, 6 filesdep +basedep +bytestringdep +cerealsetup-changed

Dependencies added: base, bytestring, cereal, leb128-cereal, tasty, tasty-hunit, tasty-quickcheck

Files

CHANGELOG.md +5/−0
LICENSE +20/−0
Setup.hs +2/−0
leb128-cereal.cabal +46/−0
src/Data/Serialize/LEB128.hs +239/−0
test.hs +81/−0

+ CHANGELOG.md view

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

+ LICENSE view

@@ -0,0 +1,20 @@+Copyright (c) 2020 Joachim Breitner++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

+ Setup.hs view

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

+ leb128-cereal.cabal view

@@ -0,0 +1,46 @@+cabal-version:       >=1.10+name:                leb128-cereal+version:             1.0+synopsis:            LEB128 and SLEB128 encoding+description:+   This module implements encoding and decoding of 'Natural' and 'Integer'+   values according to LEB128 and SLEB128. See+   <https://en.wikipedia.org/wiki/LEB128> for a specification.+   .+   This package uses the @cereal@ package, but also provides direct encoding and+   decoding to 'ByteString'.+bug-reports:         https://github.com/nomeata/haskell-leb128-cereal/issues+license:             MIT+license-file:        LICENSE+author:              Joachim Breitner+maintainer:          mail@joachim-breitner.de+copyright:           2020 Joachim Breitner+category:            Codec+build-type:          Simple+extra-source-files:  CHANGELOG.md+tested-with:         GHC == 8.2, GHC == 8.4, GHC == 8.6, GHC == 8.8, GHC == 8.10++library+  exposed-modules:     Data.Serialize.LEB128+  build-depends:       base >=4.10 && <5+  build-depends:       bytestring >= 0.10+  build-depends:       cereal >= 0.5+  hs-source-dirs: src+  default-language:    Haskell2010+  ghc-options:         -Wall -Wno-name-shadowing++test-suite test+  default-language: Haskell2010+  type: exitcode-stdio-1.0+  main-is: test.hs+  build-depends: base >= 4 && < 5+  build-depends: tasty >= 0.7+  build-depends: tasty-quickcheck+  build-depends: tasty-hunit+  build-depends: leb128-cereal+  build-depends: bytestring++source-repository head+  type:     git+  location: https://github.com/nomeata/haskell-leb128-cereal+

+ src/Data/Serialize/LEB128.hs view

@@ -0,0 +1,239 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-dodgy-imports #-}+{-# OPTIONS_GHC -O2 #-}+-- {-# OPTIONS_GHC -ddump-simpl -dsuppress-unfoldings -dsuppress-idinfo -dsuppress-module-prefixes -ddump-to-file #-}++-- |+-- Module      : Data.Serialize.LEB128+-- Description : LEB128 encoding+-- License     : MIT+-- Maintainer  : Joachim Breitner+--+-- | This module implements encoding and decoding of 'Natural' and 'Integer'+-- values according to LEB128 and SLEB128. See+-- https://en.wikipedia.org/wiki/LEB128 for a specification.+--+-- The module provides conversion to and from strict bytestrings.+--+-- Additionally, to integrate these into your own parsers and serializers, you+-- can use the interfaces based on 'B.Builder' as well as @cereal@'s 'G.Get'+-- and 'P.Put' monad.+--+-- The decoders will fail if the input is not in canonical representation,+-- i.e. longer than necessary.+--+-- This code is inspired by Andreas Klebinger's LEB128 implementation in GHC.+module Data.Serialize.LEB128+    (+    -- * The class of encodable and decodable types+      LEB128+    , SLEB128+    -- * Bytestring-based interface+    , toLEB128+    , fromLEB128+    , toSLEB128+    , fromSLEB128+    -- * Builder interface+    , buildLEB128+    , buildSLEB128+    -- * Cereal interface+    , getLEB128+    , getSLEB128+    , putLEB128+    , putSLEB128+    ) where++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Builder.Extra as B+import qualified Data.Serialize.Get as G+import qualified Data.Serialize.Put as P+import Numeric.Natural+import Control.Applicative+import Control.Monad+import Data.Bits+import Data.Word+import Data.Int+import Data.Maybe+import Data.Monoid ((<>))+import Prelude hiding ((<>))++-- | Unsigned number types can be LEB128-encoded+class (Bits a, Num a, Integral a) => LEB128 a where+instance LEB128 Natural+instance LEB128 Word+instance LEB128 Word8+instance LEB128 Word16+instance LEB128 Word32+instance LEB128 Word64++-- | Signed number types can be SLEB128-encoded+class (Bits a, Num a, Integral a) => SLEB128 a+instance SLEB128 Integer+instance SLEB128 Int+instance SLEB128 Int8+instance SLEB128 Int16+instance SLEB128 Int32+instance SLEB128 Int64++-- | LEB128-encodes a natural number to a strict bytestring+toLEB128 :: LEB128 a => a -> BS.ByteString+toLEB128 = BSL.toStrict . B.toLazyByteStringWith (B.safeStrategy 32 32) BSL.empty . buildLEB128++{-# SPECIALIZE toLEB128 :: Natural -> BS.ByteString #-}+{-# SPECIALIZE toLEB128 :: Word -> BS.ByteString #-}+{-# SPECIALIZE toLEB128 :: Word8 -> BS.ByteString #-}+{-# SPECIALIZE toLEB128 :: Word16 -> BS.ByteString #-}+{-# SPECIALIZE toLEB128 :: Word32 -> BS.ByteString #-}+{-# SPECIALIZE toLEB128 :: Word64 -> BS.ByteString #-}++-- | SLEB128-encodes an integer to a strict bytestring+toSLEB128 :: SLEB128 a => a -> BS.ByteString+toSLEB128 = BSL.toStrict . B.toLazyByteStringWith (B.safeStrategy 32 32) BSL.empty . buildSLEB128++{-# SPECIALIZE toSLEB128 :: Integer -> BS.ByteString #-}+{-# SPECIALIZE toSLEB128 :: Int -> BS.ByteString #-}+{-# SPECIALIZE toSLEB128 :: Int8 -> BS.ByteString #-}+{-# SPECIALIZE toSLEB128 :: Int16 -> BS.ByteString #-}+{-# SPECIALIZE toSLEB128 :: Int32 -> BS.ByteString #-}+{-# SPECIALIZE toSLEB128 :: Int64 -> BS.ByteString #-}++-- | LEB128-encodes a natural number via a builder+buildLEB128 :: LEB128 a => a -> B.Builder+buildLEB128 = go+  where+    go i+      | i <= 127+      = B.word8 (fromIntegral i :: Word8)+      | otherwise =+        -- bit 7 (8th bit) indicates more to come.+        B.word8 (setBit (fromIntegral i) 7) <> go (i `unsafeShiftR` 7)++{-# SPECIALIZE buildLEB128 :: Natural -> B.Builder #-}+{-# SPECIALIZE buildLEB128 :: Word -> B.Builder #-}+{-# SPECIALIZE buildLEB128 :: Word8 -> B.Builder #-}+{-# SPECIALIZE buildLEB128 :: Word16 -> B.Builder #-}+{-# SPECIALIZE buildLEB128 :: Word32 -> B.Builder #-}+{-# SPECIALIZE buildLEB128 :: Word64 -> B.Builder #-}++-- This gets inlined for the specialied variants+isFinite :: forall a. Bits a => Bool+isFinite = isJust (bitSizeMaybe (undefined :: a))++-- | SLEB128-encodes an integer via a builder+buildSLEB128 :: SLEB128 a => a -> B.Builder+buildSLEB128 = 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 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+        B.word8 byte' <> if done then mempty else go val'++{-# SPECIALIZE buildSLEB128 :: Integer -> B.Builder #-}+{-# SPECIALIZE buildSLEB128 :: Int -> B.Builder #-}+{-# SPECIALIZE buildSLEB128 :: Int8 -> B.Builder #-}+{-# SPECIALIZE buildSLEB128 :: Int16 -> B.Builder #-}+{-# SPECIALIZE buildSLEB128 :: Int32 -> B.Builder #-}+{-# SPECIALIZE buildSLEB128 :: Int64 -> B.Builder #-}++-- | LEB128-encodes a natural number in @cereal@'s 'P.Put' monad+putLEB128 :: LEB128 a => P.Putter a+putLEB128 = P.putBuilder . buildLEB128+{-# INLINE putLEB128 #-}++-- | SLEB128-encodes an integer in @cereal@'s 'P.Put' monad+putSLEB128 :: SLEB128 a => P.Putter a+putSLEB128 = P.putBuilder . buildSLEB128+{-# INLINE putSLEB128 #-}++-- | LEB128-decodes a natural number from a strict bytestring+fromLEB128 :: LEB128 a => BS.ByteString -> Either String a+fromLEB128 = runComplete getLEB128+{-# INLINE fromLEB128 #-}++-- | SLEB128-decodes an integer from a strict bytestring+fromSLEB128 :: SLEB128 a => BS.ByteString -> Either String a+fromSLEB128 = runComplete getSLEB128+{-# INLINE fromSLEB128 #-}++runComplete :: G.Get a -> BS.ByteString -> Either String a+runComplete p bs = do+    (x,r) <- G.runGetState p bs 0+    unless (BS.null r) $ Left "extra bytes in input"+    return x++-- | LEB128-decodes a natural number via @cereal@+getLEB128 :: forall a. LEB128 a => G.Get a+getLEB128 = G.label "LEB128" $ go 0 0+  where+    go :: Int -> a -> G.Get a+    go !shift !w = do+      byte <- G.getWord8 <|> fail "short encoding"+      let !byteVal = fromIntegral (clearBit byte 7)+      when (isFinite @a) $+        unless (byteVal `unsafeShiftL` shift `unsafeShiftR` shift == byteVal) $+          fail "overflow"+      let !val = w .|. (byteVal `unsafeShiftL` shift)+      let !shift' = shift+7+      if hasMore byte+        then go shift' val+        else do+          when (byte == 0x00 && shift > 0)+            $ fail "overlong encoding"+          return $! val++    hasMore b = testBit b 7++{-# SPECIALIZE getLEB128 :: G.Get Natural #-}+{-# SPECIALIZE getLEB128 :: G.Get Word #-}+{-# SPECIALIZE getLEB128 :: G.Get Word8 #-}+{-# SPECIALIZE getLEB128 :: G.Get Word16 #-}+{-# SPECIALIZE getLEB128 :: G.Get Word32 #-}+{-# SPECIALIZE getLEB128 :: G.Get Word64 #-}++-- | SLEB128-decodes an integer via @cereal@+getSLEB128 :: forall a. SLEB128 a => G.Get a+getSLEB128 = G.label "SLEB128" $ go 0 0 0+  where+    go :: Word8 -> Int -> a -> G.Get a+    go !prev !shift !w = do+        byte <- G.getWord8 <|> fail "short encoding"+        let !byteVal = fromIntegral (clearBit byte 7)+        when (isFinite @a) $+          unless ((byteVal `unsafeShiftL` shift `unsafeShiftR` shift) .&. 0x7f == byteVal) $+            fail "overflow"+        let !val = w .|. (byteVal `unsafeShiftL` shift)+        let !shift' = shift+7+        if hasMore byte+            then go byte shift' val+            else if signed byte+              then do+                when (byte == 0x7f && signed prev && shift > 0)+                  $ fail "overlong encoding"+                return $! val - bit shift'+              else do+                when (byte == 0x00 && not (signed prev) && shift > 0)+                  $ fail "overlong encoding"+                return $! val++    hasMore b = testBit b 7+    signed b = testBit b 6++{-# SPECIALIZE getSLEB128 :: G.Get Integer #-}+{-# SPECIALIZE getSLEB128 :: G.Get Int #-}+{-# SPECIALIZE getSLEB128 :: G.Get Int8 #-}+{-# SPECIALIZE getSLEB128 :: G.Get Int16 #-}+{-# SPECIALIZE getSLEB128 :: G.Get Int32 #-}+{-# SPECIALIZE getSLEB128 :: G.Get Int64 #-}

+ test.hs view

@@ -0,0 +1,81 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+import qualified Data.ByteString as B+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck+import Numeric.Natural+import Data.Word+import Data.Int+import Data.Bits+import Data.List+import Data.Typeable++import Data.Serialize.LEB128++newtype LargeInteger = LargeInteger Integer+    deriving (Show, Eq, Ord, Num, Bits, Real, Enum, Integral, SLEB128)+newtype LargeNatural = LargeNatural Natural+    deriving (Show, Eq, Ord, Num, Bits, Real, Enum, Integral, LEB128)++instance Arbitrary LargeNatural where+    arbitrary = LargeNatural . fromWords <$> arbitrary+      where+        fromWords :: [Word8] -> Natural+        fromWords = foldl' go 0+        go :: Natural -> Word8 -> Natural+        go acc w = (acc `shiftL` 8) + fromIntegral w++instance Arbitrary LargeInteger where+    arbitrary = do+       sign <- arbitrary+       LargeNatural n <- arbitrary+       return $ LargeInteger $ (if sign then negate else id) $ fromIntegral n++-- Only change the default (slight hack)+-- Needed to find corner cases involving non-short encodings+moreTests (QuickCheckTests 100) = QuickCheckTests 100000+moreTests (QuickCheckTests n) = QuickCheckTests n++leb128Tests :: forall a. (Typeable a, Arbitrary a, Show a, LEB128 a) => TestTree+leb128Tests = testGroup (show (typeRep (Proxy @a)))+  [ testCase "empty input" $+    fromLEB128 @a B.empty @=? Left "Failed reading: short encoding\nFrom:\tLEB128\n\n"+  , testProperty "roundtrip" $+    \i -> Right i === fromLEB128 (toLEB128 @a i)+  , testProperty "unique rep" $+    \(B.pack -> bs) -> case fromLEB128 @a bs of+      Left _ -> property ()+      Right i -> bs === toLEB128 i+  ]++sleb128Tests :: forall a. (Typeable a, Arbitrary a, Show a, SLEB128 a) => TestTree+sleb128Tests = testGroup (show (typeRep (Proxy @a)))+  [ testCase "empty input" $+    fromSLEB128 @a B.empty @=? Left "Failed reading: short encoding\nFrom:\tSLEB128\n\n"+  , testProperty "roundtrip" $+    \i -> Right i === fromSLEB128 (toSLEB128 @a i)+  , testProperty "unique rep" $+    \(B.pack -> bs) -> case fromSLEB128 @a bs of+      Left _ -> property ()+      Right i -> bs === toSLEB128 i+  ]++main = defaultMain $ adjustOption moreTests $+  testGroup "tests"+  [ leb128Tests @LargeNatural+  , leb128Tests @Word+  , leb128Tests @Word8+  , leb128Tests @Word16+  , leb128Tests @Word32+  , leb128Tests @Word64+  , sleb128Tests @LargeInteger+  , sleb128Tests @Int+  , sleb128Tests @Int8+  , sleb128Tests @Int16+  , sleb128Tests @Int32+  , sleb128Tests @Int64+  ]