为更高种类的数据派生实例

Posted 2023-03-23

【中文标题】为更高种类的数据派生实例

【英文标题】：Deriving instances for higher-kinded data

【发布时间】：2018-04-02 20:55:39

【问题描述】：

此问题基于 this Reasonably Polymorphic blog post 中描述的高级数据模式。

在下面的代码块中，我定义了一个类型族HKD 和一个数据类型Person，其中的字段可以是Maybe 或Identity。

-# LANGUAGE DeriveGeneric #-
-# LANGUAGE TypeFamilies  #-

import           Data.Aeson

-- "Higher Kinded Data" (http://reasonablypolymorphic.com//blog/higher-kinded-data)
type family HKD f a where
    HKD Identity a = a
    HKD Maybe a = Maybe a

data Person f = Person
   pName :: HKD f String
  , pAge  :: HKD f Int
   deriving (Generic)

然后我尝试为这种类型派生一个ToJSON 实例。

-- Already provided in imports:
-- instance ToJSON String
-- instance ToJSON Int
-- instance ToJSON a => ToJSON (Maybe a)

instance ToJSON (Person f) where
  toJSON = genericToJSON defaultOptions

不幸的是，我收到以下错误：

没有因使用genericToJSON 而产生(ToJSON (HKD f Int)) 的实例。

鉴于我已经拥有ToJSON Int 和ToJSON (Maybe Int)，GHC 不应该能够派生实例ToJSON (HKD f Int) 吗？我的理解是，就实例而言，类型族的行为类似于类型别名。如果是这种情况，那么我不能为它定义我自己的实例，但它应该从它的定义中接收实例，在这种情况下是Int 和Maybe Int。不幸的是，这个错误似乎与此相矛盾。

如何为我的类型定义 ToJSON 实例？

【问题讨论】：

instance (ToJSON (HKD f Int), ToJSON (HKD f String)) => ToJSON (Person f)，不是吗？ （当然需要-XUndecidableInstances，但还不错。）

@leftaroundabout 这应该是一个答案:)

instance ToJSON (Person f) 将暗示 ToJSON (Person []) 这将涉及没有 JSON 序列化程序的 HKD [] Int 类型（可以说，这种类型不应该存在 - 但它确实存在！）。因此，您不能在没有任何上下文的情况下定义 instance ToJSON (Person f)。

@leftaroundabout 感谢您的想法！这确实可以编译，但当相关数据类型包含大量字段时，该解决方案无法扩展。

@MatthewPiziak 这是完全有效的。它只是卡住。 HKD Identity a 没有被卡住，将减少到 a。 HKD [] a 被卡住（但有效）并且根本不会减少。如果你足够努力，你甚至可以用它来计算，我想。 Person [] 也一样。 See also

【参考方案1】：

类型族HKD 需要应用于已知的Identity 或Maybe 以减少。否则，带有未知f 的HKD f Int 会卡住，我们无法解决所有字段类型a 的HKD f a 约束，除非在上下文中列出它们，例如(ToJSON (HKD f Int), ToJSON (HKD f String))，这是一种可能的解决方案但不能很好地扩展到大量字段。

解决方案 1：派生上下文

主要问题是编写和维护字段约束列表的繁琐，这可以通过注意到它实际上是记录类型的函数来解决，并且我们可以使用 GHC 泛型在 Haskell 中定义它。

type GToJSONFields a = GFields' ToJSON (Rep a)

-- Every field satisfies constraint c
type family GFields' (c :: * -> Constraint) (f :: * -> *) :: Constraint
type instance GFields' c (M1 i d f) = GFields' c f
type instance GFields' c (f :+: g) = (GFields' c f, GFields' c g)
type instance GFields' c (f :*: g) = (GFields' c f, GFields' c g)
type instance GFields' c U1 = ()
type instance GFields' c (K1 i a) = c a

instance (GToJSONFields (Person f)) => ToJSON (Person f) where
  toJSON = genericToJSON defaultOptions

然而，这个实例是非模块化且低效的，因为它仍然暴露了记录的内部结构（其字段类型），并且每次使用 ToJSON (Person f) 时都必须重新解决每个字段的约束。

Gist of solution 1

解决方案 2：概括上下文

作为一个实例，我们真正想写的是这个

instance (forall a. ToJSON a => ToJSON (HKD f a)) => ToJSON (Person f) where
  -- ...

它使用量化约束，这是 GHC 目前正在实施的一项新功能；希望语法是自描述的。但是现在还没有发布，这期间我们能做些什么呢？

目前可以使用类型类对量化约束进行编码。

class ToJSON_HKD f where
  toJSON_HKD :: ToJSON a => f a -> Value  -- AllowAmbiguousTypes, or wrap this in a newtype (which we will define next anyway)

instance ToJSON_HKD Identity where
  toJSON_HKD = toJSON

instance ToJSON_HKD Maybe where
  toJSON_HKD = toJSON

但是genericToJSON 会在字段上使用ToJSON，而不是ToJSON_HKD。我们可以将字段包装在newtype 中，该ToJSON 约束与ToJSON_HKD 约束一起调度。

newtype Apply f a = Apply (HKD f a)

instance ToJSON_HKD f => ToJSON (Apply f a) where
  toJSON (Apply x) = toJSON_HKD @f @a x

Person 的字段只能用HKD Identity 或HKD Maybe 包裹。我们应该为HKD 再添加一个案例。事实上，让我们把它打开，并为类型构造函数重构案例。我们写HKD (Tc Maybe) a而不是HKD Maybe a；这更长，但Tc 标记可以重复用于任何其他类型的构造函数，例如HKD (Tc (Apply f)) a。

-- Redefining HKD
type family HKD f a
type instance HKD Identity a = a
type instance HKD (Tc f) a = f a

data Tc (f :: * -> *)  -- Type-level tag for type constructors

aeson 有一个ToJSON1 类型类，其作用与ToJSON_HKD 非常相似，作为forall a. ToJSON a => ToJSON (f a) 的编码。巧合的是，Tc 正是连接这些类的正确类型。

instance ToJSON1 f => ToJSON_HKD (Tc f) where
  toJSON1_HKD = toJSON1

下一步是包装器本身。

wrapApply :: Person f -> Person (Tc (Apply f))
wrapApply = gcoerce

我们所做的只是将字段包装在newtype 中（从HKD f a 到HKD (Tc (Apply f)) a，等于Apply f a 并在表示上等效于HKD f a）。所以这真的是一种胁迫。不幸的是，coerce 不会在这里进行类型检查，因为Person f 有一个名义类型参数（因为它使用HKD，它匹配 name f 以减少）。然而，Person 是一个Generic 类型，wrapApply 的输入和预期输出的通用表示实际上是可强制的。这会产生以下“通用强制”，这使得 wrapApply 变得多余：

gcoerce :: forall a b
        .  (Generic a, Generic b, Coercible (Rep a ()) (Rep b ()))
        => a -> b
gcoerce = to . (coerce :: Rep a () -> Rep b ()) . from

我们得出结论：将字段包装在Apply 中，并使用genericToJSON。

instance ToJSON_HKD f => ToJSON (Person f) where
  toJSON = genericToJSON defaultOptions . gcoerce @_ @(Person (Tc (Apply f)))

Gist of solution 2.

注意要点：HKD 被重命名为 (@@)，这是从 singletons 借来的名称，HKD Identity a 被重写为 HKD Id a，明确区分类型构造函数 Identity 和标识函数的去功能化符号Id。对我来说它看起来更整洁。

解决方案 3：没有类型族

港币博文结合了两个想法：

通过类型构造函数f（也称为"functor functor pattern"）参数化记录；

将f 推广为类型函数，这是可能的，尽管 Haskell 在类型级别没有一流的函数，这要感谢the technique of defunctionalization。

第二个想法的主要目标是能够重用具有未包装字段的记录Person。对于引入的复杂类型家族的数量，这似乎是一个相当美观的问题。

仔细观察，可以说实际上并没有那么多额外的复杂性。最后值得吗？我还没有一个好的答案。

仅供参考，以下是将上述技术应用于没有HKD 类型族的更简单记录的结果。

data Person f = Person
   name :: f String
  , age :: f Int
  

我们可以删除两个定义：ToJSON_HKD（ToJSON1 足够）和gcoerce（coerce 足够）。我们将Apply 替换为连接ToJSON 和ToJSON1 的另一个新类型：

newtype Apply' f a = Apply' (f a)  -- no HKD

instance (ToJSON1 f, ToJSON a) => ToJSON (Apply' f a) where
  toJSON (Apply' x) = toJSON1 x

我们得出ToJSON如下：

instance ToJSON1 f => ToJSON (Person f) where
  toJSON = genericToJSON defaultOptions . coerce @_ @(Person (Apply' f))

---

警告：特殊字段类型

aeson 可以选择将Maybe 字段设为可选，因此它们可以在相应的 JSON 对象中缺失。好吧，该选项不适用于上述方法。它只影响实例定义中已知为 Maybe 的字段，因此解决方案 2 和 3 由于所有字段周围的新类型而失败。

此外，对于解决方案 1，此

instance -# OVERLAPPING #- ToJSON (Person Maybe) where
  toJSON = genericToJSON defaultOptionsomitNothingFields=True

与将其他实例 事后 专门化为 Person Maybe 的行为会有所不同：

instance ... => ToJSON (Person f) where
  toJSON = genericToJSON defaultOptionsomitNothingFields=True

【讨论】：

哦，QuantifiedConstraints 正在实施中，很有趣。谢谢。

有什么办法可以从ToJSON 实例中重构出gcoerce @_ @(Person (Tc (Apply f))) 来稍微干掉代码？换句话说，除了Person 之外，一切都保持不变，所以可以用一些t 替换它吗？

我们可以编写wrap :: (...) => p f -> p (Tc (Apply f)) ; wrap = gcoerce，它应该足够专业化以允许toJSON = genericToJSON defaultOptions . wrap 无需额外注释。

【参考方案2】：

博客文章的作者在这里。可能这里最简单的解决方案是单态化您的 f 参数：

instance ToJSON (Person Identity) where
  toJSON = genericToJSON defaultOptions

instance ToJSON (Person Maybe) where
  toJSON = genericToJSON defaultOptions

有点难看，但肯定可以发货。我正在实验室中，目前正在尝试找出更好的通用解决方案来解决这个问题，如果我有任何想法，我会告诉你。