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

@@ -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,

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.
 

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) (:)

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

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)
@@ -362,7 +363,30 @@ data Value = Object !Object
            | Number !Scientific
            | Bool !Bool
            | Null
-             deriving (Eq, Read, Show, Typeable, Data, Generic)
+             deriving (Eq, Read, Typeable, Data, Generic)
+
+-- | Since version 1.5.6.0 version object values are printed in lexicographic key order
+--
+-- >>> toJSON $ H.fromList [("a", True), ("z", False)]
+-- Object (fromList [("a",Bool True),("z",Bool False)])
+--
+-- >>> toJSON $ H.fromList [("z", False), ("a", True)]
+-- Object (fromList [("a",Bool True),("z",Bool 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 ')'
 
 -- |
 --

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)

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)

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" [

tests/PropertyRoundTrip.hs

@@ -37,7 +37,8 @@ import PropertyRTFunctors
 roundTripTests :: TestTree
 roundTripTests =
   testGroup "roundTrip" [
-      testProperty "Bool" $ roundTripEq True
+      testProperty "Value" $ roundTripEq (undefined :: Value)
+    , testProperty "Bool" $ roundTripEq True
     , testProperty "Double" $ roundTripEq (1 :: Approx Double)
     , testProperty "Int" $ roundTripEq (1 :: Int)
     , testProperty "NonEmpty Char" $ roundTripEq (undefined :: NonEmpty Char)