Merge pull request #307 from devwout/nullary_constructor_encoding

Data/Aeson/TH.hs

@@ -323,14 +323,23 @@ sumToValue opts multiCons conName exp
 
     | otherwise = exp
 
+nullarySumToValue :: Options -> Bool -> Name -> Q Exp
+nullarySumToValue opts multiCons conName =
+    case sumEncoding opts of
+      TaggedObject{tagFieldName} ->
+          [|A.object|] `appE` listE
+            [ infixApp [|T.pack tagFieldName|] [|(.=)|] (conStr opts conName)
+            ]
+      _ -> sumToValue opts multiCons conName [e|toJSON ([] :: [()])|]
+
 -- | Generates code to generate the JSON encoding of a single constructor.
 argsToValue :: Options -> Bool -> Con -> Q Match
 -- Nullary constructors. Generates code that explicitly matches against the
 -- constructor even though it doesn't contain data. This is useful to prevent
 -- type errors.
 argsToValue  opts multiCons (NormalC conName []) =
     match (conP conName [])
-          (normalB (sumToValue opts multiCons conName [e|toJSON ([] :: [()])|]))
+          (normalB (nullarySumToValue opts multiCons conName))
           []
 
 -- Polyadic constructors with special case for unary constructors.
@@ -478,14 +487,22 @@ sumToEncoding opts multiCons conName exp
 
     | otherwise = exp
 
+nullarySumToEncoding :: Options -> Bool -> Name -> Q Exp
+nullarySumToEncoding opts multiCons conName =
+    case sumEncoding opts of
+      TaggedObject{tagFieldName} ->
+          object $
+          ([|E.text (T.pack tagFieldName)|] <:> encStr opts conName)
+      _ -> sumToEncoding opts multiCons conName [e|toEncoding ([] :: [()])|]
+
 -- | Generates code to generate the JSON encoding of a single constructor.
 argsToEncoding :: Options -> Bool -> Con -> Q Match
 -- Nullary constructors. Generates code that explicitly matches against the
 -- constructor even though it doesn't contain data. This is useful to prevent
 -- type errors.
 argsToEncoding  opts multiCons (NormalC conName []) =
     match (conP conName [])
-          (normalB (sumToEncoding opts multiCons conName [e|toEncoding ([] :: [()])|]))
+          (normalB (nullarySumToEncoding opts multiCons conName))
           []
 
 -- Polyadic constructors with special case for unary constructors.
@@ -873,8 +890,8 @@ parseArgs :: Name -- ^ Name of the type to which the constructor belongs.
                                         --   Right valName
           -> Q Exp
 -- Nullary constructors.
-parseArgs tName _ (NormalC conName []) (Left (valFieldName, obj)) =
-  getValField obj valFieldName $ parseNullaryMatches tName conName
+parseArgs _ _ (NormalC conName []) (Left _) =
+  [|pure|] `appE` conE conName
 parseArgs tName _ (NormalC conName []) (Right valName) =
   caseE (varE valName) $ parseNullaryMatches tName conName
 

Data/Aeson/Types/Generic.hs

@@ -206,6 +206,9 @@ instance ( IsRecord           a isRecord
 class TaggedObjectPairs' f isRecord where
     taggedObjectPairs' :: Options -> String -> f a -> Tagged isRecord [Pair]
 
+instance OVERLAPPING_ TaggedObjectPairs' U1 False where
+    taggedObjectPairs' _ _ _ = Tagged []
+
 instance (RecordToPairs f) => TaggedObjectPairs' f True where
     taggedObjectPairs' opts _ = Tagged . toList . recordToPairs opts
 
@@ -233,20 +236,22 @@ instance ( IsRecord         a isRecord
         (builder tagFieldName <>
          B.char7 ':' <>
          builder (constructorTagModifier opts (conName (undefined :: t c a p)))) <>
-        B.char7 ',' <>
         ((unTagged :: Tagged isRecord B.Builder -> B.Builder) .
          taggedObjectEnc' opts contentsFieldName . unM1 $ v) <>
         B.char7 '}'
 
 class TaggedObjectEnc' f isRecord where
     taggedObjectEnc' :: Options -> String -> f a -> Tagged isRecord B.Builder
 
+instance OVERLAPPING_ TaggedObjectEnc' U1 False where
+    taggedObjectEnc' _ _ _ = Tagged mempty
+
 instance (RecordToEncoding f) => TaggedObjectEnc' f True where
-    taggedObjectEnc' opts _ = Tagged . recordToEncoding opts
+    taggedObjectEnc' opts _ = Tagged . (\z -> B.char7 ',' <> recordToEncoding opts z)
 
 instance (GToEncoding f) => TaggedObjectEnc' f False where
     taggedObjectEnc' opts contentsFieldName =
-        Tagged . (\z -> builder contentsFieldName <> B.char7 ':' <> z) .
+        Tagged . (\z -> B.char7 ',' <> builder contentsFieldName <> B.char7 ':' <> z) .
         gbuilder opts
 
 --------------------------------------------------------------------------------
@@ -627,6 +632,9 @@ instance (GFromJSON f) => FromTaggedObject'' f False where
     parseFromTaggedObject'' opts contentsFieldName = Tagged .
       (gParseJSON opts <=< (.: pack contentsFieldName))
 
+instance OVERLAPPING_ FromTaggedObject'' U1 False where
+    parseFromTaggedObject'' _ _ _ = Tagged (pure U1)
+
 --------------------------------------------------------------------------------
 
 class ConsFromJSON f where

tests/DataFamilies/Properties.hs

@@ -17,7 +17,7 @@ tests = testGroup "data families" [
         testGroup "Nullary" [
             testProperty "string" (isString . thNullaryToJSONString)
           , testProperty "2ElemArray" (is2ElemArray . thNullaryToJSON2ElemArray)
-          , testProperty "TaggedObject" (isTaggedObjectValue . thNullaryToJSONTaggedObject)
+          , testProperty "TaggedObject" (isNullaryTaggedObject . thNullaryToJSONTaggedObject)
           , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thNullaryToJSONObjectWithSingleField)
 
           , testGroup "roundTrip" [

tests/Encoders.hs

@@ -56,27 +56,39 @@ thNullaryParseJSONObjectWithSingleField = $(mkParseJSON optsObjectWithSingleFiel
 gNullaryToJSONString :: Nullary -> Value
 gNullaryToJSONString = genericToJSON defaultOptions
 
+gNullaryToEncodingString :: Nullary -> Encoding
+gNullaryToEncodingString = genericToEncoding defaultOptions
+
 gNullaryParseJSONString :: Value -> Parser Nullary
 gNullaryParseJSONString = genericParseJSON defaultOptions
 
 
 gNullaryToJSON2ElemArray :: Nullary -> Value
 gNullaryToJSON2ElemArray = genericToJSON opts2ElemArray
 
+gNullaryToEncoding2ElemArray :: Nullary -> Encoding
+gNullaryToEncoding2ElemArray = genericToEncoding opts2ElemArray
+
 gNullaryParseJSON2ElemArray :: Value -> Parser Nullary
 gNullaryParseJSON2ElemArray = genericParseJSON opts2ElemArray
 
 
 gNullaryToJSONTaggedObject :: Nullary -> Value
 gNullaryToJSONTaggedObject = genericToJSON optsTaggedObject
 
+gNullaryToEncodingTaggedObject :: Nullary -> Encoding
+gNullaryToEncodingTaggedObject = genericToEncoding optsTaggedObject
+
 gNullaryParseJSONTaggedObject :: Value -> Parser Nullary
 gNullaryParseJSONTaggedObject = genericParseJSON optsTaggedObject
 
 
 gNullaryToJSONObjectWithSingleField :: Nullary -> Value
 gNullaryToJSONObjectWithSingleField = genericToJSON optsObjectWithSingleField
 
+gNullaryToEncodingObjectWithSingleField :: Nullary -> Encoding
+gNullaryToEncodingObjectWithSingleField = genericToEncoding optsObjectWithSingleField
+
 gNullaryParseJSONObjectWithSingleField :: Value -> Parser Nullary
 gNullaryParseJSONObjectWithSingleField = genericParseJSON optsObjectWithSingleField
 
@@ -121,20 +133,29 @@ thSomeTypeParseJSONObjectWithSingleField =
 gSomeTypeToJSON2ElemArray :: SomeType Int -> Value
 gSomeTypeToJSON2ElemArray = genericToJSON opts2ElemArray
 
+gSomeTypeToEncoding2ElemArray :: SomeType Int -> Encoding
+gSomeTypeToEncoding2ElemArray = genericToEncoding opts2ElemArray
+
 gSomeTypeParseJSON2ElemArray :: Value -> Parser (SomeType Int)
 gSomeTypeParseJSON2ElemArray = genericParseJSON opts2ElemArray
 
 
 gSomeTypeToJSONTaggedObject :: SomeType Int -> Value
 gSomeTypeToJSONTaggedObject = genericToJSON optsTaggedObject
 
+gSomeTypeToEncodingTaggedObject :: SomeType Int -> Encoding
+gSomeTypeToEncodingTaggedObject = genericToEncoding optsTaggedObject
+
 gSomeTypeParseJSONTaggedObject :: Value -> Parser (SomeType Int)
 gSomeTypeParseJSONTaggedObject = genericParseJSON optsTaggedObject
 
 
 gSomeTypeToJSONObjectWithSingleField :: SomeType Int -> Value
 gSomeTypeToJSONObjectWithSingleField = genericToJSON optsObjectWithSingleField
 
+gSomeTypeToEncodingObjectWithSingleField :: SomeType Int -> Encoding
+gSomeTypeToEncodingObjectWithSingleField = genericToEncoding optsObjectWithSingleField
+
 gSomeTypeParseJSONObjectWithSingleField :: Value -> Parser (SomeType Int)
 gSomeTypeParseJSONObjectWithSingleField = genericParseJSON optsObjectWithSingleField
 
@@ -165,13 +186,19 @@ thApproxParseJSONDefault = $(mkParseJSON defaultOptions ''Approx)
 gApproxToJSONUnwrap :: Approx String -> Value
 gApproxToJSONUnwrap = genericToJSON optsUnwrapUnaryRecords
 
+gApproxToEncodingUnwrap :: Approx String -> Encoding
+gApproxToEncodingUnwrap = genericToEncoding optsUnwrapUnaryRecords
+
 gApproxParseJSONUnwrap :: Value -> Parser (Approx String)
 gApproxParseJSONUnwrap = genericParseJSON optsUnwrapUnaryRecords
 
 
 gApproxToJSONDefault :: Approx String -> Value
 gApproxToJSONDefault = genericToJSON defaultOptions
 
+gApproxToEncodingDefault :: Approx String -> Encoding
+gApproxToEncodingDefault = genericToEncoding defaultOptions
+
 gApproxParseJSONDefault :: Value -> Parser (Approx String)
 gApproxParseJSONDefault = genericParseJSON defaultOptions
 

tests/Properties.hs

@@ -112,6 +112,9 @@ isTaggedObjectValue (Object obj) = "tag"      `H.member` obj &&
                                    "contents" `H.member` obj
 isTaggedObjectValue _            = False
 
+isNullaryTaggedObject :: Value -> Bool
+isNullaryTaggedObject obj = isTaggedObject obj && isObjectWithSingleField obj
+
 isTaggedObject :: Value -> Bool
 isTaggedObject (Object obj) = "tag" `H.member` obj
 isTaggedObject _            = False
@@ -166,12 +169,60 @@ tests = testGroup "properties" [
   , testGroup "failure messages" [
       testProperty "modify failure" modifyFailureProp
     ]
+  , testGroup "generic" [
+      testGroup "toJSON" [
+        testGroup "Nullary" [
+            testProperty "string" (isString . gNullaryToJSONString)
+          , testProperty "2ElemArray" (is2ElemArray . gNullaryToJSON2ElemArray)
+          , testProperty "TaggedObject" (isNullaryTaggedObject . gNullaryToJSONTaggedObject)
+          , testProperty "ObjectWithSingleField" (isObjectWithSingleField . gNullaryToJSONObjectWithSingleField)
+          , testGroup "roundTrip" [
+              testProperty "string" (toParseJSON gNullaryParseJSONString gNullaryToJSONString)
+            , testProperty "2ElemArray" (toParseJSON gNullaryParseJSON2ElemArray gNullaryToJSON2ElemArray)
+            , testProperty "TaggedObject" (toParseJSON gNullaryParseJSONTaggedObject gNullaryToJSONTaggedObject)
+            , testProperty "ObjectWithSingleField" (toParseJSON gNullaryParseJSONObjectWithSingleField gNullaryToJSONObjectWithSingleField)
+            ]
+        ]
+      , testGroup "SomeType" [
+          testProperty "2ElemArray" (is2ElemArray . gSomeTypeToJSON2ElemArray)
+        , testProperty "TaggedObject" (isTaggedObject . gSomeTypeToJSONTaggedObject)
+        , testProperty "ObjectWithSingleField" (isObjectWithSingleField . gSomeTypeToJSONObjectWithSingleField)
+        , testGroup "roundTrip" [
+            testProperty "2ElemArray" (toParseJSON gSomeTypeParseJSON2ElemArray gSomeTypeToJSON2ElemArray)
+          , testProperty "TaggedObject" (toParseJSON gSomeTypeParseJSONTaggedObject gSomeTypeToJSONTaggedObject)
+          , testProperty "ObjectWithSingleField" (toParseJSON gSomeTypeParseJSONObjectWithSingleField gSomeTypeToJSONObjectWithSingleField)
+          ]
+        ]
+      ]
+    , testGroup "toEncoding" [
+        testProperty "NullaryString" $
+        gNullaryToJSONString `sameAs` gNullaryToEncodingString
+      , testProperty "Nullary2ElemArray" $
+        gNullaryToJSON2ElemArray `sameAs` gNullaryToEncoding2ElemArray
+      , testProperty "NullaryTaggedObject" $
+        gNullaryToJSONTaggedObject `sameAs` gNullaryToEncodingTaggedObject
+      , testProperty "NullaryObjectWithSingleField" $
+        gNullaryToJSONObjectWithSingleField `sameAs`
+        gNullaryToEncodingObjectWithSingleField
+      -- , testProperty "ApproxUnwrap" $
+      --   gApproxToJSONUnwrap `sameAs` gApproxToEncodingUnwrap
+      , testProperty "ApproxDefault" $
+        gApproxToJSONDefault `sameAs` gApproxToEncodingDefault
+      , testProperty "SomeType2ElemArray" $
+        gSomeTypeToJSON2ElemArray `sameAsV` gSomeTypeToEncoding2ElemArray
+      , testProperty "SomeTypeTaggedObject" $
+        gSomeTypeToJSONTaggedObject `sameAsV` gSomeTypeToEncodingTaggedObject
+      , testProperty "SomeTypeObjectWithSingleField" $
+        gSomeTypeToJSONObjectWithSingleField `sameAsV`
+        gSomeTypeToEncodingObjectWithSingleField
+      ]
+    ]
   , testGroup "template-haskell" [
       testGroup "toJSON" [
         testGroup "Nullary" [
             testProperty "string" (isString . thNullaryToJSONString)
           , testProperty "2ElemArray" (is2ElemArray . thNullaryToJSON2ElemArray)
-          , testProperty "TaggedObject" (isTaggedObjectValue . thNullaryToJSONTaggedObject)
+          , testProperty "TaggedObject" (isNullaryTaggedObject . thNullaryToJSONTaggedObject)
           , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thNullaryToJSONObjectWithSingleField)
 
           , testGroup "roundTrip" [