ed53a4b...master · binary-bits

git.iko.soy/binary-bits

on master help sign in

.gitignore+1

since splitsnapshots

unifiedsplit

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

1.cabal-sandbox

2cabal.sandbox.config

3dist/

4+.stack-work

BitsQC.hs+74−41

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

9import Data.Binary.Bits

10import Data.Binary.Bits.Get

11import Data.Binary.Bits.Put

12+import Data.Binary.Bits.BitOrder

13import qualified Data.ByteString as B

14import qualified Data.ByteString as B

14import qualified Data.ByteString.Lazy as L

15import qualified Data.ByteString.Lazy as L

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

17import Data.Bits

18import Data.Bits

18import Data.Word

19import Data.Word

19import Foreign.Storable

20import Foreign.Storable

20−import System.Random

21+import Data.Traversable (traverse)

22+import Data.Foldable (traverse_)

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

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

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

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

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

36 [ testProperty "prop_composite_case" prop_composite_case ]

38 [ testProperty "prop_composite_case" prop_composite_case ]

38 , testGroup "getByteString"

40 , 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+ ]

41 , testGroup "getLazyByteString"

46 , testGroup "getLazyByteString"

42 [ testProperty "getLazyByteString == getByteString"

47 [ testProperty "getLazyByteString == getByteString"

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

84 ]

89 ]

86 , testGroup "prop_put_with_bitreq"

91 , testGroup "prop_put_with_bitreq"

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

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

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

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

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

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

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

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

91 ]

96 ]

93 , testGroup "prop_putget_list_simple"

98 , testGroup "prop_putget_list_simple"

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

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

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

113 ]

118 ]

114 , testGroup "prop_bitget_bytestring_interspersed"

119 , testGroup "prop_bitget_bytestring_interspersed"

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

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

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

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

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

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

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

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

119 ]

124 ]

120 , testGroup "Simulate programs"

125 , testGroup "Simulate programs"

121 [ testProperty "primitive" prop_primitive

126 [ testProperty "primitive" prop_primitive

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

158 n < 1 ==>

163 n < 1 ==>

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

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

160

165

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+

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

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

162−prop_putget_with_bitreq (W w) = property $

182+prop_putget_with_bitreq bo (W w) = property $

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

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

164 let p = putBits (bitreq w) w

184 let p = putBits (bitreq w) w

165 g = getBits (bitreq w)

185 g = getBits (bitreq w)

166− lbs = runPut (runBitPut p)

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

167− w' = runGet (runBitGet g) lbs

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

168 in w == w'

188 in w == w'

169

189

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

190-- | 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 $

226 in ws == ws'

246 in ws == ws'

227

247

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

248-- | 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

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

230−prop_bitget_bytestring_interspersed (W ws) bss = property $

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

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

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

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

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

233− lbs = runPut (runBitPut p)

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

234− r = runGet (runBitGet g) lbs

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

235 in map (ws,) bss == r

255 in map (ws,) bss == r

236

256

237-- | Test failing.

257-- | Test failing.

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

241 expectedBytesConsumed

261 expectedBytesConsumed

242 | bits == 0 = bytes

262 | bits == 0 = bytes

243 | otherwise = bytes + 1

263 | otherwise = bytes + 1

244− p = do getByteString (fromIntegral bytes)

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

245− getBits (fromIntegral bits) :: BitGet Word8

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

246 fail errMsg0

266 fail errMsg0

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

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

248 in case r of

268 in case r of

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

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

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

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

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

270 let p = do putBool b

290 let p = do putBool b

271− putWord16be 15 w

291+ putWord16 15 w

272 g = do v <- getBool

292 g = do v <- getBool

273 case v of

293 case v of

274− True -> getWord16be 15

294+ True -> getWord16 15

275 False -> do

295 False -> do

276 msb <- getWord8 7

296 msb <- getWord8 7

277 lsb <- getWord8 8

297 lsb <- getWord8 8

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

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

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

375 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

376

396

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−

382data Primitive

397data Primitive

383 = Bool Bool

398 = Bool Bool

384 | W8 Int Word8

399 | W8 Int Word8

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

387 | W64 Int Word64

402 | W64 Int Word64

388 | BS Int B.ByteString

403 | BS Int B.ByteString

389 | LBS Int L.ByteString

404 | LBS Int L.ByteString

405+ | Skip Int

390 | IsEmpty

406 | IsEmpty

391 deriving (Eq, Show)

407 deriving (Eq, Show)

392

408

@@ -395,7 +411,7 @@ type Program = [Primitive]

395instance Arbitrary Primitive where

411instance Arbitrary Primitive where

396 arbitrary = do

412 arbitrary = do

397 let gen c = do

413 let gen c = do

398− let (maxBits, _) = (\w -> (bitSize w, c undefined w)) undefined

414+ let (maxBits, _) = (\w -> (finiteBitSize w, c undefined w)) undefined

399 bits <- choose (0, maxBits)

415 bits <- choose (0, maxBits)

400 n <- choose (0, fromIntegral (2^bits-1))

416 n <- choose (0, fromIntegral (2^bits-1))

401 return (c bits n)

417 return (c bits n)

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

405 , gen W16

421 , gen W16

406 , gen W32

422 , gen W32

407 , gen W64

423 , gen W64

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

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

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

409 cs <- vector n

426 cs <- vector n

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

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

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

421 W16 _ x -> snk W16 x

438 W16 _ x -> snk W16 x

422 W32 _ x -> snk W32 x

439 W32 _ x -> snk W32 x

423 W64 _ x -> snk W64 x

440 W64 _ x -> snk W64 x

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

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

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

426 IsEmpty -> []

444 IsEmpty -> []

427

445

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+

428prop_primitive :: Primitive -> Property

454prop_primitive :: Primitive -> Property

429prop_primitive prim = property $

455prop_primitive prim = property $

430 let p = putPrimitive prim

456 let p = putPrimitive prim

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

446 case p of

472 case p of

447 Bool b -> putBool b

473 Bool b -> putBool b

448 W8 n x -> putWord8 n x

474 W8 n x -> putWord8 n x

449− W16 n x -> putWord16be n x

475+ W16 n x -> putWord16 n x

450− W32 n x -> putWord32be n x

476+ W32 n x -> putWord32 n x

451− W64 n x -> putWord64be n x

477+ W64 n x -> putWord64 n x

478+ Skip n -> skipBits n

452 BS _ bs -> putByteString bs

479 BS _ bs -> putByteString bs

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

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

454 IsEmpty -> return ()

481 IsEmpty -> return ()

@@ -458,13 +485,25 @@ getPrimitive p =

458 case p of

485 case p of

459 Bool _ -> Bool <$> getBool

486 Bool _ -> Bool <$> getBool

460 W8 n _ -> W8 n <$> getWord8 n

487 W8 n _ -> W8 n <$> getWord8 n

461− W16 n _ -> W16 n <$> getWord16be n

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

462− W32 n _ -> W32 n <$> getWord32be n

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

463− W64 n _ -> W64 n <$> getWord64be n

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

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

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

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

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

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

466 IsEmpty -> isEmpty >> return IsEmpty

494 IsEmpty -> isEmpty >> return IsEmpty

467

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

468

507

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

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

470verifyProgram totalLength ps0 = go 0 ps0

509verifyProgram totalLength ps0 = go 0 ps0

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

472 go _ [] = return True

511 go _ [] = return True

473 go pos (p:ps) =

512 go pos (p:ps) =

474 case p of

513 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 (getWord16be n) >> go (pos+n) ps

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

479− W64 n x -> check x (getWord64be 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

482 IsEmpty -> do

514 IsEmpty -> do

483 let expected = pos == totalLength

515 let expected = pos == totalLength

484 actual <- isEmpty

516 actual <- isEmpty

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

486 then go pos ps

518 then go pos ps

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

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

488 ++ show expected ++ " but got " ++ show actual

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

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

489 check x g = do

522 check x g = do

490 y <- g

523 y <- g

491 if x == y

524 if x == y

Data/Binary/Bits.hs+6−6

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

33 getBits = getWord8

35instance BinaryBit Word16 where

36− putBits = putWord16be

36+ putBits = putWord16

37− getBits = getWord16be

37+ getBits = getWord16

39instance BinaryBit Word32 where

40− putBits = putWord32be

40+ putBits = putWord32

41− getBits = getWord32be

41+ getBits = getWord32

43instance BinaryBit Word64 where

44− putBits = putWord64be

44+ putBits = putWord64

45− getBits = getWord64be

45+ 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.hsnew file+47

@@ -0,0 +1,47 @@

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.BitOrder

13+ ( BitOrder(..)

14+ , BitOrderable(..)

15+ )

16+where

17+

18+-- | Bit order

19+--

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

21+-- - BB: ABCDEVWX YZxxxxxx

22+-- - LL: XYZABCDE xxxxxxVW

23+-- - BL: EDCBAZYX WVxxxxxx

24+-- - LB: XWVEDCBA xxxxxxZY

25+data BitOrder

26+ = BB -- ^ Big-endian bytes and bits

27+ | LB -- ^ Little-endian bytes, big-endian bits

28+ | BL -- ^ Big-endian bytes, little-endian bits

29+ | LL -- ^ Little-endian bytes and bits

30+ 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+241−277

@@ -4,6 +4,7 @@

4-- |

5-- Module : Data.Binary.Bits.Get

6-- Copyright : (c) Lennart Kolmodin 2010-2011

7+-- (c) Sylvain Henry 2015

7-- License : BSD3-style (see LICENSE)

8-- License : BSD3-style (see LICENSE)

8--

9--

9-- Maintainer : kolmodin@gmail.com

10-- Maintainer : kolmodin@gmail.com

@@ -59,7 +60,11 @@ module Data.Binary.Bits.Get

60 -- ** Get bytes

61 -- ** Get bytes

61 , getBool

62 , getBool

63+ , getBool#

62 , getWord8

64 , getWord8

65+ , getWord16

66+ , getWord32

67+ , getWord64

63 , getWord16be

68 , getWord16be

64 , getWord32be

69 , getWord32be

65 , getWord64be

70 , getWord64be

@@ -77,6 +82,9 @@ module Data.Binary.Bits.Get

77 -- ** Read in Blocks

82 -- ** Read in Blocks

78 , bool

83 , bool

79 , word8

84 , word8

85+ , word16

86+ , word32

87+ , word64

80 , word16be

88 , word16be

81 , word32be

89 , word32be

82 , word64be

90 , word64be

@@ -89,23 +97,26 @@ module Data.Binary.Bits.Get

90import Data.Binary.Get as B ( Get, getLazyByteString, isEmpty )

98import Data.Binary.Get as B ( Get, getLazyByteString, isEmpty )

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

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

100+import Data.Binary.Bits.BitOrder

101+import Data.Binary.Bits.Internal

102+import Data.Binary.Bits.Alignment

103

93import Data.ByteString as B

104import Data.ByteString as B

94import qualified Data.ByteString.Lazy as L

105import qualified Data.ByteString.Lazy as L

95import Data.ByteString.Unsafe

106import Data.ByteString.Unsafe

107+import Foreign.Marshal.Alloc (mallocBytes)

108+import Foreign.Ptr

109+import Foreign.Storable (poke)

110+import System.IO.Unsafe (unsafePerformIO)

111

97import Data.Bits

112import Data.Bits

98import Data.Word

113import Data.Word

99import Control.Applicative

114import Control.Applicative

100−import Control.Monad (when)

115+import Control.Monad (when,foldM_)

101

116

102import Prelude as P

117import Prelude as P

103−

104−#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)

105−import GHC.Base

106import GHC.Word

118import GHC.Word

107−#endif

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

108−

109

120

110-- $bitget

121-- $bitget

111-- Parse bits using a monad.

122-- Parse bits using a monad.

@@ -154,195 +165,120 @@ import GHC.Word

154-- @

165-- @

155

166

156data S = S {-# UNPACK #-} !ByteString -- Input

167data S = S {-# UNPACK #-} !ByteString -- Input

157− {-# UNPACK #-} !Int -- Bit offset (0-7)

168+ {-# UNPACK #-} !Int -- Bit offset (0-7)

169+ !BitOrder -- Bit order

158 deriving (Show)

170 deriving (Show)

159

171

160−-- | A block that will be read with only one boundry check. Needs to know the

172+-- | Increment the current bit offset

161−-- number of bits in advance.

162−data Block a = Block Int (S -> a)

163−

164−instance Functor Block where

165− fmap f (Block i p) = Block i (\s -> f (p s))

166−

167−instance Applicative Block where

168− pure a = Block 0 (\_ -> a)

169− (Block i p) <*> (Block j q) = Block (i+j) (\s -> p s $ q (incS i s))

170− (Block i _) *> (Block j q) = Block (i+j) (q . incS i)

171− (Block i p) <* (Block j _) = Block (i+j) p

172−

173−-- | Get a block. Will be read with one single boundry check, and

174−-- therefore requires a statically known number of bits.

175−-- Build blocks using 'bool', 'word8', 'word16be', 'word32be', 'word64be',

176−-- 'byteString' and 'Applicative'.

177−block :: Block a -> BitGet a

178−block (Block i p) = do

179− ensureBits i

180− s <- getState

181− putState $! (incS i s)

182− return $! p s

183−

184incS :: Int -> S -> S

173incS :: Int -> S -> S

185−incS o (S bs n) =

186− let !o' = (n+o)

187− !d = o' `shiftR` 3

188− !n' = o' .&. make_mask 3

189− in S (unsafeDrop d bs) n'

174+incS o (S bs n bo) = S (unsafeDrop d bs) n' bo

190−

175+ where

191−-- | make_mask 3 = 00000111

176+ !o' = (n+o)

192−make_mask :: (Bits a, Num a) => Int -> a

193−make_mask n = (1 `shiftL` fromIntegral n) - 1

194−{-# SPECIALIZE make_mask :: Int -> Int #-}

195−{-# SPECIALIZE make_mask :: Int -> Word #-}

196−{-# SPECIALIZE make_mask :: Int -> Word8 #-}

197−{-# SPECIALIZE make_mask :: Int -> Word16 #-}

198−{-# SPECIALIZE make_mask :: Int -> Word32 #-}

199−{-# SPECIALIZE make_mask :: Int -> Word64 #-}

200−

201−bit_offset :: Int -> Int

202−bit_offset n = make_mask 3 .&. n

203−

204−byte_offset :: Int -> Int

177+ !d = byte_offset o'

205−byte_offset n = n `shiftR` 3

178+ !n' = bit_offset o'

206

179

180+-- | Read a single bit

207readBool :: S -> Bool

181readBool :: S -> Bool

208−readBool (S bs n) = testBit (unsafeHead bs) (7-n)

182+readBool (S bs o bo) = case bo of

209−

183+ BB -> testBit (unsafeHead bs) (7-o)

210−{-# INLINE readWord8 #-}

184+ BL -> testBit (unsafeHead bs) (7-o)

211−readWord8 :: Int -> S -> Word8

185+ LL -> testBit (unsafeHead bs) o

212−readWord8 n (S bs o)

186+ LB -> testBit (unsafeHead bs) o

213− -- no bits at all, return 0

187+

214− | n == 0 = 0

188+-- | Read a single bit

215−

189+readBool# :: S -> Int

216− -- all bits are in the same byte

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

217− -- we just need to shift and mask them right

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

218− | n <= 8 - o = let w = unsafeHead bs

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

219− m = make_mask n

193+ LL -> testBit# o

220− w' = (w `shiftr_w8` (8 - o - n)) .&. m

194+ LB -> testBit# o

221− in w'

195+ where

222−

196+ !(W8# w) = unsafeHead bs

223− -- the bits are in two different bytes

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

224− -- make a word16 using both bytes, and then shift and mask

198+

225− -- n <= 8

199+

226− | otherwise = let

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

227− w = (fromIntegral (unsafeHead bs) `shiftl_w16` 8) .|.

201+--

228− (fromIntegral (unsafeIndex bs 1))

202+-- Constraint: 8 * (length ws -1 ) < o+n <= 8 * length ws

229− m = make_mask n

203+extract :: (Num a, FastBits a) => BitOrder -> ByteString -> Int -> Int -> a

230− w' = (w `shiftr_w16` (16 - o - n)) .&. m

204+extract bo bs o n

231− in fromIntegral w'

205+ | n == 0 = 0

232−

206+ | B.length bs == 0 = error "Empty ByteString"

233−{-# INLINE readWord16be #-}

207+ | otherwise = rev . mask n . foldlWithIndex' f 0 $ bs

234−readWord16be :: Int -> S -> Word16

208+ where

235−readWord16be n s@(S bs o)

209+ -- B.foldl' with index

236−

210+ foldlWithIndex' op b = fst . B.foldl' g (b,0)

237− -- 8 or fewer bits, use readWord8

211+ where g (b',i) w = (op b' w i, (i+1))

238− | n <= 8 = fromIntegral (readWord8 n s)

212+

239−

213+ -- 'or' correctly shifted words

240− -- handle 9 or more bits, stored in two bytes

214+ f b w i = b .|. (fromIntegral w `fastShift` off i)

241−

215+

242− -- no offset, plain and simple 16 bytes

216+ -- co-offset

243− | o == 0 && n == 16 = let msb = fromIntegral (unsafeHead bs)

217+ r = B.length bs * 8 - (o + n)

244− lsb = fromIntegral (unsafeIndex bs 1)

218+

245− w = (msb `shiftl_w16` 8) .|. lsb

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

246− in w

220+ off i = case bo of

247−

221+ LL -> 8*i - o

248− -- no offset, but not full 16 bytes

222+ LB -> 8*i - o

249− | o == 0 = let msb = fromIntegral (unsafeHead bs)

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

250− lsb = fromIntegral (unsafeIndex bs 1)

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

251− w = (msb `shiftl_w16` (n-8)) .|. (lsb `shiftr_w16` (16-n))

225+

252− in w

226+ -- reverse bits if necessary

253−

227+ rev = case bo of

254− -- with offset, and n=9-16

228+ LB -> reverseBits n

255− | n <= 16 = readWithOffset s shiftl_w16 shiftr_w16 n

229+ BL -> reverseBits n

256−

230+ BB -> id

257− | otherwise = error "readWord16be: tried to read more than 16 bits"

231+ LL -> id

258−

232+

259−{-# INLINE readWord32be #-}

233+

260−readWord32be :: Int -> S -> Word32

234+-- | Generic readWord

261−readWord32be n s@(S _ o)

235+readWord :: (Num a, FastBits a) => Int -> S -> a

262− -- 8 or fewer bits, use readWord8

236+readWord n (S bs o bo)

263− | n <= 8 = fromIntegral (readWord8 n s)

237+ | n == 0 = 0

264−

238+ | otherwise = extract bo (unsafeTake nbytes bs) o n

265− -- 16 or fewer bits, use readWord16be

239+ where nbytes = byte_offset (o+n+7)

266− | n <= 16 = fromIntegral (readWord16be n s)

240+

267−

241+-- | Check that the number of bits to read is not greater than the first parameter

268− | o == 0 = readWithoutOffset s shiftl_w32 shiftr_w32 n

242+{-# INLINE readWordChecked #-}

269−

243+readWordChecked :: (Num a, FastBits a) => Int -> Int -> S -> a

270− | n <= 32 = readWithOffset s shiftl_w32 shiftr_w32 n

244+readWordChecked m n s

271−

245+ | n > m = error $ "Tried to read more than " ++ show m ++ " bits (" ++ show n ++")"

272− | otherwise = error "readWord32be: tried to read more than 32 bits"

246+ | otherwise = readWord n s

273−

247+

274−

248+-- | Read the given number of bytes and return them in Big-Endian order

275−{-# INLINE readWord64be #-}

249+--

276−readWord64be :: Int -> S -> Word64

250+-- Examples:

277−readWord64be n s@(S _ o)

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

278− -- 8 or fewer bits, use readWord8

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

279− | n <= 8 = fromIntegral (readWord8 n s)

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

280−

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

281− -- 16 or fewer bits, use readWord16be

282− | n <= 16 = fromIntegral (readWord16be n s)

283−

284− | o == 0 = readWithoutOffset s shiftl_w64 shiftr_w64 n

285−

286− | n <= 64 = readWithOffset s shiftl_w64 shiftr_w64 n

287−

288− | otherwise = error "readWord64be: tried to read more than 64 bits"

289−

290−

291readByteString :: Int -> S -> ByteString

255readByteString :: Int -> S -> ByteString

292−readByteString n s@(S bs o)

256+readByteString n (S bs o bo) =

293− -- no offset, easy.

257+ let

294− | o == 0 = unsafeTake n bs

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

295− -- offset. ugg. this is really naive and slow. but also pretty easy :)

259+ bs'' = unsafeTake n bs

296− | otherwise = B.pack (P.map (readWord8 8) (P.take n (iterate (incS 8) s)))

260+ rev = B.map (reverseBits 8)

297−

261+ in case (o,bo) of

298−readWithoutOffset :: (Bits a, Num a)

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

299− => S -> (a -> Int -> a) -> (a -> Int -> a) -> Int -> a

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

300−readWithoutOffset (S bs o) shifterL shifterR n

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

301− | o /= 0 = error "readWithoutOffset: there is an offset"

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

302−

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

303− | bit_offset n == 0 && byte_offset n <= 4 =

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

304− let segs = byte_offset n

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

305− bn 0 = fromIntegral (unsafeHead bs)

269+ (_,BB) -> unsafePerformIO $ do

306− bn m = (bn (m-1) `shifterL` 8) .|. fromIntegral (unsafeIndex bs m)

270+ let len = n+1

307−

271+ ptr <- mallocBytes len

308− in bn (segs-1)

272+ let f r i = do

309−

273+ let

310− -- n <= 64

274+ w = unsafeIndex bs (len-i)

311− | otherwise = let segs = byte_offset n

275+ w' = (w `fastShiftL` o) .|. r

312− o' = bit_offset (n - 8 + o)

276+ r' = w `fastShiftR` (8-o)

313−

277+ poke (ptr `plusPtr` (len-i)) w'

314− bn 0 = fromIntegral (unsafeHead bs)

278+ return r'

315− bn m = (bn (m-1) `shifterL` 8) .|. fromIntegral (unsafeIndex bs m)

279+ foldM_ f 0 [1..len]

316−

280+ unsafeInit <$> unsafePackMallocCStringLen (ptr,len)

317− msegs = bn (segs-1) `shifterL` o'

318−

319− lst = (fromIntegral (unsafeIndex bs segs)) `shifterR` (8 - o')

320−

321− w = msegs .|. lst

322− in w

323

281

324−readWithOffset :: (Bits a, Num a)

325− => S -> (a -> Int -> a) -> (a -> Int -> a) -> Int -> a

326−readWithOffset (S bs o) shifterL shifterR n

327− | n <= 64 = let bits_in_msb = 8 - o

328− (n',top) = (n - bits_in_msb

329− , (fromIntegral (unsafeHead bs) .&. make_mask bits_in_msb) `shifterL` n')

330−

331− segs = byte_offset n'

332−

333− bn 0 = 0

334− bn m = (bn (m-1) `shifterL` 8) .|. fromIntegral (unsafeIndex bs m)

335−

336− o' = bit_offset n'

337−

338− mseg = bn segs `shifterL` o'

339−

340− lst | o' > 0 = (fromIntegral (unsafeIndex bs (segs + 1))) `shifterR` (8 - o')

341− | otherwise = 0

342−

343− w = top .|. mseg .|. lst

344− in w

345− | otherwise = error $ "Invalid offset (" ++ show n ++ " > 64)"

346

282

347------------------------------------------------------------------------

283------------------------------------------------------------------------

348-- | 'BitGet' is a monad, applicative and a functor. See 'runBitGet'

284-- | 'BitGet' is a monad, applicative and a functor. See 'runBitGet'

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

351

287

352instance Monad BitGet where

288instance Monad BitGet where

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

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

354− fail str = B $ \(S inp n) -> putBackState inp n >> fail str

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

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

356 runState (g a) s'

291 runState (g a) s'

357

292

@@ -362,25 +297,51 @@ instance Applicative BitGet where

362 pure x = return x

297 pure x = return x

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

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

364

299

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+

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

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

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

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

367runBitGet :: BitGet a -> Get a

325runBitGet :: BitGet a -> Get a

368runBitGet bg = do

326runBitGet bg = do

369 s <- mkInitState

327 s <- mkInitState

370− ((S str' n),a) <- runState bg s

328+ (s',a) <- runState bg s

371− putBackState str' n

329+ putBackState s'

372 return a

330 return a

373

331

374mkInitState :: Get S

332mkInitState :: Get S

375mkInitState = do

333mkInitState = do

376− str <- get

334+ bs <- get

377 put B.empty

335 put B.empty

378− return (S str 0)

336+ return (S bs 0 BB)

379

337

380−putBackState :: B.ByteString -> Int -> Get ()

338+putBackState :: S -> Get ()

381−putBackState bs n = do

339+putBackState (S bs o _) = do

382 remaining <- get

340 remaining <- get

341+ let bs' = case o of

342+ 0 -> bs

343+ _ -> unsafeDrop 1 bs

383− put (B.drop (if n==0 then 0 else 1) bs `B.append` remaining)

344+ put (bs' `B.append` remaining)

384

345

385getState :: BitGet S

346getState :: BitGet S

386getState = B $ \s -> return (s,s)

347getState = B $ \s -> return (s,s)

@@ -388,52 +349,66 @@ getState = B $ \s -> return (s,s)

388putState :: S -> BitGet ()

349putState :: S -> BitGet ()

389putState s = B $ \_ -> return (s,())

350putState s = B $ \_ -> return (s,())

390

351

352+withState :: (S -> S) -> BitGet ()

353+withState f = do

354+ s <- getState

355+ putState $! f s

356+

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

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

392ensureBits :: Int -> BitGet ()

358ensureBits :: Int -> BitGet ()

393ensureBits n = do

359ensureBits n = do

394− (S bs o) <- getState

360+ (S bs o bo) <- getState

395 if n <= (B.length bs * 8 - o)

361 if n <= (B.length bs * 8 - o)

396 then return ()

362 then return ()

397 else do let currentBits = B.length bs * 8 - o

363 else do let currentBits = B.length bs * 8 - o

398− let byteCount = (n - currentBits + 7) `div` 8

364+ let byteCount = byte_offset (n - currentBits + 7)

399 B $ \_ -> do B.ensureN byteCount

365 B $ \_ -> do B.ensureN byteCount

400 bs' <- B.get

366 bs' <- B.get

401 put B.empty

367 put B.empty

402− return (S (bs`append`bs') o, ())

368+ return (S (bs`append`bs') o bo, ())

403−

404−-- | Skip the given number of bits

405−skipBits :: Int -> BitGet ()

406−skipBits n = do

407− ensureBits n

408− s <- getState

409− putState $! (incS n s)

410

369

411−-- | Skip bits if necessary to align on a byte

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

412−alignByte :: BitGet ()

371+-- undecoded bytes.

413−alignByte = do

372+isEmpty :: BitGet Bool

414− (S _ n) <- getState

373+isEmpty = B $ \ (S bs o bo) -> if B.null bs

415− when (n /= 0) $

374+ then B.isEmpty >>= \e -> return (S bs o bo, e)

416− skipBits (8-n)

375+ else return (S bs o bo, False)

417

376

418-- | Get 1 bit as a 'Bool'.

377-- | Get 1 bit as a 'Bool'.

419getBool :: BitGet Bool

378getBool :: BitGet Bool

420getBool = block bool

379getBool = block bool

421

380

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

382+getBool# :: BitGet Int

383+getBool# = block bool#

384+

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

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

423getWord8 :: Int -> BitGet Word8

386getWord8 :: Int -> BitGet Word8

424getWord8 n = block (word8 n)

387getWord8 n = block (word8 n)

425

388

426-- | Get @n@ bits as a 'Word16'. @n@ must be within @[0..16]@.

389-- | Get @n@ bits as a 'Word16'. @n@ must be within @[0..16]@.

390+getWord16 :: Int -> BitGet Word16

391+getWord16 n = block (word16 n)

392+

427getWord16be :: Int -> BitGet Word16

393getWord16be :: Int -> BitGet Word16

428−getWord16be n = block (word16be n)

394+getWord16be = getWord16

395+{-# DEPRECATED getWord16be "Use 'getWord16' instead" #-}

429

396

430-- | Get @n@ bits as a 'Word32'. @n@ must be within @[0..32]@.

397-- | Get @n@ bits as a 'Word32'. @n@ must be within @[0..32]@.

398+getWord32 :: Int -> BitGet Word32

399+getWord32 n = block (word32 n)

400+

431getWord32be :: Int -> BitGet Word32

401getWord32be :: Int -> BitGet Word32

432−getWord32be n = block (word32be n)

402+getWord32be = getWord32

403+{-# DEPRECATED getWord32be "Use 'getWord32' instead" #-}

433

404

434-- | Get @n@ bits as a 'Word64'. @n@ must be within @[0..64]@.

405-- | Get @n@ bits as a 'Word64'. @n@ must be within @[0..64]@.

406+getWord64 :: Int -> BitGet Word64

407+getWord64 n = block (word64 n)

408+

435getWord64be :: Int -> BitGet Word64

409getWord64be :: Int -> BitGet Word64

436−getWord64be n = block (word64be n)

410+getWord64be = getWord64

411+{-# DEPRECATED getWord64be "Use 'getWord64' instead" #-}

437

412

438-- | Get @n@ bytes as a 'ByteString'.

413-- | Get @n@ bytes as a 'ByteString'.

439getByteString :: Int -> BitGet ByteString

414getByteString :: Int -> BitGet ByteString

@@ -442,91 +417,80 @@ getByteString n = block (byteString n)

442-- | Get @n@ bytes as a lazy ByteString.

417-- | Get @n@ bytes as a lazy ByteString.

443getLazyByteString :: Int -> BitGet L.ByteString

418getLazyByteString :: Int -> BitGet L.ByteString

444getLazyByteString n = do

419getLazyByteString n = do

445− (S _ o) <- getState

420+ (S _ o bo) <- getState

446 case o of

421 case o of

447− 0 -> B $ \ (S bs o') -> do

422+ 0 -> B $ \s -> do

448− putBackState bs o'

423+ putBackState s

449 lbs <- B.getLazyByteString (fromIntegral n)

424 lbs <- B.getLazyByteString (fromIntegral n)

450− return (S B.empty 0, lbs)

425+ return (S B.empty 0 bo, lbs)

451 _ -> L.fromChunks . (:[]) <$> Data.Binary.Bits.Get.getByteString n

426 _ -> L.fromChunks . (:[]) <$> Data.Binary.Bits.Get.getByteString n

452

427

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

428+

454−-- undecoded bytes.

429+

455−isEmpty :: BitGet Bool

430+

456−isEmpty = B $ \ (S bs o) -> if B.null bs

431+

457− then B.isEmpty >>= \e -> return (S bs o, e)

432+-- | A block that will be read with only one boundary check. Needs to know the

433+-- number of bits in advance.

434+data Block a = Block Int (S -> a)

435+

436+instance Functor Block where

437+ fmap f (Block i p) = Block i (\s -> f (p s))

438+

439+instance Applicative Block where

440+ pure a = Block 0 (\_ -> a)

441+ (Block i p) <*> (Block j q) = Block (i+j) (\s -> p s $ q (incS i s))

442+ (Block i _) *> (Block j q) = Block (i+j) (q . incS i)

443+ (Block i p) <* (Block j _) = Block (i+j) p

444+

445+-- | Get a block. Will be read with one single boundry check, and

446+-- therefore requires a statically known number of bits.

447+-- Build blocks using 'bool', 'word8', 'word16be', 'word32be', 'word64be',

448+-- 'byteString' and 'Applicative'.

449+block :: Block a -> BitGet a

450+block (Block i p) = do

451+ ensureBits i

452+ s <- getState

453+ putState $! (incS i s)

458− else return (S bs o, False)

454+ return $! p s

459

455

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

456-- | Read a 1 bit 'Bool'.

461bool :: Block Bool

457bool :: Block Bool

462bool = Block 1 readBool

458bool = Block 1 readBool

463

459

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

461+bool# :: Block Int

462+bool# = Block 1 readBool#

463+

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

465word8 :: Int -> Block Word8

466−word8 n = Block n (readWord8 n)

466+word8 n = Block n (readWordChecked 8 n)

467

468-- | Read @n@ bits as a 'Word16'. @n@ must be within @[0..16]@.

469+word16 :: Int -> Block Word16

470+word16 n = Block n (readWordChecked 16 n)

471+

469word16be :: Int -> Block Word16

472word16be :: Int -> Block Word16

470−word16be n = Block n (readWord16be n)

473+word16be = word16

474+{-# DEPRECATED word16be "Use 'word16' instead" #-}

471

475

472-- | Read @n@ bits as a 'Word32'. @n@ must be within @[0..32]@.

476-- | Read @n@ bits as a 'Word32'. @n@ must be within @[0..32]@.

477+word32 :: Int -> Block Word32

478+word32 n = Block n (readWordChecked 32 n)

479+

473word32be :: Int -> Block Word32

480word32be :: Int -> Block Word32

474−word32be n = Block n (readWord32be n)

481+word32be = word32

482+{-# DEPRECATED word32be "Use 'word32' instead" #-}

475

483

476-- | Read @n@ bits as a 'Word64'. @n@ must be within @[0..64]@.

484-- | Read @n@ bits as a 'Word64'. @n@ must be within @[0..64]@.

485+word64 :: Int -> Block Word64

486+word64 n = Block n (readWordChecked 64 n)

487+

477word64be :: Int -> Block Word64

488word64be :: Int -> Block Word64

478−word64be n = Block n (readWord64be n)

489+word64be = word64

490+{-# DEPRECATED word64be "Use 'word64' instead" #-}

479

491

480-- | Read @n@ bytes as a 'ByteString'.

492-- | Read @n@ bytes as a 'ByteString'.

481byteString :: Int -> Block ByteString

493byteString :: Int -> Block ByteString

482byteString n | n > 0 = Block (n*8) (readByteString n)

494byteString n | n > 0 = Block (n*8) (readByteString n)

483 | otherwise = Block 0 (\_ -> B.empty)

495 | otherwise = Block 0 (\_ -> B.empty)

484

496

485−------------------------------------------------------------------------

486−-- Unchecked shifts, from the package binary

487−

488−shiftl_w16 :: Word16 -> Int -> Word16

489−shiftl_w32 :: Word32 -> Int -> Word32

490−shiftl_w64 :: Word64 -> Int -> Word64

491−

492−shiftr_w8 :: Word8 -> Int -> Word8

493−shiftr_w16 :: Word16 -> Int -> Word16

494−shiftr_w32 :: Word32 -> Int -> Word32

495−shiftr_w64 :: Word64 -> Int -> Word64

496−

497−#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)

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

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

500−

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

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

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

504−

505−

506−#if WORD_SIZE_IN_BITS < 64

507−shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i)

508−shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL64#` i)

509−

510−#if __GLASGOW_HASKELL__ <= 606

511−-- Exported by GHC.Word in GHC 6.8 and higher

512−foreign import ccall unsafe "stg_uncheckedShiftL64"

513− uncheckedShiftL64# :: Word64# -> Int# -> Word64#

514−foreign import ccall unsafe "stg_uncheckedShiftRL64"

515− uncheckedShiftRL64# :: Word64# -> Int# -> Word64#

516−#endif

517−

518−#else

519−shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i)

520−shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL#` i)

521−#endif

522−

523−#else

524−shiftl_w16 = shiftL

525−shiftl_w32 = shiftL

526−shiftl_w64 = shiftL

527−

528−shiftr_w8 = shiftR

529−shiftr_w16 = shiftR

530−shiftr_w32 = shiftR

531−shiftr_w64 = shiftR

532−#endif

Data/Binary/Bits/Internal.hsnew file+176

@@ -0,0 +1,176 @@

1+{-# LANGUAGE RankNTypes, MagicHash, BangPatterns, CPP #-}

3+-----------------------------------------------------------------------------

4+-- |

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

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

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

8+--

9+-- Maintainer : kolmodin@gmail.com

10+-- Stability : experimental

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

12+

13+module Data.Binary.Bits.Internal

14+ ( make_mask

15+ , make_mask#

16+ , mask

17+ , mask#

18+ , bit_offset

19+ , byte_offset

20+ , reverseBits

21+ , reverseBits#

22+ , FastBits(..)

23+ )

24+where

25+

26+import Data.Word

27+import Data.Bits

28+

29+#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)

30+import GHC.Base

31+import GHC.Word

32+#endif

33+

34+-- | make_mask 3 = 00000111

35+make_mask :: (Bits a, Num a) => Int -> a

36+make_mask n = (1 `shiftL` fromIntegral n) - 1

37+{-# SPECIALIZE make_mask :: Int -> Int #-}

38+{-# SPECIALIZE make_mask :: Int -> Word #-}

39+{-# SPECIALIZE make_mask :: Int -> Word8 #-}

40+{-# SPECIALIZE make_mask :: Int -> Word16 #-}

41+{-# SPECIALIZE make_mask :: Int -> Word32 #-}

42+{-# SPECIALIZE make_mask :: Int -> Word64 #-}

43+

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

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

46+

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

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

49+mask n v = v .&. make_mask n

50+{-# INLINE mask #-}

51+

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+

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

57+bit_offset :: Int -> Int

58+bit_offset n = make_mask 3 .&. n

59+{-# INLINE bit_offset #-}

60+

61+-- | Compute byte offset (equivalent to x `div` 8 but faster)

62+byte_offset :: Int -> Int

63+byte_offset n = n `shiftR` 3

64+{-# INLINE byte_offset #-}

65+

66+-- | Reverse the @n@ least important bits of the given value

67+reverseBits :: (Num a, FastBits a, Bits a) => Int -> a -> a

68+reverseBits n value = rec value n 0

69+ where

70+ -- rec v i r, where

71+ -- v is orginal value shifted

72+ -- i is the remaining number of bits

73+ -- r is current value

74+ rec 0 0 r = r

75+ rec 0 i r = r `fastShiftL` i

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

77+

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+

89+

90+---------------------------------------------------------------------

91+-- Unchecked shifts, from the "binary" package

92+

93+-- | Class for types supporting fast bit shifting

94+class Bits a => FastBits a where

95+ fastShiftR :: a -> Int -> a

96+ fastShiftR = shiftR

97+

98+ fastShiftL :: a -> Int -> a

99+ fastShiftL = shiftL

100+

101+ {-# INLINE fastShift #-}

102+ fastShift :: a -> Int -> a

103+ fastShift x n

104+ | n > 0 = fastShiftL x n

105+ | n < 0 = fastShiftR x (negate n)

106+ | otherwise = x

107+

108+instance FastBits Word8 where

109+ fastShiftR = shiftr_w8

110+ fastShiftL = shiftl_w8

111+

112+instance FastBits Word16 where

113+ fastShiftR = shiftr_w16

114+ fastShiftL = shiftl_w16

115+

116+instance FastBits Word32 where

117+ fastShiftR = shiftr_w32

118+ fastShiftL = shiftl_w32

119+

120+instance FastBits Word64 where

121+ fastShiftR = shiftr_w64

122+ fastShiftL = shiftl_w64

123+

124+instance FastBits Int

125+

126+instance FastBits Word

127+

128+

129+shiftl_w8 :: Word8 -> Int -> Word8

130+shiftl_w16 :: Word16 -> Int -> Word16

131+shiftl_w32 :: Word32 -> Int -> Word32

132+shiftl_w64 :: Word64 -> Int -> Word64

133+

134+shiftr_w8 :: Word8 -> Int -> Word8

135+shiftr_w16 :: Word16 -> Int -> Word16

136+shiftr_w32 :: Word32 -> Int -> Word32

137+shiftr_w64 :: Word64 -> Int -> Word64

138+

139+#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)

140+shiftl_w8 w i = w `unsafeShiftL` i

141+shiftl_w16 w i = w `unsafeShiftL` i

142+shiftl_w32 w i = w `unsafeShiftL` i

143+

144+shiftr_w8 w i = w `unsafeShiftR` i

145+shiftr_w16 w i = w `unsafeShiftR` i

146+shiftr_w32 w i = w `unsafeShiftR` i

147+

148+

149+#if WORD_SIZE_IN_BITS < 64

150+shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i)

151+shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL64#` i)

152+

153+#if __GLASGOW_HASKELL__ <= 606

154+-- Exported by GHC.Word in GHC 6.8 and higher

155+foreign import ccall unsafe "stg_uncheckedShiftL64"

156+ uncheckedShiftL64# :: Word64# -> Int# -> Word64#

157+foreign import ccall unsafe "stg_uncheckedShiftRL64"

158+ uncheckedShiftRL64# :: Word64# -> Int# -> Word64#

159+#endif

160+

161+#else

162+shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i)

163+shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL#` i)

164+#endif

165+

166+#else

167+shiftl_w8 = shiftL

168+shiftl_w16 = shiftL

169+shiftl_w32 = shiftL

170+shiftl_w64 = shiftL

171+

172+shiftr_w8 = shiftR

173+shiftr_w16 = shiftR

174+shiftr_w32 = shiftR

175+shiftr_w64 = shiftR

176+#endif

Data/Binary/Bits/Put.hs+186−76

@@ -1,7 +1,10 @@

1+{-# LANGUAGE MagicHash #-}

1-----------------------------------------------------------------------------

3-----------------------------------------------------------------------------

2-- |

4-- |

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

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

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

6-- Copyright : (c) Lennart Kolmodin 2010-2011

7+-- (c) Sylvain Henry 2015

5-- License : BSD3-style (see LICENSE)

8-- License : BSD3-style (see LICENSE)

6--

9--

7-- Maintainer : kolmodin@gmail.com

10-- Maintainer : kolmodin@gmail.com

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

19 -- * Data types

22 -- * Data types

20 -- ** Bool

23 -- ** Bool

21 , putBool

24 , putBool

25+ , putBool#

23 -- ** Words

27 -- ** Words

28+ , putWord#

24 , putWord8

29 , putWord8

30+ , putWord16

31+ , putWord32

32+ , putWord64

25 , putWord16be

33 , putWord16be

26 , putWord32be

34 , putWord32be

27 , putWord64be

35 , putWord64be

@@ -35,125 +43,210 @@ import qualified Data.Binary.Builder as B

35import Data.Binary.Builder ( Builder )

43import Data.Binary.Builder ( Builder )

36import qualified Data.Binary.Put as Put

44import qualified Data.Binary.Put as Put

37import Data.Binary.Put ( Put )

45import Data.Binary.Put ( Put )

46+import Data.Binary.Bits.Internal

47+import Data.Binary.Bits.BitOrder

48+import Data.Binary.Bits.Alignment

39−import Data.ByteString

50+import Data.ByteString as BS

51+import Data.ByteString.Unsafe as BS

41−import Control.Applicative

53+import Control.Monad (when)

42import Data.Bits

54import Data.Bits

43−import Data.Monoid

44import Data.Word

55import Data.Word

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

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

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

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

48data PairS a = PairS a {-# UNPACK #-} !S

61data PairS a = PairS a {-# UNPACK #-} !S

50−data S = S !Builder !Word8 !Int

63+data S = S !Builder !Word8 !Int !BitOrder

52-- | Put a 1 bit 'Bool'.

65-- | Put a 1 bit 'Bool'.

53putBool :: Bool -> BitPut ()

66putBool :: Bool -> BitPut ()

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

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

56−-- | make_mask 3 = 00000111

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

57−make_mask :: (Bits a, Num a) => Int -> a

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

58−make_mask n = (1 `shiftL` fromIntegral n) - 1

71+putBool# b = putWord# 1# b

59−{-# SPECIALIZE make_mask :: Int -> Int #-}

72+

60−{-# SPECIALIZE make_mask :: Int -> Word #-}

73+

61−{-# SPECIALIZE make_mask :: Int -> Word8 #-}

74+-- | Generic putWord

62−{-# SPECIALIZE make_mask :: Int -> Word16 #-}

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

63−{-# SPECIALIZE make_mask :: Int -> Word32 #-}

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

64−{-# SPECIALIZE make_mask :: Int -> Word64 #-}

77+

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

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

80+

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

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

83+ where

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

85+ cn = min (8-o) n

86+

87+ -- new state

88+ s' = case n of

89+ 0 -> s

90+ _ -> putWordS (n-cn) w' (flush (S builder b' (o+cn) bo))

91+

92+ -- new current byte

93+ b' = shl (selectBits w) .|. b

94+

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

96+ w' = case bo of

97+ BB -> w

98+ BL -> w `fastShiftR` cn

99+ LL -> w `fastShiftR` cn

100+ LB -> w

101+

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

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

104+ -- bits of the returned value

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

106+ selectBits x = fromIntegral $ case bo of

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

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

109+ LL -> mask cn x

110+ BL -> reverseBits cn $ mask cn x

111+

112+ -- shift left at the correct position

113+ shl :: Word8 -> Word8

114+ shl x = case bo of

115+ BB -> x `fastShiftL` (8-o-cn)

116+ BL -> x `fastShiftL` (8-o-cn)

117+ 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+

171

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

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

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

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

68−putWord8 n w = BitPut $ \s -> PairS () $

174+putWord8 = putWord

69− let w' = make_mask n .&. w in

70− case s of

71− -- a whole word8, no offset

72− (S b t o) | n == 8 && o == 0 -> flush $ S b w n

73− -- less than a word8, will fit in the current word8

74− | n <= 8 - o -> flush $ S b (t .|. (w' `shiftL` (8 - n - o))) (o+n)

75− -- will finish this word8, and spill into the next one

76− | otherwise -> flush $

77− let o' = o + n - 8

78− b' = t .|. (w' `shiftR` o')

79− t' = w `shiftL` (8 - o')

80− in S (b `mappend` B.singleton b') t' o'

175

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

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

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

178+putWord16 = putWord

179+

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

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

84−putWord16be n w

181+putWord16be = putWord

85− | n <= 8 = putWord8 n (fromIntegral w)

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

86− | otherwise =

87− BitPut $ \s -> PairS () $

88− let w' = make_mask n .&. w in

89− case s of

90− -- as n>=9, it's too big to fit into one single byte

91− -- it'll either use 2 or 3 bytes

92− -- it'll fit in 2 bytes

93− (S b t o) | o + n <= 16 -> flush $

94− let o' = o + n - 8

95− b' = t .|. fromIntegral (w' `shiftR` o')

96− t' = fromIntegral (w `shiftL` (8-o'))

97− in (S (b `mappend` B.singleton b') t' o')

98− -- 3 bytes required

99− | otherwise -> flush $

100− let o' = o + n - 16

101− b' = t .|. fromIntegral (w' `shiftR` (o' + 8))

102− b'' = fromIntegral ((w `shiftR` o') .&. 0xff)

103− t' = fromIntegral (w `shiftL` (8-o'))

104− in (S (b `mappend` B.singleton b' `mappend` B.singleton b'') t' o')

105

183

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

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

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

186+putWord32 = putWord

187+

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

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

108−putWord32be n w

189+putWord32be = putWord

109− | n <= 16 = putWord16be n (fromIntegral w)

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

110− | otherwise = do

111− putWord32be (n-16) (w`shiftR`16)

112− putWord32be 16 (w .&. 0x0000ffff)

113

191

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

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

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

194+putWord64 = putWord

195+

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

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

116−putWord64be n w

197+putWord64be = putWord

117− | n <= 32 = putWord32be n (fromIntegral w)

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

118− | otherwise = do

119− putWord64be (n-32) (w`shiftR`32)

120− putWord64be 32 (w .&. 0xffffffff)

121

199

122-- | Put a 'ByteString'.

200-- | 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

123putByteString :: ByteString -> BitPut ()

207putByteString :: ByteString -> BitPut ()

124−putByteString bs = do

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

125− offset <- hasOffset

209+

126− if offset

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

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

211+putByteStringS bs s

128− else joinPut (Put.putByteString bs)

212+ | BS.null bs = s

129− where

213+ | otherwise = case s of

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

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+

131

225

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

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

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

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

228+--

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

134joinPut :: Put -> BitPut ()

230joinPut :: Put -> BitPut ()

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

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

136− let (S b0 _ _) = flushIncomplete s0

232+ let (S b0 _ _ bo) = flushIncomplete s0

137 b = Put.execPut m

233 b = Put.execPut m

138− in (S (b0`mappend`b) 0 0)

234+ in (S (b0`mappend`b) 0 0 bo)

139−

140−flush :: S -> S

141−flush s@(S b w o)

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

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

144− | otherwise = s

145

235

146flushIncomplete :: S -> S

236flushIncomplete :: S -> S

147−flushIncomplete s@(S b w o)

237+flushIncomplete s@(S b w o bo)

148 | o == 0 = s

238 | o == 0 = s

149− | otherwise = (S (b `mappend` B.singleton w) 0 0)

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

240+

241+getOffset :: BitPut Int

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

150

243

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

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

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

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

153runBitPut m = Put.putBuilder b

246runBitPut m = Put.putBuilder b

154 where

247 where

155− PairS _ s = run m (S mempty 0 0)

248+ PairS _ s = run m (S mempty 0 0 BB)

156− (S b _ _) = flushIncomplete s

249+ (S b _ _ _) = flushIncomplete s

157

250

158instance Functor BitPut where

251instance Functor BitPut where

159 fmap f (BitPut k) = BitPut $ \s ->

252 fmap f (BitPut k) = BitPut $ \s ->

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

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

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

174 in PairS b s''

267 in PairS b s''

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

268 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+6−2

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

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

2name: binary-bits

3−version: 0.5

3+version: 0.6

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

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

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

@@ -24,7 +24,10 @@ library

25 exposed-modules: Data.Binary.Bits ,

26 Data.Binary.Bits.Put ,

27− Data.Binary.Bits.Get

27+ Data.Binary.Bits.Get ,

28+ Data.Binary.Bits.BitOrder ,

29+ Data.Binary.Bits.Alignment

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

29 default-language: Haskell98

32 default-language: Haskell98

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

34 type: exitcode-stdio-1.0

37 type: exitcode-stdio-1.0

35 main-is: BitsQC.hs

38 main-is: BitsQC.hs

36 default-language: Haskell98

39 default-language: Haskell98

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

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

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

39 QuickCheck>=2, random,

43 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