Haskell 如何定制FromJSON/ToJSON行上的显示/读取实例

我有下面的求和类型

import Data.Aeson
import Data.Aeson.Casing
import GHC.Generics

data OrderType = Confirmed | AwaitingShipping | Shipped
  deriving (Eq, Generic)

instance ToJSON OrderType where
  toJSON = genericToJSON $ (aesonPrefix snakeCase){constructorTagModifier=(camelTo2 '_')}

这将在JSON编码期间导致以下转换：

Confirmed => confirmed
AwaitingShipping => awaiting_shipping
Shipped => shipped

如何快速生成一个具有完全相同的

OrderType

=>

String

转换的

Show

实例

请注意，我知道我可以做到以下几点，但我正在寻找一种方法来避免这种陈词滥调

instance Show OrderType where
  show Confirmed = "confirmed"
  show AwaitingShipping = "awaiting_shipping"
  show Shipped = "shipped"

---

我认为它必须是

Show

的一个实例是有原因的，否则

camelTo2'.\。show

似乎可以完成这项工作

在任何情况下，都可以通过

GHC.Generics

获得构造函数名称。然后您可以编写

camelTo2'\ux'。constructorName

，无需额外设置；特别是，您可以自由地将其用作

show

的实现

import GHC.Generics

-- Constructor name of the value of an ADT.
-- Using 'Generic.from', we map it to a generic representation.
constructorName :: (Generic a, CName (Rep a)) => a -> String
constructorName = cname . from

-- Class of generic representations of ADTs, built using
-- types in GHC.Generics.
-- 'cname' extracts the constructor name from it.
class CName f where
  cname :: f p -> String

-- M1 is a newtype to attach metadata about the type
-- being represented at the type level.
-- The first parameter marks the kind of the data
-- in the second one. 'D' indicates general information
-- like the type name and whether it is a newtype.
-- Here we ignore it and look in the rest of the representation.
instance CName f => CName (M1 D c f) where
  cname (M1 f) = cname f

-- '(:+:)' represents sums.
instance (CName f, CName g) => CName (f :+: g) where
  cname (L1 f) = cname f
  cname (R1 g) = cname g

-- 'M1' again, but 'C' indicates information about a specific
-- constructor, we extract it using the 'GHC.Generics.Constructor'
-- type class.
instance Constructor c => CName (M1 C c f) where
  cname = conName

（我已经编辑了我的答案，以便有更多的解释。如果你只是想要一个包含代码的模块，那么它就是

该问题旨在更改的默认

显示

和

读取

实例 枚举类型，例如

OrderType

，并提供自定义类型。我将显示 下面是如何做到这一点，尽管原则上我建议不要这样做， 因为

Show

和

Read

通常被认为会产生Haskell 值的表示。我还将建议一种不同的解决方案， 但是，通过使用新的类型类

我的解决方案类似于李耀霞提出的解决方案，但基于GHC泛型，而不是内置GHC泛型

我们正在使用以下模块标题

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module CustomShowEnum where

import Data.Aeson
import Data.Aeson.Types
import Data.Maybe
import Generics.SOP
import Generics.SOP.NS
import Generics.SOP.TH
import Text.Read

让我们从一个计算产品（列表）的函数开始 具有静态已知的元素数）的所有 构造函数名称

conNames ::
  forall a proxy .
  (Generic a, HasDatatypeInfo a)
  => proxy a -> NP (K String) (Code a)
conNames _ =
  hmap
    (K . constructorName)
    (constructorInfo (datatypeInfo (Proxy @a)))

datatypeInfo

函数提供所有元信息 关于给定的数据类型，

constructorInfo

函数提取 从这一点来看，这是一个产品，每个产品都有元信息 构造函数。我们只对名称感兴趣，其他什么都不感兴趣， 因此，我们在产品上使用

hmap

来提取构造函数 每个位置的名称

让我们看看如何使用它：

GHCi> conNames (Proxy @Bool)
K "False" :* (K "True" :* Nil)

将

Nil

读取为空产品，将

：*

读取为“cons”。每个元素 被包装在

K

构造函数中，因为它是包含 数据类型的每个构造函数的（常量）字符串

这同样适用于其他数据类型：

GHCi> conNames (Proxy @Ordering)
K "LT" :* (K "EQ" :* (K "GT" :* Nil))
GHCi> conNames (Proxy @(Maybe ()))
K "Nothing" :* (K "Just" :* Nil)

我们还可以使其适用于问题中提到的

订单类型

：

data OrderType = Confirmed | AwaitingShipping | Shipped

但是如果我们盲目地尝试，那么我们会得到一个我们没有的错误

Generic

和

HasDatatypeInfo

类的实例。用于 泛型sop函数要工作，类型必须是这些函数的实例 类。实现这一点的一种方法是使用模板Haskell：

deriveGeneric ''OrderType

（不喜欢模板Haskell的人的另一种方式是 图书馆文档。）

现在，我们可以使用

conNames

：

GHCi> conNames (Proxy @OrderType)
K "Confirmed" :* (K "AwaitingShipping" :* (K "Shipped" :* Nil))

它的一个变体是一个函数，它接受一个特定的值，并计算 构建该值的最外层构造函数

conName ::
  forall a .
  (Generic a, HasDatatypeInfo a)
  => a -> String
conName x =
  hcollapse
    (hzipWith
      const
      (conNames (Proxy @a))
      (unSOP (from x))
    )

这里，我们使用

from

来计算给定对象的泛型表示 值，它是乘积的总和。总和编码一个或多个乘积之间的选择 数据类型的构造函数。我们可以使用

hzipWith

组合 兼容积（n个值的乘积）和和和（可选） i（n个可能选项中的第i个），它将选择 产品和组合。通过使用

const

组合两者， 结果是，我们只返回相应的构造函数名 从我们的

conNames

产品到给定的构造函数 最后的应用程序提取单个

字符串
值

让我们再看一些例子：

GHCi> conName Confirmed
"Confirmed"
GHCi> conName (Just 3)
"Just"
GHCi> conName [1,2,3]
":"

请注意，在上一个示例中，列表在顶层只是一个
cons的应用

接下来，我们定义一个函数
enum
，它计算所有的乘积
枚举类型的值。这类似于
conNames
，
但是我们没有返回构造函数名称（作为字符串），而是
返回实际的构造函数

enum ::
  forall a .
  (Generic a, HasDatatypeInfo a, All ((~) '[]) (Code a))
  => NP (K a) (Code a)
enum =
  hmap
    (mapKK to)
    (apInjs'_POP (POP (hcpure (Proxy @((~) '[])) Nil)))

apInks''u POP
函数生成所有构造函数的乘积
函数的泛型表示形式。这些仍然必须
应用于他们论点的表示，我们需要提供
这些参数作为乘积的乘积（二维表
每个构造函数一行，每行包含参数
应用于该特定构造函数）

幸运的是，我们在这里仅限于枚举类型
是没有任何构造函数参数的类型。这表示为
通过约束
All（（~）'[]）（code a）
。类型的代码为
类型列表。外部列表包含每个类型的一个条目
构造函数，内部列表给出构造函数的类型
约束声明每个内部列表必须
为空，这相当于每个构造函数
没有争论

因此，我们可以生成一个空参数列表的乘积，
这就是我们通过
POP（hcpure（Proxy（@（（~）'[]）Nil））所做的事情

最后，我们使用
hmap
和
to
将每个构造的
值从其泛型表示形式返回到其原始表示形式
形状

让我们来看一些例子：

GHCi> enum @Bool
K False :* (K True :* Nil)

GHCi> customShowEnum id AwaitingShipping
"AwaitingShipping"
GHCi> customShowEnum reverse Confirmed
"demrifnoC"
GHCi> customShowEnum (camelTo2 '_') AwaitingShipping
"awaiting_shipping"

再将此与

GHCi> conNames (Proxy @Bool)
K "False" :* (K "True" :* Nil)

注意，在一种情况下，我们返回字符串，在另一种情况下，我们
返回实际值

GHCi> enum @Ordering
K LT :* (K EQ :* (K GT :* Nil))

如果我们尝试将
enum
应用于非枚举的类型
类型，我们得到一个类型错误

如果我们尝试将
enum
应用于
OrderType
，我们会得到一个错误
缺少
OrderType
的
Show
实例

如果我们通过

deriving instance Show OrderType

我们获得：

GHCi> enum @OrderType
K Confirmed :* (K AwaitingShipping :* (K Shipped :* Nil))

如果我们使用
问题，我在下面展示了如何定义，我们得到

GHCi> enum @OrderType
K confirmed :* K awaiting_shipping :* K shipped :* Nil

这也是一个演示
GHCi> conTable @Bool
[("False", False), ("True", True)]
GHCi> conTable @Ordering
[("LT", LT), ("EQ", EQ), ("GT", GT)]
GHCi> conTable @OrderType
[("Confirmed", Confirmed), ("AwaitingShipping", AwaitingShipping), ("Shipped", Shipped)]

customShowEnum ::
  forall a .
  (Generic a, HasDatatypeInfo a, All ((~) '[]) (Code a))
  => (String -> String)
  -> a -> String
customShowEnum f = f . conName

GHCi> customShowEnum id AwaitingShipping
"AwaitingShipping"
GHCi> customShowEnum reverse Confirmed
"demrifnoC"
GHCi> customShowEnum (camelTo2 '_') AwaitingShipping
"awaiting_shipping"

readPrec :: Read a => ReadPrec a

customReadEnum ::
  forall a .
  (Generic a, HasDatatypeInfo a, All ((~) '[]) (Code a))
  => (String -> String)
  -> ReadPrec a
customReadEnum f =
  let
    adjustedTable :: [(Lexeme, a)]
    adjustedTable = map (\ (n, x) -> (Ident (f n), x)) conTable
  in
    parens $ do
      n <- lexP
      maybe pfail return (lookup n adjustedTable)

GHCi> readPrec_to_S (customReadEnum @OrderType id) 0 "AwaitingShipping"
[(AwaitingShipping, "")]
GHCi> readPrec_to_S (customReadEnum @OrderType (camelTo2 '_')) 0 "AwaitingShipping"
[]
GHCi> readPrec_to_S (customReadEnum @OrderType (camelTo2 '_')) 0 "awaiting_shipping"
[(AwaitingShipping, "")]
>>> readPrec_to_S (customReadEnum @OrderType (camelTo2 '_')) 0 "   ( awaiting_shipping)  "
[(AwaitingShipping, "  ")]

instance Show OrderType where
  show = customShowEnum (camelTo2 '_')

instance Read OrderType where
  readPrec = customReadEnum (camelTo2 '_')

class ToString a where
  toString :: a -> String

class FromString a where
  fromString :: String -> Maybe a

instance ToString OrderType where
  toString = customShowEnum (camelTo2 '_')

customFromString ::
  forall a .
  (Generic a, HasDatatypeInfo a, All ((~) '[]) (Code a))
  => (String -> String)
  -> String -> Maybe a
customFromString f x =
  case readPrec_to_S (customReadEnum f) 0 x of
    [(r, "")] -> Just r
    _         -> Nothing

instance FromString OrderType where
  fromString = customFromString (camelTo2 '_')