Aeson 合并对象编码

我想解析和编写具有一些共同基本属性和一些附加单独属性的 JSON 对象。例如，假设我们有两种类型的对象User and Email。两种类型共享相同的基本属性foo and bar，但它们具有特定于其类型的附加属性：

User:
{"foo": "foo", "bar": "bar", "user": "me", "age": "42"}

Email:
{"foo": "foo", "bar": "bar", "email": "[email protected]"}

我已经写了FromJSON and ToJSON单独对象的实例User, Email, and Base。现在我的想法是定义一个包装对象结合Base以及任何其他类型FromJSON and ToJSON实例。

data Wrapper a = Wrapper Base a

instance FromJSON a => FromJSON (Wrapper a) where
  parseJSON = withObject "Wrapper" $ \v -> Wrapper <$> parseJSON (Object v) <*> parseJSON (Object v)

instance ToJSON a => ToJSON (Wrapper a) where
  toJSON (Wrapper base a) = Object (toObject "base" (toJSON base) <> toObject "custom" (toJSON a))
    where
      toObject :: Text -> Value -> KeyMap Value
      toObject _ (Object v) = v
      toObject key v = KeyMap.singleton (Key.fromText key) v

  toEncoding = genericToEncoding defaultOptions

The FromJSON实施似乎工作得很好。还有toJSON函数似乎将所有属性打包到一个对象中。不幸的是，我找不到合并两者的解决方案Encoding在一起。默认toEncoding实现将基本属性和自定义属性打包在两个单独的 JSON 对象中，并合并底层Builder with unsafeToEncoding也没有帮助。

有没有aeson我完全缺少功能或者是否有更简单的方法来解决我的问题？任何帮助表示赞赏。谢谢！

Update

感谢 Daniel Wagner 的回答，我定义了一个新的类型类ToObject并使包装器数据类型更加通用。

newtype Merged a b = Merged (a, b)
  deriving stock (Show, Generic)
  deriving newtype (Eq)

class ToObject a where
  toObject :: a -> Object
  toSeries :: a -> Series

instance (ToObject a, ToObject b) => ToObject (Merged a b) where
  toObject (Merged (a, b)) = toObject a <> toObject b
  toSeries (Merged (a, b)) = toSeries a <> toSeries b

instance (FromJSON a, FromJSON b) => FromJSON (Merged a b) where
  parseJSON = Json.withObject "Merged" $ \v -> fmap Merged ((,) <$> parseJSON (Object v) <*> parseJSON (Object v))

instance (ToObject a, ToObject b) => ToJSON (Merged a b) where
  toJSON = Object . toObject
  toEncoding = Json.pairs . toSeries

您可以使用构建您需要的内容pairs and pair.

class ToObject a where toObject :: a -> Series

instance ToObject Base where
    toObject b = "foo" .= foo b <> "bar" .= bar b -- but no Ken, how sad
instance ToObject User where
    toObject u = "user" .= user u <> "age" .= age u
instance ToObject a => ToObject (Wrapper a) where
    toObject (Wrapper base a) = toObject base <> toObject a

instance (ToObject a, ToJSON a) => ToJSON (Wrapper a) where
    toJSON = -- as before
    toEncoding = pairs . toObject