1 {-# LANGUAGE CPP #-}
3 import Data.Tree as T
5 import Control.Applicative (Const(Const, getConst), pure, (<\$>), (<*>), liftA2)
7 import Test.Framework
8 import Test.Framework.Providers.QuickCheck2
9 import Test.QuickCheck
10 import Test.QuickCheck.Function (Fun (..), apply)
11 import Test.QuickCheck.Poly (A, B, C)
15 default (Int)
17 main :: IO ()
18 main = defaultMain
19 [
23 , testProperty "ap_ap" prop_ap_ap
24 , testProperty "ap_liftA2" prop_ap_liftA2
26 ]
28 {--------------------------------------------------------------------
29 Arbitrary trees
30 --------------------------------------------------------------------}
33 -- This instance isn't balanced very well; the trees will probably tend
34 -- to lean left. But it's better than nothing and we can fix it later.
35 instance Arbitrary a => Arbitrary (Tree a) where
36 arbitrary = sized (fmap snd . arbtree)
37 where
38 arbtree :: Arbitrary a => Int -> Gen (Int, Tree a)
39 arbtree 0 = fmap ((,) 1) \$ Node <\$> arbitrary <*> pure []
40 arbtree n = do
41 root <- arbitrary
42 num_children <- choose (0, n - 1)
43 (st, tl) <- go num_children
44 return (1+st, Node root tl)
46 go 0 = pure (0, [])
47 go n = do
48 (sh, hd) <- arbtree n
49 (st, tl) <- go (n - sh)
50 pure (sh + st, hd : tl)
53 shrink = genericShrink
54 #endif
56 ----------------------------------------------------------------
57 -- Unit tests
58 ----------------------------------------------------------------
60 ----------------------------------------------------------------
61 -- QuickCheck
62 ----------------------------------------------------------------
64 apply2 :: Fun (a, b) c -> a -> b -> c
65 apply2 f a b = apply f (a, b)
67 prop_ap_ap :: Tree (Fun A B) -> Tree A -> Property
68 prop_ap_ap fs xs = (apply <\$> fs <*> xs) === ((apply <\$> fs) `ap` xs)
70 prop_ap_liftA2 :: Fun (A, B) C -> Tree A -> Tree B -> Property
71 prop_ap_liftA2 f as bs = (apply2 f <\$> as <*> bs) === liftA2 (apply2 f) as bs
73 prop_monad_id1 :: Tree A -> Property
74 prop_monad_id1 t = (t >>= pure) === t
76 prop_monad_id2 :: A -> Fun A (Tree B) -> Property
77 prop_monad_id2 a f = (pure a >>= apply f) === apply f a
79 prop_monad_assoc :: Tree A -> Fun A (Tree B) -> Fun B (Tree C) -> Property
80 prop_monad_assoc ta atb btc =
81 ((ta >>= apply atb) >>= apply btc)
82 ===
83 (ta >>= \a -> apply atb a >>= apply btc)
85 -- The left shrinking law
86 --
87 -- This test is kind of wonky and unprincipled, because it's
88 -- rather tricky to construct test cases!
89 -- This is the most important MonadFix law to test because it's the
90 -- least intuitive by far, and because it's the only one that's
91 -- sensitive to the Monad instance.
92 prop_monadFix_ls :: Int -> Tree Int -> Fun Int (Tree Int) -> Property
93 prop_monadFix_ls val ta ti =
94 fmap (\$val) (mfix (\x -> ta >>= \y -> f x y))
95 ===
96 fmap (\$val) (ta >>= \y -> mfix (\x -> f x y))
97 where
98 fact :: Int -> (Int -> Int) -> Int -> Int
99 fact x _ 0 = x + 1
100 fact x f n = x + n * f ((n - 1) `mod` 23)
102 f :: (Int -> Int) -> Int -> Tree (Int -> Int)
103 f q y = let t = apply ti y
104 in fmap (\w -> fact w q) t