Is it possible to match a changing JSON key to a sum type data constructor with aeson inside a larger record type?

So I have this data type ItemType which is decoded using its data constructor name (see the FromJSON instance).

import           Data.Aeson
import           Data.Aeson.Types
import           Data.Char (toLower)
import           GHC.Generics

data ItemType =
    MkLogin Login
  | MkCard Card
  | MkIdentity Identity
  | MkSecureNote Note
  deriving (Generic, Show)

lowercase :: String -> String
lowercase "" = ""
lowercase (s:ss) = toLower s : ss

stripPrefix :: String -> String
stripPrefix ('M':'k':ss) = ss
stripPrefix str = str

-- | Decode value using ItemType data constructor names
instance FromJSON ItemType where
  parseJSON = genericParseJSON defaultOptions
    { constructorTagModifier = lowercase . stripPrefix
    , sumEncoding = ObjectWithSingleField }

and what I want to do is add this type as a field to a larger record type called Item

data Item =
  Item { _object :: String
       , _id :: String
       , _organizationId :: Maybe Int
       , _folderId :: Maybe Int
       , _type :: Int
       , _name :: String
       , _notes :: String
       , _favorite :: Bool
       , ??? :: ItemType -- don't know how to add this without a different field name
       , _collectionIds :: [Int]
       , _revisionDate :: Maybe String
       } deriving (Generic, Show)

instance FromJSON Item where
  parseJSON =
    genericParseJSON defaultOptions { fieldLabelModifier = stripUnderscore }

However I don't want to create a new field name for the type. Instead I want to use the data constructor which aeson matched on ItemType as the field name because the key of the ItemType field in the JSON object I'm trying to model changes depending upon what ItemType it is. So in this case the key is either "login", "card", "identity", "secureNote". Perhaps I should be using TaggedObject for the sumEncoding, but I'm not totally sure how it works.

Example JSON list of Item objects: https://i.sstatic.net/JQmH0.png. Here you can see the ItemType field by the keys "login", "card", "identity" depending on what type they are.

Solution

You can use a rather ugly hack to pre-process the incoming JSON Value, so that actual JSON input like:

{
  "id": "foo",
  "bool": false
}

is parsed as if it had been:

{
  "id": "foo",
  "itemtype": {"bool" : false}
}

which can be handled directly by the generic parsers using the ObjectWithSingleField sum encoding method.

As a simplified example, given:

data ItemType =
    MkInt Int
  | MkBool Bool
  deriving (Generic, Show)

instance FromJSON ItemType where
  parseJSON = genericParseJSON defaultOptions
    { constructorTagModifier = map toLower . \('M':'k':ss) -> ss
    , sumEncoding = ObjectWithSingleField }

and:

data Item =
  Item { _id :: String
       , _itemtype :: ItemType
       }
  deriving (Generic, Show)

you can write a FromJSON instance for Item that nests an "int" or "bool" field inside an "itemtype" field. (A duplicate of the original field is left in place but ignored by the generic parser.)

instance FromJSON Item where
  parseJSON v = do
    v' <- withObject "Item" nest v
    genericParseJSON defaultOptions { fieldLabelModifier = \('_':ss) -> ss } v'
    where nest o = Object <$> (HM.insert "itemtype" <$> item <*> pure o)
            where item = subObj "int" <|> subObj "bool" <|> fail "no item type field"
                  subObj k = (\v -> object [(k,v)]) <$> o .: k

Full code:

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

import           Control.Applicative
import           Data.Aeson
import           Data.Aeson.Types
import           Data.Char (toLower)
import           GHC.Generics
import qualified Data.HashMap.Strict as HM

data ItemType =
    MkInt Int
  | MkBool Bool
  deriving (Generic, Show)

instance FromJSON ItemType where
  parseJSON = genericParseJSON defaultOptions
    { constructorTagModifier = map toLower . \('M':'k':ss) -> ss
    , sumEncoding = ObjectWithSingleField }

data Item =
  Item { _id :: String
       , _itemtype :: ItemType
       }
  deriving (Generic, Show)

instance FromJSON Item where
  parseJSON v = do
    v' <- withObject "Item" nest v
    genericParseJSON defaultOptions { fieldLabelModifier = \('_':ss) -> ss } v'
    where nest o = Object <$> (HM.insert "itemtype" <$> item <*> pure o)
            where item = subObj "int" <|> subObj "bool" <|> fail "no item type field"
                  subObj k = (\v -> object [(k,v)]) <$> o .: k

test1, test2, test3 :: Either String Item
test1 = eitherDecode "{\"id\":\"foo\",\"bool\":false}"
test2 = eitherDecode "{\"id\":\"foo\",\"int\":10}"
test3 = eitherDecode "{\"id\":\"foo\"}"

main = do
  print test1
  print test2
  print test3

Generally, though, unless you're doing this a lot, it's probably better for the sake of clarity and readability to just abandon the generics and write the necessary boilerplate. It's not that onerous, even for your original example. Yes, you have to keep the type and instance in sync, but a couple of simple tests should catch any problems. So, for example, something like:

instance FromJSON Item where
  parseJSON = withObject "Item" $ \o ->
    Item <$> o .: "object"
         <*> o .: "id"
         <*> o .:? "organizationId"
         <*> o .:? "folderId"
         <*> o .: "type"
         <*> o .: "name"
         <*> o .: "notes"
         <*> o .: "favorite"
         <*> parseItemType o
         <*> o .: "collectionIds"
         <*> o .:? "revisionDate"
    where parseItemType o =
                MkLogin <$> o .: "login"
            <|> MkCard <$> o .: "card"
            <|> MkIdentity <$> o .: "identity"
            <|> MkSecureNote <$> o .: "securenote"