84ef299 · typeable/aeson

git.iko.soy/typeable/aeson

on master help sign in

Merge pull request #629 from Lysxia/bug-627

84ef299Adam Bergmark9 years ago

Data/Aeson/Types/FromJSON.hs+22−27

compare with master

unifiedsplit

@@ -976,7 +976,7 @@ instance ( IsRecord f isRecord

976

977instance (FromRecord arity f) => FromTaggedObject'' arity f True where

978 parseFromTaggedObject'' opts fargs _ =

979− Tagged . parseRecord opts fargs Nothing

979+ Tagged . parseRecord opts fargs

980

981instance (GFromJSON arity f) => FromTaggedObject'' arity f False where

982 parseFromTaggedObject'' opts fargs contentsFieldName = Tagged .

@@ -993,57 +993,52 @@ class ConsFromJSON arity f where

993

994class ConsFromJSON' arity f isRecord where

995 consParseJSON' :: Options -> FromArgs arity a

996− -> Maybe Text -- ^ A dummy label

997− -- (Nothing to use proper label)

998 -> Value -> Tagged isRecord (Parser (f a))

996 -> Value -> Tagged isRecord (Parser (f a))

999

997

1000instance ( IsRecord f isRecord

998instance ( IsRecord f isRecord

1001 , ConsFromJSON' arity f isRecord

999 , ConsFromJSON' arity f isRecord

1002 ) => ConsFromJSON arity f where

1000 ) => ConsFromJSON arity f where

1003− consParseJSON opts fargs v = let

1001+ consParseJSON opts fargs =

1004− (v2,lab) = case (unwrapUnaryRecords opts,isUnary (undefined :: f a)) of

1005− -- use a dummy object with a dummy label

1006− (True,True) -> (object [(pack "dummy",v)], Just $ pack "dummy")

1007− _ ->(v,Nothing)

1008− in (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a))

1002+ (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a))

1009− $ consParseJSON' opts fargs lab v2

1003+ . consParseJSON' opts fargs

1010

1004

1005+instance OVERLAPPING_

1006+ ( GFromJSON arity a, FromRecord arity (S1 s a)

1007+ ) => ConsFromJSON' arity (S1 s a) True where

1008+ consParseJSON' opts fargs

1009+ | unwrapUnaryRecords opts = Tagged . gParseJSON opts fargs

1010+ | otherwise = Tagged . withObject "unary record" (parseRecord opts fargs)

1011

1012−instance (FromRecord arity f) => ConsFromJSON' arity f True where

1012+instance FromRecord arity f => ConsFromJSON' arity f True where

1013− consParseJSON' opts fargs mlab = Tagged . withObject "record (:*:)"

1013+ consParseJSON' opts fargs =

1014− (parseRecord opts fargs mlab)

1014+ Tagged . withObject "record (:*:)" (parseRecord opts fargs)

1015

1016−instance (GFromJSON arity f) => ConsFromJSON' arity f False where

1016+instance GFromJSON arity f => ConsFromJSON' arity f False where

1017− consParseJSON' opts fargs _ = Tagged . gParseJSON opts fargs

1017+ consParseJSON' opts fargs = Tagged . gParseJSON opts fargs

1018

1019--------------------------------------------------------------------------------

1020

1021class FromRecord arity f where

1022 parseRecord :: Options -> FromArgs arity a

1023− -> Maybe Text -- ^ A dummy label

1024− -- (Nothing to use proper label)

1025 -> Object -> Parser (f a)

1023 -> Object -> Parser (f a)

1026

1024

1027instance ( FromRecord arity a

1025instance ( FromRecord arity a

1028 , FromRecord arity b

1026 , FromRecord arity b

1029 ) => FromRecord arity (a :*: b) where

1027 ) => FromRecord arity (a :*: b) where

1030− parseRecord opts fargs _ obj =

1028+ parseRecord opts fargs obj =

1031− (:*:) <$> parseRecord opts fargs Nothing obj

1029+ (:*:) <$> parseRecord opts fargs obj

1032− <*> parseRecord opts fargs Nothing obj

1030+ <*> parseRecord opts fargs obj

1033

1031

1034instance OVERLAPPABLE_ (Selector s, GFromJSON arity a) =>

1032instance OVERLAPPABLE_ (Selector s, GFromJSON arity a) =>

1035 FromRecord arity (S1 s a) where

1033 FromRecord arity (S1 s a) where

1036− parseRecord opts fargs lab =

1034+ parseRecord opts fargs =

1037 (<?> Key label) . gParseJSON opts fargs <=< (.: label)

1035 (<?> Key label) . gParseJSON opts fargs <=< (.: label)

1038 where

1036 where

1039− label = fromMaybe defLabel lab

1040− defLabel = pack . fieldLabelModifier opts $

1037+ label = pack . fieldLabelModifier opts $ selName (undefined :: t s a p)

1041− selName (undefined :: t s a p)

1042

1038

1043instance INCOHERENT_ (Selector s, FromJSON a) =>

1039instance INCOHERENT_ (Selector s, FromJSON a) =>

1044 FromRecord arity (S1 s (K1 i (Maybe a))) where

1040 FromRecord arity (S1 s (K1 i (Maybe a))) where

1045− parseRecord _ _ (Just lab) obj = M1 . K1 <$> obj .:? lab

1046− parseRecord opts _ Nothing obj = M1 . K1 <$> obj .:? pack label

1041+ parseRecord opts _ obj = M1 . K1 <$> obj .:? pack label

1047 where

1042 where

1048 label = fieldLabelModifier opts $

1043 label = fieldLabelModifier opts $

1049 selName (undefined :: t s (K1 i (Maybe a)) p)

1044 selName (undefined :: t s (K1 i (Maybe a)) p)

@@ -1051,7 +1046,7 @@ instance INCOHERENT_ (Selector s, FromJSON a) =>

1051-- Parse an Option like a Maybe.

1046-- Parse an Option like a Maybe.

1052instance INCOHERENT_ (Selector s, FromJSON a) =>

1047instance INCOHERENT_ (Selector s, FromJSON a) =>

1053 FromRecord arity (S1 s (K1 i (Semigroup.Option a))) where

1048 FromRecord arity (S1 s (K1 i (Semigroup.Option a))) where

1054− parseRecord opts fargs lab obj = wrap <$> parseRecord opts fargs lab obj

1049+ parseRecord opts fargs obj = wrap <$> parseRecord opts fargs obj

1055 where

1050 where

1056 wrap :: S1 s (K1 i (Maybe a)) p -> S1 s (K1 i (Semigroup.Option a)) p

1051 wrap :: S1 s (K1 i (Maybe a)) p -> S1 s (K1 i (Semigroup.Option a)) p

1057 wrap (M1 (K1 a)) = M1 (K1 (Semigroup.Option a))

1052 wrap (M1 (K1 a)) = M1 (K1 (Semigroup.Option a))

Data/Aeson/Types/Generic.hs−5

@@ -44,12 +44,8 @@ import GHC.Generics

44--------------------------------------------------------------------------------

46class IsRecord (f :: * -> *) isRecord | f -> isRecord

47− where

48− isUnary :: f a -> Bool

49− isUnary = const True

51instance (IsRecord f isRecord) => IsRecord (f :*: g) isRecord

48instance (IsRecord f isRecord) => IsRecord (f :*: g) isRecord

52− where isUnary = const False

53#if MIN_VERSION_base(4,9,0)

49#if MIN_VERSION_base(4,9,0)

54instance OVERLAPPING_ IsRecord (M1 S ('MetaSel 'Nothing u ss ds) f) False

50instance OVERLAPPING_ IsRecord (M1 S ('MetaSel 'Nothing u ss ds) f) False

55#else

51#else

@@ -61,7 +57,6 @@ instance IsRecord Par1 True

61instance IsRecord (Rec1 f) True

57instance IsRecord (Rec1 f) True

62instance IsRecord (f :.: g) True

58instance IsRecord (f :.: g) True

63instance IsRecord U1 False

59instance IsRecord U1 False

64− where isUnary = const False

66--------------------------------------------------------------------------------

61--------------------------------------------------------------------------------

Data/Aeson/Types/ToJSON.hs+14−10

@@ -956,7 +956,6 @@ class ConsToJSON enc arity f where

956

957class ConsToJSON' enc arity f isRecord where

958 consToJSON' :: Options -> ToArgs enc arity a

959− -> Bool -- ^ Are we a record with one field?

960 -> f a -> Tagged isRecord enc

959 -> f a -> Tagged isRecord enc

961

960

962instance ( IsRecord f isRecord

961instance ( IsRecord f isRecord

@@ -965,23 +964,28 @@ instance ( IsRecord f isRecord

965 where

964 where

966 consToJSON opts targs =

965 consToJSON opts targs =

967 (unTagged :: Tagged isRecord enc -> enc)

966 (unTagged :: Tagged isRecord enc -> enc)

968− . consToJSON' opts targs (isUnary (undefined :: f a))

967+ . consToJSON' opts targs

969 {-# INLINE consToJSON #-}

968 {-# INLINE consToJSON #-}

970

969

970+instance OVERLAPPING_

971−instance ( RecordToPairs enc pairs arity f

971+ ( RecordToPairs enc pairs arity (S1 s f)

972 , FromPairs enc pairs

973 , GToJSON enc arity f

974− ) => ConsToJSON' enc arity f True

974+ ) => ConsToJSON' enc arity (S1 s f) True

975 where

976− consToJSON' opts targs isUn =

976+ consToJSON' opts targs

977− Tagged .

978− case (isUn, unwrapUnaryRecords opts) of

977+ | unwrapUnaryRecords opts = Tagged . gToJSON opts targs

979− (True, True) -> gToJSON opts targs

980− _ -> fromPairs . recordToPairs opts targs

978+ | otherwise = Tagged . fromPairs . recordToPairs opts targs

981 {-# INLINE consToJSON' #-}

979 {-# INLINE consToJSON' #-}

982

980

981+instance ( RecordToPairs enc pairs arity f

982+ , FromPairs enc pairs

983+ ) => ConsToJSON' enc arity f True

984+ where

985+ consToJSON' opts targs = Tagged . fromPairs . recordToPairs opts targs

986+

983instance GToJSON enc arity f => ConsToJSON' enc arity f False where

987instance GToJSON enc arity f => ConsToJSON' enc arity f False where

984− consToJSON' opts targs _ = Tagged . gToJSON opts targs

988+ consToJSON' opts targs = Tagged . gToJSON opts targs

985 {-# INLINE consToJSON' #-}

989 {-# INLINE consToJSON' #-}

986

990

987--------------------------------------------------------------------------------

991--------------------------------------------------------------------------------

tests/UnitTests.hs+12

@@ -99,6 +99,7 @@ tests = testGroup "unit" [

99 , testCase "Show Options" showOptions

100 , testGroup "SingleMaybeField" singleMaybeField

101 , testCase "withEmbeddedJSON" withEmbeddedJSONTest

102+ , testCase "SingleFieldCon" singleFieldCon

102 ]

103 ]

103

104

104roundTripCamel :: String -> Assertion

105roundTripCamel :: String -> Assertion

@@ -534,6 +535,17 @@ withEmbeddedJSONTest :: Assertion

534withEmbeddedJSONTest =

535withEmbeddedJSONTest =

535 assertEqual "Unquote embedded JSON" (Right $ EmbeddedJSONTest 1) (eitherDecode "{\"prop\":\"1\"}")

536 assertEqual "Unquote embedded JSON" (Right $ EmbeddedJSONTest 1) (eitherDecode "{\"prop\":\"1\"}")

536

537

538+-- Regression test for https://github.com/bos/aeson/issues/627

539+newtype SingleFieldCon = SingleFieldCon Int deriving (Eq, Show, Generic)

540+

541+instance FromJSON SingleFieldCon where

542+ parseJSON = genericParseJSON defaultOptions{unwrapUnaryRecords=True}

543+ -- This option should have no effect on this type

544+

545+singleFieldCon :: Assertion

546+singleFieldCon =

547+ assertEqual "fromJSON" (Right (SingleFieldCon 0)) (eitherDecode "0")

548+

537deriveJSON defaultOptions{omitNothingFields=True} ''MyRecord

549deriveJSON defaultOptions{omitNothingFields=True} ''MyRecord

538

550

539deriveToJSON defaultOptions ''Foo

551deriveToJSON defaultOptions ''Foo