support tagging objects with single field

src/Data/Aeson/TH.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE TemplateHaskellQuotes #-}
+{-# LANGUAGE TupleSections #-}
 
 {-|
 Module:      Data.Aeson.TH
@@ -115,7 +116,7 @@ module Data.Aeson.TH
 import Data.Aeson.Internal.Prelude
 
 import Data.Char (ord)
-import Data.Aeson (Object, (.:), FromJSON(..), FromJSON1(..), FromJSON2(..), ToJSON(..), ToJSON1(..), ToJSON2(..), object)
+import Data.Aeson (Object, (.:), FromJSON(..), FromJSON1(..), FromJSON2(..), ToJSON(..), ToJSON1(..), ToJSON2(..))
 import Data.Aeson.Types (Options(..), Parser, SumEncoding(..), Value(..), defaultOptions, defaultTaggedObject)
 import Data.Aeson.Types.Internal ((<?>), JSONPathElement(Key))
 import Data.Aeson.Types.ToJSON (fromPairs, pair)
@@ -414,8 +415,10 @@ sumToValue letInsert target opts multiCons nullary conName value pairs
                 content = pairs contentsFieldName
             in fromPairsE target $
               if nullary then tag else infixApp tag [|(Monoid.<>)|] content
-          ObjectWithSingleField ->
-            objectE letInsert target [(conString opts conName, value)]
+          ObjectWithSingleField {tagFieldName_} ->
+            objectE letInsert target $ addTag [(conString opts conName, value)]
+            where
+              addTag = maybe id (\tfn -> ((tfn, bool target True) :)) tagFieldName_
           UntaggedValue | nullary -> conStr target opts conName
           UntaggedValue -> value
     | otherwise = value
@@ -507,6 +510,10 @@ infixr 6 <^>
 (<%>) a b = a <^> [|E.comma|] <^> b
 infixr 4 <%>
 
+bool :: ToJSONFun -> Bool -> ExpQ
+bool Encoding v = [|E.bool v|]
+bool Value v = [|Bool v|]
+
 -- | Wrap a list of quoted 'Value's in a quoted 'Array' (of type 'Value').
 array :: ToJSONFun -> [ExpQ] -> ExpQ
 array Encoding [] = [|E.emptyArray_|]
@@ -720,8 +727,8 @@ consFromJSON jc tName opts instTys cons = do
           TaggedObject {tagFieldName, contentsFieldName} ->
             parseObject $ parseTaggedObject tvMap tagFieldName contentsFieldName
           UntaggedValue -> error "UntaggedValue: Should be handled already"
-          ObjectWithSingleField ->
-            parseObject $ parseObjectWithSingleField tvMap
+          ObjectWithSingleField tagFieldName_ ->
+            parseObject $ parseObjectWithSingleField tagFieldName_ tvMap
           TwoElemArray ->
             [ do arr <- newName "array"
                  match (conP 'Array [varP arr])
@@ -827,21 +834,50 @@ consFromJSON jc tName opts instTys cons = do
                   ]
            )
 
-    parseObjectWithSingleField tvMap obj = do
-      conKey <- newName "conKeyZ"
-      conVal <- newName "conValZ"
-      caseE ([e|KM.toList|] `appE` varE obj)
-            [ match (listP [tupP [varP conKey, varP conVal]])
-                    (normalB $ parseContents tvMap conKey (Right conVal) 'conNotFoundFailObjectSingleField [|Key.fromString|] [|Key.toString|])
-                    []
-            , do other <- newName "other"
-                 match (varP other)
-                       (normalB $ [|wrongPairCountFail|]
+    parseObjectWithSingleField tagFieldName_ tvMap obj =
+      caseE ([e|KM.toList|] `appE` varE obj) $
+            case tagFieldName_ of
+                Just tfn -> [match1Tuple, match2Tuple tfn, matchOther]
+                Nothing -> [match1Tuple, matchOther]
+      where
+        parseKey key val = parseContents tvMap key (Right val) 'conNotFoundFailObjectSingleField [|Key.fromString|] [|Key.toString|]
+        match1Tuple = do
+            conKey <- newName "conKeyZ"
+            conVal <- newName "conValZ"
+            match (listP [tupP [varP conKey, varP conVal]])
+                  (normalB $ parseKey conKey conVal)
+                  []
+        match2Tuple tfn = do
+            key1 <- newName "keyZ1"
+            val1 <- newName "valZ1"
+            key2 <- newName "keyZ2"
+            val2 <- newName "valZ2"
+            match (listP [tupP [varP key1, varP val1], tupP [varP key2, varP val2]])
+                ( guardedB
+                    [ liftM2 (,) (owsfTag key1 val1) (parseKey key2 val2)
+                    , liftM2 (,) (owsfTag key2 val2) (parseKey key1 val1)
+                    , liftM2 (,) (normalG [e|otherwise|])
+                                 ([|wrongPairCountFailTagged|]
                                   `appE` litE (stringL $ show tName)
-                                  `appE` ([|show . length|] `appE` varE other)
-                       )
-                       []
-            ]
+                                  `appE` litE (stringL tfn)
+                                  `appE` litE (stringL "2")
+                                 )
+                    ]
+                )
+                []
+          where
+            owsfTag key val =
+                normalG $ varE '(&&)
+                          `appE` (varE '(==) `appE` ([|Key.toString|] `appE` varE key) `appE` stringE tfn)
+                          `appE` (varE '(==) `appE` varE val `appE` [|Bool True|])
+        matchOther = do
+          other <- newName "other"
+          match (varP other)
+                (normalB $ [|wrongPairCountFail|]
+                          `appE` litE (stringL $ show tName)
+                          `appE` ([|show . length|] `appE` varE other)
+                )
+                []
 
     parseContents tvMap conKey contents errorFun pack unpack=
         caseE (varE conKey)
@@ -1181,6 +1217,11 @@ wrongPairCountFail t n =
     fail $ printf "When parsing %s expected an Object with a single tag/contents pair but got %s pairs."
                   t n
 
+wrongPairCountFailTagged :: String -> String -> String -> Parser fail
+wrongPairCountFailTagged t tfn n =
+    fail $ printf "When parsing %s expected an Object with a single tag/contents pair and an optional tag %s, but got %s pairs."
+                  t tfn n
+
 noStringFail :: String -> String -> Parser fail
 noStringFail t o = fail $ printf "When parsing %s expected String but got %s." t o
 

src/Data/Aeson/Types/FromJSON.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE RecordWildCards #-}
@@ -1215,14 +1216,26 @@ parseNonAllNullarySum p@(tname :* opts :* _) =
               ", but found tag " ++ show tag
           cnames_ = unTagged2 (constructorTags (constructorTagModifier opts) :: Tagged2 f [String])
 
-      ObjectWithSingleField ->
+      ObjectWithSingleField {tagFieldName_} ->
           withObject tname $ \obj -> case KM.toList obj of
-              [(tag, v)] -> maybe (badTag tag) (<?> Key tag) $
-                  parsePair (tag :* p) v
-              _ -> contextType tname . fail $
-                  "expected an Object with a single pair, but found " ++
-                  show (KM.size obj) ++ " pairs"
+              [(tag, v)] -> parseTag tag v
+              [(tag1, v1), (tag2, v2)] -> case tagFieldName_ of
+                  Just tfn
+                      | owsfTag tag1 v1 -> parseTag tag2 v2
+                      | owsfTag tag2 v2 -> parseTag tag1 v1
+                      | otherwise ->
+                            contextType tname . fail $
+                                "expected an Object with a single pair and an optional tag " <> tfn <> ", but found " ++
+                                show (KM.size obj) ++ " pairs"
+                    where
+                      owsfTag tag v = Key.toString tag == tfn && v == Bool True
+                  Nothing -> badObj obj
+              _ -> badObj obj
         where
+          parseTag tag v = maybe (badTag tag) (<?> Key tag) $ parsePair (tag :* p) v
+          badObj obj = contextType tname . fail $
+              "expected an Object with a single pair, but found " ++
+              show (KM.size obj) ++ " pairs"
           badTag tag = failWith_ $ \cnames ->
               "expected an Object with a single pair where the tag is one of " ++
               show cnames ++ ", but found tag " ++ show tag

src/Data/Aeson/Types/Internal.hs

@@ -792,7 +792,7 @@ data SumEncoding =
     --
     -- /Note:/ Only the last error is kept when decoding, so in the case of
     -- malformed JSON, only an error for the last constructor will be reported.
-  | ObjectWithSingleField
+  | ObjectWithSingleField {tagFieldName_ :: Maybe String}
     -- ^ A constructor will be encoded to an object with a single
     -- field named after the constructor tag (modified by the
     -- 'constructorTagModifier') which maps to the encoded contents of

src/Data/Aeson/Types/ToJSON.hs

@@ -967,7 +967,7 @@ nonAllNullarySumToJSON opts targs =
       TaggedObject{..}      ->
         taggedObject opts targs (Key.fromString tagFieldName) (Key.fromString contentsFieldName)
 
-      ObjectWithSingleField ->
+      ObjectWithSingleField {} ->
         (unTagged :: Tagged ObjectWithSingleField enc -> enc)
           . sumToJSON' opts targs
 
@@ -1278,13 +1278,19 @@ instance {-# OVERLAPPABLE #-} (GToJSON' Encoding arity a) => EncodeProduct arity
 instance ( GToJSON'   enc arity a
          , ConsToJSON enc arity a
          , FromPairs  enc pairs
-         , KeyValuePair  enc pairs
+         , KeyValuePair enc pairs
+         , BoolEnc enc
          , Constructor c
          ) => SumToJSON' ObjectWithSingleField enc arity (C1 c a)
   where
     sumToJSON' opts targs =
-      Tagged . fromPairs . (typ `pair`) . gToJSON opts targs
+      Tagged . fromPairs . addTag . (typ `pair`) . gToJSON opts targs
         where
+          addTag = case sumEncoding opts of
+              ObjectWithSingleField {tagFieldName_ = Just tfn} ->
+                let p = pair (Key.fromString tfn) (boolEnc @enc True)
+                in (p <>)
+              _ -> id
           typ = Key.fromString $ constructorTagModifier opts $
                          conName (undefined :: t c a p)
     {-# INLINE sumToJSON' #-}
@@ -2880,3 +2886,14 @@ instance (v ~ Value) => KeyValuePair v (DList Pair) where
 instance (e ~ Encoding) => KeyValuePair e Series where
     pair = E.pair
     {-# INLINE pair #-}
+
+class BoolEnc enc where
+    boolEnc :: Bool -> enc
+
+instance BoolEnc Value where
+    boolEnc = Bool
+    {-# INLINE boolEnc #-}
+
+instance BoolEnc Encoding where
+    boolEnc = E.bool
+    {-# INLINE boolEnc #-}

tests/Encoders.hs

@@ -61,6 +61,16 @@ thNullaryParseJSONObjectWithSingleField :: Value -> Parser Nullary
 thNullaryParseJSONObjectWithSingleField = $(mkParseJSON optsObjectWithSingleField ''Nullary)
 
 
+thNullaryToJSONObjectWithSingleFieldTagged :: Nullary -> Value
+thNullaryToJSONObjectWithSingleFieldTagged = $(mkToJSON optsObjectWithSingleFieldTagged ''Nullary)
+
+thNullaryToEncodingObjectWithSingleFieldTagged :: Nullary -> Encoding
+thNullaryToEncodingObjectWithSingleFieldTagged = $(mkToEncoding optsObjectWithSingleFieldTagged ''Nullary)
+
+thNullaryParseJSONObjectWithSingleFieldTagged :: Value -> Parser Nullary
+thNullaryParseJSONObjectWithSingleFieldTagged = $(mkParseJSON optsObjectWithSingleFieldTagged ''Nullary)
+
+
 thNullaryToJSONOWSFRejectUnknown :: Nullary -> Value
 thNullaryToJSONOWSFRejectUnknown = $(mkToJSON optsOWSFRejectUnknown ''Nullary)
 
@@ -131,6 +141,16 @@ gNullaryParseJSONObjectWithSingleField :: Value -> Parser Nullary
 gNullaryParseJSONObjectWithSingleField = genericParseJSON optsObjectWithSingleField
 
 
+gNullaryToJSONObjectWithSingleFieldTagged :: Nullary -> Value
+gNullaryToJSONObjectWithSingleFieldTagged = genericToJSON optsObjectWithSingleFieldTagged
+
+gNullaryToEncodingObjectWithSingleFieldTagged :: Nullary -> Encoding
+gNullaryToEncodingObjectWithSingleFieldTagged = genericToEncoding optsObjectWithSingleFieldTagged
+
+gNullaryParseJSONObjectWithSingleFieldTagged :: Value -> Parser Nullary
+gNullaryParseJSONObjectWithSingleFieldTagged = genericParseJSON optsObjectWithSingleFieldTagged
+
+
 gNullaryToJSONOWSFRejectUnknown :: Nullary -> Value
 gNullaryToJSONOWSFRejectUnknown = genericToJSON optsOWSFRejectUnknown
 
@@ -243,6 +263,22 @@ thSomeTypeLiftParseJSONObjectWithSingleField :: LiftParseJSON SomeType a
 thSomeTypeLiftParseJSONObjectWithSingleField = $(mkLiftParseJSON optsObjectWithSingleField ''SomeType)
 
 
+thSomeTypeToJSONObjectWithSingleFieldTagged :: SomeType Int -> Value
+thSomeTypeToJSONObjectWithSingleFieldTagged = $(mkToJSON optsObjectWithSingleFieldTagged ''SomeType)
+
+thSomeTypeToEncodingObjectWithSingleFieldTagged :: SomeType Int -> Encoding
+thSomeTypeToEncodingObjectWithSingleFieldTagged = $(mkToEncoding optsObjectWithSingleFieldTagged ''SomeType)
+
+thSomeTypeParseJSONObjectWithSingleFieldTagged :: Value -> Parser (SomeType Int)
+thSomeTypeParseJSONObjectWithSingleFieldTagged = $(mkParseJSON optsObjectWithSingleFieldTagged ''SomeType)
+
+thSomeTypeLiftToJSONObjectWithSingleFieldTagged :: LiftToJSON SomeType a
+thSomeTypeLiftToJSONObjectWithSingleFieldTagged = $(mkLiftToJSON optsObjectWithSingleFieldTagged ''SomeType)
+
+thSomeTypeLiftParseJSONObjectWithSingleFieldTagged :: LiftParseJSON SomeType a
+thSomeTypeLiftParseJSONObjectWithSingleFieldTagged = $(mkLiftParseJSON optsObjectWithSingleFieldTagged ''SomeType)
+
+
 gSomeTypeToJSON2ElemArray :: SomeType Int -> Value
 gSomeTypeToJSON2ElemArray = genericToJSON opts2ElemArray
 
@@ -300,6 +336,22 @@ gSomeTypeLiftParseJSONObjectWithSingleField :: LiftParseJSON SomeType a
 gSomeTypeLiftParseJSONObjectWithSingleField = genericLiftParseJSON optsObjectWithSingleField
 
 
+gSomeTypeToJSONObjectWithSingleFieldTagged :: SomeType Int -> Value
+gSomeTypeToJSONObjectWithSingleFieldTagged = genericToJSON optsObjectWithSingleFieldTagged
+
+gSomeTypeToEncodingObjectWithSingleFieldTagged :: SomeType Int -> Encoding
+gSomeTypeToEncodingObjectWithSingleFieldTagged = genericToEncoding optsObjectWithSingleFieldTagged
+
+gSomeTypeParseJSONObjectWithSingleFieldTagged :: Value -> Parser (SomeType Int)
+gSomeTypeParseJSONObjectWithSingleFieldTagged = genericParseJSON optsObjectWithSingleFieldTagged
+
+gSomeTypeLiftToJSONObjectWithSingleFieldTagged :: LiftToJSON SomeType a
+gSomeTypeLiftToJSONObjectWithSingleFieldTagged = genericLiftToJSON optsObjectWithSingleFieldTagged
+
+gSomeTypeLiftParseJSONObjectWithSingleFieldTagged :: LiftParseJSON SomeType a
+gSomeTypeLiftParseJSONObjectWithSingleFieldTagged = genericLiftParseJSON optsObjectWithSingleFieldTagged
+
+
 gSomeTypeToJSONOmitNothingFields :: SomeType Int -> Value
 gSomeTypeToJSONOmitNothingFields = genericToJSON optsOmitNothingFields
 

tests/Options.hs

@@ -31,28 +31,35 @@ optsTaggedObject = optsDefault
 optsObjectWithSingleField :: Options
 optsObjectWithSingleField = optsDefault
                             { allNullaryToStringTag = False
-                            , sumEncoding           = ObjectWithSingleField
+                            , sumEncoding           = ObjectWithSingleField Nothing
                             }
 
+optsObjectWithSingleFieldTagged :: Options
+optsObjectWithSingleFieldTagged = optsDefault
+                                  { allNullaryToStringTag = False
+                                  , sumEncoding           = ObjectWithSingleField (Just "_tag")
+                                  }
+
+
 optsOWSFRejectUnknown :: Options
 optsOWSFRejectUnknown = optsDefault
                         { allNullaryToStringTag = False
                         , rejectUnknownFields = True
-                        , sumEncoding           = ObjectWithSingleField
+                        , sumEncoding           = ObjectWithSingleField Nothing
                         }
 
 optsOWSFNullaryToObject :: Options
 optsOWSFNullaryToObject = optsDefault
                           { allNullaryToStringTag = False
-                          , sumEncoding           = ObjectWithSingleField
+                          , sumEncoding           = ObjectWithSingleField Nothing
                           , nullaryToObject       = True
                           }
 
 optsOWSFNullaryToObjectRejectUnknown :: Options
 optsOWSFNullaryToObjectRejectUnknown = optsDefault
                                        { allNullaryToStringTag = False
                                        , rejectUnknownFields = True
-                                       , sumEncoding           = ObjectWithSingleField
+                                       , sumEncoding           = ObjectWithSingleField Nothing
                                        , nullaryToObject       = True
                                        }
 

tests/PropertyGeneric.hs

@@ -32,7 +32,8 @@ genericTests =
               testProperty "string" (toParseJSON gNullaryParseJSONString gNullaryToJSONString)
             , testProperty "2ElemArray" (toParseJSON gNullaryParseJSON2ElemArray gNullaryToJSON2ElemArray)
             , testProperty "TaggedObject" (toParseJSON gNullaryParseJSONTaggedObject gNullaryToJSONTaggedObject)
-            , testProperty "ObjectWithSingleField" (toParseJSON gNullaryParseJSONObjectWithSingleField gNullaryToJSONObjectWithSingleField)
+            , testProperty "ObjectWithSingleField" (toParseJSON gNullaryParseJSONObjectWithSingleFieldTagged gNullaryToJSONObjectWithSingleFieldTagged)
+            , testProperty "ObjectWithSingleField Tagged" (toParseJSON gNullaryParseJSONObjectWithSingleFieldTagged gNullaryToJSONObjectWithSingleFieldTagged)
             ]
         ]
       , testGroup "EitherTextInt" [
@@ -47,10 +48,12 @@ genericTests =
             testProperty "2ElemArray" (toParseJSON gSomeTypeParseJSON2ElemArray gSomeTypeToJSON2ElemArray)
           , testProperty "TaggedObject" (toParseJSON gSomeTypeParseJSONTaggedObject gSomeTypeToJSONTaggedObject)
           , testProperty "ObjectWithSingleField" (toParseJSON gSomeTypeParseJSONObjectWithSingleField gSomeTypeToJSONObjectWithSingleField)
+          , testProperty "ObjectWithSingleField Tagged" (toParseJSON gSomeTypeParseJSONObjectWithSingleFieldTagged gSomeTypeToJSONObjectWithSingleFieldTagged)
 
           , testProperty "2ElemArray unary" (toParseJSON1 gSomeTypeLiftParseJSON2ElemArray gSomeTypeLiftToJSON2ElemArray)
           , testProperty "TaggedObject unary" (toParseJSON1 gSomeTypeLiftParseJSONTaggedObject gSomeTypeLiftToJSONTaggedObject)
           , testProperty "ObjectWithSingleField unary" (toParseJSON1 gSomeTypeLiftParseJSONObjectWithSingleField gSomeTypeLiftToJSONObjectWithSingleField)
+          , testProperty "ObjectWithSingleField Tagged unary" (toParseJSON1 gSomeTypeLiftParseJSONObjectWithSingleFieldTagged gSomeTypeLiftToJSONObjectWithSingleFieldTagged)
           ]
         ]
       , testGroup "OneConstructor" [

tests/PropertyTH.hs

@@ -34,6 +34,7 @@ templateHaskellTests =
             , testProperty "2ElemArray" (toParseJSON thNullaryParseJSON2ElemArray thNullaryToJSON2ElemArray)
             , testProperty "TaggedObject" (toParseJSON thNullaryParseJSONTaggedObject thNullaryToJSONTaggedObject)
             , testProperty "ObjectWithSingleField" (toParseJSON thNullaryParseJSONObjectWithSingleField thNullaryToJSONObjectWithSingleField)
+            , testProperty "ObjectWithSingleField Tagged" (toParseJSON thNullaryParseJSONObjectWithSingleField thNullaryToJSONObjectWithSingleField)
             ]
         ]
       , testGroup "EitherTextInt" [
@@ -48,10 +49,12 @@ templateHaskellTests =
             testProperty "2ElemArray" (toParseJSON thSomeTypeParseJSON2ElemArray thSomeTypeToJSON2ElemArray)
           , testProperty "TaggedObject" (toParseJSON thSomeTypeParseJSONTaggedObject thSomeTypeToJSONTaggedObject)
           , testProperty "ObjectWithSingleField" (toParseJSON thSomeTypeParseJSONObjectWithSingleField thSomeTypeToJSONObjectWithSingleField)
+          , testProperty "ObjectWithSingleField Tagged" (toParseJSON thSomeTypeParseJSONObjectWithSingleFieldTagged thSomeTypeToJSONObjectWithSingleFieldTagged)
 
           , testProperty "2ElemArray unary" (toParseJSON1 thSomeTypeLiftParseJSON2ElemArray thSomeTypeLiftToJSON2ElemArray)
           , testProperty "TaggedObject unary" (toParseJSON1 thSomeTypeLiftParseJSONTaggedObject thSomeTypeLiftToJSONTaggedObject)
           , testProperty "ObjectWithSingleField unary" (toParseJSON1 thSomeTypeLiftParseJSONObjectWithSingleField thSomeTypeLiftToJSONObjectWithSingleField)
+          , testProperty "ObjectWithSingleField Tagged unary" (toParseJSON1 thSomeTypeLiftParseJSONObjectWithSingleFieldTagged thSomeTypeLiftToJSONObjectWithSingleFieldTagged)
 
           ]
         ]