858e615 · binary-bits · git.iko.soy

git.iko.soy/binary-bits

Add support for byte alignment and bit skip

commit858e615896ecca9a39327877c040e28e1922d26d authorSylvain HENRY <hsyl20@gmail.com> dateFri 6 Mar 2015, 20:40 (12 years ago) parent4c202bb

5 files changed+76−30

compare with master

unifiedsplit

BitsQC.hs+19−15 Data/Binary/Bits/Alignment.hs+22 Data/Binary/Bits/Get.hs+15−14 Data/Binary/Bits/Put.hs+17 binary-bits.cabal+3−1

BitsQC.hs+19−15

@@ -18,7 +18,6 @@ import Control.Applicative

1818import Data.Bits

1919import Data.Word

2020import Foreign.Storable

21−import System.Random

2221import Data.Traversable (traverse)

2322import Data.Foldable (traverse_)

2423

@@ -262,8 +261,8 @@ prop_fail lbs errMsg0 = forAll (choose (0, 8 * L.length lbs)) $ \len ->

262261 expectedBytesConsumed

263262 | bits == 0 = bytes

264263 | otherwise = bytes + 1

265− p = do getByteString (fromIntegral bytes)

266− getBits (fromIntegral bits) :: BitGet Word8

264+ p = do _ <- getByteString (fromIntegral bytes)

265+ _ <- getBits (fromIntegral bits) :: BitGet Word8

267266 fail errMsg0

268267 r = runGetIncremental (runBitGet p) `pushChunks` lbs

269268 in case r of

@@ -395,11 +394,6 @@ instance (Arbitrary (W a), Arbitrary (W b), Arbitrary (W c)) => Arbitrary (W (a,

395394 arbitrary = ((W .) .) . (,,) <$> arbitraryW <*> arbitraryW <*> arbitraryW

396395 shrink (W (a,b,c)) = ((W .) .) . (,,) <$> shrinkW a <*> shrinkW b <*> shrinkW c

397396

398−integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)

399−integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer,

400− fromIntegral b :: Integer) g of

401− (x,g) -> (fromIntegral x, g)

402−

403397data Primitive

404398 = Bool Bool

405399 | W8 Int Word8

@@ -408,6 +402,7 @@ data Primitive

408402 | W64 Int Word64

409403 | BS Int B.ByteString

410404 | LBS Int L.ByteString

405+ | Skip Int

411406 | IsEmpty

412407 deriving (Eq, Show)

413408

@@ -426,6 +421,7 @@ instance Arbitrary Primitive where

426421 , gen W16

427422 , gen W32

428423 , gen W64

424+ , Skip <$> choose (0, 3000)

429425 , do n <- choose (0,10)

430426 cs <- vector n

431427 return (BS n (B.pack cs))

@@ -442,6 +438,7 @@ instance Arbitrary Primitive where

442438 W16 _ x -> snk W16 x

443439 W32 _ x -> snk W32 x

444440 W64 _ x -> snk W64 x

441+ Skip x -> Skip <$> shrink x

445442 BS _ bs -> let ws = B.unpack bs in map (\ws' -> BS (length ws') (B.pack ws')) (shrink ws)

446443 LBS _ lbs -> let ws = L.unpack lbs in map (\ws' -> LBS (length ws') (L.pack ws')) (shrink ws)

447444 IsEmpty -> []

@@ -478,6 +475,7 @@ putPrimitive p =

478475 W16 n x -> putWord16 n x

479476 W32 n x -> putWord32 n x

480477 W64 n x -> putWord64 n x

478+ Skip n -> skipBits n

481479 BS _ bs -> putByteString bs

482480 LBS _ lbs -> mapM_ putByteString (L.toChunks lbs)

483481 IsEmpty -> return ()

@@ -490,10 +488,22 @@ getPrimitive p =

490488 W16 n _ -> W16 n <$> getWord16 n

491489 W32 n _ -> W32 n <$> getWord32 n

492490 W64 n _ -> W64 n <$> getWord64 n

491+ Skip n -> skipBits n >> return (Skip n)

493492 BS n _ -> BS n <$> getByteString n

494493 LBS n _ -> LBS n <$> getLazyByteString n

495494 IsEmpty -> isEmpty >> return IsEmpty

496495

496+getPrimitiveSize :: Primitive -> Int

497+getPrimitiveSize p = case p of

498+ Bool _ -> 1

499+ W8 n _ -> n

500+ W16 n _ -> n

501+ W32 n _ -> n

502+ W64 n _ -> n

503+ Skip n -> n

504+ BS n _ -> n*8

505+ LBS n _ -> n*8

506+ IsEmpty -> 0

497507

498508verifyProgram :: Int -> Program -> BitGet Bool

499509verifyProgram totalLength ps0 = go 0 ps0

@@ -501,13 +511,6 @@ verifyProgram totalLength ps0 = go 0 ps0

501511 go _ [] = return True

502512 go pos (p:ps) =

503513 case p of

504− Bool x -> check x getBool >> go (pos+1) ps

505− W8 n x -> check x (getWord8 n) >> go (pos+n) ps

506− W16 n x -> check x (getWord16 n) >> go (pos+n) ps

507− W32 n x -> check x (getWord32 n) >> go (pos+n) ps

508− W64 n x -> check x (getWord64 n) >> go (pos+n) ps

509− BS n x -> check x (getByteString n) >> go (pos+(8*n)) ps

510− LBS n x -> check x (getLazyByteString n) >> go (pos+(8*n)) ps

511514 IsEmpty -> do

512515 let expected = pos == totalLength

513516 actual <- isEmpty

@@ -515,6 +518,7 @@ verifyProgram totalLength ps0 = go 0 ps0

515518 then go pos ps

516519 else error $ "isEmpty returned wrong value, expected "

517520 ++ show expected ++ " but got " ++ show actual

521+ _ -> check p (getPrimitive p) >> go (pos + getPrimitiveSize p) ps

518522 check x g = do

519523 y <- g

520524 if x == y

Data/Binary/Bits/Alignment.hsnew file+22

@@ -0,0 +1,22 @@

1+-----------------------------------------------------------------------------

2+-- |

3+-- Module : Data.Binary.Bits.Get

4+-- Copyright : (c) Lennart Kolmodin 2010-2011

5+-- (c) Sylvain Henry 2015

6+-- License : BSD3-style (see LICENSE)

7+--

8+-- Maintainer : kolmodin@gmail.com

9+-- Stability : experimental

10+-- Portability : portable (should run where the package binary runs)

11+

12+module Data.Binary.Bits.Alignment

13+ ( Alignable(..)

14+ )

15+where

16+

17+class Monad m => Alignable m where

18+ -- | Skip the given number of bits

19+ skipBits :: Int -> m ()

20+

21+ -- | Skip bits if necessary to align to the next byte

22+ alignByte :: m ()

Data/Binary/Bits/Get.hs+15−14

@@ -98,6 +98,7 @@ import Data.Binary.Get as B ( Get, getLazyByteString, isEmpty )

9898import Data.Binary.Get.Internal as B ( get, put, ensureN )

9999import Data.Binary.Bits.BitOrder

100100import Data.Binary.Bits.Internal

101+import Data.Binary.Bits.Alignment

101102

102103import Data.ByteString as B

103104import qualified Data.ByteString.Lazy as L

@@ -291,6 +292,20 @@ instance BitOrderable BitGet where

291292 (S _ _ bo) <- getState

292293 return bo

293294

295+instance Alignable BitGet where

296+ -- | Skip the given number of bits

297+ skipBits n = do

298+ ensureBits n

299+ withState (incS n)

300+

301+ -- | Skip bits if necessary to align to the next byte

302+ alignByte = do

303+ (S _ o _) <- getState

304+ when (o /= 0) $

305+ skipBits (8-o)

306+

307+

308+

294309-- | Run a 'BitGet' within the Binary packages 'Get' monad. If a byte has

295310-- been partially consumed it will be discarded once 'runBitGet' is finished.

296311runBitGet :: BitGet a -> Get a

@@ -338,20 +353,6 @@ ensureBits n = do

338353 put B.empty

339354 return (S (bs`append`bs') o bo, ())

340355

341−-- | Skip the given number of bits

342−skipBits :: Int -> BitGet ()

343−skipBits n = do

344− ensureBits n

345− withState (incS n)

346−

347−-- | Skip bits if necessary to align to the next byte

348−alignByte :: BitGet ()

349−alignByte = do

350− (S _ o _) <- getState

351− when (o /= 0) $

352− skipBits (8-o)

353−

354−

355356-- | Test whether all input has been consumed, i.e. there are no remaining

356357-- undecoded bytes.

357358isEmpty :: BitGet Bool

Data/Binary/Bits/Put.hs+17

@@ -41,11 +41,13 @@ import qualified Data.Binary.Put as Put

4141import Data.Binary.Put ( Put )

4242import Data.Binary.Bits.Internal

4343import Data.Binary.Bits.BitOrder

44+import Data.Binary.Bits.Alignment

4445

4546import Data.ByteString as BS

4647import Data.ByteString.Unsafe as BS

4748

4849import Control.Applicative

50+import Control.Monad (when)

4951import Data.Bits

5052import Data.Monoid

5153import Data.Word

@@ -178,6 +180,9 @@ flushIncomplete s@(S b w o bo)

178180 | o == 0 = s

179181 | otherwise = (S (b `mappend` B.singleton w) 0 0 bo)

180182

183+getOffset :: BitPut Int

184+getOffset = BitPut $ \s@(S _ _ o _) -> PairS o s

185+

181186-- | Run the 'BitPut' monad inside 'Put'.

182187runBitPut :: BitPut () -> Put.Put

183188runBitPut m = Put.putBuilder b

@@ -208,3 +213,15 @@ instance BitOrderable BitPut where

208213 setBitOrder bo = BitPut $ \(S bu b o _) -> PairS () (S bu b o bo)

209214

210215 getBitOrder = BitPut $ \s@(S _ _ _ bo) -> PairS bo s

216+

217+instance Alignable BitPut where

218+ -- | Skip the given number of bits

219+ skipBits n

220+ | n <= 64 = putWord64 n 0

221+ | otherwise = putWord64 64 0 >> skipBits (n-64)

222+

223+ -- | Skip bits if necessary to align to the next byte

224+ alignByte = do

225+ o <- getOffset

226+ when (o /= 0) $

227+ skipBits (8-o)

binary-bits.cabal+3−1

@@ -25,7 +25,8 @@ library

2525 exposed-modules: Data.Binary.Bits ,

2626 Data.Binary.Bits.Put ,

2727 Data.Binary.Bits.Get ,

28− Data.Binary.Bits.BitOrder

28+ Data.Binary.Bits.BitOrder ,

29+ Data.Binary.Bits.Alignment

2930 other-modules: Data.Binary.Bits.Internal

3031

3132 default-language: Haskell98

@@ -36,6 +37,7 @@ test-suite qc

3637 type: exitcode-stdio-1.0

3738 main-is: BitsQC.hs

3839 default-language: Haskell98

40+ --ghc-options: -O2 -Wall

3941

4042 build-depends: base==4.*, binary >= 0.6.0.0, bytestring,

4143 QuickCheck>=2, random,