Type-directed optional fields

haskell · Jun 9, 2023 · 59c7a73 · 59c7a73
1 parent 17f8946
commit 59c7a73
Show file tree

Hide file tree

Showing 13 changed files with 413 additions and 176 deletions.
diff --git a/aeson.cabal b/aeson.cabal
@@ -175,6 +175,10 @@ test-suite aeson-tests
     Types
     UnitTests
     UnitTests.NullaryConstructors
+    UnitTests.OptionalFields
+    UnitTests.OptionalFields.Common
+    UnitTests.OptionalFields.Generics
+    UnitTests.OptionalFields.TH
 
   build-depends:
       aeson

diff --git a/src/Data/Aeson.hs b/src/Data/Aeson.hs
@@ -160,11 +160,10 @@ module Data.Aeson
 
 import Control.Exception (Exception (..))
 import Control.Monad.Catch (MonadThrow (..))
-import Data.Aeson.Types.FromJSON (ifromJSON, parseIndexedJSON)
+import Data.Aeson.Types.FromJSON (parseIndexedJSON)
 import Data.Aeson.Encoding (encodingToLazyByteString)
 import Data.Aeson.Parser.Internal (decodeWith, decodeStrictWith, eitherDecodeWith, eitherDecodeStrictWith, jsonEOF, json, jsonEOF', json')
 import Data.Aeson.Types
-import Data.Aeson.Types.Internal (formatError)
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as L
 

diff --git a/src/Data/Aeson/TH.hs b/src/Data/Aeson/TH.hs
@@ -118,7 +118,6 @@ import Data.Char (ord)
 import Data.Aeson (Object, (.:), FromJSON(..), FromJSON1(..), FromJSON2(..), ToJSON(..), ToJSON1(..), ToJSON2(..))
 import Data.Aeson.Types (Options(..), Parser, SumEncoding(..), Value(..), defaultOptions, defaultTaggedObject)
 import Data.Aeson.Types.Internal ((<?>), JSONPathElement(Key))
-import Data.Aeson.Types.FromJSON (parseOptionalFieldWith)
 import Data.Aeson.Types.ToJSON (fromPairs, pair)
 import Data.Aeson.Key (Key)
 import qualified Data.Aeson.Key as Key
@@ -135,9 +134,6 @@ import Text.Printf (printf)
 import qualified Data.Aeson.Encoding.Internal as E
 import qualified Data.List.NonEmpty as NE (length, reverse)
 import qualified Data.Map as M (fromList, keys, lookup , singleton, size)
-#if !MIN_VERSION_base(4,16,0)
-import qualified Data.Semigroup as Semigroup (Option(..))
-#endif
 import qualified Data.Set as Set (empty, insert, member)
 import qualified Data.Text as T (pack, unpack)
 import qualified Data.Vector as V (unsafeIndex, null, length, create, empty)
@@ -456,40 +452,24 @@ argsToValue letInsert target jc tvMap opts multiCons
       (True,True,[_]) -> argsToValue letInsert target jc tvMap opts multiCons
                                      (info{constructorVariant = NormalConstructor})
       _ -> do
+
         argTys' <- mapM resolveTypeSynonyms argTys
         args <- newNameList "arg" $ length argTys'
-        let pairs | omitNothingFields opts = infixApp maybeFields
-                                                      [|(Monoid.<>)|]
-                                                      restFields
-                  | otherwise = mconcatE (map pureToPair argCons)
-
-            argCons = zip3 (map varE args) argTys' fields
-
-            maybeFields = mconcatE (map maybeToPair maybes)
-
-            restFields = mconcatE (map pureToPair rest)
-
-            (maybes0, rest0) = partition isMaybe argCons
-#if MIN_VERSION_base(4,16,0)
-            maybes = maybes0
-            rest   = rest0
-#else
-            (options, rest) = partition isOption rest0
-            maybes = maybes0 ++ map optionToMaybe options
-#endif
-
-            maybeToPair = toPairLifted True
-            pureToPair = toPairLifted False
-
-            toPairLifted lifted (arg, argTy, field) =
-              let toValue = dispatchToJSON target jc conName tvMap argTy
-                  fieldName = fieldLabel opts field
-                  e arg' = pairE letInsert target fieldName (toValue `appE` arg')
-              in if lifted
-                then do
-                  x <- newName "x"
-                  [|maybe mempty|] `appE` lam1E (varP x) (e (varE x)) `appE` arg
-                else e arg
+        let argCons = zip3 (map varE args) argTys' fields
+
+            toPair (arg, argTy, fld) =
+              let fieldName = fieldLabel opts fld
+                  toValue = dispatchToJSON target jc conName tvMap argTy
+                  omitFn
+                    | omitNothingFields opts = [| omitField |]
+                    | otherwise = [| const False |]
+              in
+              [| \f x arg' -> bool x mempty (f arg') |]
+                `appE` omitFn
+                `appE` pairE letInsert target fieldName (toValue `appE` arg)
+                `appE` arg
+
+            pairs = mconcatE (map toPair argCons)
 
         match (conP conName $ map varP args)
               (normalB $ recordSumToValue letInsert target opts multiCons (null argTys) conName pairs)
@@ -514,19 +494,6 @@ argsToValue letInsert target jc tvMap opts multiCons
           )
           []
 
-isMaybe :: (a, Type, b) -> Bool
-isMaybe (_, AppT (ConT t) _, _) = t == ''Maybe
-isMaybe _                       = False
-
-#if !MIN_VERSION_base(4,16,0)
-isOption :: (a, Type, b) -> Bool
-isOption (_, AppT (ConT t) _, _) = t == ''Semigroup.Option
-isOption _                       = False
-
-optionToMaybe :: (ExpQ, b, c) -> (ExpQ, b, c)
-optionToMaybe (a, b, c) = ([|Semigroup.getOption|] `appE` a, b, c)
-#endif
-
 (<^>) :: ExpQ -> ExpQ -> ExpQ
 (<^>) a b = infixApp a [|(E.><)|] b
 infixr 6 <^>
@@ -953,6 +920,9 @@ 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|]
       tagFieldNameAppender =
           if inTaggedObject then (tagFieldName (sumEncoding opts) :) else id
       knownFields = appE [|KM.fromList|] $ listE $
@@ -970,6 +940,7 @@ parseRecord jc tvMap argTys opts tName conName fields obj inTaggedObject =
                       []
               ]
       x:xs = [ [|lookupField|]
+               `appE` defVal
                `appE` dispatchParseJSON jc conName tvMap argTy
                `appE` litE (stringL $ show tName)
                `appE` litE (stringL $ constructorTagModifier opts $ nameBase conName)
@@ -1137,28 +1108,14 @@ parseTypeMismatch tName conName expected actual =
           , actual
           ]
 
-class LookupField a where
-    lookupField :: (Value -> Parser a) -> String -> String
-                -> Object -> Key -> Parser a
-
-instance {-# OVERLAPPABLE #-} LookupField a where
-    lookupField = lookupFieldWith
-
-instance {-# INCOHERENT #-} LookupField (Maybe a) where
-    lookupField pj _ _ = parseOptionalFieldWith pj
-
-#if !MIN_VERSION_base(4,16,0)
-instance {-# INCOHERENT #-} LookupField (Semigroup.Option a) where
-    lookupField pj tName rec obj key =
-        fmap Semigroup.Option
-             (lookupField (fmap Semigroup.getOption . pj) tName rec obj key)
-#endif
-
-lookupFieldWith :: (Value -> Parser a) -> String -> String
-                -> Object -> Key -> Parser a
-lookupFieldWith pj tName rec obj key =
+lookupField :: Maybe a -> (Value -> Parser a) -> String -> String
+            -> Object -> Key -> Parser a
+lookupField maybeDefault pj tName rec obj key =
     case KM.lookup key obj of
-      Nothing -> unknownFieldFail tName rec (Key.toString key)
+      Nothing ->
+        case maybeDefault of
+          Nothing -> unknownFieldFail tName rec (Key.toString key)
+          Just x -> pure x
       Just v  -> pj v <?> Key key
 
 unknownFieldFail :: String -> String -> String -> Parser fail

diff --git a/src/Data/Aeson/Types/FromJSON.hs b/src/Data/Aeson/Types/FromJSON.hs
@@ -70,7 +70,6 @@ module Data.Aeson.Types.FromJSON
     , (.:?)
     , (.:!)
     , (.!=)
-
     -- * Internal
     , parseOptionalFieldWith
     ) where
@@ -379,6 +378,33 @@ class FromJSON a where
         . V.toList
         $ a
 
+    -- | Default value for optional fields.
+    --
+    -- Defining @omittedField = 'Just' x@ makes object fields of this type optional.
+    -- When the field is omitted, the default value @x@ will be used.
+    --
+    -- @
+    --   data R = R { a :: A, b :: Int } deriving ('Generic', 'FromJSON')
+    --
+    --   newtype A = A Int deriving (Generic)
+    --   instance FromJSON A where omittedField = Just 5
+    --
+    --   decode "{\"b\":1}" -- Just (R (A 5) 1)
+    -- @
+    --
+    -- Defining @omittedField = 'Nothing'@ makes object fields of this type required.
+    --
+    -- @
+    --   omittedField :: Maybe Int -- Nothing
+    --   decode "{\"a\":1}" -- Nothing
+    -- @
+    --
+    -- The default implementation is @omittedField = Nothing@.
+    --
+    -- @since x.x.x.x
+    omittedField :: Maybe a
+    omittedField = Nothing
+
 -- | @since 2.1.0.0
 instance (Generic a, GFromJSON Zero (Rep a)) => FromJSON (Generically a) where
     parseJSON = coerce (genericParseJSON defaultOptions :: Value -> Parser a)
@@ -1330,34 +1356,46 @@ instance ( RecordFromJSON' arity a
               <*> recordParseJSON' p obj
     {-# INLINE recordParseJSON' #-}
 
-instance {-# OVERLAPPABLE #-} (Selector s, GFromJSON arity a) =>
-         RecordFromJSON' arity (S1 s a) where
-    recordParseJSON' (cname :* tname :* opts :* fargs) obj = do
-        fv <- contextCons cname tname (obj .: label)
-        M1 <$> gParseJSON opts fargs fv <?> Key label
-      where
-        label = Key.fromString $ fieldLabelModifier opts sname
-        sname = selName (undefined :: M1 _i s _f _p)
+instance {-# OVERLAPPABLE #-}
+         RecordFromJSON' arity f => RecordFromJSON' arity (M1 i s f) where
+    recordParseJSON' args obj = M1 <$> recordParseJSON' args obj
     {-# INLINE recordParseJSON' #-}
 
-instance {-# INCOHERENT #-} (Selector s, FromJSON a) =>
-         RecordFromJSON' arity (S1 s (K1 i (Maybe a))) where
-    recordParseJSON' (_ :* _ :* opts :* _) obj = M1 . K1 <$> obj .:? label
-      where
-        label = Key.fromString $ fieldLabelModifier opts sname
-        sname = selName (undefined :: M1 _i s _f _p)
+instance (Selector s, FromJSON a, Generic a, K1 i a ~ Rep a) =>
+         RecordFromJSON' arity (S1 s (K1 i a)) where
+    recordParseJSON' args obj =
+      recordParseJSONImpl (fmap K1 omittedField) gParseJSON args obj
     {-# INLINE recordParseJSON' #-}
 
-#if !MIN_VERSION_base(4,16,0)
--- Parse an Option like a Maybe.
-instance {-# INCOHERENT #-} (Selector s, FromJSON a) =>
-         RecordFromJSON' arity (S1 s (K1 i (Semigroup.Option a))) where
-    recordParseJSON' p obj = wrap <$> recordParseJSON' p obj
-      where
-        wrap :: S1 s (K1 i (Maybe a)) p -> S1 s (K1 i (Semigroup.Option a)) p
-        wrap (M1 (K1 a)) = M1 (K1 (Semigroup.Option a))
+instance {-# OVERLAPPING #-}
+         (Selector s, FromJSON a) =>
+         RecordFromJSON' arity (S1 s (Rec0 a)) where
+    recordParseJSON' args obj =
+      recordParseJSONImpl (fmap K1 omittedField) gParseJSON args obj
+    {-# INLINE recordParseJSON' #-}
+
+instance (Selector s, GFromJSON arity (Rec1 f), FromJSON1 f) =>
+         RecordFromJSON' arity (S1 s (Rec1 f)) where
+    recordParseJSON' args obj = recordParseJSONImpl Nothing gParseJSON args obj
     {-# INLINE recordParseJSON' #-}
-#endif
+
+recordParseJSONImpl :: forall s arity a f i
+                     . (Selector s)
+                    => Maybe (f a)
+                    -> (Options -> FromArgs arity a -> Value -> Parser (f a))
+                    -> (ConName :* TypeName :* Options :* FromArgs arity a)
+                    -> Object -> Parser (M1 i s f a)
+recordParseJSONImpl mdef parseVal (cname :* tname :* opts :* fargs) obj =
+  handleMissingKey (M1 <$> mdef) $ do
+    fv <- contextCons cname tname (obj .: label)
+    M1 <$> parseVal opts fargs fv <?> Key label
+  where
+    handleMissingKey Nothing p = p
+    handleMissingKey (Just def) p = if label `KM.member` obj then p else pure def
+
+    label = Key.fromString $ fieldLabelModifier opts sname
+    sname = selName (undefined :: M1 _i s _f _p)
+{-# INLINE recordParseJSONImpl #-}
 
 --------------------------------------------------------------------------------
 
@@ -1501,7 +1539,7 @@ instance FromJSON1 Maybe where
 
 instance (FromJSON a) => FromJSON (Maybe a) where
     parseJSON = parseJSON1
-
+    omittedField = Just Nothing
 
 instance FromJSON2 Either where
     liftParseJSON2 pA _ pB _ (Object (KM.toList -> [(key, value)]))
@@ -2276,6 +2314,7 @@ instance FromJSON1 Semigroup.Option where
 
 instance FromJSON a => FromJSON (Semigroup.Option a) where
     parseJSON = parseJSON1
+    omittedField = Just (Semigroup.Option Nothing)
 #endif
 
 -------------------------------------------------------------------------------