Add combinators for using omit* stuff in manually written instances

- Add Manual tests
- Cleanup OptionalFields.Common

- More tests: TH/Generics FromJSON doesn't work
- Fix TH
- Fix Generics
- ToJSON1/2 and FromJSON1/2

Author: phadej

aeson.cabal

@@ -171,6 +171,7 @@ test-suite aeson-tests
     UnitTests.OptionalFields
     UnitTests.OptionalFields.Common
     UnitTests.OptionalFields.Generics
+    UnitTests.OptionalFields.Manual
     UnitTests.OptionalFields.TH
 
   build-depends:

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
@@ -151,6 +156,7 @@ module Data.Aeson
     , (.:?)
     , (.:!)
     , (.!=)
+    , (.:?=)
     , object
     -- * Parsing
     , parseIndexedJSON

src/Data/Aeson/TH.hs

@@ -124,7 +124,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 +321,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,8 +462,10 @@ 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') |]
@@ -653,10 +656,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 +925,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
+        | omitNothingFields 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 +946,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 +1114,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 +1255,26 @@ mkFunCommon consFun jc opts name = do
       !_ <- buildTypeInstance parentName jc ctxt instTys variant
       consFun jc parentName opts instTys cons
 
+data FunArg = Omit | Single | Plural
+
 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) =
@@ -1283,18 +1299,21 @@ dispatchFunByType jc jf conName tvMap list ty = do
        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)
+                                   (cycle [Omit,Single,Plural])
+                                   (triple rhsArgs)
             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 Single
 
-dispatchParseJSON
-  :: JSONClass -> Name -> TyVarMap -> Type -> Q Exp
-dispatchParseJSON  jc n tvMap = dispatchFunByType jc ParseJSON  n tvMap False
+dispatchOmittedField :: JSONClass -> Name -> TyVarMap -> Type -> Q Exp
+dispatchOmittedField jc n tvMap = dispatchFunByType jc ParseJSON n tvMap Omit
 
 --------------------------------------------------------------------------------
 -- Utility functions
@@ -1565,13 +1584,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 +1636,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 +1931,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 +1964,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

src/Data/Aeson/Types.hs

@@ -50,6 +50,7 @@ module Data.Aeson.Types
     -- ** Encoding
     , ToJSON(..)
     , KeyValue(..)
+    , KeyValueOmit(..)
 
     -- ** Keys for maps
     , ToJSONKey(..)
@@ -72,14 +73,18 @@ module Data.Aeson.Types
     -- ** Liftings to unary and binary type constructors
     , FromJSON1(..)
     , parseJSON1
+    , omittedField1
     , FromJSON2(..)
     , parseJSON2
+    , omittedField2
     , ToJSON1(..)
     , toJSON1
     , toEncoding1
+    , omitField1
     , ToJSON2(..)
     , toJSON2
     , toEncoding2
+    , omitField2
 
     -- ** Generic JSON classes
     , GFromJSON
@@ -111,13 +116,16 @@ module Data.Aeson.Types
     , (.:?)
     , (.:!)
     , (.!=)
+    , (.:?=)
     , object
     , parseField
     , parseFieldMaybe
     , parseFieldMaybe'
+    , parseFieldOmit
     , explicitParseField
     , explicitParseFieldMaybe
     , explicitParseFieldMaybe'
+    , explicitParseFieldOmit
 
     , listEncoding
     , listValue

src/Data/Aeson/Types/Class.hs

@@ -26,14 +26,18 @@ module Data.Aeson.Types.Class
     -- * Liftings to unary and binary type constructors
     , FromJSON1(..)
     , parseJSON1
+    , omittedField1
     , FromJSON2(..)
     , parseJSON2
+    , omittedField2
     , ToJSON1(..)
     , toJSON1
     , toEncoding1
+    , omitField1
     , ToJSON2(..)
     , toJSON2
     , toEncoding2
+    , omitField2
     -- * Generic JSON classes
     , GFromJSON(..)
     , FromArgs(..)
@@ -67,6 +71,7 @@ module Data.Aeson.Types.Class
     , genericFromJSONKey
     -- * Object key-value pairs
     , KeyValue(..)
+    , KeyValueOmit(..)
 
     -- * List functions
     , listEncoding
@@ -89,14 +94,17 @@ module Data.Aeson.Types.Class
     , parseField
     , parseFieldMaybe
     , parseFieldMaybe'
+    , parseFieldOmit
     , explicitParseField
     , explicitParseFieldMaybe
     , explicitParseFieldMaybe'
+    , explicitParseFieldOmit
     -- ** Operators
     , (.:)
     , (.:?)
     , (.:!)
     , (.!=)
+    , (.:?=)
     ) where