From 1df02b6577d82537f5723f1712a7369c66fd67d9 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Fri, 19 Feb 2021 00:41:48 +0200 Subject: [PATCH] Fix #837: Stable (in key order) Show Value instance - Add test that read . show roundtrips - Add test that Value To/FromJSON instances roundtrip (as we got Arbitrary Value instance in tests) - Cleanup some doctest looking comments --- aeson.cabal | 4 ++-- changelog.md | 3 +++ src/Data/Aeson/Parser/Internal.hs | 6 ++++- src/Data/Aeson/TH.hs | 5 ++-- src/Data/Aeson/Types/Internal.hs | 27 ++++++++++++++++++++-- tests/Instances.hs | 38 ++++++++++++++++++++++++++++++- tests/PropUtils.hs | 4 ++++ tests/Properties.hs | 1 + tests/PropertyRoundTrip.hs | 3 ++- 9 files changed, 82 insertions(+), 9 deletions(-) diff --git a/aeson.cabal b/aeson.cabal index 4fb712d4e..91eacd7d8 100644 --- a/aeson.cabal +++ b/aeson.cabal @@ -1,5 +1,5 @@ name: aeson -version: 1.5.5.1 +version: 1.5.6.0 license: BSD3 license-file: LICENSE category: Text, Web, JSON @@ -197,7 +197,7 @@ test-suite aeson-tests UnitTests.NullaryConstructors build-depends: - QuickCheck >= 2.10.0.1 && < 2.15, + QuickCheck >= 2.14.2 && < 2.15, aeson, integer-logarithms >= 1 && <1.1, attoparsec, diff --git a/changelog.md b/changelog.md index 94bf0be39..f65c77673 100644 --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,8 @@ For the latest version of this document, please see [https://github.com/bos/aeson/blob/master/changelog.md](https://github.com/bos/aeson/blob/master/changelog.md). +### 1.5.6.0 +* Make `Show Value` instance print object keys in lexicographic order. + ### 1.5.5.1 * Fix a bug in `FromJSON QuarterOfYear` instance. diff --git a/src/Data/Aeson/Parser/Internal.hs b/src/Data/Aeson/Parser/Internal.hs index 9d44abed7..84d08e533 100644 --- a/src/Data/Aeson/Parser/Internal.hs +++ b/src/Data/Aeson/Parser/Internal.hs @@ -72,6 +72,10 @@ import qualified Data.HashMap.Strict as H import qualified Data.Scientific as Sci import Data.Aeson.Parser.Unescape (unescapeText) +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import Data.Aeson.Types + #define BACKSLASH 92 #define CLOSE_CURLY 125 #define CLOSE_SQUARE 93 @@ -260,7 +264,7 @@ jsonNoDup = jsonWith parseListNoDup -- associated values from the original list @kvs@. -- -- >>> fromListAccum [("apple", Bool True), ("apple", Bool False), ("orange", Bool False)] --- fromList [("apple", [Bool False, Bool True]), ("orange", [Bool False])] +-- fromList [("apple",Array [Bool False,Bool True]),("orange",Array [Bool False])] fromListAccum :: [(Text, Value)] -> Object fromListAccum = fmap (Array . Vector.fromList . ($ [])) . H.fromListWith (.) . (fmap . fmap) (:) diff --git a/src/Data/Aeson/TH.hs b/src/Data/Aeson/TH.hs index 3dd63521b..3fb304487 100644 --- a/src/Data/Aeson/TH.hs +++ b/src/Data/Aeson/TH.hs @@ -60,8 +60,9 @@ d = Record { testOne = 3.14159 } @ ->>> fromJSON (toJSON d) == Success d -> True +@ +fromJSON (toJSON d) == Success d +@ This also works for data family instances, but instead of passing in the data family name (with double quotes), we pass in a data family instance diff --git a/src/Data/Aeson/Types/Internal.hs b/src/Data/Aeson/Types/Internal.hs index ac92f987b..60931c387 100644 --- a/src/Data/Aeson/Types/Internal.hs +++ b/src/Data/Aeson/Types/Internal.hs @@ -94,7 +94,8 @@ import Data.Data (Data) import Data.Foldable (foldl') import Data.HashMap.Strict (HashMap) import Data.Hashable (Hashable(..)) -import Data.List (intercalate) +import Data.List (intercalate, sortBy) +import Data.Ord (comparing) import Data.Scientific (Scientific) import Data.String (IsString(..)) import Data.Text (Text, pack, unpack) @@ -110,6 +111,10 @@ import qualified Data.Scientific as S import qualified Data.Vector as V import qualified Language.Haskell.TH.Syntax as TH +-- $setup +-- >>> import qualified Data.HashMap.Strict as H +-- >>> import Data.Aeson + -- | Elements of a JSON path used to describe the location of an -- error. data JSONPathElement = Key Text @@ -362,7 +367,25 @@ data Value = Object !Object | Number !Scientific | Bool !Bool | Null - deriving (Eq, Read, Show, Typeable, Data, Generic) + deriving (Eq, Read, Typeable, Data, Generic) + +-- | Since 1.5.6.0 version object values are printed in lexicographic key order +-- +-- >>> toJSON $ H.fromList [("a", True), ("z", False)] +instance Show Value where + showsPrec _ Null = showString "Null" + showsPrec d (Bool b) = showParen (d > 10) + $ showString "Bool " . showsPrec 11 b + showsPrec d (Number s) = showParen (d > 10) + $ showString "Number " . showsPrec 11 s + showsPrec d (String s) = showParen (d > 10) + $ showString "String " . showsPrec 11 s + showsPrec d (Array xs) = showParen (d > 10) + $ showString "Array " . showsPrec 11 xs + showsPrec d (Object xs) = showParen (d > 10) + $ showString "Object (fromList " + . showsPrec 11 (sortBy (comparing fst) (H.toList xs)) + . showChar ')' -- | -- diff --git a/tests/Instances.hs b/tests/Instances.hs index 8b3cfc441..356a96665 100644 --- a/tests/Instances.hs +++ b/tests/Instances.hs @@ -17,9 +17,10 @@ import Data.Function (on) import Data.Time (ZonedTime(..), TimeZone(..)) import Data.Time.Clock (UTCTime(..)) import Functions -import Test.QuickCheck (Arbitrary(..), elements, oneof) +import Test.QuickCheck (Arbitrary(..), elements, oneof, sized, Gen, chooseInt, shuffle) import Types import qualified Data.DList as DList +import qualified Data.Vector as V import qualified Data.HashMap.Strict as HM import Data.Orphans () @@ -165,3 +166,38 @@ instance (ApproxEq a) => ApproxEq [a] where instance Arbitrary a => Arbitrary (DList.DList a) where arbitrary = DList.fromList <$> 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 . HM.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) diff --git a/tests/PropUtils.hs b/tests/PropUtils.hs index 88c17b408..de997bedf 100644 --- a/tests/PropUtils.hs +++ b/tests/PropUtils.hs @@ -21,6 +21,7 @@ import Encoders import Instances () import Test.QuickCheck (Arbitrary(..), Property, Testable, (===), (.&&.), counterexample) 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 @@ -74,6 +75,9 @@ roundTripNoEnc eq _ i = roundTripEq :: (Eq a, FromJSON a, ToJSON a, Show a) => a -> a -> Property roundTripEq x y = roundTripEnc (===) x y .&&. roundTripNoEnc (===) x y +roundtripReadShow :: Value -> Property +roundtripReadShow v = readMaybe (show v) === Just v + -- We test keys by encoding HashMap and Map with it roundTripKey :: (Ord a, Hashable a, FromJSONKey a, ToJSONKey a, Show a) diff --git a/tests/Properties.hs b/tests/Properties.hs index d457f043b..b5a6940ac 100644 --- a/tests/Properties.hs +++ b/tests/Properties.hs @@ -21,6 +21,7 @@ tests = testGroup "properties" [ testProperty "encodeDouble" encodeDouble , testProperty "encodeInteger" encodeInteger ] + , testProperty "read . show = id" roundtripReadShow , roundTripTests , keysTests , testGroup "toFromJSON" [ diff --git a/tests/PropertyRoundTrip.hs b/tests/PropertyRoundTrip.hs index fc90d169c..025af62e3 100644 --- a/tests/PropertyRoundTrip.hs +++ b/tests/PropertyRoundTrip.hs @@ -37,7 +37,8 @@ import PropertyRTFunctors roundTripTests :: TestTree roundTripTests = testGroup "roundTrip" [ - testProperty "Bool" $ roundTripEq True + testProperty "Value" $ roundTripEq True + , testProperty "Bool" $ roundTripEq True , testProperty "Double" $ roundTripEq (1 :: Approx Double) , testProperty "Int" $ roundTripEq (1 :: Int) , testProperty "NonEmpty Char" $ roundTripEq (undefined :: NonEmpty Char)