parsing - 是否可以将不断变化的 JSON 键与较大记录类型中的 aeson 的总和类型数据构造函数相匹配？

Question

所以我有这个数据类型 ItemType它使用其数据构造函数名称进行解码(请参阅 FromJSON 实例)。

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 }

我想要做的是将此类型作为字段添加到名为 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 }

但是我不想为该类型创建一个新的字段名称。相反，我想使用 aeson 在 ItemType 上匹配的数据构造函数作为字段名，因为 ItemType 的键JSON 对象中的字段我试图根据什么进行建模更改 ItemType它是。所以在这种情况下， key 是“登录”、“卡”、“身份”、“secureNote”。也许我应该使用 TaggedObject为 sumEncoding ，但我不完全确定它是如何工作的。 Item 的示例 JSON 列表对象: https://i.imgur.com/xzHy9MU.png .在这里您可以看到 ItemType字段由键“登录”、“卡”、“身份”组成，具体取决于它们的类型。

Answer 1

您可以使用相当丑陋的 hack 来预处理传入的 JSON Value , 这样实际的 JSON 输入就像:

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

被解析为:

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

可以使用 ObjectWithSingleField 由通用解析器直接处理。和编码方法。
作为一个简化的例子，给出:

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)

你可以写一个 FromJSON Item 的实例嵌套一个 "int"或 "bool" "itemtype" 内的字段 field 。 (原始字段的副本保留在原位，但被通用解析器忽略。)

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

完整代码:

{-# 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

但是，一般来说，除非您经常这样做，否则为了清晰和可读性起见，放弃泛型并编写必要的样板可能会更好。即使对于您的原始示例，这也不是那么麻烦。是的，您必须保持类型和实例同步，但是一些简单的测试应该可以发现任何问题。因此，例如，类似于:

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"