master..68ad583 · binary-bits

git.iko.soy/binary-bits

on 68ad583 help sign in

.gitignore−1

since splitsnapshots

unifiedsplit

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

1.cabal-sandbox

2cabal.sandbox.config

3dist/

4−.stack-work

BitsQC.hs+41−74

@@ -9,7 +9,6 @@ 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

14import qualified Data.ByteString as B

13import qualified Data.ByteString as B

15import qualified Data.ByteString.Lazy as L

14import qualified Data.ByteString.Lazy as L

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

18import Data.Bits

17import Data.Bits

19import Data.Word

18import Data.Word

20import Foreign.Storable

19import Foreign.Storable

21−import Data.Traversable (traverse)

20+import System.Random

22−import Data.Foldable (traverse_)

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

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

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

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

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

38 [ testProperty "prop_composite_case" prop_composite_case ]

36 [ testProperty "prop_composite_case" prop_composite_case ]

40 , testGroup "getByteString"

38 , testGroup "getByteString"

41− [ testProperty "prop_getByteString_negative" prop_getByteString_negative

39+ [ 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− ]

46 , testGroup "getLazyByteString"

41 , testGroup "getLazyByteString"

47 [ testProperty "getLazyByteString == getByteString"

42 [ testProperty "getLazyByteString == getByteString"

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

89 ]

84 ]

91 , testGroup "prop_put_with_bitreq"

86 , testGroup "prop_put_with_bitreq"

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

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

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

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

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

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

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

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

96 ]

91 ]

98 , testGroup "prop_putget_list_simple"

93 , testGroup "prop_putget_list_simple"

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

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

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

118 ]

113 ]

119 , testGroup "prop_bitget_bytestring_interspersed"

114 , testGroup "prop_bitget_bytestring_interspersed"

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

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

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

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

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

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

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

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

124 ]

119 ]

125 , testGroup "Simulate programs"

120 , testGroup "Simulate programs"

126 [ testProperty "primitive" prop_primitive

121 [ testProperty "primitive" prop_primitive

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

163 n < 1 ==>

158 n < 1 ==>

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

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

165

160

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

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

182−prop_putget_with_bitreq bo (W w) = property $

162+prop_putget_with_bitreq (W w) = property $

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

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

184 let p = putBits (bitreq w) w

164 let p = putBits (bitreq w) w

185 g = getBits (bitreq w)

165 g = getBits (bitreq w)

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

166+ lbs = runPut (runBitPut p)

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

167+ w' = runGet (runBitGet g) lbs

188 in w == w'

168 in w == w'

189

169

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

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

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

246 in ws == ws'

226 in ws == ws'

247

227

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

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

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

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

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

230+prop_bitget_bytestring_interspersed (W ws) bss = property $

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

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

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

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

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

233+ lbs = runPut (runBitPut p)

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

234+ r = runGet (runBitGet g) lbs

255 in map (ws,) bss == r

235 in map (ws,) bss == r

256

236

257-- | Test failing.

237-- | Test failing.

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

261 expectedBytesConsumed

241 expectedBytesConsumed

262 | bits == 0 = bytes

242 | bits == 0 = bytes

263 | otherwise = bytes + 1

243 | otherwise = bytes + 1

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

244+ p = do getByteString (fromIntegral bytes)

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

245+ getBits (fromIntegral bits) :: BitGet Word8

266 fail errMsg0

246 fail errMsg0

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

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

268 in case r of

248 in case r of

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

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

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

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

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

290 let p = do putBool b

270 let p = do putBool b

291− putWord16 15 w

271+ putWord16be 15 w

292 g = do v <- getBool

272 g = do v <- getBool

293 case v of

273 case v of

294− True -> getWord16 15

274+ True -> getWord16be 15

295 False -> do

275 False -> do

296 msb <- getWord8 7

276 msb <- getWord8 7

297 lsb <- getWord8 8

277 lsb <- getWord8 8

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

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

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

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

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

396

376

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+

397data Primitive

382data Primitive

398 = Bool Bool

383 = Bool Bool

399 | W8 Int Word8

384 | W8 Int Word8

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

402 | W64 Int Word64

387 | W64 Int Word64

403 | BS Int B.ByteString

388 | BS Int B.ByteString

404 | LBS Int L.ByteString

389 | LBS Int L.ByteString

405− | Skip Int

406 | IsEmpty

390 | IsEmpty

407 deriving (Eq, Show)

391 deriving (Eq, Show)

408

392

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

411instance Arbitrary Primitive where

395instance Arbitrary Primitive where

412 arbitrary = do

396 arbitrary = do

413 let gen c = do

397 let gen c = do

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

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

415 bits <- choose (0, maxBits)

399 bits <- choose (0, maxBits)

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

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

417 return (c bits n)

401 return (c bits n)

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

421 , gen W16

405 , gen W16

422 , gen W32

406 , gen W32

423 , gen W64

407 , gen W64

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

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

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

426 cs <- vector n

409 cs <- vector n

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

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

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

438 W16 _ x -> snk W16 x

421 W16 _ x -> snk W16 x

439 W32 _ x -> snk W32 x

422 W32 _ x -> snk W32 x

440 W64 _ x -> snk W64 x

423 W64 _ x -> snk W64 x

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

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

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

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

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

444 IsEmpty -> []

426 IsEmpty -> []

445

427

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−

454prop_primitive :: Primitive -> Property

428prop_primitive :: Primitive -> Property

455prop_primitive prim = property $

429prop_primitive prim = property $

456 let p = putPrimitive prim

430 let p = putPrimitive prim

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

472 case p of

446 case p of

473 Bool b -> putBool b

447 Bool b -> putBool b

474 W8 n x -> putWord8 n x

448 W8 n x -> putWord8 n x

475− W16 n x -> putWord16 n x

449+ W16 n x -> putWord16be n x

476− W32 n x -> putWord32 n x

450+ W32 n x -> putWord32be n x

477− W64 n x -> putWord64 n x

451+ W64 n x -> putWord64be n x

478− Skip n -> skipBits n

479 BS _ bs -> putByteString bs

452 BS _ bs -> putByteString bs

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

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

481 IsEmpty -> return ()

454 IsEmpty -> return ()

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

485 case p of

458 case p of

486 Bool _ -> Bool <$> getBool

459 Bool _ -> Bool <$> getBool

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

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

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

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

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

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

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

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

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

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

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

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

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

494 IsEmpty -> isEmpty >> return IsEmpty

466 IsEmpty -> isEmpty >> return IsEmpty

495

467

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

507

468

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

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

509verifyProgram totalLength ps0 = go 0 ps0

470verifyProgram totalLength ps0 = go 0 ps0

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

511 go _ [] = return True

472 go _ [] = return True

512 go pos (p:ps) =

473 go pos (p:ps) =

513 case p of

474 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

514 IsEmpty -> do

482 IsEmpty -> do

515 let expected = pos == totalLength

483 let expected = pos == totalLength

516 actual <- isEmpty

484 actual <- isEmpty

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

518 then go pos ps

486 then go pos ps

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

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

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

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

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

522 check x g = do

489 check x g = do

523 y <- g

490 y <- g

524 if x == y

491 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 = putWord16

36+ putBits = putWord16be

37− getBits = getWord16

37+ getBits = getWord16be

39instance BinaryBit Word32 where

40− putBits = putWord32

40+ putBits = putWord32be

41− getBits = getWord32

41+ getBits = getWord32be

43instance BinaryBit Word64 where

44− putBits = putWord64

44+ putBits = putWord64be

45− getBits = getWord64

45+ getBits = getWord64be

Data/Binary/Bits/Alignment.hsdeleted−22

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

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.hsdeleted−47

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

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+256−211

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

4-- |

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

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

7−-- (c) Sylvain Henry 2015

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

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

9--

8--

10-- Maintainer : kolmodin@gmail.com

9-- Maintainer : kolmodin@gmail.com

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

61 -- ** Get bytes

60 -- ** Get bytes

62 , getBool

61 , getBool

63− , getBool#

64 , getWord8

62 , getWord8

65− , getWord16

66− , getWord32

67− , getWord64

68 , getWord16be

63 , getWord16be

69 , getWord32be

64 , getWord32be

70 , getWord64be

65 , getWord64be

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

82 -- ** Read in Blocks

77 -- ** Read in Blocks

83 , bool

78 , bool

84 , word8

79 , word8

85− , word16

86− , word32

87− , word64

88 , word16be

80 , word16be

89 , word32be

81 , word32be

90 , word64be

82 , word64be

@@ -97,9 +89,6 @@ module Data.Binary.Bits.Get

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

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

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

91import 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

104import Data.ByteString as B

93import Data.ByteString as B

105import qualified Data.ByteString.Lazy as L

94import qualified Data.ByteString.Lazy as L

@@ -115,8 +104,12 @@ import Control.Applicative

115import Control.Monad (when,foldM_)

104import Control.Monad (when,foldM_)

116

105

117import Prelude as P

106import Prelude as P

107+

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

109+import GHC.Base

118import GHC.Word

110import GHC.Word

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

111+#endif

112+

120

113

121-- $bitget

114-- $bitget

122-- Parse bits using a monad.

115-- Parse bits using a monad.

@@ -165,120 +158,197 @@ import GHC.Base (uncheckedShiftLWord8#, wordToWord8#, Int (..), andWord8#, Word8

165-- @

158-- @

166

159

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

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

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

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

169− !BitOrder -- Bit order

170 deriving (Show)

162 deriving (Show)

171

163

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

165+-- number of bits in advance.

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

167+

168+instance Functor Block where

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

170+

171+instance Applicative Block where

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

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

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

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

176+

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

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

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

180+-- 'byteString' and 'Applicative'.

181+block :: Block a -> BitGet a

182+block (Block i p) = do

183+ ensureBits i

184+ s <- getState

185+ putState $! (incS i s)

186+ return $! p s

187+

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

189+bit_offset :: Int -> Int

190+bit_offset n = make_mask 3 .&. n

191+{-# INLINE bit_offset #-}

192+

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

194+byte_offset :: Int -> Int

195+byte_offset n = n `shiftR` 3

196+{-# INLINE byte_offset #-}

197+

172-- | Increment the current bit offset

198-- | Increment the current bit offset

173incS :: Int -> S -> S

199incS :: Int -> S -> S

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

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

175 where

201 where

176 !o' = (n+o)

202 !o' = (n+o)

177 !d = byte_offset o'

203 !d = byte_offset o'

178 !n' = bit_offset o'

204 !n' = bit_offset o'

179

205

180−-- | Read a single bit

206+-- | make_mask 3 = 00000111

181−readBool :: S -> Bool

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

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

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

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

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

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

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

185− LL -> testBit (unsafeHead bs) o

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

186− LB -> testBit (unsafeHead bs) o

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

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

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

215+

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

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

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

219+{-# INLINE mask #-}

220+

221+class FastBits a where

222+ fastShiftR :: a -> Int -> a

223+ fastShiftL :: a -> Int -> a

224+

225+ {-# INLINE fastShift #-}

226+ fastShift :: a -> Int -> a

227+ fastShift x n

228+ | n > 0 = fastShiftL x n

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

230+ | otherwise = x

231+

232+instance FastBits Word8 where

233+ fastShiftR = shiftr_w8

234+ fastShiftL = shiftl_w8

235+

236+instance FastBits Word16 where

237+ fastShiftR = shiftr_w16

238+ fastShiftL = shiftl_w16

239+

240+instance FastBits Word32 where

241+ fastShiftR = shiftr_w32

242+ fastShiftL = shiftl_w32

243+

244+instance FastBits Word64 where

245+ fastShiftR = shiftr_w64

246+ fastShiftL = shiftl_w64

247+

248+-- | Bit order

249+--

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

251+-- - BB: ABCDEVWX YZxxxxxx

252+-- - LB: XYZABCDE xxxxxxVW

253+-- - BL: EDCBAZYX WVxxxxxx -- not implemented

254+-- - LL: XWVEDCBA xxxxxxZY -- not implemented

255+data BitOrder = BB | LB

187

256

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

257

258+-- | Read a single bit

259+readBool :: BitOrder -> S -> Bool

260+readBool BB (S bs n) = testBit (unsafeHead bs) (7-n)

261+readBool LB (S bs n) = testBit (unsafeHead bs) n

199

262

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

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

201--

264--

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

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

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

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

204extract bo bs o n

267extract bo bs o n

205 | n == 0 = 0

268 | n == 0 = 0

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

269 | B.length bs == 0 = error "Empty ByteString"

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

270+ | otherwise = mask n (foldlWithIndex' f 0 bs)

208 where

271 where

209− -- B.foldl' with index

272+ -- foldl' with index

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

273+ foldlWithIndex' f b = fst . B.foldl' g (b,0)

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

274+ where g (b,i) w = (f b w i, (i+1))

212

275

213 -- 'or' correctly shifted words

276 -- 'or' correctly shifted words

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

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

215

278

216 -- co-offset

279 -- co-offset

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

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

218

281

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

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

220− off i = case bo of

283+ off i = case bo of

221− LL -> 8*i - o

222 LB -> 8*i - o

284 LB -> 8*i - o

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

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

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

225−

226− -- reverse bits if necessary

227− rev = case bo of

228− LB -> reverseBits n

229− BL -> reverseBits n

230− BB -> id

231− LL -> id

232

286

233

287

234-- | Generic readWord

288-- | Generic readWord

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

289+readWord :: (Num a, Bits a, FastBits a) => BitOrder -> Int -> S -> a

236−readWord n (S bs o bo)

290+readWord bo n (S bs o)

237 | n == 0 = 0

291 | n == 0 = 0

292+ | o+n <= 8 = extract bo (unsafeTake 1 bs) o n

293+ | o+n <= 16 = extract bo (unsafeTake 2 bs) o n

294+ | o+n <= 24 = extract bo (unsafeTake 3 bs) o n

295+ | o+n <= 32 = extract bo (unsafeTake 4 bs) o n

296+ | o+n <= 40 = extract bo (unsafeTake 5 bs) o n

297+ | o+n <= 48 = extract bo (unsafeTake 6 bs) o n

298+ | o+n <= 56 = extract bo (unsafeTake 7 bs) o n

299+ | o+n <= 64 = extract bo (unsafeTake 8 bs) o n

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

300+ | otherwise = extract bo (unsafeTake ((o+n+7) `div` 8) bs) o n

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

301+

240−

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

242−{-# INLINE readWordChecked #-}

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

302+readWordChecked :: (Num a, Bits a, FastBits a) => Int -> BitOrder -> Int -> S -> a

244−readWordChecked m n s

303+readWordChecked m bo n s

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

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

246− | otherwise = readWord n s

305+ | otherwise = readWord bo n s

247

306

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

307+{-# INLINE readWord8 #-}

249−--

308+readWord8 :: BitOrder -> Int -> S -> Word8

250−-- Examples:

309+readWord8 = readWordChecked 8

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

310+

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

311+{-# INLINE readWord16 #-}

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

312+readWord16 :: BitOrder -> Int -> S -> Word16

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

313+readWord16 = readWordChecked 16

255−readByteString :: Int -> S -> ByteString

314+

256−readByteString n (S bs o bo) =

315+{-# INLINE readWord32 #-}

257− let

316+readWord32 :: BitOrder -> Int -> S -> Word32

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

317+readWord32 = readWordChecked 32

259− bs'' = unsafeTake n bs

260− rev = B.map (reverseBits 8)

261− in case (o,bo) of

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)

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

270− let len = n+1

271− ptr <- mallocBytes len

272− let f r i = do

273− let

274− w = unsafeIndex bs (len-i)

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

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

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

278− return r'

279− foldM_ f 0 [1..len]

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

281

318

319+{-# INLINE readWord64 #-}

320+readWord64 :: BitOrder -> Int -> S -> Word64

321+readWord64 = readWordChecked 64

322+

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

324+readByteString :: BitOrder -> Int -> S -> ByteString

325+readByteString bo n (S bs o)

326+ | o == 0 = unsafeTake n bs

327+ | otherwise = unsafePerformIO $ do

328+ let len = n+1

329+ ptr <- mallocBytes len

330+ case bo of

331+ BB -> do

332+ let f r i = do

333+ let

334+ w = unsafeIndex bs (len-i)

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

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

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

338+ return r'

339+ foldM_ f 0 [1..len]

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

341+

342+ LB -> do

343+ let f r i = do

344+ let

345+ w = unsafeIndex bs (i-1)

346+ w' = (w `fastShiftL` (8-o)) .|. r

347+ r' = w `fastShiftR` o

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

349+ return r'

350+ foldM_ f 0 [1..len]

351+ unsafeTail <$> unsafePackMallocCStringLen (ptr,len)

282

352

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

353------------------------------------------------------------------------

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

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

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

287

357

288instance Monad BitGet where

358instance Monad BitGet where

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

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

360+ fail str = B $ \(S inp n) -> putBackState inp n >> fail str

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

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

291 runState (g a) s'

362 runState (g a) s'

292

363

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

297 pure x = return x

368 pure x = return x

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

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

299

370

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−

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

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

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

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

325runBitGet :: BitGet a -> Get a

373runBitGet :: BitGet a -> Get a

326runBitGet bg = do

374runBitGet bg = do

327 s <- mkInitState

375 s <- mkInitState

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

376+ ((S str' n),a) <- runState bg s

329− putBackState s'

377+ putBackState str' n

330 return a

378 return a

331

379

332mkInitState :: Get S

380mkInitState :: Get S

333mkInitState = do

381mkInitState = do

334− bs <- get

382+ str <- get

335 put B.empty

383 put B.empty

336− return (S bs 0 BB)

384+ return (S str 0)

337

385

338−putBackState :: S -> Get ()

386+putBackState :: B.ByteString -> Int -> Get ()

339−putBackState (S bs o _) = do

387+putBackState bs n = do

340 remaining <- get

388 remaining <- get

341− let bs' = case o of

342− 0 -> bs

343− _ -> unsafeDrop 1 bs

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

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

345

390

346getState :: BitGet S

391getState :: BitGet S

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

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

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

349putState :: S -> BitGet ()

394putState :: S -> BitGet ()

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

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

351

396

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

353−withState f = do

354− s <- getState

355− putState $! f s

356−

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

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

358ensureBits :: Int -> BitGet ()

398ensureBits :: Int -> BitGet ()

359ensureBits n = do

399ensureBits n = do

360− (S bs o bo) <- getState

400+ (S bs o) <- getState

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

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

362 then return ()

402 then return ()

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

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

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

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

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

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

366 bs' <- B.get

406 bs' <- B.get

367 put B.empty

407 put B.empty

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

408+ return (S (bs`append`bs') o, ())

369

409

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

410+-- | Skip the given number of bits

371−-- undecoded bytes.

411+skipBits :: Int -> BitGet ()

372−isEmpty :: BitGet Bool

412+skipBits n = do

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

413+ ensureBits n

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

414+ s <- getState

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

415+ putState $! (incS n s)

416+

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

418+alignByte :: BitGet ()

419+alignByte = do

420+ (S _ n) <- getState

421+ when (n /= 0) $

422+ skipBits (8-n)

376

423

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

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

378getBool :: BitGet Bool

425getBool :: BitGet Bool

379getBool = block bool

426getBool = block bool

380

427

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

382−getBool# :: BitGet Int

383−getBool# = block bool#

384−

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

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

386getWord8 :: Int -> BitGet Word8

429getWord8 :: Int -> BitGet Word8

387getWord8 n = block (word8 n)

430getWord8 n = block (word8 n)

388

431

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

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

390−getWord16 :: Int -> BitGet Word16

391−getWord16 n = block (word16 n)

392−

393getWord16be :: Int -> BitGet Word16

433getWord16be :: Int -> BitGet Word16

394−getWord16be = getWord16

434+getWord16be n = block (word16be n)

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

396

435

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

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

398−getWord32 :: Int -> BitGet Word32

399−getWord32 n = block (word32 n)

400−

401getWord32be :: Int -> BitGet Word32

437getWord32be :: Int -> BitGet Word32

402−getWord32be = getWord32

438+getWord32be n = block (word32be n)

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

404

439

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

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

406−getWord64 :: Int -> BitGet Word64

407−getWord64 n = block (word64 n)

408−

409getWord64be :: Int -> BitGet Word64

441getWord64be :: Int -> BitGet Word64

410−getWord64be = getWord64

442+getWord64be n = block (word64be n)

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

412

443

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

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

414getByteString :: Int -> BitGet ByteString

445getByteString :: Int -> BitGet ByteString

@@ -417,80 +448,94 @@ getByteString n = block (byteString n)

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

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

418getLazyByteString :: Int -> BitGet L.ByteString

449getLazyByteString :: Int -> BitGet L.ByteString

419getLazyByteString n = do

450getLazyByteString n = do

420− (S _ o bo) <- getState

451+ (S _ o) <- getState

421 case o of

452 case o of

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

453+ 0 -> B $ \ (S bs o') -> do

423− putBackState s

454+ putBackState bs o'

424 lbs <- B.getLazyByteString (fromIntegral n)

455 lbs <- B.getLazyByteString (fromIntegral n)

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

456+ return (S B.empty 0, lbs)

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

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

427

458

428−

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

429−

460+-- undecoded bytes.

430−

461+isEmpty :: BitGet Bool

431−

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

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

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

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)

454− return $! p s

464+ else return (S bs o, False)

455

465

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

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

457bool :: Block Bool

467bool :: Block Bool

458−bool = Block 1 readBool

468+bool = Block 1 (readBool BB)

459−

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

461−bool# :: Block Int

462−bool# = Block 1 readBool#

463

469

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

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

465word8 :: Int -> Block Word8

471word8 :: Int -> Block Word8

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

472+word8 n = Block n (readWord8 BB n)

467

473

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

474-- | 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−

472word16be :: Int -> Block Word16

475word16be :: Int -> Block Word16

473−word16be = word16

476+word16be n = Block n (readWord16 BB n)

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

475

477

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

478-- | 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−

480word32be :: Int -> Block Word32

479word32be :: Int -> Block Word32

481−word32be = word32

480+word32be n = Block n (readWord32 BB n)

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

483

481

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

482-- | 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−

488word64be :: Int -> Block Word64

483word64be :: Int -> Block Word64

489−word64be = word64

484+word64be n = Block n (readWord64 BB n)

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

491

485

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

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

493byteString :: Int -> Block ByteString

487byteString :: Int -> Block ByteString

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

488+byteString n | n > 0 = Block (n*8) (readByteString BB n)

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

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

496

490

491+------------------------------------------------------------------------

492+-- Unchecked shifts, from the package binary

493+

494+shiftl_w8 :: Word8 -> Int -> Word8

495+shiftl_w16 :: Word16 -> Int -> Word16

496+shiftl_w32 :: Word32 -> Int -> Word32

497+shiftl_w64 :: Word64 -> Int -> Word64

498+

499+shiftr_w8 :: Word8 -> Int -> Word8

500+shiftr_w16 :: Word16 -> Int -> Word16

501+shiftr_w32 :: Word32 -> Int -> Word32

502+shiftr_w64 :: Word64 -> Int -> Word64

503+

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

505+shiftl_w8 (W8# w) (I# i) = W8# (w `uncheckedShiftL#` i)

506+shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#` i)

507+shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i)

508+

509+shiftr_w8 (W8# w) (I# i) = W8# (w `uncheckedShiftRL#` i)

510+shiftr_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftRL#` i)

511+shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i)

512+

513+

514+#if WORD_SIZE_IN_BITS < 64

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

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

517+

518+#if __GLASGOW_HASKELL__ <= 606

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

520+foreign import ccall unsafe "stg_uncheckedShiftL64"

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

522+foreign import ccall unsafe "stg_uncheckedShiftRL64"

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

524+#endif

525+

526+#else

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

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

529+#endif

530+

531+#else

532+shiftl_w8 = shiftL

533+shiftl_w16 = shiftL

534+shiftl_w32 = shiftL

535+shiftl_w64 = shiftL

536+

537+shiftr_w8 = shiftR

538+shiftr_w16 = shiftR

539+shiftr_w32 = shiftR

540+shiftr_w64 = shiftR

541+#endif

Data/Binary/Bits/Internal.hsdeleted−176

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

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

2−

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+76−186

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

1−{-# LANGUAGE MagicHash #-}

2−

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

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

4-- |

2-- |

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

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

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

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

7−-- (c) Sylvain Henry 2015

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

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

9--

6--

10-- Maintainer : kolmodin@gmail.com

7-- Maintainer : kolmodin@gmail.com

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

22 -- * Data types

19 -- * Data types

23 -- ** Bool

20 -- ** Bool

24 , putBool

21 , putBool

25− , putBool#

27 -- ** Words

23 -- ** Words

28− , putWord#

29 , putWord8

24 , putWord8

30− , putWord16

31− , putWord32

32− , putWord64

33 , putWord16be

25 , putWord16be

34 , putWord32be

26 , putWord32be

35 , putWord64be

27 , putWord64be

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

43import Data.Binary.Builder ( Builder )

35import Data.Binary.Builder ( Builder )

44import qualified Data.Binary.Put as Put

36import qualified Data.Binary.Put as Put

45import Data.Binary.Put ( Put )

37import Data.Binary.Put ( Put )

46−import Data.Binary.Bits.Internal

47−import Data.Binary.Bits.BitOrder

48−import Data.Binary.Bits.Alignment

50−import Data.ByteString as BS

39+import Data.ByteString

51−import Data.ByteString.Unsafe as BS

53−import Control.Monad (when)

41+import Control.Applicative

54import Data.Bits

42import Data.Bits

43+import Data.Monoid

55import Data.Word

44import Data.Word

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

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

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

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

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

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

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

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

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

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

66putBool :: Bool -> BitPut ()

53putBool :: Bool -> BitPut ()

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

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

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

56+-- | make_mask 3 = 00000111

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

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

71−putBool# b = putWord# 1# b

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

72−

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

73−

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

74−-- | Generic putWord

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

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

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

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

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

77−

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

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

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

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

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

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

174−putWord8 = putWord

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

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

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

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

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

178−putWord16 = putWord

179−

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

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

181−putWord16be = putWord

84+putWord16be n w

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

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

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

183

105

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

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

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

186−putWord32 = putWord

187−

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

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

189−putWord32be = putWord

108+putWord32be n w

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

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

110+ | otherwise = do

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

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

191

113

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

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

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

194−putWord64 = putWord

195−

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

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

197−putWord64be = putWord

116+putWord64be n w

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

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

118+ | otherwise = do

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

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

199

121

200-- | Put a 'ByteString'.

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

207putByteString :: ByteString -> BitPut ()

123putByteString :: ByteString -> BitPut ()

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

124+putByteString bs = do

209−

125+ offset <- hasOffset

210−putByteStringS :: ByteString -> S -> S

126+ if offset

211−putByteStringS bs s

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

212− | BS.null bs = s

128+ else joinPut (Put.putByteString bs)

213− | otherwise = case s of

129+ where

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

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

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−

225

131

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

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

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

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

228−--

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

230joinPut :: Put -> BitPut ()

134joinPut :: Put -> BitPut ()

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

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

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

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

233 b = Put.execPut m

137 b = Put.execPut m

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

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

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

235

145

236flushIncomplete :: S -> S

146flushIncomplete :: S -> S

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

147+flushIncomplete s@(S b w o)

238 | o == 0 = s

148 | o == 0 = s

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

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

240−

241−getOffset :: BitPut Int

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

243

150

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

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

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

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

246runBitPut m = Put.putBuilder b

153runBitPut m = Put.putBuilder b

247 where

154 where

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

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

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

156+ (S b _ _) = flushIncomplete s

250

157

251instance Functor BitPut where

158instance Functor BitPut where

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

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

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

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

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

267 in PairS b s''

174 in PairS b s''

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

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

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

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

2name: binary-bits

3−version: 0.6

3+version: 0.5.1

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,10 +24,7 @@ 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

32 default-language: Haskell98

29 default-language: Haskell98

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

37 type: exitcode-stdio-1.0

34 type: exitcode-stdio-1.0

38 main-is: BitsQC.hs

35 main-is: BitsQC.hs

39 default-language: Haskell98

36 default-language: Haskell98

40− --ghc-options: -O2 -Wall

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

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

43 QuickCheck>=2, random,

39 QuickCheck>=2, random,

flake.lockdeleted−59

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

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.nixdeleted−24

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

1−{

2− inputs = {

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

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

5− };

6−

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.yamldeleted−66

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

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/

6−

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.lockdeleted−12

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

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

5−

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