1{-# OPTIONS_GHC -fno-warn-orphans #-}
2{-# LANGUAGE FlexibleInstances #-}
3
4module GetTests (tests) where
5
6import           Control.Applicative
7import           Control.Monad
8import           Data.Word
9import           Data.Function
10import qualified Data.ByteString as BS
11import qualified Data.ByteString.Lazy as LB
12import           Data.Serialize.Get
13import           Test.Framework (Test(),testGroup)
14import           Test.Framework.Providers.QuickCheck2 (testProperty)
15import           Test.QuickCheck as QC
16
17
18-- Data to express Get parser to generate
19data GetD
20  = Get8
21  | Eof
22  | Get16be
23  | Get32be
24  | Get64be
25  | Get16le
26  | Get32le
27  | Get64le
28  | GetD  :*>   GetD
29  | GetD  :<|>  GetD
30  | LookAhead GetD
31  | Skip Int
32  deriving Show
33
34-- Get parser generator
35buildGet :: GetD -> Get ()
36buildGet = d  where
37  d Get8           =  getWord8    *> pure ()
38  d Eof            =  guard =<< isEmpty
39  d Get16be        =  getWord16be *> pure ()
40  d Get32be        =  getWord32be *> pure ()
41  d Get64be        =  getWord64be *> pure ()
42  d Get16le        =  getWord16le *> pure ()
43  d Get32le        =  getWord32le *> pure ()
44  d Get64le        =  getWord64le *> pure ()
45  d (x :*>  y)     =  d x *>  d y
46  d (x :<|> y)     =  d x <|> d y
47  d (LookAhead x)  =  lookAhead $ d x
48  d (Skip i)       =  skip i
49
50-- Randomly generate parser
51genGetD :: Gen GetD
52genGetD =
53    oneof $
54    [ pure g
55    | g <- [ Get8, Eof
56           , Get16be, Get32be, Get64be
57           , Get16le, Get32le, Get64le
58           ]
59    ] ++
60    [ (:*>)     <$> genGetD <*> genGetD
61    , (:<|>)    <$> genGetD <*> genGetD
62    , LookAhead <$> genGetD
63    , Skip      <$> choose (0, 10)
64    ]
65
66instance Arbitrary GetD where
67  arbitrary = genGetD
68
69instance Arbitrary (Get ()) where
70  arbitrary = buildGet <$> genGetD
71
72newtype R a =
73  R { unR :: Either String a }
74  deriving Show
75
76
77-- Ignore equality of error message string
78instance Eq a => Eq (R a) where
79  (==)  =  (==) `on` either (const Nothing) Just . unR
80
81data Chunks = Chunks [[Word8]] deriving (Eq, Show)
82
83mkChunks :: Word -> Chunks
84mkChunks n = Chunks . take (fromIntegral n) $ cycle [ [x] | x <- [0 .. 255] ]
85
86instance Arbitrary Chunks where
87  arbitrary = mkChunks <$> choose (0, 512)
88
89
90testLength :: Word
91testLength = 255
92
93-- Equality between strict and lazy parsing
94eqStrictLazy :: GetD -> Property
95eqStrictLazy getD =
96  conjoin
97  [ counterexample (show in0) $ R (runGet parser sb) == R (runGetLazy parser lb)
98  | n <- [0 .. testLength]
99  , let Chunks in0 = mkChunks n
100        lb = LB.fromChunks [ BS.pack c | c <- in0 ]
101        sb = BS.pack $ concat in0
102  ]
103  where
104    parser = buildGet getD
105
106-- Remaining length equality between strict and lazy parsing
107remainingStrictLazy :: GetD -> Property
108remainingStrictLazy getD =
109  conjoin
110  [ counterexample (show in0) $ R (runGet parser sb) == R (runGetLazy parser lb)
111  | n <- [0 .. testLength]
112  , let Chunks in0 = mkChunks n
113        lb = LB.fromChunks [ BS.pack c | c <- in0 ]
114        sb = BS.pack $ concat in0
115  ]
116  where
117    parser = buildGet getD *> remaining
118
119isEmpty2 :: Get Bool
120isEmpty2 = do
121  lookAhead getWord8 *> pure False
122  <|>
123  pure True
124
125-- Compare with chunks
126(==~) :: Eq a => Get a -> Get a -> Property
127p1 ==~ p2 =
128  conjoin
129  [ counterexample (show in0) $ R (runGetLazy p1 s) == R (runGetLazy p2 s)
130  | n <- [0 .. testLength]
131  , let Chunks in0 = mkChunks n
132        s = LB.fromChunks [ BS.pack c | c <- in0 ]
133  ]
134
135(==!) :: Eq a => Get a -> Get a -> Property
136p1 ==! p2 =
137  conjoin
138  [ counterexample (show s) $ R (runGet p1 s) == R (runGet p2 s)
139  | n <- [0 .. testLength]
140  , let Chunks in0 = mkChunks n
141        s = BS.pack $ concat in0
142  ]
143
144infix 2 ==~, ==!
145
146-- Equality between two eof definition - lazy
147eqEof :: GetD -> Property
148eqEof getD =
149    x *> isEmpty ==~ x *> isEmpty2
150  where
151    x = buildGet getD
152
153-- Equality between two eof definition - strict
154eqEof' :: GetD -> Property
155eqEof' getD =
156    x *> isEmpty ==! x *> isEmpty2
157  where
158    x = buildGet getD
159
160
161monadIdL :: GetD -> Property
162monadIdL getD =
163    (return () >>= const x) ==~ x
164  where
165    x = buildGet getD
166
167monadIdL' :: GetD -> Property
168monadIdL' getD =
169    (return () >>= const x) ==! x
170  where
171    x = buildGet getD
172
173monadIdR :: GetD -> Property
174monadIdR getD =
175    (x >>= return) ==~ x
176  where
177    x = buildGet getD
178
179monadIdR' :: GetD -> Property
180monadIdR' getD =
181    (x >>= return) ==! x
182  where
183    x = buildGet getD
184
185monadAssoc :: GetD -> GetD -> GetD -> Property
186monadAssoc p1 p2 p3 =
187    (x >> (y >> z)) ==~ (x >> y >> z)
188  where
189    x = buildGet p1
190    y = buildGet p2
191    z = buildGet p3
192
193monadAssoc' :: GetD -> GetD -> GetD -> Property
194monadAssoc' p1 p2 p3 =
195    (x >> (y >> z)) ==! (x >> y >> z)
196  where
197    x = buildGet p1
198    y = buildGet p2
199    z = buildGet p3
200
201alterIdL :: GetD -> Property
202alterIdL getD =
203    empty <|> x ==~ x
204  where
205    x = buildGet getD
206
207alterIdL' :: GetD -> Property
208alterIdL' getD =
209    empty <|> x ==! x
210  where
211    x = buildGet getD
212
213alterIdR :: GetD -> Property
214alterIdR getD =
215    x <|> empty ==~ x
216  where
217    x = buildGet getD
218
219alterIdR' :: GetD -> Property
220alterIdR' getD =
221    x <|> empty ==! x
222  where
223    x = buildGet getD
224
225alterAssoc :: GetD -> GetD -> GetD -> Property
226alterAssoc p1 p2 p3 =
227    x <|> y <|> z ==~ x <|> (y <|> z)
228  where
229    x = buildGet p1
230    y = buildGet p2
231    z = buildGet p3
232
233alterAssoc' :: GetD -> GetD -> GetD -> Property
234alterAssoc' p1 p2 p3 =
235    x <|> y <|> z ==! x <|> (y <|> z)
236  where
237    x = buildGet p1
238    y = buildGet p2
239    z = buildGet p3
240
241alterDistr :: GetD -> GetD -> GetD -> Property
242alterDistr p1 p2 p3 =
243    x *> (y <|> z) ==~ x *> y <|> x *> z
244  where
245    x = buildGet p1
246    y = buildGet p2
247    z = buildGet p3
248
249alterDistr' :: GetD -> GetD -> GetD -> Property
250alterDistr' p1 p2 p3 =
251    x *> (y <|> z) ==! x *> y <|> x *> z
252  where
253    x = buildGet p1
254    y = buildGet p2
255    z = buildGet p3
256
257
258tests :: Test
259tests  = testGroup "GetTests"
260  [ testProperty "lazy   - monad left id"          monadIdL
261  , testProperty "strict - monad left id"          monadIdL'
262  , testProperty "lazy   - monad right id"         monadIdR
263  , testProperty "strict - monad right id"         monadIdR'
264  , testProperty "lazy   - monad assoc"            monadAssoc
265  , testProperty "strict - monad assoc"            monadAssoc'
266  , testProperty "strict lazy - equality"          eqStrictLazy
267  , testProperty "strict lazy - remaining equality"remainingStrictLazy
268  , testProperty "lazy   - two eof"                eqEof
269  , testProperty "strict - two eof"                eqEof'
270  , testProperty "lazy   - alternative left Id"    alterIdL
271  , testProperty "strict - alternative left Id"    alterIdL'
272  , testProperty "lazy   - alternative right Id"   alterIdR
273  , testProperty "strict - alternative right Id"   alterIdR'
274  , testProperty "lazy   - alternative assoc"      alterAssoc
275  , testProperty "strict - alternative assoc"      alterAssoc'
276  , testProperty "lazy   - alternative distr"      alterDistr
277  , testProperty "strict - alternative distr"      alterDistr'
278  ]
279