Systematic testing with QuickCheck.

\begin{code}
import Control.Monad
import System.Random
import Test.QuickCheck
\end{code}

Properties and basic test invocation.

\begin{spec}
quickCheck :: Testable prop => prop -> IO ()

class Testable prop where
  property :: prop -> Property

instance Testable Bool
instance (Arbitrary a, Testable prop) => Testable (a -> prop)
\end{spec}

A first property.

\begin{spec}
propAppendNil xs = xs ++ [] == xs

t1 = quickCheck propAppendNil
\end{spec}

Problems with polymorphism.

\begin{spec}
propAppendNil :: [a] -> Bool
\end{spec}

Concretization.

\begin{code}
propAppendNil :: [Bool] -> Bool
propAppendNil xs = xs ++ [] == xs

t1 = quickCheck propAppendNil
\end{code}

Increasing the number of test cases.

\begin{spec}
data Args = Args {
  replay      :: Maybe (StdGen, Int)
  maxSuccess  :: Int
  maxDiscard  :: Int
  maxSize     :: Int
}

stdArgs :: Args

quickCheckWith :: Testable prop => Args -> prop -> IO ()
\end{spec}
\begin{code}
qc1000 = quickCheckWith (stdArgs { maxSuccess = 1000 })
t2 = qc1000 propAppendNil
\end{code}

Testing the associativity of append.

\begin{code}
propAppendAssoc :: [Bool] -> [Bool] -> [Bool] -> Bool
propAppendAssoc xs ys zs = (xs ++ ys) ++ zs == xs ++ (ys ++ zs)

t3 = quickCheck propAppendAssoc
\end{code}

Tree Sort.  Build a search tree from a list and flatten it by infix traversal.

\begin{code}
data Tree a = Leaf 
            | Node (Tree a) a (Tree a) 
              deriving (Show, Eq)

insert :: Ord a => a -> Tree a -> Tree a
insert a Leaf = Node Leaf a Leaf
insert a (Node l b r) = if a <= b then Node (insert a l) b r
                        else Node l b (insert a r)

toList :: Tree a -> [a]
toList Leaf = []
toList (Node l a r) = toList l ++ a : toList r

sort :: Ord a => [a] -> [a]
sort = toList . foldl (flip insert) Leaf
\end{code}

Testing that tree sort always returns a sorted list.

\begin{code}
sorted :: Ord a => [a] -> Bool
sorted []       =  True
sorted [a]      =  True
sorted (a:b:l)  =  a <= b && sorted (b:l)

propTreeSort :: [Int] -> Bool
propTreeSort = sorted . sort

t4 = quickCheck propTreeSort
\end{code}

We would like to test |insert| by itself.

\begin{spec}
(==>) :: Testable prop => Bool -> prop -> Property

propSortedInsert :: Int -> Tree Int -> Property
propSortedInsert a t = sortedTree t ==> 
                         sortedTree (insert a t)
\end{spec}

A testcase generator for trees.

\begin{spec}
liftM   :: Monad m => (a -> b) -> (m a -> m b)
liftM3  :: Monad m => (a -> b -> c -> d) -> (m a -> m b -> m c -> m d)
oneof   :: [Gen a] -> Gen a
\end{spec}
\begin{code}
treeGen0 :: (Arbitrary a) => Gen (Tree a)
treeGen0 = oneof [ return Leaf
                 , liftM3 Node treeGen0 arbitrary treeGen0 ]

intTreeGen0 :: Gen (Tree Int)
intTreeGen0 = treeGen0

t5 = sample intTreeGen0  -- generates very large trees
\end{code}

Restricting the size of samples.

\begin{spec}
sized :: (Int -> Gen a) -> Gen a
\end{spec}
\begin{code}
treeGen1 :: (Arbitrary a) => Gen (Tree a)
treeGen1 = sized treeGen1'

treeGen1' :: (Arbitrary a) => Int -> Gen (Tree a)
treeGen1' 0 = return Leaf
treeGen1' n = oneof [ return Leaf
                   , liftM3 Node t arbitrary t ]
  where t = treeGen1' (n `div` 2)

intTreeGen1 :: Gen (Tree Int)
intTreeGen1 = treeGen1

t6 = sample intTreeGen1 
\end{code}

Checking the search tree invariant.

\begin{code}
between :: Ord a => Maybe a -> a -> Maybe a -> Bool
between Nothing  a Nothing  = True
between Nothing  a (Just r) = a <= r
between (Just l) a Nothing  = l <= a
between (Just l) a (Just r) = l <= a && a <= r

betweenTree :: Ord a => Maybe a -> Tree a -> Maybe a -> Bool
betweenTree ml Leaf         mr = True
betweenTree ml (Node l a r) mr = between ml a mr 
  && betweenTree ml l (Just a) && betweenTree (Just a) r mr 

sortedTree :: Ord a => Tree a -> Bool
sortedTree t = betweenTree Nothing t Nothing
\end{code}

Testing that |insert| preserves the search tree invariant.

\begin{code}
             
propSortedInsert :: Int -> Property
propSortedInsert a = forAll treeGen1 $ \ t ->
                         sortedTree t ==> 
                           sortedTree (insert a t)

t7 = quickCheck propSortedInsert
\end{code}

Analyzing the quality of test cases.

\begin{spec}
classify         Conditionally labels test case.
:: Testable prop	
=> Bool	         True if the test case should be labelled.
-> String	 Label.
-> prop	
-> Property	
\end{spec}

How often did we test on the empty tree?

\begin{code}
trivial :: Testable a => Bool -> a -> Property
trivial = (`classify` "trivial")

propSortedInsert1 :: Int -> Property
propSortedInsert1 a = forAll treeGen1 $ \ t ->
                         sortedTree t ==> 
                           (t == Leaf) `trivial` sortedTree (insert a t)

t8 = quickCheck propSortedInsert1
\end{code}

Collecting statistics about the test data.  Here: depth of tested tree.

\begin{code}
depth :: Tree a -> Int
depth Leaf = 0
depth (Node l a r) = 1 + max (depth l) (depth r)

propSortedInsert2 :: Int -> Property
propSortedInsert2 a = forAll treeGen1 $ \ t ->
                         sortedTree t ==> 
                           collect (depth t) $ sortedTree (insert a t)

t9 = quickCheck propSortedInsert2
\end{code}

Controlling the probability distribution of generated data.

\begin{spec}
frequency :: [(Int, Gen a)] -> Gen a
\end{spec}

\begin{code}
treeGen2 :: (Arbitrary a) => Gen (Tree a)
treeGen2 = sized treeGen2'

treeGen2' :: (Arbitrary a) => Int -> Gen (Tree a)
treeGen2' 0 = return Leaf
treeGen2' n = frequency [ (10, return Leaf)
                        , (90, liftM3 Node t arbitrary t) ]
  where t = treeGen2' (n `div` 2)

intTreeGen2 :: Gen (Tree Int)
intTreeGen2 = treeGen2

t10 = sample intTreeGen2 

propSortedInsert3 :: Int -> Property
propSortedInsert3 a = forAll treeGen2 $ \ t ->
                         sortedTree t ==> 
                           collect (depth t) $ sortedTree (insert a t)

t11 = quickCheck propSortedInsert3
\end{code}

A generator for sorted trees.

\begin{code}
sortedTreeGen :: (Arbitrary a, Bounded a, Random a) => Gen (Tree a)
sortedTreeGen = sized $ \ n -> sortedTreeGen' n (minBound, maxBound)

sortedTreeGen' :: (Arbitrary a, Random a) => Int -> (a, a) -> Gen (Tree a)
sortedTreeGen' 0 _ = return Leaf
sortedTreeGen' n (l,r) = 
  frequency [ (10, return Leaf)
            , (90, do a <- choose (l,r)
                      let n' = n `div` 2
                      tl <- sortedTreeGen' n' (l,a)
                      tr <- sortedTreeGen' n' (a,r)
                      return $ Node tl a tr) ]

sortedIntTreeGen :: Gen (Tree Int)
sortedIntTreeGen = sortedTreeGen

t12 = sample sortedIntTreeGen 

propSortedInsert4 :: Int -> Property
propSortedInsert4 a = forAll sortedTreeGen $ \ t ->
                           collect (depth t) $ sortedTree (insert a t)

t13 = quickCheck propSortedInsert4
\end{code}


Arbitrary Class.

\begin{code}
instance (Arbitrary a) => Arbitrary (Tree a) where
  arbitrary = treeGen2

propSortedInsert5 :: Int -> Tree Int -> Property
propSortedInsert5 a t = sortedTree t ==> 
                           collect (depth t) $ sortedTree (insert a t)

t14 = quickCheck propSortedInsert5
\end{code}

|newtype| trick.

\begin{code}
newtype SortedTree a =  SortedTree { tree :: (Tree a) } deriving (Show, Eq)

instance (Arbitrary a, Random a, Bounded a) => Arbitrary (SortedTree a) where
  arbitrary = liftM SortedTree sortedTreeGen

propSortedInsert6 :: Int -> SortedTree Int -> Property
propSortedInsert6 a (SortedTree t) = 
                           collect (depth t) $ sortedTree (insert a t)

t15 = quickCheck propSortedInsert6
\end{code}