generics - 使用 GHC.Generics 反序列化

Question

我正在尝试将 get 函数添加到 wiki 中描述的通用序列化中。 。有些部分看起来很简单，但有一些地方我非常不确定要写什么，毫不奇怪，我遇到了编译错误。我已经查看了原始论文以及 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.

Answer 1

主要问题是您的gget 的类型与您的get 的类型不兼容。你是这么说的

get :: [Bit] -> (a, [Bit])

那么，相应地，你应该有

gget :: [Bit] -> (f a, [Bit])

您实际上在求和和乘积实例中做了正确的事情，但在 U1 和 K1 的情况下需要进行更正。

为了完整起见，您的代码版本进行类型检查:

{-# 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, [Bit])

-- | Unit: used for constructors without arguments
instance GSerialize U1 where
  gput U1 = []
  gget xs = (U1, xs)

-- | 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 xs = (M1 x, xs')
    where (x, xs') = gget xs

-- | Products: encode multiple arguments to constructors
instance (Serialize a) => GSerialize (K1 i a) where
  gput (K1 x) = put x
  gget xs = (K1 x, xs') -- LINE 54
    where (x, xs') = get xs

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)