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