如何为此GADT编写Serialize实例

Question

下面是一个模块，它试图实现一个简单GADT的Serialize实例。不幸的是，Reorder构造函数的get实现抱怨没有Ixed a约束。有什么方法可以实现这一点，无论是美丽的还是丑陋的？我无法将Ixed a添加到实例上下文中，因为Update构造函数需要为不满足此约束的值工作。

{-# LANGUAGE GADTs #-}
import Control.Lens (Index, Ixed)
import Data.Serialize
-- | Two different ways of updating a value - replacing it completely or,
-- if it is an instance of Ixed, re-ordering it.
data Op a where
Update :: Serialize a => a -> Op a
Reorder :: (Ixed a, Serialize (Index a)) => [Index a] -> Op a
instance Serialize a => Serialize (Op a) where
put (Update a) = putWord8 1 >> put a
put (Reorder ks) = putWord8 2 >> put ks
get = do
i <- getWord8
case i of
1 -> Update <$> get
2 -> Reorder <$> get
_ -> error "instance Serialize (Op a) - corrupt data"

---

附录：对此的一个简化可能是使类型变量a成为幻影类型，因此Op看起来像这样：

data Op a where
Update :: Serialize a => ByteString -> Op a
Reorder :: (Ixed a, Serialize (Index a)) => [ByteString] -> Op a

然后可以使用该类型来正确地解码字节字符串。不确定这是否有助于

Answer 1

您想要做的事情通常是不可能的。本质上，您试图让GHC在只给定Serialize a的情况下推导Ixed a和Serialize (Index a)。当然，这可能适用于您心目中的任何用例，但通常都不起作用，这就是GHC拒绝您的实例的原因。

我说"；一般来说是不可能的"；因为如果你指定了你关心的类型，那么这肯定是可能的。这意味着您必须列出所有可以从Reorder序列化的类型，但这确实是最好的。

有多种方法可以做到这一点，但我认为最简单的方法是使用constraints包来捕获您在Dict中想要的内容。你可以从定义开始：

class MaybeSerializeIndexed a where
canSerializeIndex :: Maybe (Dict (Ixed a, Serialize (Index a)))
default canSerializeIndex :: (Ixed a, Serialize (Index a)) -> Maybe (Dict (Ixed a, Serialize (Index a)))
canSerializeIndex = Just Dict

默认签名(需要DefaultSignatures杂注)是让你的生活变得简单的关键，因为它意味着你可以用简单的一行代码列出你关心的类型，如：

instance Serialize a => MaybeSerializeIndexed [a]
instance Serialize k => MaybeSerializeIndexed (Map k a)

除此之外，您还可以创建一个重叠实例来处理不能使用Reorder:的类型

instance {-# OVERLAPPABLE #-} MaybeSerializeIndexed a where
canSerializeIndex = Nothing

有了这个机器，你就可以编写你的实例：

instance (MaybeSerializeIndexed a, Serialize a) => Serialize (Op a) where
put (Update a) = putWord8 1 >> put a
put (Reorder ks) = putWord8 2 >> put ks
get = do
i <- getWord8
case (i, canSerializeIndex @a) of
(1, _)         -> Update <$> get
(2, Just Dict) -> Reorder <$> get
_ -> error "instance Serialize (Op a) - corrupt data"

请注意，将MaybeSerializeIndexed a约束添加到实例中并不是什么大不了的事情，因为每种类型都有一个实例。这也意味着，如果在没有为系统添加MaybeSerializeIndexed实例的情况下向系统添加新类型，那么在尝试反序列化它时不会出现类型错误，只会出现运行时错误。例如，如果您添加了一个新类型Foo，其中您知道Ixed Foo和Serialize (Index Foo)，但没有添加instance MaybeSerializeIndexed Foo，那么如果您编写的程序尝试将get作为Foo值，则不会出现类型错误，但在运行时会出现运行时错误。

Answer 2

根据@AntC的评论，可能值得重新思考为什么需要Op作为GADT。然而，这里有一种方法似乎有效。。。

Haskell的基本原理是，您可以请求一个实例Ixed a，但不能根据实例Ixed a是否存在而有条件地执行。因此，无论如何，您必须显式枚举要在此序列化中使用的所有类型a，并手动指示哪些类型将被视为Ixed，哪些类型不被视为。

一旦你接受了这一点，就会有一个显而易见的解决方案。如果要为a ~ Int(而不是Ixed)和a ~ [Int](使用Ixed)支持Op a，可以定义两个实例：

instance Serialize (Op Int) where
put (Update a) = putWord8 1 >> put a
put (Reorder ks) = putWord8 2 >> put ks
get = do
i <- getWord8
case i of
1 -> Update <$> get
_ -> error "instance Serialize (Op a) - corrupt data"
instance Serialize (Op [Int]) where
put (Update a) = putWord8 1 >> put a
put (Reorder ks) = putWord8 2 >> put ks
get = do
i <- getWord8
case i of
1 -> Update <$> get
2 -> Reorder <$> get
_ -> error "instance Serialize (Op a) - corrupt data"

并解决了主要问题。剩下的问题是如何让这个样板菜变得可口。

有一种方法。我们可以定义一个类型类来提供getOp :: Op a操作，它配备了两个实例，一个用于Ixed，另一个用于非Ixed类型。对于Ixed的存在，类型类在数据类型Bool和底层类型中都被参数化，如下所示：

class OpVal' (hasixed :: Bool) a where
getOp :: Get (Op a)

并且这两个实例由hasixed类型选择，该类型指定了a:的能力

instance (Serialize a) => OpVal' False a where
getOp = do
i <- getWord8
case i of
1 -> Update <$> get
_ -> error "instance Serialize (Op a) - corrupt data"
instance (Ixed a, Serialize (Index a), Serialize a) => OpVal' True a where
getOp = do
i <- getWord8
case i of
1 -> Update <$> get
2 -> Reorder <$> get
_ -> error "instance Serialize (Op a) - corrupt data"

为了为类型选择合适的实例，我们定义了一个类型族：

type family HasIxed a :: Bool

其指定类型CCD_ 42是否具有CCD_。然后，我们可以使用另一个类型族来基于HasIxed:选择正确的OpVal'实例

type family OpVal a where
OpVal a = OpVal' (HasIxed a) a

最后，我们可以定义我们的Serialize (Op a)实例：

instance OpVal a => Serialize (Op a) where
put (Update a) = putWord8 1 >> put a
put (Reorder ks) = putWord8 2 >> put ks
get = getOp @(HasIxed a)

这样，您就可以将类型a添加到打开的HasIxed类型族中：

type instance HasIxed Int = False
type instance HasIxed [Int] = True

这一切都很有效：

instance OpVal a => Serialize (Op a) where
put (Update a) = putWord8 1 >> put a
put (Reorder ks) = putWord8 2 >> put ks
get = getOp @(HasIxed a)
data BigThing a b = BigThing (Op a) (Op b) deriving (Generic)
instance (OpVal a, OpVal b) => Serialize (BigThing a b)
main = do
let s = runPut $ put (BigThing (Update (5 :: Int)) (Reorder @[Int] [1,2,3]))
Right (BigThing (Update x) (Reorder xs)) = runGet (get :: Get (BigThing Int [Int])) s
print (x, xs)

完整示例：

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
import GHC.Generics (Generic)
import Control.Lens (Index, Ixed)
import Data.Serialize
data Op a where
Update :: Serialize a => a -> Op a
Reorder :: (Ixed a, Serialize (Index a)) => [Index a] -> Op a
class OpVal' (hasixed :: Bool) a where
getOp :: Get (Op a)
instance (Serialize a) => OpVal' False a where
getOp = do
i <- getWord8
case i of
1 -> Update <$> get
_ -> error "instance Serialize (Op a) - corrupt data"
instance (Ixed a, Serialize (Index a), Serialize a) => OpVal' True a where
getOp = do
i <- getWord8
case i of
1 -> Update <$> get
2 -> Reorder <$> get
_ -> error "instance Serialize (Op a) - corrupt data"
type family HasIxed a :: Bool
type instance HasIxed Int = False
type instance HasIxed [Int] = True
type family OpVal a where
OpVal a = OpVal' (HasIxed a) a
instance OpVal a => Serialize (Op a) where
put (Update a) = putWord8 1 >> put a
put (Reorder ks) = putWord8 2 >> put ks
get = getOp @(HasIxed a)
data BigThing a b = BigThing (Op a) (Op b) deriving (Generic)
instance (OpVal a, OpVal b) => Serialize (BigThing a b)
main = do
let s = runPut $ put (BigThing (Update (5 :: Int)) (Reorder @[Int] [1,2,3]))
Right (BigThing (Update x) (Reorder xs)) = runGet (get :: Get (BigThing Int [Int])) s
print (x, xs)