master..4d3767c · typeable/aeson

git.iko.soy/typeable/aeson

on 4d3767c help sign in

CONTRIBUTING.md−38

since splitsnapshots

unifiedsplit

@@ -58,41 +58,3 @@ 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+4−24

@@ -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 (difference, fromList, keys, lookup, toList)

146+import qualified Data.HashMap.Strict as H (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,32 +922,12 @@ parseRecord :: JSONClass

922 -> Name

923 -> [Name]

924 -> Name

925− -> Bool

926 -> ExpQ

925 -> ExpQ

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

926+parseRecord jc tvMap argTys opts tName conName fields obj =

928− (if rejectUnknownFields opts

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

930− else id) $

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

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

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

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

933 xs

929 xs

934 where

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

951 x:xs = [ [|lookupField|]

931 x:xs = [ [|lookupField|]

952 `appE` dispatchParseJSON jc conName tvMap argTy

932 `appE` dispatchParseJSON jc conName tvMap argTy

953 `appE` litE (stringL $ show tName)

933 `appE` litE (stringL $ show tName)

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

1022 , constructorFields = argTys }

1002 , constructorFields = argTys }

1023 (Left (_, obj)) = do

1003 (Left (_, obj)) = do

1024 argTys' <- mapM resolveTypeSynonyms argTys

1004 argTys' <- mapM resolveTypeSynonyms argTys

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

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

1026parseArgs jc tvMap tName opts

1006parseArgs jc tvMap tName opts

1027 info@ConstructorInfo { constructorName = conName

1007 info@ConstructorInfo { constructorName = conName

1028 , constructorVariant = RecordConstructor fields

1008 , constructorVariant = RecordConstructor fields

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

1037 argTys' <- mapM resolveTypeSynonyms argTys

1017 argTys' <- mapM resolveTypeSynonyms argTys

1038 caseE (varE valName)

1018 caseE (varE valName)

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

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

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

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

1041 , matchFailed tName conName "Object"

1021 , matchFailed tName conName "Object"

1042 ]

1022 ]

1043

1023

Data/Aeson/Types.hs−1

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

124 , sumEncoding

125 , unwrapUnaryRecords

126 , tagSingleConstructors

127− , rejectUnknownFields

128

127

129 -- ** Options utilities

128 -- ** Options utilities

130 , SumEncoding(..)

129 , SumEncoding(..)

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

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

11{-# LANGUAGE RecordWildCards #-}

12{-# LANGUAGE ScopedTypeVariables #-}

13{-# LANGUAGE TypeOperators #-}

14−{-# LANGUAGE TupleSections #-}

15{-# LANGUAGE UndecidableInstances #-}

14{-# LANGUAGE UndecidableInstances #-}

16{-# LANGUAGE ViewPatterns #-}

15{-# LANGUAGE ViewPatterns #-}

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

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

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

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

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

1203

1202

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

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

1205 -- Records are unpacked in the tagged object

1204 -- Records are unpacked in the tagged object

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

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

1207

1206

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

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

1209 -- Nonnullary nonrecords are encoded in the contents field

1208 -- Nonnullary nonrecords are encoded in the contents field

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

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

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

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

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

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

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

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

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

1248

1247

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

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

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

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

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

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

1252

1251

1253instance OVERLAPPING_

1252instance OVERLAPPING_

1254 ConsFromJSON' arity U1 False where

1253 ConsFromJSON' arity U1 False where

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

1274

1273

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

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

1276

1275

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−

1288class RecordFromJSON arity f where

1276class RecordFromJSON arity f where

1289 recordParseJSON

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

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

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

1314 -> Object -> Parser (f a)

1279 -> Object -> Parser (f a)

1315

1280

1316−instance ( RecordFromJSON' arity a

1281+instance ( RecordFromJSON arity a

1317− , RecordFromJSON' arity b

1282+ , RecordFromJSON arity b

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

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

1319− recordParseJSON' p obj =

1284+ recordParseJSON p obj =

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

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

1321− <*> recordParseJSON' p obj

1286+ <*> recordParseJSON p obj

1322

1287

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

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

1324− RecordFromJSON' arity (S1 s a) where

1289+ RecordFromJSON arity (S1 s a) where

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

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

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

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

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

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

1328 where

1293 where

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

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

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

1331

1296

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

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

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

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

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

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

1335 where

1300 where

1336 label = fieldLabelModifier opts sname

1301 label = fieldLabelModifier opts sname

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

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

1338

1303

1339-- Parse an Option like a Maybe.

1304-- Parse an Option like a Maybe.

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

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

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

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

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

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

1343 where

1308 where

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

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

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

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

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

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

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

1577

1542

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

1543instance (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

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

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

1590− numerator <- obj .: "numerator"

1545+ numerator <- obj .: "numerator"

1591− denominator <- obj .: "denominator"

1546+ denominator <- obj .: "denominator"

1592− if denominator == 0

1547+ if denominator == 0

1593− then fail "Ratio denominator was 0"

1548+ then fail "Ratio denominator was 0"

1594− else pure $ numerator % denominator

1549+ else pure $ numerator % denominator

1595 {-# INLINE parseJSON #-}

1550 {-# INLINE parseJSON #-}

1596

1551

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

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

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

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

64 , sumEncoding

65 , unwrapUnaryRecords

66 , tagSingleConstructors

67− , rejectUnknownFields

68 )

67 )

70 , SumEncoding(..)

69 , SumEncoding(..)

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

625 , tagSingleConstructors :: Bool

624 , tagSingleConstructors :: Bool

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

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

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

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

632 }

627 }

633

628

634instance Show Options where

629instance Show Options where

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

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

636 "Options {"

631 "Options {"

637 ++ intercalate ", "

632 ++ intercalate ", "

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

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

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

642 , "sumEncoding = " ++ show s

637 , "sumEncoding = " ++ show s

643 , "unwrapUnaryRecords = " ++ show u

638 , "unwrapUnaryRecords = " ++ show u

644 , "tagSingleConstructors = " ++ show t

639 , "tagSingleConstructors = " ++ show t

645− , "rejectUnknownFields = " ++ show r

646 ]

640 ]

647 ++ "}"

641 ++ "}"

648

642

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

724-- , 'sumEncoding' = 'defaultTaggedObject'

718-- , 'sumEncoding' = 'defaultTaggedObject'

725-- , 'unwrapUnaryRecords' = False

719-- , 'unwrapUnaryRecords' = False

726-- , 'tagSingleConstructors' = False

720-- , 'tagSingleConstructors' = False

727−-- , 'rejectUnknownFields' = False

728-- }

721-- }

729-- @

722-- @

730defaultOptions :: Options

723defaultOptions :: Options

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

736 , sumEncoding = defaultTaggedObject

729 , sumEncoding = defaultTaggedObject

737 , unwrapUnaryRecords = False

730 , unwrapUnaryRecords = False

738 , tagSingleConstructors = False

731 , tagSingleConstructors = False

739− , rejectUnknownFields = False

740 }

732 }

741

733

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

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

Data/Aeson/Types/ToJSON.hs+1

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

100import Numeric.Natural (Natural)

101import qualified Data.Aeson.Encoding as E

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

103+import qualified Data.ByteString as S

103import qualified Data.ByteString.Lazy as L

104import qualified Data.ByteString.Lazy as L

104import qualified Data.DList as DList

105import qualified Data.DList as DList

105import qualified Data.HashMap.Strict as H

106import qualified Data.HashMap.Strict as H

changelog.md−5

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

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

4−

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

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

7−

8### 1.4.6.0

3### 1.4.6.0

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

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

tests/Encoders.hs−25

@@ -243,31 +243,6 @@ 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−

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

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

272-- Option fields

247-- Option fields

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

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

tests/ErrorMessages.hs−26

@@ -136,29 +136,6 @@ 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−

162 , testWith "EitherTextInt"

139 , testWith "EitherTextInt"

163 (select

140 (select

164 thEitherTextIntParseJSONUntaggedValue

141 thEitherTextIntParseJSONUntaggedValue

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

219

196

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

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

221testWithSomeType = testWith

198testWithSomeType = 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 `fmap` arbitrary

32+ arbitrary = DotNetTime `liftM` arbitrary

33 shrink = map DotNetTime . shrink . fromDotNetTime

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

tests/Options.hs−11

@@ -55,14 +55,3 @@ 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+4−106

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

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

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

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

37+ , camelTo, camelTo2, defaultOptions, formatPath, formatRelativePath

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, isSuffixOf)

44+import Data.List (sort)

45import Data.Maybe (fromMaybe)

46import Data.Scientific (Scientific, scientific)

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

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

112 , testGroup "SingleMaybeField" singleMaybeField

113 , testCase "withEmbeddedJSON" withEmbeddedJSONTest

114 , testCase "SingleFieldCon" singleFieldCon

115− , testGroup "UnknownFields" unknownFields

116 , testGroup "Ordering of object keys" keyOrdering

115 , testGroup "Ordering of object keys" keyOrdering

117 , testCase "Ratio with denominator 0" ratioDenominator0

116 , testCase "Ratio with denominator 0" ratioDenominator0

118− , testCase "Rational parses number" rationalNumber

119− , testCase "Big rational" bigRationalDecoding

120− , testCase "Small rational" smallRationalDecoding

121 , testCase "Big scientific exponent" bigScientificExponent

117 , testCase "Big scientific exponent" bigScientificExponent

122 , testCase "Big integer decoding" bigIntegerDecoding

118 , testCase "Big integer decoding" bigIntegerDecoding

123 , testCase "Big natural decading" bigNaturalDecoding

119 , testCase "Big natural decading" bigNaturalDecoding

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

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

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

541 ++ ", unwrapUnaryRecords = False"

537 ++ ", unwrapUnaryRecords = False"

542 ++ ", tagSingleConstructors = False"

538 ++ ", tagSingleConstructors = False"

543− ++ ", rejectUnknownFields = False"

544 ++ "}")

539 ++ "}")

545 (show defaultOptions)

540 (show defaultOptions)

546

541

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

585singleFieldCon =

580singleFieldCon =

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

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

587

582

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−

661testParser :: (Eq a, Show a)

583testParser :: (Eq a, Show a)

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

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

663testParser name json_ s expected =

585testParser name json_ s expected =

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

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

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

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

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

700

622

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−

720bigScientificExponent :: Assertion

623bigScientificExponent :: Assertion

721bigScientificExponent =

624bigScientificExponent =

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

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

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

753deriveToJSON1 defaultOptions ''Foo

656deriveToJSON1 defaultOptions ''Foo

754

657

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

658deriveJSON 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,14 +31,6 @@ 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"]

42EitherTextInt

34EitherTextInt

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

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

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

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