bf5c487...master · binary-bits

git.iko.soy/binary-bits

13 files changed+505−128

since splitsnapshots

unifiedsplit

.gitignore+1 BitsQC.hs+69−36 Data/Binary/Bits.hs+3−3 Data/Binary/Bits/Alignment.hs+22 Data/Binary/Bits/BitOrder.hs+20−2 Data/Binary/Bits/Get.hs+63−57 Data/Binary/Bits/Internal.hs+27−6 Data/Binary/Bits/Put.hs+135−22 binary-bits.cabal+4−2 flake.lock+59 flake.nix+24 stack.yaml+66 stack.yaml.lock+12

.gitignore+1

@@ -1,3 +1,4 @@

11.cabal-sandbox

22cabal.sandbox.config

33dist/

4+.stack-work

BitsQC.hs+69−36

@@ -9,6 +9,7 @@ import Data.Binary.Put ( runPut )

99import Data.Binary.Bits

1010import Data.Binary.Bits.Get

1111import Data.Binary.Bits.Put

12+import Data.Binary.Bits.BitOrder

1213

1314import qualified Data.ByteString as B

1415import qualified Data.ByteString.Lazy as L

@@ -17,7 +18,8 @@ import Control.Applicative

1718import Data.Bits

1819import Data.Word

1920import Foreign.Storable

20−import System.Random

21+import Data.Traversable (traverse)

22+import Data.Foldable (traverse_)

2123

2224import Test.Framework.Providers.QuickCheck2 ( testProperty )

2325import Test.Framework.Runners.Console ( defaultMain )

@@ -36,7 +38,10 @@ tests =

3638 [ testProperty "prop_composite_case" prop_composite_case ]

3739

3840 , testGroup "getByteString"

39− [ testProperty "prop_getByteString_negative" prop_getByteString_negative ]

41+ [ testProperty "prop_getByteString_negative" prop_getByteString_negative

42+ , testProperty "prop_putByteString_getByteString" (prop_putByteString_getByteString :: BitOrder -> B.ByteString -> Property)

43+ , testProperty "prop_putByteString_getByteString_many" (prop_putByteString_getByteString_many :: BitOrder -> [B.ByteString] -> Property)

44+ ]

4045

4146 , testGroup "getLazyByteString"

4247 [ testProperty "getLazyByteString == getByteString"

@@ -84,10 +89,10 @@ tests =

8489 ]

8590

8691 , testGroup "prop_put_with_bitreq"

87− [ testProperty "Word8" (prop_putget_with_bitreq :: W Word8 -> Property)

88− , testProperty "Word16" (prop_putget_with_bitreq :: W Word16 -> Property)

89− , testProperty "Word32" (prop_putget_with_bitreq :: W Word32 -> Property)

90− , testProperty "Word64" (prop_putget_with_bitreq :: W Word64 -> Property)

92+ [ testProperty "Word8" (prop_putget_with_bitreq :: BitOrder -> W Word8 -> Property)

93+ , testProperty "Word16" (prop_putget_with_bitreq :: BitOrder -> W Word16 -> Property)

94+ , testProperty "Word32" (prop_putget_with_bitreq :: BitOrder -> W Word32 -> Property)

95+ , testProperty "Word64" (prop_putget_with_bitreq :: BitOrder -> W Word64 -> Property)

9196 ]

9297

9398 , testGroup "prop_putget_list_simple"

@@ -112,10 +117,10 @@ tests =

112117 , testProperty "Word64" (prop_putget_list_with_bitreq :: W [Word64] -> Property)

113118 ]

114119 , testGroup "prop_bitget_bytestring_interspersed"

115− [ testProperty "Word8" (prop_bitget_bytestring_interspersed :: W Word8 -> [B.ByteString] -> Property)

116− , testProperty "Word16" (prop_bitget_bytestring_interspersed :: W Word16 -> [B.ByteString] -> Property)

117− , testProperty "Word32" (prop_bitget_bytestring_interspersed :: W Word32 -> [B.ByteString] -> Property)

118− , testProperty "Word64" (prop_bitget_bytestring_interspersed :: W Word64 -> [B.ByteString] -> Property)

120+ [ testProperty "Word8" (prop_bitget_bytestring_interspersed :: BitOrder -> W Word8 -> [B.ByteString] -> Property)

121+ , testProperty "Word16" (prop_bitget_bytestring_interspersed :: BitOrder -> W Word16 -> [B.ByteString] -> Property)

122+ , testProperty "Word32" (prop_bitget_bytestring_interspersed :: BitOrder -> W Word32 -> [B.ByteString] -> Property)

123+ , testProperty "Word64" (prop_bitget_bytestring_interspersed :: BitOrder -> W Word64 -> [B.ByteString] -> Property)

119124 ]

120125 , testGroup "Simulate programs"

121126 [ testProperty "primitive" prop_primitive

@@ -158,13 +163,28 @@ prop_getByteString_negative n =

158163 n < 1 ==>

159164 runGet (runBitGet (getByteString n)) L.empty == B.empty

160165

161−prop_putget_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => W a -> Property

162−prop_putget_with_bitreq (W w) = property $

166+prop_putByteString_getByteString :: BitOrder -> B.ByteString -> Property

167+prop_putByteString_getByteString bo bs = property $ bs' == bs

168+ where

169+ n = B.length bs

170+ w = runPut (runBitPut (withBitOrder bo (putByteString bs)))

171+ bs' = runGet (runBitGet (withBitOrder bo (getByteString n))) w

172+

173+prop_putByteString_getByteString_many :: BitOrder -> [B.ByteString] -> Property

174+prop_putByteString_getByteString_many bo bs = property $ bs' == bs

175+ where

176+ n = fmap B.length bs

177+ w = runPut (runBitPut (withBitOrder bo (traverse_ putByteString bs)))

178+ bs' = runGet (runBitGet (withBitOrder bo (traverse getByteString n))) w

179+

180+

181+prop_putget_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => BitOrder -> W a -> Property

182+prop_putget_with_bitreq bo (W w) = property $

163183 -- write all words with as many bits as it's required

164184 let p = putBits (bitreq w) w

165185 g = getBits (bitreq w)

166− lbs = runPut (runBitPut p)

167− w' = runGet (runBitGet g) lbs

186+ lbs = runPut (runBitPut (withBitOrder bo p))

187+ w' = runGet (runBitGet (withBitOrder bo g)) lbs

168188 in w == w'

169189

170190-- | Write a list of items. Each item is written with the maximum amount of

@@ -226,12 +246,12 @@ prop_bitget_with_put_from_binary (W ws) = property $

226246 in ws == ws'

227247

228248-- | Write each 'ByteString' with a variable sized value as a separator.

229−prop_bitget_bytestring_interspersed :: (BinaryBit a, Binary a, Num a, Ord a, Bits a) => W a -> [B.ByteString] -> Property

230−prop_bitget_bytestring_interspersed (W ws) bss = property $

249+prop_bitget_bytestring_interspersed :: (BinaryBit a, Binary a, Num a, Ord a, Bits a) => BitOrder -> W a -> [B.ByteString] -> Property

250+prop_bitget_bytestring_interspersed bo (W ws) bss = property $

231251 let p = mapM_ (\bs -> putBits (bitreq ws) ws >> putByteString bs) bss

232252 g = mapM (\bs -> (,) <$> getBits (bitreq ws) <*> getByteString (B.length bs)) bss

233− lbs = runPut (runBitPut p)

234− r = runGet (runBitGet g) lbs

253+ lbs = runPut (runBitPut (withBitOrder bo p))

254+ r = runGet (runBitGet (withBitOrder bo g)) lbs

235255 in map (ws,) bss == r

236256

237257-- | Test failing.

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

241261 expectedBytesConsumed

242262 | bits == 0 = bytes

243263 | otherwise = bytes + 1

244− p = do getByteString (fromIntegral bytes)

245− getBits (fromIntegral bits) :: BitGet Word8

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

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

246266 fail errMsg0

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

248268 in case r of

@@ -268,7 +288,7 @@ prop_bitreq (W w) = property $

268288prop_composite_case :: Bool -> W Word16 -> Property

269289prop_composite_case b (W w) = w < 0x8000 ==>

270290 let p = do putBool b

271− putWord16be 15 w

291+ putWord16 15 w

272292 g = do v <- getBool

273293 case v of

274294 True -> getWord16 15

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

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

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

376396

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

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

379− fromIntegral b :: Integer) g of

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

381−

382397data Primitive

383398 = Bool Bool

384399 | W8 Int Word8

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

387402 | W64 Int Word64

388403 | BS Int B.ByteString

389404 | LBS Int L.ByteString

405+ | Skip Int

390406 | IsEmpty

391407 deriving (Eq, Show)

392408

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

405421 , gen W16

406422 , gen W32

407423 , gen W64

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

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

409426 cs <- vector n

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

@@ -421,10 +438,19 @@ instance Arbitrary Primitive where

421438 W16 _ x -> snk W16 x

422439 W32 _ x -> snk W32 x

423440 W64 _ x -> snk W64 x

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

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

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

426444 IsEmpty -> []

427445

446+instance Arbitrary BitOrder where

447+ arbitrary = elements [BB, LB, LL, BL]

448+ shrink LL = [BB,LB,BL]

449+ shrink BL = [BB,LB]

450+ shrink LB = [BB]

451+ shrink BB = []

452+

453+

428454prop_primitive :: Primitive -> Property

429455prop_primitive prim = property $

430456 let p = putPrimitive prim

@@ -446,9 +472,10 @@ putPrimitive p =

446472 case p of

447473 Bool b -> putBool b

448474 W8 n x -> putWord8 n x

449− W16 n x -> putWord16be n x

450− W32 n x -> putWord32be n x

451− W64 n x -> putWord64be n x

475+ W16 n x -> putWord16 n x

476+ W32 n x -> putWord32 n x

477+ W64 n x -> putWord64 n x

478+ Skip n -> skipBits n

452479 BS _ bs -> putByteString bs

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

454481 IsEmpty -> return ()

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

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

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

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

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

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

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

466494 IsEmpty -> isEmpty >> return IsEmpty

467495

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

468507

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

470509verifyProgram totalLength ps0 = go 0 ps0

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

472511 go _ [] = return True

473512 go pos (p:ps) =

474513 case p of

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

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

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

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

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

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

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

482514 IsEmpty -> do

483515 let expected = pos == totalLength

484516 actual <- isEmpty

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

486518 then go pos ps

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

488520 ++ show expected ++ " but got " ++ show actual

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

489522 check x g = do

490523 y <- g

491524 if x == y

Data/Binary/Bits.hs+3−3

@@ -33,13 +33,13 @@ instance BinaryBit Word8 where

3333 getBits = getWord8

3434

3535instance BinaryBit Word16 where

36− putBits = putWord16be

36+ putBits = putWord16

3737 getBits = getWord16

3838

3939instance BinaryBit Word32 where

40− putBits = putWord32be

40+ putBits = putWord32

4141 getBits = getWord32

4242

4343instance BinaryBit Word64 where

44− putBits = putWord64be

44+ putBits = putWord64

4545 getBits = getWord64

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/BitOrder.hs+20−2

@@ -11,6 +11,7 @@

1111

1212module Data.Binary.Bits.BitOrder

1313 ( BitOrder(..)

14+ , BitOrderable(..)

1415 )

1516where

1617

@@ -18,12 +19,29 @@ where

1819--

1920-- E.g. two words of 5 bits: ABCDE, VWXYZ

2021-- - BB: ABCDEVWX YZxxxxxx

21−-- - LB: XYZABCDE xxxxxxVW

22+-- - LL: XYZABCDE xxxxxxVW

2223-- - BL: EDCBAZYX WVxxxxxx

23−-- - LL: XWVEDCBA xxxxxxZY

24+-- - LB: XWVEDCBA xxxxxxZY

2425data BitOrder

2526 = BB -- ^ Big-endian bytes and bits

2627 | LB -- ^ Little-endian bytes, big-endian bits

2728 | BL -- ^ Big-endian bytes, little-endian bits

2829 | LL -- ^ Little-endian bytes and bits

2930 deriving (Show)

31+

32+

33+class Monad m => BitOrderable m where

34+ -- | Set the current bit-order

35+ setBitOrder :: BitOrder -> m ()

36+

37+ -- | Retrieve the current bit-order

38+ getBitOrder :: m BitOrder

39+

40+ -- | Perform the given action with the given bit-order

41+ withBitOrder :: BitOrder -> m a -> m a

42+ withBitOrder bo act = do

43+ bo' <- getBitOrder

44+ setBitOrder bo

45+ r <- act

46+ setBitOrder bo'

47+ return r

Data/Binary/Bits/Get.hs+63−57

@@ -57,12 +57,10 @@ module Data.Binary.Bits.Get

5757

5858 BitGet

5959 , runBitGet

60− , getBitOrder

61− , selectBitOrder

62− , withBitOrder

6360

6461 -- ** Get bytes

6562 , getBool

63+ , getBool#

6664 , getWord8

6765 , getWord16

6866 , getWord32

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

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

102100import Data.Binary.Bits.BitOrder

103101import Data.Binary.Bits.Internal

102+import Data.Binary.Bits.Alignment

104103

105104import Data.ByteString as B

106105import qualified Data.ByteString.Lazy as L

@@ -116,6 +115,8 @@ import Control.Applicative

116115import Control.Monad (when,foldM_)

117116

118117import Prelude as P

118+import GHC.Word

119+import GHC.Base (uncheckedShiftLWord8#, wordToWord8#, Int (..), andWord8#, Word8#, (-#), Int#, xorI#, eqWord8#, TYPE)

119120

120121-- $bitget

121122-- Parse bits using a monad.

@@ -176,17 +177,25 @@ incS o (S bs n bo) = S (unsafeDrop d bs) n' bo

176177 !d = byte_offset o'

177178 !n' = bit_offset o'

178179

179−-- | Select the bit ordering

180−selectBitOrderS :: BitOrder -> S -> S

181−selectBitOrderS bo (S bs o _) = S bs o bo

182−

183180-- | Read a single bit

184181readBool :: S -> Bool

185182readBool (S bs o bo) = case bo of

186183 BB -> testBit (unsafeHead bs) (7-o)

187184 BL -> testBit (unsafeHead bs) (7-o)

188− LB -> testBit (unsafeHead bs) o

189185 LL -> testBit (unsafeHead bs) o

186+ LB -> testBit (unsafeHead bs) o

187+

188+-- | Read a single bit

189+readBool# :: S -> Int

190+readBool# (S bs (I# o) bo) = case bo of

191+ BB -> testBit# (7# -# o)

192+ BL -> testBit# (7# -# o)

193+ LL -> testBit# o

194+ LB -> testBit# o

195+ where

196+ !(W8# w) = unsafeHead bs

197+ testBit# n = I# (((w `andWord8#` (wordToWord8# 1## `uncheckedShiftLWord8#` n)) `eqWord8#` wordToWord8# 0##) `xorI#` 1#)

198+

190199

191200-- | Extract a range of bits from (ws :: ByteString)

192201--

@@ -209,17 +218,17 @@ extract bo bs o n

209218

210219 -- shift offset depending on the byte position (0..B.length-1)

211220 off i = case bo of

212− LB -> 8*i - o

213221 LL -> 8*i - o

222+ LB -> 8*i - o

214223 BB -> (B.length bs -1 - i) * 8 - r

215224 BL -> (B.length bs -1 - i) * 8 - r

216225

217226 -- reverse bits if necessary

218227 rev = case bo of

219− LL -> reverseBits n

228+ LB -> reverseBits n

220229 BL -> reverseBits n

221230 BB -> id

222− LB -> id

231+ LL -> id

223232

224233

225234-- | Generic readWord

@@ -240,22 +249,23 @@ readWordChecked m n s

240249--

241250-- Examples:

242251-- BB: xxxABCDE FGHIJKLM NOPxxxxx -> ABCDEFGH IJKLMNOP

243−-- LB: LMNOPxxx DEFGHIJK xxxxxABC -> ABCDEFGH IJKLMNOP

252+-- LL: LMNOPxxx DEFGHIJK xxxxxABC -> ABCDEFGH IJKLMNOP

244253-- BL: xxxPONML KJIHGFED CBAxxxxx -> ABCDEFGH IJKLMNOP

245−-- LL: EDCBAxxx MLKJIHGF xxxxxPON -> ABCDEFGH IJKLMNOP

254+-- LB: EDCBAxxx MLKJIHGF xxxxxPON -> ABCDEFGH IJKLMNOP

246255readByteString :: Int -> S -> ByteString

247256readByteString n (S bs o bo) =

248257 let

249− bs' = unsafeTake (n+1) bs

250− rev = B.map (reverseBits 8)

258+ bs' = unsafeTake (n+1) bs

259+ bs'' = unsafeTake n bs

260+ rev = B.map (reverseBits 8)

251261 in case (o,bo) of

252− (0,BB) -> unsafeTake n bs

253− (0,LB) -> B.reverse (unsafeTake n bs)

254− (0,BL) -> rev (unsafeTake n bs)

255− (0,LL) -> rev (B.reverse (unsafeTake n bs))

256− (_,BL) -> rev (readByteString n (S (B.reverse bs') o LB))

257− (_,LL) -> rev (readByteString n (S (B.reverse bs') o BB))

258− (_,LB) -> readByteString n (S (B.reverse bs') o BB)

262+ (0,BB) -> bs''

263+ (0,LL) -> B.reverse bs''

264+ (0,LB) -> rev bs''

265+ (0,BL) -> rev . B.reverse $ bs''

266+ (_,LL) -> readByteString n (S (B.reverse bs') (8-o) BB)

267+ (_,BL) -> rev . B.reverse $ readByteString n (S bs' o BB)

268+ (_,LB) -> rev . B.reverse $ readByteString n (S bs' o LL)

259269 (_,BB) -> unsafePerformIO $ do

260270 let len = n+1

261271 ptr <- mallocBytes len

@@ -277,7 +287,6 @@ newtype BitGet a = B { runState :: S -> Get (S,a) }

277287

278288instance Monad BitGet where

279289 return x = B $ \s -> return (s,x)

280− fail str = B $ \s -> putBackState s >> fail str

281290 (B f) >>= g = B $ \s -> do (s',a) <- f s

282291 runState (g a) s'

283292

@@ -288,6 +297,29 @@ instance Applicative BitGet where

288297 pure x = return x

289298 fm <*> m = fm >>= \f -> m >>= \v -> return (f v)

290299

300+instance BitOrderable BitGet where

301+ setBitOrder bo = do

302+ (S bs o _) <- getState

303+ putState (S bs o bo)

304+

305+ getBitOrder = do

306+ (S _ _ bo) <- getState

307+ return bo

308+

309+instance Alignable BitGet where

310+ -- | Skip the given number of bits

311+ skipBits n = do

312+ ensureBits n

313+ withState (incS n)

314+

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

316+ alignByte = do

317+ (S _ o _) <- getState

318+ when (o /= 0) $

319+ skipBits (8-o)

320+

321+

322+

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

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

293325runBitGet :: BitGet a -> Get a

@@ -322,13 +354,6 @@ withState f = do

322354 s <- getState

323355 putState $! f s

324356

325−-- | Get the bit ordering

326−getBitOrder :: BitGet BitOrder

327−getBitOrder = do

328− (S _ _ bo) <- getState

329− return bo

330−

331−

332357-- | Make sure there are at least @n@ bits.

333358ensureBits :: Int -> BitGet ()

334359ensureBits n = do

@@ -342,33 +367,6 @@ ensureBits n = do

342367 put B.empty

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

344369

345−-- | Skip the given number of bits

346−skipBits :: Int -> BitGet ()

347−skipBits n = do

348− ensureBits n

349− withState (incS n)

350−

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

352−alignByte :: BitGet ()

353−alignByte = do

354− (S _ o _) <- getState

355− when (o /= 0) $

356− skipBits (8-o)

357−

358−-- | Select the bit ordering

359−selectBitOrder :: BitOrder -> BitGet ()

360−selectBitOrder = withState . selectBitOrderS

361−

362−withBitOrder :: BitOrder -> BitGet a -> BitGet a

363−withBitOrder bo f = do

364− bo' <- getBitOrder

365− selectBitOrder bo

366− r <- f

367− selectBitOrder bo'

368− return r

369−

370−

371−

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

373371-- undecoded bytes.

374372isEmpty :: BitGet Bool

@@ -380,6 +378,10 @@ isEmpty = B $ \ (S bs o bo) -> if B.null bs

380378getBool :: BitGet Bool

381379getBool = block bool

382380

381+-- | Get 1 bit as a 'Bool'.

382+getBool# :: BitGet Int

383+getBool# = block bool#

384+

383385-- | Get @n@ bits as a 'Word8'. @n@ must be within @[0..8]@.

384386getWord8 :: Int -> BitGet Word8

385387getWord8 n = block (word8 n)

@@ -455,6 +457,10 @@ block (Block i p) = do

455457bool :: Block Bool

456458bool = Block 1 readBool

457459

460+-- | Read a 1 bit 'Bool'.

461+bool# :: Block Int

462+bool# = Block 1 readBool#

463+

458464-- | Read @n@ bits as a 'Word8'. @n@ must be within @[0..8]@.

459465word8 :: Int -> Block Word8

460466word8 n = Block n (readWordChecked 8 n)

Data/Binary/Bits/Internal.hs+27−6

@@ -12,10 +12,13 @@

1212

1313module Data.Binary.Bits.Internal

1414 ( make_mask

15+ , make_mask#

1516 , mask

17+ , mask#

1618 , bit_offset

1719 , byte_offset

1820 , reverseBits

21+ , reverseBits#

1922 , FastBits(..)

2023 )

2124where

@@ -38,11 +41,18 @@ make_mask n = (1 `shiftL` fromIntegral n) - 1

3841{-# SPECIALIZE make_mask :: Int -> Word32 #-}

3942{-# SPECIALIZE make_mask :: Int -> Word64 #-}

4043

44+make_mask# :: Int# -> Word#

45+make_mask# n = (1## `shiftL#` n) `minusWord#` 1##

46+

4147-- | Keep only the n least-significant bits of the given value

4248mask :: (Bits a, Num a) => Int -> a -> a

4349mask n v = v .&. make_mask n

4450{-# INLINE mask #-}

4551

52+-- | Keep only the n least-significant bits of the given value

53+mask# :: Int# -> Word# -> Word#

54+mask# n v = v `and#` make_mask# n

55+

4656-- | Compute bit offset (equivalent to x `mod` 8 but faster)

4757bit_offset :: Int -> Int

4858bit_offset n = make_mask 3 .&. n

@@ -65,6 +75,17 @@ reverseBits n value = rec value n 0

6575 rec 0 i r = r `fastShiftL` i

6676 rec v i r = rec (v `fastShiftR` 1) (i-1) ((r `fastShiftL` 1) .|. (v .&. 0x1))

6777

78+reverseBits# :: Int# -> Word# -> Word#

79+reverseBits# n value = rec value n 0##

80+ where

81+ -- rec v i r, where

82+ -- v is orginal value shifted

83+ -- i is the remaining number of bits

84+ -- r is current value

85+ rec 0## 0# r = r

86+ rec 0## i r = r `shiftL#` i

87+ rec v i r = rec (v `shiftRL#` 1#) (i -# 1#) ((r `shiftL#` 1#) `or#` (v `and#` 0x1##))

88+

6889

6990---------------------------------------------------------------------

7091-- Unchecked shifts, from the "binary" package

@@ -116,13 +137,13 @@ shiftr_w32 :: Word32 -> Int -> Word32

116137shiftr_w64 :: Word64 -> Int -> Word64

117138

118139#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)

119−shiftl_w8 (W8# w) (I# i) = W8# (w `uncheckedShiftL#` i)

120−shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#` i)

121−shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i)

140+shiftl_w8 w i = w `unsafeShiftL` i

141+shiftl_w16 w i = w `unsafeShiftL` i

142+shiftl_w32 w i = w `unsafeShiftL` i

122143

123−shiftr_w8 (W8# w) (I# i) = W8# (w `uncheckedShiftRL#` i)

124−shiftr_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftRL#` i)

125−shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i)

144+shiftr_w8 w i = w `unsafeShiftR` i

145+shiftr_w16 w i = w `unsafeShiftR` i

146+shiftr_w32 w i = w `unsafeShiftR` i

126147

127148

128149#if WORD_SIZE_IN_BITS < 64

Data/Binary/Bits/Put.hs+135−22

@@ -1,3 +1,5 @@

1+{-# LANGUAGE MagicHash #-}

13-----------------------------------------------------------------------------

24-- |

35-- Module : Data.Binary.Bits.Put

@@ -20,9 +22,14 @@ module Data.Binary.Bits.Put

2022 -- * Data types

2123 -- ** Bool

2224 , putBool

25+ , putBool#

2326

2427 -- ** Words

28+ , putWord#

2529 , putWord8

30+ , putWord16

31+ , putWord32

32+ , putWord64

2633 , putWord16be

2734 , putWord32be

2835 , putWord64be

@@ -38,13 +45,16 @@ import qualified Data.Binary.Put as Put

3845import Data.Binary.Put ( Put )

3946import Data.Binary.Bits.Internal

4047import Data.Binary.Bits.BitOrder

48+import Data.Binary.Bits.Alignment

4149

42−import Data.ByteString

50+import Data.ByteString as BS

51+import Data.ByteString.Unsafe as BS

4352

44−import Control.Applicative

53+import Control.Monad (when)

4554import Data.Bits

46−import Data.Monoid

4755import Data.Word

56+import GHC.Base (Word#, shiftRL#, Int (..), Int#, (-#), (<#), isTrue#, (+#), shiftL#, wordToWord8#, orWord8#)

57+import GHC.Word (Word8(..))

4858

4959data BitPut a = BitPut { run :: (S -> PairS a) }

5060

@@ -56,11 +66,18 @@ data S = S !Builder !Word8 !Int !BitOrder

5666putBool :: Bool -> BitPut ()

5767putBool b = putWord8 1 (if b then 0xff else 0x00)

5868

69+-- | Put a 1 bit 'Bool'.

70+putBool# :: Word# -> BitPut ()

71+putBool# b = putWord# 1# b

72+

5973

6074-- | Generic putWord

6175putWord :: (Num a, FastBits a, Integral a) => Int -> a -> BitPut ()

6276putWord n w = BitPut $ \s -> PairS () (putWordS n w s)

6377

78+putWord# :: Int# -> Word# -> BitPut ()

79+putWord# n w = BitPut $ \s -> PairS () (putWordS# n w s)

80+

6481putWordS :: (Num a, FastBits a, Integral a) => Int -> a -> S -> S

6582putWordS n w s@(S builder b o bo) = s'

6683 where

@@ -78,9 +95,9 @@ putWordS n w s@(S builder b o bo) = s'

7895 -- Word containing the remaining (n-cn) bits to store in its LSB

7996 w' = case bo of

8097 BB -> w

81− BL -> w

82− LB -> w `fastShiftR` cn

98+ BL -> w `fastShiftR` cn

8399 LL -> w `fastShiftR` cn

100+ LB -> w

84101

85102 -- Select bits to store in the current byte.

86103 -- Put them in the correct order and return them in the least-significant

@@ -88,63 +105,142 @@ putWordS n w s@(S builder b o bo) = s'

88105 selectBits :: (Num a, FastBits a, Integral a) => a -> Word8

89106 selectBits x = fromIntegral $ case bo of

90107 BB -> mask cn $ x `fastShiftR` (n-cn)

91− BL -> reverseBits cn $ mask cn $ x `fastShiftR` (n-cn)

92− LB -> mask cn x

93− LL -> reverseBits cn $ mask cn x

108+ LB -> reverseBits cn $ mask cn $ x `fastShiftR` (n-cn)

109+ LL -> mask cn x

110+ BL -> reverseBits cn $ mask cn x

94111

95112 -- shift left at the correct position

96113 shl :: Word8 -> Word8

97114 shl x = case bo of

98115 BB -> x `fastShiftL` (8-o-cn)

99116 BL -> x `fastShiftL` (8-o-cn)

100− LB -> x `fastShiftL` o

101117 LL -> x `fastShiftL` o

118+ LB -> x `fastShiftL` o

119+

120+ flush s2@(S b2 w2 o2 bo2)

121+ | o2 == 8 = S (b2 `mappend` B.singleton w2) 0 0 bo2

122+ | otherwise = s2

123+

124+putWordS# :: Int# -> Word# -> S -> S

125+putWordS# n w s@(S builder (W8# b) (I# o) bo) = s'

126+ where

127+ min# :: Int# -> Int# -> Int#

128+ min# x y | isTrue# (x <# y) = x

129+ min# _ y = y

130+

131+ -- number of bits that will be stored in the current byte

132+ cn = min# (8# -# o) n

133+

134+ -- new state

135+ s' = case n of

136+ 0# -> s

137+ _ -> putWordS# (n -# cn) w' (flush (S builder (W8# b') (I# (o +# cn)) bo))

138+

139+ -- new current byte

140+ b' = wordToWord8# (shl (selectBits w)) `orWord8#` b

141+

142+ -- Word containing the remaining (n-cn) bits to store in its LSB

143+ w' = case bo of

144+ BB -> w

145+ BL -> w `shiftRL#` cn

146+ LL -> w `shiftRL#` cn

147+ LB -> w

148+

149+ -- Select bits to store in the current byte.

150+ -- Put them in the correct order and return them in the least-significant

151+ -- bits of the returned value

152+ selectBits :: Word# -> Word#

153+ selectBits x = case bo of

154+ BB -> mask# cn (x `shiftRL#` (n -# cn))

155+ LB -> reverseBits# cn (mask# cn (x `shiftRL#` (n -# cn)))

156+ LL -> mask# cn x

157+ BL -> reverseBits# cn (mask# cn x)

158+

159+ -- shift left at the correct position

160+ shl :: Word# -> Word#

161+ shl x = case bo of

162+ BB -> x `shiftL#` (8# -# o -# cn)

163+ BL -> x `shiftL#` (8# -# o -# cn)

164+ LL -> x `shiftL#` o

165+ LB -> x `shiftL#` o

166+

167+ flush s2@(S b2 w2 o2 bo2)

168+ | o2 == 8 = S (b2 `mappend` B.singleton w2) 0 0 bo2

169+ | otherwise = s2

170+

102171

103172-- | Put the @n@ lower bits of a 'Word8'.

104173putWord8 :: Int -> Word8 -> BitPut ()

105174putWord8 = putWord

106175

107176-- | Put the @n@ lower bits of a 'Word16'.

177+putWord16 :: Int -> Word16 -> BitPut ()

178+putWord16 = putWord

179+

108180putWord16be :: Int -> Word16 -> BitPut ()

109181putWord16be = putWord

182+{-# DEPRECATED putWord16be "Use 'putWord16' instead" #-}

110183

111184-- | Put the @n@ lower bits of a 'Word32'.

185+putWord32 :: Int -> Word32 -> BitPut ()

186+putWord32 = putWord

187+

112188putWord32be :: Int -> Word32 -> BitPut ()

113189putWord32be = putWord

190+{-# DEPRECATED putWord32be "Use 'putWord32' instead" #-}

114191

115192-- | Put the @n@ lower bits of a 'Word64'.

193+putWord64 :: Int -> Word64 -> BitPut ()

194+putWord64 = putWord

195+

116196putWord64be :: Int -> Word64 -> BitPut ()

117197putWord64be = putWord

198+{-# DEPRECATED putWord64be "Use 'putWord64' instead" #-}

118199

119200-- | Put a 'ByteString'.

201+--

202+-- Examples: 3 bits are already written in the current byte

203+-- BB: ABCDEFGH IJKLMNOP -> xxxABCDE FGHIJKLM NOPxxxxx

204+-- LL: ABCDEFGH IJKLMNOP -> LMNOPxxx DEFGHIJK xxxxxABC

205+-- BL: ABCDEFGH IJKLMNOP -> xxxPONML KJIHGFED CBAxxxxx

206+-- LB: ABCDEFGH IJKLMNOP -> EDCBAxxx MLKJIHGF xxxxxPON

120207putByteString :: ByteString -> BitPut ()

121−putByteString bs = do

122− offset <- hasOffset

123− if offset

124− then mapM_ (putWord8 8) (unpack bs) -- naive

125− else joinPut (Put.putByteString bs)

126− where

127− hasOffset = BitPut $ \ s@(S _ _ o _) -> PairS (o /= 0) s

208+putByteString bs = BitPut $ \s -> PairS () (putByteStringS bs s)

209+

210+putByteStringS :: ByteString -> S -> S

211+putByteStringS bs s

212+ | BS.null bs = s

213+ | otherwise = case s of

214+ (S builder b 0 BB) -> S (builder `mappend` B.fromByteString bs) b 0 BB

215+ (S builder b 0 LL) -> S (builder `mappend` B.fromByteString (BS.reverse bs)) b 0 LL

216+ (S builder b 0 LB) -> S (builder `mappend` B.fromByteString (rev bs)) b 0 LB

217+ (S builder b 0 BL) -> S (builder `mappend` B.fromByteString (rev (BS.reverse bs))) b 0 BL

218+ (S _ _ _ BB) -> putByteStringS (BS.unsafeTail bs) (putWordS 8 (BS.unsafeHead bs) s)

219+ (S _ _ _ LL) -> putByteStringS (BS.unsafeInit bs) (putWordS 8 (BS.unsafeLast bs) s)

220+ (S _ _ _ BL) -> putByteStringS (BS.unsafeInit bs) (putWordS 8 (BS.unsafeLast bs) s)

221+ (S _ _ _ LB) -> putByteStringS (BS.unsafeTail bs) (putWordS 8 (BS.unsafeHead bs) s)

222+ where

223+ rev = BS.map (reverseBits 8)

224+

128225

129226-- | Run a 'Put' inside 'BitPut'. Any partially written bytes will be flushed

130227-- before 'Put' executes to ensure byte alignment.

228+--

229+-- Warning: this method does not take bit order into account (i.e. BB assumed)

131230joinPut :: Put -> BitPut ()

132231joinPut m = BitPut $ \s0 -> PairS () $

133232 let (S b0 _ _ bo) = flushIncomplete s0

134233 b = Put.execPut m

135234 in (S (b0`mappend`b) 0 0 bo)

136235

137−flush :: S -> S

138−flush s@(S b w o bo)

139− | o > 8 = error "flush: offset > 8"

140− | o == 8 = S (b `mappend` B.singleton w) 0 0 bo

141− | otherwise = s

142−

143236flushIncomplete :: S -> S

144237flushIncomplete s@(S b w o bo)

145238 | o == 0 = s

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

147240

241+getOffset :: BitPut Int

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

243+

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

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

150246runBitPut m = Put.putBuilder b

@@ -170,3 +266,20 @@ instance Monad BitPut where

170266 PairS b s'' = run (k a) s'

171267 in PairS b s''

172268 return x = BitPut $ \s -> PairS x s

269+

270+instance BitOrderable BitPut where

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

272+

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

274+

275+instance Alignable BitPut where

276+ -- | Skip the given number of bits

277+ skipBits n

278+ | n <= 64 = putWord64 n 0

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

280+

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

282+ alignByte = do

283+ o <- getOffset

284+ when (o /= 0) $

285+ skipBits (8-o)

binary-bits.cabal+4−2

@@ -1,6 +1,6 @@

11-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/

22name: binary-bits

3−version: 0.5.1

3+version: 0.6

44synopsis: Bit parsing/writing on top of binary.

55description: Bit parsing/writing on top of binary. Provides functions to

66 read and write bits to and from 8\/16\/32\/64 words.

@@ -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,

flake.locknew file+59

@@ -0,0 +1,59 @@

1+{

2+ "nodes": {

3+ "flake-utils": {

4+ "inputs": {

5+ "systems": "systems"

6+ },

7+ "locked": {

8+ "lastModified": 1731533236,

9+ "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=",

10+ "owner": "numtide",

11+ "repo": "flake-utils",

12+ "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b",

13+ "type": "github"

14+ },

15+ "original": {

16+ "id": "flake-utils",

17+ "type": "indirect"

18+ }

19+ },

20+ "nixpkgs": {

21+ "locked": {

22+ "lastModified": 1737469691,

23+ "narHash": "sha256-nmKOgAU48S41dTPIXAq0AHZSehWUn6ZPrUKijHAMmIk=",

24+ "owner": "NixOS",

25+ "repo": "nixpkgs",

26+ "rev": "9e4d5190a9482a1fb9d18adf0bdb83c6e506eaab",

27+ "type": "github"

28+ },

29+ "original": {

30+ "id": "nixpkgs",

31+ "ref": "nixos-unstable",

32+ "type": "indirect"

33+ }

34+ },

35+ "root": {

36+ "inputs": {

37+ "flake-utils": "flake-utils",

38+ "nixpkgs": "nixpkgs"

39+ }

40+ },

41+ "systems": {

42+ "locked": {

43+ "lastModified": 1681028828,

44+ "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",

45+ "owner": "nix-systems",

46+ "repo": "default",

47+ "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",

48+ "type": "github"

49+ },

50+ "original": {

51+ "owner": "nix-systems",

52+ "repo": "default",

53+ "type": "github"

54+ }

55+ }

56+ },

57+ "root": "root",

58+ "version": 7

59+}

flake.nixnew file+24

@@ -0,0 +1,24 @@

1+{

2+ inputs = {

3+ nixpkgs.url = "nixpkgs/nixos-unstable";

4+ flake-utils.url = "flake-utils";

5+ };

7+ outputs = { self, flake-utils, nixpkgs }:

8+ let

9+ supportedSystems =

10+ [ "x86_64-linux" "x86_64-darwin" "aarch64-darwin" "aarch64-linux" ];

11+ compilerVersion = "966";

12+ in flake-utils.lib.eachSystem supportedSystems (system:

13+ let pkgs = import nixpkgs { inherit system; };

14+ in {

15+ devShells.default = pkgs.mkShell {

16+ buildInputs = with pkgs; [

17+ haskell.compiler."ghc${compilerVersion}"

18+ (pkgs.haskell-language-server.override {

19+ supportedGhcVersions = [ compilerVersion ];

20+ })

21+ ];

22+ };

23+ });

24+}

stack.yamlnew file+66

@@ -0,0 +1,66 @@

1+# This file was automatically generated by 'stack init'

2+#

3+# Some commonly used options have been documented as comments in this file.

4+# For advanced use and comprehensive documentation of the format, please see:

5+# https://docs.haskellstack.org/en/stable/yaml_configuration/

7+# Resolver to choose a 'specific' stackage snapshot or a compiler version.

8+# A snapshot resolver dictates the compiler version and the set of packages

9+# to be used for project dependencies. For example:

10+#

11+# resolver: lts-3.5

12+# resolver: nightly-2015-09-21

13+# resolver: ghc-7.10.2

14+#

15+# The location of a snapshot can be provided as a file or url. Stack assumes

16+# a snapshot provided as a file might change, whereas a url resource does not.

17+#

18+# resolver: ./custom-snapshot.yaml

19+# resolver: https://example.com/snapshots/2018-01-01.yaml

20+resolver: lts-22.43

21+

22+# User packages to be built.

23+# Various formats can be used as shown in the example below.

24+#

25+# packages:

26+# - some-directory

27+# - https://example.com/foo/bar/baz-0.0.2.tar.gz

28+# subdirs:

29+# - auto-update

30+# - wai

31+packages:

32+- .

33+# Dependency packages to be pulled from upstream that are not in the resolver.

34+# These entries can reference officially published versions as well as

35+# forks / in-progress versions pinned to a git hash. For example:

36+#

37+# extra-deps:

38+# - acme-missiles-0.3

39+# - git: https://github.com/commercialhaskell/stack.git

40+# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a

41+#

42+# extra-deps: []

43+

44+# Override default flag values for local packages and extra-deps

45+# flags: {}

46+

47+# Extra package databases containing global packages

48+# extra-package-dbs: []

49+

50+# Control whether we use the GHC we find on the path

51+# system-ghc: true

52+#

53+# Require a specific version of stack, using version ranges

54+# require-stack-version: -any # Default

55+# require-stack-version: ">=2.9"

56+#

57+# Override the architecture used by stack, especially useful on Windows

58+# arch: i386

59+# arch: x86_64

60+#

61+# Extra directories used by stack for building

62+# extra-include-dirs: [/path/to/dir]

63+# extra-lib-dirs: [/path/to/dir]

64+#

65+# Allow a newer minor version of GHC than the snapshot specifies

66+# compiler-check: newer-minor

stack.yaml.locknew file+12

@@ -0,0 +1,12 @@

1+# This file was autogenerated by Stack.

2+# You should not edit this file by hand.

3+# For more information, please see the documentation at:

4+# https://docs.haskellstack.org/en/stable/lock_files

6+packages: []

7+snapshots:

8+- completed:

9+ sha256: 08bd13ce621b41a8f5e51456b38d5b46d7783ce114a50ab604d6bbab0d002146

10+ size: 720271

11+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/43.yaml

12+ original: lts-22.43