Commit bb214739 authored by Don Stewart's avatar Don Stewart
Browse files

Add model-based tests for ByteString.Lazy<=>ByteString<=>Data.list

parent 69c82de7
#!/usr/bin/env runhaskell
{-# OPTIONS_GHC -fglasgow-exts #-}
--
-- Uses multi-param type classes
--
import Test.QuickCheck.Batch
import Test.QuickCheck
import Text.Show.Functions
import Data.List
import Data.Char
import Data.Word
import Data.Int
import Data.List
import Data.Maybe
import Data.Word
import Text.Printf
import System.Environment
import System.IO
import System.Environment
import System.IO.Unsafe
import System.Random
import Data.ByteString.Char8 (ByteString, pack , unpack)
import qualified Data.ByteString.Char8 as P
instance Arbitrary Char where
arbitrary = choose ('\0', '\255') -- since we have to test words, unlines too
coarbitrary c = variant (ord c `rem` 16)
-- arbitrary = oneof $ map return
-- (['a'..'z']++['A'..'Z']++['1'..'9']++['\n','\t','0','~','.',',','-','/'])
instance Arbitrary Word8 where
arbitrary = choose (minBound, maxBound)
coarbitrary c = variant (fromIntegral ((fromIntegral c) `rem` 16))
instance Random Word8 where
randomR (a,b) g = case randomR (fromIntegral a :: Integer
,fromIntegral b :: Integer) g of
(x,g) -> (fromIntegral x :: Word8, g)
random g = randomR (minBound,maxBound) g
instance Arbitrary ByteString where
arbitrary = P.pack `fmap` arbitrary
coarbitrary s = coarbitrary (P.unpack s)
------------------------------------------------------------------------
-- Simon's functions:
import Control.Monad ( liftM2 )
prop_pack string = string == P.unpack (P.pack string)
prop_nil1 = P.length P.empty == 0
prop_nil2 = P.unpack P.empty == ""
prop_cons c xs = P.unpack (P.cons c (P.pack xs)) == (c:xs)
import Text.Printf
import Debug.Trace
prop_headS xs = not (P.null xs) ==> P.head xs == head (P.unpack xs)
import Foreign.Ptr
prop_tailS xs = not (P.null xs) ==> P.tail xs == P.pack (tail (P.unpack xs))
import Data.ByteString.Lazy (ByteString(..), pack , unpack)
import qualified Data.ByteString.Lazy as L
prop_null xs = null (P.unpack xs) == P.null xs
import Data.ByteString.Fusion
import qualified Data.ByteString as P
import qualified Data.ByteString.Lazy as L
prop_append xs ys = P.append xs ys == P.pack (P.unpack xs ++ P.unpack ys)
import qualified Data.ByteString.Char8 as PC
import qualified Data.ByteString.Lazy.Char8 as LC
import qualified Data.ByteString as P
import qualified Data.ByteString.Base as P
import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString.Lazy.Char8 as D
import Data.ByteString.Fusion
prop_lengthS xs = length xs == P.length (P.pack xs)
import Prelude hiding (abs)
prop_index xs =
not (null xs) ==>
forAll indices $ \i -> (xs !! i) == P.pack xs `P.index` i
where indices = choose (0, length xs -1)
-- Enable this to get verbose test output. Including the actual tests.
debug = False
prop_unsafeIndex xs =
not (null xs) ==>
forAll indices $ \i -> (xs !! i) == P.pack xs `P.unsafeIndex` i
where indices = choose (0, length xs -1)
mytest :: Testable a => a -> Int -> IO ()
mytest a n = mycheck defaultConfig
{ configMaxTest=n
, configEvery= \n args -> if debug then show n ++ ":\n" ++ unlines args else [] } a
prop_mapS f xs = P.map f (P.pack xs) == P.pack (map f xs)
mycheck :: Testable a => Config -> a -> IO ()
mycheck config a =
do let rnd = mkStdGen 99
mytests config (evaluate a) rnd 0 0 []
prop_mapfusion f g xs = P.map f (P.map g xs) == P.map (f . g) xs
mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO ()
mytests config gen rnd0 ntest nfail stamps
| ntest == configMaxTest config = do done "OK," ntest stamps
| nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps
| otherwise =
do putStr (configEvery config ntest (arguments result)) >> hFlush stdout
case ok result of
Nothing ->
mytests config gen rnd1 ntest (nfail+1) stamps
Just True ->
mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps)
Just False ->
putStr ( "Falsifiable after "
++ show ntest
++ " tests:\n"
++ unlines (arguments result)
) >> hFlush stdout
where
result = generate (configSize config ntest) rnd2 gen
(rnd1,rnd2) = split rnd0
prop_filter f xs = P.filter f (P.pack xs) == P.pack (filter f xs)
done :: String -> Int -> [[String]] -> IO ()
done mesg ntest stamps =
do putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table )
where
table = display
. map entry
. reverse
. sort
. map pairLength
. group
. sort
. filter (not . null)
$ stamps
prop_filterfusion f g xs = P.filter f (P.filter g xs) == P.filter (\c -> f c && g c) xs
display [] = ".\n"
display [x] = " (" ++ x ++ ").\n"
display xs = ".\n" ++ unlines (map (++ ".") xs)
prop_reverseS xs = P.reverse (P.pack xs) == P.pack (reverse xs)
pairLength xss@(xs:_) = (length xss, xs)
entry (n, xs) = percentage n ntest
++ " "
++ concat (intersperse ", " xs)
prop_concat xss = P.concat (map P.pack xss) == P.pack (concat xss)
percentage n m = show ((100 * n) `div` m) ++ "%"
prop_elemS x xs = P.elem x (P.pack xs) == elem x xs
------------------------------------------------------------------------
prop_takeS i xs = P.take i (P.pack xs) == P.pack (take i xs)
instance Arbitrary Char where
arbitrary = choose ('a', 'i')
coarbitrary c = variant (ord c `rem` 4)
prop_dropS i xs = P.drop i (P.pack xs) == P.pack (drop i xs)
instance (Arbitrary a, Arbitrary b) => Arbitrary (PairS a b) where
arbitrary = liftM2 (:*:) arbitrary arbitrary
coarbitrary (a :*: b) = coarbitrary a . coarbitrary b
prop_splitAtS i xs = collect (i >= 0 && i < length xs) $
P.splitAt i (P.pack xs) ==
let (a,b) = splitAt i xs in (P.pack a, P.pack b)
instance Arbitrary Word8 where
arbitrary = choose (97, 105)
coarbitrary c = variant (fromIntegral ((fromIntegral c) `rem` 4))
prop_foldl f c xs = P.foldl f c (P.pack xs) == foldl f c xs
where types = c :: Char
instance Arbitrary Int64 where
arbitrary = sized $ \n -> choose (-fromIntegral n,fromIntegral n)
coarbitrary n = variant (fromIntegral (if n >= 0 then 2*n else 2*(-n) + 1))
prop_foldr f c xs = P.foldl f c (P.pack xs) == foldl f c xs
where types = c :: Char
instance Arbitrary a => Arbitrary (Maybe a) where
arbitrary = do a <- arbitrary ; elements [Nothing, Just a]
coarbitrary Nothing = variant 0
coarbitrary _ = variant 1 -- ok?
prop_takeWhileS f xs = P.takeWhile f (P.pack xs) == P.pack (takeWhile f xs)
instance Arbitrary a => Arbitrary (MaybeS a) where
arbitrary = do a <- arbitrary ; elements [NothingS, JustS a]
coarbitrary NothingS = variant 0
coarbitrary _ = variant 1 -- ok?
prop_dropWhileS f xs = P.dropWhile f (P.pack xs) == P.pack (dropWhile f xs)
{-
instance Arbitrary Char where
arbitrary = choose ('\0', '\255') -- since we have to test words, unlines too
coarbitrary c = variant (ord c `rem` 16)
prop_spanS f xs = P.span f (P.pack xs) ==
let (a,b) = span f xs in (P.pack a, P.pack b)
instance Arbitrary Word8 where
arbitrary = choose (minBound, maxBound)
coarbitrary c = variant (fromIntegral ((fromIntegral c) `rem` 16))
-}
prop_breakS f xs = P.break f (P.pack xs) ==
let (a,b) = break f xs in (P.pack a, P.pack b)
instance Random Word8 where
randomR = integralRandomR
random = randomR (minBound,maxBound)
prop_breakspan_1 xs c = P.break (== c) xs == P.span (/= c) xs
instance Random Int64 where
randomR = integralRandomR
random = randomR (minBound,maxBound)
prop_linesS xs = P.lines (P.pack xs) == map P.pack (lines xs)
integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)
integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer,
fromIntegral b :: Integer) g of
(x,g) -> (fromIntegral x, g)
prop_unlinesS xss = P.unlines (map P.pack xss) == P.pack (unlines xss)
instance Arbitrary L.ByteString where
arbitrary = arbitrary >>= return . L.LPS . filter (not. P.null) -- maintain the invariant.
coarbitrary s = coarbitrary (L.unpack s)
prop_wordsS xs =
P.words (P.pack xs) == map P.pack (words xs)
instance Arbitrary P.ByteString where
arbitrary = P.pack `fmap` arbitrary
coarbitrary s = coarbitrary (P.unpack s)
prop_unwordsS xss = P.unwords (map P.pack xss) == P.pack (unwords xss)
instance Functor ((->) r) where
fmap = (.)
prop_splitWith f xs = (l1 == l2 || l1 == l2+1) &&
sum (map P.length splits) == P.length xs - l2
where splits = P.splitWith f xs
l1 = length splits
l2 = P.length (P.filter f xs)
instance Monad ((->) r) where
return = const
f >>= k = \ r -> k (f r) r
prop_joinsplit c xs = P.join (P.pack [c]) (P.split c xs) == xs
instance Functor ((,) a) where
fmap f (x,y) = (x, f y)
prop_linessplit xs =
(not . P.null) xs ==>
P.lines' xs == P.split '\n' xs
------------------------------------------------------------------------
--
-- We're doing two forms of testing here. Firstly, model based testing.
-- For our Lazy and strict bytestring types, we have model types:
--
-- i.e. Lazy == Byte
-- \\ //
-- List
--
-- That is, the Lazy type can be modeled by functions in both the Byte
-- and List type. For each of the 3 models, we have a set of tests that
-- check those types match.
--
-- The Model class connects a type and its model type, via a conversion
-- function.
--
--
class Model a b where
model :: a -> b -- get the abstract vale from a concrete value
--
-- Connecting our Lazy and Strict types to their models. We also check
-- the data invariant on Lazy types.
--
-- These instances represent the arrows in the above diagram
--
instance Model B P where model = abstr . checkInvariant
instance Model P [W] where model = P.unpack
instance Model P [Char] where model = PC.unpack
instance Model B [W] where model = L.unpack . checkInvariant
instance Model B [Char] where model = LC.unpack . checkInvariant
-- Types are trivially modeled by themselves
instance Model Bool Bool where model = id
instance Model Int Int where model = id
instance Model Int64 Int64 where model = id
instance Model Int64 Int where model = fromIntegral
instance Model Word8 Word8 where model = id
instance Model Ordering Ordering where model = id
-- More structured types are modeled recursively, using the NatTrans class from Gofer.
class (Functor f, Functor g) => NatTrans f g where
eta :: f a -> g a
-- The transformation of the same type is identity
instance NatTrans [] [] where eta = id
instance NatTrans Maybe Maybe where eta = id
instance NatTrans ((->) X) ((->) X) where eta = id
instance NatTrans ((->) W) ((->) W) where eta = id
-- We have a transformation of pairs, if the pairs are in Model
instance Model f g => NatTrans ((,) f) ((,) g) where eta (f,a) = (model f, a)
-- And finally, we can take any (m a) to (n b), if we can Model m n, and a b
instance (NatTrans m n, Model a b) => Model (m a) (n b) where model x = fmap model (eta x)
prop_linessplit2 xs =
P.lines xs == P.split '\n' xs ++ (if P.last xs == '\n' then [P.empty] else [])
------------------------------------------------------------------------
prop_splitsplitWith c xs = P.split c xs == P.splitWith (== c) xs
-- In a form more useful for QC testing (and it's lazy)
checkInvariant :: L.ByteString -> L.ByteString
checkInvariant (L.LPS lps) = L.LPS (check lps)
where check [] = []
check (x:xs) | P.null x = error ("invariant violation: " ++ show lps)
| otherwise = x : check xs
prop_bijection c = (P.w2c . P.c2w) c == id c
prop_bijection' w = (P.c2w . P.w2c) w == id w
abstr :: L.ByteString -> P.ByteString
abstr (L.LPS []) = P.empty
abstr (L.LPS xs) = P.concat xs
prop_packunpack s = (P.unpack . P.pack) s == id s
prop_packunpack' s = (P.pack . P.unpack) s == id s
-- Some short hand.
type X = Int
type W = Word8
type P = P.ByteString
type B = L.ByteString
------------------------------------------------------------------------
-- at first we just check the correspondence to List functions
prop_eq1 xs = xs == (unpack . pack $ xs)
prop_eq2 xs = xs == xs
--
-- These comparison functions handle wrapping and equality.
--
-- A single class for these would be nice, but note that they differe in
-- the number of arguments, and those argument types, so we'd need HList
-- tricks. See here: http://okmij.org/ftp/Haskell/vararg-fn.lhs
--
eq1 f g = \a ->
model (f a) == g (model a)
eq2 f g = \a b ->
model (f a b) == g (model a) (model b)
eq3 f g = \a b c ->
model (f a b c) == g (model a) (model b) (model c)
eq4 f g = \a b c d ->
model (f a b c d) == g (model a) (model b) (model c) (model d)
eq5 f g = \a b c d e ->
model (f a b c d e) == g (model a) (model b) (model c) (model d) (model e)
--
-- And for functions that take non-null input
--
eqnotnull1 f g = \x -> (not (isNull x)) ==> eq1 f g x
eqnotnull2 f g = \x y -> (not (isNull y)) ==> eq2 f g x y
eqnotnull3 f g = \x y z -> (not (isNull z)) ==> eq3 f g x y z
class IsNull t where isNull :: t -> Bool
instance IsNull L.ByteString where isNull = L.null
instance IsNull P.ByteString where isNull = P.null
prop_compare1 xs = (pack xs `compare` pack xs) == EQ
prop_compare2 xs c = (pack (xs++[c]) `compare` pack xs) == GT
prop_compare3 xs c = (pack xs `compare` pack (xs++[c])) == LT
prop_compare4 xs = (not (null xs)) ==> (pack xs `compare` P.empty) == GT
prop_compare5 xs = (not (null xs)) ==> (P.empty `compare` pack xs) == LT
prop_compare6 xs ys= (not (null ys)) ==> (pack (xs++ys) `compare` pack xs) == GT
prop_compare7 x y = x `compare` y == (P.singleton x `compare` P.singleton y)
------------------------------------------------------------------------
-- prop_nil1 xs = (null xs) ==> pack xs == P.empty
--
-- ByteString.Lazy <=> ByteString
--
prop_concatBP = L.concat `eq1` P.concat
prop_nullBP = L.null `eq1` P.null
prop_reverseBP = L.reverse `eq1` P.reverse
prop_transposeBP = L.transpose `eq1` P.transpose
prop_groupBP = L.group `eq1` P.group
prop_initsBP = L.inits `eq1` P.inits
prop_tailsBP = L.tails `eq1` P.tails
prop_allBP = L.all `eq2` P.all
prop_anyBP = L.any `eq2` P.any
prop_appendBP = L.append `eq2` P.append
prop_breakBP = L.break `eq2` P.break
-- prop_concatMapBP = L.concatMap `eq2` P.concatMap
prop_consBP = L.cons `eq2` P.cons
prop_countBP = L.count `eq2` P.count
prop_dropBP = L.drop `eq2` P.drop
prop_dropWhileBP = L.dropWhile `eq2` P.dropWhile
prop_filterBP = L.filter `eq2` P.filter
prop_findBP = L.find `eq2` P.find
prop_findIndexBP = L.findIndex `eq2` P.findIndex
prop_findIndicesBP = L.findIndices `eq2` P.findIndices
prop_isPrefixOfBP = L.isPrefixOf `eq2` P.isPrefixOf
prop_mapBP = L.map `eq2` P.map
prop_replicateBP = L.replicate `eq2` P.replicate
prop_snocBP = L.snoc `eq2` P.snoc
prop_spanBP = L.span `eq2` P.span
prop_splitBP = L.split `eq2` P.split
prop_splitAtBP = L.splitAt `eq2` P.splitAt
prop_takeBP = L.take `eq2` P.take
prop_takeWhileBP = L.takeWhile `eq2` P.takeWhile
prop_elemBP = L.elem `eq2` P.elem
prop_notElemBP = L.notElem `eq2` P.notElem
prop_elemIndexBP = L.elemIndex `eq2` P.elemIndex
prop_elemIndicesBP = L.elemIndices `eq2` P.elemIndices
prop_lengthBP = L.length `eq1` (fromIntegral . P.length :: P.ByteString -> Int64)
prop_readIntBP = D.readInt `eq1` C.readInt
prop_linesBP = D.lines `eq1` C.lines
prop_headBP = L.head `eqnotnull1` P.head
prop_initBP = L.init `eqnotnull1` P.init
prop_lastBP = L.last `eqnotnull1` P.last
prop_maximumBP = L.maximum `eqnotnull1` P.maximum
prop_minimumBP = L.minimum `eqnotnull1` P.minimum
prop_tailBP = L.tail `eqnotnull1` P.tail
prop_foldl1BP = L.foldl1 `eqnotnull2` P.foldl1
prop_foldl1BP' = L.foldl1' `eqnotnull2` P.foldl1'
prop_foldr1BP = L.foldr1 `eqnotnull2` P.foldr1
prop_scanlBP = L.scanl `eqnotnull3` P.scanl
prop_eqBP = eq2
((==) :: B -> B -> Bool)
((==) :: P -> P -> Bool)
prop_compareBP = eq2
((compare) :: B -> B -> Ordering)
((compare) :: P -> P -> Ordering)
prop_foldlBP = eq3
(L.foldl :: (X -> W -> X) -> X -> B -> X)
(P.foldl :: (X -> W -> X) -> X -> P -> X)
prop_foldlBP' = eq3
(L.foldl' :: (X -> W -> X) -> X -> B -> X)
(P.foldl' :: (X -> W -> X) -> X -> P -> X)
prop_foldrBP = eq3
(L.foldr :: (W -> X -> X) -> X -> B -> X)
(P.foldr :: (W -> X -> X) -> X -> P -> X)
prop_mapAccumLBP = eq3
(L.mapAccumL :: (X -> W -> (X,W)) -> X -> B -> (X, B))
(P.mapAccumL :: (X -> W -> (X,W)) -> X -> P -> (X, P))
prop_unfoldrBP = eq3
((\n f a -> L.take (fromIntegral n) $
L.unfoldr f a) :: Int -> (X -> Maybe (W,X)) -> X -> B)
((\n f a -> fst $
P.unfoldrN n f a) :: Int -> (X -> Maybe (W,X)) -> X -> P)
--
-- properties comparing ByteString.Lazy `eq1` List
--
prop_concatBL = L.concat `eq1` (concat :: [[W]] -> [W])
prop_lengthBL = L.length `eq1` (length :: [W] -> Int)
prop_nullBL = L.null `eq1` (null :: [W] -> Bool)
prop_reverseBL = L.reverse `eq1` (reverse :: [W] -> [W])
prop_transposeBL = L.transpose `eq1` (transpose :: [[W]] -> [[W]])
prop_groupBL = L.group `eq1` (group :: [W] -> [[W]])
prop_initsBL = L.inits `eq1` (inits :: [W] -> [[W]])
prop_tailsBL = L.tails `eq1` (tails :: [W] -> [[W]])
prop_allBL = L.all `eq2` (all :: (W -> Bool) -> [W] -> Bool)
prop_anyBL = L.any `eq2` (any :: (W -> Bool) -> [W] -> Bool)
prop_appendBL = L.append `eq2` ((++) :: [W] -> [W] -> [W])
prop_breakBL = L.break `eq2` (break :: (W -> Bool) -> [W] -> ([W],[W]))
-- prop_concatMapBL = L.concatMap `eq2` (concatMap :: (W -> [W]) -> [W] -> [W])
prop_consBL = L.cons `eq2` ((:) :: W -> [W] -> [W])
prop_dropBL = L.drop `eq2` (drop :: Int -> [W] -> [W])
prop_dropWhileBL = L.dropWhile `eq2` (dropWhile :: (W -> Bool) -> [W] -> [W])
prop_filterBL = L.filter `eq2` (filter :: (W -> Bool ) -> [W] -> [W])
prop_findBL = L.find `eq2` (find :: (W -> Bool) -> [W] -> Maybe W)
prop_findIndicesBL = L.findIndices `eq2` (findIndices:: (W -> Bool) -> [W] -> [Int])
prop_findIndexBL = L.findIndex `eq2` (findIndex :: (W -> Bool) -> [W] -> Maybe Int)
prop_isPrefixOfBL = L.isPrefixOf `eq2` (isPrefixOf:: [W] -> [W] -> Bool)
prop_mapBL = L.map `eq2` (map :: (W -> W) -> [W] -> [W])
prop_replicateBL = L.replicate `eq2` (replicate :: Int -> W -> [W])
prop_snocBL = L.snoc `eq2` ((\xs x -> xs ++ [x]) :: [W] -> W -> [W])
prop_spanBL = L.span `eq2` (span :: (W -> Bool) -> [W] -> ([W],[W]))
prop_splitAtBL = L.splitAt `eq2` (splitAt :: Int -> [W] -> ([W],[W]))
prop_takeBL = L.take `eq2` (take :: Int -> [W] -> [W])
prop_takeWhileBL = L.takeWhile `eq2` (takeWhile :: (W -> Bool) -> [W] -> [W])
prop_elemBL = L.elem `eq2` (elem :: W -> [W] -> Bool)
prop_notElemBL = L.notElem `eq2` (notElem :: W -> [W] -> Bool)
prop_elemIndexBL = L.elemIndex `eq2` (elemIndex :: W -> [W] -> Maybe Int)
prop_elemIndicesBL = L.elemIndices `eq2` (elemIndices:: W -> [W] -> [Int])
prop_linesBL = D.lines `eq1` (lines :: String -> [String])
prop_foldl1BL = L.foldl1 `eqnotnull2` (foldl1 :: (W -> W -> W) -> [W] -> W)
prop_foldl1BL' = L.foldl1' `eqnotnull2` (foldl1' :: (W -> W -> W) -> [W] -> W)
prop_foldr1BL = L.foldr1 `eqnotnull2` (foldr1 :: (W -> W -> W) -> [W] -> W)
prop_headBL = L.head `eqnotnull1` (head :: [W] -> W)
prop_initBL = L.init `eqnotnull1` (init :: [W] -> [W])
prop_lastBL = L.last `eqnotnull1` (last :: [W] -> W)
prop_maximumBL = L.maximum `eqnotnull1` (maximum :: [W] -> W)
prop_minimumBL = L.minimum `eqnotnull1` (minimum :: [W] -> W)
prop_tailBL = L.tail `eqnotnull1` (tail :: [W] -> [W])
prop_eqBL = eq2
((==) :: B -> B -> Bool)
((==) :: [W] -> [W] -> Bool)
prop_compareBL = eq2
((compare) :: B -> B -> Ordering)
((compare) :: [W] -> [W] -> Ordering)
prop_foldlBL = eq3
(L.foldl :: (X -> W -> X) -> X -> B -> X)
( foldl :: (X -> W -> X) -> X -> [W] -> X)
prop_foldlBL' = eq3
(L.foldl' :: (X -> W -> X) -> X -> B -> X)
( foldl' :: (X -> W -> X) -> X -> [W] -> X)
prop_foldrBL = eq3
(L.foldr :: (W -> X -> X) -> X -> B -> X)
( foldr :: (W -> X -> X) -> X -> [W] -> X)
prop_mapAccumLBL = eq3
(L.mapAccumL :: (X -> W -> (X,W)) -> X -> B -> (X, B))
( mapAccumL :: (X -> W -> (X,W)) -> X -> [W] -> (X, [W]))
prop_unfoldrBL = eq3