如何为含多选择器的泛型派生解码器实现列表解码实例？

我正尝试为基于列表的解码器泛型派生实例。对含多选择器的类型使用derive (Generic)时，选择器会被组织为树状结构，比如四个字段的构造器对应((S1 a :*: S1 b) :*: (S1 c :*: S1 d))。我已经理解选择器的关联算法，但不知道怎么编写对应的实例。

最小示例代码 #

{-# language DefaultSignatures, DeriveGeneric #-}
import Data.List
import GHC.Generics
import Numeric.Natural

data Foo = Foo Int Int Int Int
    deriving (Generic, Show)

data Bar = Bar Int Int
    deriving (Generic, Show)

class Codec a where
    encode :: a -> [Int]
    default encode :: (Generic a, Codec' (Rep a)) => a -> [Int]
    encode = encode' . from
    decode :: [Int] -> a
    default decode :: (Generic a, Codec' (Rep a)) => [Int] -> a
    decode = to . decode'

class Codec' f where
    encode' :: f a -> [Int]
    decode' :: [Int] -> f a

instance Codec Int where
    encode = singleton
    decode = head

instance Codec c => Codec' (K1 i c) where
    encode' (K1 x) = encode x
    decode' x = K1 (decode x)

instance Codec' f => Codec' (M1 i t f) where
    encode' (M1 x) = encode' x
    decode' x = M1 (decode' x)

instance (Codec' f, Codec' g) => Codec' (f :*: g) where
    encode' (x :*: y) = encode' x <> encode' y
    decode' (x:xs) = decode' (singleton x) :*: decode' xs

instance Codec Foo
instance Codec Bar

main :: IO ()
main = do
    print (decode $ encode (Bar 1 2) :: Bar)
    print (decode $ encode (Foo 1 2 3 4) :: Foo)

当前输出 #

Bar 1 2
Foo 1 generic.hs: Prelude.head: empty list
CallStack (from HasCallStack):
  error, called at libraries/base/GHC/List.hs:1644:3 in base:GHC.List
  errorEmptyList, called at libraries/base/GHC/List.hs:87:11 in base:GHC.List
  badHead, called at libraries/base/GHC/List.hs:83:28 in base:GHC.List
  head, called at /private/tmp/generic.hs:26:14 in main:Main

期望输出 #

Bar 1 2
Foo 1 2 3 4

问题分析 #

当前的:*:实例decode'实现逻辑错误：它把输入列表的第一个元素单独传给左侧类型解码，剩余部分传给右侧类型。但对于嵌套的:*:结构（比如Foo对应的((S1 :*: S1) :*: (S1 :*: S1))），第一层:*:会把第一个元素传给S1 :*: S1，而这个子结构的decode'又会把单元素列表拆成第一个元素给左侧S1，剩下的空列表给右侧S1，导致右侧S1对应的Int解码时调用head取空列表元素，触发错误。

正确的做法是让解码函数返回剩余未使用的列表，这样每个:*:实例可以让左侧解码一部分输入，剩余的输入完整传给右侧解码。

修正后的代码 #

{-# language DefaultSignatures, DeriveGeneric #-}
import Data.List
import GHC.Generics
import Numeric.Natural

data Foo = Foo Int Int Int Int
    deriving (Generic, Show)

data Bar = Bar Int Int
    deriving (Generic, Show)

class Codec a where
    encode :: a -> [Int]
    default encode :: (Generic a, Codec' (Rep a)) => a -> [Int]
    encode = encode' . from
    decode :: [Int] -> a
    default decode :: (Generic a, Codec' (Rep a)) => [Int] -> a
    decode xs = case decode' xs of (x, _) -> to x

class Codec' f where
    encode' :: f a -> [Int]
    decode' :: [Int] -> (f a, [Int])

instance Codec Int where
    encode = singleton
    decode = head

instance Codec c => Codec' (K1 i c) where
    encode' (K1 x) = encode x
    decode' xs = (K1 (decode xs'), rest) where
        (xs', rest) = splitAt 1 xs  -- 因为Int的encode是单元素列表，直接拆分1个元素

instance Codec' f => Codec' (M1 i t f) where
    encode' (M1 x) = encode' x
    decode' xs = let (x, rest) = decode' xs in (M1 x, rest)

instance (Codec' f, Codec' g) => Codec' (f :*: g) where
    encode' (x :*: y) = encode' x <> encode' y
    decode' xs = let (x, xs') = decode' xs
                     (y, xs'') = decode' xs'
                 in (x :*: y, xs'')

instance Codec Foo
instance Codec Bar

main :: IO ()
main = do
    print (decode $ encode (Bar 1 2) :: Bar)
    print (decode $ encode (Foo 1 2 3 4) :: Foo)

验证结果 #

运行修正后的代码，输出与期望一致：

Bar 1 2
Foo 1 2 3 4

内容的提问来源于stack exchange，提问作者Johannes Riecken