WIP

Author: Poscat

Data/Aeson/TH.hs

@@ -421,6 +421,7 @@ sumToValue target opts multiCons nullary conName value pairs
                 content = pairs contentsFieldName
             in fromPairsE $
               if nullary then tag else infixApp tag [|(Monoid.<>)|] content
+          TaggedFlatObject {} -> error "impossible"
           ObjectWithSingleField ->
             objectE [(conString opts conName, value)]
           UntaggedValue | nullary -> conStr target opts conName
@@ -434,7 +435,20 @@ argsToValue :: ToJSONFun -> JSONClass -> TyVarMap -> Options -> Bool -> Construc
 argsToValue target jc tvMap opts multiCons
   ConstructorInfo { constructorName    = conName
                   , constructorVariant = NormalConstructor
-                  , constructorFields  = argTys } = do
+                  , constructorFields  = argTys } 
+      | TaggedFlatObject{tagFieldName} <- sumEncoding opts = do
+        let tag = (tagFieldName, conStr target opts conName)
+        argTys' <- mapM resolveTypeSynonyms argTys
+        let len = length argTys'
+        args <- newNameList "arg" len
+        let os = zipWith (\arg argTy -> dispatchToJSON target jc conName tvMap argTy `appE` varE arg) args argTys'
+            pairs = zip (fmap (show :: Int -> String) [1..]) os
+            obj = objectE (tag : pairs)
+        match (conP conName $ map varP args)
+              (normalB obj)
+              []
+      | otherwise =
+    do
     argTys' <- mapM resolveTypeSynonyms argTys
     let len = length argTys'
     args <- newNameList "arg" len
@@ -729,6 +743,7 @@ consFromJSON jc tName opts instTys cons = do
         case sumEncoding opts of
           TaggedObject {tagFieldName, contentsFieldName} ->
             parseObject $ parseTaggedObject tvMap tagFieldName contentsFieldName
+          TaggedFlatObject {tagFieldName} -> error "unsupported"
           UntaggedValue -> error "UntaggedValue: Should be handled already"
           ObjectWithSingleField ->
             parseObject $ parseObjectWithSingleField tvMap
@@ -778,6 +793,13 @@ consFromJSON jc tName opts instTys cons = do
                             ([|T.pack|] `appE` stringE typFieldName))
           , noBindS $ parseContents tvMap conKey (Left (valFieldName, obj)) 'conNotFoundFailTaggedObject
           ]
+    
+    parseTaggedFlatObject tvMap typFieldName obj = do
+      conKey <- newName "conKey"
+      doE [ bindS (varP conKey)
+                  (infixApp (varE obj) [|(.:)|] ([|T.pack|] `appE` stringE typFieldName))
+          , noBindS $ parseContents tvMap conKey (Right obj) 'conNotFoundFailTaggedObject
+          ]
 
     parseUntaggedValue tvMap cons' conVal =
         foldr1 (\e e' -> infixApp e [|(<|>)|] e')