Skip to content

Commit 3738f8d

Browse files
phadejphadej
committed
Higher stuff
1 parent 5c04c58 commit 3738f8d

File tree

11 files changed

+328
-135
lines changed

11 files changed

+328
-135
lines changed

‎src/Data/Aeson.hs

+4
Original file line numberDiff line numberDiff line change
@@ -92,14 +92,18 @@ module Data.Aeson
9292
-- ** Liftings to unary and binary type constructors
9393
, FromJSON1(..)
9494
, parseJSON1
95+
, omittedField1
9596
, FromJSON2(..)
9697
, parseJSON2
98+
, omittedField2
9799
, ToJSON1(..)
98100
, toJSON1
99101
, toEncoding1
102+
, omitField1
100103
, ToJSON2(..)
101104
, toJSON2
102105
, toEncoding2
106+
, omitField2
103107
-- ** Generic JSON classes and options
104108
, GFromJSON
105109
, FromArgs

‎src/Data/Aeson/TH.hs

+19-12
Original file line numberDiff line numberDiff line change
@@ -124,7 +124,7 @@ import Data.Aeson.Key (Key)
124124
import qualified Data.Aeson.Key as Key
125125
import qualified Data.Aeson.KeyMap as KM
126126
import Data.Foldable (foldr')
127-
import Data.List (genericLength, intercalate, partition, union)
127+
import Data.List (genericLength, intercalate, union)
128128
import Data.List.NonEmpty ((<|), NonEmpty((:|)))
129129
import Data.Map (Map)
130130
import qualified Data.Monoid as Monoid
@@ -462,8 +462,10 @@ argsToValue letInsert target jc tvMap opts multiCons
462462
toPair (arg, argTy, fld) =
463463
let fieldName = fieldLabel opts fld
464464
toValue = dispatchToJSON target jc conName tvMap argTy
465+
466+
omitFn :: Q Exp
465467
omitFn
466-
| omitNothingFields opts = [| omitField |]
468+
| omitNothingFields opts = dispatchOmitField jc conName tvMap argTy
467469
| otherwise = [| const False |]
468470
in
469471
[| \f x arg' -> bool x mempty (f arg') |]
@@ -923,9 +925,11 @@ parseRecord jc tvMap argTys opts tName conName fields obj inTaggedObject =
923925
(infixApp (conE conName) [|(<$>)|] x)
924926
xs
925927
where
926-
lookupField = case jc of
927-
JSONClass From Arity0 | omitNothingFields opts -> [| lookupFieldOmit omittedField |]
928-
_ -> [| lookupFieldNoOmit |]
928+
lookupField :: Type -> Q Exp
929+
lookupField argTy
930+
| omitNothingFields opts = [| lookupFieldOmit |] `appE` dispatchOmittedField jc conName tvMap argTy
931+
| otherwise = [| lookupFieldNoOmit |]
932+
929933
tagFieldNameAppender =
930934
if inTaggedObject then (tagFieldName (sumEncoding opts) :) else id
931935
knownFields = appE [|KM.fromList|] $ listE $
@@ -942,7 +946,7 @@ parseRecord jc tvMap argTys opts tName conName fields obj inTaggedObject =
942946
(appE [|show|] (varE unknownFields)))
943947
[]
944948
]
945-
x:xs = [ lookupField
949+
x:xs = [ lookupField argTy
946950
`appE` dispatchParseJSON jc conName tvMap argTy
947951
`appE` litE (stringL $ show tName)
948952
`appE` litE (stringL $ constructorTagModifier opts $ nameBase conName)
@@ -1299,15 +1303,18 @@ dispatchFunByType jc jf conName tvMap list ty = do
12991303
(triple rhsArgs)
13001304
else varE $ jsonFunValOrListName list jf Arity0
13011305

1302-
dispatchToJSON
1303-
:: ToJSONFun -> JSONClass -> Name -> TyVarMap -> Type -> Q Exp
1304-
dispatchToJSON target jc n tvMap =
1305-
dispatchFunByType jc (targetToJSONFun target) n tvMap Single
1306+
dispatchToJSON :: ToJSONFun -> JSONClass -> Name -> TyVarMap -> Type -> Q Exp
1307+
dispatchToJSON target jc n tvMap = dispatchFunByType jc (targetToJSONFun target) n tvMap Single
13061308

1307-
dispatchParseJSON
1308-
:: JSONClass -> Name -> TyVarMap -> Type -> Q Exp
1309+
dispatchOmitField :: JSONClass -> Name -> TyVarMap -> Type -> Q Exp
1310+
dispatchOmitField jc n tvMap = dispatchFunByType jc ToJSON n tvMap Omit
1311+
1312+
dispatchParseJSON :: JSONClass -> Name -> TyVarMap -> Type -> Q Exp
13091313
dispatchParseJSON jc n tvMap = dispatchFunByType jc ParseJSON n tvMap Single
13101314

1315+
dispatchOmittedField :: JSONClass -> Name -> TyVarMap -> Type -> Q Exp
1316+
dispatchOmittedField jc n tvMap = dispatchFunByType jc ParseJSON n tvMap Omit
1317+
13111318
--------------------------------------------------------------------------------
13121319
-- Utility functions
13131320
--------------------------------------------------------------------------------

‎src/Data/Aeson/Types.hs

+4
Original file line numberDiff line numberDiff line change
@@ -73,14 +73,18 @@ module Data.Aeson.Types
7373
-- ** Liftings to unary and binary type constructors
7474
, FromJSON1(..)
7575
, parseJSON1
76+
, omittedField1
7677
, FromJSON2(..)
7778
, parseJSON2
79+
, omittedField2
7880
, ToJSON1(..)
7981
, toJSON1
8082
, toEncoding1
83+
, omitField1
8184
, ToJSON2(..)
8285
, toJSON2
8386
, toEncoding2
87+
, omitField2
8488

8589
-- ** Generic JSON classes
8690
, GFromJSON

‎src/Data/Aeson/Types/Class.hs

+4
Original file line numberDiff line numberDiff line change
@@ -26,14 +26,18 @@ module Data.Aeson.Types.Class
2626
-- * Liftings to unary and binary type constructors
2727
, FromJSON1(..)
2828
, parseJSON1
29+
, omittedField1
2930
, FromJSON2(..)
3031
, parseJSON2
32+
, omittedField2
3133
, ToJSON1(..)
3234
, toJSON1
3335
, toEncoding1
36+
, omitField1
3437
, ToJSON2(..)
3538
, toJSON2
3639
, toEncoding2
40+
, omitField2
3741
-- * Generic JSON classes
3842
, GFromJSON(..)
3943
, FromArgs(..)

‎src/Data/Aeson/Types/FromJSON.hs

+26-14
Original file line numberDiff line numberDiff line change
@@ -241,11 +241,11 @@ class GFromJSON arity f where
241241
gParseJSON :: Options -> FromArgs arity a -> Value -> Parser (f a)
242242

243243
-- | A 'FromArgs' value either stores nothing (for 'FromJSON') or it stores the
244-
-- two function arguments that decode occurrences of the type parameter (for
244+
-- three function arguments that decode occurrences of the type parameter (for
245245
-- 'FromJSON1').
246246
data FromArgs arity a where
247247
NoFromArgs :: FromArgs Zero a
248-
From1Args :: (Value -> Parser a) -> (Value -> Parser [a]) -> FromArgs One a
248+
From1Args :: Maybe a -> (Value -> Parser a) -> (Value -> Parser [a]) -> FromArgs One a
249249

250250
-- | A configurable generic JSON decoder. This function applied to
251251
-- 'defaultOptions' is used as the default for 'parseJSON' when the
@@ -258,9 +258,9 @@ genericParseJSON opts = fmap to . gParseJSON opts NoFromArgs
258258
-- 'defaultOptions' is used as the default for 'liftParseJSON' when the
259259
-- type is an instance of 'Generic1'.
260260
genericLiftParseJSON :: (Generic1 f, GFromJSON One (Rep1 f))
261-
=> Options -> (Value -> Parser a) -> (Value -> Parser [a])
261+
=> Options -> Maybe a -> (Value -> Parser a) -> (Value -> Parser [a])
262262
-> Value -> Parser (f a)
263-
genericLiftParseJSON opts pj pjl = fmap to1 . gParseJSON opts (From1Args pj pjl)
263+
genericLiftParseJSON opts o pj pjl = fmap to1 . gParseJSON opts (From1Args o pj pjl)
264264

265265
-------------------------------------------------------------------------------
266266
-- Class
@@ -626,7 +626,7 @@ class FromJSON1 f where
626626

627627
default liftParseJSON :: (Generic1 f, GFromJSON One (Rep1 f))
628628
=> Maybe a -> (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser (f a)
629-
liftParseJSON _ = genericLiftParseJSON defaultOptions
629+
liftParseJSON = genericLiftParseJSON defaultOptions
630630

631631
liftParseJSONList :: Maybe a -> (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser [f a]
632632
liftParseJSONList o f g v = listParser (liftParseJSON o f g) v
@@ -637,7 +637,7 @@ class FromJSON1 f where
637637
-- | @since 2.1.0.0
638638
instance (Generic1 f, GFromJSON One (Rep1 f)) => FromJSON1 (Generically1 f) where
639639
liftParseJSON :: forall a. Maybe a -> (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser (Generically1 f a)
640-
liftParseJSON _ = coerce (genericLiftParseJSON defaultOptions :: (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser (f a))
640+
liftParseJSON = coerce (genericLiftParseJSON defaultOptions :: Maybe a -> (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser (f a))
641641

642642
-- | Lift the standard 'parseJSON' function through the type constructor.
643643
parseJSON1 :: (FromJSON1 f, FromJSON a) => Value -> Parser (f a)
@@ -991,22 +991,25 @@ instance (FromJSON a) => GFromJSON arity (K1 i a) where
991991
instance GFromJSON One Par1 where
992992
-- Direct occurrences of the last type parameter are decoded with the
993993
-- function passed in as an argument:
994-
gParseJSON _opts (From1Args pj _) = fmap Par1 . pj
994+
gParseJSON _opts (From1Args _ pj _) = fmap Par1 . pj
995995
{-# INLINE gParseJSON #-}
996996

997997
instance (FromJSON1 f) => GFromJSON One (Rec1 f) where
998998
-- Recursive occurrences of the last type parameter are decoded using their
999999
-- FromJSON1 instance:
1000-
gParseJSON _opts (From1Args pj pjl) = fmap Rec1 . liftParseJSON (error "TODO") pj pjl
1000+
gParseJSON _opts (From1Args o pj pjl) = fmap Rec1 . liftParseJSON o pj pjl
10011001
{-# INLINE gParseJSON #-}
10021002

10031003
instance (FromJSON1 f, GFromJSON One g) => GFromJSON One (f :.: g) where
10041004
-- If an occurrence of the last type parameter is nested inside two
10051005
-- composed types, it is decoded by using the outermost type's FromJSON1
10061006
-- instance to generically decode the innermost type:
1007+
--
1008+
-- Note: the ommitedField is not passed here.
1009+
-- This might be related for :.: associated the wrong way in Generics Rep.
10071010
gParseJSON opts fargs =
1008-
let gpj = gParseJSON opts fargs in
1009-
fmap Comp1 . liftParseJSON (error "TODO") gpj (listParser gpj)
1011+
let gpj = gParseJSON opts fargs
1012+
in fmap Comp1 . liftParseJSON Nothing gpj (listParser gpj)
10101013
{-# INLINE gParseJSON #-}
10111014

10121015
--------------------------------------------------------------------------------
@@ -1403,21 +1406,30 @@ instance {-# OVERLAPPABLE #-}
14031406
instance (Selector s, FromJSON a, Generic a, K1 i a ~ Rep a) =>
14041407
RecordFromJSON' arity (S1 s (K1 i a)) where
14051408
recordParseJSON' args@(_ :* _ :* opts :* _) obj =
1406-
recordParseJSONImpl (fmap K1 $ guard (omitNothingFields opts) >> omittedField) gParseJSON args obj
1409+
recordParseJSONImpl (guard (omitNothingFields opts) >> fmap K1 omittedField) gParseJSON args obj
14071410
{-# INLINE recordParseJSON' #-}
14081411

14091412
instance {-# OVERLAPPING #-}
14101413
(Selector s, FromJSON a) =>
14111414
RecordFromJSON' arity (S1 s (Rec0 a)) where
14121415
recordParseJSON' args@(_ :* _ :* opts :* _) obj =
1413-
recordParseJSONImpl (fmap K1 $ guard (omitNothingFields opts) >> omittedField) gParseJSON args obj
1416+
recordParseJSONImpl (guard (omitNothingFields opts) >> fmap K1 omittedField) gParseJSON args obj
14141417
{-# INLINE recordParseJSON' #-}
14151418

1416-
instance (Selector s, GFromJSON arity (Rec1 f), FromJSON1 f) =>
1419+
instance {-# OVERLAPPING #-}
1420+
(Selector s, GFromJSON arity (Rec1 f), FromJSON1 f) =>
14171421
RecordFromJSON' arity (S1 s (Rec1 f)) where
14181422
recordParseJSON' args obj = recordParseJSONImpl Nothing gParseJSON args obj
14191423
{-# INLINE recordParseJSON' #-}
14201424

1425+
instance {-# OVERLAPPING #-}
1426+
(Selector s, GFromJSON One Par1) =>
1427+
RecordFromJSON' One (S1 s Par1) where
1428+
recordParseJSON' args@(_ :* _ :* opts :* From1Args o _ _) obj =
1429+
recordParseJSONImpl (guard (omitNothingFields opts) >> fmap Par1 o) gParseJSON args obj
1430+
{-# INLINE recordParseJSON' #-}
1431+
1432+
14211433
recordParseJSONImpl :: forall s arity a f i
14221434
. (Selector s)
14231435
=> Maybe (f a)
@@ -2358,7 +2370,7 @@ instance (FromJSON a) => FromJSON (Semigroup.WrappedMonoid a) where
23582370

23592371
#if !MIN_VERSION_base(4,16,0)
23602372
instance FromJSON1 Semigroup.Option where
2361-
liftParseJSON p p' = fmap Semigroup.Option . liftParseJSON p p'
2373+
liftParseJSON o p p' = fmap Semigroup.Option . liftParseJSON o p p'
23622374
liftOmittedField _ = Just (Semigroup.Option Nothing)
23632375

23642376
instance FromJSON a => FromJSON (Semigroup.Option a) where

0 commit comments

Comments
 (0)