8449c3d..master · binary-bits

git.iko.soy/binary-bits

on master help sign in

.gitignorenew file+4

since splitsnapshots

unifiedsplit

@@ -0,0 +1,4 @@

1+.cabal-sandbox

2+cabal.sandbox.config

3+dist/

4+.stack-work

.travis.ymlnew file+41

@@ -0,0 +1,41 @@

1+# NB: don't set `language: haskell` here

2+# See https://github.com/hvr/multi-ghc-travis for more information

4+env:

5+ - CABALVER=1.18 GHCVER=7.4.2

6+ - CABALVER=1.18 GHCVER=7.6.3

7+ - CABALVER=1.18 GHCVER=7.8.3

8+ - CABALVER=1.22 GHCVER=7.10.1

10+before_install:

11+ - sudo add-apt-repository -y ppa:hvr/ghc

12+ - sudo apt-get update

13+ - sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER

14+ - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH

15+

16+install:

17+ - cabal update

18+ - cabal sandbox init

19+ - cabal install --only-dependencies --enable-tests --enable-benchmarks

20+

21+script:

22+ - cabal configure --enable-tests --enable-benchmarks -v2

23+ - cabal build

24+ - cabal test

25+# "cabal check" disabled due to -O2 warning

26+# - cabal check

27+ - cabal sdist

28+# check that the generated source-distribution can be built & installed

29+ - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ;

30+ cd dist/;

31+ cabal sandbox init;

32+ if [ -f "$SRC_TGZ" ]; then

33+ cabal install --force-reinstalls "$SRC_TGZ";

34+ else

35+ echo "expected '$SRC_TGZ' not found";

36+ exit 1;

37+ fi

38+

39+notifications:

40+ email:

41+ - kolmodin@gmail.com

BitsQC.hs+324−73

@@ -1,33 +1,32 @@

1−{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}

1+{-# LANGUAGE CPP, FlexibleInstances, FlexibleContexts, TupleSections #-}

3−module Main where

3+module Main ( main ) where

5−import Data.Binary ( encode, Binary(..) )

5+import Data.Binary ( Binary(..) )

6−import Data.Binary.Get ( runGet )

6+import Data.Binary.Get ( runGet, runGetIncremental, pushChunks, Decoder(..) )

7import Data.Binary.Put ( runPut )

9−import qualified Data.Binary.Get as BG ( getWord8, getWord16be, getWord32be, getWord64be )

10−import qualified Data.Binary.Put as BP ( putWord8, putWord16be, putWord32be, putWord64be )

11−

12import Data.Binary.Bits

9import Data.Binary.Bits

13import Data.Binary.Bits.Get

10import Data.Binary.Bits.Get

14import Data.Binary.Bits.Put

11import Data.Binary.Bits.Put

12+import Data.Binary.Bits.BitOrder

13+

14+import qualified Data.ByteString as B

15+import qualified Data.ByteString.Lazy as L

16import Control.Applicative

17import Control.Applicative

17import Data.Bits

18import Data.Bits

18−import Data.Monoid

19import Data.Word

20import Foreign.Storable

21−import System.Random

21+import Data.Traversable (traverse)

22−import System

22+import Data.Foldable (traverse_)

24−import Test.Framework.Options ( TestOptions'(..) )

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

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

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

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

27−import Test.Framework.Runners.Options ( RunnerOptions'(..) )

28import Test.Framework ( Test, testGroup )

26import Test.Framework ( Test, testGroup )

29import Test.QuickCheck

27import Test.QuickCheck

29+main :: IO ()

31main = defaultMain tests

30main = defaultMain tests

33tests :: [Test]

32tests :: [Test]

@@ -38,6 +37,29 @@ tests =

38 , testGroup "Custom test cases"

37 , testGroup "Custom test cases"

39 [ testProperty "prop_composite_case" prop_composite_case ]

38 [ testProperty "prop_composite_case" prop_composite_case ]

40+ , testGroup "getByteString"

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

45+

46+ , testGroup "getLazyByteString"

47+ [ testProperty "getLazyByteString == getByteString"

48+ prop_getLazyByteString_equal_to_ByteString

49+ , testProperty "getLazyByteString == getByteString (with shift)"

50+ prop_getLazyByteString_equal_to_ByteString2

51+ ]

52+

53+ , testGroup "isEmpty"

54+ [ testProperty "prop_isEmptyOfEmptyEmpty" prop_isEmptyOfEmptyEmpty

55+ , testProperty "prop_isEmptyOfNonEmptyEmpty" prop_isEmptyOfNonEmptyEmpty

56+ , testProperty "prop_isEmptyOfConsumedEmpty" prop_isEmptyOfConsumedEmpty

57+ , testProperty "prop_isEmptyOfNotConsumedNotEmpty" prop_isEmptyOfNotConsumedNotEmpty

58+ ]

59+

60+ , testGroup "Fail"

61+ [ testProperty "monadic fail" prop_fail ]

62+

41 , testGroup "prop_bitput_with_get_from_binary"

63 , testGroup "prop_bitput_with_get_from_binary"

42 [ testProperty "Word8" (prop_bitput_with_get_from_binary :: W [Word8] -> Property)

64 [ testProperty "Word8" (prop_bitput_with_get_from_binary :: W [Word8] -> Property)

43 , testProperty "Word16" (prop_bitput_with_get_from_binary :: W [Word16] -> Property)

65 , testProperty "Word16" (prop_bitput_with_get_from_binary :: W [Word16] -> Property)

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

67 ]

89 ]

69 , testGroup "prop_put_with_bitreq"

91 , testGroup "prop_put_with_bitreq"

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

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

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

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

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

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

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

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

74 ]

96 ]

76 , testGroup "prop_putget_list_simple"

98 , testGroup "prop_putget_list_simple"

@@ -81,28 +103,88 @@ tests =

81 , testProperty "Word64" (prop_putget_list_simple :: W [Word64] -> Property)

103 , testProperty "Word64" (prop_putget_list_simple :: W [Word64] -> Property)

82 ]

104 ]

105

106+ , testGroup "prop_putget_applicative_with_bitreq"

107+ [ testProperty "Word8" (prop_putget_applicative_with_bitreq :: W [(Word8,Word8,Word8)] -> Property)

108+ , testProperty "Word16" (prop_putget_applicative_with_bitreq :: W [(Word16,Word16,Word16)] -> Property)

109+ , testProperty "Word32" (prop_putget_applicative_with_bitreq :: W [(Word32,Word32,Word32)] -> Property)

110+ , testProperty "Word64" (prop_putget_applicative_with_bitreq :: W [(Word64,Word64,Word64)] -> Property)

111+ ]

112+

84 , testGroup "prop_putget_list_with_bitreq"

113 , testGroup "prop_putget_list_with_bitreq"

85 [ testProperty "Word8" (prop_putget_list_with_bitreq :: W [Word8] -> Property)

114 [ testProperty "Word8" (prop_putget_list_with_bitreq :: W [Word8] -> Property)

86 , testProperty "Word16" (prop_putget_list_with_bitreq :: W [Word16] -> Property)

115 , testProperty "Word16" (prop_putget_list_with_bitreq :: W [Word16] -> Property)

87 , testProperty "Word32" (prop_putget_list_with_bitreq :: W [Word32] -> Property)

116 , testProperty "Word32" (prop_putget_list_with_bitreq :: W [Word32] -> Property)

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

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

118+ ]

119+ , testGroup "prop_bitget_bytestring_interspersed"

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

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

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

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

124+ ]

125+ , testGroup "Simulate programs"

126+ [ testProperty "primitive" prop_primitive

127+ , testProperty "many primitives in sequence" prop_program

89 ]

128 ]

90 ]

129 ]

130

92−{-

131+prop_isEmptyOfEmptyEmpty :: Bool

93− -- these tests use the R structure

132+prop_isEmptyOfEmptyEmpty = runGet (runBitGet isEmpty) L.empty

94− --

133+

95− -- quickCheck prop_Word32_from_2_Word16

134+prop_isEmptyOfNonEmptyEmpty :: L.ByteString -> Property

96− -- quickCheck prop_Word32_from_Word8_and_Word16

135+prop_isEmptyOfNonEmptyEmpty bs =

97−-}

136+ not (L.null bs) ==> not (runGet (runBitGet isEmpty) bs)

98−

137+

138+prop_isEmptyOfConsumedEmpty :: L.ByteString -> Property

139+prop_isEmptyOfConsumedEmpty bs =

140+ not (L.null bs) ==>

141+ runGet (runBitGet (getByteString n >> isEmpty)) bs

142+ where n = fromIntegral $ L.length bs

143+

144+prop_isEmptyOfNotConsumedNotEmpty :: L.ByteString -> Int -> Property

145+prop_isEmptyOfNotConsumedNotEmpty bs n =

146+ (fromIntegral n) < L.length bs && not (L.null bs) ==>

147+ not (runGet (runBitGet (getByteString n >> isEmpty)) bs)

148+

149+prop_getLazyByteString_equal_to_ByteString :: L.ByteString -> Int -> Property

150+prop_getLazyByteString_equal_to_ByteString bs n =

151+ (fromIntegral n) <= L.length bs ==>

152+ runGet (runBitGet (getLazyByteString (fromIntegral n))) bs ==

153+ (L.fromChunks . (:[]) $ runGet (runBitGet (getByteString n)) bs)

154+

155+prop_getLazyByteString_equal_to_ByteString2 :: L.ByteString -> Int -> Property

156+prop_getLazyByteString_equal_to_ByteString2 bs n =

157+ (L.length bs > 1) && (fromIntegral n) < L.length bs ==>

158+ runGet (runBitGet (getWord8 2 >> getLazyByteString (fromIntegral n))) bs ==

159+ (L.fromChunks . (:[]) $ runGet (runBitGet (getWord8 2 >> getByteString n)) bs)

160+

161+prop_getByteString_negative :: Int -> Property

162+prop_getByteString_negative n =

163+ n < 1 ==>

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

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+

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

100−prop_putget_with_bitreq (W w) = property $

182+prop_putget_with_bitreq bo (W w) = property $

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

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

102 let p = putBits (bitreq w) w

184 let p = putBits (bitreq w) w

103 g = getBits (bitreq w)

185 g = getBits (bitreq w)

104− lbs = runPut (runBitPut p)

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

105− w' = runGet (runBitGetSimple g) lbs

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

106 in w == w'

188 in w == w'

107

189

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

@@ -110,10 +192,10 @@ prop_putget_with_bitreq (W w) = property $

110prop_putget_list_simple :: (BinaryBit a, Eq a, Storable a) => W [a] -> Property

192prop_putget_list_simple :: (BinaryBit a, Eq a, Storable a) => W [a] -> Property

111prop_putget_list_simple (W ws) = property $

193prop_putget_list_simple (W ws) = property $

112 let s = sizeOf (head ws) * 8

194 let s = sizeOf (head ws) * 8

113− p = mapM_ (\v -> putBits s v) ws

195+ p = mapM_ (putBits s) ws

114 g = mapM (const (getBits s)) ws

196 g = mapM (const (getBits s)) ws

115 lbs = runPut (runBitPut p)

197 lbs = runPut (runBitPut p)

116− ws' = runGet (runBitGetSimple g) lbs

198+ ws' = runGet (runBitGet g) lbs

117 in ws == ws'

199 in ws == ws'

118

200

119-- | Write a list of items. Each item is written with exactly as many bits

201-- | Write a list of items. Each item is written with exactly as many bits

@@ -124,11 +206,23 @@ prop_putget_list_with_bitreq (W ws) = property $

124 let p = mapM_ (\v -> putBits (bitreq v) v) ws

206 let p = mapM_ (\v -> putBits (bitreq v) v) ws

125 g = mapM getBits bitlist

207 g = mapM getBits bitlist

126 lbs = runPut (runBitPut p)

208 lbs = runPut (runBitPut p)

127− ws' = runGet (runBitGetSimple g) lbs

209+ ws' = runGet (runBitGet g) lbs

128 in ws == ws'

210 in ws == ws'

129 where

211 where

130 bitlist = map bitreq ws

212 bitlist = map bitreq ws

131

213

214+prop_putget_applicative_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => W [(a,a,a)] -> Property

215+prop_putget_applicative_with_bitreq (W ts) = property $

216+ let p = mapM_ (\(a,b,c) -> do putBits (bitreq a) a

217+ putBits (bitreq b) b

218+ putBits (bitreq c) c) ts

219+ g = mapM (\(a,b,c) -> (,,) <$> getBits a <*> getBits b <*> getBits c) bitlist

220+ lbs = runPut (runBitPut p)

221+ ts' = runGet (runBitGet g) lbs

222+ in ts == ts'

223+ where

224+ bitlist = map (\(a,b,c) -> (bitreq a, bitreq b, bitreq c)) ts

225+

132-- | Write bits using this library, and read them back using the binary

226-- | Write bits using this library, and read them back using the binary

133-- library.

227-- library.

134prop_bitput_with_get_from_binary :: (BinaryBit a, Binary a, Storable a, Eq a) => W [a] -> Property

228prop_bitput_with_get_from_binary :: (BinaryBit a, Binary a, Storable a, Eq a) => W [a] -> Property

@@ -148,38 +242,65 @@ prop_bitget_with_put_from_binary (W ws) = property $

148 p = mapM_ put ws

242 p = mapM_ put ws

149 g = mapM (const (getBits s)) ws

243 g = mapM (const (getBits s)) ws

150 lbs = runPut p

244 lbs = runPut p

151− ws' = runGet (runBitGetSimple g) lbs

245+ ws' = runGet (runBitGet g) lbs

152 in ws == ws'

246 in ws == ws'

153

247

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

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

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

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

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

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

255+ in map (ws,) bss == r

256+

257+-- | Test failing.

258+prop_fail :: L.ByteString -> String -> Property

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

260+ let (bytes,bits) = len `divMod` 8

261+ expectedBytesConsumed

262+ | bits == 0 = bytes

263+ | otherwise = bytes + 1

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

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

266+ fail errMsg0

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

268+ in case r of

269+ Fail remainingBS pos errMsg ->

270+ and [ L.fromChunks [remainingBS] == L.drop expectedBytesConsumed lbs

271+ , pos == expectedBytesConsumed

272+ , errMsg == errMsg0

273+ ]

274+ _ -> False

275+

154−-- number of bits required to write 'v'

276+-- | number of bits required to write @v@

155−bitreq :: (Num b, Bits a, Ord a) => a -> b

277+bitreq :: (Num b, Num a, Bits a, Ord a) => a -> b

156bitreq v = fromIntegral . head $ [ req | (req, top) <- bittable, v <= top ]

278bitreq v = fromIntegral . head $ [ req | (req, top) <- bittable, v <= top ]

157

279

158−bittable :: Bits a => [(Integer, a)]

280+bittable :: (Bits a, Num a) => [(Integer, a)]

159bittable = [ (fromIntegral x, (1 `shiftL` x) - 1) | x <- [1..64] ]

281bittable = [ (fromIntegral x, (1 `shiftL` x) - 1) | x <- [1..64] ]

160

282

161prop_bitreq :: W Word64 -> Property

283prop_bitreq :: W Word64 -> Property

162prop_bitreq (W w) = property $

284prop_bitreq (W w) = property $

163 ( w == 0 && bitreq w == 1 )

285 ( w == 0 && bitreq w == 1 )

164− || bitreq w == (bitreq (w `shiftR` 1)) + 1

286+ || bitreq w == bitreq (w `shiftR` 1) + 1

165

287

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

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

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

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

168 let p = do putBool b

290 let p = do putBool b

169− putWord16be 15 w

291+ putWord16 15 w

170 g = do v <- getBool

292 g = do v <- getBool

171 case v of

293 case v of

172− True -> getWord16be 15

294+ True -> getWord16 15

173 False -> do

295 False -> do

174 msb <- getWord8 7

296 msb <- getWord8 7

175 lsb <- getWord8 8

297 lsb <- getWord8 8

176 return ((fromIntegral msb `shiftL` 8) .|. fromIntegral lsb)

298 return ((fromIntegral msb `shiftL` 8) .|. fromIntegral lsb)

177 lbs = runPut (runBitPut p)

299 lbs = runPut (runBitPut p)

178− w' = runGet (runBitGetSimple g) lbs

300+ w' = runGet (runBitGet g) lbs

179 in w == w'

301 in w == w'

180

302

181−

182−prop_compare_put_with_naive :: (Bits a, BinaryBit a, Ord a) => W [a] -> Property

303+prop_compare_put_with_naive :: (Bits a, BinaryBit a, Ord a, Num a) => W [a] -> Property

183prop_compare_put_with_naive (W ws) = property $

304prop_compare_put_with_naive (W ws) = property $

184 let pn = mapM_ (\v -> naive_put (bitreq v) v) ws

305 let pn = mapM_ (\v -> naive_put (bitreq v) v) ws

185 p = mapM_ (\v -> putBits (bitreq v) v) ws

306 p = mapM_ (\v -> putBits (bitreq v) v) ws

@@ -193,10 +314,10 @@ prop_compare_get_with_naive (W ws) = property $

193 g = mapM (\v -> getBits (bitreq v)) ws

314 g = mapM (\v -> getBits (bitreq v)) ws

194 p = mapM_ (\v -> naive_put (bitreq v) v) ws

315 p = mapM_ (\v -> naive_put (bitreq v) v) ws

195 lbs = runPut (runBitPut p)

316 lbs = runPut (runBitPut p)

196− rn = runGet (runBitGetSimple gn) lbs

317+ rn = runGet (runBitGet gn) lbs

197− r = runGet (runBitGetSimple g ) lbs

318+ r = runGet (runBitGet g ) lbs

198 -- we must help our compiler to resolve the types of 'gn' and 'g'

319 -- we must help our compiler to resolve the types of 'gn' and 'g'

199− types = rn == ws && r == ws

320+ _types = rn == ws && r == ws

200 in rn == r

321 in rn == r

201

322

202-- | Write one bit at a time until the full word has been written

323-- | Write one bit at a time until the full word has been written

@@ -214,27 +335,6 @@ naive_get n0 =

214 True -> loop (n-1) ((acc `shiftL` 1) + 1)

335 True -> loop (n-1) ((acc `shiftL` 1) + 1)

215 in loop n0 0

336 in loop n0 0

216

337

217−{-

218−prop_Word32_from_Word8_and_Word16 :: Word8 -> Word16 -> Property

219−prop_Word32_from_Word8_and_Word16 w8 w16 = property $

220− let p = RWord32be 24

221− w' = runGet (get p) lbs

222− in w0 == w'

223− where

224− lbs = runPut (putWord8 w8 >> putWord16be w16)

225− w0 = ((fromIntegral w8) `shiftL` 16) .|. fromIntegral w16

226−

227−prop_Word32_from_2_Word16 :: Word16 -> Word16 -> Property

228−prop_Word32_from_2_Word16 w1 w2 = property $

229− let p = RWord32be 32

230− w' = runGet (get p) lbs

231− in w0 == w'

232− where

233− lbs = encode w0

234− w0 = ((fromIntegral w1) `shiftL` 16) .|. fromIntegral w2

235−-}

236−

237−

238shrinker :: (Num a, Ord a, Bits a) => a -> [a]

338shrinker :: (Num a, Ord a, Bits a) => a -> [a]

239shrinker 0 = []

339shrinker 0 = []

240shrinker w = [ w `shiftR` 1 -- try to make everything roughly half size

340shrinker w = [ w `shiftR` 1 -- try to make everything roughly half size

@@ -248,14 +348,16 @@ shrinker w = [ w `shiftR` 1 -- try to make everything roughly half size

248

348

249data W a = W { unW :: a } deriving (Show, Eq, Ord)

349data W a = W { unW :: a } deriving (Show, Eq, Ord)

250

350

351+arbitraryW :: (Arbitrary (W a)) => Gen a

352+arbitraryW = unW <$> arbitrary

353+

354+shrinkW :: (Arbitrary (W a)) => a -> [a]

355+shrinkW x = unW <$> shrink (W x)

356+

251instance Arbitrary (W Bool) where

357instance Arbitrary (W Bool) where

252 arbitrary = W <$> arbitrary

358 arbitrary = W <$> arbitrary

253 shrink = map W <$> shrink . unW

359 shrink = map W <$> shrink . unW

254

360

255−instance (Arbitrary (W a)) => Arbitrary (W [a]) where

256− arbitrary = W . map unW <$> arbitrary

257− shrink = map (W . map unW) <$> mapM shrink . map W . unW

258−

259instance Arbitrary (W Word8) where

361instance Arbitrary (W Word8) where

260 arbitrary = W <$> choose (minBound, maxBound)

362 arbitrary = W <$> choose (minBound, maxBound)

261 shrink = map W . shrinker . unW

363 shrink = map W . shrinker . unW

@@ -272,11 +374,159 @@ instance Arbitrary (W Word64) where

272 arbitrary = W <$> choose (minBound, maxBound)

374 arbitrary = W <$> choose (minBound, maxBound)

273 shrink = map W . shrinker . unW

375 shrink = map W . shrinker . unW

274

376

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

377+instance Arbitrary B.ByteString where

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

378+ arbitrary = B.pack <$> arbitrary

277− fromIntegral b :: Integer) g of

379+ shrink bs = B.pack <$> shrink (B.unpack bs)

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

380+

381+instance Arbitrary L.ByteString where

382+ arbitrary = L.fromChunks <$> arbitrary

383+ shrink bs = L.fromChunks <$> shrink (L.toChunks bs)

279

384

385+instance (Arbitrary (W a)) => Arbitrary (W [a]) where

386+ arbitrary = W . map unW <$> arbitrary

387+ shrink = map (W . map unW) <$> mapM shrink . map W . unW

388+

389+instance (Arbitrary (W a), Arbitrary (W b)) => Arbitrary (W (a,b)) where

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

391+ shrink (W (a,b)) = (W .) . (,) <$> shrinkW a <*> shrinkW b

392+

393+instance (Arbitrary (W a), Arbitrary (W b), Arbitrary (W c)) => Arbitrary (W (a,b,c)) where

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

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

396+

397+data Primitive

398+ = Bool Bool

399+ | W8 Int Word8

400+ | W16 Int Word16

401+ | W32 Int Word32

402+ | W64 Int Word64

403+ | BS Int B.ByteString

404+ | LBS Int L.ByteString

405+ | Skip Int

406+ | IsEmpty

407+ deriving (Eq, Show)

408+

409+type Program = [Primitive]

410+

411+instance Arbitrary Primitive where

412+ arbitrary = do

413+ let gen c = do

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

415+ bits <- choose (0, maxBits)

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

417+ return (c bits n)

418+ oneof

419+ [ Bool <$> arbitrary

420+ , gen W8

421+ , gen W16

422+ , gen W32

423+ , gen W64

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

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

426+ cs <- vector n

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

428+ , do n <- choose (0,10)

429+ cs <- vector n

430+ return (LBS n (L.pack cs))

431+ , return IsEmpty

432+ ]

433+ shrink p =

434+ let snk c x = map (\x' -> c (bitreq x') x') (shrinker x) in

435+ case p of

436+ Bool b -> if b then [Bool False] else []

437+ W8 _ x -> snk W8 x

438+ W16 _ x -> snk W16 x

439+ W32 _ x -> snk W32 x

440+ 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)

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

444+ IsEmpty -> []

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+

454+prop_primitive :: Primitive -> Property

455+prop_primitive prim = property $

456+ let p = putPrimitive prim

457+ g = getPrimitive prim

458+ lbs = runPut (runBitPut p)

459+ r = runGet (runBitGet g) lbs

460+ in r == prim

461+

462+prop_program :: Program -> Property

463+prop_program program = property $

464+ let p = mapM_ putPrimitive program

465+ g = verifyProgram (8 * fromIntegral (L.length lbs)) program

466+ lbs = runPut (runBitPut p)

467+ r = runGet (runBitGet g) lbs

468+ in r

469+

470+putPrimitive :: Primitive -> BitPut ()

471+putPrimitive p =

472+ case p of

473+ Bool b -> putBool b

474+ W8 n x -> putWord8 n x

475+ W16 n x -> putWord16 n x

476+ W32 n x -> putWord32 n x

477+ W64 n x -> putWord64 n x

478+ Skip n -> skipBits n

479+ BS _ bs -> putByteString bs

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

481+ IsEmpty -> return ()

482+

483+getPrimitive :: Primitive -> BitGet Primitive

484+getPrimitive p =

485+ case p of

486+ Bool _ -> Bool <$> getBool

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

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

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

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

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

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

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

494+ IsEmpty -> isEmpty >> return IsEmpty

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

507+

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

509+verifyProgram totalLength ps0 = go 0 ps0

510+ where

511+ go _ [] = return True

512+ go pos (p:ps) =

513+ case p of

514+ IsEmpty -> do

515+ let expected = pos == totalLength

516+ actual <- isEmpty

517+ if expected == actual

518+ then go pos ps

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

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

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

522+ check x g = do

523+ y <- g

524+ if x == y

525+ then return ()

526+ else error $ "Roundtrip error: Expected "

527+ ++ show x ++ " but got " ++ show y

528+

529+{-

280instance Random Word where

530instance Random Word where

281 randomR = integralRandomR

531 randomR = integralRandomR

282 random = randomR (minBound,maxBound)

532 random = randomR (minBound,maxBound)

@@ -296,3 +546,4 @@ instance Random Word32 where

296instance Random Word64 where

546instance Random Word64 where

297 randomR = integralRandomR

547 randomR = integralRandomR

298 random = randomR (minBound,maxBound)

548 random = randomR (minBound,maxBound)

549+-}

Data/Binary/Bits.hs+21−6

@@ -1,3 +1,18 @@

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

2+-- |

3+-- Module : Data.Binary.Bits

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

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

6+--

7+-- Maintainer : kolmodin@gmail.com

8+-- Stability : experimental

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

10+--

11+-- Parse and write bits easily. Parsing can be done either in a monadic style, or more

12+-- efficiently, using the 'Applicative' style. Writing is monadic style only.

13+-- See "Data.Binary.Bits.Get" and "Data.Binary.Bits.Put", respectively.

14+-----------------------------------------------------------------------------

15+

1module Data.Binary.Bits where

16module Data.Binary.Bits where

3import Data.Binary.Bits.Get

18import Data.Binary.Bits.Get

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

18 getBits = getWord8

33 getBits = getWord8

20instance BinaryBit Word16 where

35instance BinaryBit Word16 where

21− putBits = putWord16be

36+ putBits = putWord16

22− getBits = getWord16be

37+ getBits = getWord16

24instance BinaryBit Word32 where

39instance BinaryBit Word32 where

25− putBits = putWord32be

40+ putBits = putWord32

26− getBits = getWord32be

41+ getBits = getWord32

28instance BinaryBit Word64 where

43instance BinaryBit Word64 where

29− putBits = putWord64be

44+ putBits = putWord64

30− 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+440−357

@@ -1,413 +1,496 @@

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

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

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

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)

9+--

10+-- Maintainer : kolmodin@gmail.com

11+-- Stability : experimental

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

13+--

14+-- Parse bits easily. Parsing can be done either in a monadic style, or more

15+-- efficiently, using the 'Applicative' style.

16+--

17+-- For the monadic style, write your parser as a 'BitGet' monad using the

18+--

19+-- * 'getBool'

20+--

21+-- * 'getWord8'

22+--

23+-- * 'getWord16be'

24+--

25+-- * 'getWord32be'

26+--

27+-- * 'getWord64be'

28+--

29+-- * 'getByteString'

30+--

31+-- functions and run it with 'runBitGet'.

32+--

33+-- For the applicative style, compose the fuctions

34+--

35+-- * 'bool'

36+--

37+-- * 'word8'

38+--

39+-- * 'word16be'

40+--

41+-- * 'word32be'

42+--

43+-- * 'word64be'

44+--

45+-- * 'byteString'

46+--

47+-- to make a 'Block'.

48+-- Use 'block' to turn it into the 'BitGet' monad to be able to run it with

49+-- 'runBitGet'.

50+-----------------------------------------------------------------------------

3module Data.Binary.Bits.Get

52module Data.Binary.Bits.Get

4− ( T(..)

53+ (

54+ -- * BitGet monad

55+

56+ -- $bitget

57+

58+ BitGet

5 , runBitGet

59 , runBitGet

6− , runBitGetSimple

7− , BitGet

61+ -- ** Get bytes

9 , getBool

62 , getBool

63+ , getBool#

10 , getWord8

64 , getWord8

65+ , getWord16

66+ , getWord32

67+ , getWord64

11 , getWord16be

68 , getWord16be

12 , getWord32be

69 , getWord32be

13 , getWord64be

70 , getWord64be

72+ -- ** Skip bits

73+ , skipBits

74+ , alignByte

75+

76+ -- * Blocks

77+

78+ -- $blocks

79+ , Block

80+ , block

81+

82+ -- ** Read in Blocks

83+ , bool

84+ , word8

85+ , word16

86+ , word32

87+ , word64

88+ , word16be

89+ , word32be

90+ , word64be

91+ , byteString

15 , Data.Binary.Bits.Get.getByteString

92 , Data.Binary.Bits.Get.getByteString

16−

93+ , Data.Binary.Bits.Get.getLazyByteString

17− , readBool

94+ , Data.Binary.Bits.Get.isEmpty

18− , readWord8

19− , readWord16be

21 ) where

96 ) where

23−import Data.Binary.Get as B ( runGet, Get, getByteString )

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

99+import 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

25import Data.ByteString as B

104import Data.ByteString as B

26−import Data.ByteString.Internal

27−import Data.ByteString.Unsafe

28−

29import qualified Data.ByteString.Lazy as L

105import qualified Data.ByteString.Lazy as L

106+import 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

31import Data.Bits

112import Data.Bits

32import Data.Word

113import Data.Word

33−import Data.List as List ( reverse )

34−

35import Control.Applicative

114import Control.Applicative

115+import Control.Monad (when,foldM_)

116

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

38−import GHC.Base

117+import Prelude as P

39import GHC.Word

118import GHC.Word

40−import GHC.Int

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

41−#endif

120+

42−

121+-- $bitget

43−data T a b = !a :*: !b deriving (Show)

122+-- Parse bits using a monad.

44−

123+--

124+-- @

125+--myBitParser :: 'Get' ('Word8', 'Word8')

126+--myBitParser = 'runGetBit' parse4by4

127+--

128+--parse4by4 :: 'BitGet' ('Word8', 'Word8')

129+--parse4by4 = do

130+-- bits <- 'getWord8' 4

131+-- more <- 'getWord8' 4

132+-- return (bits,more)

133+-- @

134+

135+-- $blocks

136+-- Parse more efficiently in blocks. Each block is read with only one boundry

137+-- check (checking that there is enough input) as the size of the block can be

138+-- calculated statically. This is somewhat limiting as you cannot make the

139+-- parsing depend on the input being parsed.

140+--

141+-- @

142+--data IPV6Header = IPV6Header {

143+-- ipv6Version :: 'Word8'

144+-- , ipv6TrafficClass :: 'Word8'

145+-- , ipv6FlowLabel :: 'Word32

146+-- , ipv6PayloadLength :: 'Word16'

147+-- , ipv6NextHeader :: 'Word8'

148+-- , ipv6HopLimit :: 'Word8'

149+-- , ipv6SourceAddress :: 'ByteString'

150+-- , ipv6DestinationAddress :: 'ByteString'

151+-- }

152+--

153+-- ipv6headerblock =

154+-- IPV6Header '<$>' 'word8' 4

155+-- '<*>' 'word8' 8

156+-- '<*>' 'word32be' 24

157+-- '<*>' 'word16be' 16

158+-- '<*>' 'word8' 8

159+-- '<*>' 'word8' 8

160+-- '<*>' 'byteString' 16

161+-- '<*>' 'byteString' 16

162+--

163+--ipv6Header :: 'Get' IPV6Header

164+--ipv6Header = 'runBitGet' ('block' ipv6headerblock)

165+-- @

166+

45−data S = S !ByteString -- ^ Input

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

46− !Int -- ^ Bit offset (0-7)

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

169+ !BitOrder -- Bit order

47 deriving (Show)

170 deriving (Show)

171

49−-- | make_mask 3 = 00000111

172+-- | Increment the current bit offset

50−make_mask :: Bits a => Int -> a

173+incS :: Int -> S -> S

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

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

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

175+ where

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

176+ !o' = (n+o)

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

177+ !d = byte_offset o'

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

178+ !n' = bit_offset o'

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

179+

57−

180+-- | Read a single bit

58−readBool :: S -> T Bool S

181+readBool :: S -> Bool

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

59−readBool s@(S bs n) = testBit (unsafeHead bs) (7-n) :*: incS s 1

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

60−

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

61−incS :: S -> Int -> S

185+ LL -> testBit (unsafeHead bs) o

62−incS (S bs n) 1 =

186+ LB -> testBit (unsafeHead bs) o

63− let

187+

64− n' = n + 1

188+-- | Read a single bit

65− s' | n' == 8 = S (unsafeTail bs) 0

189+readBool# :: S -> Int

66− | otherwise = S bs n'

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

67− in s'

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

68−incS (S bs n) o =

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

69− let (d,n') = divMod (n+o) 8

193+ LL -> testBit# o

70− in S (unsafeDrop d bs) n'

194+ LB -> testBit# o

71−

195+ where

72−readByteString :: S -> Int -> T ByteString S

196+ !(W8# w) = unsafeHead bs

73−readByteString s@(S bs o) n

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

74− | o == 0 = unsafeTake n bs :*: (S (unsafeDrop n bs) 0)

198+

75− | otherwise = unsafeTake n (unsafeTail bs) :*: (S (unsafeDrop (n+1) bs) 0)

199+

76−

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

77−readWord8 :: S -> Int -> T Word8 S

201+--

78−readWord8 s@(S bs o) n

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

79− -- no bits at all, return 0

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

80− | n == 0 = 0 :*: s

204+extract bo bs o n

81−

205+ | n == 0 = 0

82− -- all bits are in the same byte

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

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

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

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

208+ where

85− m = make_mask n

209+ -- B.foldl' with index

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

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

87− in w' :*: incS s n

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

88−

212+

89− -- the bits are in two different bytes

213+ -- 'or' correctly shifted words

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

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

91− | n <= 8 = let w = (fromIntegral (unsafeHead bs) `shiftl_w16` 8) .|.

215+

92− (fromIntegral (unsafeIndex bs 1))

216+ -- co-offset

93− m = make_mask n

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

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

218+

95− in fromIntegral w' :*: incS s n

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

96−

220+ off i = case bo of

97−bit_offset :: Int -> Int

221+ LL -> 8*i - o

98−bit_offset n = make_mask 3 .&. n

222+ LB -> 8*i - o

99−

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

100−byte_offset :: Int -> Int

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

101−byte_offset n = n `shiftR` 3

225+

102−

226+ -- reverse bits if necessary

103−readWord16be :: S -> Int -> T Word16 S

227+ rev = case bo of

104−readWord16be s@(S bs o) n

228+ LB -> reverseBits n

105−

229+ BL -> reverseBits n

106− -- 8 or fewer bits, use readWord8

230+ BB -> id

107− | n <= 8 = let w :*: s' = readWord8 s n

231+ LL -> id

108− in fromIntegral w :*: s'

232+

109−

233+

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

234+-- | Generic readWord

111−

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

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

236+readWord n (S bs o bo)

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

237+ | n == 0 = 0

114− lsb = fromIntegral (unsafeIndex bs 1)

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

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

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

116− in w :*: incS s n

240+

117−

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

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

242+{-# INLINE readWordChecked #-}

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

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

120− lsb = fromIntegral (unsafeIndex bs 1)

244+readWordChecked m n s

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

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

122− in w :*: incS s n

246+ | otherwise = readWord n s

123−

247+

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

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

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

249+--

126−

250+-- Examples:

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

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

128−

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

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

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

130− => S -> (a -> Int -> a) -> (a -> Int -> a) -> Int -> T a S

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

131−readWithoutOffset s@(S bs o) shifterL shifterR n

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

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

256+readByteString n (S bs o bo) =

133−

257+ let

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

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

135− let segs = byte_offset n

259+ bs'' = unsafeTake n bs

136− bn 0 = fromIntegral (unsafeHead bs)

260+ rev = B.map (reverseBits 8)

137− bn n = (bn (n-1) `shifterL` 8) .|. fromIntegral (unsafeIndex bs n)

261+ in case (o,bo) of

138−

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

139− in (bn (segs-1) :*: incS s n)

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

140−

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

141− | n <= 64 = let segs = byte_offset n

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

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

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

143−

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

144− bn 0 = fromIntegral (unsafeHead bs)

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

145− bn n = (bn (n-1) `shifterL` 8) .|. fromIntegral (unsafeIndex bs n)

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

146−

270+ let len = n+1

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

271+ ptr <- mallocBytes len

148−

272+ let f r i = do

149− last = (fromIntegral (unsafeIndex bs segs)) `shifterR` (8 - o')

273+ let

150−

274+ w = unsafeIndex bs (len-i)

151− w = msegs .|. last

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

152− in w :*: incS s n

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

153−

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

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

278+ return r'

155− => S -> (a -> Int -> a) -> (a -> Int -> a) -> Int -> T a S

279+ foldM_ f 0 [1..len]

156−readWithOffset s@(S bs o) shifterL shifterR n

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

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

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

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

160−

161− segs = byte_offset n'

162−

163− bn 0 = 0

164− bn 1 = fromIntegral (unsafeIndex bs 1)

165− bn n = (bn (n-1) `shifterL` 8) .|. fromIntegral (unsafeIndex bs n)

166−

167− o' = bit_offset n'

168−

169− mseg = bn segs `shifterL` o'

170−

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

172− | otherwise = 0

173−

174− w = top .|. mseg .|. last

175− in w :*: incS s n

176−

177−

178−readWord32be :: S -> Int -> T Word32 S

179−readWord32be s@(S bs o) n

180− -- 8 or fewer bits, use readWord8

181− | n <= 8 = let w :*: s' = readWord8 s n

182− in fromIntegral w :*: s'

183

281

184− -- 16 or fewer bits, use readWord16be

185− | n <= 16 = let w :*: s' = readWord16be s n

186− in fromIntegral w :*: s'

187

282

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

283+------------------------------------------------------------------------

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

285+-- for how to run it.

286+newtype BitGet a = B { runState :: S -> Get (S,a) }

189

287

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

288+instance Monad BitGet where

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

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

291+ runState (g a) s'

191

292

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

293+instance Functor BitGet where

294+ fmap f m = m >>= \a -> return (f a)

193

295

296+instance Applicative BitGet where

297+ pure x = return x

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

194

299

195−readWord64be :: S -> Int -> T Word64 S

300+instance BitOrderable BitGet where

196−readWord64be s@(S bs o) n

301+ setBitOrder bo = do

197− -- 8 or fewer bits, use readWord8

302+ (S bs o _) <- getState

198− | n <= 8 = let w :*: s' = readWord8 s n

303+ putState (S bs o bo)

199− in fromIntegral w :*: s'

200

304

201− -- 16 or fewer bits, use readWord16be

305+ getBitOrder = do

202− | n <= 16 = let w :*: s' = readWord16be s n

306+ (S _ _ bo) <- getState

203− in fromIntegral w :*: s'

307+ return bo

204

308

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

309+instance Alignable BitGet where

310+ -- | Skip the given number of bits

311+ skipBits n = do

312+ ensureBits n

313+ withState (incS n)

206

314

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

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)

208

320

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

210

321

211−------------------------------------------------------------------------

212−-- unrolled codensity/state monad

213−newtype BitGet a = C { runCont :: forall r.

214− S ->

215− Success a r ->

216− Get r }

217

322

218−type Success a r = S -> a -> Get r

323+-- | 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.

325+runBitGet :: BitGet a -> Get a

326+runBitGet bg = do

327+ s <- mkInitState

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

329+ putBackState s'

330+ return a

219

331

220−instance Monad BitGet where

332+mkInitState :: Get S

333+mkInitState = do

334+ bs <- get

335+ put B.empty

221− return x = C $ \s ks -> ks s x

336+ return (S bs 0 BB)

222− fail str = C $ \s ks -> fail str

223− (C c) >>= f = C $ \s ks -> c s (\s' a -> runCont (f a) s' ks)

224

337

225−instance Functor BitGet where

338+putBackState :: S -> Get ()

226− fmap f m = m >>= \a -> return (f a)

339+putBackState (S bs o _) = do

340+ remaining <- get

341+ let bs' = case o of

342+ 0 -> bs

343+ _ -> unsafeDrop 1 bs

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

227

345

228−instance Applicative BitGet where

346+getState :: BitGet S

229− pure x = return x

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

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

231

348

232−runBitGetSimple :: BitGet a -> Get a

349+putState :: S -> BitGet ()

233−runBitGetSimple bg = runBitGet bg

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

234

351

235−runBitGet :: BitGet a -> Get a

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

236−runBitGet bg = runCont bg (S B.empty 0) (\_s a -> return a)

353+withState f = do

354+ s <- getState

355+ putState $! f s

237

356

238−-- | Make sure there are at lest @n@ bits.

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

239ensureBits :: Int -> BitGet ()

358ensureBits :: Int -> BitGet ()

240−ensureBits n = C $ \s ks ->

359+ensureBits n = do

360+ (S bs o bo) <- getState

241− let loop (S bs o) | n <= (B.length bs * 8 - o) = ks (S bs o) ()

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

242− | otherwise = do

362+ then return ()

243− let currentBits = B.length bs * 8 - o

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

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

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

245− bs' <- B.getByteString byteCount

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

246− -- should always be enough going once throguh the loop

366+ bs' <- B.get

367+ put B.empty

247− loop (S (bs`append`bs') o)

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

248− in loop s

369+

249−

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

371+-- undecoded bytes.

372+isEmpty :: BitGet Bool

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

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

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

376+

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

250getBool :: BitGet Bool

378getBool :: BitGet Bool

251−getBool = ensureBits 1 >> modifyState readBool

379+getBool = block bool

252

380

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]@.

253getWord8 :: Int -> BitGet Word8

386getWord8 :: Int -> BitGet Word8

254−getWord8 n = ensureBits n >> modifyState (flip readWord8 n)

387+getWord8 n = block (word8 n)

388+

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

390+getWord16 :: Int -> BitGet Word16

391+getWord16 n = block (word16 n)

255

392

256getWord16be :: Int -> BitGet Word16

393getWord16be :: Int -> BitGet Word16

257−getWord16be n = ensureBits n >> modifyState (flip readWord16be n)

394+getWord16be = getWord16

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

396+

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

398+getWord32 :: Int -> BitGet Word32

399+getWord32 n = block (word32 n)

258

400

259getWord32be :: Int -> BitGet Word32

401getWord32be :: Int -> BitGet Word32

260−getWord32be n = ensureBits n >> modifyState (flip readWord32be n)

402+getWord32be = getWord32

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

404+

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

406+getWord64 :: Int -> BitGet Word64

407+getWord64 n = block (word64 n)

261

408

262getWord64be :: Int -> BitGet Word64

409getWord64be :: Int -> BitGet Word64

263−getWord64be n = ensureBits n >> modifyState (flip readWord64be n)

410+getWord64be = getWord64

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

264

412

265−-- | Get a @ByteString@. Drops the current byte if we've started to read

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

266−-- from it.

267getByteString :: Int -> BitGet ByteString

414getByteString :: Int -> BitGet ByteString

268−getByteString n = do

415+getByteString n = block (byteString n)

269− ensureBits (n*8)

416+

270− -- drop the first byte if we've started to use it

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

271− modifyState $ \s@(S bs o) ->

418+getLazyByteString :: Int -> BitGet L.ByteString

272− let bs' | o == 0 = bs

419+getLazyByteString n = do

273− | otherwise = B.tail bs

420+ (S _ o bo) <- getState

274− in B.take n bs' :*: S (B.drop n bs') 0

421+ case o of

275−

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

276−getState :: BitGet S

423+ putBackState s

277−getState = C $ \s ks -> ks s s

424+ lbs <- B.getLazyByteString (fromIntegral n)

278−

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

279−putState :: S -> BitGet ()

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

280−putState s = C $ \_ ks -> ks s ()

427+

281−

428+

282−modifyState :: (S -> (T a S)) -> BitGet a

429+

283−modifyState f = C $ \s ks -> case f s of

430+

284− w :*: s' -> ks s' w

431+

285−

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

286−------------------------------------------------------------------------

433+-- number of bits in advance.

287−-- Unchecked shifts, from the package binary

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

288−

435+

289−shiftl_w16 :: Word16 -> Int -> Word16

290−shiftl_w32 :: Word32 -> Int -> Word32

291−shiftl_w64 :: Word64 -> Int -> Word64

292−

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

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

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

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

297−

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

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

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

301−

302−

303−#if WORD_SIZE_IN_BITS < 64

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

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

306−

307−#if __GLASGOW_HASKELL__ <= 606

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

309−foreign import ccall unsafe "stg_uncheckedShiftL64"

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

311−foreign import ccall unsafe "stg_uncheckedShiftRL64"

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

313−#endif

314−

315−#else

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

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

318−#endif

319−

320−#else

321−shiftl_w8 = shiftL

322−shiftl_w16 = shiftL

323−shiftl_w32 = shiftL

324−shiftl_w64 = shiftL

325−

326−shiftr_w8 = shiftR

327−shiftr_w16 = shiftR

328−shiftr_w32 = shiftR

329−shiftr_w64 = shiftR

330−#endif

331−

332−{-

333−data R a where

334− RBool :: R Bool

335− RWord8 :: Int -> R Word8

336− RWord16be :: Int -> R Word16

337− RWord32be :: Int -> R Word32

338− RByteString :: Int -> R ByteString

339− RThis :: a -> R a

340− RNextTo :: R a -> R b -> R (T a b)

341− RMap :: R b -> (b -> R a) -> R a

342− RMapPure :: R a -> (a -> b) -> R b

343− RList :: Int -> R a -> R [a]

344− RCheck :: R a -> (a -> Bool) -> String -> R a

345−

346−instance Functor R where

436+instance Functor Block where

347− fmap f m = RMapPure m f

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

348−

438+

349−instance Show (R a) where

439+instance Applicative Block where

350− show r = case r of

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

351− RBool -> "Bool"

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

352−

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

353−size_in_bits :: forall a. R a -- ^ The record

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

354− -> Int -- ^ Number of bits

444+

355−size_in_bits r = case r of

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

356− RBool -> 1

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

357− RWord8 n -> min n 8

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

358− RWord16be n -> min n 16

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

359− RWord32be n -> min n 16

449+block :: Block a -> BitGet a

360− RByteString n -> 8 * n

450+block (Block i p) = do

361− RThis _ -> 0

451+ ensureBits i

362− RList n r -> n * size_in_bits r

452+ s <- getState

363− RMap r _ -> size_in_bits r

453+ putState $! (incS i s)

364− RMapPure r _ -> size_in_bits r

454+ return $! p s

365− RCheck r _ _ -> size_in_bits r

455+

366− RNextTo a b -> size_in_bits a + size_in_bits b

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

367−

457+bool :: Block Bool

368−size_in_bytes :: forall a. R a

458+bool = Block 1 readBool

369− -> Int

459+

370−size_in_bytes r = byte_offset (size_in_bits r + 7)

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

371−

461+bool# :: Block Int

372−get :: R a -> Get a

462+bool# = Block 1 readBool#

373−get r = do

463+

374− bs <- getByteString (size_in_bytes r)

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

375− a :*: s <- getR (S bs 0) r

465+word8 :: Int -> Block Word8

376− return a

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

377−

467+

378−getR :: S -> R a -> Get (T a S)

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

379−getR s0 r = do

469+word16 :: Int -> Block Word16

380− case r of

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

381− RBool -> return (readBool s0)

471+

382− RWord8 n -> return (readWord8 s0 n)

472+word16be :: Int -> Block Word16

383− RWord16be n -> return (readWord16be s0 n)

473+word16be = word16

384− RWord32be n -> return (readWord32be s0 n)

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

475+

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+

480+word32be :: Int -> Block Word32

481+word32be = word32

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

483+

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+

488+word64be :: Int -> Block Word64

489+word64be = word64

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

491+

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

493+byteString :: Int -> Block ByteString

385− RByteString n -> return (readByteString s0 n)

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

386− RThis x -> return (x :*: s0)

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

387− RNextTo a b -> do

388− t :*: s <- getR s0 a

389− u :*: s' <- getR s b

390− return (t:*:u:*:s')

391− RMap r p -> do

392− a :*: s@(S bs o) <- getR s0 r

393− let codepath = p a

394− required_bytes = byte_offset (size_in_bits r - o)

395− bs' <- getByteString required_bytes

396− getR (S (bs `append` bs') o) codepath

397− RMapPure r f -> do

398− a :*: s <- getR s0 r

399− return (f a :*: s)

400− RList n r ->

401− let loop 0 s acc = return (List.reverse acc :*: s)

402− loop m s acc = do

403− a :*: s' <- getR s r

404− loop (m-1) s' (a:acc)

405− in loop n s0 []

406− RCheck r c m -> do

407− a :*: s <- getR s0 r

408− if c a

409− then return (a :*: s)

410− else fail m

411−-}

412−

413

496

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+229−69

@@ -1,13 +1,40 @@

1+{-# LANGUAGE MagicHash #-}

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

4+-- |

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

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

7+-- (c) Sylvain Henry 2015

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

9+--

10+-- Maintainer : kolmodin@gmail.com

11+-- Stability : experimental

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

13+--

14+-- Put bits easily.

15+-----------------------------------------------------------------------------

16+

1module Data.Binary.Bits.Put

17module Data.Binary.Bits.Put

2 ( BitPut

18 ( BitPut

3 , runBitPut

19 , runBitPut

4 , joinPut

20 , joinPut

22+ -- * Data types

23+ -- ** Bool

6 , putBool

24 , putBool

25+ , putBool#

26+

27+ -- ** Words

28+ , putWord#

7 , putWord8

29 , putWord8

30+ , putWord16

31+ , putWord32

32+ , putWord64

8 , putWord16be

33 , putWord16be

9 , putWord32be

34 , putWord32be

10 , putWord64be

35 , putWord64be

36+

37+ -- ** ByteString

11 , putByteString

38 , putByteString

12 )

39 )

13 where

40 where

@@ -16,106 +43,222 @@ import qualified Data.Binary.Builder as B

16import Data.Binary.Builder ( Builder )

43import Data.Binary.Builder ( Builder )

17import qualified Data.Binary.Put as Put

44import qualified Data.Binary.Put as Put

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

20−import Data.ByteString

50+import Data.ByteString as BS

51+import Data.ByteString.Unsafe as BS

53+import Control.Monad (when)

22import Data.Bits

54import Data.Bits

23−import Data.Monoid

24import Data.Word

55import Data.Word

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

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

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

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

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

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

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

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

31−

32−instance Show S where

33− show (S _ w o) = "S( " ++ show w ++ " : " ++ show o ++ ")"

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

35putBool :: Bool -> BitPut ()

66putBool :: Bool -> BitPut ()

36−putBool b = putWord8 1 (if b then 1 else 0)

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

68+

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

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

71+putBool# b = putWord# 1# b

72+

73+

74+-- | Generic putWord

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

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

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+

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

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

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

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

174+putWord8 = putWord

40− case s of

175+

41− -- a whole word8, no offset

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

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

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

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

178+putWord16 = putWord

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

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

46− | otherwise -> flush $

47− let o' = o + n - 8

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

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

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

179

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

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

53−putWord16be n w

181+putWord16be = putWord

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

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

55− | otherwise =

183+

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

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

57− case s of

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

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

186+putWord32 = putWord

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

60− -- it'll fit in 2 bytes

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

62− let o' = o + n - 8

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

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

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

66− -- 3 bytes required

67− | otherwise -> flush $

68− let o' = o + n - 16

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

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

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

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

187

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

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

75−putWord32be n w

189+putWord32be = putWord

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

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

77− | otherwise = do

191+

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

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

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

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

194+putWord64 = putWord

195

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

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

82−putWord64be n w

197+putWord64be = putWord

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

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

84− | otherwise = do

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

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

199

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

88putByteString :: ByteString -> BitPut ()

207putByteString :: ByteString -> BitPut ()

89−putByteString bs = do

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

90− offset <- hasOffset

209+

91− if offset

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

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

211+putByteStringS bs s

93− else joinPut (Put.putByteString bs)

212+ | BS.null bs = s

94− where

213+ | otherwise = case s of

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

225+

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

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

228+--

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

97joinPut :: Put -> BitPut ()

230joinPut :: Put -> BitPut ()

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

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

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

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

100 b = Put.execPut m

233 b = Put.execPut m

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

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

102−

103−flush :: S -> S

104−flush s@(S b w o)

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

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

107− | otherwise = s

108

235

109flushIncomplete :: S -> S

236flushIncomplete :: S -> S

110−flushIncomplete s@(S b w o)

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

111 | o == 0 = s

238 | o == 0 = s

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

113

243

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

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

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

115−runBitPut m = Put.putBuilder b'

246+runBitPut m = Put.putBuilder b

116 where

247 where

117− PairS _ s@(S b t o) = run m (S mempty 0 0)

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

118− (S b' _ _) = flushIncomplete s

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

250+

251+instance Functor BitPut where

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

253+ let PairS x s' = k s

254+ in PairS (f x) s'

255+

256+instance Applicative BitPut where

257+ pure a = BitPut (\s -> PairS a s)

258+ (BitPut f) <*> (BitPut g) = BitPut $ \s ->

259+ let PairS a s' = f s

260+ PairS b s'' = g s'

261+ in PairS (a b) s''

119

262

120instance Monad BitPut where

263instance Monad BitPut where

121 m >>= k = BitPut $ \s ->

264 m >>= k = BitPut $ \s ->

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

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

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

124 in PairS b s''

267 in PairS b s''

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

LICENSE+22−22

@@ -1,30 +1,30 @@

1+Copyright (c) Lennart Kolmodin

5Redistribution and use in source and binary forms, with or without

6−modification, are permitted provided that the following conditions are met:

6+modification, are permitted provided that the following conditions

7+are met:

8− * Redistributions of source code must retain the above copyright

9+1. Redistributions of source code must retain the above copyright

9− notice, this list of conditions and the following disclaimer.

10+ notice, this list of conditions and the following disclaimer.

11− * Redistributions in binary form must reproduce the above

12+2. Redistributions in binary form must reproduce the above copyright

12− copyright notice, this list of conditions and the following

13+ notice, this list of conditions and the following disclaimer in the

13− disclaimer in the documentation and/or other materials provided

14+ documentation and/or other materials provided with the distribution.

14− with the distribution.

16− * Neither the name of Lennart Kolmodin nor the names of other

16+3. Neither the name of the author nor the names of his contributors

17− contributors may be used to endorse or promote products derived

17+ may be used to endorse or promote products derived from this software

18− from this software without specific prior written permission.

18+ without specific prior written permission.

20−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS

20+THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS

21−"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT

21+OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED

22−LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR

22+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE

23−A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT

23+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR

24−OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

25−SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT

24+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL

26−LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,

25+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS

27−DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY

26+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)

28−THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT

27+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,

29−(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

28+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN

30−OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

29+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE

30+POSSIBILITY OF SUCH DAMAGE.

binary-bits.cabal+24−20

@@ -1,44 +1,48 @@

1−-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.

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

2name: binary-bits

3−version: 0.1

3+version: 0.6

4−synopsis: Bit parsing on top of binary.

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

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

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

6− read parts of 8/16/32/64 words.

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

7license: BSD3

8license-file: LICENSE

9−author: Lennart Kolmodin <kolmodin@gentoo.org>

9+author: Lennart Kolmodin <kolmodin@gmail.com>

10−maintainer: Lennart Kolmodin <kolmodin@gentoo.org>

10+maintainer: Lennart Kolmodin <kolmodin@gmail.com>

11−-- copyright:

12−category: Data

11+category: Data, Parsing

13build-type: Simple

12build-type: Simple

14−-- Extra files to be distributed with the package, such as examples or

15−-- a README.

16−-- extra-source-files:

18−-- Constraint on the version of Cabal needed to build this package.

19cabal-version: >=1.10

14cabal-version: >=1.10

16+source-repository head

17+ type: git

18+ location: git://github.com/kolmodin/binary-bits.git

22library

20library

23− build-depends: base==4.*, binary, bytestring

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

22+

23+ other-extensions: RankNTypes, MagicHash, BangPatterns, CPP

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

31− -- other-modules:

34+ ghc-options: -O2 -Wall

32− -- build-tools:

34test-suite qc

36test-suite qc

35 type: exitcode-stdio-1.0

37 type: exitcode-stdio-1.0

36 main-is: BitsQC.hs

38 main-is: BitsQC.hs

37 default-language: Haskell98

39 default-language: Haskell98

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

39− build-depends: binary-bits, binary,

40− base==4.*, haskell98, bytestring,

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

41 QuickCheck>=2, random,

43 QuickCheck>=2, random,

42 test-framework,

44 test-framework,

43 test-framework-quickcheck2

45 test-framework-quickcheck2

44− ghc-options: -fhpc

46+

47+ other-extensions: RankNTypes, MagicHash, BangPatterns, CPP,

48+ FlexibleInstances, FlexibleContexts, TupleSections

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