Silence warning.
[packages/binary.git] / tests / QC.hs
1 {-# LANGUAGE CPP, ScopedTypeVariables #-}
2 module Main ( main ) where
3
4 #if MIN_VERSION_base(4,8,0)
5 #define HAS_NATURAL
6 #endif
7
8 import Control.Applicative
9 import Control.Exception as C (SomeException,
10 catch, evaluate)
11 import Control.Monad (unless)
12 import qualified Data.ByteString as B
13 import qualified Data.ByteString.Lazy as L
14 import qualified Data.ByteString.Lazy.Internal as L
15 import Data.Int
16 import Data.Ratio
17 import System.IO.Unsafe
18
19 import Test.Framework
20 import Test.Framework.Providers.QuickCheck2
21 import Test.QuickCheck
22
23 import qualified Action (tests)
24 import Arbitrary (
25 #ifdef HAS_NATURAL
26 arbitrarySizedNatural
27 #endif
28 )
29 import Data.Binary
30 import Data.Binary.Get
31 import Data.Binary.Put
32
33 ------------------------------------------------------------------------
34
35 roundTrip :: (Eq a, Binary a) => a -> (L.ByteString -> L.ByteString) -> Bool
36 roundTrip a f = a ==
37 {-# SCC "decode.refragment.encode" #-} decode (f (encode a))
38
39 roundTripWith :: Eq a => (a -> Put) -> Get a -> a -> Property
40 roundTripWith putter getter x =
41 forAll positiveList $ \xs ->
42 x == runGet getter (refragment xs (runPut (putter x)))
43
44 -- make sure that a test fails
45 mustThrowError :: B a
46 mustThrowError a = unsafePerformIO $
47 C.catch (do _ <- C.evaluate a
48 return False)
49 (\(_e :: SomeException) -> return True)
50
51 -- low level ones:
52
53 prop_Word16be :: Word16 -> Property
54 prop_Word16be = roundTripWith putWord16be getWord16be
55
56 prop_Word16le :: Word16 -> Property
57 prop_Word16le = roundTripWith putWord16le getWord16le
58
59 prop_Word16host :: Word16 -> Property
60 prop_Word16host = roundTripWith putWord16host getWord16host
61
62 prop_Word32be :: Word32 -> Property
63 prop_Word32be = roundTripWith putWord32be getWord32be
64
65 prop_Word32le :: Word32 -> Property
66 prop_Word32le = roundTripWith putWord32le getWord32le
67
68 prop_Word32host :: Word32 -> Property
69 prop_Word32host = roundTripWith putWord32host getWord32host
70
71 prop_Word64be :: Word64 -> Property
72 prop_Word64be = roundTripWith putWord64be getWord64be
73
74 prop_Word64le :: Word64 -> Property
75 prop_Word64le = roundTripWith putWord64le getWord64le
76
77 prop_Word64host :: Word64 -> Property
78 prop_Word64host = roundTripWith putWord64host getWord64host
79
80 prop_Wordhost :: Word -> Property
81 prop_Wordhost = roundTripWith putWordhost getWordhost
82
83
84 -- done, partial and fail
85
86 -- | Test partial results.
87 -- May or may not use the whole input, check conditions for the different
88 -- outcomes.
89 prop_partial :: L.ByteString -> Property
90 prop_partial lbs = forAll (choose (0, L.length lbs * 2)) $ \skipN ->
91 let result = pushChunks (runGetIncremental decoder) lbs
92 decoder = do
93 s <- getByteString (fromIntegral skipN)
94 return (L.fromChunks [s])
95 in case result of
96 Partial _ -> L.length lbs < skipN
97 Done unused _pos value ->
98 and [ L.length value == skipN
99 , L.append value (L.fromChunks [unused]) == lbs
100 ]
101 Fail _ _ _ -> False
102
103 -- | Fail a decoder and make sure the result is sane.
104 prop_fail :: L.ByteString -> String -> Property
105 prop_fail lbs msg = forAll (choose (0, L.length lbs)) $ \pos ->
106 let result = pushChunks (runGetIncremental decoder) lbs
107 decoder = do
108 -- use part of the input...
109 _ <- getByteString (fromIntegral pos)
110 -- ... then fail
111 fail msg
112 in case result of
113 Fail unused pos' msg' ->
114 and [ pos == pos'
115 , msg == msg'
116 , L.length lbs - pos == fromIntegral (B.length unused)
117 , L.fromChunks [unused] `L.isSuffixOf` lbs
118 ]
119 _ -> False -- wuut?
120
121 -- read negative length
122 prop_getByteString_negative :: Int -> Property
123 prop_getByteString_negative n =
124 n < 1 ==>
125 runGet (getByteString n) L.empty == B.empty
126
127
128 prop_bytesRead :: L.ByteString -> Property
129 prop_bytesRead lbs =
130 forAll (makeChunks 0 totalLength) $ \chunkSizes ->
131 let result = pushChunks (runGetIncremental decoder) lbs
132 decoder = do
133 -- Read some data and invoke bytesRead several times.
134 -- Each time, check that the values are what we expect.
135 flip mapM_ chunkSizes $ \(total, step) -> do
136 _ <- getByteString (fromIntegral step)
137 n <- bytesRead
138 unless (n == total) $ fail "unexpected position"
139 bytesRead
140 in case result of
141 Done unused pos value ->
142 and [ value == totalLength
143 , pos == value
144 , B.null unused
145 ]
146 Partial _ -> False
147 Fail _ _ _ -> False
148 where
149 totalLength = L.length lbs
150 makeChunks total i
151 | i == 0 = return []
152 | otherwise = do
153 n <- choose (0,i)
154 let total' = total + n
155 rest <- makeChunks total' (i - n)
156 return ((total',n):rest)
157
158
159 -- | We're trying to guarantee that the Decoder will not ask for more input
160 -- with Partial if it has been given Nothing once.
161 -- In this test we're making the decoder return 'Partial' to get more
162 -- input, and to get knownledge of the current position using 'BytesRead'.
163 -- Both of these operations, when used with the <|> operator, result internally
164 -- in that the decoder return with Partial and BytesRead multiple times,
165 -- in which case we need to keep track of if the user has passed Nothing to a
166 -- Partial in the past.
167 prop_partialOnlyOnce :: Property
168 prop_partialOnlyOnce = property $
169 let result = runGetIncremental (decoder <|> decoder)
170 decoder = do
171 0 <- bytesRead
172 _ <- getWord8 -- this will make the decoder return with Partial
173 return "shouldn't get here"
174 in case result of
175 -- we expect Partial followed by Fail
176 Partial k -> case k Nothing of -- push down a Nothing
177 Fail _ _ _ -> True
178 Partial _ -> error $ "partial twice! oh noes!"
179 Done _ _ _ -> error $ "we're not supposed to be done."
180 _ -> error $ "not partial, error!"
181
182 -- read too much
183 prop_readTooMuch :: (Eq a, Binary a) => a -> Bool
184 prop_readTooMuch x = mustThrowError $ x == a && x /= b
185 where
186 -- encode 'a', but try to read 'b' too
187 (a,b) = decode (encode x)
188 _types = [a,b]
189
190 -- In binary-0.5 the Get monad looked like
191 --
192 -- > data S = S {-# UNPACK #-} !B.ByteString
193 -- > L.ByteString
194 -- > {-# UNPACK #-} !Int64
195 -- >
196 -- > newtype Get a = Get { unGet :: S -> (# a, S #) }
197 --
198 -- with a helper function
199 --
200 -- > mkState :: L.ByteString -> Int64 -> S
201 -- > mkState l = case l of
202 -- > L.Empty -> S B.empty L.empty
203 -- > L.Chunk x xs -> S x xs
204 --
205 -- Note that mkState is strict in its first argument. This goes wrong in this
206 -- function:
207 --
208 -- > getBytes :: Int -> Get B.ByteString
209 -- > getBytes n = do
210 -- > S s ss bytes <- traceNumBytes n $ get
211 -- > if n <= B.length s
212 -- > then do let (consume,rest) = B.splitAt n s
213 -- > put $! S rest ss (bytes + fromIntegral n)
214 -- > return $! consume
215 -- > else
216 -- > case L.splitAt (fromIntegral n) (s `join` ss) of
217 -- > (consuming, rest) ->
218 -- > do let now = B.concat . L.toChunks $ consuming
219 -- > put $ mkState rest (bytes + fromIntegral n)
220 -- > -- forces the next chunk before this one is returned
221 -- > if (B.length now < n)
222 -- > then
223 -- > fail "too few bytes"
224 -- > else
225 -- > return now
226 --
227 -- Consider the else-branch of this function; suppose we ask for n bytes;
228 -- the call to L.splitAt gives us a lazy bytestring 'consuming' of precisely @n@
229 -- bytes (unless we don't have enough data, in which case we fail); but then
230 -- the strict evaluation of mkState on 'rest' means we look ahead too far.
231 --
232 -- Although this is all done completely differently in binary-0.7 it is
233 -- important that the same bug does not get introduced in some other way. The
234 -- test is basically the same test that already exists in this test suite,
235 -- verifying that
236 --
237 -- > decode . refragment . encode == id
238 --
239 -- However, we use a different 'refragment', one that introduces an exception
240 -- as the tail of the bytestring after rechunking. If we don't look ahead too
241 -- far then this should make no difference, but if we do then this will throw
242 -- an exception (for instance, in binary-0.5, this will throw an exception for
243 -- certain rechunkings, but not for others).
244 --
245 -- To make sure that the property holds no matter what refragmentation we use,
246 -- we test exhaustively for a single chunk, and all ways to break the string
247 -- into 2, 3 and 4 chunks.
248 prop_lookAheadIndepOfChunking :: (Eq a, Binary a) => a -> Property
249 prop_lookAheadIndepOfChunking testInput =
250 forAll (testCuts (L.length (encode testInput))) $
251 roundTrip testInput . rechunk
252 where
253 testCuts :: forall a. (Num a, Enum a) => a -> Gen [a]
254 testCuts len = elements $ [ [] ]
255 ++ [ [i]
256 | i <- [0 .. len] ]
257 ++ [ [i, j]
258 | i <- [0 .. len]
259 , j <- [0 .. len - i] ]
260 ++ [ [i, j, k]
261 | i <- [0 .. len]
262 , j <- [0 .. len - i]
263 , k <- [0 .. len - i - j] ]
264
265 -- Rechunk a bytestring, leaving the tail as an exception rather than Empty
266 rechunk :: forall a. Integral a => [a] -> L.ByteString -> L.ByteString
267 rechunk cuts = fromChunks . cut cuts . B.concat . L.toChunks
268 where
269 cut :: [a] -> B.ByteString -> [B.ByteString]
270 cut [] bs = [bs]
271 cut (i:is) bs = let (bs0, bs1) = B.splitAt (fromIntegral i) bs
272 in bs0 : cut is bs1
273
274 fromChunks :: [B.ByteString] -> L.ByteString
275 fromChunks [] = error "Binary should not have to ask for this chunk!"
276 fromChunks (bs:bss) = L.Chunk bs (fromChunks bss)
277
278 -- String utilities
279
280 prop_getLazyByteString :: L.ByteString -> Property
281 prop_getLazyByteString lbs = forAll (choose (0, 2 * L.length lbs)) $ \len ->
282 let result = pushChunks (runGetIncremental decoder) lbs
283 decoder = getLazyByteString len
284 in case result of
285 Done unused _pos value ->
286 and [ value == L.take len lbs
287 , L.fromChunks [unused] == L.drop len lbs
288 ]
289 Partial _ -> len > L.length lbs
290 _ -> False
291
292 prop_getLazyByteStringNul :: Word16 -> [Int] -> Property
293 prop_getLazyByteStringNul count0 fragments = count >= 0 ==>
294 forAll (choose (0, count)) $ \pos ->
295 let lbs = case L.splitAt pos (L.replicate count 65) of
296 (start,end) -> refragment fragments $ L.concat [start, L.singleton 0, end]
297 result = pushEndOfInput $ pushChunks (runGetIncremental getLazyByteStringNul) lbs
298 in case result of
299 Done unused pos' value ->
300 and [ value == L.take pos lbs
301 , pos + 1 == pos' -- 1 for the NUL
302 , L.fromChunks [unused] == L.drop (pos + 1) lbs
303 ]
304 _ -> False
305 where
306 count = fromIntegral count0 -- to make the generated numbers a bit smaller
307
308 -- | Same as prop_getLazyByteStringNul, but without any NULL in the string.
309 prop_getLazyByteStringNul_noNul :: Word16 -> [Int] -> Property
310 prop_getLazyByteStringNul_noNul count0 fragments = count >= 0 ==>
311 let lbs = refragment fragments $ L.replicate count 65
312 result = pushEndOfInput $ pushChunks (runGetIncremental getLazyByteStringNul) lbs
313 in case result of
314 Fail _ _ _ -> True
315 _ -> False
316 where
317 count = fromIntegral count0 -- to make the generated numbers a bit smaller
318
319 prop_getRemainingLazyByteString :: L.ByteString -> Property
320 prop_getRemainingLazyByteString lbs = property $
321 let result = pushEndOfInput $ pushChunks (runGetIncremental getRemainingLazyByteString) lbs
322 in case result of
323 Done unused pos value ->
324 and [ value == lbs
325 , B.null unused
326 , fromIntegral pos == L.length lbs
327 ]
328 _ -> False
329
330 -- sanity:
331
332 invariant_lbs :: L.ByteString -> Bool
333 invariant_lbs (L.Empty) = True
334 invariant_lbs (L.Chunk x xs) = not (B.null x) && invariant_lbs xs
335
336 prop_invariant :: (Binary a) => a -> Bool
337 prop_invariant = invariant_lbs . encode
338
339 -- refragment a lazy bytestring's chunks
340 refragment :: [Int] -> L.ByteString -> L.ByteString
341 refragment [] lbs = lbs
342 refragment (x:xs) lbs =
343 let x' = fromIntegral . (+1) . abs $ x
344 rest = refragment xs (L.drop x' lbs) in
345 L.append (L.fromChunks [B.concat . L.toChunks . L.take x' $ lbs]) rest
346
347 -- check identity of refragmentation
348 prop_refragment :: L.ByteString -> [Int] -> Bool
349 prop_refragment lbs xs = lbs == refragment xs lbs
350
351 -- check that refragmention still hold invariant
352 prop_refragment_inv :: L.ByteString -> [Int] -> Bool
353 prop_refragment_inv lbs xs = invariant_lbs $ refragment xs lbs
354
355 main :: IO ()
356 main = defaultMain tests
357
358 ------------------------------------------------------------------------
359
360 #ifdef HAS_NATURAL
361 -- | Until the QuickCheck library implements instance Arbitrary Natural,
362 -- we need this test.
363 prop_test_Natural :: Property
364 prop_test_Natural = forAll arbitrarySizedNatural test
365 #endif
366
367 ------------------------------------------------------------------------
368
369 type T a = a -> Property
370 type B a = a -> Bool
371
372 p :: (Testable p) => p -> Property
373 p = property
374
375 test :: (Eq a, Binary a) => a -> Property
376 test a = forAll positiveList (roundTrip a . refragment)
377
378 positiveList :: Gen [Int]
379 positiveList = fmap (filter (/=0) . map abs) $ arbitrary
380
381 tests :: [Test]
382 tests =
383 [ testGroup "Utils"
384 [ testProperty "refragment id" (p prop_refragment)
385 , testProperty "refragment invariant" (p prop_refragment_inv)
386 ]
387
388 , testGroup "Boundaries"
389 [ testProperty "read to much" (p (prop_readTooMuch :: B Word8))
390 , testProperty "read negative length" (p (prop_getByteString_negative :: T Int))
391 , -- Arbitrary test input
392 let testInput :: [Int] ; testInput = [0 .. 10]
393 in testProperty "look-ahead independent of chunking" (p (prop_lookAheadIndepOfChunking testInput))
394 ]
395
396 , testGroup "Partial"
397 [ testProperty "partial" (p prop_partial)
398 , testProperty "fail" (p prop_fail)
399 , testProperty "bytesRead" (p prop_bytesRead)
400 , testProperty "partial only once" (p prop_partialOnlyOnce)
401 ]
402
403 , testGroup "Model"
404 Action.tests
405
406 , testGroup "Primitives"
407 [ testProperty "Word16be" (p prop_Word16be)
408 , testProperty "Word16le" (p prop_Word16le)
409 , testProperty "Word16host" (p prop_Word16host)
410 , testProperty "Word32be" (p prop_Word32be)
411 , testProperty "Word32le" (p prop_Word32le)
412 , testProperty "Word32host" (p prop_Word32host)
413 , testProperty "Word64be" (p prop_Word64be)
414 , testProperty "Word64le" (p prop_Word64le)
415 , testProperty "Word64host" (p prop_Word64host)
416 , testProperty "Wordhost" (p prop_Wordhost)
417 ]
418
419 , testGroup "String utils"
420 [ testProperty "getLazyByteString" prop_getLazyByteString
421 , testProperty "getLazyByteStringNul" prop_getLazyByteStringNul
422 , testProperty "getLazyByteStringNul No Null" prop_getLazyByteStringNul_noNul
423 , testProperty "getRemainingLazyByteString" prop_getRemainingLazyByteString
424 ]
425
426 , testGroup "Using Binary class, refragmented ByteString" $ map (uncurry testProperty)
427 [ ("()", p (test :: T () ))
428 , ("Bool", p (test :: T Bool ))
429 , ("Ordering", p (test :: T Ordering ))
430 , ("Ratio Int", p (test :: T (Ratio Int) ))
431
432
433 , ("Word8", p (test :: T Word8 ))
434 , ("Word16", p (test :: T Word16 ))
435 , ("Word32", p (test :: T Word32 ))
436 , ("Word64", p (test :: T Word64 ))
437
438 , ("Int8", p (test :: T Int8 ))
439 , ("Int16", p (test :: T Int16 ))
440 , ("Int32", p (test :: T Int32 ))
441 , ("Int64", p (test :: T Int64 ))
442
443 , ("Word", p (test :: T Word ))
444 , ("Int", p (test :: T Int ))
445 , ("Integer", p (test :: T Integer ))
446 #ifdef HAS_NATURAL
447 , ("Natural", (prop_test_Natural :: Property ))
448 #endif
449
450 , ("Float", p (test :: T Float ))
451 , ("Double", p (test :: T Double ))
452
453 , ("Char", p (test :: T Char ))
454
455 , ("[()]", p (test :: T [()] ))
456 , ("[Word8]", p (test :: T [Word8] ))
457 , ("[Word32]", p (test :: T [Word32] ))
458 , ("[Word64]", p (test :: T [Word64] ))
459 , ("[Word]", p (test :: T [Word] ))
460 , ("[Int]", p (test :: T [Int] ))
461 , ("[Integer]", p (test :: T [Integer] ))
462 , ("String", p (test :: T String ))
463 , ("((), ())", p (test :: T ((), ()) ))
464 , ("(Word8, Word32)", p (test :: T (Word8, Word32) ))
465 , ("(Int8, Int32)", p (test :: T (Int8, Int32) ))
466 , ("(Int32, [Int])", p (test :: T (Int32, [Int]) ))
467
468 , ("Maybe Int8", p (test :: T (Maybe Int8) ))
469 , ("Either Int8 Int16", p (test :: T (Either Int8 Int16) ))
470
471 , ("(Int, ByteString)",
472 p (test :: T (Int, B.ByteString) ))
473 , ("[(Int, ByteString)]",
474 p (test :: T [(Int, B.ByteString)] ))
475
476 , ("(Maybe Int64, Bool, [Int])",
477 p (test :: T (Maybe Int64, Bool, [Int])))
478 , ("(Maybe Word8, Bool, [Int], Either Bool Word8)",
479 p (test :: T (Maybe Word8, Bool, [Int], Either Bool Word8) ))
480 , ("(Maybe Word16, Bool, [Int], Either Bool Word16, Int)",
481 p (test :: T (Maybe Word16, Bool, [Int], Either Bool Word16, Int) ))
482
483 , ("(Int,Int,Int,Int,Int,Int)",
484 p (test :: T (Int,Int,Int,Int,Int,Int)))
485 , ("(Int,Int,Int,Int,Int,Int,Int)",
486 p (test :: T (Int,Int,Int,Int,Int,Int,Int)))
487 , ("(Int,Int,Int,Int,Int,Int,Int,Int)",
488 p (test :: T (Int,Int,Int,Int,Int,Int,Int,Int)))
489 , ("(Int,Int,Int,Int,Int,Int,Int,Int,Int)",
490 p (test :: T (Int,Int,Int,Int,Int,Int,Int,Int,Int)))
491 , ("(Int,Int,Int,Int,Int,Int,Int,Int,Int,Int)",
492 p (test :: T (Int,Int,Int,Int,Int,Int,Int,Int,Int,Int)))
493
494 , ("B.ByteString", p (test :: T B.ByteString ))
495 , ("L.ByteString", p (test :: T L.ByteString ))
496 ]
497
498 , testGroup "Invariants" $ map (uncurry testProperty)
499 [ ("B.ByteString invariant", p (prop_invariant :: B B.ByteString ))
500 , ("[B.ByteString] invariant", p (prop_invariant :: B [B.ByteString] ))
501 , ("L.ByteString invariant", p (prop_invariant :: B L.ByteString ))
502 , ("[L.ByteString] invariant", p (prop_invariant :: B [L.ByteString] ))
503 ]
504 ]