Merge pull request #918 from haskell/better-shrink

Add ordNub to shrink

Author: phadej

aeson.cabal

@@ -194,6 +194,7 @@ test-suite aeson-tests
     , generic-deriving      >=1.10     && <1.15
     , ghc-prim              >=0.2
     , hashable
+    , indexed-traversable
     , integer-logarithms    >=1        && <1.1
     , OneTuple
     , primitive

src/Data/Aeson/Types/Internal.hs

@@ -113,6 +113,7 @@ import qualified Data.Aeson.KeyMap as KM
 import qualified Data.Scientific as Sci
 import qualified Data.Text as T
 import qualified Test.QuickCheck as QC
+import Witherable (ordNub)
 
 -- | Elements of a JSON path used to describe the location of an
 -- error.
@@ -395,12 +396,13 @@ instance Show Value where
 instance QC.Arbitrary Value where
     arbitrary = QC.sized arbValue
 
-    shrink Null       = []
-    shrink (Bool b)   = Null : map Bool (QC.shrink b)
-    shrink (String x) = Null : map (String . T.pack) (QC.shrink (T.unpack x))
-    shrink (Number x) = Null : map Number (shrScientific x)
-    shrink (Array x)  = Null : V.toList x ++ map (Array . V.fromList) (QC.shrink (V.toList x))
-    shrink (Object x) = Null : KM.elems x ++ map (Object . KM.fromList) (QC.shrink (KM.toList x))
+    shrink = ordNub . go where
+        go Null       = []
+        go (Bool b)   = Null : map Bool (QC.shrink b)
+        go (String x) = Null : map (String . T.pack) (QC.shrink (T.unpack x))
+        go (Number x) = Null : map Number (shrScientific x)
+        go (Array x)  = Null : V.toList x ++ map (Array . V.fromList) (QC.liftShrink go (V.toList x))
+        go (Object x) = Null : KM.elems x ++ map (Object . KM.fromList) (QC.liftShrink (QC.liftShrink go) (KM.toList x))
 
 -- | @since 2.0.3.0
 instance QC.CoArbitrary Value where

tests/PropertyQC.hs

@@ -1,28 +1,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 (testProperty)
+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 Data.Aeson (Value)
+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"
-    [ testProperty "shrink terminates" shrink_prop
+    [ 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
+      ]
     ]
 
--- | Test that shrink eventually (in 1000000 steps at most) terminates.
-shrink_prop :: Value -> Bool
-shrink_prop = go 0 where
-    go :: Int -> Value -> Bool
-    go !n v
-        | n >= 1000000 = False
-        | otherwise    = case shrink v of
-            []     -> True
-            v' : _ -> go (n + 1) v'
-        
+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