c3d4d5875457f18559e8515a48263efb771fb6c5
[packages/binary.git] / tests / QC.hs
1 {-# LANGUAGE ScopedTypeVariables #-}
2 module Main where
3
4 import Data.Binary
5 import Data.Binary.Put
6 import Data.Binary.Get
7
8 import Control.Applicative
9 import Control.Monad (unless)
10
11 import qualified Data.ByteString as B
12 -- import qualified Data.ByteString.Internal as B
13 -- import qualified Data.ByteString.Unsafe as B
14 import qualified Data.ByteString.Lazy as L
15 import qualified Data.ByteString.Lazy.Internal as L
16 -- import qualified Data.Map as Map
17 -- import qualified Data.Set as Set
18 -- import qualified Data.IntMap as IntMap
19 -- import qualified Data.IntSet as IntSet
20
21 -- import Data.Array (Array)
22 -- import Data.Array.IArray
23 -- import Data.Array.Unboxed (UArray)
24
25 -- import Data.Word
26 import Data.Int
27 import Data.Ratio
28
29 import Control.Exception as C (catch,evaluate,SomeException)
30 -- import Control.Monad
31 -- import System.Environment
32 -- import System.IO
33 import System.IO.Unsafe
34
35 import Test.QuickCheck
36 -- import Text.Printf
37
38 import Test.Framework
39 import Test.Framework.Providers.QuickCheck2
40 -- import Data.Monoid
41
42 import Action (prop_action)
43 import Arbitrary()
44
45 ------------------------------------------------------------------------
46
47 roundTrip :: (Eq a, Binary a) => a -> (L.ByteString -> L.ByteString) -> Bool
48 roundTrip a f = a ==
49 {-# SCC "decode.refragment.encode" #-} decode (f (encode a))
50
51 roundTripWith :: Eq a => (a -> Put) -> Get a -> a -> Property
52 roundTripWith putter getter x =
53 forAll positiveList $ \xs ->
54 x == runGet getter (refragment xs (runPut (putter x)))
55
56 -- make sure that a test fails
57 mustThrowError :: B a
58 mustThrowError a = unsafePerformIO $
59 C.catch (do _ <- C.evaluate a
60 return False)
61 (\(_e :: SomeException) -> return True)
62
63 -- low level ones:
64
65 prop_Word16be :: Word16 -> Property
66 prop_Word16be = roundTripWith putWord16be getWord16be
67
68 prop_Word16le :: Word16 -> Property
69 prop_Word16le = roundTripWith putWord16le getWord16le
70
71 prop_Word16host :: Word16 -> Property
72 prop_Word16host = roundTripWith putWord16host getWord16host
73
74 prop_Word32be :: Word32 -> Property
75 prop_Word32be = roundTripWith putWord32be getWord32be
76
77 prop_Word32le :: Word32 -> Property
78 prop_Word32le = roundTripWith putWord32le getWord32le
79
80 prop_Word32host :: Word32 -> Property
81 prop_Word32host = roundTripWith putWord32host getWord32host
82
83 prop_Word64be :: Word64 -> Property
84 prop_Word64be = roundTripWith putWord64be getWord64be
85
86 prop_Word64le :: Word64 -> Property
87 prop_Word64le = roundTripWith putWord64le getWord64le
88
89 prop_Word64host :: Word64 -> Property
90 prop_Word64host = roundTripWith putWord64host getWord64host
91
92 prop_Wordhost :: Word -> Property
93 prop_Wordhost = roundTripWith putWordhost getWordhost
94
95
96 -- done, partial and fail
97
98 -- | Test partial results.
99 -- May or may not use the whole input, check conditions for the different
100 -- outcomes.
101 prop_partial :: L.ByteString -> Property
102 prop_partial lbs = forAll (choose (0, L.length lbs * 2)) $ \skipN ->
103 let result = pushChunks (runGetIncremental decoder) lbs
104 decoder = do
105 s <- getByteString (fromIntegral skipN)
106 return (L.fromChunks [s])
107 in case result of
108 Partial _ -> L.length lbs < skipN
109 Done unused _pos value ->
110 and [ L.length value == skipN
111 , L.append value (L.fromChunks [unused]) == lbs
112 ]
113 Fail _ _ _ -> False
114
115 -- | Fail a decoder and make sure the result is sane.
116 prop_fail :: L.ByteString -> String -> Property
117 prop_fail lbs msg = forAll (choose (0, L.length lbs)) $ \pos ->
118 let result = pushChunks (runGetIncremental decoder) lbs
119 decoder = do
120 -- use part of the input...
121 _ <- getByteString (fromIntegral pos)
122 -- ... then fail
123 fail msg
124 in case result of
125 Fail unused pos' msg' ->
126 and [ pos == pos'
127 , msg == msg'
128 , L.length lbs - pos == fromIntegral (B.length unused)
129 , L.fromChunks [unused] `L.isSuffixOf` lbs
130 ]
131 _ -> False -- wuut?
132
133 -- read negative length
134 prop_getByteString_negative :: Int -> Property
135 prop_getByteString_negative n =
136 n < 1 ==>
137 runGet (getByteString n) L.empty == B.empty
138
139
140 prop_bytesRead :: L.ByteString -> Property
141 prop_bytesRead lbs =
142 forAll (makeChunks 0 totalLength) $ \chunkSizes ->
143 let result = pushChunks (runGetIncremental decoder) lbs
144 decoder = do
145 -- Read some data and invoke bytesRead several times.
146 -- Each time, check that the values are what we expect.
147 flip mapM_ chunkSizes $ \(total, step) -> do
148 _ <- getByteString (fromIntegral step)
149 n <- bytesRead
150 unless (n == total) $ fail "unexpected position"
151 bytesRead
152 in case result of
153 Done unused pos value ->
154 and [ value == totalLength
155 , pos == value
156 , B.null unused
157 ]
158 Partial _ -> False
159 Fail _ _ _ -> False
160 where
161 totalLength = L.length lbs
162 makeChunks total i
163 | i == 0 = return []
164 | otherwise = do
165 n <- choose (0,i)
166 let total' = total + n
167 rest <- makeChunks total' (i - n)
168 return ((total',n):rest)
169
170
171 -- | We're trying to guarantee that the Decoder will not ask for more input
172 -- with Partial if it has been given Nothing once.
173 -- In this test we're making the decoder return 'Partial' to get more
174 -- input, and to get knownledge of the current position using 'BytesRead'.
175 -- Both of these operations, when used with the <|> operator, result internally
176 -- in that the decoder return with Partial and BytesRead multiple times,
177 -- in which case we need to keep track of if the user has passed Nothing to a
178 -- Partial in the past.
179 prop_partialOnlyOnce :: Property
180 prop_partialOnlyOnce = property $
181 let result = runGetIncremental (decoder <|> decoder)
182 decoder = do
183 0 <- bytesRead
184 _ <- getWord8 -- this will make the decoder return with Partial
185 return "shouldn't get here"
186 in case result of
187 -- we expect Partial followed by Fail
188 Partial k -> case k Nothing of -- push down a Nothing
189 Fail _ _ _ -> True
190 Partial _ -> error $ "partial twice! oh noes!"
191 Done _ _ _ -> error $ "we're not supposed to be done."
192 _ -> error $ "not partial, error!"
193
194 -- read too much
195 prop_readTooMuch :: (Eq a, Binary a) => a -> Bool
196 prop_readTooMuch x = mustThrowError $ x == a && x /= b
197 where
198 -- encode 'a', but try to read 'b' too
199 (a,b) = decode (encode x)
200 _types = [a,b]
201
202
203 -- String utilities
204
205 prop_getLazyByteString :: L.ByteString -> Property
206 prop_getLazyByteString lbs = forAll (choose (0, 2 * L.length lbs)) $ \len ->
207 let result = pushChunks (runGetIncremental decoder) lbs
208 decoder = getLazyByteString len
209 in case result of
210 Done unused _pos value ->
211 and [ value == L.take len lbs
212 , L.fromChunks [unused] == L.drop len lbs
213 ]
214 Partial _ -> len > L.length lbs
215 _ -> False
216
217 prop_getLazyByteStringNul :: Word16 -> [Int] -> Property
218 prop_getLazyByteStringNul count0 fragments = count >= 0 ==>
219 forAll (choose (0, count)) $ \pos ->
220 let lbs = case L.splitAt pos (L.replicate count 65) of
221 (start,end) -> refragment fragments $ L.concat [start, L.singleton 0, end]
222 result = pushEndOfInput $ pushChunks (runGetIncremental getLazyByteStringNul) lbs
223 in case result of
224 Done unused pos' value ->
225 and [ value == L.take pos lbs
226 , pos + 1 == pos' -- 1 for the NUL
227 , L.fromChunks [unused] == L.drop (pos + 1) lbs
228 ]
229 _ -> False
230 where
231 count = fromIntegral count0 -- to make the generated numbers a bit smaller
232
233 -- | Same as prop_getLazyByteStringNul, but without any NULL in the string.
234 prop_getLazyByteStringNul_noNul :: Word16 -> [Int] -> Property
235 prop_getLazyByteStringNul_noNul count0 fragments = count >= 0 ==>
236 let lbs = refragment fragments $ L.replicate count 65
237 result = pushEndOfInput $ pushChunks (runGetIncremental getLazyByteStringNul) lbs
238 in case result of
239 Fail _ _ _ -> True
240 _ -> False
241 where
242 count = fromIntegral count0 -- to make the generated numbers a bit smaller
243
244 prop_getRemainingLazyByteString :: L.ByteString -> Property
245 prop_getRemainingLazyByteString lbs = property $
246 let result = pushEndOfInput $ pushChunks (runGetIncremental getRemainingLazyByteString) lbs
247 in case result of
248 Done unused pos value ->
249 and [ value == lbs
250 , B.null unused
251 , fromIntegral pos == L.length lbs
252 ]
253 _ -> False
254
255 -- sanity:
256
257 invariant_lbs :: L.ByteString -> Bool
258 invariant_lbs (L.Empty) = True
259 invariant_lbs (L.Chunk x xs) = not (B.null x) && invariant_lbs xs
260
261 prop_invariant :: (Binary a) => a -> Bool
262 prop_invariant = invariant_lbs . encode
263
264 -- refragment a lazy bytestring's chunks
265 refragment :: [Int] -> L.ByteString -> L.ByteString
266 refragment [] lbs = lbs
267 refragment (x:xs) lbs =
268 let x' = fromIntegral . (+1) . abs $ x
269 rest = refragment xs (L.drop x' lbs) in
270 L.append (L.fromChunks [B.concat . L.toChunks . L.take x' $ lbs]) rest
271
272 -- check identity of refragmentation
273 prop_refragment :: L.ByteString -> [Int] -> Bool
274 prop_refragment lbs xs = lbs == refragment xs lbs
275
276 -- check that refragmention still hold invariant
277 prop_refragment_inv :: L.ByteString -> [Int] -> Bool
278 prop_refragment_inv lbs xs = invariant_lbs $ refragment xs lbs
279
280 main :: IO ()
281 main = defaultMain tests
282
283 ------------------------------------------------------------------------
284
285 type T a = a -> Property
286 type B a = a -> Bool
287
288 p :: (Testable p) => p -> Property
289 p = property
290
291 test :: (Eq a, Binary a) => a -> Property
292 test a = forAll positiveList (roundTrip a . refragment)
293
294 positiveList :: Gen [Int]
295 positiveList = fmap (filter (/=0) . map abs) $ arbitrary
296
297 tests :: [Test]
298 tests =
299 [ testGroup "Utils"
300 [ testProperty "refragment id" (p prop_refragment)
301 , testProperty "refragment invariant" (p prop_refragment_inv)
302 ]
303
304 , testGroup "Boundaries"
305 [ testProperty "read to much" (p (prop_readTooMuch :: B Word8))
306 , testProperty "read negative length" (p (prop_getByteString_negative :: T Int))
307 ]
308
309 , testGroup "Partial"
310 [ testProperty "partial" (p prop_partial)
311 , testProperty "fail" (p prop_fail)
312 , testProperty "bytesRead" (p prop_bytesRead)
313 , testProperty "partial only once" (p prop_partialOnlyOnce)
314 ]
315
316 , testGroup "Model"
317 [ testProperty "action" Action.prop_action
318 ]
319
320 , testGroup "Primitives"
321 [ testProperty "Word16be" (p prop_Word16be)
322 , testProperty "Word16le" (p prop_Word16le)
323 , testProperty "Word16host" (p prop_Word16host)
324 , testProperty "Word32be" (p prop_Word32be)
325 , testProperty "Word32le" (p prop_Word32le)
326 , testProperty "Word32host" (p prop_Word32host)
327 , testProperty "Word64be" (p prop_Word64be)
328 , testProperty "Word64le" (p prop_Word64le)
329 , testProperty "Word64host" (p prop_Word64host)
330 , testProperty "Wordhost" (p prop_Wordhost)
331 ]
332
333 , testGroup "String utils"
334 [ testProperty "getLazyByteString" prop_getLazyByteString
335 , testProperty "getLazyByteStringNul" prop_getLazyByteStringNul
336 , testProperty "getLazyByteStringNul No Null" prop_getLazyByteStringNul_noNul
337 , testProperty "getRemainingLazyByteString" prop_getRemainingLazyByteString
338 ]
339
340 , testGroup "Using Binary class, refragmented ByteString" $ map (uncurry testProperty)
341 [ ("()", p (test :: T () ))
342 , ("Bool", p (test :: T Bool ))
343 , ("Ordering", p (test :: T Ordering ))
344 , ("Ratio Int", p (test :: T (Ratio Int) ))
345
346
347 , ("Word8", p (test :: T Word8 ))
348 , ("Word16", p (test :: T Word16 ))
349 , ("Word32", p (test :: T Word32 ))
350 , ("Word64", p (test :: T Word64 ))
351
352 , ("Int8", p (test :: T Int8 ))
353 , ("Int16", p (test :: T Int16 ))
354 , ("Int32", p (test :: T Int32 ))
355 , ("Int64", p (test :: T Int64 ))
356
357 , ("Word", p (test :: T Word ))
358 , ("Int", p (test :: T Int ))
359 , ("Integer", p (test :: T Integer ))
360
361 , ("Float", p (test :: T Float ))
362 , ("Double", p (test :: T Double ))
363
364 , ("Char", p (test :: T Char ))
365
366 , ("[()]", p (test :: T [()] ))
367 , ("[Word8]", p (test :: T [Word8] ))
368 , ("[Word32]", p (test :: T [Word32] ))
369 , ("[Word64]", p (test :: T [Word64] ))
370 , ("[Word]", p (test :: T [Word] ))
371 , ("[Int]", p (test :: T [Int] ))
372 , ("[Integer]", p (test :: T [Integer] ))
373 , ("String", p (test :: T String ))
374 , ("((), ())", p (test :: T ((), ()) ))
375 , ("(Word8, Word32)", p (test :: T (Word8, Word32) ))
376 , ("(Int8, Int32)", p (test :: T (Int8, Int32) ))
377 , ("(Int32, [Int])", p (test :: T (Int32, [Int]) ))
378
379 , ("Maybe Int8", p (test :: T (Maybe Int8) ))
380 , ("Either Int8 Int16", p (test :: T (Either Int8 Int16) ))
381
382 , ("(Int, ByteString)",
383 p (test :: T (Int, B.ByteString) ))
384 , ("[(Int, ByteString)]",
385 p (test :: T [(Int, B.ByteString)] ))
386
387 , ("(Maybe Int64, Bool, [Int])",
388 p (test :: T (Maybe Int64, Bool, [Int])))
389 , ("(Maybe Word8, Bool, [Int], Either Bool Word8)",
390 p (test :: T (Maybe Word8, Bool, [Int], Either Bool Word8) ))
391 , ("(Maybe Word16, Bool, [Int], Either Bool Word16, Int)",
392 p (test :: T (Maybe Word16, Bool, [Int], Either Bool Word16, Int) ))
393
394 , ("(Int,Int,Int,Int,Int,Int)",
395 p (test :: T (Int,Int,Int,Int,Int,Int)))
396 , ("(Int,Int,Int,Int,Int,Int,Int)",
397 p (test :: T (Int,Int,Int,Int,Int,Int,Int)))
398 , ("(Int,Int,Int,Int,Int,Int,Int,Int)",
399 p (test :: T (Int,Int,Int,Int,Int,Int,Int,Int)))
400 , ("(Int,Int,Int,Int,Int,Int,Int,Int,Int)",
401 p (test :: T (Int,Int,Int,Int,Int,Int,Int,Int,Int)))
402 , ("(Int,Int,Int,Int,Int,Int,Int,Int,Int,Int)",
403 p (test :: T (Int,Int,Int,Int,Int,Int,Int,Int,Int,Int)))
404 {-
405 , ("IntSet", p (test :: T IntSet.IntSet ))
406 , ("IntMap ByteString", p (test :: T (IntMap.IntMap B.ByteString) ))
407 -}
408
409 , ("B.ByteString", p (test :: T B.ByteString ))
410 , ("L.ByteString", p (test :: T L.ByteString ))
411 ]
412
413 , testGroup "Invariants" $ map (uncurry testProperty)
414 [ ("B.ByteString invariant", p (prop_invariant :: B B.ByteString ))
415 , ("[B.ByteString] invariant", p (prop_invariant :: B [B.ByteString] ))
416 , ("L.ByteString invariant", p (prop_invariant :: B L.ByteString ))
417 , ("[L.ByteString] invariant", p (prop_invariant :: B [L.ByteString] ))
418 ]
419 ]
420
421 -- GHC only:
422 -- ,("Sequence", p (roundTrip :: Seq.Seq Int64 -> Bool))