我正在尝试向wikiget中描述的通用序列化添加一个函数。有些部分看起来很简单，但有一些地方我非常不确定要写什么，不出所料，我遇到了编译错误。我查看了原始论文和 中的实现，但这些资源有点超出我的想象。如果我可以让这个简单的示例正常运行，我将对如何使用泛型有更好的理解。cereal
请参阅下面的第 33 行、第 41 行、第 43 行和第 54 行。
{-# LANGUAGE DefaultSignatures, DeriveGeneric, TypeOperators, FlexibleContexts #-}
import GHC.Generics
import Data.Bits
data Bit = O | I deriving Show
class Serialize a where
put :: a -> [Bit]
default put :: (Generic a, GSerialize (Rep a)) => a -> [Bit]
put a = gput (from a)
get :: [Bit] -> (a, [Bit])
default get :: (Generic a, GSerialize (Rep a)) => [Bit] -> (a, [Bit])
get xs = (to x, xs')
where (x, xs') = gget xs
class GSerialize f where
gput :: f a -> [Bit]
gget :: [Bit] -> f a
-- | Unit: used for constructors without arguments
instance GSerialize U1 where
gput U1 = []
gget xs = U1
-- | Constants, additional parameters and recursion of kind *
instance (GSerialize a, GSerialize b) => GSerialize (a :*: b) where
gput (a :*: b) = gput a ++ gput b
gget xs = (a :*: b, xs'') -- LINE 33
where (a, xs') = gget xs
(b, xs'') = gget xs'
-- | Meta-information (constructor names, etc.)
instance (GSerialize a, GSerialize b) => GSerialize (a :+: b) where
gput (L1 x) = O : gput x
gput (R1 x) = I : gput x
gget (O:xs) = (L1 x, xs') -- LINE 41
where (x, xs') = gget xs
gget (I:xs) = (R1 x, xs') -- LINE 43
where (x, xs') = gget xs
-- | Sums: encode choice between constructors
instance (GSerialize a) => GSerialize (M1 i c a) where
gput (M1 x) = gput x
gget = M1 . gget
-- | Products: encode multiple arguments to constructors
instance (Serialize a) => GSerialize (K1 i a) where
gput (K1 x) = put x
gget xs = K1 . get -- LINE 54
instance Serialize Bool where
put True = [I]
put False = [O]
get (I:xs) = (True, xs)
get (O:xs) = (False, xs)
--
-- Try it out...
--
data UserTree a = Node a (UserTree a) (UserTree a) | Leaf
deriving (Generic, Show)
instance (Serialize a) => Serialize (UserTree a)
main = do
let xs = put True
print (fst . get $ xs :: Bool)
let ys = put (Leaf :: UserTree Bool)
print (fst . get $ ys :: UserTree Bool)
let zs = put (Node False Leaf Leaf :: UserTree Bool)
print (fst . get $ zs :: UserTree Bool)
以下是错误：
amy11.hs:33:13:
Couldn't match expected type `(:*:) a b a1'
with actual type `((:*:) f2 g2 p3, t2)'
In the expression: (a :*: b, xs'')
In an equation for `gget':
gget xs
= (a :*: b, xs'')
where
(a, xs') = gget xs
(b, xs'') = gget xs'
In the instance declaration for `GSerialize (a :*: b)'
amy11.hs:41:17:
Couldn't match expected type `(:+:) a b a1'
with actual type `((:+:) f0 g0 p1, t0)'
In the expression: (L1 x, xs')
In an equation for `gget':
gget (O : xs)
= (L1 x, xs')
where
(x, xs') = gget xs
In the instance declaration for `GSerialize (a :+: b)'
amy11.hs:43:17:
Couldn't match expected type `(:+:) a b a1'
with actual type `((:+:) f1 g1 p2, t1)'
In the expression: (R1 x, xs')
In an equation for `gget':
gget (I : xs)
= (R1 x, xs')
where
(x, xs') = gget xs
In the instance declaration for `GSerialize (a :+: b)'
amy11.hs:54:13:
Couldn't match expected type `K1 i a a1'
with actual type `[Bit] -> K1 i0 (a0, [Bit]) p0'
In the expression: K1 . get
In an equation for `gget': gget xs = K1 . get
In the instance declaration for `GSerialize (K1 i a)'
Failed, modules loaded: none.