1{-# LANGUAGE DeriveFunctor #-}
2-- | This QC doesn't shrink :(
3module MiniQC where
4
5import Control.Monad                  (ap)
6import Data.Int                       (Int32, Int64)
7import Data.Word                      (Word32, Word64)
8import Prelude ()
9import Prelude.Compat
10import Test.Framework.Providers.API   (Test, TestName)
11import Test.Framework.Providers.HUnit (testCase)
12import Test.HUnit                     (assertFailure)
13
14import System.Random.SplitMix
15
16newtype Gen a = Gen { unGen :: SMGen -> a }
17  deriving (Functor)
18
19instance Applicative Gen where
20    pure x = Gen (const x)
21    (<*>) = ap
22
23instance Monad Gen where
24    return = pure
25
26    m >>= k = Gen $ \g ->
27        let (g1, g2) = splitSMGen g
28        in unGen (k (unGen m g1)) g2
29
30class Arbitrary a where
31    arbitrary :: Gen a
32
33instance Arbitrary Word32 where
34    arbitrary = Gen $ \g -> fst (nextWord32 g)
35instance Arbitrary Word64 where
36    arbitrary = Gen $ \g -> fst (nextWord64 g)
37instance Arbitrary Int32 where
38    arbitrary = Gen $ \g -> fromIntegral (fst (nextWord32 g))
39instance Arbitrary Int64 where
40    arbitrary = Gen $ \g -> fromIntegral (fst (nextWord64 g))
41instance Arbitrary Double where
42    arbitrary = Gen $ \g -> fst (nextDouble g)
43
44newtype Property = Property { unProperty :: Gen ([String], Bool) }
45
46class Testable a where
47    property :: a -> Property
48
49instance Testable Property where
50    property = id
51
52instance Testable Bool where
53    property b = Property $ pure ([show b], b)
54
55instance (Arbitrary a, Show a, Testable b) => Testable (a -> b) where
56    property f = Property $ do
57        x <- arbitrary
58        (xs, b) <- unProperty (property (f x))
59        return (show x : xs, b)
60
61forAllBlind :: Testable prop => Gen a -> (a -> prop) -> Property
62forAllBlind g f = Property $ do
63    x <- g
64    (xs, b) <- unProperty (property (f x))
65    return ("<blind>" : xs, b)
66
67counterexample :: Testable prop => String -> prop -> Property
68counterexample msg prop = Property $ do
69    (xs, b) <- unProperty (property prop)
70    return (msg : xs, b)
71
72testMiniProperty :: Testable prop => TestName -> prop -> Test
73testMiniProperty name prop = testCase name $ do
74    g <- newSMGen
75    go (100 :: Int) g
76  where
77    go n _ | n <= 0  = return ()
78    go n g           = do
79        let (g1, g2) = splitSMGen g
80        case unGen (unProperty (property prop)) g1 of
81            (_, True) -> return ()
82            (xs, False) -> assertFailure (unlines (reverse xs))
83        go (pred n) g2
84