Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Type-directed optional fields #1023

Closed
wants to merge 1 commit into from
Closed

Type-directed optional fields #1023

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
4 changes: 4 additions & 0 deletions aeson.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -168,6 +168,10 @@ test-suite aeson-tests
Types
UnitTests
UnitTests.NullaryConstructors
UnitTests.OptionalFields
UnitTests.OptionalFields.Common
UnitTests.OptionalFields.Generics
UnitTests.OptionalFields.TH

build-depends:
aeson
Expand Down
98 changes: 28 additions & 70 deletions src/Data/Aeson/TH.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -114,11 +114,11 @@ 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)
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
Expand All @@ -135,9 +135,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)
Expand Down Expand Up @@ -456,40 +453,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)
Expand All @@ -514,19 +495,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 <^>
Expand Down Expand Up @@ -953,6 +921,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 $
Expand All @@ -970,6 +941,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)
Expand Down Expand Up @@ -1137,28 +1109,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
Expand Down
89 changes: 64 additions & 25 deletions src/Data/Aeson/Types/FromJSON.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -70,7 +70,6 @@ module Data.Aeson.Types.FromJSON
, (.:?)
, (.:!)
, (.!=)

-- * Internal
, parseOptionalFieldWith
) where
Expand Down Expand Up @@ -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.
--
-- @
-- newtype A = A Int deriving (Generic)
-- instance FromJSON A where omittedField = Just (A 0)
--
-- data R = R { a :: A, b :: Int } deriving ('Generic', 'FromJSON')
--
-- decode "{\"b\":1}" -- Just (R (A 0) 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)
Expand Down Expand Up @@ -1336,34 +1362,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 #-}

--------------------------------------------------------------------------------

Expand Down Expand Up @@ -1507,7 +1545,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)]))
Expand Down Expand Up @@ -2274,6 +2312,7 @@ instance FromJSON1 Semigroup.Option where

instance FromJSON a => FromJSON (Semigroup.Option a) where
parseJSON = parseJSON1
omittedField = Just (Semigroup.Option Nothing)
#endif

-------------------------------------------------------------------------------
Expand Down
Loading