{-# LANGUAGE NumDecimals #-} {-# LANGUAGE RankNTypes #-} module QuickCheck (props) where import Control.Applicative import Data.Typeable (Typeable) import Data.Int import Data.ByteString.Lazy as BSL import Data.Binary import Data.Binary.Typed import Data.Binary.Typed.Internal import Test.Tasty import Test.Tasty.QuickCheck import Text.Show.Functions () -- This fixes the missing Show (a->b) instance in -- Travis. Can probably be removed in the future. -- | The entire QuickCheck test tree, to be imported qualified props :: TestTree props = tree tests where tree = testGroup "QuickCheck" tests = [ prop_inverses , prop_api , prop_internal , prop_sizes ] -- ############################################################################# -- ### Decode is left-inverse to encode ###################################### -- ############################################################################# -- | Check whether typed encoding and decoding are inverses of each other prop_inverses :: TestTree prop_inverses = tree tests where tree = testGroup "decode.encode = id" tests = [ prop_inverses_int , prop_inverses_string ] -- | Check whether encoding and decoding an Int works properly prop_inverses_int :: TestTree prop_inverses_int = tree tests where tree = localOption (QuickCheckMaxSize maxBound) . testGroup "Int" tests = [ testProperty "Untyped" (prop Untyped) , testProperty "Hashed32" (prop Hashed32) , testProperty "Hashed64" (prop Hashed64) , testProperty "Shown" (prop Shown) , testProperty "Full" (prop Full) ] prop :: TypeFormat -> Int -> Bool prop format i = unsafeDecodeTyped (encodeTyped format i) == i -- | Check whether encoding and decoding a String works properly prop_inverses_string :: TestTree prop_inverses_string = tree tests where tree = localOption (QuickCheckMaxSize 100) . testGroup "String" tests = [ testProperty "Untyped" (prop Untyped) , testProperty "Hashed32" (prop Hashed32) , testProperty "Hashed64" (prop Hashed64) , testProperty "Shown" (prop Shown) , testProperty "Full" (prop Full) ] prop :: TypeFormat -> String -> Bool prop format i = unsafeDecodeTyped (encodeTyped format i) == i -- ############################################################################# -- ### API tests ############################################################# -- ############################################################################# -- | Check whether the laws mentioned in the docs hold prop_api :: TestTree prop_api = tree tests where tree = testGroup "API" tests = [ testProperty "erase inverse of typed" prop_erase , testProperty "mapTyped id ~ id" prop_mapTyped_id , testProperty "mapTyped f.g ~ mapTyped f . mapTyped g" prop_mapTyped_compose , testProperty "reType equivalent to reconstruction" prop_reType , testProperty "encodeTyped = encode.typed" prop_encodeTyped ] prop_erase :: TypeFormat -> Int -> Bool prop_erase format x = erase (typed format x) == x prop_mapTyped_id :: Typed Double -> Bool prop_mapTyped_id x = x `isEqual` mapTyped id x prop_mapTyped_compose :: (Int -> Maybe Integer) -> (Double -> Int) -> Typed Double -> Bool prop_mapTyped_compose f g x = mapTyped (f . g) x `isIdentical` (mapTyped f . mapTyped g) x prop_reType :: TypeFormat -> Typed Int -> Bool prop_reType format x =reType format x `isIdentical` typed format (erase x) prop_encodeTyped :: TypeFormat -> Int -> Bool prop_encodeTyped format value = (unsafeDecodeTyped (encodeTyped format value) :: Int) == (unsafeDecodeTyped (encode (typed format value)) :: Int) -- | Equality of 'Typed' values, taking only the contained value into account. -- See also 'isIdentical'. isEqual :: Eq a => Typed a -> Typed a -> Bool isEqual (Typed _tyA a) (Typed _tyB b) = a == b -- | Equality of 'Typed' values, taking the contained type representation into -- account. This means that a cached and an uncached (otherwise identical) -- type representation are unequal. -- See also 'isEqual'. isIdentical :: Eq a => Typed a -> Typed a -> Bool isIdentical (Typed tyA a) (Typed tyB b) = (tyA, a) == (tyB, b) instance (Arbitrary a, Typeable a) => Arbitrary (Typed a) where arbitrary = frequency [(10, plain), (5, cached), (3, cached2)] where plain = typed <$> arbitrary <*> arbitrary cached = fmap preserializeTyped plain cached2 = fmap preserializeTyped cached preserializeTyped (Typed ty x) = Typed (preserialize ty) x instance Arbitrary TypeFormat where arbitrary = elements [Untyped, Hashed32, Hashed64, Shown, Full] -- ############################################################################# -- ### Internal functions #################################################### -- ############################################################################# prop_internal :: TestTree prop_internal = tree tests where tree = testGroup "Internal" tests = [ localOption (QuickCheckMaxSize 10) (testProperty "stripTypeRep . unStripTypeRep = id" prop_stripTypeRep_inverses) , testProperty "stripTyCon . unStripTyCon = id" prop_stripTyCon_inverses , testProperty "getFormat extracts format correctly" prop_getFormat ] -- getFormat extracts the right format prop_getFormat :: Typed Double -> Bool prop_getFormat t@(Typed ty x) = t `isEqual` typed (getFormat ty) x prop_stripTypeRep_inverses :: TypeRep -> Bool prop_stripTypeRep_inverses x = (stripTypeRep . unStripTypeRep) x == x prop_stripTyCon_inverses :: TyCon -> Bool prop_stripTyCon_inverses x = (stripTyCon . unStripTyCon) x == x instance Arbitrary TyCon where arbitrary = TyCon <$> arbitrary <*> arbitrary <*> arbitrary instance Arbitrary TypeRep where arbitrary = TypeRep <$> arbitrary <*> args where args = listOf (modifySize (`div` 2) arbitrary) -- | Modify the size parameter of a 'Gen'. modifySize :: (Int -> Int) -> Gen a -> Gen a modifySize f gen = sized (\n -> resize (f n) gen) -- ############################################################################# -- ### Encoding sizes ######################################################## -- ############################################################################# -- | Are the additional message sizes stated by the docs accurate? -- -- Untyped: +1 byte -- Hashed32: +5 byte -- Hashed64: +9 byte prop_sizes :: TestTree prop_sizes = tree tests where tree = testGroup "Data sizes" tests = [ testProperty "Untyped: +1 byte" (prop_size_added (encodeTyped Untyped) 1) , testProperty "Hashed32: +5 byte" (prop_size_added (encodeTyped Hashed32) 5) , testProperty "Hashed64: +9 byte" (prop_size_added (encodeTyped Hashed64) 9) ] type Complicated = Either (Char, Int) (Either String (Maybe Integer)) -- | Check whether data created with a certain format has a certain -- overhead over the direct Binary serialization. prop_size_added :: (forall a. (Typeable a, Binary a) => a -> BSL.ByteString) -> Int64 -> Property prop_size_added serializer n = conjoin [ forAll arbitrary (verify :: Integer -> Bool) , forAll arbitrary (verify :: Double -> Bool) , forAll arbitrary (verify :: [Double] -> Bool) , forAll arbitrary (verify :: Complicated -> Bool) ] where binSize :: Binary a => a -> Int64 binSize = BSL.length . encode typedSize :: (Binary a, Typeable a) => a -> Int64 typedSize = BSL.length . serializer verify :: (Binary a, Typeable a) => a -> Bool verify x = binSize x + n == typedSize x