4d3767c...master · typeable/aeson

git.iko.soy/typeable/aeson

13 files changed+321−33

since splitsnapshots

unifiedsplit

CONTRIBUTING.md+38 Data/Aeson/TH.hs+24−4 Data/Aeson/Types.hs+1 Data/Aeson/Types/FromJSON.hs+67−22 Data/Aeson/Types/Internal.hs+9−1 Data/Aeson/Types/ToJSON.hs−1 changelog.md+5 tests/Encoders.hs+25 tests/ErrorMessages.hs+26 tests/Instances.hs+1−1 tests/Options.hs+11 tests/UnitTests.hs+106−4 tests/golden/generic.expected+8

CONTRIBUTING.md+38

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

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

5959import qualified A

6060```

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/TH.hs+24−4

@@ -143,7 +143,7 @@ import Language.Haskell.TH.Syntax (mkNameG_tc)

143143import Text.Printf (printf)

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

145145import qualified Data.Foldable as F (all)

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

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

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

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

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

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

922922 -> Name

923923 -> [Name]

924924 -> Name

925+ -> Bool

925926 -> ExpQ

926−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) $

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

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

929933 xs

930934 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+ ]

931951 x:xs = [ [|lookupField|]

932952 `appE` dispatchParseJSON jc conName tvMap argTy

933953 `appE` litE (stringL $ show tName)

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

10021022 , constructorFields = argTys }

10031023 (Left (_, obj)) = do

10041024 argTys' <- mapM resolveTypeSynonyms argTys

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

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

10061026parseArgs jc tvMap tName opts

10071027 info@ConstructorInfo { constructorName = conName

10081028 , constructorVariant = RecordConstructor fields

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

10171037 argTys' <- mapM resolveTypeSynonyms argTys

10181038 caseE (varE valName)

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

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

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

10211041 , matchFailed tName conName "Object"

10221042 ]

10231043

Data/Aeson/Types.hs+1

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

124124 , sumEncoding

125125 , unwrapUnaryRecords

126126 , tagSingleConstructors

127+ , rejectUnknownFields

127128

128129 -- ** Options utilities

129130 , SumEncoding(..)

Data/Aeson/Types/FromJSON.hs+67−22

@@ -11,6 +11,7 @@

1111{-# LANGUAGE RecordWildCards #-}

1212{-# LANGUAGE ScopedTypeVariables #-}

1313{-# LANGUAGE TypeOperators #-}

14+{-# LANGUAGE TupleSections #-}

1415{-# LANGUAGE UndecidableInstances #-}

1516{-# LANGUAGE ViewPatterns #-}

1617

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

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

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

12021203

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

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

12041205 -- Records are unpacked in the tagged object

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

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

12061207

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

12081209 -- Nonnullary nonrecords are encoded in the contents field

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

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

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

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

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

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

12471248

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

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

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

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

12511252

12521253instance OVERLAPPING_

12531254 ConsFromJSON' arity U1 False where

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

12731274

12741275--------------------------------------------------------------------------------

12751276

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+

12761288class RecordFromJSON arity f where

12771289 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'

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

12791314 -> Object -> Parser (f a)

12801315

1281−instance ( RecordFromJSON arity a

1282− , RecordFromJSON arity b

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

1284− recordParseJSON p obj =

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

1286− <*> recordParseJSON p obj

1316+instance ( RecordFromJSON' arity a

1317+ , RecordFromJSON' arity b

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

1319+ recordParseJSON' p obj =

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

1321+ <*> recordParseJSON' p obj

12871322

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

1289− RecordFromJSON arity (S1 s a) where

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

1324+ RecordFromJSON' arity (S1 s a) where

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

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

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

12931328 where

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

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

12961331

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

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

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

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

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

13001335 where

13011336 label = fieldLabelModifier opts sname

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

13031338

13041339-- Parse an Option like a Maybe.

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

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

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

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

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

13081343 where

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

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

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

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

15421577

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

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

1545− numerator <- obj .: "numerator"

1546− denominator <- obj .: "denominator"

1547− if denominator == 0

1548− then fail "Ratio denominator was 0"

1549− else pure $ numerator % denominator

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

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

1590+ numerator <- obj .: "numerator"

1591+ denominator <- obj .: "denominator"

1592+ if denominator == 0

1593+ then fail "Ratio denominator was 0"

1594+ else pure $ numerator % denominator

15501595 {-# INLINE parseJSON #-}

15511596

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

Data/Aeson/Types/Internal.hs+9−1

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

6464 , sumEncoding

6565 , unwrapUnaryRecords

6666 , tagSingleConstructors

67+ , rejectUnknownFields

6768 )

6869

6970 , SumEncoding(..)

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

624625 , tagSingleConstructors :: Bool

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

626627 -- 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.

627632 }

628633

629634instance Show Options where

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

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

631636 "Options {"

632637 ++ intercalate ", "

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

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

637642 , "sumEncoding = " ++ show s

638643 , "unwrapUnaryRecords = " ++ show u

639644 , "tagSingleConstructors = " ++ show t

645+ , "rejectUnknownFields = " ++ show r

640646 ]

641647 ++ "}"

642648

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

718724-- , 'sumEncoding' = 'defaultTaggedObject'

719725-- , 'unwrapUnaryRecords' = False

720726-- , 'tagSingleConstructors' = False

727+-- , 'rejectUnknownFields' = False

721728-- }

722729-- @

723730defaultOptions :: Options

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

729736 , sumEncoding = defaultTaggedObject

730737 , unwrapUnaryRecords = False

731738 , tagSingleConstructors = False

739+ , rejectUnknownFields = False

732740 }

733741

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

Data/Aeson/Types/ToJSON.hs−1

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

100100import Numeric.Natural (Natural)

101101import qualified Data.Aeson.Encoding as E

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

103−import qualified Data.ByteString as S

104103import qualified Data.ByteString.Lazy as L

105104import qualified Data.DList as DList

106105import qualified Data.HashMap.Strict as H

changelog.md+5

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

11For 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.

38### 1.4.6.0

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

tests/Encoders.hs+25

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

243243gSomeTypeToEncodingOmitNothingFields = genericToEncoding optsOmitNothingFields

244244

245245

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+

246271--------------------------------------------------------------------------------

247272-- Option fields

248273--------------------------------------------------------------------------------

tests/ErrorMessages.hs+26

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

136136 , "[1,"

137137 ]

138138

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+

139162 , testWith "EitherTextInt"

140163 (select

141164 thEitherTextIntParseJSONUntaggedValue

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

196219

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

198221testWithSomeType = testWith

222+

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

224+testWithFoo = testWith

tests/Instances.hs+1−1

@@ -29,7 +29,7 @@ import Data.Hashable.Time ()

2929-- "System" types.

3030

3131instance Arbitrary DotNetTime where

32− arbitrary = DotNetTime `liftM` arbitrary

32+ arbitrary = DotNetTime `fmap` arbitrary

3333 shrink = map DotNetTime . shrink . fromDotNetTime

3434

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

tests/Options.hs+11

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

5555 { fieldLabelModifier = const "field"

5656 , omitNothingFields = True

5757 }

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/UnitTests.hs+106−4

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

3333 ( json, jsonLast, jsonAccum, jsonNoDup

3434 , json', jsonLast', jsonAccum', jsonNoDup')

3535import Data.Aeson.Types

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

37− , camelTo, camelTo2, defaultOptions, formatPath, formatRelativePath

38− , omitNothingFields, parse)

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

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

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

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

4040import Data.Char (toUpper)

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

4242import Data.Hashable (hash)

4343import Data.HashMap.Strict (HashMap)

44−import Data.List (sort)

44+import Data.List (sort, isSuffixOf)

4545import Data.Maybe (fromMaybe)

4646import Data.Scientific (Scientific, scientific)

4747import Data.Tagged (Tagged(..))

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

112112 , testGroup "SingleMaybeField" singleMaybeField

113113 , testCase "withEmbeddedJSON" withEmbeddedJSONTest

114114 , testCase "SingleFieldCon" singleFieldCon

115+ , testGroup "UnknownFields" unknownFields

115116 , testGroup "Ordering of object keys" keyOrdering

116117 , testCase "Ratio with denominator 0" ratioDenominator0

118+ , testCase "Rational parses number" rationalNumber

119+ , testCase "Big rational" bigRationalDecoding

120+ , testCase "Small rational" smallRationalDecoding

117121 , testCase "Big scientific exponent" bigScientificExponent

118122 , testCase "Big integer decoding" bigIntegerDecoding

119123 , testCase "Big natural decading" bigNaturalDecoding

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

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

537541 ++ ", unwrapUnaryRecords = False"

538542 ++ ", tagSingleConstructors = False"

543+ ++ ", rejectUnknownFields = False"

539544 ++ "}")

540545 (show defaultOptions)

541546

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

580585singleFieldCon =

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

582587

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+

583661testParser :: (Eq a, Show a)

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

585663testParser name json_ s expected =

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

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

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

622700

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+

623720bigScientificExponent :: Assertion

624721bigScientificExponent =

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

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

656753deriveToJSON1 defaultOptions ''Foo

657754

658755deriveJSON 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+8

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

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

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

3333Error 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"]

3442EitherTextInt

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

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