Merge pull request #1045 from haskell/nothunks

Produce Value in normal form in D.A.Decoding.

Author: phadej

aeson.cabal

@@ -183,11 +183,13 @@ test-suite aeson-tests
     UnitTests.OptionalFields.Manual
     UnitTests.OptionalFields.TH
     UnitTests.UTCTime
+    UnitTests.NoThunks
 
   build-depends:
       aeson
     , base
     , base-compat
+    , deepseq
     , base-orphans          >=0.5.3  && <0.10
     , base16-bytestring
     , bytestring
@@ -225,6 +227,9 @@ test-suite aeson-tests
     , uuid-types
     , vector
 
+  if impl(ghc >=9.2 && <9.7)
+    build-depends: nothunks >=0.1.4 && <0.2
+
 source-repository head
   type:     git
   location: git://github.com/haskell/aeson.git

benchmarks/aeson-benchmarks.cabal

@@ -26,7 +26,7 @@ library
   default-language: Haskell2010
   build-depends:    base
 
-executable aeson-benchmark-suite
+executable aeson-bench
   default-language: Haskell2010
   main-is:          aeson-benchmark-suite.hs
   hs-source-dirs:   bench examples/src

benchmarks/bench/CompareWithJSON.hs

@@ -47,12 +47,27 @@ decode' :: BL.ByteString -> A.Value
 decode' s = fromMaybe (error "fail to parse via Aeson") $ A.decode' s
 
 decodeS :: BS.ByteString -> A.Value
-decodeS s = fromMaybe (error "fail to parse via Aeson") $ A.decodeStrict' s
+decodeS s = fromMaybe (error "fail to parse via Aeson") $ A.decodeStrict s
+
+decodeS' :: BS.ByteString -> A.Value
+decodeS' s = fromMaybe (error "fail to parse via Aeson") $ A.decodeStrict' s
 
 decodeAtto :: BL.ByteString -> A.Value
 decodeAtto s = fromMaybe (error "fail to parse via Parser.decodeWith") $
     I.decodeWith I.jsonEOF A.fromJSON s
 
+decodeAtto' :: BL.ByteString -> A.Value
+decodeAtto' s = fromMaybe (error "fail to parse via Parser.decodeWith") $
+    I.decodeWith I.jsonEOF' A.fromJSON s
+
+decodeAttoS :: BS.ByteString -> A.Value
+decodeAttoS s = fromMaybe (error "fail to parse via Parser.decodeWith") $
+    I.decodeStrictWith I.jsonEOF A.fromJSON s
+
+decodeAttoS' :: BS.ByteString -> A.Value
+decodeAttoS' s = fromMaybe (error "fail to parse via Parser.decodeWith") $
+    I.decodeStrictWith I.jsonEOF' A.fromJSON s
+
 encodeJ :: J.JSValue -> BL.ByteString
 encodeJ = toLazyByteString . fromString . J.encode
 
@@ -72,17 +87,43 @@ benchmark =
   env (readStr jpFile) $ \jpJ ->
   bgroup "compare-json" [
       bgroup "decode" [
-        bgroup "en" [
-          bench "aeson/lazy"       $ nf decode enA
-        , bench "aeson/strict"     $ nf decode' enA
-        , bench "aeson/stricter"   $ nf decodeS enS
-        , bench "aeson/attoparsec" $ nf decodeAtto enA
-        , bench "json"             $ nf decodeJ enJ
+        bgroup "whnf" [
+          -- Note: we use whnf to only force the outer constructor,
+          -- which may force different amount of value substructure.
+          bench "aeson/normal"      $ whnf decode enA
+        , bench "aeson/normal'"     $ whnf decode' enA
+        , bench "aeson/strict"      $ whnf decodeS enS
+        , bench "aeson/strict'"     $ whnf decodeS' enS
+
+          -- attoparsec-aeson package
+        , bench "aeson/atto"        $ whnf decodeAtto enA
+        , bench "aeson/atto'"       $ whnf decodeAtto' enA
+        , bench "aeson/attoS"       $ whnf decodeAttoS enS
+        , bench "aeson/attoS'"      $ whnf decodeAttoS' enS
+
+          -- json package
+        , bench "json"              $ whnf decodeJ enJ
+        ]
+
+      , bgroup "nf" [
+          bench "aeson/normal"      $ nf decode enA
+        , bench "aeson/normal"      $ nf decode' enA
+        , bench "aeson/strict"      $ nf decodeS enS
+        , bench "aeson/strict'"     $ nf decodeS' enS
+
+          -- attoparsec-aeson package
+        , bench "aeson/atto"        $ nf decodeAtto enA
+        , bench "aeson/atto'"       $ nf decodeAtto' enA
+        , bench "aeson/attoS"       $ nf decodeAttoS enS
+        , bench "aeson/attoS'"      $ nf decodeAttoS' enS
+
+          -- json package
+        , bench "json"              $ nf decodeJ enJ
         ]
       , bgroup "jp" [
-          bench "aeson"          $ nf decode jpA
-        , bench "aeson/stricter" $ nf decodeS jpS
-        , bench "json"           $ nf decodeJ jpJ
+          bench "aeson/normal"      $ whnf decode jpA
+        , bench "aeson/strict"      $ whnf decodeS jpS
+        , bench "json"              $ whnf decodeJ jpJ
         ]
       ]
     , bgroup "encode" [

changelog.md

@@ -26,6 +26,11 @@ For the latest version of this document, please see [https://github.com/haskell/
     [#792](https://github.com/haskell/aeson/issues/792).
 
 * Use `Data.Aeson.Decoding` parsing functions (introduced in version 2.1.2.0) as default in `Data.Aeson`.
+  As one side-effect, `decode` and `decode'` etc pair functions are operationally the same.
+  All variants use an intermediate `Value` in normal form.
+
+  The lazier variant could had `Value` thunks inside `Array` (i.e. `Vector`), but the record had been value strict since version `0.4.0.0` (before that the lazy `Data.Map` was used as `Object`).
+
 * Move `Data.Aeson.Parser` module into separate [`attoparsec-aeson`](https://hackage.haskell.org/package/attoparsec-aeson) package, as these parsers are not used by `aeson` itself anymore.
 * Use [`text-iso8601`](https://hackage.haskell.org/package/text-iso8601) package for parsing `time` types. These are slightly faster than previously used (copy of) `attoparsec-iso8601`.
 * Remove `cffi` flag. Toggling the flag made `aeson` use a C implementation for string unescaping (used for `text <2` versions).

src/Data/Aeson.hs

@@ -221,6 +221,8 @@ decodeStrict' = decodeStrict
 -- If this fails due to incomplete or invalid input, 'Nothing' is
 -- returned.
 --
+-- Since @2.2.0.0@ an alias for 'decodeFileStrict'.
+--
 decodeFileStrict' :: (FromJSON a) => FilePath -> IO (Maybe a)
 decodeFileStrict' = decodeFileStrict
 
@@ -231,22 +233,30 @@ eitherDecodeFileStrict =
 {-# INLINE eitherDecodeFileStrict #-}
 
 -- | Like 'decode'' but returns an error message when decoding fails.
+--
+-- Since @2.2.0.0@ an alias for 'eitherDecode'.
 eitherDecode' :: (FromJSON a) => L.ByteString -> Either String a
 eitherDecode' = eitherDecode
 {-# INLINE eitherDecode' #-}
 
 -- | Like 'decodeStrict'' but returns an error message when decoding fails.
+--
+-- Since @2.2.0.0@ an alias for 'eitherDecodeStrict'.
 eitherDecodeStrict' :: (FromJSON a) => B.ByteString -> Either String a
 eitherDecodeStrict' = eitherDecodeStrict
 {-# INLINE eitherDecodeStrict' #-}
 
 -- | Like 'decodeFileStrict'' but returns an error message when decoding fails.
+--
+-- Since @2.2.0.0@ an alias for 'eitherDecodeFileStrict''.
 eitherDecodeFileStrict' :: (FromJSON a) => FilePath -> IO (Either String a)
 eitherDecodeFileStrict' = eitherDecodeFileStrict
 {-# INLINE eitherDecodeFileStrict' #-}
 
 -- | Like 'decode'' but throws an 'AesonException' when decoding fails.
 --
+-- Since @2.2.0.0@ an alias for 'throwDecode'.
+--
 -- @since 2.1.2.0
 --
 throwDecode' :: forall a m. (FromJSON a, MonadThrow m) => L.ByteString -> m a
@@ -255,6 +265,8 @@ throwDecode' = throwDecode
 
 -- | Like 'decodeStrict'' but throws an 'AesonException' when decoding fails.
 --
+-- Since @2.2.0.0@ an alias for 'throwDecodeStrict'.
+--
 -- @since 2.1.2.0
 --
 throwDecodeStrict' :: forall a m. (FromJSON a, MonadThrow m) => B.ByteString -> m a

src/Data/Aeson/Decoding.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE RankNTypes          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 -- | Convertion to and from @aeson@ 'A.Value'.
+-- 
 module Data.Aeson.Decoding (
     decode,
     eitherDecode,

src/Data/Aeson/Decoding/Conversion.hs

@@ -26,6 +26,10 @@ lbsSpace :: L.ByteString -> Bool
 lbsSpace = L.all (\w -> w == 0x20 || w == 0x0a || w == 0x0d || w == 0x09)
 
 -- | Convert 'Tokens' to 'A.Value'.
+--
+-- The resulting value will be in normal form if its forced.
+-- In other words, there shouldn't be thunks inside.
+--
 toEitherValue
     :: Tokens k e             -- ^ tokens
     -> Either e (A.Value, k)  -- ^ either token error or value and leftover.
@@ -34,43 +38,48 @@ toEitherValue t = unResult (toResultValue t) Left $ \v k -> Right (v, k)
 toResultValue
     :: Tokens k e           -- ^ tokens
     -> Result e k A.Value   -- ^ either token error or value and leftover.
-toResultValue t0 = Result (go t0) where
-    go :: Tokens k e -> (e -> r) -> (A.Value -> k -> r) -> r
-    go (TkLit l k)        _ f = f (lit l) k
-    go (TkText t k)       _ f = f (A.String t) k
-    go (TkNumber n k)     _ f = f (A.Number (num n)) k
-    go (TkArrayOpen arr)  g f = goA 0 id arr g $ \n xs k -> f (A.Array (V.fromListN n xs)) k
-    go (TkRecordOpen rec) g f = goR [] rec g $ \xs k -> f (A.Object (KM.fromList xs)) k
-    go (TkErr e)          g _ = g e
+toResultValue t0 = Result (convert t0)
 
+convert :: Tokens k e -> (e -> r) -> (A.Value -> k -> r) -> r
+convert (TkLit l k)        _ f = f (lit l) k where
     lit :: Lit -> A.Value
     lit LitNull  = A.Null
     lit LitTrue  = A.Bool True
     lit LitFalse = A.Bool False
-
+convert (TkText t k)       _ f = f (A.String t) k
+convert (TkNumber n k)     _ f = f (A.Number (num n)) k where
     num :: Number -> Scientific
-    num (NumInteger n)    = fromInteger n
+    num (NumInteger m)    = fromInteger m
     num (NumDecimal s)    = s
     num (NumScientific s) = s
+convert (TkArrayOpen arr)  g f = convertA arr g $ \xs k -> f (A.Array xs) k
+convert (TkRecordOpen rec) g f = convertR rec g $ \xs k -> f (A.Object xs) k
+convert (TkErr e)          g _ = g e
 
+convertA :: TkArray k e -> (e -> r) -> (A.Array -> k -> r) -> r
+convertA tka err kont = goA 0 id tka err $ \n xs -> kont (V.fromListN n xs) where
     goA :: Int                           -- size accumulator
         -> ([A.Value] -> [A.Value])      -- dlist accumulator
         -> TkArray k e                   -- array tokens
         -> (e -> r)                      -- error continuation
         -> (Int -> [A.Value] -> k -> r)  -- success continuation
         -> r
-    goA !n !acc (TkItem toks)  g f = go toks g $ \v k -> goA (succ n) (acc . (v :)) k g f
+    goA !n !acc (TkItem toks)  g f = convert toks g $ \ !v k -> goA (succ n) (acc . (v :)) k g f
     goA !n !acc (TkArrayEnd k) _ f = f n (acc []) k
     goA !_ !_   (TkArrayErr e) g _ = g e
 
+convertR :: TkRecord k e -> (e -> r) -> (A.Object -> k -> r) -> r
+convertR tkr err kont = goR [] tkr err $ kont . KM.fromList where
     -- we accumulate keys in reverse order
     -- then the first duplicate key in objects wins (as KM.fromList picks last).
     goR :: [(Key, A.Value)]
         -> TkRecord k e
         -> (e -> r)
         -> ([(Key, A.Value)] -> k -> r)
         -> r
-    goR !acc (TkPair t toks) g f = go toks g $ \v k -> goR ((t , v) : acc) k g f
+    -- here we don't stricly need bang on !v as KM is a Strict (in values) map.
+    -- but we force the value sooner.
+    goR !acc (TkPair t toks) g f = convert toks g $ \ !v k -> goR ((t , v) : acc) k g f
     goR !acc (TkRecordEnd k) _ f = f acc k
     goR !_   (TkRecordErr e) g _ = g e
 

tests/UnitTests.hs

@@ -69,6 +69,7 @@ import UnitTests.FromJSONKey
 import UnitTests.Hashable
 import UnitTests.KeyMapInsertWith
 import UnitTests.MonadFix
+import UnitTests.NoThunks
 import UnitTests.NullaryConstructors (nullaryConstructors)
 import UnitTests.OptionalFields (optionalFields)
 import UnitTests.UTCTime
@@ -569,4 +570,5 @@ tests = testGroup "unit" [
   , issue967
   , keyMapInsertWithTests
   , omitNothingFieldsNoteTests
+  , noThunksTests
   ]

tests/UnitTests/NoThunks.hs

@@ -0,0 +1,64 @@
+{-# LANGUAGE BangPatterns      #-}
+{-# LANGUAGE CPP               #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+module UnitTests.NoThunks where
+
+import           Test.Tasty            (TestTree, testGroup)
+
+#if __GLASGOW_HASKELL__ >=902 && __GLASGOW_HASKELL__ <907
+
+import           Data.Maybe            (isNothing)
+import           NoThunks.Class        (NoThunks (..), allNoThunks, noThunksInKeysAndValues)
+import           Test.QuickCheck       (ioProperty)
+import           Test.Tasty.HUnit      (assertFailure, testCase)
+import           Test.Tasty.QuickCheck (testProperty)
+
+import qualified Data.Aeson.Key        as K
+import qualified Data.Aeson.KeyMap     as KM
+import qualified Data.Scientific       as Sci
+
+import           Data.Aeson
+
+noThunksTests :: TestTree
+noThunksTests = testGroup "nothunks"
+    [ testNoThunks "example1" "null"
+    , testNoThunks "example2" "[ 1, 2, 3, true ]"
+    , testNoThunks "example3" "{ \"1\": 1, \"2\": 2 }"
+    , testProperty "property" $ \input -> ioProperty $ do
+        let lbs = encode (input :: Value)
+        !value <- either fail return $ eitherDecode lbs
+        isNothing <$> noThunks [] (value :: Value)
+    ]
+  where
+    testNoThunks name bs = testCase name $ do
+        !value <- either fail return $ eitherDecode bs
+        x <- noThunks [] (value :: Value)
+        case x of
+            Nothing -> return ()
+            Just ti -> assertFailure $ show ti
+
+instance NoThunks Value
+
+instance NoThunks v => NoThunks (KM.KeyMap v) where
+    wNoThunks ctx m = noThunksInKeysAndValues ctx (KM.toList m)
+    showTypeOf _ = "KeyMap"
+
+instance NoThunks K.Key where
+    wNoThunks _ _ = return Nothing
+    showTypeOf _ = "Key"
+
+instance NoThunks Sci.Scientific where
+    wNoThunks ctx s = do
+        let !c = Sci.coefficient s
+        let !e = Sci.base10Exponent s
+        allNoThunks [ wNoThunks ctx c, wNoThunks ctx e ]
+    showTypeOf _ = "Scientific"
+
+#else
+
+-- for other GHCs the test group is empty
+noThunksTests :: TestTree
+noThunksTests = testGroup "nothunks" []
+
+#endif