Merge pull request #629 from Lysxia/bug-627

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

Author: bergmark

Data/Aeson/Types/FromJSON.hs

@@ -976,7 +976,7 @@ instance ( IsRecord                   f isRecord
 
 instance (FromRecord arity f) => FromTaggedObject'' arity f True where
     parseFromTaggedObject'' opts fargs _ =
-      Tagged . parseRecord opts fargs Nothing
+      Tagged . parseRecord opts fargs
 
 instance (GFromJSON arity f) => FromTaggedObject'' arity f False where
     parseFromTaggedObject'' opts fargs contentsFieldName = Tagged .
@@ -993,65 +993,60 @@ class ConsFromJSON arity f where
 
 class ConsFromJSON' arity f isRecord where
     consParseJSON' :: Options -> FromArgs arity a
-                   -> Maybe Text -- ^ A dummy label
-                                 --   (Nothing to use proper label)
                    -> Value -> Tagged isRecord (Parser (f a))
 
 instance ( IsRecord            f isRecord
          , ConsFromJSON' arity f isRecord
          ) => ConsFromJSON arity f where
-    consParseJSON opts fargs v = let
-      (v2,lab) = case (unwrapUnaryRecords opts,isUnary (undefined :: f a)) of
-                       -- use a dummy object with a dummy label
-        (True,True) -> (object [(pack "dummy",v)], Just $ pack "dummy")
-        _ ->(v,Nothing)
-      in (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a))
-                       $ consParseJSON' opts fargs lab v2
+    consParseJSON opts fargs =
+      (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a))
+        . consParseJSON' opts fargs
 
+instance OVERLAPPING_
+         ( GFromJSON arity a, FromRecord arity (S1 s a)
+         ) => ConsFromJSON' arity (S1 s a) True where
+    consParseJSON' opts fargs
+      | unwrapUnaryRecords opts = Tagged . gParseJSON opts fargs
+      | otherwise = Tagged . withObject "unary record" (parseRecord opts fargs)
 
-instance (FromRecord arity f) => ConsFromJSON' arity f True where
-    consParseJSON' opts fargs mlab = Tagged . withObject "record (:*:)"
-                                        (parseRecord opts fargs mlab)
+instance FromRecord arity f => ConsFromJSON' arity f True where
+    consParseJSON' opts fargs =
+      Tagged . withObject "record (:*:)" (parseRecord opts fargs)
 
-instance (GFromJSON arity f) => ConsFromJSON' arity f False where
-    consParseJSON' opts fargs _ = Tagged . gParseJSON opts fargs
+instance GFromJSON arity f => ConsFromJSON' arity f False where
+    consParseJSON' opts fargs = Tagged . gParseJSON opts fargs
 
 --------------------------------------------------------------------------------
 
 class FromRecord arity f where
     parseRecord :: Options -> FromArgs arity a
-                -> Maybe Text -- ^ A dummy label
-                              --   (Nothing to use proper label)
                 -> Object -> Parser (f a)
 
 instance ( FromRecord arity a
          , FromRecord arity b
          ) => FromRecord arity (a :*: b) where
-    parseRecord opts fargs _ obj =
-      (:*:) <$> parseRecord opts fargs Nothing obj
-            <*> parseRecord opts fargs Nothing obj
+    parseRecord opts fargs obj =
+      (:*:) <$> parseRecord opts fargs obj
+            <*> parseRecord opts fargs obj
 
 instance OVERLAPPABLE_ (Selector s, GFromJSON arity a) =>
   FromRecord arity (S1 s a) where
-    parseRecord opts fargs lab =
+    parseRecord opts fargs =
       (<?> Key label) . gParseJSON opts fargs <=< (.: label)
         where
-          label = fromMaybe defLabel lab
-          defLabel = pack . fieldLabelModifier opts $
-                       selName (undefined :: t s a p)
+          label = pack . fieldLabelModifier opts $ selName (undefined :: t s a p)
 
 instance INCOHERENT_ (Selector s, FromJSON a) =>
   FromRecord arity (S1 s (K1 i (Maybe a))) where
-    parseRecord _ _ (Just lab) obj = M1 . K1 <$> obj .:? lab
-    parseRecord opts _ Nothing obj = M1 . K1 <$> obj .:? pack label
+    parseRecord opts _ obj = M1 . K1 <$> obj .:? pack label
         where
           label = fieldLabelModifier opts $
                     selName (undefined :: t s (K1 i (Maybe a)) p)
 
 -- Parse an Option like a Maybe.
 instance INCOHERENT_ (Selector s, FromJSON a) =>
   FromRecord arity (S1 s (K1 i (Semigroup.Option a))) where
-    parseRecord opts fargs lab obj = wrap <$> parseRecord opts fargs lab obj
+    parseRecord opts fargs obj = wrap <$> parseRecord opts fargs 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))

Data/Aeson/Types/Generic.hs

@@ -44,12 +44,8 @@ import GHC.Generics
 --------------------------------------------------------------------------------
 
 class IsRecord (f :: * -> *) isRecord | f -> isRecord
-  where
-    isUnary :: f a -> Bool
-    isUnary = const True
 
 instance (IsRecord f isRecord) => IsRecord (f :*: g) isRecord
-  where isUnary = const False
 #if MIN_VERSION_base(4,9,0)
 instance OVERLAPPING_ IsRecord (M1 S ('MetaSel 'Nothing u ss ds) f) False
 #else
@@ -61,7 +57,6 @@ instance IsRecord Par1 True
 instance IsRecord (Rec1 f) True
 instance IsRecord (f :.: g) True
 instance IsRecord U1 False
-  where isUnary = const False
 
 --------------------------------------------------------------------------------
 

Data/Aeson/Types/ToJSON.hs

@@ -956,7 +956,6 @@ class ConsToJSON enc arity f where
 
 class ConsToJSON' enc arity f isRecord where
     consToJSON'     :: Options -> ToArgs enc arity a
-                    -> Bool -- ^ Are we a record with one field?
                     -> f a -> Tagged isRecord enc
 
 instance ( IsRecord                f isRecord
@@ -965,23 +964,28 @@ instance ( IsRecord                f isRecord
   where
     consToJSON opts targs =
         (unTagged :: Tagged isRecord enc -> enc)
-      . consToJSON' opts targs (isUnary (undefined :: f a))
+      . consToJSON' opts targs
     {-# INLINE consToJSON #-}
 
-instance ( RecordToPairs enc pairs arity f
+instance OVERLAPPING_
+         ( RecordToPairs enc pairs arity (S1 s f)
          , FromPairs enc pairs
          , GToJSON enc arity f
-         ) => ConsToJSON' enc arity f True
+         ) => ConsToJSON' enc arity (S1 s f) True
   where
-    consToJSON' opts targs isUn =
-      Tagged .
-        case (isUn, unwrapUnaryRecords opts) of
-          (True, True) -> gToJSON opts targs
-          _ -> fromPairs . recordToPairs opts targs
+    consToJSON' opts targs
+      | unwrapUnaryRecords opts = Tagged . gToJSON opts targs
+      | otherwise = Tagged . fromPairs . recordToPairs opts targs
     {-# INLINE consToJSON' #-}
 
+instance ( RecordToPairs enc pairs arity f
+         , FromPairs enc pairs
+         ) => ConsToJSON' enc arity f True
+  where
+    consToJSON' opts targs = Tagged . fromPairs . recordToPairs opts targs
+
 instance GToJSON enc arity f => ConsToJSON' enc arity f False where
-    consToJSON' opts targs _ = Tagged . gToJSON opts targs
+    consToJSON' opts targs = Tagged . gToJSON opts targs
     {-# INLINE consToJSON' #-}
 
 --------------------------------------------------------------------------------

tests/UnitTests.hs

@@ -99,6 +99,7 @@ tests = testGroup "unit" [
   , testCase "Show Options" showOptions
   , testGroup "SingleMaybeField" singleMaybeField
   , testCase "withEmbeddedJSON" withEmbeddedJSONTest
+  , testCase "SingleFieldCon" singleFieldCon
   ]
 
 roundTripCamel :: String -> Assertion
@@ -534,6 +535,17 @@ withEmbeddedJSONTest :: Assertion
 withEmbeddedJSONTest =
   assertEqual "Unquote embedded JSON" (Right $ EmbeddedJSONTest 1) (eitherDecode "{\"prop\":\"1\"}")
 
+-- Regression test for https://github.com/bos/aeson/issues/627
+newtype SingleFieldCon = SingleFieldCon Int deriving (Eq, Show, Generic)
+
+instance FromJSON SingleFieldCon where
+  parseJSON = genericParseJSON defaultOptions{unwrapUnaryRecords=True}
+  -- This option should have no effect on this type
+
+singleFieldCon :: Assertion
+singleFieldCon =
+  assertEqual "fromJSON" (Right (SingleFieldCon 0)) (eitherDecode "0")
+
 deriveJSON defaultOptions{omitNothingFields=True} ''MyRecord
 
 deriveToJSON  defaultOptions ''Foo