1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
|
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeApplications #-}
module PropertyQC (quickcheckTests) where
import Prelude.Compat
import Instances ()
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck (Arbitrary, Property, testProperty, counterexample, property)
import Test.QuickCheck (shrink)
import Data.Char (isLower, isUpper, isDigit, isSpace)
import Data.Foldable (foldl')
import Data.Foldable.WithIndex (ifoldl')
import qualified Data.Text as T
import qualified Data.Aeson.Key as K
import qualified Data.Scientific as Sci
import Data.Aeson (Value (..))
quickcheckTests :: TestTree
quickcheckTests = testGroup "QuickCheck"
[ testGroup "shrink terminates"
[ testProperty "Int" $ shrink_prop @Int
, testProperty "Bool" $ shrink_prop @Int
, testProperty "Integer" $ shrink_prop @Integer
, testProperty "Char" $ shrink_prop @Char
, testProperty "Text" $ shrink_prop @T.Text
, testProperty "(Int,Int)" $ shrink_prop @(Integer, Int)
, testProperty "Scientific" $ shrink_prop @Sci.Scientific
, testProperty "Value" $ shrink_prop @Value
]
]
shrink_prop :: (Show a, ShrinkMetric a) => a -> Property
shrink_prop v = case vs' of
[] -> property True
v' : _ -> counterexample (show vs') $
counterexample (show (metric v, metric v', v)) False
where
vs = shrink v
-- we check only 50 first ones, otherwise it would take too long.
vs' = filter (not . predicate) $ take 50 vs
-- shrunk v's should be smaller.
predicate v' = metric v' < metric v
class Arbitrary a => ShrinkMetric a where
metric :: a -> Integer
instance (ShrinkMetric a, ShrinkMetric b) => ShrinkMetric (a, b) where
metric (a, b) = (1 + metric a) * (1 + metric b)
instance ShrinkMetric Bool where
metric b = if b then 1 else 0
instance ShrinkMetric Int where
metric = metric . toInteger
instance ShrinkMetric Integer where
metric i = if i < 0 then 1 + negate i else i
-- Char shrinking is tricky.
-- See: https://hackage.haskell.org/package/QuickCheck-2.14.2/docs/src/Test.QuickCheck.Arbitrary.html#line-664
instance ShrinkMetric Char where
metric c = toInteger $ foldl' (+) 0
[ if not $ isLower c then 0x2000000 else 0
, if not $ isUpper c then 0x1000000 else 0
, if not $ isDigit c then 0x0800000 else 0
, if not $ c == ' ' then 0x0400000 else 0
, if not $ isSpace c then 0x0200000 else 0
, fromEnum c
]
instance ShrinkMetric T.Text where
metric = foldl' (\acc c -> acc + 1 + metric c) 0 . T.unpack
instance ShrinkMetric K.Key where
metric = metric . K.toText
instance ShrinkMetric Sci.Scientific where
metric s = metric (Sci.coefficient s, Sci.base10Exponent s)
instance ShrinkMetric Value where
metric Null = 0
metric (Bool b) = 1 + metric b
metric (String t) = 1 + metric t
metric (Number n) = 1 + metric n
metric (Array xs) = foldl' (\acc x -> acc + 1 + metric x) 1 xs
metric (Object xs) = ifoldl' (\k acc x -> acc + metric (k, x)) 1 xs
|
