1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
|
{-# OPTIONS_GHC -fglasgow-exts #-}
module Main where
import Data.Binary
import Data.Binary.Put
import Data.Binary.Get
import Parallel
import qualified Data.ByteString as B
import qualified Data.ByteString.Internal as B
import qualified Data.ByteString.Unsafe as B
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Internal 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 qualified Control.Exception as C (catch,evaluate)
import Control.Monad
import Foreign
import System.Environment
import System.IO
import System.IO.Unsafe
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)))
-- make sure that a test fails
errorish :: B a
errorish a = unsafePerformIO $
C.catch (do C.evaluate a
return False)
(\_ -> return True)
-- 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
-- read too much:
prop_bookworm x = errorish $ x == a && x /= b
where
(a,b) = decode (encode x)
-- sanity:
invariant_lbs :: L.ByteString -> Bool
invariant_lbs (L.Empty) = True
invariant_lbs (L.Chunk x xs) = not (B.null x) && invariant_lbs 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
s <- getArgs
let x = if null s then 100 else read (head s)
pRun 2 x 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 String
p = pNon
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 :: [(String, Int -> IO String)]
tests =
-- utils
[ ("refragment id", p prop_refragment )
, ("refragment invariant", p prop_refragment_inv )
-- boundaries
, ("read to much", p (prop_bookworm :: B Word8 ))
-- 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)))
]
|
