binary-0.3: tests/QC.hs
{-# OPTIONS_GHC -fglasgow-exts #-}
module Main where
import Data.Binary
import Data.Binary.Put
import Data.Binary.Get
import qualified Data.ByteString as B
import qualified Data.ByteString.Base as B
import qualified Data.ByteString.Lazy as L
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
import Data.Array (Array)
import Data.Array.IArray
import Data.Array.Unboxed (UArray)
import Control.Monad
import Foreign
import System.Environment
import System.IO
import Test.QuickCheck hiding (test)
import QuickCheckUtils
import Text.Printf
-- import qualified Data.Sequence as Seq
------------------------------------------------------------------------
roundTrip :: (Eq a, Binary a) => a -> (L.ByteString -> L.ByteString) -> Bool
roundTrip a f = a ==
{-# SCC "decode.refragment.encode" #-} decode (f (encode a))
roundTripWith put get x =
forAll positiveList $ \xs ->
x == runGet get (refragment xs (runPut (put x)))
-- low level ones:
prop_Word16be = roundTripWith putWord16be getWord16be
prop_Word16le = roundTripWith putWord16le getWord16le
prop_Word16host = roundTripWith putWord16host getWord16host
prop_Word32be = roundTripWith putWord32be getWord32be
prop_Word32le = roundTripWith putWord32le getWord32le
prop_Word32host = roundTripWith putWord32host getWord32host
prop_Word64be = roundTripWith putWord64be getWord64be
prop_Word64le = roundTripWith putWord64le getWord64le
prop_Word64host = roundTripWith putWord64host getWord64host
prop_Wordhost = roundTripWith putWordhost getWordhost
invariant_lbs :: L.ByteString -> Bool
invariant_lbs (B.LPS []) = True
invariant_lbs (B.LPS xs) = all (not . B.null) xs
prop_invariant :: (Binary a) => a -> Bool
prop_invariant = invariant_lbs . encode
-- be lazy!
-- doesn't do fair testing of lazy put/get.
-- tons of untested cases
-- lazyTrip :: (Binary a, Eq a) => a -> Property
-- lazyTrip a = forAll positiveList $ \xs ->
-- a == (runGet lazyGet . refragment xs . runPut . lazyPut $ a)
-- refragment a lazy bytestring's chunks
refragment :: [Int] -> L.ByteString -> L.ByteString
refragment [] lps = lps
refragment (x:xs) lps =
let x' = fromIntegral . (+1) . abs $ x
rest = refragment xs (L.drop x' lps) in
L.append (L.fromChunks [B.concat . L.toChunks . L.take x' $ lps]) rest
-- check identity of refragmentation
prop_refragment lps xs = lps == refragment xs lps
-- check that refragmention still hold invariant
prop_refragment_inv lps xs = invariant_lbs $ refragment xs lps
main :: IO ()
main = do
hSetBuffering stdout NoBuffering
run tests
run :: [(String, Int -> IO ())] -> IO ()
run tests = do
x <- getArgs
let n = if null x then 100 else read . head $ x
mapM_ (\(s,a) -> printf "%-50s" s >> a n) tests
------------------------------------------------------------------------
type T a = a -> Property
type B a = a -> Bool
p :: Testable a => a -> Int -> IO ()
p = mytest
test :: (Eq a, Binary a) => a -> Property
test a = forAll positiveList (roundTrip a . refragment)
positiveList :: Gen [Int]
positiveList = fmap (filter (/=0) . map abs) $ arbitrary
tests =
-- utils
[ ("refragment id", p prop_refragment )
, ("refragment invariant", p prop_refragment_inv )
-- Primitives
, ("Word16be", p prop_Word16be)
, ("Word16le", p prop_Word16le)
, ("Word16host", p prop_Word16host)
, ("Word32be", p prop_Word32be)
, ("Word32le", p prop_Word32le)
, ("Word32host", p prop_Word32host)
, ("Word64be", p prop_Word64be)
, ("Word64le", p prop_Word64le)
, ("Word64host", p prop_Word64host)
, ("Wordhost", p prop_Wordhost)
-- higher level ones using the Binary class
,("()", p (test :: T () ))
,("Bool", p (test :: T Bool ))
,("Ordering", p (test :: T Ordering ))
,("Word8", p (test :: T Word8 ))
,("Word16", p (test :: T Word16 ))
,("Word32", p (test :: T Word32 ))
,("Word64", p (test :: T Word64 ))
,("Int8", p (test :: T Int8 ))
,("Int16", p (test :: T Int16 ))
,("Int32", p (test :: T Int32 ))
,("Int64", p (test :: T Int64 ))
,("Word", p (test :: T Word ))
,("Int", p (test :: T Int ))
,("Integer", p (test :: T Integer ))
,("Float", p (test :: T Float ))
,("Double", p (test :: T Double ))
,("Char", p (test :: T Char ))
,("[()]", p (test :: T [()] ))
,("[Word8]", p (test :: T [Word8] ))
,("[Word32]", p (test :: T [Word32] ))
,("[Word64]", p (test :: T [Word64] ))
,("[Word]", p (test :: T [Word] ))
,("[Int]", p (test :: T [Int] ))
,("[Integer]", p (test :: T [Integer] ))
,("String", p (test :: T String ))
,("((), ())", p (test :: T ((), ()) ))
,("(Word8, Word32)", p (test :: T (Word8, Word32) ))
,("(Int8, Int32)", p (test :: T (Int8, Int32) ))
,("(Int32, [Int])", p (test :: T (Int32, [Int]) ))
,("Maybe Int8", p (test :: T (Maybe Int8) ))
,("Either Int8 Int16", p (test :: T (Either Int8 Int16) ))
,("(Maybe Word8, Bool, [Int], Either Bool Word8)",
p (test :: T (Maybe Word8, Bool, [Int], Either Bool Word8) ))
,("(Int, ByteString)", p (test :: T (Int, B.ByteString) ))
-- ,("Lazy (Int, ByteString)", p (lazyTrip :: T (Int, B.ByteString) ))
,("[(Int, ByteString)]", p (test :: T [(Int, B.ByteString)] ))
-- ,("Lazy [(Int, ByteString)]", p (lazyTrip :: T [(Int, B.ByteString)] ))
-- ,("Lazy IntMap", p (lazyTrip :: T IntSet.IntSet ))
,("IntSet", p (test :: T IntSet.IntSet ))
,("IntMap ByteString", p (test :: T (IntMap.IntMap B.ByteString) ))
,("B.ByteString", p (test :: T B.ByteString ))
,("L.ByteString", p (test :: T L.ByteString ))
,("B.ByteString invariant", p (prop_invariant :: B B.ByteString ))
,("[B.ByteString] invariant", p (prop_invariant :: B [B.ByteString] ))
,("L.ByteString invariant", p (prop_invariant :: B L.ByteString ))
,("[L.ByteString] invariant", p (prop_invariant :: B [L.ByteString] ))
,("IntMap invariant", p (prop_invariant :: B (IntMap.IntMap B.ByteString) ))
,("Set Word32", p (test :: T (Set.Set Word32) ))
,("Map Word16 Int", p (test :: T (Map.Map Word16 Int) ))
,("(Maybe Int64, Bool, [Int])", p (test :: T (Maybe Int64, Bool, [Int])))
{-
--
-- Big tuples lack an Arbitrary instance in Hugs/QuickCheck
--
,("(Maybe Word16, Bool, [Int], Either Bool Word16, Int)",
p (test :: T (Maybe Word16, Bool, [Int], Either Bool Word16, Int) ))
,("(Maybe Word32, Bool, [Int], Either Bool Word32, Int, Int)", p (roundTrip :: (Maybe Word32, Bool, [Int], Either Bool Word32, Int, Int) -> Bool))
,("(Maybe Word64, Bool, [Int], Either Bool Word64, Int, Int, Int)", p (roundTrip :: (Maybe Word64, Bool, [Int], Either Bool Word64, Int, Int, Int) -> Bool))
-}
-- GHC only:
-- ,("Sequence", p (roundTrip :: Seq.Seq Int64 -> Bool))
-- Obsolete
-- ,("ensureLeft/Fail", mytest (shouldFail (decode L.empty :: Either ParseError Int)))
]