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
haskell · Jun 15, 2023 · d835b9d · d835b9d
1 parent 2f8ed86
commit d835b9d
Show file tree

Hide file tree

Showing 24 changed files with 1,317 additions and 656 deletions.
diff --git a/aeson.cabal b/aeson.cabal
@@ -165,6 +165,7 @@ test-suite aeson-tests
     PropUtils
     Regression.Issue351
     Regression.Issue571
+    Regression.Issue687
     Regression.Issue967
     SerializationFormatSpec
     Types
@@ -174,9 +175,11 @@ test-suite aeson-tests
     UnitTests.KeyMapInsertWith
     UnitTests.MonadFix
     UnitTests.NullaryConstructors
+    UnitTests.OmitNothingFieldsNote
     UnitTests.OptionalFields
     UnitTests.OptionalFields.Common
     UnitTests.OptionalFields.Generics
+    UnitTests.OptionalFields.Manual
     UnitTests.OptionalFields.TH
     UnitTests.UTCTime
 

diff --git a/changelog.md b/changelog.md
@@ -1,12 +1,30 @@
 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).
 
-### 2.2
-
-* Use `Data.Aeson.Decoding` parsing functions as default in `Data.Aeson`.
-* Move `Data.Aeson.Parser` module into separate `attoparsec-aeson` package, as these parsers are not used by `aeson` itself anymore.
-* Remove `cffi` flag. Then the C implementation for string unescaping was used for `text <2` versions.
-  The new native Haskell implementation introduced in version 2.0.3.0 is at least as fast.
-* Drop instances for `attoparsec.Number`.
+### 2.2.0.0
+
+* Rework how `omitNothingFields` works. Add `allowOmittedFields` as a parsing counterpart.
+
+  New type-class members were added: `omitField :: a -> Bool` to `ToJSON` and `omittedField :: Maybe a` to `FromJSON`.
+  These control which fields can be omitted.
+  The `.:?=`, `.:!=` and `.?=` operators were added to make use of these new members.
+  GHC.Generics and Template Haskell deriving has been updated accordingly.
+
+  In addition to `Maybe` (and `Option`) fields the `Data.Monoid.First` and `Data.Monoid.Last` are also omitted,
+  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`).
+  Additionall "boring" types like `()` and `Proxy` can be omitted as well.
+  As the omitting is now uniform, type arguments are also omitted (also in `Generic1` derived instance).
+
+  Resolves issues
+    [#687](https://github.com/haskell/aeson/issues/687),
+    [#571](https://github.com/haskell/aeson/issues/571),
+    [#792](https://github.com/haskell/aeson/issues/792).
+
+* Use `Data.Aeson.Decoding` parsing functions (introduced in version 2.1.2.0) as default in `Data.Aeson`.
+* 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.
+* 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`.
+* Remove `cffi` flag. Toggling the flag made `aeson` use a C implementation for string unescaping (used for `text <2` versions).
+  The new native Haskell implementation (introduced in version 2.0.3.0) is at least as fast.
+* Drop instances for `Number` from `attoparsec` package.
 * Improve `Arbitrary Value` instance.
 
 ### 2.1.2.1

diff --git a/src/Data/Aeson.hs b/src/Data/Aeson.hs
@@ -76,6 +76,7 @@ module Data.Aeson
     , fromJSON
     , ToJSON(..)
     , KeyValue(..)
+    , KeyValueOmit(..)
     , (<?>)
     , JSONPath
     -- ** Keys for maps
@@ -91,14 +92,18 @@ module Data.Aeson
     -- ** Liftings to unary and binary type constructors
     , FromJSON1(..)
     , parseJSON1
+    , omittedField1
     , FromJSON2(..)
     , parseJSON2
+    , omittedField2
     , ToJSON1(..)
     , toJSON1
     , toEncoding1
+    , omitField1
     , ToJSON2(..)
     , toJSON2
     , toEncoding2
+    , omitField2
     -- ** Generic JSON classes and options
     , GFromJSON
     , FromArgs
@@ -123,6 +128,7 @@ module Data.Aeson
     , constructorTagModifier
     , allNullaryToStringTag
     , omitNothingFields
+    , allowOmittedFields
     , sumEncoding
     , unwrapUnaryRecords
     , tagSingleConstructors
@@ -151,6 +157,8 @@ module Data.Aeson
     , (.:?)
     , (.:!)
     , (.!=)
+    , (.:?=)
+    , (.:!=)
     , object
     -- * Parsing
     , parseIndexedJSON

diff --git a/src/Data/Aeson/Encoding/Internal.hs b/src/Data/Aeson/Encoding/Internal.hs
@@ -115,7 +115,7 @@ instance Ord (Encoding' a) where
     compare (Encoding a) (Encoding b) =
       compare (toLazyByteString a) (toLazyByteString b)
 
--- | @since 2.2
+-- | @since 2.2.0.0
 instance IsString (Encoding' a) where
   fromString = string
 

diff --git a/src/Data/Aeson/TH.hs b/src/Data/Aeson/TH.hs
@@ -114,7 +114,6 @@ module Data.Aeson.TH
 
 import Data.Aeson.Internal.Prelude
 
-import Data.Bool (bool)
 import Data.Char (ord)
 import Data.Aeson (Object, (.:), FromJSON(..), FromJSON1(..), FromJSON2(..), ToJSON(..), ToJSON1(..), ToJSON2(..))
 import Data.Aeson.Types (Options(..), Parser, SumEncoding(..), Value(..), defaultOptions, defaultTaggedObject)
@@ -124,7 +123,7 @@ import Data.Aeson.Key (Key)
 import qualified Data.Aeson.Key as Key
 import qualified Data.Aeson.KeyMap as KM
 import Data.Foldable (foldr')
-import Data.List (genericLength, intercalate, partition, union)
+import Data.List (genericLength, intercalate, union)
 import Data.List.NonEmpty ((<|), NonEmpty((:|)))
 import Data.Map (Map)
 import qualified Data.Monoid as Monoid
@@ -321,10 +320,11 @@ consToValue _ _ _ _ [] =
 
 consToValue target jc opts instTys cons = autoletE liftSBS $ \letInsert -> do
     value <- newName "value"
+    os    <- newNameList "_o"   $ arityInt jc
     tjs   <- newNameList "_tj"  $ arityInt jc
     tjls  <- newNameList "_tjl" $ arityInt jc
-    let zippedTJs      = zip tjs tjls
-        interleavedTJs = interleave tjs tjls
+    let zippedTJs      = zip3 os tjs tjls
+        interleavedTJs = flatten3 zippedTJs
         lastTyVars     = map varTToName $ drop (length instTys - arityInt jc) instTys
         tvMap          = M.fromList $ zip lastTyVars zippedTJs
     lamE (map varP $ interleavedTJs ++ [value]) $
@@ -461,14 +461,16 @@ argsToValue letInsert target jc tvMap opts multiCons
             toPair (arg, argTy, fld) =
               let fieldName = fieldLabel opts fld
                   toValue = dispatchToJSON target jc conName tvMap argTy
+
+                  omitFn :: Q Exp
                   omitFn
-                    | omitNothingFields opts = [| omitField |]
+                    | omitNothingFields opts = dispatchOmitField jc conName tvMap argTy
                     | otherwise = [| const False |]
-              in
-              [| \f x arg' -> bool x mempty (f arg') |]
-                `appE` omitFn
-                `appE` pairE letInsert target fieldName (toValue `appE` arg)
-                `appE` arg
+
+              in condE
+                (omitFn `appE` arg)
+                [| mempty |]
+                (pairE letInsert target fieldName (toValue `appE` arg))
 
             pairs = mconcatE (map toPair argCons)
 
@@ -653,10 +655,11 @@ consFromJSON _ _ _ _ [] =
 
 consFromJSON jc tName opts instTys cons = do
   value <- newName "value"
+  os    <- newNameList "_o"   $ arityInt jc
   pjs   <- newNameList "_pj"  $ arityInt jc
   pjls  <- newNameList "_pjl" $ arityInt jc
-  let zippedPJs      = zip pjs pjls
-      interleavedPJs = interleave pjs pjls
+  let zippedPJs      = zip3 os pjs pjls
+      interleavedPJs = flatten3 zippedPJs
       lastTyVars     = map varTToName $ drop (length instTys - arityInt jc) instTys
       tvMap          = M.fromList $ zip lastTyVars zippedPJs
   lamE (map varP $ interleavedPJs ++ [value]) $ lamExpr value tvMap
@@ -921,9 +924,11 @@ parseRecord jc tvMap argTys opts tName conName fields obj inTaggedObject =
            (infixApp (conE conName) [|(<$>)|] x)
            xs
     where
-      defVal = case jc of
-        JSONClass From Arity0 -> [|omittedField|]
-        _ -> [|Nothing|]
+      lookupField :: Type -> Q Exp
+      lookupField argTy
+        | allowOmittedFields opts = [| lookupFieldOmit |] `appE` dispatchOmittedField jc conName tvMap argTy
+        | otherwise               = [| lookupFieldNoOmit |]
+
       tagFieldNameAppender =
           if inTaggedObject then (tagFieldName (sumEncoding opts) :) else id
       knownFields = appE [|KM.fromList|] $ listE $
@@ -940,8 +945,7 @@ parseRecord jc tvMap argTys opts tName conName fields obj inTaggedObject =
                           (appE [|show|] (varE unknownFields)))
                       []
               ]
-      x:xs = [ [|lookupField|]
-               `appE` defVal
+      x:xs = [ lookupField argTy
                `appE` dispatchParseJSON jc conName tvMap argTy
                `appE` litE (stringL $ show tName)
                `appE` litE (stringL $ constructorTagModifier opts $ nameBase conName)
@@ -1109,16 +1113,21 @@ parseTypeMismatch tName conName expected actual =
           , actual
           ]
 
-lookupField :: Maybe a -> (Value -> Parser a) -> String -> String
-            -> Object -> Key -> Parser a
-lookupField maybeDefault pj tName rec obj key =
+lookupFieldOmit :: Maybe a -> (Value -> Parser a) -> String -> String -> Object -> Key -> Parser a
+lookupFieldOmit maybeDefault pj tName rec obj key =
     case KM.lookup key obj of
       Nothing ->
         case maybeDefault of
           Nothing -> unknownFieldFail tName rec (Key.toString key)
           Just x -> pure x
       Just v  -> pj v <?> Key key
 
+lookupFieldNoOmit :: (Value -> Parser a) -> String -> String -> Object -> Key -> Parser a
+lookupFieldNoOmit pj tName rec obj key =
+    case KM.lookup key obj of
+      Nothing -> unknownFieldFail tName rec (Key.toString key)
+      Just v  -> pj v <?> Key key
+
 unknownFieldFail :: String -> String -> String -> Parser fail
 unknownFieldFail tName rec key =
     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
       !_ <- buildTypeInstance parentName jc ctxt instTys variant
       consFun jc parentName opts instTys cons
 
+data FunArg = Omit | Single | Plural deriving (Eq)
+
 dispatchFunByType :: JSONClass
                   -> JSONFun
                   -> Name
                   -> TyVarMap
-                  -> Bool -- True if we are using the function argument that works
-                          -- on lists (e.g., [a] -> Value). False is we are using
-                          -- the function argument that works on single values
-                          -- (e.g., a -> Value).
+                  -> FunArg -- Plural if we are using the function argument that works
+                            -- on lists (e.g., [a] -> Value). Single is we are using
+                            -- the function argument that works on single values
+                            -- (e.g., a -> Value). Omit if we use it to check omission
+                            -- (e.g. a -> Bool)
                   -> Type
                   -> Q Exp
 dispatchFunByType _ jf _ tvMap list (VarT tyName) =
     varE $ case M.lookup tyName tvMap of
-                Just (tfjExp, tfjlExp) -> if list then tfjlExp else tfjExp
-                Nothing                -> jsonFunValOrListName list jf Arity0
+                Just (tfjoExp, tfjExp, tfjlExp) -> case list of
+                    Omit -> tfjoExp
+                    Single -> tfjExp 
+                    Plural -> tfjlExp
+                Nothing                   -> jsonFunValOrListName list jf Arity0
 dispatchFunByType jc jf conName tvMap list (SigT ty _) =
     dispatchFunByType jc jf conName tvMap list ty
 dispatchFunByType jc jf conName tvMap list (ForallT _ _ ty) =
@@ -1277,24 +1292,29 @@ dispatchFunByType jc jf conName tvMap list ty = do
         tyVarNames :: [Name]
         tyVarNames = M.keys tvMap
 
+        args :: [Q Exp]
+        args
+            | list == Omit = map     (dispatchFunByType jc jf conName tvMap  Omit)                        rhsArgs
+            | otherwise    = zipWith (dispatchFunByType jc jf conName tvMap) (cycle [Omit,Single,Plural]) (triple rhsArgs)
+
     itf <- isInTypeFamilyApp tyVarNames tyCon tyArgs
     if any (`mentionsName` tyVarNames) lhsArgs || itf
        then outOfPlaceTyVarError jc conName
        else if any (`mentionsName` tyVarNames) rhsArgs
-            then appsE $ varE (jsonFunValOrListName list jf $ toEnum numLastArgs)
-                         : zipWith (dispatchFunByType jc jf conName tvMap)
-                                   (cycle [False,True])
-                                   (interleave rhsArgs rhsArgs)
+            then appsE $ varE (jsonFunValOrListName list jf $ toEnum numLastArgs) : args
             else varE $ jsonFunValOrListName list jf Arity0
 
-dispatchToJSON
-  :: ToJSONFun -> JSONClass -> Name -> TyVarMap -> Type -> Q Exp
-dispatchToJSON target jc n tvMap =
-    dispatchFunByType jc (targetToJSONFun target) n tvMap False
+dispatchToJSON :: ToJSONFun -> JSONClass -> Name -> TyVarMap -> Type -> Q Exp
+dispatchToJSON target jc n tvMap = dispatchFunByType jc (targetToJSONFun target) n tvMap Single
+
+dispatchOmitField :: JSONClass -> Name -> TyVarMap -> Type -> Q Exp
+dispatchOmitField jc n tvMap = dispatchFunByType jc ToJSON n tvMap Omit
 
-dispatchParseJSON
-  :: JSONClass -> Name -> TyVarMap -> Type -> Q Exp
-dispatchParseJSON  jc n tvMap = dispatchFunByType jc ParseJSON  n tvMap False
+dispatchParseJSON :: JSONClass -> Name -> TyVarMap -> Type -> Q Exp
+dispatchParseJSON  jc n tvMap = dispatchFunByType jc ParseJSON  n tvMap Single
+
+dispatchOmittedField :: JSONClass -> Name -> TyVarMap -> Type -> Q Exp
+dispatchOmittedField jc n tvMap = dispatchFunByType jc ParseJSON n tvMap Omit
 
 --------------------------------------------------------------------------------
 -- Utility functions
@@ -1565,13 +1585,14 @@ Both.
 -- A mapping of type variable Names to their encoding/decoding function Names.
 -- For example, in a ToJSON2 declaration, a TyVarMap might look like
 --
--- { a ~> (tj1, tjl1)
--- , b ~> (tj2, tjl2) }
+-- { a ~> (o1, tj1, tjl1)
+-- , b ~> (o2, tj2, tjl2) }
 --
--- where a and b are the last two type variables of the datatype, tj1 and tjl1 are
--- the function arguments of types (a -> Value) and ([a] -> Value), and tj2 and tjl2
--- are the function arguments of types (b -> Value) and ([b] -> Value).
-type TyVarMap = Map Name (Name, Name)
+-- where a and b are the last two type variables of the datatype,
+-- o1 and o2 are function argument of types (a -> Bool),
+-- tj1 and tjl1 are the function arguments of types (a -> Value)
+-- and ([a] -> Value), and tj2 and tjl2 are the function arguments of types (b -> Value) and ([b] -> Value).
+type TyVarMap = Map Name (Name, Name, Name)
 
 -- | Returns True if a Type has kind *.
 hasKindStar :: Type -> Bool
@@ -1616,9 +1637,11 @@ varTToNameMaybe _          = Nothing
 varTToName :: Type -> Name
 varTToName = fromMaybe (error "Not a type variable!") . varTToNameMaybe
 
-interleave :: [a] -> [a] -> [a]
-interleave (a1:a1s) (a2:a2s) = a1:a2:interleave a1s a2s
-interleave _        _        = []
+flatten3 :: [(a,a,a)] -> [a]
+flatten3 = foldr (\(a,b,c) xs -> a:b:c:xs) []
+
+triple :: [a] -> [a]
+triple = foldr (\x xs -> x:x:x:xs) []
 
 -- | Fully applies a type constructor to its type variables.
 applyTyCon :: Name -> [Type] -> Type
@@ -1909,6 +1932,17 @@ jsonClassName (JSONClass From Arity0) = ''FromJSON
 jsonClassName (JSONClass From Arity1) = ''FromJSON1
 jsonClassName (JSONClass From Arity2) = ''FromJSON2
 
+jsonFunOmitName :: JSONFun -> Arity -> Name
+jsonFunOmitName ToJSON     Arity0 = 'omitField
+jsonFunOmitName ToJSON     Arity1 = 'liftOmitField
+jsonFunOmitName ToJSON     Arity2 = 'liftOmitField2
+jsonFunOmitName ToEncoding Arity0 = 'omitField
+jsonFunOmitName ToEncoding Arity1 = 'liftOmitField
+jsonFunOmitName ToEncoding Arity2 = 'liftOmitField2
+jsonFunOmitName ParseJSON  Arity0 = 'omittedField
+jsonFunOmitName ParseJSON  Arity1 = 'liftOmittedField
+jsonFunOmitName ParseJSON  Arity2 = 'liftOmittedField2
+
 jsonFunValName :: JSONFun -> Arity -> Name
 jsonFunValName ToJSON     Arity0 = 'toJSON
 jsonFunValName ToJSON     Arity1 = 'liftToJSON
@@ -1931,10 +1965,11 @@ jsonFunListName ParseJSON  Arity0 = 'parseJSONList
 jsonFunListName ParseJSON  Arity1 = 'liftParseJSONList
 jsonFunListName ParseJSON  Arity2 = 'liftParseJSONList2
 
-jsonFunValOrListName :: Bool -- e.g., toJSONList if True, toJSON if False
+jsonFunValOrListName :: FunArg -- e.g., toJSONList if True, toJSON if False
                      -> JSONFun -> Arity -> Name
-jsonFunValOrListName False = jsonFunValName
-jsonFunValOrListName True  = jsonFunListName
+jsonFunValOrListName Omit   = jsonFunOmitName
+jsonFunValOrListName Single = jsonFunValName
+jsonFunValOrListName Plural = jsonFunListName
 
 arityInt :: JSONClass -> Int
 arityInt = fromEnum . arity