Aeson merge object encodings

I want to parse and write JSON objects that have some base attributes in common and some additional individual attributes. For example, let’s say we have two types of objects User and Email. Both types share the same base attributes foo and bar, but they have additional attributes specific to their type:

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

Email:
{"foo": "foo", "bar": "bar", "email": "me@example.com"}

I have written FromJSON and ToJSON instances for the separate objects User, Email, and Base. Now my idea was to define a wrapper object combining Base and any other type with FromJSON and ToJSON instances.

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 implementations seems to work just fine. Also the toJSON function appears to pack all attributes into a single object. Unfortunately, I couldn’t find a solution to merge the two Encodings together. The default toEncoding implementation packs the base and custom attributes in two separate JSON objects and merging the underlaying Builder with unsafeToEncoding doesn’t help either.

Is there any aeson functionality I am missing completely or is there a much easier approach to solve my problem? Any help is appreciated. Thanks!

>Solution :

You can build what you need using 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