36331af...master · typeable/aeson

git.iko.soy/typeable/aeson

on master help sign in

.gitignore+1

since splitsnapshots

unifiedsplit

@@ -5,6 +5,7 @@ dist-newstyle

5cabal.sandbox.config

6.stack-work/

7.stack-work-bench/

8+*.yaml.lock

9*.o

10*.o

10*.hi

11*.hi

.travis.yml+34−23

@@ -12,47 +12,58 @@ cache:

12 - $HOME/.stack

13 - $HOME/.cabsnap

14 - $HOME/.cabal/packages

15+ - $HOME/.cabal/store

16before_cache:

17before_cache:

17 - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log

18 - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log

18− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar

19+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.*

20+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json

21+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache

22+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar

23+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx

20matrix:

25matrix:

21 include:

26 include:

27+

22− - env: BUILD=hlint CABALVER=2.2 GHCVER=8.4.3

28+ - env: BUILD=hlint CABALVER=2.2 GHCVER=8.4.4

23− compiler: ": #GHC 8.4.3"

29+ compiler: ": #GHC 8.4.4"

24− addons: {apt: {packages: [cabal-install-2.2,ghc-8.4.3], sources: [hvr-ghc]}}

30+ addons: {apt: {packages: [cabal-install-2.2,ghc-8.4.4], sources: [hvr-ghc]}}

31+

25− - env: BUILD=stack CABALVER=2.2 GHCVER=8.4.3 STACK_YAML=stack-bench.yaml

32+ - env: BUILD=stack CABALVER=2.4 GHCVER=8.6.5 STACK_YAML=stack-bench.yaml

26− compiler: ": #GHC 8.4.3"

33+ compiler: ": #GHC 8.6.5"

27− addons: {apt: {packages: [cabal-install-2.2,ghc-8.4.3], sources: [hvr-ghc]}}

34+ addons: {apt: {packages: [cabal-install-2.4,ghc-8.6.5], sources: [hvr-ghc]}}

35+

28− - env: BUILD=stack CABALVER=2.2 GHCVER=8.4.3 STACK_YAML=stack-ffi-unescape.yaml

36+ - env: BUILD=stack CABALVER=2.2 GHCVER=8.6.5 STACK_YAML=stack-ffi-unescape.yaml

29− compiler: ": #GHC 8.4.3"

37+ compiler: ": #GHC 8.6.5"

30− addons: {apt: {packages: [cabal-install-2.2,ghc-8.4.3], sources: [hvr-ghc]}}

38+ addons: {apt: {packages: [cabal-install-2.2,ghc-8.6.5], sources: [hvr-ghc]}}

31−

39+

40+ - env: BUILD=cabal2 CABALVER=3.0 GHCVER=8.8.1

41+ compiler: ": #GHC 8.8.1"

42+ addons: {apt: {packages: [cabal-install-3.0,ghc-8.8.1], sources: [hvr-ghc]}}

43+

32− - env: BUILD=cabal CABALVER=2.4 GHCVER=8.6.1

44+ - env: BUILD=cabal CABALVER=2.4 GHCVER=8.6.5

33− compiler: ": #GHC 8.6.1"

45+ compiler: ": #GHC 8.6.5"

34− addons: {apt: {packages: [cabal-install-2.4,ghc-8.6.1], sources: [hvr-ghc]}}

46+ addons: {apt: {packages: [cabal-install-2.4,ghc-8.6.5], sources: [hvr-ghc]}}

47+

35− - env: BUILD=cabal CABALVER=2.2 GHCVER=8.4.3

48+ - env: BUILD=cabal CABALVER=2.2 GHCVER=8.4.4

36− compiler: ": #GHC 8.4.3"

49+ compiler: ": #GHC 8.4.4"

37− addons: {apt: {packages: [cabal-install-2.2,ghc-8.4.3], sources: [hvr-ghc]}}

50+ addons: {apt: {packages: [cabal-install-2.2,ghc-8.4.4], sources: [hvr-ghc]}}

51+

38 - env: BUILD=cabal CABALVER=2.0 GHCVER=8.2.2

52 - env: BUILD=cabal CABALVER=2.0 GHCVER=8.2.2

39 compiler: ": #GHC 8.2.2"

53 compiler: ": #GHC 8.2.2"

40 addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.2], sources: [hvr-ghc]}}

54 addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.2], sources: [hvr-ghc]}}

55+

41 - env: BUILD=cabal CABALVER=2.0 GHCVER=8.0.2

56 - env: BUILD=cabal CABALVER=2.0 GHCVER=8.0.2

42 compiler: ": #GHC 8.0.2"

57 compiler: ": #GHC 8.0.2"

43 addons: {apt: {packages: [cabal-install-2.0,ghc-8.0.2], sources: [hvr-ghc]}}

58 addons: {apt: {packages: [cabal-install-2.0,ghc-8.0.2], sources: [hvr-ghc]}}

59+

44 - env: BUILD=cabal CABALVER=1.22 GHCVER=7.10.3

60 - env: BUILD=cabal CABALVER=1.22 GHCVER=7.10.3

45 compiler: ": #GHC 7.10.3"

61 compiler: ": #GHC 7.10.3"

46 addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3], sources: [hvr-ghc]}}

62 addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3], sources: [hvr-ghc]}}

63+

47 - env: BUILD=cabal CABALVER=1.18 GHCVER=7.8.4

64 - env: BUILD=cabal CABALVER=1.18 GHCVER=7.8.4

48 compiler: ": #GHC 7.8.4"

65 compiler: ": #GHC 7.8.4"

49 addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4], sources: [hvr-ghc]}}

66 addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4], sources: [hvr-ghc]}}

50− - env: BUILD=cabal CABALVER=1.18 GHCVER=7.6.3

51− compiler: ": #GHC 7.6.3"

52− addons: {apt: {packages: [cabal-install-1.18,ghc-7.6.3], sources: [hvr-ghc]}}

53− - env: BUILD=cabal CABALVER=1.18 GHCVER=7.4.2

54− compiler: ": #GHC 7.4.2"

55− addons: {apt: {packages: [cabal-install-1.18,ghc-7.4.2], sources: [hvr-ghc]}}

57before_install:

68before_install:

58 - unset CC

69 - unset CC

CONTRIBUTING.md+38

@@ -58,3 +58,41 @@ import Foo as F

58import Qux (Q(..), q)

59import qualified A

60```

61+

62+## Development Workflow (If you plan on using Stack)

63+

64+Here we outline a general workflow new contributors could adopt for a nice incremental development experience.

65+

66+The root folder consists of two stack-*.yaml config files.

67+

68+1. stack-nightly.yaml - Config file defines all the settings to build and test any changes.

69+2. stack-bench.yaml - Used to run benchmark tests.

70+3. stack-ffi-unescape.yaml - This is for replacing certain parts with a C-implementation.

71+

72+Therefore, a ghci development experience would be:

73+

74+1. `stack ghci --stack-yaml stack-nightly.yaml --test`

75+2. :r to recompile

76+3. `main` to run all tests, or `:main --pattern Foo` to run specific tests matched by pattern.

77+

78+Some discussion on this topic can also be found here [here](https://github.com/bos/aeson/issues/733)

79+

80+Of course before submitting a PR, the following steps are recommended:

81+

82+1. 'stack test --stack-yaml stack-nightly.yaml` - Run the entire suite of tests

83+2. `make hlint` - Run hlint on the source folders.

84+3. 'stack test --stack-yaml stack-bench.yaml` - Run the benchmark tests if you believe your changes could affect the benchmarks.

85+

86+## Development Workflow (If you plan on using Cabal)

87+

88+A ghci development experience would be:

89+

90+1. `cabal new-repl test:tests`

91+2. `:r` to recompile

92+3. `Main.main` to run all tests, or `:m Main; :main --pattern Foo` to run specific tests matched by pattern.

93+

94+Of course before submitting a PR, the following steps are recommended:

95+

96+1. `cabal new-test` - Run the entire suite of tests

97+2. `make hlint` - Run hlint on the source folders.

98+3. Uncomment the `benchmarks` line in `cabal.project` - Run the benchmark tests if you believe your changes could affect the benchmarks.

Data/Aeson/Compat.hsdeleted−16

@@ -1,16 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−

3−module Data.Aeson.Compat

4− (

5− fromStrict

6− ) where

7−

8−import qualified Data.ByteString as S

9−import qualified Data.ByteString.Lazy as L

10−

11−fromStrict :: S.ByteString -> L.ByteString

12−#if MIN_VERSION_bytestring(0, 9, 2)

13−fromStrict = L.fromChunks . (:[])

14−#else

15−fromStrict = L.fromStrict

16−#endif

Data/Aeson/TH.hs+24−38

@@ -135,22 +135,15 @@ import Data.Map (Map)

135import Data.Maybe (catMaybes, fromMaybe, mapMaybe)

136import qualified Data.Monoid as Monoid

137import Data.Set (Set)

138−#if MIN_VERSION_template_haskell(2,8,0)

139import Language.Haskell.TH hiding (Arity)

138import Language.Haskell.TH hiding (Arity)

140−#else

141−import Language.Haskell.TH

142−#endif

143import Language.Haskell.TH.Datatype

139import Language.Haskell.TH.Datatype

144−#if MIN_VERSION_template_haskell(2,7,0) && !(MIN_VERSION_template_haskell(2,8,0))

145−import Language.Haskell.TH.Lib (starK)

146−#endif

147#if MIN_VERSION_template_haskell(2,8,0) && !(MIN_VERSION_template_haskell(2,10,0))

140#if MIN_VERSION_template_haskell(2,8,0) && !(MIN_VERSION_template_haskell(2,10,0))

148import Language.Haskell.TH.Syntax (mkNameG_tc)

141import Language.Haskell.TH.Syntax (mkNameG_tc)

149#endif

142#endif

150import Text.Printf (printf)

143import Text.Printf (printf)

151import qualified Data.Aeson.Encoding.Internal as E

144import qualified Data.Aeson.Encoding.Internal as E

152import qualified Data.Foldable as F (all)

145import qualified Data.Foldable as F (all)

153−import qualified Data.HashMap.Strict as H (lookup, toList)

146+import qualified Data.HashMap.Strict as H (difference, fromList, keys, lookup, toList)

154import qualified Data.List.NonEmpty as NE (length, reverse)

147import qualified Data.List.NonEmpty as NE (length, reverse)

155import qualified Data.Map as M (fromList, keys, lookup , singleton, size)

148import qualified Data.Map as M (fromList, keys, lookup , singleton, size)

156import qualified Data.Semigroup as Semigroup (Option(..))

149import qualified Data.Semigroup as Semigroup (Option(..))

@@ -929,12 +922,32 @@ parseRecord :: JSONClass

929 -> Name

922 -> Name

930 -> [Name]

923 -> [Name]

931 -> Name

924 -> Name

925+ -> Bool

932 -> ExpQ

926 -> ExpQ

933−parseRecord jc tvMap argTys opts tName conName fields obj =

927+parseRecord jc tvMap argTys opts tName conName fields obj inTaggedObject =

928+ (if rejectUnknownFields opts

929+ then infixApp checkUnknownRecords [|(>>)|]

930+ else id) $

934 foldl' (\a b -> infixApp a [|(<*>)|] b)

931 foldl' (\a b -> infixApp a [|(<*>)|] b)

935 (infixApp (conE conName) [|(<$>)|] x)

932 (infixApp (conE conName) [|(<$>)|] x)

936 xs

933 xs

937 where

934 where

935+ tagFieldNameAppender =

936+ if inTaggedObject then (tagFieldName (sumEncoding opts) :) else id

937+ knownFields = appE [|H.fromList|] $ listE $

938+ map (\knownName -> tupE [appE [|T.pack|] $ litE $ stringL knownName, [|()|]]) $

939+ tagFieldNameAppender $ map nameBase fields

940+ checkUnknownRecords =

941+ caseE (appE [|H.keys|] $ infixApp (varE obj) [|H.difference|] knownFields)

942+ [ match (listP []) (normalB [|return ()|]) []

943+ , newName "unknownFields" >>=

944+ \unknownFields -> match (varP unknownFields)

945+ (normalB $ appE [|fail|] $ infixApp

946+ (litE (stringL "Unknown fields: "))

947+ [|(++)|]

948+ (appE [|show|] (varE unknownFields)))

949+ []

950+ ]

938 x:xs = [ [|lookupField|]

951 x:xs = [ [|lookupField|]

939 `appE` dispatchParseJSON jc conName tvMap argTy

952 `appE` dispatchParseJSON jc conName tvMap argTy

940 `appE` litE (stringL $ show tName)

953 `appE` litE (stringL $ show tName)

@@ -1009,7 +1022,7 @@ parseArgs jc tvMap tName opts

1009 , constructorFields = argTys }

1022 , constructorFields = argTys }

1010 (Left (_, obj)) = do

1023 (Left (_, obj)) = do

1011 argTys' <- mapM resolveTypeSynonyms argTys

1024 argTys' <- mapM resolveTypeSynonyms argTys

1012− parseRecord jc tvMap argTys' opts tName conName fields obj

1025+ parseRecord jc tvMap argTys' opts tName conName fields obj True

1013parseArgs jc tvMap tName opts

1026parseArgs jc tvMap tName opts

1014 info@ConstructorInfo { constructorName = conName

1027 info@ConstructorInfo { constructorName = conName

1015 , constructorVariant = RecordConstructor fields

1028 , constructorVariant = RecordConstructor fields

@@ -1024,7 +1037,7 @@ parseArgs jc tvMap tName opts

1024 argTys' <- mapM resolveTypeSynonyms argTys

1037 argTys' <- mapM resolveTypeSynonyms argTys

1025 caseE (varE valName)

1038 caseE (varE valName)

1026 [ match (conP 'Object [varP obj]) (normalB $

1039 [ match (conP 'Object [varP obj]) (normalB $

1027− parseRecord jc tvMap argTys' opts tName conName fields obj) []

1040+ parseRecord jc tvMap argTys' opts tName conName fields obj False) []

1028 , matchFailed tName conName "Object"

1041 , matchFailed tName conName "Object"

1029 ]

1042 ]

1030

1043

@@ -1590,21 +1603,13 @@ type TyVarMap = Map Name (Name, Name)

1590-- | Returns True if a Type has kind *.

1603-- | Returns True if a Type has kind *.

1591hasKindStar :: Type -> Bool

1604hasKindStar :: Type -> Bool

1592hasKindStar VarT{} = True

1605hasKindStar VarT{} = True

1593−#if MIN_VERSION_template_haskell(2,8,0)

1594hasKindStar (SigT _ StarT) = True

1606hasKindStar (SigT _ StarT) = True

1595−#else

1596−hasKindStar (SigT _ StarK) = True

1597−#endif

1598hasKindStar _ = False

1607hasKindStar _ = False

1599

1608

1600-- Returns True is a kind is equal to *, or if it is a kind variable.

1609-- Returns True is a kind is equal to *, or if it is a kind variable.

1601isStarOrVar :: Kind -> Bool

1610isStarOrVar :: Kind -> Bool

1602−#if MIN_VERSION_template_haskell(2,8,0)

1603isStarOrVar StarT = True

1611isStarOrVar StarT = True

1604isStarOrVar VarT{} = True

1612isStarOrVar VarT{} = True

1605−#else

1606−isStarOrVar StarK = True

1607−#endif

1608isStarOrVar _ = False

1613isStarOrVar _ = False

1609

1614

1610-- Generate a list of fresh names with a common prefix, and numbered suffixes.

1615-- Generate a list of fresh names with a common prefix, and numbered suffixes.

@@ -1662,9 +1667,7 @@ isTyFamily (ConT n) = do

1662#else

1667#else

1663 FamilyI (FamilyD TypeFam _ _ _) _ -> True

1668 FamilyI (FamilyD TypeFam _ _ _) _ -> True

1664#endif

1669#endif

1665−#if MIN_VERSION_template_haskell(2,9,0)

1666 FamilyI ClosedTypeFamilyD{} _ -> True

1670 FamilyI ClosedTypeFamilyD{} _ -> True

1667−#endif

1668 _ -> False

1671 _ -> False

1669isTyFamily _ = return False

1672isTyFamily _ = return False

1670

1673

@@ -1692,9 +1695,7 @@ mentionsName = go

1692 go :: Type -> [Name] -> Bool

1695 go :: Type -> [Name] -> Bool

1693 go (AppT t1 t2) names = go t1 names || go t2 names

1696 go (AppT t1 t2) names = go t1 names || go t2 names

1694 go (SigT t _k) names = go t names

1697 go (SigT t _k) names = go t names

1695−#if MIN_VERSION_template_haskell(2,8,0)

1696 || go _k names

1698 || go _k names

1697−#endif

1698 go (VarT n) names = n `elem` names

1699 go (VarT n) names = n `elem` names

1699 go _ _ = False

1700 go _ _ = False

1700

1701

@@ -1750,23 +1751,14 @@ uncurryTy t = ([], t :| [])

1750

1751

1751-- | Like uncurryType, except on a kind level.

1752-- | Like uncurryType, except on a kind level.

1752uncurryKind :: Kind -> NonEmpty Kind

1753uncurryKind :: Kind -> NonEmpty Kind

1753−#if MIN_VERSION_template_haskell(2,8,0)

1754uncurryKind = snd . uncurryTy

1755−#else

1756−uncurryKind (ArrowK k1 k2) = k1 <| uncurryKind k2

1757−uncurryKind k = k :| []

1758−#endif

1759

1755

1760createKindChain :: Int -> Kind

1756createKindChain :: Int -> Kind

1761createKindChain = go starK

1757createKindChain = go starK

1762 where

1758 where

1763 go :: Kind -> Int -> Kind

1759 go :: Kind -> Int -> Kind

1764 go k 0 = k

1760 go k 0 = k

1765−#if MIN_VERSION_template_haskell(2,8,0)

1766 go k !n = go (AppT (AppT ArrowT StarT) k) (n - 1)

1761 go k !n = go (AppT (AppT ArrowT StarT) k) (n - 1)

1767−#else

1768− go k !n = go (ArrowK StarK k) (n - 1)

1769−#endif

1770

1762

1771-- | Makes a string literal expression from a constructor's name.

1763-- | Makes a string literal expression from a constructor's name.

1772conNameExp :: Options -> ConstructorInfo -> Q Exp

1764conNameExp :: Options -> ConstructorInfo -> Q Exp

@@ -1820,11 +1812,7 @@ canEtaReduce remaining dropped =

1820-------------------------------------------------------------------------------

1812-------------------------------------------------------------------------------

1821

1813

1822applySubstitutionKind :: Map Name Kind -> Type -> Type

1814applySubstitutionKind :: Map Name Kind -> Type -> Type

1823−#if MIN_VERSION_template_haskell(2,8,0)

1824applySubstitutionKind = applySubstitution

1815applySubstitutionKind = applySubstitution

1825−#else

1826−applySubstitutionKind _ t = t

1827−#endif

1828

1816

1829substNameWithKind :: Name -> Kind -> Type -> Type

1817substNameWithKind :: Name -> Kind -> Type -> Type

1830substNameWithKind n k = applySubstitutionKind (M.singleton n k)

1818substNameWithKind n k = applySubstitutionKind (M.singleton n k)

@@ -1988,9 +1976,7 @@ data StarKindStatus = NotKindStar

1988canRealizeKindStar :: Type -> StarKindStatus

1976canRealizeKindStar :: Type -> StarKindStatus

1989canRealizeKindStar t = case t of

1977canRealizeKindStar t = case t of

1990 _ | hasKindStar t -> KindStar

1978 _ | hasKindStar t -> KindStar

1991−#if MIN_VERSION_template_haskell(2,8,0)

1992 SigT _ (VarT k) -> IsKindVar k

1979 SigT _ (VarT k) -> IsKindVar k

1993−#endif

1994 _ -> NotKindStar

1980 _ -> NotKindStar

1995

1981

1996-- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it exists.

1982-- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it exists.

Data/Aeson/Types.hs+8

@@ -124,6 +124,7 @@ module Data.Aeson.Types

124 , sumEncoding

125 , unwrapUnaryRecords

126 , tagSingleConstructors

127+ , rejectUnknownFields

127

128

128 -- ** Options utilities

129 -- ** Options utilities

129 , SumEncoding(..)

130 , SumEncoding(..)

@@ -136,6 +137,13 @@ module Data.Aeson.Types

136 , JSONKeyOptions

137 , JSONKeyOptions

137 , keyModifier

138 , keyModifier

138 , defaultJSONKeyOptions

139 , defaultJSONKeyOptions

140+

141+ -- * Parsing context

142+ , (<?>)

143+ , JSONPath

144+ , JSONPathElement(..)

145+ , formatPath

146+ , formatRelativePath

139 ) where

147 ) where

140

148

141import Prelude.Compat

149import Prelude.Compat

Data/Aeson/Types/FromJSON.hs+90−66

@@ -7,16 +7,14 @@

7{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE NoImplicitPrelude #-}

9{-# LANGUAGE OverloadedStrings #-}

10+{-# LANGUAGE PolyKinds #-}

10{-# LANGUAGE RecordWildCards #-}

11{-# LANGUAGE RecordWildCards #-}

11{-# LANGUAGE ScopedTypeVariables #-}

12{-# LANGUAGE ScopedTypeVariables #-}

12{-# LANGUAGE TypeOperators #-}

13{-# LANGUAGE TypeOperators #-}

14+{-# LANGUAGE TupleSections #-}

13{-# LANGUAGE UndecidableInstances #-}

15{-# LANGUAGE UndecidableInstances #-}

14{-# LANGUAGE ViewPatterns #-}

16{-# LANGUAGE ViewPatterns #-}

16−#if __GLASGOW_HASKELL__ >= 706

17−{-# LANGUAGE PolyKinds #-}

18−#endif

19−

20#include "incoherent-compat.h"

18#include "incoherent-compat.h"

21#include "overlapping-compat.h"

19#include "overlapping-compat.h"

@@ -120,9 +118,9 @@ import GHC.Generics

120import Numeric.Natural (Natural)

118import Numeric.Natural (Natural)

121import Text.ParserCombinators.ReadP (readP_to_S)

119import Text.ParserCombinators.ReadP (readP_to_S)

122import Unsafe.Coerce (unsafeCoerce)

120import Unsafe.Coerce (unsafeCoerce)

123−import qualified Data.Aeson.Compat as Compat

124import qualified Data.Aeson.Parser.Time as Time

121import qualified Data.Aeson.Parser.Time as Time

125import qualified Data.Attoparsec.ByteString.Char8 as A (endOfInput, parseOnly, scientific)

122import qualified Data.Attoparsec.ByteString.Char8 as A (endOfInput, parseOnly, scientific)

123+import qualified Data.ByteString.Lazy as L

126import qualified Data.DList as DList

124import qualified Data.DList as DList

127import qualified Data.HashMap.Strict as H

125import qualified Data.HashMap.Strict as H

128import qualified Data.HashSet as HashSet

126import qualified Data.HashSet as HashSet

@@ -157,18 +155,8 @@ import qualified Data.Primitive.UnliftedArray as PM

157import qualified Data.Primitive.PrimArray as PM

155import qualified Data.Primitive.PrimArray as PM

158#endif

156#endif

159

157

160−#ifndef HAS_COERCIBLE

161−#define HAS_COERCIBLE (__GLASGOW_HASKELL__ >= 707)

162−#endif

163

158

164−#if HAS_COERCIBLE

165import Data.Coerce (Coercible, coerce)

159import Data.Coerce (Coercible, coerce)

166−coerce' :: Coercible a b => a -> b

167−coerce' = coerce

168−#else

169−coerce' :: a -> b

170−coerce' = unsafeCoerce

171−#endif

172

160

173parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a

161parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a

174parseIndexedJSON p idx value = p value <?> Index idx

162parseIndexedJSON p idx value = p value <?> Index idx

@@ -440,11 +428,7 @@ class FromJSONKey a where

440-- At the moment this type is intentionally not exported. 'FromJSONKeyFunction'

428-- At the moment this type is intentionally not exported. 'FromJSONKeyFunction'

441-- can be inspected, but cannot be constructed.

429-- can be inspected, but cannot be constructed.

442data CoerceText a where

430data CoerceText a where

443−#if HAS_COERCIBLE

444 CoerceText :: Coercible Text a => CoerceText a

431 CoerceText :: Coercible Text a => CoerceText a

445−#else

446− CoerceText :: CoerceText a

447−#endif

448

432

449-- | This type is related to 'ToJSONKeyFunction'. If 'FromJSONKeyValue' is used in the

433-- | This type is related to 'ToJSONKeyFunction'. If 'FromJSONKeyValue' is used in the

450-- 'FromJSONKey' instance, then 'ToJSONKeyValue' should be used in the 'ToJSONKey'

434-- 'FromJSONKey' instance, then 'ToJSONKeyValue' should be used in the 'ToJSONKey'

@@ -464,7 +448,7 @@ data FromJSONKeyFunction a

464

448

465-- | Only law abiding up to interpretation

449-- | Only law abiding up to interpretation

466instance Functor FromJSONKeyFunction where

450instance Functor FromJSONKeyFunction where

467− fmap h (FromJSONKeyCoerce CoerceText) = FromJSONKeyText (h . coerce')

451+ fmap h (FromJSONKeyCoerce CoerceText) = FromJSONKeyText (h . coerce)

468 fmap h (FromJSONKeyText f) = FromJSONKeyText (h . f)

452 fmap h (FromJSONKeyText f) = FromJSONKeyText (h . f)

469 fmap h (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap h . f)

453 fmap h (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap h . f)

470 fmap h (FromJSONKeyValue f) = FromJSONKeyValue (fmap h . f)

454 fmap h (FromJSONKeyValue f) = FromJSONKeyValue (fmap h . f)

@@ -478,9 +462,7 @@ instance Functor FromJSONKeyFunction where

478--

462--

479-- On pre GHC 7.8 this is unconstrainted function.

463-- On pre GHC 7.8 this is unconstrainted function.

480fromJSONKeyCoerce ::

464fromJSONKeyCoerce ::

481−#if HAS_COERCIBLE

482 Coercible Text a =>

465 Coercible Text a =>

483−#endif

484 FromJSONKeyFunction a

466 FromJSONKeyFunction a

485fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText

467fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText

486

468

@@ -488,29 +470,18 @@ fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText

488--

470--

489-- See note on 'fromJSONKeyCoerce'.

471-- See note on 'fromJSONKeyCoerce'.

490coerceFromJSONKeyFunction ::

472coerceFromJSONKeyFunction ::

491−#if HAS_COERCIBLE

492 Coercible a b =>

473 Coercible a b =>

493−#endif

494 FromJSONKeyFunction a -> FromJSONKeyFunction b

474 FromJSONKeyFunction a -> FromJSONKeyFunction b

495−#if HAS_COERCIBLE

496coerceFromJSONKeyFunction = coerce

475coerceFromJSONKeyFunction = coerce

497−#else

498−coerceFromJSONKeyFunction (FromJSONKeyCoerce CoerceText) = FromJSONKeyCoerce CoerceText

499−coerceFromJSONKeyFunction (FromJSONKeyText f) = FromJSONKeyText (coerce' . f)

500−coerceFromJSONKeyFunction (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap coerce' . f)

501−coerceFromJSONKeyFunction (FromJSONKeyValue f) = FromJSONKeyValue (fmap coerce' . f)

502−#endif

503

476

504{-# RULES

477{-# RULES

505 "FromJSONKeyCoerce: fmap id" forall (x :: FromJSONKeyFunction a).

478 "FromJSONKeyCoerce: fmap id" forall (x :: FromJSONKeyFunction a).

506 fmap id x = x

479 fmap id x = x

507 #-}

480 #-}

508−#if HAS_COERCIBLE

509{-# RULES

481{-# RULES

510 "FromJSONKeyCoerce: fmap coerce" forall x .

482 "FromJSONKeyCoerce: fmap coerce" forall x .

511 fmap coerce x = coerceFromJSONKeyFunction x

483 fmap coerce x = coerceFromJSONKeyFunction x

512 #-}

484 #-}

513−#endif

514

485

515-- | Same as 'fmap'. Provided for the consistency with 'ToJSONKeyFunction'.

486-- | Same as 'fmap'. Provided for the consistency with 'ToJSONKeyFunction'.

516mapFromJSONKeyFunction :: (a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b

487mapFromJSONKeyFunction :: (a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b

@@ -797,13 +768,13 @@ withBoundedScientific' f v = withBoundedScientific_ id f v

797-- | A variant of 'withBoundedScientific_' parameterized by a function to apply

768-- | A variant of 'withBoundedScientific_' parameterized by a function to apply

798-- to the 'Parser' in case of failure.

769-- to the 'Parser' in case of failure.

799withBoundedScientific_ :: (Parser a -> Parser a) -> (Scientific -> Parser a) -> Value -> Parser a

770withBoundedScientific_ :: (Parser a -> Parser a) -> (Scientific -> Parser a) -> Value -> Parser a

800−withBoundedScientific_ whenFail f v@(Number scientific) =

771+withBoundedScientific_ whenFail f (Number scientific) =

801− if exponent > 1024

772+ if exp10 > 1024

802 then whenFail (fail msg)

773 then whenFail (fail msg)

803 else f scientific

774 else f scientific

804 where

775 where

805− exponent = base10Exponent scientific

776+ exp10 = base10Exponent scientific

806− msg = "found a number with exponent " ++ show exponent ++ ", but it must not be greater than 1024"

777+ msg = "found a number with exponent " ++ show exp10 ++ ", but it must not be greater than 1024"

807withBoundedScientific_ whenFail _ v =

778withBoundedScientific_ whenFail _ v =

808 whenFail (typeMismatch "Number" v)

779 whenFail (typeMismatch "Number" v)

809{-# INLINE withBoundedScientific_ #-}

780{-# INLINE withBoundedScientific_ #-}

@@ -823,7 +794,7 @@ withBool name _ v = prependContext name (typeMismatch "Boolean" v)

823-- | Decode a nested JSON-encoded string.

794-- | Decode a nested JSON-encoded string.

824withEmbeddedJSON :: String -> (Value -> Parser a) -> Value -> Parser a

795withEmbeddedJSON :: String -> (Value -> Parser a) -> Value -> Parser a

825withEmbeddedJSON _ innerParser (String txt) =

796withEmbeddedJSON _ innerParser (String txt) =

826− either fail innerParser $ eitherDecode (Compat.fromStrict $ T.encodeUtf8 txt)

797+ either fail innerParser $ eitherDecode (L.fromStrict $ T.encodeUtf8 txt)

827 where

798 where

828 eitherDecode = eitherFormatError . eitherDecodeWith jsonEOF ifromJSON

799 eitherDecode = eitherFormatError . eitherDecodeWith jsonEOF ifromJSON

829 eitherFormatError = either (Left . uncurry formatError) Right

800 eitherFormatError = either (Left . uncurry formatError) Right

@@ -892,7 +863,7 @@ parseFieldMaybe' = (.:!)

892-- E.g. @'explicitParseField' 'parseJSON1' :: ('FromJSON1' f, 'FromJSON' a) -> 'Object' -> 'Text' -> 'Parser' (f a)@

863-- E.g. @'explicitParseField' 'parseJSON1' :: ('FromJSON1' f, 'FromJSON' a) -> 'Object' -> 'Text' -> 'Parser' (f a)@

893explicitParseField :: (Value -> Parser a) -> Object -> Text -> Parser a

864explicitParseField :: (Value -> Parser a) -> Object -> Text -> Parser a

894explicitParseField p obj key = case H.lookup key obj of

865explicitParseField p obj key = case H.lookup key obj of

895− Nothing -> fail $ "key " ++ show key ++ " not present"

866+ Nothing -> fail $ "key " ++ show key ++ " not found"

896 Just v -> p v <?> Key key

867 Just v -> p v <?> Key key

897{-# INLINE explicitParseField #-}

868{-# INLINE explicitParseField #-}

898

869

@@ -951,6 +922,16 @@ type ConName = String

951contextType :: TypeName -> Parser a -> Parser a

922contextType :: TypeName -> Parser a -> Parser a

952contextType = prependContext

923contextType = prependContext

953

924

925+-- | Add the tagKey that will be looked up while building an ADT

926+-- | Produce the error equivalent to

927+-- | Left "Error in $: parsing T failed, expected an object with keys "tag" and

928+-- | "contents", where "tag" i-- |s associated to one of ["Foo", "Bar"],

929+-- | The parser returned error was: could not find key "tag"

930+contextTag :: Text -> [String] -> Parser a -> Parser a

931+contextTag tagKey cnames = prependFailure

932+ ("expected Object with key \"" ++ unpack tagKey ++ "\"" ++

933+ " containing one of " ++ show cnames ++ ", ")

934+

954-- | Add the name of the constructor being parsed to a parser's error messages.

935-- | Add the name of the constructor being parsed to a parser's error messages.

955contextCons :: ConName -> TypeName -> Parser a -> Parser a

936contextCons :: ConName -> TypeName -> Parser a -> Parser a

956contextCons cname tname = prependContext (showCons cname tname)

937contextCons cname tname = prependContext (showCons cname tname)

@@ -1129,8 +1110,8 @@ instance ConstructorNames a => ConstructorNames (D1 d a) where

1129 retag (Tagged2 x) = Tagged2 x

1110 retag (Tagged2 x) = Tagged2 x

1130

1111

1131--------------------------------------------------------------------------------

1112--------------------------------------------------------------------------------

1132−

1133−parseNonAllNullarySum :: ( FromPair arity f

1113+parseNonAllNullarySum :: forall f c arity.

1114+ ( FromPair arity f

1134 , FromTaggedObject arity f

1115 , FromTaggedObject arity f

1135 , FromUntaggedValue arity f

1116 , FromUntaggedValue arity f

1136 , ConstructorNames f

1117 , ConstructorNames f

@@ -1140,7 +1121,7 @@ parseNonAllNullarySum p@(tname :* opts :* _) =

1140 case sumEncoding opts of

1121 case sumEncoding opts of

1141 TaggedObject{..} ->

1122 TaggedObject{..} ->

1142 withObject tname $ \obj -> do

1123 withObject tname $ \obj -> do

1143− tag <- contextType tname $ obj .: tagKey

1124+ tag <- contextType tname . contextTag tagKey cnames_ $ obj .: tagKey

1144 fromMaybe (badTag tag <?> Key tagKey) $

1125 fromMaybe (badTag tag <?> Key tagKey) $

1145 parseFromTaggedObject (tag :* contentsFieldName :* p) obj

1126 parseFromTaggedObject (tag :* contentsFieldName :* p) obj

1146 where

1127 where

@@ -1148,6 +1129,7 @@ parseNonAllNullarySum p@(tname :* opts :* _) =

1148 badTag tag = failWith_ $ \cnames ->

1129 badTag tag = failWith_ $ \cnames ->

1149 "expected tag field to be one of " ++ show cnames ++

1130 "expected tag field to be one of " ++ show cnames ++

1150 ", but found tag " ++ show tag

1131 ", but found tag " ++ show tag

1132+ cnames_ = unTagged2 (constructorTags (constructorTagModifier opts) :: Tagged2 f [String])

1151

1133

1152 ObjectWithSingleField ->

1134 ObjectWithSingleField ->

1153 withObject tname $ \obj -> case H.toList obj of

1135 withObject tname $ \obj -> case H.toList obj of

@@ -1219,9 +1201,9 @@ class FromTaggedObject' arity f isRecord where

1219 :: String :* ConName :* TypeName :* Options :* FromArgs arity a

1201 :: String :* ConName :* TypeName :* Options :* FromArgs arity a

1220 -> Object -> Tagged isRecord (Parser (f a))

1202 -> Object -> Tagged isRecord (Parser (f a))

1221

1203

1222−instance (RecordFromJSON arity f) => FromTaggedObject' arity f True where

1204+instance (RecordFromJSON arity f, FieldNames f) => FromTaggedObject' arity f True where

1223 -- Records are unpacked in the tagged object

1205 -- Records are unpacked in the tagged object

1224− parseFromTaggedObject' (_ :* p) = Tagged . recordParseJSON p

1206+ parseFromTaggedObject' (_ :* p) = Tagged . recordParseJSON (True :* p)

1225

1207

1226instance (ConsFromJSON arity f) => FromTaggedObject' arity f False where

1208instance (ConsFromJSON arity f) => FromTaggedObject' arity f False where

1227 -- Nonnullary nonrecords are encoded in the contents field

1209 -- Nonnullary nonrecords are encoded in the contents field

@@ -1262,11 +1244,11 @@ instance OVERLAPPING_

1262 ) => ConsFromJSON' arity (S1 s a) True where

1244 ) => ConsFromJSON' arity (S1 s a) True where

1263 consParseJSON' p@(cname :* tname :* opts :* fargs)

1245 consParseJSON' p@(cname :* tname :* opts :* fargs)

1264 | unwrapUnaryRecords opts = Tagged . fmap M1 . gParseJSON opts fargs

1246 | unwrapUnaryRecords opts = Tagged . fmap M1 . gParseJSON opts fargs

1265− | otherwise = Tagged . withObject (showCons cname tname) (recordParseJSON p)

1247+ | otherwise = Tagged . withObject (showCons cname tname) (recordParseJSON (False :* p))

1266

1248

1267instance RecordFromJSON arity f => ConsFromJSON' arity f True where

1249instance RecordFromJSON arity f => ConsFromJSON' arity f True where

1268 consParseJSON' p@(cname :* tname :* _) =

1250 consParseJSON' p@(cname :* tname :* _) =

1269− Tagged . withObject (showCons cname tname) (recordParseJSON p)

1251+ Tagged . withObject (showCons cname tname) (recordParseJSON (False :* p))

1270

1252

1271instance OVERLAPPING_

1253instance OVERLAPPING_

1272 ConsFromJSON' arity U1 False where

1254 ConsFromJSON' arity U1 False where

@@ -1292,21 +1274,55 @@ instance (ProductFromJSON arity f, ProductSize f

1292

1274

1293--------------------------------------------------------------------------------

1275--------------------------------------------------------------------------------

1294

1276

1277+class FieldNames f where

1278+ fieldNames :: f a -> [Text] -> [Text]

1279+

1280+instance (FieldNames a, FieldNames b) => FieldNames (a :*: b) where

1281+ fieldNames _ =

1282+ fieldNames (undefined :: a x) .

1283+ fieldNames (undefined :: b y)

1284+

1285+instance (Selector s) => FieldNames (S1 s f) where

1286+ fieldNames _ = (pack (selName (undefined :: M1 _i s _f _p)) :)

1287+

1295class RecordFromJSON arity f where

1288class RecordFromJSON arity f where

1296 recordParseJSON

1289 recordParseJSON

1290+ :: Bool :* ConName :* TypeName :* Options :* FromArgs arity a

1291+ -> Object -> Parser (f a)

1292+

1293+instance ( FieldNames f

1294+ , RecordFromJSON' arity f

1295+ ) => RecordFromJSON arity f where

1296+ recordParseJSON (fromTaggedSum :* p@(cname :* tname :* opts :* _)) =

1297+ \obj -> checkUnknown obj >> recordParseJSON' p obj

1298+ where

1299+ knownFields :: H.HashMap Text ()

1300+ knownFields = H.fromList $ map (,()) $

1301+ fieldNames (undefined :: f a)

1302+ [pack (tagFieldName (sumEncoding opts)) | fromTaggedSum]

1303+ checkUnknown =

1304+ if not (rejectUnknownFields opts)

1305+ then \_ -> return ()

1306+ else \obj -> case H.keys (H.difference obj knownFields) of

1307+ [] -> return ()

1308+ unknownFields -> contextCons cname tname $

1309+ fail ("unknown fields: " ++ show unknownFields)

1310+

1311+class RecordFromJSON' arity f where

1312+ recordParseJSON'

1297 :: ConName :* TypeName :* Options :* FromArgs arity a

1313 :: ConName :* TypeName :* Options :* FromArgs arity a

1298 -> Object -> Parser (f a)

1314 -> Object -> Parser (f a)

1299

1315

1300−instance ( RecordFromJSON arity a

1316+instance ( RecordFromJSON' arity a

1301− , RecordFromJSON arity b

1317+ , RecordFromJSON' arity b

1302− ) => RecordFromJSON arity (a :*: b) where

1318+ ) => RecordFromJSON' arity (a :*: b) where

1303− recordParseJSON p obj =

1319+ recordParseJSON' p obj =

1304− (:*:) <$> recordParseJSON p obj

1320+ (:*:) <$> recordParseJSON' p obj

1305− <*> recordParseJSON p obj

1321+ <*> recordParseJSON' p obj

1306

1322

1307instance OVERLAPPABLE_ (Selector s, GFromJSON arity a) =>

1323instance OVERLAPPABLE_ (Selector s, GFromJSON arity a) =>

1308− RecordFromJSON arity (S1 s a) where

1324+ RecordFromJSON' arity (S1 s a) where

1309− recordParseJSON (cname :* tname :* opts :* fargs) obj = do

1325+ recordParseJSON' (cname :* tname :* opts :* fargs) obj = do

1310 fv <- contextCons cname tname (obj .: label)

1326 fv <- contextCons cname tname (obj .: label)

1311 M1 <$> gParseJSON opts fargs fv <?> Key label

1327 M1 <$> gParseJSON opts fargs fv <?> Key label

1312 where

1328 where

@@ -1314,16 +1330,16 @@ instance OVERLAPPABLE_ (Selector s, GFromJSON arity a) =>

1314 sname = selName (undefined :: M1 _i s _f _p)

1330 sname = selName (undefined :: M1 _i s _f _p)

1315

1331

1316instance INCOHERENT_ (Selector s, FromJSON a) =>

1332instance INCOHERENT_ (Selector s, FromJSON a) =>

1317− RecordFromJSON arity (S1 s (K1 i (Maybe a))) where

1333+ RecordFromJSON' arity (S1 s (K1 i (Maybe a))) where

1318− recordParseJSON (_ :* _ :* opts :* _) obj = M1 . K1 <$> obj .:? pack label

1334+ recordParseJSON' (_ :* _ :* opts :* _) obj = M1 . K1 <$> obj .:? pack label

1319 where

1335 where

1320 label = fieldLabelModifier opts sname

1336 label = fieldLabelModifier opts sname

1321 sname = selName (undefined :: M1 _i s _f _p)

1337 sname = selName (undefined :: M1 _i s _f _p)

1322

1338

1323-- Parse an Option like a Maybe.

1339-- Parse an Option like a Maybe.

1324instance INCOHERENT_ (Selector s, FromJSON a) =>

1340instance INCOHERENT_ (Selector s, FromJSON a) =>

1325− RecordFromJSON arity (S1 s (K1 i (Semigroup.Option a))) where

1341+ RecordFromJSON' arity (S1 s (K1 i (Semigroup.Option a))) where

1326− recordParseJSON p obj = wrap <$> recordParseJSON p obj

1342+ recordParseJSON' p obj = wrap <$> recordParseJSON' p obj

1327 where

1343 where

1328 wrap :: S1 s (K1 i (Maybe a)) p -> S1 s (K1 i (Semigroup.Option a)) p

1344 wrap :: S1 s (K1 i (Maybe a)) p -> S1 s (K1 i (Semigroup.Option a)) p

1329 wrap (M1 (K1 a)) = M1 (K1 (Semigroup.Option a))

1345 wrap (M1 (K1 a)) = M1 (K1 (Semigroup.Option a))

@@ -1560,12 +1576,22 @@ instance FromJSONKey Float where

1560 _ -> Scientific.toRealFloat <$> parseScientificText t

1576 _ -> Scientific.toRealFloat <$> parseScientificText t

1561

1577

1562instance (FromJSON a, Integral a) => FromJSON (Ratio a) where

1578instance (FromJSON a, Integral a) => FromJSON (Ratio a) where

1579+ parseJSON (Number x)

1580+ | exp10 <= 1024

1581+ , exp10 >= -1024 = return $! realToFrac x

1582+ | otherwise = prependContext "Ratio" $ fail msg

1583+ where

1584+ exp10 = base10Exponent x

1585+ msg = "found a number with exponent " ++ show exp10

1586+ ++ ", but it must not be greater than 1024 or less than -1024"

1587+ parseJSON o = objParser o

1588+ where

1563− parseJSON = withObject "Rational" $ \obj -> do

1589+ objParser = withObject "Rational" $ \obj -> do

1564− numerator <- obj .: "numerator"

1590+ numerator <- obj .: "numerator"

1565− denominator <- obj .: "denominator"

1591+ denominator <- obj .: "denominator"

1566− if denominator == 0

1592+ if denominator == 0

1567− then fail "Ratio denominator was 0"

1593+ then fail "Ratio denominator was 0"

1568− else pure $ numerator % denominator

1594+ else pure $ numerator % denominator

1569 {-# INLINE parseJSON #-}

1595 {-# INLINE parseJSON #-}

1570

1596

1571-- | This instance includes a bounds check to prevent maliciously

1597-- | This instance includes a bounds check to prevent maliciously

@@ -1980,7 +2006,6 @@ instance FromJSON DotNetTime where

1980-- primitive

2006-- primitive

1981-------------------------------------------------------------------------------

2007-------------------------------------------------------------------------------

1982

2008

1983−#if MIN_VERSION_base(4,7,0)

1984instance FromJSON a => FromJSON (PM.Array a) where

2009instance FromJSON a => FromJSON (PM.Array a) where

1985 -- note: we could do better than this if vector exposed the data

2010 -- note: we could do better than this if vector exposed the data

1986 -- constructor in Data.Vector.

2011 -- constructor in Data.Vector.

@@ -1998,7 +2023,6 @@ instance (PM.PrimUnlifted a,FromJSON a) => FromJSON (PM.UnliftedArray a) where

1998 parseJSON = fmap Exts.fromList . parseJSON

2023 parseJSON = fmap Exts.fromList . parseJSON

1999#endif

2024#endif

2000#endif

2025#endif

2001−#endif

2002

2026

2003-------------------------------------------------------------------------------

2027-------------------------------------------------------------------------------

2004-- time

2028-- time

Data/Aeson/Types/Internal.hs+26−5

@@ -49,6 +49,8 @@ module Data.Aeson.Types.Internal

49 , parserThrowError

50 , parserCatchError

51 , formatError

52+ , formatPath

53+ , formatRelativePath

52 , (<?>)

54 , (<?>)

53 -- * Constructors and accessors

55 -- * Constructors and accessors

54 , object

56 , object

@@ -62,6 +64,7 @@ module Data.Aeson.Types.Internal

62 , sumEncoding

64 , sumEncoding

63 , unwrapUnaryRecords

65 , unwrapUnaryRecords

64 , tagSingleConstructors

66 , tagSingleConstructors

67+ , rejectUnknownFields

65 )

68 )

67 , SumEncoding(..)

70 , SumEncoding(..)

@@ -99,6 +102,7 @@ import Data.Time.Format (FormatTime)

99import Data.Typeable (Typeable)

102import Data.Typeable (Typeable)

100import Data.Vector (Vector)

103import Data.Vector (Vector)

101import GHC.Generics (Generic)

104import GHC.Generics (Generic)

105+import qualified Control.Monad as Monad

102import qualified Control.Monad.Fail as Fail

106import qualified Control.Monad.Fail as Fail

103import qualified Data.HashMap.Strict as H

107import qualified Data.HashMap.Strict as H

104import qualified Data.Scientific as S

108import qualified Data.Scientific as S

@@ -152,7 +156,7 @@ instance Functor Result where

152 fmap _ (Error err) = Error err

156 fmap _ (Error err) = Error err

153 {-# INLINE fmap #-}

157 {-# INLINE fmap #-}

154

158

155−instance Monad IResult where

159+instance Monad.Monad IResult where

156 return = pure

160 return = pure

157 {-# INLINE return #-}

161 {-# INLINE return #-}

158

162

@@ -169,7 +173,7 @@ instance Fail.MonadFail IResult where

169 fail err = IError [] err

173 fail err = IError [] err

170 {-# INLINE fail #-}

174 {-# INLINE fail #-}

171

175

172−instance Monad Result where

176+instance Monad.Monad Result where

173 return = pure

177 return = pure

174 {-# INLINE return #-}

178 {-# INLINE return #-}

175

179

@@ -288,7 +292,7 @@ newtype Parser a = Parser {

288 -> f r

292 -> f r

289 }

293 }

290

294

291−instance Monad Parser where

295+instance Monad.Monad Parser where

292 m >>= g = Parser $ \path kf ks -> let ks' a = runParser (g a) path kf ks

296 m >>= g = Parser $ \path kf ks -> let ks' a = runParser (g a) path kf ks

293 in runParser m path kf ks'

297 in runParser m path kf ks'

294 {-# INLINE (>>=) #-}

298 {-# INLINE (>>=) #-}

@@ -457,7 +461,17 @@ parseEither m v = runParser (m v) [] onError Right

457-- | Annotate an error message with a

461-- | Annotate an error message with a

458-- <http://goessner.net/articles/JsonPath/ JSONPath> error location.

462-- <http://goessner.net/articles/JsonPath/ JSONPath> error location.

459formatError :: JSONPath -> String -> String

463formatError :: JSONPath -> String -> String

460−formatError path msg = "Error in " ++ format "$" path ++ ": " ++ msg

464+formatError path msg = "Error in " ++ formatPath path ++ ": " ++ msg

465+

466+-- | Format a <http://goessner.net/articles/JsonPath/ JSONPath> as a 'String',

467+-- representing the root object as @$@.

468+formatPath :: JSONPath -> String

469+formatPath path = "$" ++ formatRelativePath path

470+

471+-- | Format a <http://goessner.net/articles/JsonPath/ JSONPath> as a 'String'

472+-- which represents the path relative to some root object.

473+formatRelativePath :: JSONPath -> String

474+formatRelativePath path = format "" path

461 where

475 where

462 format :: String -> JSONPath -> String

476 format :: String -> JSONPath -> String

463 format pfx [] = pfx

477 format pfx [] = pfx

@@ -611,10 +625,14 @@ data Options = Options

611 , tagSingleConstructors :: Bool

625 , tagSingleConstructors :: Bool

612 -- ^ Encode types with a single constructor as sums,

626 -- ^ Encode types with a single constructor as sums,

613 -- so that `allNullaryToStringTag` and `sumEncoding` apply.

627 -- so that `allNullaryToStringTag` and `sumEncoding` apply.

628+ , rejectUnknownFields :: Bool

629+ -- ^ Applies only to 'Data.Aeson.FromJSON' instances. If a field appears in

630+ -- the parsed object map, but does not appear in the target object, parsing

631+ -- will fail, with an error message indicating which fields were unknown.

614 }

632 }

615

633

616instance Show Options where

634instance Show Options where

617− show (Options f c a o s u t) =

635+ show (Options f c a o s u t r) =

618 "Options {"

636 "Options {"

619 ++ intercalate ", "

637 ++ intercalate ", "

620 [ "fieldLabelModifier =~ " ++ show (f "exampleField")

638 [ "fieldLabelModifier =~ " ++ show (f "exampleField")

@@ -624,6 +642,7 @@ instance Show Options where

624 , "sumEncoding = " ++ show s

642 , "sumEncoding = " ++ show s

625 , "unwrapUnaryRecords = " ++ show u

643 , "unwrapUnaryRecords = " ++ show u

626 , "tagSingleConstructors = " ++ show t

644 , "tagSingleConstructors = " ++ show t

645+ , "rejectUnknownFields = " ++ show r

627 ]

646 ]

628 ++ "}"

647 ++ "}"

629

648

@@ -705,6 +724,7 @@ data JSONKeyOptions = JSONKeyOptions

705-- , 'sumEncoding' = 'defaultTaggedObject'

724-- , 'sumEncoding' = 'defaultTaggedObject'

706-- , 'unwrapUnaryRecords' = False

725-- , 'unwrapUnaryRecords' = False

707-- , 'tagSingleConstructors' = False

726-- , 'tagSingleConstructors' = False

727+-- , 'rejectUnknownFields' = False

708-- }

728-- }

709-- @

729-- @

710defaultOptions :: Options

730defaultOptions :: Options

@@ -716,6 +736,7 @@ defaultOptions = Options

716 , sumEncoding = defaultTaggedObject

736 , sumEncoding = defaultTaggedObject

717 , unwrapUnaryRecords = False

737 , unwrapUnaryRecords = False

718 , tagSingleConstructors = False

738 , tagSingleConstructors = False

739+ , rejectUnknownFields = False

719 }

740 }

720

741

721-- | Default 'TaggedObject' 'SumEncoding' options:

742-- | Default 'TaggedObject' 'SumEncoding' options:

Data/Aeson/Types/ToJSON.hs+3−42

@@ -8,15 +8,12 @@

8{-# LANGUAGE NoImplicitPrelude #-}

9{-# LANGUAGE OverloadedStrings #-}

10{-# LANGUAGE PatternGuards #-}

11+{-# LANGUAGE PolyKinds #-}

11{-# LANGUAGE RecordWildCards #-}

12{-# LANGUAGE RecordWildCards #-}

12{-# LANGUAGE ScopedTypeVariables #-}

13{-# LANGUAGE ScopedTypeVariables #-}

13{-# LANGUAGE TypeOperators #-}

14{-# LANGUAGE TypeOperators #-}

14{-# LANGUAGE UndecidableInstances #-}

15{-# LANGUAGE UndecidableInstances #-}

16−#if __GLASGOW_HASKELL__ >= 706

17−{-# LANGUAGE PolyKinds #-}

18−#endif

19−

20#include "overlapping-compat.h"

17#include "overlapping-compat.h"

21#include "incoherent-compat.h"

18#include "incoherent-compat.h"

@@ -103,7 +100,6 @@ import GHC.Generics

103import Numeric.Natural (Natural)

100import Numeric.Natural (Natural)

104import qualified Data.Aeson.Encoding as E

101import qualified Data.Aeson.Encoding as E

105import qualified Data.Aeson.Encoding.Internal as E (InArray, comma, econcat, retagEncoding)

102import qualified Data.Aeson.Encoding.Internal as E (InArray, comma, econcat, retagEncoding)

106−import qualified Data.ByteString as S

107import qualified Data.ByteString.Lazy as L

103import qualified Data.ByteString.Lazy as L

108import qualified Data.DList as DList

104import qualified Data.DList as DList

109import qualified Data.HashMap.Strict as H

105import qualified Data.HashMap.Strict as H

@@ -144,14 +140,6 @@ import qualified Data.Primitive.UnliftedArray as PM

144import qualified Data.Primitive.PrimArray as PM

140import qualified Data.Primitive.PrimArray as PM

145#endif

141#endif

146

142

147−#if !(MIN_VERSION_bytestring(0,10,0))

148−import Foreign.ForeignPtr (withForeignPtr)

149−import Foreign.Marshal.Utils (copyBytes)

150−import Foreign.Ptr (plusPtr)

151−import qualified Data.ByteString.Internal as S

152−import qualified Data.ByteString.Lazy.Internal as L

153−#endif

154−

155toJSONPair :: (a -> Value) -> (b -> Value) -> (a, b) -> Value

143toJSONPair :: (a -> Value) -> (b -> Value) -> (a, b) -> Value

156toJSONPair a b = liftToJSON2 a (listValue a) b (listValue b)

144toJSONPair a b = liftToJSON2 a (listValue a) b (listValue b)

157{-# INLINE toJSONPair #-}

145{-# INLINE toJSONPair #-}

@@ -515,7 +503,7 @@ toJSONKeyTextEnc e = ToJSONKeyText tot e

515 -- TODO: dropAround is also used in stringEncoding, which is unfortunate atm

503 -- TODO: dropAround is also used in stringEncoding, which is unfortunate atm

516 tot = T.dropAround (== '"')

504 tot = T.dropAround (== '"')

517 . T.decodeLatin1

505 . T.decodeLatin1

518− . lazyToStrictByteString

506+ . L.toStrict

519 . E.encodingToLazyByteString

507 . E.encodingToLazyByteString

520 . e

508 . e

521

509

@@ -1982,7 +1970,6 @@ formatMillis = take 3 . formatTime defaultTimeLocale "%q"

1982-- primitive

1970-- primitive

1983-------------------------------------------------------------------------------

1971-------------------------------------------------------------------------------

1984

1972

1985−#if MIN_VERSION_base(4,7,0)

1986instance ToJSON a => ToJSON (PM.Array a) where

1973instance ToJSON a => ToJSON (PM.Array a) where

1987 -- note: we could do better than this if vector exposed the data

1974 -- note: we could do better than this if vector exposed the data

1988 -- constructor in Data.Vector.

1975 -- constructor in Data.Vector.

@@ -2004,7 +1991,6 @@ instance (PM.PrimUnlifted a,ToJSON a) => ToJSON (PM.UnliftedArray a) where

2004 toEncoding = toEncoding . Exts.toList

1991 toEncoding = toEncoding . Exts.toList

2005#endif

1992#endif

2006#endif

1993#endif

2007−#endif

2008

1994

2009-------------------------------------------------------------------------------

1995-------------------------------------------------------------------------------

2010-- time

1996-- time

@@ -2054,7 +2040,7 @@ stringEncoding :: Encoding' Text -> Value

2054stringEncoding = String

2040stringEncoding = String

2055 . T.dropAround (== '"')

2041 . T.dropAround (== '"')

2056 . T.decodeLatin1

2042 . T.decodeLatin1

2057− . lazyToStrictByteString

2043+ . L.toStrict

2058 . E.encodingToLazyByteString

2044 . E.encodingToLazyByteString

2059{-# INLINE stringEncoding #-}

2045{-# INLINE stringEncoding #-}

2060

2046

@@ -2861,31 +2847,6 @@ instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g,

2861 toEncoding = toEncoding2

2847 toEncoding = toEncoding2

2862 {-# INLINE toEncoding #-}

2848 {-# INLINE toEncoding #-}

2863

2849

2864−-------------------------------------------------------------------------------

2865−-- pre-bytestring-0.10 compatibility

2866−-------------------------------------------------------------------------------

2867−

2868−{-# INLINE lazyToStrictByteString #-}

2869−lazyToStrictByteString :: L.ByteString -> S.ByteString

2870−#if MIN_VERSION_bytestring(0,10,0)

2871−lazyToStrictByteString = L.toStrict

2872−#else

2873−lazyToStrictByteString = packChunks

2874−

2875−-- packChunks is taken from the blaze-builder package.

2876−

2877−-- | Pack the chunks of a lazy bytestring into a single strict bytestring.

2878−packChunks :: L.ByteString -> S.ByteString

2879−packChunks lbs =

2880− S.unsafeCreate (fromIntegral $ L.length lbs) (copyChunks lbs)

2881− where

2882− copyChunks L.Empty _pf = return ()

2883− copyChunks (L.Chunk (S.PS fpbuf o l) lbs') pf = do

2884− withForeignPtr fpbuf $ \pbuf ->

2885− copyBytes pf (pbuf `plusPtr` o) l

2886− copyChunks lbs' (pf `plusPtr` l)

2887−#endif

2888−

2889--------------------------------------------------------------------------------

2850--------------------------------------------------------------------------------

2890

2851

2891-- | Wrap a list of pairs as an object.

2852-- | Wrap a list of pairs as an object.

aeson.cabal+9−15

@@ -1,5 +1,5 @@

1name: aeson

2−version: 1.4.4.0

2+version: 1.4.6.0

3license: BSD3

4license-file: LICENSE

5category: Text, Web, JSON

@@ -88,7 +88,6 @@ library

88 Data.Aeson.Encode

90 other-modules:

91− Data.Aeson.Compat

92 Data.Aeson.Encoding.Builder

91 Data.Aeson.Encoding.Builder

93 Data.Aeson.Internal.Functions

92 Data.Aeson.Internal.Functions

94 Data.Aeson.Parser.Unescape

93 Data.Aeson.Parser.Unescape

@@ -103,28 +102,23 @@ library

103

102

104 -- GHC bundled libs

103 -- GHC bundled libs

105 build-depends:

104 build-depends:

106− base >= 4.5.0.0 && < 5,

105+ base >= 4.7.0.0 && < 5,

106+ bytestring >= 0.10.4.0 && < 0.11,

107− containers >= 0.4.2.1 && < 0.7,

107+ containers >= 0.5.5.1 && < 0.7,

108 deepseq >= 1.3.0.0 && < 1.5,

109 ghc-prim >= 0.2 && < 0.6,

110− template-haskell >= 2.7.0.0 && < 2.15,

110+ template-haskell >= 2.9.0.0 && < 2.16,

111 text >= 1.2.3.0 && < 1.3,

112− time >= 1.4 && < 1.9

112+ time >= 1.4 && < 1.10

113

114 if impl(ghc >= 8.0)

115 build-depends: bytestring >= 0.10.8.1

116

117 -- Compat

118 build-depends:

119− base-compat >= 0.9.1 && < 0.11,

119+ base-compat >= 0.9.1 && < 0.12,

120 time-compat >= 1.9.2.2 && < 1.10

121

122− if flag(bytestring-builder)

123− build-depends: bytestring >= 0.9.2.1 && < 0.10.4,

124− bytestring-builder >= 0.10.4 && < 1

125− else

126− build-depends: bytestring >= 0.10.4 && < 0.11

127−

128 if !impl(ghc >= 8.6)

122 if !impl(ghc >= 8.6)

129 build-depends:

123 build-depends:

130 contravariant >=1.4.1 && <1.6

124 contravariant >=1.4.1 && <1.6

@@ -225,9 +219,9 @@ test-suite tests

225 containers,

219 containers,

226 directory,

220 directory,

227 dlist,

221 dlist,

228− Diff,

222+ Diff >= 0.4 && < 0.5,

229 filepath,

223 filepath,

230− generic-deriving >= 1.10 && < 1.13,

224+ generic-deriving >= 1.10 && < 1.14,

231 ghc-prim >= 0.2,

225 ghc-prim >= 0.2,

232 hashable >= 1.2.4.0,

226 hashable >= 1.2.4.0,

233 scientific,

227 scientific,

attoparsec-iso8601/Data/Attoparsec/Time/Internal.hs−20

@@ -29,16 +29,8 @@ import Data.Time.Clock (diffTimeToPicoseconds)

30#endif

32−#if MIN_VERSION_base(4,7,0)

33−

34import Data.Fixed (Pico, Fixed(MkFixed))

32import Data.Fixed (Pico, Fixed(MkFixed))

36−#else

37−

38−import Data.Fixed (Pico)

39−

40−#endif

41−

42#if !MIN_VERSION_time(1,6,0)

34#if !MIN_VERSION_time(1,6,0)

44diffTimeToPicoseconds :: DiffTime -> Integer

36diffTimeToPicoseconds :: DiffTime -> Integer

@@ -46,24 +38,12 @@ diffTimeToPicoseconds = unsafeCoerce

47#endif

39#endif

49−#if MIN_VERSION_base(4,7,0)

50−

51toPico :: Integer -> Pico

41toPico :: Integer -> Pico

52toPico = MkFixed

42toPico = MkFixed

54fromPico :: Pico -> Integer

44fromPico :: Pico -> Integer

55fromPico (MkFixed i) = i

45fromPico (MkFixed i) = i

57−#else

58−

59−toPico :: Integer -> Pico

60−toPico = unsafeCoerce

61−

62−fromPico :: Pico -> Integer

63−fromPico = unsafeCoerce

64−

65−#endif

66−

67-- | Like TimeOfDay, but using a fixed-width integer for seconds.

47-- | Like TimeOfDay, but using a fixed-width integer for seconds.

68data TimeOfDay64 = TOD {-# UNPACK #-} !Int

48data TimeOfDay64 = TOD {-# UNPACK #-} !Int

69 {-# UNPACK #-} !Int

49 {-# UNPACK #-} !Int

attoparsec-iso8601/attoparsec-iso8601.cabal+2−2

@@ -36,8 +36,8 @@ library

36 Data.Attoparsec.Time

37 build-depends:

38 attoparsec >= 0.13.0.1,

39− base >= 4.5 && < 5,

39+ base >= 4.7 && < 5,

40− base-compat >= 0.9.1 && < 0.11,

40+ base-compat >= 0.9.1 && < 0.12,

41 text >= 1.1.1.0,

42 time >= 1.1.1.4

benchmarks/AesonEncode.hs+1−1

@@ -7,7 +7,7 @@ module Main (main) where

7import Prelude.Compat

9import Control.DeepSeq

10−import Control.Monad

10+import Control.Monad (forM_)

11import Data.Aeson

12import Data.Attoparsec.ByteString (IResult(..), parseWith)

13import Data.Char (isDigit)

benchmarks/Compare/JsonBench.hs+2−1

@@ -20,6 +20,7 @@ import Data.Aeson ((.:))

20import Data.Monoid ((<>))

21import Data.Text (Text)

22import Typed.Common (load)

23+import qualified Control.Monad.Fail as Fail

23import qualified Data.Aeson as Aeson

24import qualified Data.Aeson as Aeson

24import qualified Data.BufferBuilder.Json as Json

25import qualified Data.BufferBuilder.Json as Json

@@ -82,7 +83,7 @@ genderTable = [("male", Male), ("female", Female)]

82fruitTable :: [(Text, Fruit)]

83fruitTable :: [(Text, Fruit)]

83fruitTable = [("apple", Apple), ("strawberry", Strawberry), ("banana", Banana)]

84fruitTable = [("apple", Apple), ("strawberry", Strawberry), ("banana", Banana)]

85−enumFromJson :: Monad m => String -> [(Text, enum)] -> (json -> m Text) -> json -> m enum

86+enumFromJson :: Fail.MonadFail m => String -> [(Text, enum)] -> (json -> m Text) -> json -> m enum

86enumFromJson enumName table extract v = do

87enumFromJson enumName table extract v = do

87 s <- extract v

88 s <- extract v

88 case lookup s table of

89 case lookup s table of

benchmarks/aeson-benchmarks.cabal−1

@@ -72,7 +72,6 @@ library

73 exposed-modules:

74 Data.Aeson

75− Data.Aeson.Compat

76 Data.Aeson.Encoding

75 Data.Aeson.Encoding

77 Data.Aeson.Encoding.Builder

76 Data.Aeson.Encoding.Builder

78 Data.Aeson.Encoding.Internal

77 Data.Aeson.Encoding.Internal

cabal.project+3−1

@@ -1,3 +1,5 @@

1with-compiler: ghc

2packages: .

3−packages: attoparsec-iso8601, benchmarks

3+packages: attoparsec-iso8601

4+-- packages: benchmarks

5+tests: true

changelog.md+21

@@ -1,5 +1,26 @@

1For 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).

3+### upcoming

5+* `FromJSON` instance of `Ratio a` now parses numbers in addtion to

6+ standard `{numerator=..., denumerator=...}` encoding.

8+### 1.4.6.0

10+* Provide a clearer error message when a required tagKey for a constructor is missing, thanks to Guru Devanla.

11+ The error message now looks like this: `Error in $: parsing Types.SomeType failed, expected Object with key "tag" containing one of ["nullary","unary","product","record","list"], key "tag" not found`

12+

13+* Add `formatPath` and `formatRelativePath` functions to turn a `JSONPath` into a `String`, thanks to Robbie McMichael

14+

15+

16+### 1.4.5.0

17+

18+* Expose `(<?>)`, `JSONPath` and `JSONPathElement(..)` from `Data.Aeson.Types`. Previously only available through internal modules. Thanks to Luke Clifton.

19+

20+* Support for base-compat 0.11, thanks to Ryan Scott.

21+

22+* Travis build for GHC 8.8, thanks to Oleg Grenrus.

23+

3### 1.4.4.0

24### 1.4.4.0

5**New features**:

26**New features**:

stack-bench.yaml+2−8

@@ -1,4 +1,4 @@

1−resolver: lts-12.26

1+resolver: nightly-2019-09-21

2# We use aeson in the snapshot to

3# - avoid recompilation of criterion

4# - compare against it

@@ -9,10 +9,4 @@ resolver: lts-12.26

9work-dir: .stack-work-bench

10packages:

11- benchmarks

12−extra-deps:

12+extra-deps: []

13−- base-orphans-0.8.1

14−- hashable-time-0.2.0.1

15−- QuickCheck-2.13.1

16−- quickcheck-instances-0.3.21

17−- splitmix-0.0.2

18−- time-compat-1.9.2.2

stack-ffi-unescape.yaml+2−7

@@ -1,4 +1,4 @@

1−resolver: lts-12.26

1+resolver: nightly-2019-09-21

2packages:

3- '.'

4flags:

@@ -6,9 +6,4 @@ flags:

6 fast: true

7 cffi: true

8extra-deps:

9−- base-orphans-0.8.1

9+- Diff-0.4.0

10−- hashable-time-0.2.0.1

11−- QuickCheck-2.13.1

12−- quickcheck-instances-0.3.21

13−- splitmix-0.0.2

14−- time-compat-1.9.2.2

stack-nightly.yaml+2−4

@@ -1,4 +1,4 @@

1−resolver: nightly-2019-05-13

1+resolver: nightly-2019-10-14

2packages:

3- '.'

4- attoparsec-iso8601

@@ -8,6 +8,4 @@ flags:

8 attoparsec-iso8601:

9 fast: true

10extra-deps:

11−- hlint-2.1.18

11+- generic-deriving-1.12.4

12−- time-compat-1.9.2.2

13−- quickcheck-instances-0.3.21

tests/Encoders.hs+25−6

@@ -188,7 +188,6 @@ gSomeTypeToEncoding2ElemArray = genericToEncoding opts2ElemArray

188gSomeTypeParseJSON2ElemArray :: Value -> Parser (SomeType Int)

189gSomeTypeParseJSON2ElemArray = genericParseJSON opts2ElemArray

190

191−#if __GLASGOW_HASKELL__ >= 706

192gSomeTypeLiftToEncoding2ElemArray :: LiftToEncoding SomeType a

191gSomeTypeLiftToEncoding2ElemArray :: LiftToEncoding SomeType a

193gSomeTypeLiftToEncoding2ElemArray = genericLiftToEncoding opts2ElemArray

192gSomeTypeLiftToEncoding2ElemArray = genericLiftToEncoding opts2ElemArray

194

193

@@ -197,7 +196,6 @@ gSomeTypeLiftToJSON2ElemArray = genericLiftToJSON opts2ElemArray

197

196

198gSomeTypeLiftParseJSON2ElemArray :: LiftParseJSON SomeType a

197gSomeTypeLiftParseJSON2ElemArray :: LiftParseJSON SomeType a

199gSomeTypeLiftParseJSON2ElemArray = genericLiftParseJSON opts2ElemArray

198gSomeTypeLiftParseJSON2ElemArray = genericLiftParseJSON opts2ElemArray

200−#endif

201

199

202

200

203gSomeTypeToJSONTaggedObject :: SomeType Int -> Value

201gSomeTypeToJSONTaggedObject :: SomeType Int -> Value

@@ -209,7 +207,6 @@ gSomeTypeToEncodingTaggedObject = genericToEncoding optsTaggedObject

209gSomeTypeParseJSONTaggedObject :: Value -> Parser (SomeType Int)

207gSomeTypeParseJSONTaggedObject :: Value -> Parser (SomeType Int)

210gSomeTypeParseJSONTaggedObject = genericParseJSON optsTaggedObject

208gSomeTypeParseJSONTaggedObject = genericParseJSON optsTaggedObject

211

209

212−#if __GLASGOW_HASKELL__ >= 706

213gSomeTypeLiftToEncodingTaggedObject :: LiftToEncoding SomeType a

210gSomeTypeLiftToEncodingTaggedObject :: LiftToEncoding SomeType a

214gSomeTypeLiftToEncodingTaggedObject = genericLiftToEncoding optsTaggedObject

211gSomeTypeLiftToEncodingTaggedObject = genericLiftToEncoding optsTaggedObject

215

212

@@ -218,7 +215,6 @@ gSomeTypeLiftToJSONTaggedObject = genericLiftToJSON optsTaggedObject

218

215

219gSomeTypeLiftParseJSONTaggedObject :: LiftParseJSON SomeType a

216gSomeTypeLiftParseJSONTaggedObject :: LiftParseJSON SomeType a

220gSomeTypeLiftParseJSONTaggedObject = genericLiftParseJSON optsTaggedObject

217gSomeTypeLiftParseJSONTaggedObject = genericLiftParseJSON optsTaggedObject

221−#endif

222

218

223

219

224gSomeTypeToJSONObjectWithSingleField :: SomeType Int -> Value

220gSomeTypeToJSONObjectWithSingleField :: SomeType Int -> Value

@@ -230,7 +226,6 @@ gSomeTypeToEncodingObjectWithSingleField = genericToEncoding optsObjectWithSingl

230gSomeTypeParseJSONObjectWithSingleField :: Value -> Parser (SomeType Int)

226gSomeTypeParseJSONObjectWithSingleField :: Value -> Parser (SomeType Int)

231gSomeTypeParseJSONObjectWithSingleField = genericParseJSON optsObjectWithSingleField

227gSomeTypeParseJSONObjectWithSingleField = genericParseJSON optsObjectWithSingleField

232

228

233−#if __GLASGOW_HASKELL__ >= 706

234gSomeTypeLiftToEncodingObjectWithSingleField :: LiftToEncoding SomeType a

229gSomeTypeLiftToEncodingObjectWithSingleField :: LiftToEncoding SomeType a

235gSomeTypeLiftToEncodingObjectWithSingleField = genericLiftToEncoding optsObjectWithSingleField

230gSomeTypeLiftToEncodingObjectWithSingleField = genericLiftToEncoding optsObjectWithSingleField

236

231

@@ -239,7 +234,6 @@ gSomeTypeLiftToJSONObjectWithSingleField = genericLiftToJSON optsObjectWithSingl

239

234

240gSomeTypeLiftParseJSONObjectWithSingleField :: LiftParseJSON SomeType a

235gSomeTypeLiftParseJSONObjectWithSingleField :: LiftParseJSON SomeType a

241gSomeTypeLiftParseJSONObjectWithSingleField = genericLiftParseJSON optsObjectWithSingleField

236gSomeTypeLiftParseJSONObjectWithSingleField = genericLiftParseJSON optsObjectWithSingleField

242−#endif

243

237

244

238

245gSomeTypeToJSONOmitNothingFields :: SomeType Int -> Value

239gSomeTypeToJSONOmitNothingFields :: SomeType Int -> Value

@@ -249,6 +243,31 @@ gSomeTypeToEncodingOmitNothingFields :: SomeType Int -> Encoding

249gSomeTypeToEncodingOmitNothingFields = genericToEncoding optsOmitNothingFields

243gSomeTypeToEncodingOmitNothingFields = genericToEncoding optsOmitNothingFields

250

244

251

245

246+thSomeTypeParseJSONRejectUnknownFields :: Value -> Parser (SomeType Int)

247+thSomeTypeParseJSONRejectUnknownFields = $(mkParseJSON optsRejectUnknownFields ''SomeType)

248+

249+gSomeTypeParseJSONRejectUnknownFields :: Value -> Parser (SomeType Int)

250+gSomeTypeParseJSONRejectUnknownFields = genericParseJSON optsRejectUnknownFields

251+

252+

253+--------------------------------------------------------------------------------

254+-- Foo decoders

255+--------------------------------------------------------------------------------

256+

257+thFooParseJSONRejectUnknownFields :: Value -> Parser Foo

258+thFooParseJSONRejectUnknownFields = $(mkParseJSON optsRejectUnknownFields ''Foo)

259+

260+gFooParseJSONRejectUnknownFields :: Value -> Parser Foo

261+gFooParseJSONRejectUnknownFields = genericParseJSON optsRejectUnknownFields

262+

263+

264+thFooParseJSONRejectUnknownFieldsTagged :: Value -> Parser Foo

265+thFooParseJSONRejectUnknownFieldsTagged = $(mkParseJSON optsRejectUnknownFieldsTagged ''Foo)

266+

267+gFooParseJSONRejectUnknownFieldsTagged :: Value -> Parser Foo

268+gFooParseJSONRejectUnknownFieldsTagged = genericParseJSON optsRejectUnknownFieldsTagged

269+

270+

252--------------------------------------------------------------------------------

271--------------------------------------------------------------------------------

253-- Option fields

272-- Option fields

254--------------------------------------------------------------------------------

273--------------------------------------------------------------------------------

tests/ErrorMessages.hs+27−1

@@ -13,7 +13,7 @@ import Data.Aeson (FromJSON(..), Value, json)

13import Data.Aeson.Types (Parser)

14import Data.Aeson.Parser (eitherDecodeWith)

15import Data.Aeson.Internal (formatError, iparse)

16−import Data.Algorithm.Diff (Diff(..), getGroupedDiff)

16+import Data.Algorithm.Diff (PolyDiff (..), getGroupedDiff)

17import Data.Proxy (Proxy(..))

18import Data.Semigroup ((<>))

19import Data.Sequence (Seq)

@@ -136,6 +136,29 @@ outputGeneric choice = concat

136 , "[1,"

137 ]

138

139+ , testWithSomeType "SomeType (reject unknown fields)"

140+ (select

141+ thSomeTypeParseJSONRejectUnknownFields

142+ gSomeTypeParseJSONRejectUnknownFields)

143+ [ "{\"tag\": \"record\", \"testOne\": 1.0, \"testZero\": 1}"

144+ , "{\"testZero\": 1}"

145+ , "{\"tag\": \"record\", \"testone\": true, \"testtwo\": null, \"testthree\": null}"

146+ ]

147+

148+ , testWithFoo "Foo (reject unknown fields)"

149+ (select

150+ thFooParseJSONRejectUnknownFields

151+ gFooParseJSONRejectUnknownFields)

152+ [ "{\"tag\": \"foo\"}"

153+ ]

154+

155+ , testWithFoo "Foo (reject unknown fields, tagged single)"

156+ (select

157+ thFooParseJSONRejectUnknownFieldsTagged

158+ gFooParseJSONRejectUnknownFieldsTagged)

159+ [ "{\"tag\": \"foo\", \"unknownField\": 0}"

160+ ]

161+

139 , testWith "EitherTextInt"

162 , testWith "EitherTextInt"

140 (select

163 (select

141 thEitherTextIntParseJSONUntaggedValue

164 thEitherTextIntParseJSONUntaggedValue

@@ -196,3 +219,6 @@ testFor name _ = testWith name (parseJSON :: Value -> Parser a)

196

219

197testWithSomeType :: String -> (Value -> Parser (SomeType Int)) -> [L.ByteString] -> Output

220testWithSomeType :: String -> (Value -> Parser (SomeType Int)) -> [L.ByteString] -> Output

198testWithSomeType = testWith

221testWithSomeType = testWith

222+

223+testWithFoo :: String -> (Value -> Parser Foo) -> [L.ByteString] -> Output

224+testWithFoo = testWith

tests/Instances.hs+1−4

@@ -1,4 +1,3 @@

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE FlexibleContexts #-}

1{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleInstances #-}

2{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE NoImplicitPrelude #-}

3{-# LANGUAGE NoImplicitPrelude #-}

@@ -25,14 +24,12 @@ import qualified Data.HashMap.Strict as HM

26import Data.Orphans ()

25import Data.Orphans ()

27import Test.QuickCheck.Instances ()

26import Test.QuickCheck.Instances ()

28−#if MIN_VERSION_base(4,7,0)

29import Data.Hashable.Time ()

27import Data.Hashable.Time ()

30−#endif

32-- "System" types.

29-- "System" types.

34instance Arbitrary DotNetTime where

31instance Arbitrary DotNetTime where

35− arbitrary = DotNetTime `liftM` arbitrary

32+ arbitrary = DotNetTime `fmap` arbitrary

36 shrink = map DotNetTime . shrink . fromDotNetTime

33 shrink = map DotNetTime . shrink . fromDotNetTime

38-- | Compare timezone part only on 'timeZoneMinutes'

35-- | Compare timezone part only on 'timeZoneMinutes'

tests/Options.hs+11

@@ -55,3 +55,14 @@ optsOptionField = optsDefault

55 { fieldLabelModifier = const "field"

56 , omitNothingFields = True

57 }

58+

59+optsRejectUnknownFields :: Options

60+optsRejectUnknownFields = optsDefault

61+ { rejectUnknownFields = True

62+ }

63+

64+optsRejectUnknownFieldsTagged :: Options

65+optsRejectUnknownFieldsTagged = optsDefault

66+ { rejectUnknownFields = True

67+ , tagSingleConstructors = True

68+ }

tests/PropertyGeneric.hs−8

@@ -44,11 +44,9 @@ genericTests =

44 , testProperty "TaggedObject" (toParseJSON gSomeTypeParseJSONTaggedObject gSomeTypeToJSONTaggedObject)

45 , testProperty "ObjectWithSingleField" (toParseJSON gSomeTypeParseJSONObjectWithSingleField gSomeTypeToJSONObjectWithSingleField)

47−#if __GLASGOW_HASKELL__ >= 706

48 , testProperty "2ElemArray unary" (toParseJSON1 gSomeTypeLiftParseJSON2ElemArray gSomeTypeLiftToJSON2ElemArray)

47 , testProperty "2ElemArray unary" (toParseJSON1 gSomeTypeLiftParseJSON2ElemArray gSomeTypeLiftToJSON2ElemArray)

49 , testProperty "TaggedObject unary" (toParseJSON1 gSomeTypeLiftParseJSONTaggedObject gSomeTypeLiftToJSONTaggedObject)

48 , testProperty "TaggedObject unary" (toParseJSON1 gSomeTypeLiftParseJSONTaggedObject gSomeTypeLiftToJSONTaggedObject)

50 , testProperty "ObjectWithSingleField unary" (toParseJSON1 gSomeTypeLiftParseJSONObjectWithSingleField gSomeTypeLiftToJSONObjectWithSingleField)

49 , testProperty "ObjectWithSingleField unary" (toParseJSON1 gSomeTypeLiftParseJSONObjectWithSingleField gSomeTypeLiftToJSONObjectWithSingleField)

51−#endif

52 ]

50 ]

53 ]

51 ]

54 , testGroup "OneConstructor" [

52 , testGroup "OneConstructor" [

@@ -85,30 +83,24 @@ genericTests =

86 , testProperty "SomeType2ElemArray" $

84 , testProperty "SomeType2ElemArray" $

87 gSomeTypeToJSON2ElemArray `sameAs` gSomeTypeToEncoding2ElemArray

85 gSomeTypeToJSON2ElemArray `sameAs` gSomeTypeToEncoding2ElemArray

88−#if __GLASGOW_HASKELL__ >= 706

89 , testProperty "SomeType2ElemArray unary" $

86 , testProperty "SomeType2ElemArray unary" $

90 gSomeTypeLiftToJSON2ElemArray `sameAs1` gSomeTypeLiftToEncoding2ElemArray

87 gSomeTypeLiftToJSON2ElemArray `sameAs1` gSomeTypeLiftToEncoding2ElemArray

91 , testProperty "SomeType2ElemArray unary agree" $

88 , testProperty "SomeType2ElemArray unary agree" $

92 gSomeTypeToEncoding2ElemArray `sameAs1Agree` gSomeTypeLiftToEncoding2ElemArray

89 gSomeTypeToEncoding2ElemArray `sameAs1Agree` gSomeTypeLiftToEncoding2ElemArray

93−#endif

95 , testProperty "SomeTypeTaggedObject" $

91 , testProperty "SomeTypeTaggedObject" $

96 gSomeTypeToJSONTaggedObject `sameAs` gSomeTypeToEncodingTaggedObject

92 gSomeTypeToJSONTaggedObject `sameAs` gSomeTypeToEncodingTaggedObject

97−#if __GLASGOW_HASKELL__ >= 706

98 , testProperty "SomeTypeTaggedObject unary" $

93 , testProperty "SomeTypeTaggedObject unary" $

99 gSomeTypeLiftToJSONTaggedObject `sameAs1` gSomeTypeLiftToEncodingTaggedObject

94 gSomeTypeLiftToJSONTaggedObject `sameAs1` gSomeTypeLiftToEncodingTaggedObject

100 , testProperty "SomeTypeTaggedObject unary agree" $

95 , testProperty "SomeTypeTaggedObject unary agree" $

101 gSomeTypeToEncodingTaggedObject `sameAs1Agree` gSomeTypeLiftToEncodingTaggedObject

96 gSomeTypeToEncodingTaggedObject `sameAs1Agree` gSomeTypeLiftToEncodingTaggedObject

102−#endif

103

104 , testProperty "SomeTypeObjectWithSingleField" $

98 , testProperty "SomeTypeObjectWithSingleField" $

105 gSomeTypeToJSONObjectWithSingleField `sameAs` gSomeTypeToEncodingObjectWithSingleField

99 gSomeTypeToJSONObjectWithSingleField `sameAs` gSomeTypeToEncodingObjectWithSingleField

106−#if __GLASGOW_HASKELL__ >= 706

107 , testProperty "SomeTypeObjectWithSingleField unary" $

100 , testProperty "SomeTypeObjectWithSingleField unary" $

108 gSomeTypeLiftToJSONObjectWithSingleField `sameAs1` gSomeTypeLiftToEncodingObjectWithSingleField

101 gSomeTypeLiftToJSONObjectWithSingleField `sameAs1` gSomeTypeLiftToEncodingObjectWithSingleField

109 , testProperty "SomeTypeObjectWithSingleField unary agree" $

102 , testProperty "SomeTypeObjectWithSingleField unary agree" $

110 gSomeTypeToEncodingObjectWithSingleField `sameAs1Agree` gSomeTypeLiftToEncodingObjectWithSingleField

103 gSomeTypeToEncodingObjectWithSingleField `sameAs1Agree` gSomeTypeLiftToEncodingObjectWithSingleField

111−#endif

112

104

113 , testProperty "SomeTypeOmitNothingFields" $

105 , testProperty "SomeTypeOmitNothingFields" $

114 gSomeTypeToJSONOmitNothingFields `sameAs` gSomeTypeToEncodingOmitNothingFields

106 gSomeTypeToJSONOmitNothingFields `sameAs` gSomeTypeToEncodingOmitNothingFields

tests/PropertyKeys.hs−3

@@ -1,4 +1,3 @@

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE NoImplicitPrelude #-}

1{-# LANGUAGE NoImplicitPrelude #-}

4module PropertyKeys ( keysTests ) where

3module PropertyKeys ( keysTests ) where

@@ -31,12 +30,10 @@ keysTests =

31 , testProperty "Natural" $ roundTripKey (undefined :: Natural)

30 , testProperty "Natural" $ roundTripKey (undefined :: Natural)

32 , testProperty "Float" $ roundTripKey (undefined :: Float)

31 , testProperty "Float" $ roundTripKey (undefined :: Float)

33 , testProperty "Double" $ roundTripKey (undefined :: Double)

32 , testProperty "Double" $ roundTripKey (undefined :: Double)

34−#if MIN_VERSION_base(4,7,0)

35 , testProperty "Day" $ roundTripKey (undefined :: Day)

33 , testProperty "Day" $ roundTripKey (undefined :: Day)

36 , testProperty "LocalTime" $ roundTripKey (undefined :: LocalTime)

34 , testProperty "LocalTime" $ roundTripKey (undefined :: LocalTime)

37 , testProperty "TimeOfDay" $ roundTripKey (undefined :: TimeOfDay)

35 , testProperty "TimeOfDay" $ roundTripKey (undefined :: TimeOfDay)

38 , testProperty "UTCTime" $ roundTripKey (undefined :: UTCTime)

36 , testProperty "UTCTime" $ roundTripKey (undefined :: UTCTime)

39−#endif

40 , testProperty "Version" $ roundTripKey (undefined :: Version)

37 , testProperty "Version" $ roundTripKey (undefined :: Version)

41 , testProperty "Lazy Text" $ roundTripKey (undefined :: LT.Text)

38 , testProperty "Lazy Text" $ roundTripKey (undefined :: LT.Text)

42 , testProperty "UUID" $ roundTripKey UUID.nil

39 , testProperty "UUID" $ roundTripKey UUID.nil

tests/SerializationFormatSpec.hs−4

@@ -3,9 +3,7 @@

3{-# LANGUAGE GADTs #-}

4{-# LANGUAGE NoImplicitPrelude #-}

5{-# LANGUAGE OverloadedStrings #-}

6−#if __GLASGOW_HASKELL__ >= 708

7{-# LANGUAGE DataKinds #-}

6{-# LANGUAGE DataKinds #-}

8−#endif

10------------------------------------------------------------------------------

8------------------------------------------------------------------------------

11-- These tests assert that the JSON serialization doesn't change by accident.

9-- These tests assert that the JSON serialization doesn't change by accident.

@@ -77,10 +75,8 @@ jsonExamples =

77 , example "Just" "1" (Just 1 :: Maybe Int)

75 , example "Just" "1" (Just 1 :: Maybe Int)

78 , example "Proxy Int" "null" (Proxy :: Proxy Int)

76 , example "Proxy Int" "null" (Proxy :: Proxy Int)

79 , example "Tagged Char Int" "1" (Tagged 1 :: Tagged Char Int)

77 , example "Tagged Char Int" "1" (Tagged 1 :: Tagged Char Int)

80−#if __GLASGOW_HASKELL__ >= 708

81 -- Test Tagged instance is polykinded

78 -- Test Tagged instance is polykinded

82 , example "Tagged 123 Int" "1" (Tagged 1 :: Tagged 123 Int)

79 , example "Tagged 123 Int" "1" (Tagged 1 :: Tagged 123 Int)

83−#endif

84 , example "Const Char Int" "\"c\"" (Const 'c' :: Const Char Int)

80 , example "Const Char Int" "\"c\"" (Const 'c' :: Const Char Int)

85 , example "Tuple" "[1,2]" ((1, 2) :: (Int, Int))

81 , example "Tuple" "[1,2]" ((1, 2) :: (Int, Int))

86 , example "NonEmpty" "[1,2,3]" (1 :| [2, 3] :: NonEmpty Int)

82 , example "NonEmpty" "[1,2,3]" (1 :| [2, 3] :: NonEmpty Int)

tests/Types.hs−2

@@ -119,9 +119,7 @@ deriving instance Generic (Sum4 a b c d)

119deriving instance Generic (Approx a)

120deriving instance Generic Nullary

121deriving instance Generic (SomeType a)

122−#if __GLASGOW_HASKELL__ >= 706

123deriving instance Generic1 SomeType

122deriving instance Generic1 SomeType

124−#endif

125deriving instance Generic OptionField

123deriving instance Generic OptionField

126deriving instance Generic EitherTextInt

124deriving instance Generic EitherTextInt

127

125

tests/UnitTests.hs+118−3

@@ -33,14 +33,15 @@ import Data.Aeson.Parser

33 ( json, jsonLast, jsonAccum, jsonNoDup

34 , json', jsonLast', jsonAccum', jsonNoDup')

35import Data.Aeson.Types

36− ( Options(..), Result(Success), ToJSON(..), Value(Array, Bool, Null, Object)

36+ ( Options(..), Result(Success, Error), ToJSON(..)

37+ , Value(Array, Bool, Null, Number, Object, String), camelTo, camelTo2

37− , camelTo, camelTo2, defaultOptions, omitNothingFields, parse)

38+ , defaultOptions, formatPath, formatRelativePath, omitNothingFields, parse)

38import Data.Attoparsec.ByteString (Parser, parseOnly)

39import Data.Attoparsec.ByteString (Parser, parseOnly)

39import Data.Char (toUpper)

40import Data.Char (toUpper)

40import Data.Either.Compat (isLeft, isRight)

41import Data.Either.Compat (isLeft, isRight)

41import Data.Hashable (hash)

42import Data.Hashable (hash)

42import Data.HashMap.Strict (HashMap)

43import Data.HashMap.Strict (HashMap)

43−import Data.List (sort)

44+import Data.List (sort, isSuffixOf)

44import Data.Maybe (fromMaybe)

45import Data.Maybe (fromMaybe)

45import Data.Scientific (Scientific, scientific)

46import Data.Scientific (Scientific, scientific)

46import Data.Tagged (Tagged(..))

47import Data.Tagged (Tagged(..))

@@ -111,8 +112,12 @@ tests = testGroup "unit" [

111 , testGroup "SingleMaybeField" singleMaybeField

112 , testGroup "SingleMaybeField" singleMaybeField

112 , testCase "withEmbeddedJSON" withEmbeddedJSONTest

113 , testCase "withEmbeddedJSON" withEmbeddedJSONTest

113 , testCase "SingleFieldCon" singleFieldCon

114 , testCase "SingleFieldCon" singleFieldCon

115+ , testGroup "UnknownFields" unknownFields

114 , testGroup "Ordering of object keys" keyOrdering

116 , testGroup "Ordering of object keys" keyOrdering

115 , testCase "Ratio with denominator 0" ratioDenominator0

117 , testCase "Ratio with denominator 0" ratioDenominator0

118+ , testCase "Rational parses number" rationalNumber

119+ , testCase "Big rational" bigRationalDecoding

120+ , testCase "Small rational" smallRationalDecoding

116 , testCase "Big scientific exponent" bigScientificExponent

121 , testCase "Big scientific exponent" bigScientificExponent

117 , testCase "Big integer decoding" bigIntegerDecoding

122 , testCase "Big integer decoding" bigIntegerDecoding

118 , testCase "Big natural decading" bigNaturalDecoding

123 , testCase "Big natural decading" bigNaturalDecoding

@@ -253,6 +258,18 @@ formatErrorExample =

253 lhs = "Error in $[0].foo.bar['a.b.c']['']['\\'\\\\'].end: error msg"

258 lhs = "Error in $[0].foo.bar['a.b.c']['']['\\'\\\\'].end: error msg"

254 in assertEqual "formatError example" lhs rhs

259 in assertEqual "formatError example" lhs rhs

255

260

261+formatPathExample :: Assertion

262+formatPathExample =

263+ let rhs = formatPath [Key "x", Index 0]

264+ lhs = "$.x[0]"

265+ in assertEqual "formatPath example" lhs rhs

266+

267+formatRelativePathExample :: Assertion

268+formatRelativePathExample =

269+ let rhs = formatPath [Key "x", Index 0]

270+ lhs = ".x[0]"

271+ in assertEqual "formatRelativePath example" lhs rhs

272+

256------------------------------------------------------------------------------

273------------------------------------------------------------------------------

257-- Comparison (.:?) and (.:!)

274-- Comparison (.:?) and (.:!)

258------------------------------------------------------------------------------

275------------------------------------------------------------------------------

@@ -523,6 +540,7 @@ showOptions =

523 ++ ", sumEncoding = TaggedObject {tagFieldName = \"tag\", contentsFieldName = \"contents\"}"

540 ++ ", sumEncoding = TaggedObject {tagFieldName = \"tag\", contentsFieldName = \"contents\"}"

524 ++ ", unwrapUnaryRecords = False"

541 ++ ", unwrapUnaryRecords = False"

525 ++ ", tagSingleConstructors = False"

542 ++ ", tagSingleConstructors = False"

543+ ++ ", rejectUnknownFields = False"

526 ++ "}")

544 ++ "}")

527 (show defaultOptions)

545 (show defaultOptions)

528

546

@@ -567,6 +585,79 @@ singleFieldCon :: Assertion

567singleFieldCon =

585singleFieldCon =

568 assertEqual "fromJSON" (Right (SingleFieldCon 0)) (eitherDecode "0")

586 assertEqual "fromJSON" (Right (SingleFieldCon 0)) (eitherDecode "0")

569

587

588+newtype UnknownFields = UnknownFields { knownField :: Int }

589+ deriving (Eq, Show, Generic)

590+newtype UnknownFieldsTag = UnknownFieldsTag { tag :: Int }

591+ deriving (Eq, Show, Generic)

592+newtype UnknownFieldsUnaryTagged = UnknownFieldsUnaryTagged { knownFieldUnaryTagged :: Int }

593+ deriving (Eq, Show, Generic)

594+data UnknownFieldsSum

595+ = UnknownFields1 { knownField1 :: Int }

596+ | UnknownFields2 { knownField2 :: Int }

597+ deriving (Eq, Show, Generic)

598+

599+unknownFields :: [TestTree]

600+unknownFields = concat

601+ [ testsUnary

602+ "unary-unknown"

603+ (object [("knownField", Number 1), ("unknownField", Number 1)])

604+ (Error "nknown fields: [\"unknownField\"]" :: Result UnknownFields)

605+ , testsUnary

606+ "unary-unknown-tag"

607+ (object [("knownField", Number 1), ("tag", String "UnknownFields")])

608+ (Error "nknown fields: [\"tag\"]" :: Result UnknownFields)

609+ , testsUnaryTag

610+ "unary-explicit-tag"

611+ (object [("tag", Number 1)])

612+ (Success $ UnknownFieldsTag 1)

613+ , testsSum

614+ "sum-tag"

615+ (object [("knownField1", Number 1), ("tag", String "UnknownFields1")])

616+ (Success $ UnknownFields1 1)

617+ , testsSum

618+ "sum-unknown-in-branch"

619+ (object [("knownField1", Number 1), ("knownField2", Number 1), ("tag", String "UnknownFields1")])

620+ (Error "nknown fields: [\"knownField2\"]" :: Result UnknownFieldsSum)

621+ , testsSum

622+ "sum-unknown"

623+ (object [("knownField1", Number 1), ("unknownField", Number 1), ("tag", String "UnknownFields1")])

624+ (Error "nknown fields: [\"unknownField\"]" :: Result UnknownFieldsSum)

625+ , testsTagged

626+ "unary-tagged"

627+ (object [("knownFieldUnaryTagged", Number 1), ("tag", String "UnknownFieldsUnaryTagged")])

628+ (Success $ UnknownFieldsUnaryTagged 1)

629+ , -- Just a case to verify that the tag isn't optional, this is likely already tested by other unit tests

630+ testsTagged

631+ "unary-tagged-notag"

632+ (object [("knownFieldUnaryTagged", Number 1)])

633+ (Error "key \"tag\" not found" :: Result UnknownFieldsUnaryTagged)

634+ , testsTagged

635+ "unary-tagged-unknown"

636+ (object [ ("knownFieldUnaryTagged", Number 1), ("unknownField", Number 1)

637+ , ("tag", String "UnknownFieldsUnaryTagged")])

638+ (Error "nknown fields: [\"unknownField\"]" :: Result UnknownFieldsUnaryTagged)

639+ ]

640+ where

641+ opts = defaultOptions{rejectUnknownFields=True}

642+ taggedOpts = opts{tagSingleConstructors=True}

643+ assertApprox :: (Show a, Eq a) => Result a -> Result a -> IO ()

644+ assertApprox (Error expected) (Error actual) | expected `isSuffixOf` actual = return ()

645+ assertApprox expected actual = assertEqual "fromJSON" expected actual

646+ testsBase :: (Show a, Eq a) => (Value -> Result a) -> (Value -> Result a)

647+ -> String -> Value -> Result a -> [TestTree]

648+ testsBase th g name value expected =

649+ [ testCase (name ++ "-th") $ assertApprox expected (th value)

650+ , testCase (name ++ "-generic") $ assertApprox expected (g value)

651+ ]

652+ testsUnary :: String -> Value -> Result UnknownFields -> [TestTree]

653+ testsUnary = testsBase fromJSON (parse (genericParseJSON opts))

654+ testsUnaryTag :: String -> Value -> Result UnknownFieldsTag -> [TestTree]

655+ testsUnaryTag = testsBase fromJSON (parse (genericParseJSON opts))

656+ testsSum :: String -> Value -> Result UnknownFieldsSum -> [TestTree]

657+ testsSum = testsBase fromJSON (parse (genericParseJSON opts))

658+ testsTagged :: String -> Value -> Result UnknownFieldsUnaryTagged -> [TestTree]

659+ testsTagged = testsBase fromJSON (parse (genericParseJSON taggedOpts))

660+

570testParser :: (Eq a, Show a)

661testParser :: (Eq a, Show a)

571 => String -> Parser a -> S.ByteString -> Either String a -> TestTree

662 => String -> Parser a -> S.ByteString -> Either String a -> TestTree

572testParser name json_ s expected =

663testParser name json_ s expected =

@@ -607,6 +698,25 @@ ratioDenominator0 =

607 (Left "Error in $: Ratio denominator was 0")

698 (Left "Error in $: Ratio denominator was 0")

608 (eitherDecode "{ \"numerator\": 1, \"denominator\": 0 }" :: Either String Rational)

699 (eitherDecode "{ \"numerator\": 1, \"denominator\": 0 }" :: Either String Rational)

609

700

701+rationalNumber :: Assertion

702+rationalNumber =

703+ assertEqual "Ratio with denominator 0"

704+ (Right 1.37)

705+ (eitherDecode "1.37" :: Either String Rational)

706+

707+bigRationalDecoding :: Assertion

708+bigRationalDecoding =

709+ assertEqual "Decoding an Integer with a large exponent should fail"

710+ (Left "Error in $: parsing Ratio failed, found a number with exponent 2000, but it must not be greater than 1024 or less than -1024")

711+ ((eitherDecode :: L.ByteString -> Either String Rational) "1e2000")

712+

713+smallRationalDecoding :: Assertion

714+smallRationalDecoding =

715+ assertEqual "Decoding an Integer with a large exponent should fail"

716+ (Left "Error in $: parsing Ratio failed, found a number with exponent -2000, but it must not be greater than 1024 or less than -1024")

717+ ((eitherDecode :: L.ByteString -> Either String Rational) "1e-2000")

718+

719+

610bigScientificExponent :: Assertion

720bigScientificExponent :: Assertion

611bigScientificExponent =

721bigScientificExponent =

612 assertEqual "Encoding an integral scientific with a large exponent should normalize it"

722 assertEqual "Encoding an integral scientific with a large exponent should normalize it"

@@ -643,3 +753,8 @@ deriveToJSON defaultOptions ''Foo

643deriveToJSON1 defaultOptions ''Foo

753deriveToJSON1 defaultOptions ''Foo

644

754

645deriveJSON defaultOptions{omitNothingFields=True,unwrapUnaryRecords=True} ''SingleMaybeField

755deriveJSON defaultOptions{omitNothingFields=True,unwrapUnaryRecords=True} ''SingleMaybeField

756+

757+deriveJSON defaultOptions{rejectUnknownFields=True} ''UnknownFields

758+deriveJSON defaultOptions{rejectUnknownFields=True} ''UnknownFieldsTag

759+deriveJSON defaultOptions{tagSingleConstructors=True,rejectUnknownFields=True} ''UnknownFieldsUnaryTagged

760+deriveJSON defaultOptions{rejectUnknownFields=True} ''UnknownFieldsSum

tests/golden/generic.expected+11−3

@@ -6,11 +6,11 @@ Error in $: parsing Types.Nullary failed, expected one of the tags ["C1","C2","C

6Error in $: parsing Types.Nullary failed, expected String, but encountered Array

7SomeType (tagged)

8Error in $.contents: parsing Int failed, expected Number, but encountered Boolean

9−Error in $: parsing Types.SomeType(Unary) failed, key "contents" not present

9+Error in $: parsing Types.SomeType(Unary) failed, key "contents" not found

10−Error in $: parsing Types.SomeType(Record) failed, key "testone" not present

10+Error in $: parsing Types.SomeType(Record) failed, key "testone" not found

11Error in $.testone: parsing Double failed, unexpected Boolean

12Error in $.tag: parsing Types.SomeType failed, expected tag field to be one of ["nullary","unary","product","record","list"], but found tag "X"

13−Error in $: parsing Types.SomeType failed, key "tag" not present

13+Error in $: parsing Types.SomeType failed, expected Object with key "tag" containing one of ["nullary","unary","product","record","list"], key "tag" not found

14Error in $: parsing Types.SomeType failed, expected Object, but encountered Array

15SomeType (single-field)

16Error in $.unary: parsing Int failed, expected Number, but encountered Object

@@ -31,6 +31,14 @@ Error in $: parsing Types.SomeType failed, expected a 2-element Array, but encou

31Error in $: parsing Types.SomeType failed, expected Array, but encountered Object

32Error in $: not enough input. Expecting ',' or ']'

33Error in $: not enough input. Expecting json list value

34+SomeType (reject unknown fields)

35+Error in $: parsing Types.SomeType(Record) failed, unknown fields: ["testZero"]

36+Error in $: parsing Types.SomeType failed, expected Object with key "tag" containing one of ["nullary","unary","product","record","list"], key "tag" not found

37+Error in $: parsing Types.SomeType(Record) failed, unknown fields: ["testtwo","testone","testthree"]

38+Foo (reject unknown fields)

39+Error in $: parsing Types.Foo(Foo) failed, unknown fields: ["tag"]

40+Foo (reject unknown fields, tagged single)

41+Error in $: parsing Types.Foo(Foo) failed, unknown fields: ["unknownField"]

34EitherTextInt

42EitherTextInt

35Error in $: parsing Types.EitherTextInt(NoneNullary) failed, expected tag "nonenullary", but found tag "X"

43Error in $: parsing Types.EitherTextInt(NoneNullary) failed, expected tag "nonenullary", but found tag "X"

36Error in $: parsing Types.EitherTextInt(NoneNullary) failed, expected String, but encountered Array

44Error in $: parsing Types.EitherTextInt(NoneNullary) failed, expected String, but encountered Array

travis/install.sh+6

@@ -49,4 +49,10 @@ case $BUILD in

49 cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/;

50 fi

51 ;;

52+ cabal2)

53+ cabal v2-update -v

54+ sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config

55+

56+ cabal v2-build --only-dependencies --enable-tests --enable-benchmarks --dry

57+ ;;

52esac

58esac

travis/script.sh+4

@@ -19,6 +19,10 @@ case $BUILD in

19 SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz &&

20 (cd dist && cabal install --force-reinstalls "$SRC_TGZ")

21 ;;

22+ cabal2)

23+ cabal v2-build --enable-tests --enable-benchmarks

24+ cabal v2-test --enable-tests --enable-benchmarks

25+ ;;

22 hlint)

26 hlint)

23 make lint

27 make lint

24 ;;

28 ;;