master..99e7da6 · binary-bits

git.iko.soy/binary-bits

on 99e7da6 help sign in

.gitignoredeleted−4

since splitsnapshots

unifiedsplit

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

1−.cabal-sandbox

2−cabal.sandbox.config

3−dist/

4−.stack-work

.travis.ymldeleted−41

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

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

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

3−

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

9−

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+74−305

@@ -1,32 +1,34 @@

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

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

3−module Main ( main ) where

3+module Main where

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

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

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

6+import Data.Binary.Get ( runGet )

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+

9import Data.Binary.Bits

12import Data.Binary.Bits

10import Data.Binary.Bits.Get

13import Data.Binary.Bits.Get

11import Data.Binary.Bits.Put

14import Data.Binary.Bits.Put

12−import Data.Binary.Bits.BitOrder

14import qualified Data.ByteString as B

16import qualified Data.ByteString as B

15−import qualified Data.ByteString.Lazy as L

17import Control.Applicative

18import Control.Applicative

18import Data.Bits

19import Data.Bits

20+import Data.Monoid

19import Data.Word

21import Data.Word

20import Foreign.Storable

22import Foreign.Storable

21−import Data.Traversable (traverse)

23+import System.Random

22−import Data.Foldable (traverse_)

25+import Test.Framework.Options ( TestOptions'(..) )

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

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

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

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

28+import Test.Framework.Runners.Options ( RunnerOptions'(..) )

26import Test.Framework ( Test, testGroup )

29import Test.Framework ( Test, testGroup )

27import Test.QuickCheck

30import Test.QuickCheck

29−main :: IO ()

30main = defaultMain tests

32main = defaultMain tests

32tests :: [Test]

34tests :: [Test]

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

37 , testGroup "Custom test cases"

39 , testGroup "Custom test cases"

38 [ testProperty "prop_composite_case" prop_composite_case ]

40 [ 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−

63 , testGroup "prop_bitput_with_get_from_binary"

42 , testGroup "prop_bitput_with_get_from_binary"

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

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

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

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

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

89 ]

68 ]

91 , testGroup "prop_put_with_bitreq"

70 , testGroup "prop_put_with_bitreq"

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

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

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

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

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

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

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

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

96 ]

75 ]

98 , testGroup "prop_putget_list_simple"

77 , testGroup "prop_putget_list_simple"

@@ -103,13 +82,6 @@ tests =

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

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

104 ]

83 ]

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−

113 , testGroup "prop_putget_list_with_bitreq"

85 , testGroup "prop_putget_list_with_bitreq"

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

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

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

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

@@ -117,74 +89,27 @@ tests =

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

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

118 ]

90 ]

119 , testGroup "prop_bitget_bytestring_interspersed"

91 , testGroup "prop_bitget_bytestring_interspersed"

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

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

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

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

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

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

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

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

124− ]

125− , testGroup "Simulate programs"

126− [ testProperty "primitive" prop_primitive

127− , testProperty "many primitives in sequence" prop_program

128 ]

96 ]

129 ]

97 ]

130

131−prop_isEmptyOfEmptyEmpty :: Bool

99+{-

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

100+ -- these tests use the R structure

133−

101+ --

134−prop_isEmptyOfNonEmptyEmpty :: L.ByteString -> Property

102+ -- quickCheck prop_Word32_from_2_Word16

135−prop_isEmptyOfNonEmptyEmpty bs =

103+ -- quickCheck prop_Word32_from_Word8_and_Word16

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

104+-}

137−

105+

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−

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

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

182−prop_putget_with_bitreq bo (W w) = property $

107+prop_putget_with_bitreq (W w) = property $

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

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

184 let p = putBits (bitreq w) w

109 let p = putBits (bitreq w) w

185 g = getBits (bitreq w)

110 g = getBits (bitreq w)

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

111+ lbs = runPut (runBitPut p)

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

112+ w' = runGet (runBitGet g) lbs

188 in w == w'

113 in w == w'

189

114

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

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

@@ -192,7 +117,7 @@ prop_putget_with_bitreq bo (W w) = property $

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

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

193prop_putget_list_simple (W ws) = property $

118prop_putget_list_simple (W ws) = property $

194 let s = sizeOf (head ws) * 8

119 let s = sizeOf (head ws) * 8

195− p = mapM_ (putBits s) ws

120+ p = mapM_ (\v -> putBits s v) ws

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

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

197 lbs = runPut (runBitPut p)

122 lbs = runPut (runBitPut p)

198 ws' = runGet (runBitGet g) lbs

123 ws' = runGet (runBitGet g) lbs

@@ -211,18 +136,6 @@ prop_putget_list_with_bitreq (W ws) = property $

211 where

136 where

212 bitlist = map bitreq ws

137 bitlist = map bitreq ws

213

138

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−

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

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

227-- library.

140-- library.

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

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

@@ -246,52 +159,33 @@ prop_bitget_with_put_from_binary (W ws) = property $

246 in ws == ws'

159 in ws == ws'

247

160

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

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

162+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 $

163+prop_bitget_bytestring_interspersed (W ws) bss = property $

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

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

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

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

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

166+ lbs = runPut (runBitPut p)

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

167+ r = runGet (runBitGet g) lbs

255 in map (ws,) bss == r

168 in map (ws,) bss == r

256

169

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−

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

170+-- number of bits required to write @v@

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

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

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

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

279

173

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

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

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

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

282

176

283prop_bitreq :: W Word64 -> Property

177prop_bitreq :: W Word64 -> Property

284prop_bitreq (W w) = property $

178prop_bitreq (W w) = property $

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

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

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

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

287

181

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

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

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

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

290 let p = do putBool b

184 let p = do putBool b

291− putWord16 15 w

185+ putWord16be 15 w

292 g = do v <- getBool

186 g = do v <- getBool

293 case v of

187 case v of

294− True -> getWord16 15

188+ True -> getWord16be 15

295 False -> do

189 False -> do

296 msb <- getWord8 7

190 msb <- getWord8 7

297 lsb <- getWord8 8

191 lsb <- getWord8 8

@@ -300,7 +194,8 @@ prop_composite_case b (W w) = w < 0x8000 ==>

300 w' = runGet (runBitGet g) lbs

194 w' = runGet (runBitGet g) lbs

301 in w == w'

195 in w == w'

302

196

197+

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

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

304prop_compare_put_with_naive (W ws) = property $

199prop_compare_put_with_naive (W ws) = property $

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

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

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

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

@@ -317,7 +212,7 @@ prop_compare_get_with_naive (W ws) = property $

317 rn = runGet (runBitGet gn) lbs

212 rn = runGet (runBitGet gn) lbs

318 r = runGet (runBitGet g ) lbs

213 r = runGet (runBitGet g ) lbs

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

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

320− _types = rn == ws && r == ws

215+ types = rn == ws && r == ws

321 in rn == r

216 in rn == r

322

217

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

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

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

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

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

336 in loop n0 0

231 in loop n0 0

337

232

233+{-

234+prop_Word32_from_Word8_and_Word16 :: Word8 -> Word16 -> Property

235+prop_Word32_from_Word8_and_Word16 w8 w16 = property $

236+ let p = RWord32be 24

237+ w' = runGet (get p) lbs

238+ in w0 == w'

239+ where

240+ lbs = runPut (putWord8 w8 >> putWord16be w16)

241+ w0 = ((fromIntegral w8) `shiftL` 16) .|. fromIntegral w16

242+

243+prop_Word32_from_2_Word16 :: Word16 -> Word16 -> Property

244+prop_Word32_from_2_Word16 w1 w2 = property $

245+ let p = RWord32be 32

246+ w' = runGet (get p) lbs

247+ in w0 == w'

248+ where

249+ lbs = encode w0

250+ w0 = ((fromIntegral w1) `shiftL` 16) .|. fromIntegral w2

251+-}

252+

253+

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

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

339shrinker 0 = []

255shrinker 0 = []

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

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

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

348

264

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

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

350

266

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−

357instance Arbitrary (W Bool) where

267instance Arbitrary (W Bool) where

358 arbitrary = W <$> arbitrary

268 arbitrary = W <$> arbitrary

359 shrink = map W <$> shrink . unW

269 shrink = map W <$> shrink . unW

360

270

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

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

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

274+

361instance Arbitrary (W Word8) where

275instance Arbitrary (W Word8) where

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

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

363 shrink = map W . shrinker . unW

277 shrink = map W . shrinker . unW

@@ -378,155 +292,11 @@ instance Arbitrary B.ByteString where

378 arbitrary = B.pack <$> arbitrary

292 arbitrary = B.pack <$> arbitrary

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

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

380

294

381−instance Arbitrary L.ByteString where

295+integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)

382− arbitrary = L.fromChunks <$> arbitrary

296+integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer,

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

297+ fromIntegral b :: Integer) g of

384−

298+ (x,g) -> (fromIntegral x, g)

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

299

529−{-

530instance Random Word where

300instance Random Word where

531 randomR = integralRandomR

301 randomR = integralRandomR

532 random = randomR (minBound,maxBound)

302 random = randomR (minBound,maxBound)

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

546instance Random Word64 where

316instance Random Word64 where

547 randomR = integralRandomR

317 randomR = integralRandomR

548 random = randomR (minBound,maxBound)

318 random = randomR (minBound,maxBound)

549−-}

Data/Binary/Bits.hs+6−21

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

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−

16module Data.Binary.Bits where

1module Data.Binary.Bits where

18import Data.Binary.Bits.Get

3import Data.Binary.Bits.Get

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

33 getBits = getWord8

18 getBits = getWord8

35instance BinaryBit Word16 where

20instance BinaryBit Word16 where

36− putBits = putWord16

21+ putBits = putWord16be

37− getBits = getWord16

22+ getBits = getWord16be

39instance BinaryBit Word32 where

24instance BinaryBit Word32 where

40− putBits = putWord32

25+ putBits = putWord32be

41− getBits = getWord32

26+ getBits = getWord32be

43instance BinaryBit Word64 where

28instance BinaryBit Word64 where

44− putBits = putWord64

29+ putBits = putWord64be

45− getBits = getWord64

30+ 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+333−400

@@ -1,292 +1,233 @@

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

51−

52module Data.Binary.Bits.Get

3module Data.Binary.Bits.Get

53− (

54− -- * BitGet monad

55−

56− -- $bitget

57−

58− BitGet

4+ ( BitGet

59 , runBitGet

5 , runBitGet

61− -- ** Get bytes

62 , getBool

7 , getBool

63− , getBool#

64 , getWord8

8 , getWord8

65− , getWord16

66− , getWord32

67− , getWord64

68 , getWord16be

9 , getWord16be

69 , getWord32be

10 , getWord32be

70 , getWord64be

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

13 , bool

84 , word8

14 , word8

85− , word16

86− , word32

87− , word64

88 , word16be

15 , word16be

89 , word32be

16 , word32be

90 , word64be

17 , word64be

91− , byteString

92− , Data.Binary.Bits.Get.getByteString

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

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

19+ , block

20+

21+ , Data.Binary.Bits.Get.getByteString

96 ) where

22 ) where

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

24+import Data.Binary.Get as B ( runGet, Get, getByteString )

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

104import Data.ByteString as B

26import Data.ByteString as B

105−import qualified Data.ByteString.Lazy as L

27+import Data.ByteString.Internal

106import Data.ByteString.Unsafe

28import Data.ByteString.Unsafe

107−import Foreign.Marshal.Alloc (mallocBytes)

29+

108−import Foreign.Ptr

30+import qualified Data.ByteString.Lazy as L

109−import Foreign.Storable (poke)

110−import System.IO.Unsafe (unsafePerformIO)

111

112import Data.Bits

32import Data.Bits

113import Data.Word

33import Data.Word

34+import Data.List as List ( reverse )

35+

114import Control.Applicative

36import Control.Applicative

115−import Control.Monad (when,foldM_)

116

117import Prelude as P

38import Prelude as P

39+

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

41+import GHC.Base

118import GHC.Word

42import GHC.Word

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

43+import GHC.Int

120−

44+#endif

121−-- $bitget

45+

122−-- Parse bits using a monad.

46+data T a b = !a :*: !b deriving (Show)

123−--

47+

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−

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

48+data S = S !ByteString -- ^ Input

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

49+ !Int -- ^ Bit offset (0-7)

169− !BitOrder -- Bit order

170 deriving (Show)

50 deriving (Show)

171

172−-- | Increment the current bit offset

52+-- | A block that will be read with only one boundry check.

173−incS :: Int -> S -> S

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

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

54+

175− where

55+instance Functor Block where

176− !o' = (n+o)

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

177− !d = byte_offset o'

57+

178− !n' = bit_offset o'

58+instance Applicative Block where

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

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

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

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

63+

64+block :: Block a -> BitGet a

65+block (Block i p) = do

66+ ensureBits i

67+ modifyState (\s -> (incS i s, p s))

68+

69+-- | make_mask 3 = 00000111

70+make_mask :: Bits a => Int -> a

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

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

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

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

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

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

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

179

180−-- | Read a single bit

181readBool :: S -> Bool

79readBool :: S -> Bool

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

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

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

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

81+

185− LL -> testBit (unsafeHead bs) o

82+incS :: Int -> S -> S

186− LB -> testBit (unsafeHead bs) o

83+incS o (S bs n) =

187−

84+ let !o' = (n+o)

188−-- | Read a single bit

85+ !d = o' `shiftR` 3

189−readBool# :: S -> Int

86+ !n' = o' .&. make_mask 3

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

87+ in S (unsafeDrop d bs) n'

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

88+

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−

199−

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

201−--

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

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

204−extract bo bs o n

205− | n == 0 = 0

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

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

208− where

209− -- B.foldl' with index

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

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

212−

213− -- 'or' correctly shifted words

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

215−

216− -- co-offset

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

218−

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

220− off i = case bo of

221− LL -> 8*i - o

222− LB -> 8*i - o

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

233−

234−-- | Generic readWord

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

236−readWord n (S bs o bo)

237− | n == 0 = 0

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

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

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

244−readWordChecked m n s

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

246− | otherwise = readWord n s

247−

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

249−--

250−-- Examples:

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

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

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

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

255readByteString :: Int -> S -> ByteString

89readByteString :: Int -> S -> ByteString

256−readByteString n (S bs o bo) =

90+readByteString n s@(S bs o)

257− let

91+ -- no offset, easy.

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

92+ | o == 0 = unsafeTake n bs

259− bs'' = unsafeTake n bs

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

260− rev = B.map (reverseBits 8)

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

261− in case (o,bo) of

95+

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

96+readWord8 :: Int -> S -> Word8

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

97+readWord8 n s@(S bs o)

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'

98+ -- no bits at all, return 0

279− foldM_ f 0 [1..len]

99+ | n == 0 = 0

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

100+

101+ -- all bits are in the same byte

102+ -- we just need to shift and mask them right

103+ | n <= 8 - o = let w = unsafeHead bs

104+ m = make_mask n

105+ w' = (w `shiftr_w8` (8 - o - n)) .&. m

106+ in w'

107+

108+ -- the bits are in two different bytes

109+ -- make a word16 using both bytes, and then shift and mask

110+ | n <= 8 = let w = (fromIntegral (unsafeHead bs) `shiftl_w16` 8) .|.

111+ (fromIntegral (unsafeIndex bs 1))

112+ m = make_mask n

113+ w' = (w `shiftr_w16` (16 - o - n)) .&. m

114+ in fromIntegral w'

115+

116+bit_offset :: Int -> Int

117+bit_offset n = make_mask 3 .&. n

118+

119+byte_offset :: Int -> Int

120+byte_offset n = n `shiftR` 3

121+

122+readWord16be :: Int -> S -> Word16

123+readWord16be n s@(S bs o)

124+

125+ -- 8 or fewer bits, use readWord8

126+ | n <= 8 = fromIntegral (readWord8 n s)

127+

128+ -- handle 9 or more bits, stored in two bytes

129+

130+ -- no offset, plain and simple 16 bytes

131+ | o == 0 && n == 16 = let msb = fromIntegral (unsafeHead bs)

132+ lsb = fromIntegral (unsafeIndex bs 1)

133+ w = (msb `shiftl_w16` 8) .|. lsb

134+ in w

135+

136+ -- no offset, but not full 16 bytes

137+ | o == 0 = let msb = fromIntegral (unsafeHead bs)

138+ lsb = fromIntegral (unsafeIndex bs 1)

139+ w = (msb `shiftl_w16` (n-8)) .|. (lsb `shiftr_w16` (16-n))

140+ in w

141+

142+ -- with offset, and n=9-16

143+ | n <= 16 = readWithOffset s shiftl_w16 shiftr_w16 n

144+

145+ | otherwise = error "readWord16be: tried to read more than 16 bits"

146+

147+readWithoutOffset :: (Bits a, Num a)

148+ => S -> (a -> Int -> a) -> (a -> Int -> a) -> Int -> a

149+readWithoutOffset s@(S bs o) shifterL shifterR n

150+ | o /= 0 = error "readWithoutOffset: there is an offset"

151+

152+ | bit_offset n == 0 && byte_offset n <= 4 =

153+ let segs = byte_offset n

154+ bn 0 = fromIntegral (unsafeHead bs)

155+ bn n = (bn (n-1) `shifterL` 8) .|. fromIntegral (unsafeIndex bs n)

156+

157+ in bn (segs-1)

158+

159+ | n <= 64 = let segs = byte_offset n

160+ o' = bit_offset (n - 8 + o)

161+

162+ bn 0 = fromIntegral (unsafeHead bs)

163+ bn n = (bn (n-1) `shifterL` 8) .|. fromIntegral (unsafeIndex bs n)

164+

165+ msegs = bn (segs-1) `shifterL` o'

166+

167+ last = (fromIntegral (unsafeIndex bs segs)) `shifterR` (8 - o')

168+

169+ w = msegs .|. last

170+ in w

171+

172+readWithOffset :: (Bits a, Num a)

173+ => S -> (a -> Int -> a) -> (a -> Int -> a) -> Int -> a

174+readWithOffset s@(S bs o) shifterL shifterR n

175+ | n <= 64 = let bits_in_msb = 8 - o

176+ (n',top) = (n - bits_in_msb

177+ , (fromIntegral (unsafeHead bs) .&. make_mask bits_in_msb) `shifterL` n')

178+

179+ segs = byte_offset n'

180+

181+ bn 0 = 0

182+ bn n = (bn (n-1) `shifterL` 8) .|. fromIntegral (unsafeIndex bs n)

281

183

184+ o' = bit_offset n'

185+

186+ mseg = bn segs `shifterL` o'

187+

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

189+ | otherwise = 0

190+

191+ w = top .|. mseg .|. last

192+ in w

193+

194+

195+readWord32be :: Int -> S -> Word32

196+readWord32be n s@(S bs o)

197+ -- 8 or fewer bits, use readWord8

198+ | n <= 8 = fromIntegral (readWord8 n s)

199+

200+ -- 16 or fewer bits, use readWord16be

201+ | n <= 16 = fromIntegral (readWord16be n s)

202+

203+ | o == 0 = readWithoutOffset s shiftl_w32 shiftr_w32 n

204+

205+ | n <= 32 = readWithOffset s shiftl_w32 shiftr_w32 n

206+

207+ | otherwise = error "readWord32be: tried to read more than 32 bits"

208+

209+

210+readWord64be :: Int -> S -> Word64

211+readWord64be n s@(S bs o)

212+ -- 8 or fewer bits, use readWord8

213+ | n <= 8 = fromIntegral (readWord8 n s)

214+

215+ -- 16 or fewer bits, use readWord16be

216+ | n <= 16 = fromIntegral (readWord16be n s)

217+

218+ | o == 0 = readWithoutOffset s shiftl_w64 shiftr_w64 n

219+

220+ | n <= 64 = readWithOffset s shiftl_w64 shiftr_w64 n

221+

222+ | otherwise = error "readWord64be: tried to read more than 64 bits"

282

223

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

224------------------------------------------------------------------------

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

225+-- unrolled codensity/state monad

285−-- for how to run it.

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

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

287

227

288instance Monad BitGet where

228instance Monad BitGet where

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

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

230+ fail str = B $ \_s -> fail str

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

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

291 runState (g a) s'

232 runState (g a) s'

292

233

@@ -297,200 +238,192 @@ instance Applicative BitGet where

297 pure x = return x

238 pure x = return x

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

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

299

240

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

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

325runBitGet :: BitGet a -> Get a

241runBitGet :: BitGet a -> Get a

326runBitGet bg = do

242runBitGet bg = do

327− s <- mkInitState

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

243+ (_,a) <- runState bg (S B.empty 0)

329− putBackState s'

330 return a

244 return a

331

245

332−mkInitState :: Get S

333−mkInitState = do

334− bs <- get

335− put B.empty

336− return (S bs 0 BB)

337−

338−putBackState :: S -> Get ()

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)

345−

346getState :: BitGet S

246getState :: BitGet S

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

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

348

248

349putState :: S -> BitGet ()

249putState :: S -> BitGet ()

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

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

351

251

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

252+modifyState :: (S -> (S,a)) -> BitGet a

353−withState f = do

253+modifyState f = B $ \s -> return (f s)

354− s <- getState

355− putState $! f s

356

254

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

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

358ensureBits :: Int -> BitGet ()

256ensureBits :: Int -> BitGet ()

359ensureBits n = do

257ensureBits n = do

360− (S bs o bo) <- getState

258+ s@(S bs o) <- getState

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

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

362 then return ()

260 then return ()

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

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

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

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

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

263+ B $ \s -> do bs' <- B.getByteString byteCount

366− bs' <- B.get

367− put B.empty

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

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

369−

265+

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

378getBool :: BitGet Bool

266getBool :: BitGet Bool

379getBool = block bool

267getBool = block bool

380

268

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

386getWord8 :: Int -> BitGet Word8

269getWord8 :: Int -> BitGet Word8

387getWord8 n = block (word8 n)

270getWord8 n = block (word8 n)

388

271

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

390−getWord16 :: Int -> BitGet Word16

391−getWord16 n = block (word16 n)

392−

393getWord16be :: Int -> BitGet Word16

272getWord16be :: Int -> BitGet Word16

394−getWord16be = getWord16

273+getWord16be n = block (word16be n)

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)

400

274

401getWord32be :: Int -> BitGet Word32

275getWord32be :: Int -> BitGet Word32

402−getWord32be = getWord32

276+getWord32be n = block (word32be n)

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)

408

277

409getWord64be :: Int -> BitGet Word64

278getWord64be :: Int -> BitGet Word64

410−getWord64be = getWord64

279+getWord64be n = block (word64be n)

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

412

280

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

414getByteString :: Int -> BitGet ByteString

281getByteString :: Int -> BitGet ByteString

415getByteString n = block (byteString n)

282getByteString n = block (byteString n)

416

283

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

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

419−getLazyByteString n = do

420− (S _ o bo) <- getState

421− case o of

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

423− putBackState s

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

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

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

427−

428−

429−

430−

431−

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

433−-- number of bits in advance.

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

435−

436−instance Functor Block where

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

438−

439−instance Applicative Block where

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

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

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

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

444−

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

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

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

448−-- 'byteString' and 'Applicative'.

449−block :: Block a -> BitGet a

450−block (Block i p) = do

451− ensureBits i

452− s <- getState

453− putState $! (incS i s)

454− return $! p s

455−

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

457bool :: Block Bool

284bool :: Block Bool

458bool = Block 1 readBool

285bool = Block 1 readBool

459

286

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

461−bool# :: Block Int

462−bool# = Block 1 readBool#

463−

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

465word8 :: Int -> Block Word8

287word8 :: Int -> Block Word8

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

288+word8 n = Block n (readWord8 n)

467−

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

469−word16 :: Int -> Block Word16

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

471

289

472word16be :: Int -> Block Word16

290word16be :: Int -> Block Word16

473−word16be = word16

291+word16be n = Block n (readWord16be 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

292

480word32be :: Int -> Block Word32

293word32be :: Int -> Block Word32

481−word32be = word32

294+word32be n = Block n (readWord32be n)

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

295

488word64be :: Int -> Block Word64

296word64be :: Int -> Block Word64

489−word64be = word64

297+word64be n = Block n (readWord64be n)

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

491

298

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

493byteString :: Int -> Block ByteString

299byteString :: Int -> Block ByteString

300+byteString n = Block (n*8) (readByteString n)

301+

302+------------------------------------------------------------------------

303+-- Unchecked shifts, from the package binary

304+

305+shiftl_w16 :: Word16 -> Int -> Word16

306+shiftl_w32 :: Word32 -> Int -> Word32

307+shiftl_w64 :: Word64 -> Int -> Word64

308+

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

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

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

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

313+

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

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

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

317+

318+

319+#if WORD_SIZE_IN_BITS < 64

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

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

322+

323+#if __GLASGOW_HASKELL__ <= 606

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

325+foreign import ccall unsafe "stg_uncheckedShiftL64"

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

327+foreign import ccall unsafe "stg_uncheckedShiftRL64"

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

329+#endif

330+

331+#else

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

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

334+#endif

335+

336+#else

337+shiftl_w8 = shiftL

338+shiftl_w16 = shiftL

339+shiftl_w32 = shiftL

340+shiftl_w64 = shiftL

341+

342+shiftr_w8 = shiftR

343+shiftr_w16 = shiftR

344+shiftr_w32 = shiftR

345+shiftr_w64 = shiftR

346+#endif

347+

348+{-

349+data R a where

350+ RBool :: R Bool

351+ RWord8 :: Int -> R Word8

352+ RWord16be :: Int -> R Word16

353+ RWord32be :: Int -> R Word32

354+ RByteString :: Int -> R ByteString

355+ RThis :: a -> R a

356+ RNextTo :: R a -> R b -> R (T a b)

357+ RMap :: R b -> (b -> R a) -> R a

358+ RMapPure :: R a -> (a -> b) -> R b

359+ RList :: Int -> R a -> R [a]

360+ RCheck :: R a -> (a -> Bool) -> String -> R a

361+

362+instance Functor R where

363+ fmap f m = RMapPure m f

364+

365+instance Show (R a) where

366+ show r = case r of

367+ RBool -> "Bool"

368+

369+size_in_bits :: forall a. R a -- ^ The record

370+ -> Int -- ^ Number of bits

371+size_in_bits r = case r of

372+ RBool -> 1

373+ RWord8 n -> min n 8

374+ RWord16be n -> min n 16

375+ RWord32be n -> min n 16

376+ RByteString n -> 8 * n

377+ RThis _ -> 0

378+ RList n r -> n * size_in_bits r

379+ RMap r _ -> size_in_bits r

380+ RMapPure r _ -> size_in_bits r

381+ RCheck r _ _ -> size_in_bits r

382+ RNextTo a b -> size_in_bits a + size_in_bits b

383+

384+size_in_bytes :: forall a. R a

385+ -> Int

386+size_in_bytes r = byte_offset (size_in_bits r + 7)

387+

388+get :: R a -> Get a

389+get r = do

390+ bs <- getByteString (size_in_bytes r)

391+ a :*: s <- getR (S bs 0) r

392+ return a

393+

394+getR :: S -> R a -> Get (T a S)

395+getR s0 r = do

396+ case r of

397+ RBool -> return (readBool s0)

398+ RWord8 n -> return (readWord8 s0 n)

399+ RWord16be n -> return (readWord16be s0 n)

400+ RWord32be n -> return (readWord32be s0 n)

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

401+ RByteString n -> return (readByteString s0 n)

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

402+ RThis x -> return (x :*: s0)

403+ RNextTo a b -> do

404+ t :*: s <- getR s0 a

405+ u :*: s' <- getR s b

406+ return (t:*:u:*:s')

407+ RMap r p -> do

408+ a :*: s@(S bs o) <- getR s0 r

409+ let codepath = p a

410+ required_bytes = byte_offset (size_in_bits r - o)

411+ bs' <- getByteString required_bytes

412+ getR (S (bs `append` bs') o) codepath

413+ RMapPure r f -> do

414+ a :*: s <- getR s0 r

415+ return (f a :*: s)

416+ RList n r ->

417+ let loop 0 s acc = return (List.reverse acc :*: s)

418+ loop m s acc = do

419+ a :*: s' <- getR s r

420+ loop (m-1) s' (a:acc)

421+ in loop n s0 []

422+ RCheck r c m -> do

423+ a :*: s <- getR s0 r

424+ if c a

425+ then return (a :*: s)

426+ else fail m

427+-}

428+

496

429

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

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

1−{-# LANGUAGE MagicHash #-}

2−

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−

17module Data.Binary.Bits.Put

1module Data.Binary.Bits.Put

18 ( BitPut

2 ( BitPut

19 , runBitPut

3 , runBitPut

20 , joinPut

4 , joinPut

22− -- * Data types

23− -- ** Bool

24 , putBool

6 , putBool

25− , putBool#

26−

27− -- ** Words

28− , putWord#

29 , putWord8

7 , putWord8

30− , putWord16

31− , putWord32

32− , putWord64

33 , putWord16be

8 , putWord16be

34 , putWord32be

9 , putWord32be

35 , putWord64be

10 , putWord64be

36−

37− -- ** ByteString

38 , putByteString

11 , putByteString

39 )

12 )

40 where

13 where

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

43import Data.Binary.Builder ( Builder )

16import Data.Binary.Builder ( Builder )

44import qualified Data.Binary.Put as Put

17import qualified Data.Binary.Put as Put

45import Data.Binary.Put ( Put )

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

20+import Data.ByteString

51−import Data.ByteString.Unsafe as BS

53−import Control.Monad (when)

54import Data.Bits

22import Data.Bits

23+import Data.Monoid

55import Data.Word

24import 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) }

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

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

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

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

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

64−

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

66−putBool :: Bool -> BitPut ()

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

32+instance Show S where

143− w' = case bo of

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

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

35+putBool :: Bool -> BitPut ()

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

171

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

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

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

174−putWord8 = putWord

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

175−

40+ case s of

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

41+ -- a whole word8, no offset

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

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

178−putWord16 = putWord

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

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

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

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

181−putWord16be = putWord

53+putWord16be n w

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

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

183−

55+ | otherwise =

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

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

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

57+ case s of

186−putWord32 = putWord

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

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

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

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

189−putWord32be = putWord

75+putWord32be n w

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

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

191−

77+ | otherwise = do

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

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

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

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

194−putWord64 = putWord

195

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

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

197−putWord64be = putWord

82+putWord64be n w

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

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

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

207putByteString :: ByteString -> BitPut ()

88putByteString :: ByteString -> BitPut ()

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

89+putByteString bs = do

209−

90+ offset <- hasOffset

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

91+ if offset

211−putByteStringS bs s

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

212− | BS.null bs = s

93+ else joinPut (Put.putByteString bs)

213− | otherwise = case s of

94+ where

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

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

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)

230joinPut :: Put -> BitPut ()

97joinPut :: Put -> BitPut ()

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

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

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

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

233 b = Put.execPut m

100 b = Put.execPut m

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

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

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

235

108

236flushIncomplete :: S -> S

109flushIncomplete :: S -> S

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

110+flushIncomplete s@(S b w o)

238 | o == 0 = s

111 | o == 0 = s

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

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

240−

241−getOffset :: BitPut Int

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

243

113

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

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

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

246−runBitPut m = Put.putBuilder b

115+runBitPut m = Put.putBuilder b'

247 where

116 where

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

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

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

118+ (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''

262

119

263instance Monad BitPut where

120instance Monad BitPut where

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

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

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

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

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

267 in PairS b s''

124 in PairS b s''

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

125 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

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

7−are met:

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

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

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

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

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

11+ * Redistributions in binary form must reproduce the above

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

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

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

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

14+ with the distribution.

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

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

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

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

18− without specific prior written permission.

18+ from this software without specific prior written permission.

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

30−POSSIBILITY OF SUCH DAMAGE.

binary-bits.cabal+20−24

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

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

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

2name: binary-bits

3−version: 0.6

3+version: 0.1

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

4+synopsis: Bit parsing on top of binary.

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

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

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

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

7license: BSD3

8license-file: LICENSE

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

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

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

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

11+-- copyright:

11−category: Data, Parsing

12+category: Data

12build-type: Simple

13build-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.

14cabal-version: >=1.10

19cabal-version: >=1.10

16−source-repository head

17− type: git

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

20library

22library

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

23+ build-depends: base==4.*, binary, 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

32 default-language: Haskell98

29 default-language: Haskell98

34− ghc-options: -O2 -Wall

31+ -- other-modules:

32+ -- build-tools:

36test-suite qc

34test-suite qc

37 type: exitcode-stdio-1.0

35 type: exitcode-stdio-1.0

38 main-is: BitsQC.hs

36 main-is: BitsQC.hs

39 default-language: Haskell98

37 default-language: Haskell98

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

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

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

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

43 QuickCheck>=2, random,

41 QuickCheck>=2, random,

44 test-framework,

42 test-framework,

45 test-framework-quickcheck2

43 test-framework-quickcheck2

46−

44+ ghc-options: -fhpc

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

48− FlexibleInstances, FlexibleContexts, TupleSections

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