4c202bb · binary-bits · git.iko.soy

git.iko.soy/binary-bits

Add tests and fix bugs

commit4c202bbffb21ca4542765d9247976c23b4abdc24 authorSylvain HENRY <hsyl20@gmail.com> dateFri 6 Mar 2015, 20:09 (12 years ago) parent1d24023

3 files changed+71−42

compare with master

unifiedsplit

BitsQC.hs+46−17 Data/Binary/Bits/Get.hs+10−9 Data/Binary/Bits/Put.hs+15−16

BitsQC.hs+46−17

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

99import Data.Binary.Bits

1010import Data.Binary.Bits.Get

1111import Data.Binary.Bits.Put

12+import Data.Binary.Bits.BitOrder

1213

1314import qualified Data.ByteString as B

1415import qualified Data.ByteString.Lazy as L

@@ -18,6 +19,8 @@ import Data.Bits

1819import Data.Word

1920import Foreign.Storable

2021import System.Random

22+import Data.Traversable (traverse)

23+import Data.Foldable (traverse_)

2124

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

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

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

3639 [ testProperty "prop_composite_case" prop_composite_case ]

3740

3841 , testGroup "getByteString"

39− [ testProperty "prop_getByteString_negative" prop_getByteString_negative ]

42+ [ testProperty "prop_getByteString_negative" prop_getByteString_negative

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

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

45+ ]

4046

4147 , testGroup "getLazyByteString"

4248 [ testProperty "getLazyByteString == getByteString"

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

8490 ]

8591

8692 , testGroup "prop_put_with_bitreq"

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

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

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

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

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

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

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

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

9197 ]

9298

9399 , testGroup "prop_putget_list_simple"

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

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

113119 ]

114120 , testGroup "prop_bitget_bytestring_interspersed"

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

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

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

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

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

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

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

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

119125 ]

120126 , testGroup "Simulate programs"

121127 [ testProperty "primitive" prop_primitive

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

158164 n < 1 ==>

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

160166

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

162−prop_putget_with_bitreq (W w) = property $

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

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

169+ where

170+ n = B.length bs

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

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

173+

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

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

176+ where

177+ n = fmap B.length bs

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

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

180+

181+

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

183+prop_putget_with_bitreq bo (W w) = property $

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

164185 let p = putBits (bitreq w) w

165186 g = getBits (bitreq w)

166− lbs = runPut (runBitPut p)

167− w' = runGet (runBitGet g) lbs

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

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

168189 in w == w'

169190

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

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

226247 in ws == ws'

227248

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

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

230−prop_bitget_bytestring_interspersed (W ws) bss = property $

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

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

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

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

233− lbs = runPut (runBitPut p)

234− r = runGet (runBitGet g) lbs

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

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

235256 in map (ws,) bss == r

236257

237258-- | Test failing.

@@ -425,6 +446,14 @@ instance Arbitrary Primitive where

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

426447 IsEmpty -> []

427448

449+instance Arbitrary BitOrder where

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

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

452+ shrink BL = [BB,LB]

453+ shrink LB = [BB]

454+ shrink BB = []

455+

456+

428457prop_primitive :: Primitive -> Property

429458prop_primitive prim = property $

430459 let p = putPrimitive prim

Data/Binary/Bits/Get.hs+10−9

@@ -239,16 +239,17 @@ readWordChecked m n s

239239readByteString :: Int -> S -> ByteString

240240readByteString n (S bs o bo) =

241241 let

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

243− rev = B.map (reverseBits 8)

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

243+ bs'' = unsafeTake n bs

244+ rev = B.map (reverseBits 8)

244245 in case (o,bo) of

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

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

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

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

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

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

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

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

247+ (0,LB) -> B.reverse bs''

248+ (0,LL) -> rev bs''

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

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

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

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

252253 (_,BB) -> unsafePerformIO $ do

253254 let len = n+1

254255 ptr <- mallocBytes len

Data/Binary/Bits/Put.hs+15−16

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

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

8383 w' = case bo of

8484 BB -> w

85− BL -> w

85+ BL -> w `fastShiftR` cn

8686 LB -> w `fastShiftR` cn

87− LL -> w `fastShiftR` cn

87+ LL -> w

8888

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

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

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

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

9393 selectBits x = fromIntegral $ case bo of

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

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

95+ LL -> reverseBits cn $ mask cn $ x `fastShiftR` (n-cn)

9696 LB -> mask cn x

97− LL -> reverseBits cn $ mask cn x

97+ BL -> reverseBits cn $ mask cn x

9898

9999 -- shift left at the correct position

100100 shl :: Word8 -> Word8

@@ -148,20 +148,19 @@ putByteString :: ByteString -> BitPut ()

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

149149

150150putByteStringS :: ByteString -> S -> S

151−putByteStringS bs (S builder b 0 BB) = S (builder `mappend` B.fromByteString bs) b 0 BB

152−putByteStringS bs s@(S _ _ _ BB)

151+putByteStringS bs s

153152 | BS.null bs = s

154− | otherwise = putByteStringS (BS.unsafeTail bs) (putWordS 8 (BS.unsafeHead bs) s)

155−putByteStringS bs (S builder b o bo) = putByteStringS bs' (S builder b o BB)

153+ | otherwise = case s of

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

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

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

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

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

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

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

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

156162 where

157− rev = BS.map (reverseBits 8)

158−

159− bs' = case bo of

160− BL -> BS.reverse (rev bs)

161− LB -> BS.reverse bs

162− LL -> rev bs

163− BB -> bs -- should not occur, already matched but the compiler doesn't detect it

164−

163+ rev = BS.map (reverseBits 8)

165164

166165

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