Current section
Files
Jump to
Current section
Files
lib/Test/QuickCheck.hm
-----------------------------------------------------------------------------
-- |
-- Module : QuickCheck
-- Copyright : (c) 2020-2021 EMQ Technologies Co., Ltd.
-- License : BSD-style (see the LICENSE file)
--
-- Maintainer : Feng Lee, feng@emqx.io
-- Yang M, yangm@emqx.io
-- Stability : experimental
-- Portability : portable
--
-- The QuickCheck module.
--
-----------------------------------------------------------------------------
module Test.QuickCheck where
import Data.Atom (atom)
import Data.Bool (otherwise)
import Data.Enum (range)
import Data.Eq ((==))
import Data.Int (Int)
import Data.List (concat, replicate, length) --init,
import Data.Functor (class Functor, map, (<$>))
import Data.Function (($), identity, error, (<<<))
import Data.Maybe (Maybe(..))
import Data.Ord ((<), (<=), (>=))
import Data.Ring ((-),(/),negate)
import Data.Semigroup ((<>))
import Data.Semiring ((+))
import Data.Show (showAny, show)
import Data.Tuple (fst)
import Data.Foldable (foldl)
import Data.Traversable (sequence)
import Data.Unit (Unit,unit)
import Control.Monad (unsafePerformIO, liftM1, liftM2, class Applicative, pure, class Monad, bind, IO, discard, seqio, (>>=))
import System.IO (printf, println)
import System.Random(randomRIO)
import Data.Binary (listToBin)
import System.Error (catchException)
foreign import data Rand :: Type
foreign import split :: Rand -> (Rand, Rand)
foreign import next :: Rand -> Rand
foreign import mkRand :: Integer -> Rand
class Random a where
randomR :: (a, a) -> Rand -> a
instance Random Integer where
randomR = randomRInt
foreign import randomRInt :: (Integer, Integer) -> Rand -> Integer
instance Random Float where
randomR = randomRFloat
foreign import randomRFloat :: (Float, Float) -> Rand -> Float
instance Random Char where
randomR = randomRChar
foreign import randomRChar :: (Char, Char) -> Rand -> Char
data Gen a = Gen (Integer -> Rand -> a)
choose :: forall a. Random a => (a, a) -> Gen a
choose bounds = Gen (\n r -> randomR bounds r)
rands :: Integer -> Rand -> Rand
rands 0 r = r
rands i r0 = rands (i-1) (next r0)
variant :: forall a. Integer -> Gen a -> Gen a
variant v (Gen m) = Gen (\n r ->
m n $ rands (v+1) r )
promote :: forall a b. (a -> Gen b) -> Gen (a -> b)
promote f = Gen (\n r -> \a ->
let Gen m = f a
in m n r )
sized :: forall a. (Int -> Gen a) -> Gen a
sized fgen = Gen ( \n r ->
let Gen m = fgen n in m n r
)
instance Functor Gen where
map f (Gen m) = Gen $ \n r -> f (m n r)
instance Applicative Gen where
apply (Gen f) (Gen a) = Gen $ \n r0 ->
let (r1, r2) = split r0
vf = f n r1
va = a n r2
in vf va
pure a = Gen $ \n r -> a
instance Monad Gen where
bind (Gen m1) k = Gen $ \n r0 ->
let (r1, r2) = split r0
Gen m2 = k (m1 n r1)
in m2 n r2
-----------------------------------------------------------------------------
index :: forall a. Integer -> [a] -> a
index 0 [x | _] = x
index i [x | xs] = index (i-1) xs
index _ _ = error "error input"
elements :: forall a. [a] -> Gen a
elements xs = map (\v -> index v xs) $ choose (0, length xs -1)
vector :: forall a. Arbitrary a => Integer -> Gen [a]
vector 0 = pure []
vector n = sequence [ arbitrary | i <- [1..n]]
oneof :: forall a. [Gen a] -> Gen a
oneof gens = elements gens >>= identity
pick :: forall a. Integer -> [(Integer, a)] -> a
pick n [(k,x)| xs] | n <= k = x
| otherwise = pick (n-k) xs
pick _ _ = error "error input"
frequency :: forall a. [(Integer, Gen a)] -> Gen a
frequency xs = choose (1, foldl (+) 0 (map fst xs)) >>= \x -> pick x xs
-----------------------------------------------------------------------------
class ArbitraryM a where
arbitraryM :: Integer -> Gen a
class Arbitrary a where
arbitrary :: Gen a
instance Arbitrary Boolean where
arbitrary = elements [true, false]
instance Arbitrary Integer where
arbitrary = sized (\n -> choose (-n, n))
instance Arbitrary Float where
arbitrary = choose (-100000000.0, 100000000.0)
instance Arbitrary Char where
arbitrary = choose ('A', 'z')
instance Arbitrary Atom where
arbitrary = atom <$> arbitrary
instance Arbitrary Binary where
arbitrary = listToBin <$> ( map tabs <$> arbitrary)
where tabs :: Integer -> Integer
tabs x | x >= 0 = x
| otherwise = (-x)
instance (Arbitrary a, Arbitrary b) => Arbitrary (a, b) where
arbitrary = liftM2 (\x y -> (x,y)) arbitrary arbitrary
instance Arbitrary a => Arbitrary [a] where
arbitrary = sized (\n -> choose (0,n) >>= vector)
instance (Coarbitrary a, Arbitrary b) => Arbitrary (a -> b) where
arbitrary = promote (\x -> x `coarbitrary` arbitrary)
instance Arbitrary v => Arbitrary (Maybe v) where
arbitrary = liftM1 Just arbitrary
-----------------------------------------------------------------------------
class Coarbitrary a where
coarbitrary :: forall b. a -> Gen b -> Gen b
instance Coarbitrary Boolean where
coarbitrary b = variant (if b then 0 else 1)
instance Coarbitrary Integer where
coarbitrary n
| n == 0 = variant 0
| n < 0 = variant 2 <<< coarbitrary (- n)
| otherwise = variant 1 <<< coarbitrary (n / 2)
-----------------------------------------------------------------------------
data Result = Result
{ok :: Maybe Boolean, stamp :: [String], arguments :: [String]}
data Property = Prop (Gen Result)
nothing :: forall a. {ok :: Maybe a, stamp :: [String], arguments :: [String]}
nothing = {ok = Nothing, stamp =[], arguments = []}
result :: Result -> Property
result res = Prop (pure res)
class Testable a where
property :: a -> Property
instance Testable Boolean where
property b = result ( Result nothing{ok= Just b})
instance Testable Property where
property prop = prop
instance (Testable a) => Testable (IO a) where
property b = property $ unsafePerformIO b
instance (Arbitrary a, Testable b) => Testable (a -> b) where
property f = forAll arbitrary f
evaluate :: forall a. Testable a => a -> Gen Result
evaluate a = gen where Prop gen = property a
forAll :: forall a b. Testable b => Gen a -> (a -> b) -> Property
forAll gen body = Prop $
do a <- gen
Result res <- unsafePerformIO $ catchException (pure $ evaluate (body a)) handleExcept
pure $ Result (arg a res)
where
arg a res = res{arguments = [showAny a | res.arguments ]}
handleExcept e = pure $ Gen $ \i r -> Result {arguments = [ showAny e], stamp = [], ok = Nothing }
type SpaceCounter = Integer
basePipe :: String
basePipe = "| "
errorPipe :: String
errorPipe = "✖ "
crashPipe :: String
crashPipe = "● "
check :: forall a. Testable a => String -> Integer -> a -> SpaceCounter -> IO TestResult
check s 0 m n = (printf "%s✔ %s" (concat $ replicate (n/5) basePipe) s :: IO ()) >>= \_ -> pure Successed
check s v m n = do
i <- randomRIO 1332292274972041455 7304856964418773083
let Gen fun = evaluate m
Result r = fun 15 (mkRand i)
case r.ok of
Just true -> check s (v-1) m n
Just false -> (printf "%s✖ %s -----> %s"
(concat $ replicate (n/5) errorPipe) s (showAny r.arguments) :: IO ()) >>= \_ -> pure $ Failed s (showAny r.arguments)
Nothing -> (printf "%s● %s ==> crash happened!!! %s"
(concat $ replicate (n/5) crashPipe) s (showAny r.arguments) :: IO ()) >>= \_ -> pure $ Crash s (showAny r.arguments)
quickCheck :: forall a. Testable a => String -> a -> SpaceCounter -> IO TestResult
quickCheck s m n = check s 100 m n
quickCheck1 :: forall a. Testable a => String -> a -> SpaceCounter -> IO TestResult
quickCheck1 s m n = check s 1 m n
data TestResult = Successed
| Failed String String
| Crash String String
data TestGroup a = TxG String [TestGroup a]
| Exe [a]
tgToList :: TestGroup TestResult -> [TestResult]
tgToList (Exe xs) = xs
tgToList (TxG _ xs) = concat $ map tgToList xs
runTestGroup :: SpaceCounter -> TestGroup (Integer -> IO TestResult) -> IO (TestGroup TestResult)
runTestGroup n (Exe fs) = Exe <$> (seqio $ map (\x -> x n) fs)
runTestGroup n (TxG s xs) =
TxG s <$> do println (concat (replicate (n/5) basePipe) <> "✺ "<> s )
res <- seqio $ map (runTestGroup (n+5)) xs
let res1 = concat $ map tgToList res
(succ, fail, crash, total) = tcount (0,0,0,0) res1
renderCrash 0 = ""
renderCrash i = "(crashed " <> show i <> ")"
printf "%s----> ◯ %d, ✔ %d, ✖ %d%s." (concat $ replicate (n/5) basePipe) total succ fail (renderCrash crash)
pure res
runTest :: TestGroup (Integer -> IO TestResult) -> IO ()
runTest g = runTestGroup 0 g >>= \_ -> pure ()
tcount :: (Integer, Integer, Integer, Integer) -> [TestResult] -> (Integer, Integer, Integer, Integer)
tcount (a,b,c,d) [] = (a,b,c,d)
tcount (a,b,c,d) [x|xs] = case x of
Successed -> tcount (a+1 ,b ,c , d+1) xs
Failed _ _ -> tcount (a ,b+1 ,c , d+1) xs
Crash _ _ -> tcount (a ,b+1 ,c+1 , d+1) xs