Skip to content

Commit d835b9d

Browse files
phadejphadej
committed
Complete omitField and omittedField things
- Add combinators for using omit* stuff in manually written instances - Add Manual tests - Cleanup OptionalFields.Common - Fix TH and Generics - Add combinators ToJSON1/2 and FromJSON1/2 - Const, Identity, Tagged and other newtypes - Fix #687. ToJSON1 respects omitting fields - Fix #571. Introduce allowOmittedFields to Generics/TH options. - Resolve #792. () and Proxy can be omitted
1 parent 2f8ed86 commit d835b9d

24 files changed

+1317
-656
lines changed

‎aeson.cabal

+3
Original file line numberDiff line numberDiff line change
@@ -165,6 +165,7 @@ test-suite aeson-tests
165165
PropUtils
166166
Regression.Issue351
167167
Regression.Issue571
168+
Regression.Issue687
168169
Regression.Issue967
169170
SerializationFormatSpec
170171
Types
@@ -174,9 +175,11 @@ test-suite aeson-tests
174175
UnitTests.KeyMapInsertWith
175176
UnitTests.MonadFix
176177
UnitTests.NullaryConstructors
178+
UnitTests.OmitNothingFieldsNote
177179
UnitTests.OptionalFields
178180
UnitTests.OptionalFields.Common
179181
UnitTests.OptionalFields.Generics
182+
UnitTests.OptionalFields.Manual
180183
UnitTests.OptionalFields.TH
181184
UnitTests.UTCTime
182185

‎changelog.md

+25-7
Original file line numberDiff line numberDiff line change
@@ -1,12 +1,30 @@
11
For the latest version of this document, please see [https://github.com/haskell/aeson/blob/master/changelog.md](https://github.com/haskell/aeson/blob/master/changelog.md).
22

3-
### 2.2
4-
5-
* Use `Data.Aeson.Decoding` parsing functions as default in `Data.Aeson`.
6-
* Move `Data.Aeson.Parser` module into separate `attoparsec-aeson` package, as these parsers are not used by `aeson` itself anymore.
7-
* Remove `cffi` flag. Then the C implementation for string unescaping was used for `text <2` versions.
8-
The new native Haskell implementation introduced in version 2.0.3.0 is at least as fast.
9-
* Drop instances for `attoparsec.Number`.
3+
### 2.2.0.0
4+
5+
* Rework how `omitNothingFields` works. Add `allowOmittedFields` as a parsing counterpart.
6+
7+
New type-class members were added: `omitField :: a -> Bool` to `ToJSON` and `omittedField :: Maybe a` to `FromJSON`.
8+
These control which fields can be omitted.
9+
The `.:?=`, `.:!=` and `.?=` operators were added to make use of these new members.
10+
GHC.Generics and Template Haskell deriving has been updated accordingly.
11+
12+
In addition to `Maybe` (and `Option`) fields the `Data.Monoid.First` and `Data.Monoid.Last` are also omitted,
13+
as well as the most newtype wrappers, when their wrap omittable type (e.g. newtypes in `Data.Monoid` and `Data.Semigroup`, `Identity`, `Const`, `Tagged`, `Compose`).
14+
Additionall "boring" types like `()` and `Proxy` can be omitted as well.
15+
As the omitting is now uniform, type arguments are also omitted (also in `Generic1` derived instance).
16+
17+
Resolves issues
18+
[#687](https://github.com/haskell/aeson/issues/687),
19+
[#571](https://github.com/haskell/aeson/issues/571),
20+
[#792](https://github.com/haskell/aeson/issues/792).
21+
22+
* Use `Data.Aeson.Decoding` parsing functions (introduced in version 2.1.2.0) as default in `Data.Aeson`.
23+
* Move `Data.Aeson.Parser` module into separate [`attoparsec-aeson`](https://hackage.haskell.org/package/attoparsec-aeson) package, as these parsers are not used by `aeson` itself anymore.
24+
* Use [`text-iso8601`](https://hackage.haskell.org/package/text-iso8601) package for parsing `time` types. These are slightly faster than previously used (copy of) `attoparsec-iso8601`.
25+
* Remove `cffi` flag. Toggling the flag made `aeson` use a C implementation for string unescaping (used for `text <2` versions).
26+
The new native Haskell implementation (introduced in version 2.0.3.0) is at least as fast.
27+
* Drop instances for `Number` from `attoparsec` package.
1028
* Improve `Arbitrary Value` instance.
1129

1230
### 2.1.2.1

‎src/Data/Aeson.hs

+8
Original file line numberDiff line numberDiff line change
@@ -76,6 +76,7 @@ module Data.Aeson
7676
, fromJSON
7777
, ToJSON(..)
7878
, KeyValue(..)
79+
, KeyValueOmit(..)
7980
, (<?>)
8081
, JSONPath
8182
-- ** Keys for maps
@@ -91,14 +92,18 @@ module Data.Aeson
9192
-- ** Liftings to unary and binary type constructors
9293
, FromJSON1(..)
9394
, parseJSON1
95+
, omittedField1
9496
, FromJSON2(..)
9597
, parseJSON2
98+
, omittedField2
9699
, ToJSON1(..)
97100
, toJSON1
98101
, toEncoding1
102+
, omitField1
99103
, ToJSON2(..)
100104
, toJSON2
101105
, toEncoding2
106+
, omitField2
102107
-- ** Generic JSON classes and options
103108
, GFromJSON
104109
, FromArgs
@@ -123,6 +128,7 @@ module Data.Aeson
123128
, constructorTagModifier
124129
, allNullaryToStringTag
125130
, omitNothingFields
131+
, allowOmittedFields
126132
, sumEncoding
127133
, unwrapUnaryRecords
128134
, tagSingleConstructors
@@ -151,6 +157,8 @@ module Data.Aeson
151157
, (.:?)
152158
, (.:!)
153159
, (.!=)
160+
, (.:?=)
161+
, (.:!=)
154162
, object
155163
-- * Parsing
156164
, parseIndexedJSON

‎src/Data/Aeson/Encoding/Internal.hs

+1-1
Original file line numberDiff line numberDiff line change
@@ -115,7 +115,7 @@ instance Ord (Encoding' a) where
115115
compare (Encoding a) (Encoding b) =
116116
compare (toLazyByteString a) (toLazyByteString b)
117117

118-
-- | @since 2.2
118+
-- | @since 2.2.0.0
119119
instance IsString (Encoding' a) where
120120
fromString = string
121121

‎src/Data/Aeson/TH.hs

+84-49
Original file line numberDiff line numberDiff line change
@@ -114,7 +114,6 @@ module Data.Aeson.TH
114114

115115
import Data.Aeson.Internal.Prelude
116116

117-
import Data.Bool (bool)
118117
import Data.Char (ord)
119118
import Data.Aeson (Object, (.:), FromJSON(..), FromJSON1(..), FromJSON2(..), ToJSON(..), ToJSON1(..), ToJSON2(..))
120119
import Data.Aeson.Types (Options(..), Parser, SumEncoding(..), Value(..), defaultOptions, defaultTaggedObject)
@@ -124,7 +123,7 @@ import Data.Aeson.Key (Key)
124123
import qualified Data.Aeson.Key as Key
125124
import qualified Data.Aeson.KeyMap as KM
126125
import Data.Foldable (foldr')
127-
import Data.List (genericLength, intercalate, partition, union)
126+
import Data.List (genericLength, intercalate, union)
128127
import Data.List.NonEmpty ((<|), NonEmpty((:|)))
129128
import Data.Map (Map)
130129
import qualified Data.Monoid as Monoid
@@ -321,10 +320,11 @@ consToValue _ _ _ _ [] =
321320

322321
consToValue target jc opts instTys cons = autoletE liftSBS $ \letInsert -> do
323322
value <- newName "value"
323+
os <- newNameList "_o" $ arityInt jc
324324
tjs <- newNameList "_tj" $ arityInt jc
325325
tjls <- newNameList "_tjl" $ arityInt jc
326-
let zippedTJs = zip tjs tjls
327-
interleavedTJs = interleave tjs tjls
326+
let zippedTJs = zip3 os tjs tjls
327+
interleavedTJs = flatten3 zippedTJs
328328
lastTyVars = map varTToName $ drop (length instTys - arityInt jc) instTys
329329
tvMap = M.fromList $ zip lastTyVars zippedTJs
330330
lamE (map varP $ interleavedTJs ++ [value]) $
@@ -461,14 +461,16 @@ argsToValue letInsert target jc tvMap opts multiCons
461461
toPair (arg, argTy, fld) =
462462
let fieldName = fieldLabel opts fld
463463
toValue = dispatchToJSON target jc conName tvMap argTy
464+
465+
omitFn :: Q Exp
464466
omitFn
465-
| omitNothingFields opts = [| omitField |]
467+
| omitNothingFields opts = dispatchOmitField jc conName tvMap argTy
466468
| otherwise = [| const False |]
467-
in
468-
[| \f x arg' -> bool x mempty (f arg') |]
469-
`appE` omitFn
470-
`appE` pairE letInsert target fieldName (toValue `appE` arg)
471-
`appE` arg
469+
470+
in condE
471+
(omitFn `appE` arg)
472+
[| mempty |]
473+
(pairE letInsert target fieldName (toValue `appE` arg))
472474

473475
pairs = mconcatE (map toPair argCons)
474476

@@ -653,10 +655,11 @@ consFromJSON _ _ _ _ [] =
653655

654656
consFromJSON jc tName opts instTys cons = do
655657
value <- newName "value"
658+
os <- newNameList "_o" $ arityInt jc
656659
pjs <- newNameList "_pj" $ arityInt jc
657660
pjls <- newNameList "_pjl" $ arityInt jc
658-
let zippedPJs = zip pjs pjls
659-
interleavedPJs = interleave pjs pjls
661+
let zippedPJs = zip3 os pjs pjls
662+
interleavedPJs = flatten3 zippedPJs
660663
lastTyVars = map varTToName $ drop (length instTys - arityInt jc) instTys
661664
tvMap = M.fromList $ zip lastTyVars zippedPJs
662665
lamE (map varP $ interleavedPJs ++ [value]) $ lamExpr value tvMap
@@ -921,9 +924,11 @@ parseRecord jc tvMap argTys opts tName conName fields obj inTaggedObject =
921924
(infixApp (conE conName) [|(<$>)|] x)
922925
xs
923926
where
924-
defVal = case jc of
925-
JSONClass From Arity0 -> [|omittedField|]
926-
_ -> [|Nothing|]
927+
lookupField :: Type -> Q Exp
928+
lookupField argTy
929+
| allowOmittedFields opts = [| lookupFieldOmit |] `appE` dispatchOmittedField jc conName tvMap argTy
930+
| otherwise = [| lookupFieldNoOmit |]
931+
927932
tagFieldNameAppender =
928933
if inTaggedObject then (tagFieldName (sumEncoding opts) :) else id
929934
knownFields = appE [|KM.fromList|] $ listE $
@@ -940,8 +945,7 @@ parseRecord jc tvMap argTys opts tName conName fields obj inTaggedObject =
940945
(appE [|show|] (varE unknownFields)))
941946
[]
942947
]
943-
x:xs = [ [|lookupField|]
944-
`appE` defVal
948+
x:xs = [ lookupField argTy
945949
`appE` dispatchParseJSON jc conName tvMap argTy
946950
`appE` litE (stringL $ show tName)
947951
`appE` litE (stringL $ constructorTagModifier opts $ nameBase conName)
@@ -1109,16 +1113,21 @@ parseTypeMismatch tName conName expected actual =
11091113
, actual
11101114
]
11111115

1112-
lookupField :: Maybe a -> (Value -> Parser a) -> String -> String
1113-
-> Object -> Key -> Parser a
1114-
lookupField maybeDefault pj tName rec obj key =
1116+
lookupFieldOmit :: Maybe a -> (Value -> Parser a) -> String -> String -> Object -> Key -> Parser a
1117+
lookupFieldOmit maybeDefault pj tName rec obj key =
11151118
case KM.lookup key obj of
11161119
Nothing ->
11171120
case maybeDefault of
11181121
Nothing -> unknownFieldFail tName rec (Key.toString key)
11191122
Just x -> pure x
11201123
Just v -> pj v <?> Key key
11211124

1125+
lookupFieldNoOmit :: (Value -> Parser a) -> String -> String -> Object -> Key -> Parser a
1126+
lookupFieldNoOmit pj tName rec obj key =
1127+
case KM.lookup key obj of
1128+
Nothing -> unknownFieldFail tName rec (Key.toString key)
1129+
Just v -> pj v <?> Key key
1130+
11221131
unknownFieldFail :: String -> String -> String -> Parser fail
11231132
unknownFieldFail tName rec key =
11241133
fail $ printf "When parsing the record %s of type %s the key %s was not present."
@@ -1245,20 +1254,26 @@ mkFunCommon consFun jc opts name = do
12451254
!_ <- buildTypeInstance parentName jc ctxt instTys variant
12461255
consFun jc parentName opts instTys cons
12471256

1257+
data FunArg = Omit | Single | Plural deriving (Eq)
1258+
12481259
dispatchFunByType :: JSONClass
12491260
-> JSONFun
12501261
-> Name
12511262
-> TyVarMap
1252-
-> Bool -- True if we are using the function argument that works
1253-
-- on lists (e.g., [a] -> Value). False is we are using
1254-
-- the function argument that works on single values
1255-
-- (e.g., a -> Value).
1263+
-> FunArg -- Plural if we are using the function argument that works
1264+
-- on lists (e.g., [a] -> Value). Single is we are using
1265+
-- the function argument that works on single values
1266+
-- (e.g., a -> Value). Omit if we use it to check omission
1267+
-- (e.g. a -> Bool)
12561268
-> Type
12571269
-> Q Exp
12581270
dispatchFunByType _ jf _ tvMap list (VarT tyName) =
12591271
varE $ case M.lookup tyName tvMap of
1260-
Just (tfjExp, tfjlExp) -> if list then tfjlExp else tfjExp
1261-
Nothing -> jsonFunValOrListName list jf Arity0
1272+
Just (tfjoExp, tfjExp, tfjlExp) -> case list of
1273+
Omit -> tfjoExp
1274+
Single -> tfjExp
1275+
Plural -> tfjlExp
1276+
Nothing -> jsonFunValOrListName list jf Arity0
12621277
dispatchFunByType jc jf conName tvMap list (SigT ty _) =
12631278
dispatchFunByType jc jf conName tvMap list ty
12641279
dispatchFunByType jc jf conName tvMap list (ForallT _ _ ty) =
@@ -1277,24 +1292,29 @@ dispatchFunByType jc jf conName tvMap list ty = do
12771292
tyVarNames :: [Name]
12781293
tyVarNames = M.keys tvMap
12791294

1295+
args :: [Q Exp]
1296+
args
1297+
| list == Omit = map (dispatchFunByType jc jf conName tvMap Omit) rhsArgs
1298+
| otherwise = zipWith (dispatchFunByType jc jf conName tvMap) (cycle [Omit,Single,Plural]) (triple rhsArgs)
1299+
12801300
itf <- isInTypeFamilyApp tyVarNames tyCon tyArgs
12811301
if any (`mentionsName` tyVarNames) lhsArgs || itf
12821302
then outOfPlaceTyVarError jc conName
12831303
else if any (`mentionsName` tyVarNames) rhsArgs
1284-
then appsE $ varE (jsonFunValOrListName list jf $ toEnum numLastArgs)
1285-
: zipWith (dispatchFunByType jc jf conName tvMap)
1286-
(cycle [False,True])
1287-
(interleave rhsArgs rhsArgs)
1304+
then appsE $ varE (jsonFunValOrListName list jf $ toEnum numLastArgs) : args
12881305
else varE $ jsonFunValOrListName list jf Arity0
12891306

1290-
dispatchToJSON
1291-
:: ToJSONFun -> JSONClass -> Name -> TyVarMap -> Type -> Q Exp
1292-
dispatchToJSON target jc n tvMap =
1293-
dispatchFunByType jc (targetToJSONFun target) n tvMap False
1307+
dispatchToJSON :: ToJSONFun -> JSONClass -> Name -> TyVarMap -> Type -> Q Exp
1308+
dispatchToJSON target jc n tvMap = dispatchFunByType jc (targetToJSONFun target) n tvMap Single
1309+
1310+
dispatchOmitField :: JSONClass -> Name -> TyVarMap -> Type -> Q Exp
1311+
dispatchOmitField jc n tvMap = dispatchFunByType jc ToJSON n tvMap Omit
12941312

1295-
dispatchParseJSON
1296-
:: JSONClass -> Name -> TyVarMap -> Type -> Q Exp
1297-
dispatchParseJSON jc n tvMap = dispatchFunByType jc ParseJSON n tvMap False
1313+
dispatchParseJSON :: JSONClass -> Name -> TyVarMap -> Type -> Q Exp
1314+
dispatchParseJSON jc n tvMap = dispatchFunByType jc ParseJSON n tvMap Single
1315+
1316+
dispatchOmittedField :: JSONClass -> Name -> TyVarMap -> Type -> Q Exp
1317+
dispatchOmittedField jc n tvMap = dispatchFunByType jc ParseJSON n tvMap Omit
12981318

12991319
--------------------------------------------------------------------------------
13001320
-- Utility functions
@@ -1565,13 +1585,14 @@ Both.
15651585
-- A mapping of type variable Names to their encoding/decoding function Names.
15661586
-- For example, in a ToJSON2 declaration, a TyVarMap might look like
15671587
--
1568-
-- { a ~> (tj1, tjl1)
1569-
-- , b ~> (tj2, tjl2) }
1588+
-- { a ~> (o1, tj1, tjl1)
1589+
-- , b ~> (o2, tj2, tjl2) }
15701590
--
1571-
-- where a and b are the last two type variables of the datatype, tj1 and tjl1 are
1572-
-- the function arguments of types (a -> Value) and ([a] -> Value), and tj2 and tjl2
1573-
-- are the function arguments of types (b -> Value) and ([b] -> Value).
1574-
type TyVarMap = Map Name (Name, Name)
1591+
-- where a and b are the last two type variables of the datatype,
1592+
-- o1 and o2 are function argument of types (a -> Bool),
1593+
-- tj1 and tjl1 are the function arguments of types (a -> Value)
1594+
-- and ([a] -> Value), and tj2 and tjl2 are the function arguments of types (b -> Value) and ([b] -> Value).
1595+
type TyVarMap = Map Name (Name, Name, Name)
15751596

15761597
-- | Returns True if a Type has kind *.
15771598
hasKindStar :: Type -> Bool
@@ -1616,9 +1637,11 @@ varTToNameMaybe _ = Nothing
16161637
varTToName :: Type -> Name
16171638
varTToName = fromMaybe (error "Not a type variable!") . varTToNameMaybe
16181639

1619-
interleave :: [a] -> [a] -> [a]
1620-
interleave (a1:a1s) (a2:a2s) = a1:a2:interleave a1s a2s
1621-
interleave _ _ = []
1640+
flatten3 :: [(a,a,a)] -> [a]
1641+
flatten3 = foldr (\(a,b,c) xs -> a:b:c:xs) []
1642+
1643+
triple :: [a] -> [a]
1644+
triple = foldr (\x xs -> x:x:x:xs) []
16221645

16231646
-- | Fully applies a type constructor to its type variables.
16241647
applyTyCon :: Name -> [Type] -> Type
@@ -1909,6 +1932,17 @@ jsonClassName (JSONClass From Arity0) = ''FromJSON
19091932
jsonClassName (JSONClass From Arity1) = ''FromJSON1
19101933
jsonClassName (JSONClass From Arity2) = ''FromJSON2
19111934

1935+
jsonFunOmitName :: JSONFun -> Arity -> Name
1936+
jsonFunOmitName ToJSON Arity0 = 'omitField
1937+
jsonFunOmitName ToJSON Arity1 = 'liftOmitField
1938+
jsonFunOmitName ToJSON Arity2 = 'liftOmitField2
1939+
jsonFunOmitName ToEncoding Arity0 = 'omitField
1940+
jsonFunOmitName ToEncoding Arity1 = 'liftOmitField
1941+
jsonFunOmitName ToEncoding Arity2 = 'liftOmitField2
1942+
jsonFunOmitName ParseJSON Arity0 = 'omittedField
1943+
jsonFunOmitName ParseJSON Arity1 = 'liftOmittedField
1944+
jsonFunOmitName ParseJSON Arity2 = 'liftOmittedField2
1945+
19121946
jsonFunValName :: JSONFun -> Arity -> Name
19131947
jsonFunValName ToJSON Arity0 = 'toJSON
19141948
jsonFunValName ToJSON Arity1 = 'liftToJSON
@@ -1931,10 +1965,11 @@ jsonFunListName ParseJSON Arity0 = 'parseJSONList
19311965
jsonFunListName ParseJSON Arity1 = 'liftParseJSONList
19321966
jsonFunListName ParseJSON Arity2 = 'liftParseJSONList2
19331967

1934-
jsonFunValOrListName :: Bool -- e.g., toJSONList if True, toJSON if False
1968+
jsonFunValOrListName :: FunArg -- e.g., toJSONList if True, toJSON if False
19351969
-> JSONFun -> Arity -> Name
1936-
jsonFunValOrListName False = jsonFunValName
1937-
jsonFunValOrListName True = jsonFunListName
1970+
jsonFunValOrListName Omit = jsonFunOmitName
1971+
jsonFunValOrListName Single = jsonFunValName
1972+
jsonFunValOrListName Plural = jsonFunListName
19381973

19391974
arityInt :: JSONClass -> Int
19401975
arityInt = fromEnum . arity

0 commit comments

Comments
 (0)