@@ -1,9 +1,12 @@
11module Main where
22
3−import Data.Binary ( encode )
3+import Data.Binary ( encode, Binary(..) )
44import Data.Binary.Get ( runGet )
55import Data.Binary.Put ( runPut )
66
7+import qualified Data.Binary.Get as BG ( getWord8, getWord16be, getWord32be, getWord64be )
8+import qualified Data.Binary.Put as BP ( putWord8, putWord16be, putWord32be, putWord64be )
9+
710import Bits
811
912import Data.Bits
@@ -44,6 +47,34 @@ tests =
4447 , testGroup "Custom test cases"
4548 [ testProperty "prop_composite_case" prop_composite_case ]
4649
50+ , testGroup "prop_bitput_with_get_from_binary"
51+ [ testProperty "Word8" (prop_bitput_with_get_from_binary :: [Word8] -> Property)
52+ , testProperty "Word16" (prop_bitput_with_get_from_binary :: [Word16] -> Property)
53+ , testProperty "Word32" (prop_bitput_with_get_from_binary :: [Word32] -> Property)
54+ -- , testProperty "Word64" (prop_bitput_with_get_from_binary :: [Word64] -> Property)
55+ ]
56+
57+ , testGroup "prop_bitget_with_put_from_binary"
58+ [ testProperty "Word8" (prop_bitget_with_put_from_binary :: [Word8] -> Property)
59+ , testProperty "Word16" (prop_bitget_with_put_from_binary :: [Word16] -> Property)
60+ , testProperty "Word32" (prop_bitget_with_put_from_binary :: [Word32] -> Property)
61+ -- , testProperty "Word64" (prop_bitget_with_put_from_binary :: [Word64] -> Property)
62+ ]
63+
64+ , testGroup "prop_compare_put_with_naive"
65+ [ testProperty "Word8" (prop_compare_put_with_naive :: [Word8] -> Property)
66+ , testProperty "Word16" (prop_compare_put_with_naive :: [Word16] -> Property)
67+ , testProperty "Word32" (prop_compare_put_with_naive :: [Word32] -> Property)
68+ -- , testProperty "Word64" (prop_compare_put_with_naive :: [Word64] -> Property)
69+ ]
70+
71+ , testGroup "prop_compare_get_with_naive"
72+ [ testProperty "Word8" (prop_compare_get_with_naive:: [Word8] -> Property)
73+ , testProperty "Word16" (prop_compare_get_with_naive:: [Word16] -> Property)
74+ , testProperty "Word32" (prop_compare_get_with_naive:: [Word32] -> Property)
75+ -- , testProperty "Word64" (prop_compare_get_with_naive:: [Word64] -> Property)
76+ ]
77+
4778 , testGroup "prop_put_with_bitreq"
4879 [ testProperty "Word8" (prop_putget_with_bitreq :: Word8 -> Property)
4980 , testProperty "Word16" (prop_putget_with_bitreq :: Word16 -> Property)
@@ -83,6 +114,8 @@ prop_putget_with_bitreq w = property $
83114 w' = runGet (runBitGetSimple g) lbs
84115 in w == w'
85116
117+-- | Write a list of items. Each item is written with the maximum amount of
118+-- bits, i.e. 8 for Word8, 16 for Word16, etc.
86119prop_putget_list_simple :: (BinaryBit a, Eq a, Storable a) => [a] -> Property
87120prop_putget_list_simple ws = property $
88121 let s = sizeOf (head ws) * 8
@@ -92,6 +125,8 @@ prop_putget_list_simple ws = property $
92125 ws' = runGet (runBitGetSimple g) lbs
93126 in ws == ws'
94127
128+-- | Write a list of items. Each item is written with exactly as many bits
129+-- as required. Then read it back.
95130prop_putget_list_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => [a] -> Property
96131prop_putget_list_with_bitreq ws = property $
97132 -- write all words with as many bits as it's required
@@ -103,6 +138,28 @@ prop_putget_list_with_bitreq ws = property $
103138 where
104139 bitlist = map bitreq ws
105140
141+-- | Write bits using this library, and read them back using the binary
142+-- library.
143+prop_bitput_with_get_from_binary :: (BinaryBit a, Binary a, Storable a, Eq a) => [a] -> Property
144+prop_bitput_with_get_from_binary ws = property $
145+ let s = sizeOf (head ws) * 8
146+ p = mapM_ (putBits s) ws
147+ g = mapM (const get) ws
148+ lbs = runPut (runBitPut p)
149+ ws' = runGet g lbs
150+ in ws == ws'
151+
152+-- | Write bits using the binary library, and read them back using this
153+-- library.
154+prop_bitget_with_put_from_binary :: (BinaryBit a, Binary a, Storable a, Eq a) => [a] -> Property
155+prop_bitget_with_put_from_binary ws = property $
156+ let s = sizeOf (head ws) * 8
157+ p = mapM_ put ws
158+ g = mapM (const (getBits s)) ws
159+ lbs = runPut p
160+ ws' = runGet (runBitGetSimple g) lbs
161+ in ws == ws'
162+
106163-- number of bits required to write 'v'
107164bitreq :: (Num b, Bits a, Ord a) => a -> b
108165bitreq v = fromIntegral . head $ [ req | (req, top) <- bittable, v <= top ]
@@ -130,6 +187,42 @@ prop_composite_case b w = w < 0x8000 ==>
130187 w' = runGet (runBitGetSimple g) lbs
131188 in w == w'
132189
190+
191+prop_compare_put_with_naive :: (Bits a, BinaryBit a, Ord a) => [a] -> Property
192+prop_compare_put_with_naive ws = property $
193+ let pn = mapM_ (\v -> naive_put (bitreq v) v) ws
194+ p = mapM_ (\v -> putBits (bitreq v) v) ws
195+ lbs_n = runPut (runBitPut pn)
196+ lbs = runPut (runBitPut p)
197+ in lbs_n == lbs
198+
199+prop_compare_get_with_naive :: (Bits a, BinaryBit a, Ord a, Num a) => [a] -> Property
200+prop_compare_get_with_naive ws = property $
201+ let gn = mapM (\v -> naive_get (bitreq v)) ws
202+ g = mapM (\v -> getBits (bitreq v)) ws
203+ p = mapM_ (\v -> naive_put (bitreq v) v) ws
204+ lbs = runPut (runBitPut p)
205+ rn = runGet (runBitGetSimple gn) lbs
206+ r = runGet (runBitGetSimple g ) lbs
207+ -- we must help our compiler to resolve the types of 'gn' and 'g'
208+ types = rn == ws && r == ws
209+ in rn == r
210+
211+-- | Write one bit at a time until the full word has been written
212+naive_put :: (Bits a) => Int -> a -> BitPut ()
213+naive_put n w = mapM_ (\b -> putBool (testBit w b)) [n-1,n-2..0]
214+
215+-- | Read one bit at a time until we've reconstructed the whole word
216+naive_get :: (Bits a, Num a) => Int -> BitGet a
217+naive_get n0 =
218+ let loop 0 acc = return acc
219+ loop n acc = do
220+ b <- getBool
221+ case b of
222+ False -> loop (n-1) (acc `shiftL` 1)
223+ True -> loop (n-1) ((acc `shiftL` 1) + 1)
224+ in loop n0 0
225+
133226{-
134227prop_Word32_from_Word8_and_Word16 :: Word8 -> Word16 -> Property
135228prop_Word32_from_Word8_and_Word16 w8 w16 = property $