Add sum encoding TaggedFlatObject

flake.nix

@@ -0,0 +1,31 @@
+{
+  inputs.nixpkgs.url = github:NixOS/nixpkgs/nixos-unstable;
+  inputs.flake-utils.url = github:poscat0x04/flake-utils;
+
+  outputs = { self, nixpkgs, flake-utils, ... }: with flake-utils;
+    eachDefaultSystem (
+      system:
+        let
+          pkgs = import nixpkgs { inherit system; overlays = [ self.overlay ]; };
+        in
+          with pkgs;
+          {
+            devShell = aeson-dev.envFunc { withHoogle = true; };
+            defaultPackage = aeson;
+          }
+    ) // {
+      overlay = self: super:
+        let
+          hpkgs = super.haskellPackages;
+          aeson = hpkgs.callCabal2nix "aeson" ./. {};
+        in
+          with super; with haskell.lib;
+          {
+            inherit aeson;
+            aeson-dev = addBuildTools aeson [
+              haskell-language-server
+              cabal-install
+            ];
+          };
+    };
+}

src/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 "TaggedFlatObject: Should be handled already"
           ObjectWithSingleField ->
             objectE [(conString opts conName, value)]
           UntaggedValue | nullary -> conStr target opts conName
@@ -434,7 +435,21 @@ 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
+      , multiCons = 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) [0..]) 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
@@ -491,14 +506,33 @@ argsToValue target jc tvMap opts multiCons
                 else e arg
 
         match (conP conName $ map varP args)
-              (normalB $ recordSumToValue target opts multiCons (null argTys) conName pairs)
+              (normalB $ case () of
+                           ()
+                            | TaggedFlatObject {tagFieldName} <- sumEncoding opts -> do
+                               let tag = pairE tagFieldName (conStr target opts conName)
+                               fromPairsE $ infixApp tag [|(Monoid.<>)|] pairs
+                            | otherwise -> recordSumToValue target opts multiCons (null argTys) conName pairs)
               []
 
 -- Infix constructors.
 argsToValue target jc tvMap opts multiCons
   ConstructorInfo { constructorName    = conName
                   , constructorVariant = InfixConstructor
-                  , constructorFields  = argTys } = do
+                  , constructorFields  = argTys }
+      | TaggedFlatObject {tagFieldName} <- sumEncoding opts
+      , multiCons = do
+        [alTy, arTy] <- mapM resolveTypeSynonyms argTys
+        al <- newName "argL"
+        ar <- newName "argR"
+        let tag = (tagFieldName, conStr target opts conName)
+            os = zipWith (\arg argTy -> dispatchToJSON target jc conName tvMap argTy `appE` varE arg) [al, ar] [alTy, arTy]
+            pairs = zip (fmap (show :: Int -> String) [0..]) os
+            obj = objectE (tag : pairs)
+        match (infixP (varP al) conName (varP ar))
+              (normalB obj)
+              []
+      | otherwise =
+    do
     [alTy, arTy] <- mapM resolveTypeSynonyms argTys
     al <- newName "argL"
     ar <- newName "argR"
@@ -729,6 +763,8 @@ consFromJSON jc tName opts instTys cons = do
         case sumEncoding opts of
           TaggedObject {tagFieldName, contentsFieldName} ->
             parseObject $ parseTaggedObject tvMap tagFieldName contentsFieldName
+          TaggedFlatObject {tagFieldName} ->
+            parseObject $ parseTaggedFlatObject tvMap tagFieldName
           UntaggedValue -> error "UntaggedValue: Should be handled already"
           ObjectWithSingleField ->
             parseObject $ parseObjectWithSingleField tvMap
@@ -779,6 +815,88 @@ consFromJSON jc tName opts instTys cons = do
           , noBindS $ parseContents tvMap conKey (Left (valFieldName, obj)) 'conNotFoundFailTaggedObject
           ]
 
+    parseTaggedFlatObject tvMap tagFieldName obj = do
+      conKey <- newName "conKey"
+      doE [ bindS (varP conKey)
+                  (infixApp (varE obj) [|(.:)|] ([|T.pack|] `appE` stringE tagFieldName))
+          , noBindS $
+            caseE (varE conKey)
+              [ match wildP
+                ( guardedB $
+                  [ do g <- normalG $ infixApp (varE conKey)
+                                               [|(==)|]
+                                               ([|T.pack|] `appE`
+                                                  conNameExp opts con)
+                       argTys <- mapM resolveTypeSynonyms (constructorFields con)
+                       let conName = constructorName con
+                       e <- case constructorVariant con of
+                              RecordConstructor fields ->
+                                parseRecord jc tvMap argTys opts tName conName fields obj False
+                              _ ->
+                                parseNumRec tvMap argTys conName obj
+                       return (g, e)
+                  | con <- cons
+                  ]
+                  ++
+                  [ liftM2 (,)
+                           (normalG [e|otherwise|])
+                           ( varE 'conNotFoundFailTaggedObject
+                             `appE` litE (stringL $ show tName)
+                             `appE` listE (map ( litE
+                                               . stringL
+                                               . constructorTagModifier opts
+                                               . nameBase
+                                               . constructorName
+                                               ) cons
+                                          )
+                             `appE` ([|T.unpack|] `appE` varE conKey)
+                           )
+                  ]
+                )
+                []
+              ]
+          ]
+
+    parseNumRec :: TyVarMap
+                -> [Type]
+                -> Name
+                -> Name
+                -> ExpQ
+    parseNumRec tvMap argTys conName obj =
+        (if rejectUnknownFields opts
+          then infixApp checkUnknownRecords [|(>>)|]
+          else id) $
+          if null argTys
+            then [|pure|] `appE` conE conName
+            else
+              foldl' (\a b -> infixApp a [|(<*>)|] b)
+                     (infixApp (conE conName) [|(<$>)|] x)
+                     xs
+        where
+          fields = map (show :: Int -> String) $ take (length argTys) [0..]
+          knownFields = appE [|H.fromList|] $ listE $
+              map (\knownName -> tupE [appE [|T.pack|] $ litE $ stringL knownName, [|()|]]) fields
+          checkUnknownRecords =
+              caseE (appE [|H.keys|] $ infixApp (varE obj) [|H.difference|] knownFields)
+                  [ match (listP []) (normalB [|return ()|]) []
+                  , newName "unknownFields" >>=
+                      \unknownFields -> match (varP unknownFields)
+                          (normalB $ appE [|fail|] $ infixApp
+                              (litE (stringL "Unknown fields: "))
+                              [|(++)|]
+                              (appE [|show|] (varE unknownFields)))
+                          []
+                  ]
+          x:xs = [ [|lookupField|]
+                   `appE` dispatchParseJSON jc conName tvMap argTy
+                   `appE` litE (stringL $ show tName)
+                   `appE` litE (stringL $ constructorTagModifier opts $ nameBase conName)
+                   `appE` varE obj
+                   `appE` ( [|T.pack|] `appE` stringE field
+                          )
+                 | (field, argTy) <- zip fields argTys
+                 ]
+
     parseUntaggedValue tvMap cons' conVal =
         foldr1 (\e e' -> infixApp e [|(<|>)|] e')
                (map (\x -> parseValue tvMap x conVal) cons')

src/Data/Aeson/Types/FromJSON.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -158,6 +159,7 @@ import qualified Data.Primitive.Types as PM
 import qualified Data.Primitive.PrimArray as PM
 
 import Data.Coerce (Coercible, coerce)
+import GHC.TypeLits
 
 parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a
 parseIndexedJSON p idx value = p value <?> Index idx
@@ -1010,6 +1012,7 @@ instance ( ConstructorNames        f
          , FromPair          arity f
          , FromTaggedObject  arity f
          , FromUntaggedValue arity f
+         , FromTaggedFlatObject arity f
          ) => ParseSum       arity f True where
     parseSum p@(tname :* opts :* _)
         | allNullaryToStringTag opts = Tagged . parseAllNullarySum tname opts
@@ -1019,6 +1022,7 @@ instance ( ConstructorNames        f
          , FromPair          arity f
          , FromTaggedObject  arity f
          , FromUntaggedValue arity f
+         , FromTaggedFlatObject arity f
          ) => ParseSum       arity f False where
     parseSum p = Tagged . parseNonAllNullarySum p
 
@@ -1101,6 +1105,7 @@ parseNonAllNullarySum :: forall f c arity.
                          ( FromPair          arity f
                          , FromTaggedObject  arity f
                          , FromUntaggedValue arity f
+                         , FromTaggedFlatObject arity f
                          , ConstructorNames        f
                          ) => TypeName :* Options :* FromArgs arity c
                            -> Value -> Parser (f c)
@@ -1118,6 +1123,17 @@ parseNonAllNullarySum p@(tname :* opts :* _) =
               ", but found tag " ++ show tag
           cnames_ = unTagged2 (constructorTags (constructorTagModifier opts) :: Tagged2 f [String])
 
+      TaggedFlatObject{..} ->
+          withObject tname $ \obj -> do
+              let tagKey = pack tagFieldName
+                  badTag tag = failWith_ $ \cnames ->
+                    "expected tag field to be one of " ++ show cnames ++
+                    ", but found tag " ++ show tag
+                  cnames_ = unTagged2 (constructorTags (constructorTagModifier opts) :: Tagged2 f [String])
+              tag <- contextType tname . contextTag tagKey cnames_ $ obj .: tagKey
+              fromMaybe (badTag tag <?> Key tagKey) $
+                parseTaggedFlatObject (tag :* p) obj
+
       ObjectWithSingleField ->
           withObject tname $ \obj -> case H.toList obj of
               [(tag, v)] -> maybe (badTag tag) (<?> Key tag) $
@@ -1401,6 +1417,66 @@ instance ( Constructor c
 
 --------------------------------------------------------------------------------
 
+class FromTaggedFlatObject arity f where
+    parseTaggedFlatObject :: Text :* TypeName :* Options :* FromArgs arity a
+                          -> Object
+                          -> Maybe (Parser (f a))
+
+instance ( FromTaggedFlatObject arity f
+         , FromTaggedFlatObject arity g
+         ) => FromTaggedFlatObject arity (f :+: g) where
+    parseTaggedFlatObject p obj =
+        (fmap L1 <$> parseTaggedFlatObject p obj) <|>
+        (fmap R1 <$> parseTaggedFlatObject p obj)
+
+instance ( IsRecord f isRecord
+         , FromTaggedFlatObject' arity f isRecord
+         , Constructor c
+         ) => FromTaggedFlatObject arity (C1 c f) where
+    parseTaggedFlatObject :: Text :* TypeName :* Options :* FromArgs arity a
+                          -> Object
+                          -> Maybe (Parser (C1 c f a))
+    parseTaggedFlatObject (tag :* p@(_ :* opts :* _)) obj
+       | tag == tag' = Just $ fmap M1 $ (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a)) $ parseTaggedFlatObject' (cname :* p) obj
+       | otherwise = Nothing
+     where
+        tag' = pack $ constructorTagModifier opts cname
+        cname = conName (undefined :: M1 i c f p)
+
+class FromTaggedFlatObject' arity f isRecord where
+    parseTaggedFlatObject' :: ConName :* TypeName :* Options :* FromArgs arity a
+                          -> Object
+                          -> Tagged isRecord (Parser (f a))
+
+instance (RecordFromJSON arity f, FieldNames f) => FromTaggedFlatObject' arity f True where
+    parseTaggedFlatObject' p = Tagged . recordParseJSON (True :* p)
+
+instance FromTaggedFlatObject' arity U1 False where
+    parseTaggedFlatObject' _ _ = Tagged (pure U1)
+
+instance OVERLAPPABLE_ PositionFromObject 0 arity f => FromTaggedFlatObject' arity f False where
+    parseTaggedFlatObject' (_ :* p) obj = Tagged (positionFromObject (Proxy :: Proxy 0) p obj)
+
+class KnownNat n => PositionFromObject n arity f where
+    positionFromObject :: Proxy n
+                       -> TypeName :* Options :* FromArgs arity a
+                       -> Object
+                       -> Parser (f a)
+
+instance (KnownNat n, GFromJSON arity a) => PositionFromObject n arity (S1 m a) where
+    positionFromObject _ (_ :* opts :* fargs) obj =
+       explicitParseField (gParseJSON opts fargs) obj $ pack $ show $ natVal (Proxy :: Proxy n)
+
+instance ( PositionFromObject n arity f
+         , PositionFromObject (n+1) arity g
+         ) => PositionFromObject n arity (f :*: g) where
+    positionFromObject _ p obj =
+      (:*:)
+        <$> positionFromObject (Proxy :: Proxy n) p obj
+        <*> positionFromObject (Proxy :: Proxy (n+1)) p obj
+
+--------------------------------------------------------------------------------
+
 class FromUntaggedValue arity f where
     parseUntaggedValue :: TypeName :* Options :* FromArgs arity a
                        -> Value

src/Data/Aeson/Types/Internal.hs

@@ -682,6 +682,39 @@ data SumEncoding =
     -- by the encoded value of that field! If the constructor is not a
     -- record the encoded constructor contents will be stored under
     -- the 'contentsFieldName' field.
+  | TaggedFlatObject { tagFieldName :: String }
+    -- ^ Conceptually, this option will allow data types to be encoded to an object
+    -- with an additional field 'tagFieldName' which specifies the constructor tag.
+    -- This option differs from 'TaggedObject' in that the fields are encoded
+    -- in the same object as the tag, instead of in another object under the
+    -- field @contentsFieldName@.
+    --
+    -- The detailed behavior is as follows:
+    --
+    --   1. If the data type has only a single constructor and has field names
+    --      (a record), it will be encoded as an object without any additional fields.
+    --      For example, given @A@ defined as
+    --      @data A = A {field1 :: Int, field2 :: Int}@,
+    --      this option will encode @A 1 2@ as @{"field1": 1, "field2": 2}@
+    --   2. If the data type has only a single constructor but does not have any fields,
+    --      it will be encoded as an array.
+    --      For example, given @A@ defined as
+    --      @data A = A Int Int@,
+    --      this option will encode @A 1 2@ as @[1, 2]@
+    --   3. If the data type has multiple constructors and the constructor has field names,
+    --      it will be encoded as an object with an additional field '$tagFieldName'.
+    --      For example, given @A@ defined as
+    --      @data A = A {field1 :: Int, field2 :: Int} | B@,
+    --      this option will encode @A 1 2@ as @{"field1": 1, "field2": 2, "$tagFieldName": \"A"}@
+    --   4. If the data type has multiple constructors and the constructor does not have
+    --      any feild names, it will be encoded as an object whose keys are the position of the value
+    --      in that data type with an additional field '$tagFieldName'.
+    --      For example, given @A@ defined as
+    --      @data A = A Int Int | B@,
+    --      this option will encode @A 1 2@ as @{"0": 1, "1": 2, "$tagFieldName": \"A"}@
+    --   5. The behavior is undefined when the '$tagFieldName' collides with another field name and should
+    --      not be relied upon. It may or may not overwite the field.
+    --      It may or may not throw an runtime exception. It may or may not raise an compile time error.
   | UntaggedValue
     -- ^ Constructor names won't be encoded. Instead only the contents of the
     -- constructor will be encoded as if the type had a single constructor. JSON