f2306d8...master · typeable/aeson

git.iko.soy/typeable/aeson

on master help sign in

CONTRIBUTING.md+38

since splitsnapshots

unifiedsplit

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

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

143import Text.Printf (printf)

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

145import 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)

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

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

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

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

922 -> Name

923 -> [Name]

924 -> Name

925+ -> Bool

925 -> ExpQ

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

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

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

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

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

929 xs

933 xs

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

931 x:xs = [ [|lookupField|]

951 x:xs = [ [|lookupField|]

932 `appE` dispatchParseJSON jc conName tvMap argTy

952 `appE` dispatchParseJSON jc conName tvMap argTy

933 `appE` litE (stringL $ show tName)

953 `appE` litE (stringL $ show tName)

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

1002 , constructorFields = argTys }

1022 , constructorFields = argTys }

1003 (Left (_, obj)) = do

1023 (Left (_, obj)) = do

1004 argTys' <- mapM resolveTypeSynonyms argTys

1024 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

1006parseArgs jc tvMap tName opts

1026parseArgs jc tvMap tName opts

1007 info@ConstructorInfo { constructorName = conName

1027 info@ConstructorInfo { constructorName = conName

1008 , constructorVariant = RecordConstructor fields

1028 , constructorVariant = RecordConstructor fields

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

1017 argTys' <- mapM resolveTypeSynonyms argTys

1037 argTys' <- mapM resolveTypeSynonyms argTys

1018 caseE (varE valName)

1038 caseE (varE valName)

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

1039 [ 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) []

1021 , matchFailed tName conName "Object"

1041 , matchFailed tName conName "Object"

1022 ]

1042 ]

1023

1043

Data/Aeson/Types.hs+1

@@ -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(..)

Data/Aeson/Types/FromJSON.hs+51−16

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

11{-# LANGUAGE RecordWildCards #-}

12{-# LANGUAGE ScopedTypeVariables #-}

13{-# LANGUAGE TypeOperators #-}

14+{-# LANGUAGE TupleSections #-}

14{-# LANGUAGE UndecidableInstances #-}

15{-# LANGUAGE UndecidableInstances #-}

15{-# LANGUAGE ViewPatterns #-}

16{-# LANGUAGE ViewPatterns #-}

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

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

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

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

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

1202

1203

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

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

1204 -- Records are unpacked in the tagged object

1205 -- Records are unpacked in the tagged object

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

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

1206

1207

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

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

1208 -- Nonnullary nonrecords are encoded in the contents field

1209 -- Nonnullary nonrecords are encoded in the contents field

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

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

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

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

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

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

1246 | 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))

1247

1248

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

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

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

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

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

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

1251

1252

1252instance OVERLAPPING_

1253instance OVERLAPPING_

1253 ConsFromJSON' arity U1 False where

1254 ConsFromJSON' arity U1 False where

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

1273

1274

1274--------------------------------------------------------------------------------

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

1275

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+

1276class RecordFromJSON arity f where

1288class RecordFromJSON arity f where

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

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

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

1279 -> Object -> Parser (f a)

1314 -> Object -> Parser (f a)

1280

1315

1281−instance ( RecordFromJSON arity a

1316+instance ( RecordFromJSON' arity a

1282− , RecordFromJSON arity b

1317+ , RecordFromJSON' arity b

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

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

1284− recordParseJSON p obj =

1319+ recordParseJSON' p obj =

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

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

1286− <*> recordParseJSON p obj

1321+ <*> recordParseJSON' p obj

1287

1322

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

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

1289− RecordFromJSON arity (S1 s a) where

1324+ RecordFromJSON' arity (S1 s a) where

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

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

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

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

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

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

1293 where

1328 where

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

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

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

1296

1331

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

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

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

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

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

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

1300 where

1335 where

1301 label = fieldLabelModifier opts sname

1336 label = fieldLabelModifier opts sname

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

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

1303

1338

1304-- Parse an Option like a Maybe.

1339-- Parse an Option like a Maybe.

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

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

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

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

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

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

1308 where

1343 where

1309 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

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

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

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

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

64 , sumEncoding

65 , unwrapUnaryRecords

66 , tagSingleConstructors

67+ , rejectUnknownFields

67 )

68 )

69 , SumEncoding(..)

70 , SumEncoding(..)

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

624 , tagSingleConstructors :: Bool

625 , tagSingleConstructors :: Bool

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

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

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

627 }

632 }

628

633

629instance Show Options where

634instance Show Options where

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

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

631 "Options {"

636 "Options {"

632 ++ intercalate ", "

637 ++ intercalate ", "

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

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

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

637 , "sumEncoding = " ++ show s

642 , "sumEncoding = " ++ show s

638 , "unwrapUnaryRecords = " ++ show u

643 , "unwrapUnaryRecords = " ++ show u

639 , "tagSingleConstructors = " ++ show t

644 , "tagSingleConstructors = " ++ show t

645+ , "rejectUnknownFields = " ++ show r

640 ]

646 ]

641 ++ "}"

647 ++ "}"

642

648

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

718-- , 'sumEncoding' = 'defaultTaggedObject'

724-- , 'sumEncoding' = 'defaultTaggedObject'

719-- , 'unwrapUnaryRecords' = False

725-- , 'unwrapUnaryRecords' = False

720-- , 'tagSingleConstructors' = False

726-- , 'tagSingleConstructors' = False

727+-- , 'rejectUnknownFields' = False

721-- }

728-- }

722-- @

729-- @

723defaultOptions :: Options

730defaultOptions :: Options

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

729 , sumEncoding = defaultTaggedObject

736 , sumEncoding = defaultTaggedObject

730 , unwrapUnaryRecords = False

737 , unwrapUnaryRecords = False

731 , tagSingleConstructors = False

738 , tagSingleConstructors = False

739+ , rejectUnknownFields = False

732 }

740 }

733

741

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

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

tests/Encoders.hs+25

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

243gSomeTypeToEncodingOmitNothingFields = genericToEncoding optsOmitNothingFields

244

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+

246--------------------------------------------------------------------------------

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

247-- Option fields

272-- Option fields

248--------------------------------------------------------------------------------

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

tests/ErrorMessages.hs+26

@@ -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−1

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

29-- "System" types.

31instance Arbitrary DotNetTime where

32− arbitrary = DotNetTime `liftM` arbitrary

32+ arbitrary = DotNetTime `fmap` arbitrary

33 shrink = map DotNetTime . shrink . fromDotNetTime

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

@@ -33,15 +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, formatPath, formatRelativePath

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

38− , omitNothingFields, parse)

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

40import Data.Char (toUpper)

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

42import Data.Hashable (hash)

43import Data.HashMap.Strict (HashMap)

44−import Data.List (sort)

44+import Data.List (sort, isSuffixOf)

45import Data.Maybe (fromMaybe)

46import Data.Scientific (Scientific, scientific)

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

@@ -112,6 +112,7 @@ tests = testGroup "unit" [

112 , testGroup "SingleMaybeField" singleMaybeField

113 , testCase "withEmbeddedJSON" withEmbeddedJSONTest

114 , testCase "SingleFieldCon" singleFieldCon

115+ , testGroup "UnknownFields" unknownFields

115 , testGroup "Ordering of object keys" keyOrdering

116 , testGroup "Ordering of object keys" keyOrdering

116 , testCase "Ratio with denominator 0" ratioDenominator0

117 , testCase "Ratio with denominator 0" ratioDenominator0

117 , testCase "Rational parses number" rationalNumber

118 , testCase "Rational parses number" rationalNumber

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

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

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

540 ++ ", unwrapUnaryRecords = False"

541 ++ ", unwrapUnaryRecords = False"

541 ++ ", tagSingleConstructors = False"

542 ++ ", tagSingleConstructors = False"

543+ ++ ", rejectUnknownFields = False"

542 ++ "}")

544 ++ "}")

543 (show defaultOptions)

545 (show defaultOptions)

544

546

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

583singleFieldCon =

585singleFieldCon =

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

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

585

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+

586testParser :: (Eq a, Show a)

661testParser :: (Eq a, Show a)

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

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

588testParser name json_ s expected =

663testParser name json_ s expected =

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

678deriveToJSON1 defaultOptions ''Foo

753deriveToJSON1 defaultOptions ''Foo

679

754

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

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