如何修复GHC.Generics实现FromRow泛型方法的转换错误？

问题背景 #

已通过GHC.Generics为ToRow类实现了正常工作的默认方法，现在需要为反向操作的FromRow类编写泛型默认实现，但当前实现存在错误：转换时重复使用[SqlValue]列表的第一个元素，导致类型转换失败。

正常工作的ToRow实现 #

import GHC.Generics
import Database.HDBC ( fromSql, toSql, SqlValue )
import Data.Convertible ( convert, ConvertResult, Convertible(..) )
import Data.Kind

class ToRow a where
  toRow :: a -> [SqlValue]

  default toRow :: Generic a => GToRow (Rep a) => a -> [SqlValue]
  toRow a = gtoRow $ from a

class GToRow f where
  gtoRow :: (f a) -> [SqlValue]

instance GToRow U1 where
  gtoRow U1 = mempty

instance (Convertible a SqlValue) => GToRow (K1 i a) where
  gtoRow (K1 a) = pure $ convert a

instance (GToRow a, GToRow b) => GToRow (a :*: b) where
  gtoRow (a :*: b) = gtoRow a `mappend` gtoRow b

instance GToRow a => GToRow (M1 i c a) where
  gtoRow (M1 a) = gtoRow a

存在问题的FromRow实现 #

class FromRow a where
  fromRow :: [SqlValue] -> a

  default fromRow :: GHC.Generics.Generic a => GFromRow (Rep a) => [SqlValue] -> a
  fromRow = to <$> gfromRow


class GFromRow f where
  gfromRow :: [SqlValue] -> f a

instance GFromRow U1 where
  gfromRow :: forall k (a :: k). [SqlValue] -> U1 a
  gfromRow = pure U1

instance (Convertible SqlValue a) => GFromRow (K1 i a) where
  gfromRow :: forall k (a1 :: k). [SqlValue] -> K1 i a a1
  gfromRow = K1 <$> convert . head    -- 错误：始终使用列表的第一个元素

instance GFromRow a => GFromRow (M1 i c a) where
  gfromRow :: forall k (a :: k -> Type) i (c :: Meta) (a1 :: k). GFromRow a => [SqlValue] -> M1 i c a a1
  gfromRow = M1 <$> gfromRow

instance (GFromRow a, GFromRow b) => GFromRow (a :*: b) where
  gfromRow = (:*:) <$> gfromRow <*> gfromRow

测试代码与错误输出 #

测试代码 #

data Person = Person { name :: String, age :: Int }
  deriving (Generic, Show, ToRow, FromRow)

main :: IO ()
main = do
  let sqlValueList = toRow $ Person "John Doe" 30
  putStrLn $ "SQL values: " ++ show sqlValueList

  let person = fromRow sqlValueList :: Person
  putStrLn $ "Person: " ++ show person

错误输出 #

> main
SQL values: [SqlString "John Doe",SqlInt64 30]
Person: Person {name = "John Doe", age = *** Exception: Convertible: error converting source data SqlString "John Doe" of type SqlValue to type Int: Cannot read source value as dest type
CallStack (from HasCallStack):
  error, called at ./Data/Convertible/Base.hs:69:17 in convertible-1.1.1.1-1MxkWJFsBaiitSWznJamo:Data.Convertible.Base

修复方案 #

核心问题是原GFromRow接口没有消耗列表元素，每个字段解析都重复使用整个列表。需要修改接口，让解析函数返回剩余未处理的SqlValue列表，确保每个字段依次使用列表中的元素。

修改后的完整FromRow实现 #

class FromRow a where
  fromRow :: [SqlValue] -> a

  default fromRow :: Generic a => GFromRow (Rep a) => [SqlValue] -> a
  fromRow vals = to $ fst $ gfromRow vals

class GFromRow f where
  -- 调整类型：返回解析后的泛型结构 + 剩余SqlValue列表
  gfromRow :: [SqlValue] -> (f a, [SqlValue])

instance GFromRow U1 where
  gfromRow vals = (U1, vals)

instance (Convertible SqlValue a) => GFromRow (K1 i a) where
  gfromRow [] = error "FromRow: 提供的SqlValue数量不足"
  gfromRow (v:vs) = (K1 $ convert v, vs)

instance GFromRow a => GFromRow (M1 i c a) where
  gfromRow vals = let (a, rest) = gfromRow vals
                  in (M1 a, rest)

instance (GFromRow a, GFromRow b) => GFromRow (a :*: b) where
  gfromRow vals = let (a, rest1) = gfromRow vals
                      (b, rest2) = gfromRow rest1
                  in (a :*: b, rest2)

修复原理 #

1. 调整GFromRow的方法类型，使其返回(f a, [SqlValue])，解析一个字段后剩余的列表会传递给下一个字段的解析。
2. K1实例现在取列表的第一个元素进行转换，并返回剩余列表。
3. (:*:)实例先解析第一个字段，用剩余列表解析第二个字段，再组合结果。
4. FromRow的默认实现取解析结果的第一个部分（泛型结构），通过to转换为目标类型。

修改后运行测试代码，会得到正确输出：

> main
SQL values: [SqlString "John Doe",SqlInt64 30]
Person: Person {name = "John Doe", age = 30}

内容的提问来源于stack exchange，提问作者Thomas Mahler