git.iko.soy/typeable/aeson
on master help sign in
Merge pull request #629 from Lysxia/bug-627

Fix generic `FromJSON` for non-record constructors with one field

commit84ef29959e2fdcbf762ed73527cbff97591a7695 authorAdam Bergmark <adam@bergmark.nl> dateThu 29 Mar 2018, 18:37 (9 years ago) parent728da7600d839a
4 files changed+48−42
compare with master
unifiedsplit
Data/Aeson/Types/FromJSON.hs+22−27 Data/Aeson/Types/Generic.hs−5 Data/Aeson/Types/ToJSON.hs+14−10 tests/UnitTests.hs+12
Data/Aeson/Types/FromJSON.hs+22−27
@@ -976,7 +976,7 @@ instance ( IsRecord f isRecord
976976
977977instance (FromRecord arity f) => FromTaggedObject'' arity f True where
978978 parseFromTaggedObject'' opts fargs _ =
979− Tagged . parseRecord opts fargs Nothing
979+ Tagged . parseRecord opts fargs
980980
981981instance (GFromJSON arity f) => FromTaggedObject'' arity f False where
982982 parseFromTaggedObject'' opts fargs contentsFieldName = Tagged .
@@ -993,57 +993,52 @@ class ConsFromJSON arity f where
993993
994994class ConsFromJSON' arity f isRecord where
995995 consParseJSON' :: Options -> FromArgs arity a
996− -> Maybe Text -- ^ A dummy label
997− -- (Nothing to use proper label)
998996 -> Value -> Tagged isRecord (Parser (f a))
999997
1000998instance ( IsRecord f isRecord
1001999 , ConsFromJSON' arity f isRecord
10021000 ) => ConsFromJSON arity f where
1003− consParseJSON opts fargs v = let
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))
1009− $ consParseJSON' opts fargs lab v2
1001+ consParseJSON opts fargs =
1002+ (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a))
1003+ . consParseJSON' opts fargs
10101004
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)
10111011
1012−instance (FromRecord arity f) => ConsFromJSON' arity f True where
1013− consParseJSON' opts fargs mlab = Tagged . withObject "record (:*:)"
1014− (parseRecord opts fargs mlab)
1012+instance FromRecord arity f => ConsFromJSON' arity f True where
1013+ consParseJSON' opts fargs =
1014+ Tagged . withObject "record (:*:)" (parseRecord opts fargs)
10151015
1016−instance (GFromJSON arity f) => ConsFromJSON' arity f False where
1017− consParseJSON' opts fargs _ = Tagged . gParseJSON opts fargs
1016+instance GFromJSON arity f => ConsFromJSON' arity f False where
1017+ consParseJSON' opts fargs = Tagged . gParseJSON opts fargs
10181018
10191019--------------------------------------------------------------------------------
10201020
10211021class FromRecord arity f where
10221022 parseRecord :: Options -> FromArgs arity a
1023− -> Maybe Text -- ^ A dummy label
1024− -- (Nothing to use proper label)
10251023 -> Object -> Parser (f a)
10261024
10271025instance ( FromRecord arity a
10281026 , FromRecord arity b
10291027 ) => FromRecord arity (a :*: b) where
1030− parseRecord opts fargs _ obj =
1031− (:*:) <$> parseRecord opts fargs Nothing obj
1032− <*> parseRecord opts fargs Nothing obj
1028+ parseRecord opts fargs obj =
1029+ (:*:) <$> parseRecord opts fargs obj
1030+ <*> parseRecord opts fargs obj
10331031
10341032instance OVERLAPPABLE_ (Selector s, GFromJSON arity a) =>
10351033 FromRecord arity (S1 s a) where
1036− parseRecord opts fargs lab =
1034+ parseRecord opts fargs =
10371035 (<?> Key label) . gParseJSON opts fargs <=< (.: label)
10381036 where
1039− label = fromMaybe defLabel lab
1040− defLabel = pack . fieldLabelModifier opts $
1041− selName (undefined :: t s a p)
1037+ label = pack . fieldLabelModifier opts $ selName (undefined :: t s a p)
10421038
10431039instance INCOHERENT_ (Selector s, FromJSON a) =>
10441040 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
10471042 where
10481043 label = fieldLabelModifier opts $
10491044 selName (undefined :: t s (K1 i (Maybe a)) p)
@@ -1051,7 +1046,7 @@ instance INCOHERENT_ (Selector s, FromJSON a) =>
10511046-- Parse an Option like a Maybe.
10521047instance INCOHERENT_ (Selector s, FromJSON a) =>
10531048 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
10551050 where
10561051 wrap :: S1 s (K1 i (Maybe a)) p -> S1 s (K1 i (Semigroup.Option a)) p
10571052 wrap (M1 (K1 a)) = M1 (K1 (Semigroup.Option a))
Data/Aeson/Types/Generic.hs−5
@@ -44,12 +44,8 @@ import GHC.Generics
4444--------------------------------------------------------------------------------
4545
4646class IsRecord (f :: * -> *) isRecord | f -> isRecord
47− where
48− isUnary :: f a -> Bool
49− isUnary = const True
5047
5148instance (IsRecord f isRecord) => IsRecord (f :*: g) isRecord
52− where isUnary = const False
5349#if MIN_VERSION_base(4,9,0)
5450instance OVERLAPPING_ IsRecord (M1 S ('MetaSel 'Nothing u ss ds) f) False
5551#else
@@ -61,7 +57,6 @@ instance IsRecord Par1 True
6157instance IsRecord (Rec1 f) True
6258instance IsRecord (f :.: g) True
6359instance IsRecord U1 False
64− where isUnary = const False
6560
6661--------------------------------------------------------------------------------
6762
Data/Aeson/Types/ToJSON.hs+14−10
@@ -956,7 +956,6 @@ class ConsToJSON enc arity f where
956956
957957class ConsToJSON' enc arity f isRecord where
958958 consToJSON' :: Options -> ToArgs enc arity a
959− -> Bool -- ^ Are we a record with one field?
960959 -> f a -> Tagged isRecord enc
961960
962961instance ( IsRecord f isRecord
@@ -965,23 +964,28 @@ instance ( IsRecord f isRecord
965964 where
966965 consToJSON opts targs =
967966 (unTagged :: Tagged isRecord enc -> enc)
968− . consToJSON' opts targs (isUnary (undefined :: f a))
967+ . consToJSON' opts targs
969968 {-# INLINE consToJSON #-}
970969
971−instance ( RecordToPairs enc pairs arity f
970+instance OVERLAPPING_
971+ ( RecordToPairs enc pairs arity (S1 s f)
972972 , FromPairs enc pairs
973973 , GToJSON enc arity f
974− ) => ConsToJSON' enc arity f True
974+ ) => ConsToJSON' enc arity (S1 s f) True
975975 where
976− consToJSON' opts targs isUn =
977− Tagged .
978− case (isUn, unwrapUnaryRecords opts) of
979− (True, True) -> gToJSON opts targs
980− _ -> fromPairs . recordToPairs opts targs
976+ consToJSON' opts targs
977+ | unwrapUnaryRecords opts = Tagged . gToJSON opts targs
978+ | otherwise = Tagged . fromPairs . recordToPairs opts targs
981979 {-# INLINE consToJSON' #-}
982980
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+
983987instance 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
985989 {-# INLINE consToJSON' #-}
986990
987991--------------------------------------------------------------------------------
tests/UnitTests.hs+12
@@ -99,6 +99,7 @@ tests = testGroup "unit" [
9999 , testCase "Show Options" showOptions
100100 , testGroup "SingleMaybeField" singleMaybeField
101101 , testCase "withEmbeddedJSON" withEmbeddedJSONTest
102+ , testCase "SingleFieldCon" singleFieldCon
102103 ]
103104
104105roundTripCamel :: String -> Assertion
@@ -534,6 +535,17 @@ withEmbeddedJSONTest :: Assertion
534535withEmbeddedJSONTest =
535536 assertEqual "Unquote embedded JSON" (Right $ EmbeddedJSONTest 1) (eitherDecode "{\"prop\":\"1\"}")
536537
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+
537549deriveJSON defaultOptions{omitNothingFields=True} ''MyRecord
538550
539551deriveToJSON defaultOptions ''Foo