{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
import Test.QuickCheck
import Test.QuickCheck.Poly
import Test.QuickCheck.Checkers
import Test.QuickCheck.Classes
import Test.ChasingBottoms
import Test.Framework as Framework
import Test.Framework.Providers.QuickCheck2
import qualified Data.Tree.Binary.Preorder as Preorder
import qualified Data.Tree.Binary.Leafy as Leafy
import qualified Data.Tree.Binary.Inorder as Inorder
import Control.Applicative
import Data.Foldable
import Data.Traversable
#if MIN_VERSION_base(4,9,0)
import Data.Functor.Classes
#endif
import Prelude hiding
( replicate
#if MIN_VERSION_base(4,8,0)
,Functor(..),Foldable(..),Applicative, (<$>), foldMap, Monoid
#else
,foldr,foldl
#endif
)
import Data.Functor (Functor(fmap))
#if MIN_VERSION_base(4,6,0)
import Data.Foldable (Foldable(foldl, foldr, foldMap, foldl', foldr'))
#else
import Data.Foldable (Foldable(foldl, foldr, foldMap))
#endif
#if MIN_VERSION_base(4,9,0)
import qualified Data.Semigroup as Semigroup
#endif
import Text.Read
--------------------------------------------------------------------------------
-- Lifted Properties
--------------------------------------------------------------------------------
#if MIN_VERSION_base(4,9,0)
eq1Prop ::
(Eq (f OrdA), Eq1 f, Show (f OrdA), Arbitrary (f OrdA))
=> f OrdA
-> Property
eq1Prop p =
forAllShrink arbitrary shrink $ \xs ->
forAllShrink (oneof [pure xs, arbitrary]) shrink $ \ys ->
(Lifted xs == Lifted ys) === ((xs `asTypeOf` p) == ys)
ord1Prop ::
(Ord (f OrdA), Ord1 f, Show (f OrdA), Arbitrary (f OrdA))
=> f OrdA
-> Property
ord1Prop p =
forAllShrink arbitrary shrink $ \xs ->
forAllShrink (oneof [pure xs, arbitrary]) shrink $ \ys ->
(Lifted xs `compare` Lifted ys) === ((xs `asTypeOf` p) `compare` ys)
showProp :: (Show1 f, Show (f A)) => f () -> f A -> Property
showProp _ xs = show xs === show (Lifted xs)
readProp ::
(Read1 f, Show (f (f Int)), Read (f Int), EqProp (f (f Int)), Arbitrary (f (f Int)))
=> f (f Int)
-> Property
readProp p = inverseL reader show
where
reader str = runLifted (read str) `asTypeOf` p
liftedProperties
:: (Ord (f OrdA)
,Ord1 f
,Show (f OrdA)
,Arbitrary (f OrdA)
,Show1 f
,Arbitrary (f A)
,Show (f A)
,Read1 f
,Show (f (f Int))
,Read (f Int)
,EqProp (f (f Int))
,Arbitrary (f (f Int))
,EqProp (f OrdA))
=> (OrdA -> f OrdA) -> Framework.Test
liftedProperties t =
testGroup
"Lifted Classes"
[ testBatch (ord (\x -> oneof [pure x, arbitrary `asTypeOf` conv3 t]))
, testProperty "eq1" (eq1Prop (t undefined))
, testProperty "ord1 consistency" (ord1Prop (t undefined))
, testProperty "show1" (showProp (conv t))
, testProperty "read1" (readProp (conv2 t))]
where
conv :: (OrdA -> f OrdA) -> f ()
conv = undefined
conv2 :: (OrdA -> f OrdA) -> f (f Int)
conv2 = undefined
conv3 :: (OrdA -> f OrdA) -> Gen (Lifted f OrdA)
conv3 = undefined
#endif
--------------------------------------------------------------------------------
-- Folds
--------------------------------------------------------------------------------
foldlProp ::
(Foldable f)
=> f ()
-> f A
-> Fun (B, A) B
-> B
-> Property
foldlProp _ xs f b =
foldl (applyFun2 f) b (toList xs) === foldl (applyFun2 f) b xs
foldrProp' ::
(Foldable f)
=> f ()
-> f A
-> Fun (A, B) B
-> B
-> Property
foldrProp' _ xs f b = foldr' (applyFun2 f) b xs === foldr (applyFun2 f) b xs
foldlProp' ::
(Foldable f)
=> f ()
-> f A
-> Fun (B, A) B
-> B
-> Property
foldlProp' _ xs f b =
foldl' (applyFun2 f) b xs === foldl (applyFun2 f) b xs
foldMapProp :: Foldable f => f () -> f A -> Fun A [B] -> Property
foldMapProp _ xs f =
foldMap (applyFun f) (toList xs) === foldMap (applyFun f) xs
indexed :: Traversable f => f a -> (Int, f Int)
indexed = mapAccumL (\a _ -> (a+1, a)) 0
foldrStrictProp :: (Show (f Int), Traversable f) => f () -> f () -> Property
foldrStrictProp _ xs' =
conjoin
[ counterexample (unlines [show xs, show ys, show i]) $
isBottom (foldr' c b xs) === isBottom (foldr' c b ys)
| b
-- error "too strict",
<-
[0 :: Int]
, (i, c) <- zip [(-1 :: Int) ..] fns
]
where
(n, xs) = indexed xs'
ys = [0 .. n - 1]
fns =
const :
[ \y _ ->
if x == y
then error "too strict"
else y
| x <- ys
]
foldlStrictProp :: (Show (f Int), Traversable f) => f () -> f () -> Property
foldlStrictProp _ xs' =
conjoin
[ counterexample (unlines [show xs, show ys, show i]) $
isBottom (foldl' c b xs) == isBottom (foldl' c b ys)
| b <- [error "too strict", 0]
, (i, c) <- zip [(-1 :: Int) ..] fns
]
where
(n, xs) = indexed xs'
ys = [(0 :: Int) .. n - 1]
fns =
const id :
[ \_ y ->
if x == y
then error "too strict"
else y
| x <- ys
]
foldProperties
:: (Arbitrary (f A)
,Show (f A)
,Show (f Int)
,Arbitrary (f ())
,Show (f ())
,Traversable f)
=> f () -> Framework.Test
foldProperties p =
testGroup
"Folds"
[ testProperty "foldl" (foldlProp p)
, testProperty "foldr'" (foldrProp' p)
, testProperty "foldl'" (foldlProp' p)
, testProperty "foldMap" (foldMapProp p)
, testProperty "foldrStrict" (foldrStrictProp p)
#if MIN_VERSION_base(4,8,0) || !MIN_VERSION_base(4,6,0)
, testProperty "foldlStrict" (foldlStrictProp p)
#endif
]
--------------------------------------------------------------------------------
-- Display
--------------------------------------------------------------------------------
endsInNewlineProp :: (a -> String) -> a -> Property
endsInNewlineProp f x =
maybe (counterexample "shouldn't be empty" False) ('\n' ===) (last' (f x))
where
last' =
foldl'
(\_ e ->
Just e)
Nothing
--------------------------------------------------------------------------------
-- Helper for Checker format
--------------------------------------------------------------------------------
testBatch :: TestBatch -> Framework.Test
testBatch (name, tests) = testGroup name (map (uncurry testProperty) tests)
main :: IO ()
main =
defaultMain
[ testGroup
"Preorder"
[ testBatch (monoid (Preorder.Leaf :: Preorder.Tree A))
, testProperty "toList . fromList" (inverseL toList (Preorder.fromList :: [Int] -> Preorder.Tree Int))
#if MIN_VERSION_base(4,9,0)
, liftedProperties (const Preorder.Leaf)
#endif
, foldProperties Preorder.Leaf
, testBatch (functor (undefined :: Preorder.Tree (A, B, C)))
, testBatch
( "applicative"
, [ (name, test)
| (name, test) <- snd $ applicative (undefined :: Preorder.Tree (A, B, C))
, name /= "homomorphism"
])
, testBatch (traversable (undefined :: Preorder.Tree (A, B, [Int])))
, testBatch (alternative (undefined :: Preorder.Tree A))
, testProperty "drawTree ends in newline" (endsInNewlineProp (Preorder.drawTree :: Preorder.Tree A -> String))
]
, testGroup
"Inorder"
[ testBatch (monoid (Inorder.Leaf :: Inorder.Tree A))
, testProperty "toList . fromList" (inverseL toList (Inorder.fromList :: [Int] -> Inorder.Tree Int))
#if MIN_VERSION_base(4,9,0)
, liftedProperties (const Inorder.Leaf)
#endif
, foldProperties Inorder.Leaf
, testBatch
( "applicative"
, [ (name, test)
| (name, test) <- snd $ applicative (undefined :: Inorder.Tree (A, B, C))
, name /= "homomorphism"
])
, testBatch (functor (undefined :: Inorder.Tree (A, B, C)))
, testBatch (traversable (undefined :: Inorder.Tree (A, B, [Int])))
, testBatch (alternative (undefined :: Inorder.Tree A))
, testProperty "drawTree ends in newline" (endsInNewlineProp (Inorder.drawTree :: Inorder.Tree A -> String))
]
, testGroup
"Leafy"
[
#if MIN_VERSION_base(4,9,0)
testProperty "semigroup" (isAssoc ((Semigroup.<>) :: Leafy.Tree Int -> Leafy.Tree Int -> Leafy.Tree Int) ) ,
#endif
testProperty "toList . fromList" (inverseL (NonEmpty . toList) (Leafy.fromList . getNonEmpty :: NonEmptyList Int -> Leafy.Tree Int))
#if MIN_VERSION_base(4,9,0)
, liftedProperties Leafy.Leaf
#endif
, foldProperties (Leafy.Leaf undefined)
, testBatch (functor (undefined :: Leafy.Tree (A, B, C)))
, testBatch (applicative (undefined :: Leafy.Tree (A, B, C)))
, testBatch (monad (undefined :: Leafy.Tree (A, B, C)))
, testBatch (monadFunctor (undefined :: Leafy.Tree (A, B)))
, testBatch (monadApplicative (undefined :: Leafy.Tree (A, B)))
, testBatch (traversable (undefined :: Leafy.Tree (A, B, [Int])))
, testProperty "drawTree ends in newline" (endsInNewlineProp (Leafy.drawTree :: Leafy.Tree A -> String))
]
]
--------------------------------------------------------------------------------
-- Arbitrary Instances
--------------------------------------------------------------------------------
instance Arbitrary a => Arbitrary (Preorder.Tree a) where
arbitrary = sized go
where
go n
| n <= 0 = pure Preorder.Leaf
| otherwise =
oneof [pure Preorder.Leaf, liftA3 Preorder.Node arbitrary sub sub]
where
sub = go (n `div` 2)
shrink Preorder.Leaf = []
shrink (Preorder.Node x l r) =
Preorder.Leaf :
l : r : [Preorder.Node x' l' r' | (x', l', r') <- shrink (x, l, r)]
instance Arbitrary a => Arbitrary (Inorder.Tree a) where
arbitrary = sized go
where
go n
| n <= 0 = pure Inorder.Leaf
| otherwise =
oneof [pure Inorder.Leaf, liftA3 Inorder.Node sub arbitrary sub]
where
sub = go (n `div` 2)
shrink Inorder.Leaf = []
shrink (Inorder.Node l x r) =
Inorder.Leaf :
l : r : [Inorder.Node l' x' r' | (l', x', r') <- shrink (l, x, r)]
instance Arbitrary a => Arbitrary (Leafy.Tree a) where
arbitrary = sized go
where
go n
| n <= 0 = fmap Leafy.Leaf arbitrary
| otherwise =
oneof [fmap Leafy.Leaf arbitrary, liftA2 (Leafy.:*:) sub sub]
where
sub = go (n `div` 2)
shrink (Leafy.Leaf x) = fmap Leafy.Leaf (shrink x)
shrink (l Leafy.:*: r) =
l : r : [l' Leafy.:*: r' | (l', r') <- shrink (l, r)]
--------------------------------------------------------------------------------
-- EqProp Instances
--------------------------------------------------------------------------------
instance (Show a, Eq a) => EqProp (Preorder.Tree a) where
x =-= y =
whenFail
(putStrLn (Preorder.drawTree x ++ "\n/=\n" ++ Preorder.drawTree y))
(x == y)
instance (Show a, Eq a) => EqProp (Inorder.Tree a) where
x =-= y =
whenFail
(putStrLn (Inorder.drawTree x ++ "\n/=\n" ++ Inorder.drawTree y))
(x == y)
instance (Show a, Eq a) => EqProp (Leafy.Tree a) where
x =-= y =
whenFail
(putStrLn (Leafy.drawTree x ++ "\n/=\n" ++ Leafy.drawTree y))
(x == y)
instance (Eq a, Show a) => EqProp (NonEmptyList a) where
(=-=) = (===)
--------------------------------------------------------------------------------
-- Lifted
--------------------------------------------------------------------------------
#if MIN_VERSION_base(4,9,0)
newtype Lifted f a = Lifted { runLifted :: f a }
instance (Eq1 f, Eq a) => Eq (Lifted f a) where
Lifted xs == Lifted ys = eq1 xs ys
instance (Ord1 f, Ord a) => Ord (Lifted f a) where
compare (Lifted xs) (Lifted ys) = compare1 xs ys
instance (Show1 f, Show a) => Show (Lifted f a) where
showsPrec n (Lifted xs) = showsPrec1 n xs
showList xs = liftShowList showsPrec showList [ x | Lifted x <- xs ]
instance (Read1 f, Read a) => Read (Lifted f a) where
#if MIN_VERSION_base(4,10,0)
readPrec = fmap Lifted readPrec1
#else
readsPrec n xs = [ (Lifted x,ys) | (x, ys) <- readsPrec1 n xs ]
#endif
instance EqProp (f a) => EqProp (Lifted f a) where
Lifted x =-= Lifted y = x =-= y
instance Arbitrary (f a) => Arbitrary (Lifted f a) where
arbitrary = fmap Lifted arbitrary
shrink (Lifted xs) = fmap Lifted (shrink xs)
#endif