Merge pull request #916 from haskell/arbitrary

Add QuickCheck instances

Author: phadej

aeson.cabal

@@ -1,5 +1,5 @@
 name:               aeson
-version:            2.0.2.0
+version:            2.0.3.0
 license:            BSD3
 license-file:       LICENSE
 category:           Text, Web, JSON
@@ -119,6 +119,7 @@ library
     , indexed-traversable   >=0.1.1    && <0.2
     , OneTuple              >=0.3.1    && <0.4
     , primitive             >=0.7.0.1  && <0.8
+    , QuickCheck            >=2.14.2   && <2.15
     , scientific            >=0.3.7.0  && <0.4
     , semialign             >=1.2      && <1.3
     , strict                >=0.4      && <0.5
@@ -166,6 +167,7 @@ test-suite aeson-tests
     Properties
     PropertyGeneric
     PropertyKeys
+    PropertyQC
     PropertyRoundTrip
     PropertyRTFunctors
     PropertyTH

benchmarks/aeson-benchmarks.cabal

@@ -36,6 +36,7 @@ library
     , mtl
     , OneTuple
     , primitive
+    , QuickCheck
     , scientific
     , semialign
     , strict

changelog.md

@@ -1,5 +1,12 @@
 For the latest version of this document, please see [https://github.com/haskell/aeson/blob/master/changelog.md](https://github.com/haskell/aeson/blob/master/changelog.md).
 
+### 2.0.3.0
+
+* `text-2.0` support
+* `bytestring-0.11.2.0` support
+* Rewrite pure text literal unescaper.
+* Add `QuickCheck`'s `Arbitrary`, `CoArbitrary` and `Function` instances
+
 ### 2.0.2.0
 
 * Add `IsList (KeyMap v)` instance.

src/Data/Aeson/Key.hs

@@ -31,6 +31,7 @@ import qualified Data.String
 import qualified Data.Text as T
 import qualified Data.Text.Short as ST
 import qualified Language.Haskell.TH.Syntax as TH
+import qualified Test.QuickCheck as QC
 
 newtype Key = Key { unKey :: Text }
   deriving (Eq, Ord, Typeable, Data)
@@ -103,3 +104,16 @@ instance TH.Lift Key where
 #elif MIN_VERSION_template_haskell(2,16,0)
     liftTyped = TH.unsafeTExpCoerce . TH.lift
 #endif
+
+-- | @since 2.0.3.0
+instance QC.Arbitrary Key where
+    arbitrary = fromString <$> QC.arbitrary
+    shrink k  = fromString <$> QC.shrink (toString k)
+
+-- | @since 2.0.3.0
+instance QC.CoArbitrary Key where
+    coarbitrary = QC.coarbitrary . toString
+
+-- | @since 2.0.3.0
+instance QC.Function Key where
+    function = QC.functionMap toString fromString

src/Data/Aeson/KeyMap.hs

@@ -48,6 +48,7 @@ module Data.Aeson.KeyMap (
     fromListWith,
     toList,
     toAscList,
+    elems,
 
     -- * Maps
     fromHashMap,
@@ -121,6 +122,7 @@ import qualified Data.Traversable.WithIndex as WI (TraversableWithIndex (..))
 import qualified Data.Semialign as SA
 import qualified Data.Semialign.Indexed as SAI
 import qualified GHC.Exts
+import qualified Test.QuickCheck as QC
 import qualified Witherable as W
 
 #ifdef USE_ORDEREDMAP
@@ -235,12 +237,18 @@ fromListWith op = KeyMap . M.fromListWith op
 fromList :: [(Key, v)] -> KeyMap v
 fromList = KeyMap . M.fromList
 
--- | Return a list of this map's elements.
+-- | Return a list of this map's keys and elements.
 --
 -- The order is not stable. Use 'toAscList' for stable ordering.
 toList :: KeyMap v -> [(Key, v)]
 toList = M.toList . unKeyMap
 
+-- | Return a list of this map' elements.
+--
+-- @since 2.0.2.0
+elems :: KeyMap v -> [v]
+elems = M.elems . unKeyMap
+
 -- | Return a list of this map's elements in ascending order
 -- based of the textual key.
 toAscList :: KeyMap v -> [(Key, v)]
@@ -436,6 +444,12 @@ fromList = KeyMap . H.fromList
 toList :: KeyMap v -> [(Key, v)]
 toList = H.toList . unKeyMap
 
+-- | Return a list of this map' elements.
+--
+-- @since 2.0.2.0
+elems :: KeyMap v -> [v]
+elems = H.elems . unKeyMap
+
 -- | Return a list of this map's elements in ascending order
 -- based of the textual key.
 toAscList :: KeyMap v -> [(Key, v)]
@@ -679,3 +693,25 @@ instance W.FilterableWithIndex Key KeyMap where
     imapMaybe = mapMaybeWithKey
 
 instance W.WitherableWithIndex Key KeyMap where
+
+-------------------------------------------------------------------------------
+-- QuickCheck
+-------------------------------------------------------------------------------
+
+-- | @since 2.0.3.0
+instance QC.Arbitrary1 KeyMap where
+    liftArbitrary a  = fmap fromList (QC.liftArbitrary (QC.liftArbitrary a))
+    liftShrink shr m = fmap fromList (QC.liftShrink (QC.liftShrink shr) (toList m))
+
+-- | @since 2.0.3.0
+instance QC.Arbitrary v => QC.Arbitrary (KeyMap v) where
+    arbitrary = QC.arbitrary1
+    shrink    = QC.shrink1
+
+-- | @since 2.0.3.0
+instance QC.CoArbitrary v => QC.CoArbitrary (KeyMap v) where
+    coarbitrary = QC.coarbitrary . toList
+
+-- | @since 2.0.3.0
+instance QC.Function v => QC.Function (KeyMap v) where
+    function = QC.functionMap toList fromList

src/Data/Aeson/Types/Internal.hs

@@ -110,6 +110,9 @@ import qualified Data.Vector as V
 import qualified Language.Haskell.TH.Syntax as TH
 import qualified Data.Aeson.Key as Key
 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
 
 -- | Elements of a JSON path used to describe the location of an
 -- error.
@@ -388,6 +391,92 @@ instance Show Value where
         . showsPrec 11 (KM.toAscList xs)
         . showChar ')'
 
+-- | @since 2.0.3.0
+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))
+
+-- | @since 2.0.3.0
+instance QC.CoArbitrary Value where
+    coarbitrary Null       = QC.variant (0 :: Int)
+    coarbitrary (Bool b)   = QC.variant (1 :: Int) . QC.coarbitrary b
+    coarbitrary (String x) = QC.variant (2 :: Int) . QC.coarbitrary (T.unpack x)
+    coarbitrary (Number x) = QC.variant (3 :: Int) . QC.coarbitrary (Sci.coefficient x) . QC.coarbitrary (Sci.base10Exponent x)
+    coarbitrary (Array x)  = QC.variant (4 :: Int) . QC.coarbitrary (V.toList x)
+    coarbitrary (Object x) = QC.variant (5 :: Int) . QC.coarbitrary (KM.toList x)
+
+-- | @since 2.0.3.0
+instance QC.Function Value where
+    function = QC.functionMap fwd bwd where
+        fwd :: Value -> RepValue
+        fwd Null       = Left Nothing
+        fwd (Bool b)   = Left (Just b)
+        fwd (String x) = Right (Left (Left (T.unpack x)))
+        fwd (Number x) = Right (Left (Right (Sci.coefficient x, Sci.base10Exponent x)))
+        fwd (Array x)  = Right (Right (Left (V.toList x)))
+        fwd (Object x) = Right (Right (Right (KM.toList x)))
+
+        bwd :: RepValue -> Value
+        bwd (Left Nothing)                = Null
+        bwd (Left (Just b))               = Bool b
+        bwd (Right (Left (Left x)))       = String (T.pack x)
+        bwd (Right (Left (Right (x, y)))) = Number (Sci.scientific x y)
+        bwd (Right (Right (Left x)))      = Array (V.fromList x)
+        bwd (Right (Right (Right x)))     = Object (KM.fromList x)
+
+-- Used to implement QC.Function Value instance
+type RepValue
+    = Either (Maybe Bool) (Either (Either String (Integer, Int)) (Either [Value] [(Key, Value)]))
+
+arbValue :: Int -> QC.Gen Value
+arbValue n
+    | n <= 0 = QC.oneof
+        [ pure Null
+        , Bool <$> QC.arbitrary
+        , String <$> arbText
+        , Number <$> arbScientific
+        ]
+
+    | otherwise = QC.oneof
+        [ Object <$> arbObject n
+        , Array <$> arbArray  n
+        ]
+
+arbText :: QC.Gen Text
+arbText = T.pack <$> QC.arbitrary
+
+arbScientific :: QC.Gen Scientific
+arbScientific = Sci.scientific <$> QC.arbitrary <*> QC.arbitrary
+
+shrScientific :: Scientific -> [Scientific]
+shrScientific s = map (uncurry Sci.scientific) $
+    QC.shrink (Sci.coefficient s, Sci.base10Exponent s) 
+
+arbObject :: Int -> QC.Gen Object
+arbObject n = do
+    p <- arbPartition (n - 1)
+    KM.fromList <$> traverse (\m -> (,) <$> QC.arbitrary <*> arbValue m) p
+
+arbArray :: Int -> QC.Gen Array
+arbArray n = do
+    p <- arbPartition (n - 1)
+    V.fromList <$> traverse arbValue p
+
+arbPartition :: Int -> QC.Gen [Int]
+arbPartition k = case compare k 1 of
+    LT -> pure []
+    EQ -> pure [1]
+    GT -> do
+        first <- QC.chooseInt (1, k)
+        rest <- arbPartition $ k - first
+        QC.shuffle (first : rest)
+
 -- |
 --
 -- The ordering is total, consistent with 'Eq' instance.

tests/Instances.hs

@@ -14,19 +14,15 @@ import Prelude.Compat
 import Control.Applicative (empty)
 import Control.Monad
 import Data.Aeson.Types
-import qualified Data.Aeson.KeyMap as KM
 import Data.Function (on)
 import Data.Time (ZonedTime(..), TimeZone(..))
 import Data.Time.Clock (UTCTime(..))
 import Functions
-import Test.QuickCheck (Arbitrary(..), elements,  oneof, sized, Gen, chooseInt, shuffle)
+import Test.QuickCheck (Arbitrary(..), elements,  oneof)
 import Types
-import qualified Data.Aeson.Key as Key
 import qualified Data.DList as DList
-import qualified Data.Vector as V
 import qualified Data.HashMap.Strict as HM
 
-
 import Data.Orphans ()
 import Test.QuickCheck.Instances ()
 
@@ -171,41 +167,3 @@ instance (ApproxEq a) => ApproxEq [a] where
 
 instance Arbitrary a => Arbitrary (DList.DList a) where
     arbitrary = DList.fromList <$> arbitrary
-
-instance Arbitrary Key where
-    arbitrary = Key.fromText <$> arbitrary
-
-instance Arbitrary Value where
-    arbitrary = sized arb where
-        arb :: Int -> Gen Value
-        arb n
-            | n <= 1 = oneof
-                [ return Null
-                , fmap Bool arbitrary
-                , fmap String arbitrary
-                , fmap Number arbitrary
-                ]
-
-            | otherwise = oneof [arr n, obj n]
-
-        arr n = do
-            pars <- arbPartition (n - 1)
-            fmap (Array . V.fromList) (traverse arb pars)
-
-        obj n = do
-            pars <- arbPartition (n - 1)
-            fmap (Object . KM.fromList) (traverse pair pars)
-
-        pair n = do
-            k <- arbitrary
-            v <- arb n
-            return (k, v)
-
-        arbPartition :: Int -> Gen [Int]
-        arbPartition k = case compare k 1 of
-            LT -> pure []
-            EQ -> pure [1]
-            GT -> do
-                first <- chooseInt (1, k)
-                rest <- arbPartition $ k - first
-                shuffle (first : rest)

tests/PropUtils.hs

@@ -26,7 +26,6 @@ import Types
 import Text.Read (readMaybe)
 import qualified Data.Attoparsec.Lazy as L
 import qualified Data.ByteString.Lazy.Char8 as L
-import qualified Data.HashMap.Strict as H
 import qualified Data.Map as Map
 import qualified Data.Text as T
 import qualified Data.Vector as V

tests/Properties.hs

@@ -11,14 +11,15 @@ import Test.QuickCheck (Property)
 import PropUtils
 import PropertyGeneric
 import PropertyKeys
+import PropertyQC
 import PropertyRoundTrip
 import PropertyTH
 
 
 tests :: TestTree
 tests = testGroup "properties" [
-  testGroup "encode" [
-      testProperty "encodeDouble" encodeDouble
+  testGroup "encode"
+    [ testProperty "encodeDouble" encodeDouble
     , testProperty "encodeInteger" encodeInteger
     ]
   , testProperty "read . show = id" roundtripReadShow
@@ -38,4 +39,5 @@ tests = testGroup "properties" [
     ]
   , genericTests
   , templateHaskellTests
+  , quickcheckTests
   ]

tests/PropertyQC.hs

@@ -0,0 +1,28 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+module PropertyQC  (quickcheckTests) where
+
+import Prelude.Compat
+
+import Instances ()
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.QuickCheck (testProperty)
+import Test.QuickCheck (shrink)
+
+import Data.Aeson (Value)
+
+quickcheckTests :: TestTree
+quickcheckTests = testGroup "QuickCheck"
+    [ testProperty "shrink terminates" shrink_prop
+    ]
+
+-- | 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'
+