{-# OPTIONS_GHC -fglasgow-exts #-}
--
-- Uses multi-param type classes
--
module QuickCheckUtils where
import Test.QuickCheck.Batch
import Test.QuickCheck
import Text.Show.Functions
import Control.Monad ( liftM2 )
import Data.Char
import Data.List
import Data.Word
import Data.Int
import System.Random
import System.IO
import Data.ByteString.Fusion
import qualified Data.ByteString as P
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Base as L (LazyByteString(..))
import qualified Data.ByteString.Char8 as PC
import qualified Data.ByteString.Lazy.Char8 as LC
-- Enable this to get verbose test output. Including the actual tests.
debug = False
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
mycheck :: Testable a => Config -> a -> IO ()
mycheck config a =
do rnd <- newStdGen
mytests config (evaluate a) rnd 0 0 []
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
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
display [] = ".\n"
display [x] = " (" ++ x ++ ").\n"
display xs = ".\n" ++ unlines (map (++ ".") xs)
pairLength xss@(xs:_) = (length xss, xs)
entry (n, xs) = percentage n ntest
++ " "
++ concat (intersperse ", " xs)
percentage n m = show ((100 * n) `div` m) ++ "%"
------------------------------------------------------------------------
instance Arbitrary Char where
arbitrary = choose ('\0','\255')
coarbitrary c = variant (ord c `rem` 4)
instance (Arbitrary a, Arbitrary b) => Arbitrary (PairS a b) where
arbitrary = liftM2 (:*:) arbitrary arbitrary
coarbitrary (a :*: b) = coarbitrary a . coarbitrary b
instance Arbitrary Word8 where
arbitrary = choose (97, 105)
coarbitrary c = variant (fromIntegral ((fromIntegral c) `rem` 4))
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))
instance Arbitrary a => Arbitrary (Maybe a) where
arbitrary = do a <- arbitrary ; elements [Nothing, Just a]
coarbitrary Nothing = variant 0
coarbitrary _ = variant 1 -- ok?
instance Arbitrary a => Arbitrary (MaybeS a) where
arbitrary = do a <- arbitrary ; elements [NothingS, JustS a]
coarbitrary NothingS = variant 0
coarbitrary _ = variant 1 -- ok?
{-
instance Arbitrary Char where
arbitrary = choose ('\0', '\255') -- since we have to test words, unlines too
coarbitrary c = variant (ord c `rem` 16)
instance Arbitrary Word8 where
arbitrary = choose (minBound, maxBound)
coarbitrary c = variant (fromIntegral ((fromIntegral c) `rem` 16))
-}
instance Random Word8 where
randomR = integralRandomR
random = randomR (minBound,maxBound)
instance Random Int64 where
randomR = integralRandomR
random = randomR (minBound,maxBound)
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)
instance Arbitrary L.ByteString where
arbitrary = arbitrary >>= return . L.LPS . filter (not. P.null) -- maintain the invariant.
coarbitrary s = coarbitrary (L.unpack s)
instance Arbitrary P.ByteString where
arbitrary = P.pack `fmap` arbitrary
coarbitrary s = coarbitrary (P.unpack s)
instance Functor ((->) r) where
fmap = (.)
instance Monad ((->) r) where
return = const
f >>= k = \ r -> k (f r) r
instance Functor ((,) a) where
fmap f (x,y) = (x, f y)
------------------------------------------------------------------------
--
-- 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)
------------------------------------------------------------------------
-- 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
abstr :: L.ByteString -> P.ByteString
abstr (L.LPS []) = P.empty
abstr (L.LPS xs) = P.concat xs
-- Some short hand.
type X = Int
type W = Word8
type P = P.ByteString
type B = L.ByteString
------------------------------------------------------------------------
--
-- 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
|
