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