2010-08-17 01:33:18 +04:00
|
|
|
module Main where
|
|
|
|
|
|
|
|
import Data.Binary ( encode )
|
2010-08-26 17:19:02 +04:00
|
|
|
import Data.Binary.Get ( runGet )
|
|
|
|
import Data.Binary.Put ( runPut )
|
2010-08-17 01:33:18 +04:00
|
|
|
|
2010-08-26 18:41:05 +04:00
|
|
|
import Bits
|
|
|
|
|
2010-08-17 23:30:23 +04:00
|
|
|
import Data.Bits
|
2010-08-17 01:33:18 +04:00
|
|
|
import Data.Word
|
2010-08-26 18:41:05 +04:00
|
|
|
import Foreign.Storable
|
2010-08-17 01:33:18 +04:00
|
|
|
import System.Random
|
|
|
|
|
2010-08-26 17:19:02 +04:00
|
|
|
import BitsGet
|
|
|
|
import BitsPut
|
2010-08-17 01:33:18 +04:00
|
|
|
|
|
|
|
import Test.QuickCheck
|
|
|
|
|
2010-08-17 23:30:23 +04:00
|
|
|
main = do
|
2010-08-24 22:07:59 +04:00
|
|
|
quickCheck prop_Bools
|
2010-08-26 17:19:02 +04:00
|
|
|
quickCheck prop_SimpleCase
|
2010-08-26 18:41:05 +04:00
|
|
|
|
|
|
|
quickCheck (prop_putget_with_bitreq :: Word8 -> Property)
|
|
|
|
quickCheck (prop_putget_with_bitreq :: Word16 -> Property)
|
|
|
|
|
|
|
|
quickCheck (prop_putget_list_simple :: [Bool] -> Property)
|
|
|
|
quickCheck (prop_putget_list_simple :: [Word8] -> Property)
|
|
|
|
quickCheck (prop_putget_list_simple :: [Word16] -> Property)
|
|
|
|
|
|
|
|
quickCheck (prop_putget_list_with_bitreq :: [Word8] -> Property)
|
|
|
|
quickCheck (prop_putget_list_with_bitreq :: [Word16] -> Property)
|
2010-08-17 23:30:23 +04:00
|
|
|
|
2010-08-24 22:15:29 +04:00
|
|
|
-- these tests use the R structure
|
|
|
|
--
|
|
|
|
-- quickCheck prop_Word32_from_2_Word16
|
|
|
|
-- quickCheck prop_Word32_from_Word8_and_Word16
|
|
|
|
|
2010-08-26 18:41:05 +04:00
|
|
|
prop_putget_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => a -> Property
|
|
|
|
prop_putget_with_bitreq w = property $
|
2010-08-26 17:24:53 +04:00
|
|
|
-- write all words with as many bits as it's required
|
2010-08-26 18:41:05 +04:00
|
|
|
let p = putBits (bitreq w) w
|
|
|
|
g = getBits (bitreq w)
|
2010-08-26 17:19:02 +04:00
|
|
|
lbs = runPut (runBitPut p)
|
|
|
|
w' = runGet (runBitGetSimple g) lbs
|
|
|
|
in w == w'
|
|
|
|
|
2010-08-26 18:41:05 +04:00
|
|
|
prop_putget_list_simple :: (BinaryBit a, Eq a, Storable a) => [a] -> Property
|
|
|
|
prop_putget_list_simple ws = property $
|
|
|
|
let s = sizeOf (head ws) * 8
|
|
|
|
p = mapM_ (\v -> putBits s v) ws
|
|
|
|
g = mapM (const (getBits s)) ws
|
2010-08-26 17:19:02 +04:00
|
|
|
lbs = runPut (runBitPut p)
|
|
|
|
ws' = runGet (runBitGetSimple g) lbs
|
|
|
|
in ws == ws'
|
|
|
|
|
2010-08-26 18:41:05 +04:00
|
|
|
prop_putget_list_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => [a] -> Property
|
|
|
|
prop_putget_list_with_bitreq ws = property $
|
2010-08-26 17:24:53 +04:00
|
|
|
-- write all words with as many bits as it's required
|
2010-08-26 18:41:05 +04:00
|
|
|
let p = mapM_ (\v -> putBits (bitreq v) v) ws
|
|
|
|
g = mapM getBits bitlist
|
2010-08-26 17:19:02 +04:00
|
|
|
lbs = runPut (runBitPut p)
|
|
|
|
ws' = runGet (runBitGetSimple g) lbs
|
|
|
|
in ws == ws'
|
|
|
|
where
|
|
|
|
bitlist = map bitreq ws
|
|
|
|
|
|
|
|
-- number of bits required to write 'v'
|
|
|
|
bitreq :: (Num b, Bits a, Ord a) => a -> b
|
2010-08-24 22:07:59 +04:00
|
|
|
bitreq v = fromIntegral . head $ [ req | (req, top) <- bittable, v <= top ]
|
2010-08-26 17:19:02 +04:00
|
|
|
|
|
|
|
bittable :: Bits a => [(Integer, a)]
|
2010-08-26 17:24:53 +04:00
|
|
|
bittable = [ (fromIntegral x, (1 `shiftL` x) - 1) | x <- [1..64] ]
|
2010-08-24 22:07:59 +04:00
|
|
|
|
|
|
|
prop_Bools :: [Bool] -> Property
|
|
|
|
prop_Bools bs = property $
|
2010-08-26 17:19:02 +04:00
|
|
|
let p = sequence . replicate (length bs) $ getBool
|
|
|
|
Right bs' = runGet (runBitGet p) lbs
|
2010-08-24 22:07:59 +04:00
|
|
|
in bs == bs'
|
2010-08-26 17:19:02 +04:00
|
|
|
where lbs = runPut $ runBitPut (mapM_ putBool bs)
|
|
|
|
|
|
|
|
prop_SimpleCase :: Bool -> Word16 -> Property
|
|
|
|
prop_SimpleCase b w = w < 0x8000 ==>
|
|
|
|
let p = do putBool b
|
|
|
|
putWord16be 15 w
|
|
|
|
g = do v <- getBool
|
|
|
|
case v of
|
|
|
|
True -> getWord16be 15
|
|
|
|
False -> do
|
|
|
|
msb <- getWord8 7
|
|
|
|
lsb <- getWord8 8
|
|
|
|
return ((fromIntegral msb `shiftL` 8) .|. fromIntegral lsb)
|
|
|
|
lbs = runPut (runBitPut p)
|
|
|
|
w' = runGet (runBitGetSimple g) lbs
|
|
|
|
in w == w'
|
|
|
|
where
|
2010-08-24 22:07:59 +04:00
|
|
|
|
2010-08-24 22:15:29 +04:00
|
|
|
|
|
|
|
{-
|
2010-08-17 23:30:23 +04:00
|
|
|
prop_Word32_from_Word8_and_Word16 :: Word8 -> Word16 -> Property
|
|
|
|
prop_Word32_from_Word8_and_Word16 w8 w16 = property $
|
|
|
|
let p = RWord32be 24
|
|
|
|
w' = runGet (get p) lbs
|
|
|
|
in w0 == w'
|
|
|
|
where
|
|
|
|
lbs = runPut (putWord8 w8 >> putWord16be w16)
|
|
|
|
w0 = ((fromIntegral w8) `shiftL` 16) .|. fromIntegral w16
|
|
|
|
|
|
|
|
prop_Word32_from_2_Word16 :: Word16 -> Word16 -> Property
|
|
|
|
prop_Word32_from_2_Word16 w1 w2 = property $
|
|
|
|
let p = RWord32be 32
|
|
|
|
w' = runGet (get p) lbs
|
|
|
|
in w0 == w'
|
|
|
|
where
|
|
|
|
lbs = encode w0
|
|
|
|
w0 = ((fromIntegral w1) `shiftL` 16) .|. fromIntegral w2
|
2010-08-24 22:15:29 +04:00
|
|
|
-}
|
2010-08-17 23:30:23 +04:00
|
|
|
|
2010-08-17 01:33:18 +04:00
|
|
|
instance Arbitrary Word8 where
|
|
|
|
arbitrary = choose (minBound, maxBound)
|
|
|
|
shrink 0 = []
|
|
|
|
shrink n = [ n - 1 ]
|
|
|
|
|
|
|
|
instance Arbitrary Word16 where
|
|
|
|
arbitrary = choose (minBound, maxBound)
|
|
|
|
shrink 0 = []
|
2010-08-26 17:19:02 +04:00
|
|
|
shrink n = [ n - 10000, n - 1000, n - 100, n - 1 ]
|
2010-08-17 01:33:18 +04:00
|
|
|
|
|
|
|
instance Arbitrary Word32 where
|
|
|
|
arbitrary = choose (minBound, maxBound)
|
|
|
|
|
|
|
|
instance Arbitrary Word64 where
|
|
|
|
arbitrary = choose (minBound, maxBound)
|
|
|
|
|
|
|
|
|
|
|
|
integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)
|
|
|
|
integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer,
|
|
|
|
fromIntegral b :: Integer) g of
|
|
|
|
(x,g) -> (fromIntegral x, g)
|
|
|
|
|
|
|
|
instance Random Word where
|
|
|
|
randomR = integralRandomR
|
|
|
|
random = randomR (minBound,maxBound)
|
|
|
|
|
|
|
|
instance Random Word8 where
|
|
|
|
randomR = integralRandomR
|
|
|
|
random = randomR (minBound,maxBound)
|
|
|
|
|
|
|
|
instance Random Word16 where
|
|
|
|
randomR = integralRandomR
|
|
|
|
random = randomR (minBound,maxBound)
|
|
|
|
|
|
|
|
instance Random Word32 where
|
|
|
|
randomR = integralRandomR
|
|
|
|
random = randomR (minBound,maxBound)
|
|
|
|
|
|
|
|
instance Random Word64 where
|
|
|
|
randomR = integralRandomR
|
|
|
|
random = randomR (minBound,maxBound)
|