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

git.iko.soy/binary-bits

on master help sign in

Add support for byte alignment and bit skip

858e615Sylvain HENRY12 years ago

BitsQC.hs+19−15

compare with master

unifiedsplit

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

18import Data.Bits

19import Data.Word

20import Foreign.Storable

21−import System.Random

22import Data.Traversable (traverse)

21import Data.Traversable (traverse)

23import Data.Foldable (traverse_)

22import Data.Foldable (traverse_)

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

262 expectedBytesConsumed

261 expectedBytesConsumed

263 | bits == 0 = bytes

262 | bits == 0 = bytes

264 | otherwise = bytes + 1

263 | otherwise = bytes + 1

265− p = do getByteString (fromIntegral bytes)

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

266− getBits (fromIntegral bits) :: BitGet Word8

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

267 fail errMsg0

266 fail errMsg0

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

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

269 in case r of

268 in case r of

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

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

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

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

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

397

396

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−

403data Primitive

397data Primitive

404 = Bool Bool

398 = Bool Bool

405 | W8 Int Word8

399 | W8 Int Word8

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

408 | W64 Int Word64

402 | W64 Int Word64

409 | BS Int B.ByteString

403 | BS Int B.ByteString

410 | LBS Int L.ByteString

404 | LBS Int L.ByteString

405+ | Skip Int

411 | IsEmpty

406 | IsEmpty

412 deriving (Eq, Show)

407 deriving (Eq, Show)

413

408

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

426 , gen W16

421 , gen W16

427 , gen W32

422 , gen W32

428 , gen W64

423 , gen W64

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

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

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

430 cs <- vector n

426 cs <- vector n

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

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

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

442 W16 _ x -> snk W16 x

438 W16 _ x -> snk W16 x

443 W32 _ x -> snk W32 x

439 W32 _ x -> snk W32 x

444 W64 _ x -> snk W64 x

440 W64 _ x -> snk W64 x

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

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

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

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

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

447 IsEmpty -> []

444 IsEmpty -> []

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

478 W16 n x -> putWord16 n x

475 W16 n x -> putWord16 n x

479 W32 n x -> putWord32 n x

476 W32 n x -> putWord32 n x

480 W64 n x -> putWord64 n x

477 W64 n x -> putWord64 n x

478+ Skip n -> skipBits n

481 BS _ bs -> putByteString bs

479 BS _ bs -> putByteString bs

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

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

483 IsEmpty -> return ()

481 IsEmpty -> return ()

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

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

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

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

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

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

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

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

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

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

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

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

495 IsEmpty -> isEmpty >> return IsEmpty

494 IsEmpty -> isEmpty >> return IsEmpty

496

495

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

497

507

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

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

499verifyProgram totalLength ps0 = go 0 ps0

509verifyProgram totalLength ps0 = go 0 ps0

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

501 go _ [] = return True

511 go _ [] = return True

502 go pos (p:ps) =

512 go pos (p:ps) =

503 case p of

513 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

511 IsEmpty -> do

514 IsEmpty -> do

512 let expected = pos == totalLength

515 let expected = pos == totalLength

513 actual <- isEmpty

516 actual <- isEmpty

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

515 then go pos ps

518 then go pos ps

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

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

517 ++ show expected ++ " but got " ++ show actual

520 ++ show expected ++ " but got " ++ show actual

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

518 check x g = do

522 check x g = do

519 y <- g

523 y <- g

520 if x == y

524 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 )

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

99import Data.Binary.Bits.BitOrder

100import Data.Binary.Bits.Internal

101+import Data.Binary.Bits.Alignment

101

102

102import Data.ByteString as B

103import Data.ByteString as B

103import qualified Data.ByteString.Lazy as L

104import qualified Data.ByteString.Lazy as L

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

291 (S _ _ bo) <- getState

292 (S _ _ bo) <- getState

292 return bo

293 return bo

293

294

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+

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

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

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

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

296runBitGet :: BitGet a -> Get a

311runBitGet :: BitGet a -> Get a

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

338 put B.empty

353 put B.empty

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

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

340

355

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−

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

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

356-- undecoded bytes.

357-- undecoded bytes.

357isEmpty :: BitGet Bool

358isEmpty :: BitGet Bool

Data/Binary/Bits/Put.hs+17

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

41import Data.Binary.Put ( Put )

42import Data.Binary.Bits.Internal

43import Data.Binary.Bits.BitOrder

44+import Data.Binary.Bits.Alignment

45import Data.ByteString as BS

46import Data.ByteString as BS

46import Data.ByteString.Unsafe as BS

47import Data.ByteString.Unsafe as BS

48import Control.Applicative

49import Control.Applicative

50+import Control.Monad (when)

49import Data.Bits

51import Data.Bits

50import Data.Monoid

52import Data.Monoid

51import Data.Word

53import Data.Word

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

178 | o == 0 = s

180 | o == 0 = s

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

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

180

182

183+getOffset :: BitPut Int

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

185+

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

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

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

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

183runBitPut m = Put.putBuilder b

188runBitPut m = Put.putBuilder b

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

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

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

209

214

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

215 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

25 exposed-modules: Data.Binary.Bits ,

26 Data.Binary.Bits.Put ,

27 Data.Binary.Bits.Get ,

28− Data.Binary.Bits.BitOrder

28+ Data.Binary.Bits.BitOrder ,

29+ Data.Binary.Bits.Alignment

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

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

31 default-language: Haskell98

32 default-language: Haskell98

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

36 type: exitcode-stdio-1.0

37 type: exitcode-stdio-1.0

37 main-is: BitsQC.hs

38 main-is: BitsQC.hs

38 default-language: Haskell98

39 default-language: Haskell98

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

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

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

41 QuickCheck>=2, random,

43 QuickCheck>=2, random,