如何使用Lens修改多态记录类型并适配任意DbRecord

要实现适配任意同类多态DbRecord的toRecordWrite函数，核心是重新构造目标类型实例——因为原类型和目标类型的类型参数不同，属于完全不同的类型，Lens的同类型修改无法直接使用。以下是几种可行方案：

1. 针对单个多态类型的直接实现 #

如果只处理DbRecordPoly这类固定结构的类型，直接通过模式匹配提取需要保留的字段，再构造目标类型即可：

{-# LANGUAGE TemplateHaskell #-}

module Try2 where

import Control.Lens
import Data.Time
import Prelude hiding (id)

data DbRecordPoly id createdAt updatedAt name = DbRecordPoly
  { _dbrId        :: id
  , _dbrCreatedAt :: createdAt
  , _dbrUpdatedAt :: updatedAt
  , _dbrName      :: name
  }
$(makeLensesWith abbreviatedFields ''DbRecordPoly)

type DbRecordRead = DbRecordPoly Int UTCTime UTCTime String
type DbRecordWrite = DbRecordPoly () () () String

-- 针对DbRecordPoly的实现
toRecordWrite :: DbRecordPoly i c u n -> DbRecordPoly () () () n
toRecordWrite (DbRecordPoly _ _ _ name) = DbRecordPoly () () () name

-- 或者用Lens提取字段（效果一致）
toRecordWrite' :: DbRecordPoly i c u n -> DbRecordPoly () () () n
toRecordWrite' r = DbRecordPoly () () () (r ^. name)

2. 用类型类适配任意同类多态类型 #

如果需要适配UserPoly、PostPoly等多个类似结构的多态类型，可以定义一个类型类，为每个目标类型手动实现实例：

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TemplateHaskell #-}

import Control.Lens
import Data.Time
import Prelude hiding (id)

-- 定义类型类：src是源类型，dst是对应的写类型，src可唯一推导dst
class ToRecordWrite src dst | src -> dst where
  toRecordWrite :: src -> dst

-- 示例：DbRecordPoly的实例
data DbRecordPoly id createdAt updatedAt name = DbRecordPoly
  { _dbrId        :: id
  , _dbrCreatedAt :: createdAt
  , _dbrUpdatedAt :: updatedAt
  , _dbrName      :: name
  }
$(makeLensesWith abbreviatedFields ''DbRecordPoly)

instance ToRecordWrite (DbRecordPoly i c u n) (DbRecordPoly () () () n) where
  toRecordWrite (DbRecordPoly _ _ _ n) = DbRecordPoly () () () n

-- 示例：UserPoly的实例
data UserPoly id createdAt updatedAt email username = UserPoly
  { _userId        :: id
  , _userCreatedAt :: createdAt
  , _userUpdatedAt :: updatedAt
  , _userEmail     :: email
  , _userUsername  :: username
  }
$(makeLensesWith abbreviatedFields ''UserPoly)

instance ToRecordWrite (UserPoly i c u e un) (UserPoly () () () e un) where
  toRecordWrite (UserPoly _ _ _ e un) = UserPoly () () () e un

-- 使用示例
type UserRead = UserPoly Int UTCTime UTCTime String String
type UserWrite = UserPoly () () () String String

testUser :: UserRead
testUser = UserPoly 1 (UTCTime (toEnum 0) 0) (UTCTime (toEnum 0) 0) "test@example.com" "testuser"

testConvert :: UserWrite
testConvert = toRecordWrite testUser

3. 用Template Haskell自动生成实例 #

如果需要适配大量同结构的多态类型，手动写实例会很繁琐，可以用Template Haskell自动生成ToRecordWrite实例：

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}

import Control.Lens
import Data.Time
import Prelude hiding (id)
import Language.Haskell.TH

-- 定义类型类
class ToRecordWrite src dst | src -> dst where
  toRecordWrite :: src -> dst

-- 自动生成ToRecordWrite实例的TH函数
deriveToRecordWrite :: Name -> Q [Dec]
deriveToRecordWrite tyName = do
  -- 获取目标类型的元数据
  TyConI (DataD _ _ typeVars _ [RecC conName fields] _) <- reify tyName
  -- 拆分类型变量：前3个是id/createdAt/updatedAt，剩下的是需要保留的字段类型
  let [tvId, tvCreated, tvUpdated] = take 3 typeVars
      restTVs = drop 3 typeVars
      -- 构造源类型和目标类型
      srcTy = foldl AppT (ConT tyName) (map VarT typeVars)
      dstTy = foldl AppT (ConT tyName) (ConT ''() : ConT ''() : ConT ''() : map VarT restTVs)
      -- 模式匹配：忽略前3个字段，绑定剩下的字段
      pats = map (const WildP) (take 3 fields) ++ map (\(fieldName, _, _) -> VarP (mkName (nameBase fieldName))) (drop 3 fields)
      -- 构造目标实例：前3个字段填()，剩下的字段用绑定的变量
      args = map (\_ -> ConE '()) (take 3 fields) ++ map (\(fieldName, _, _) -> VarE (mkName (nameBase fieldName))) (drop 3 fields)
      body = foldl AppE (ConE conName) args
  -- 生成实例声明
  instanceD (cxt [])
            (AppT (AppT (ConT ''ToRecordWrite) srcTy) dstTy)
            [funD 'toRecordWrite [clause [ConP conName pats] (normalB body) []]]

-- 定义DbRecordPoly并自动生成实例
data DbRecordPoly id createdAt updatedAt name = DbRecordPoly
  { _dbrId        :: id
  , _dbrCreatedAt :: createdAt
  , _dbrUpdatedAt :: updatedAt
  , _dbrName      :: name
  }
$(makeLensesWith abbreviatedFields ''DbRecordPoly)
$(deriveToRecordWrite ''DbRecordPoly)

-- 定义UserPoly并自动生成实例
data UserPoly id createdAt updatedAt email username = UserPoly
  { _userId        :: id
  , _userCreatedAt :: createdAt
  , _userUpdatedAt :: updatedAt
  , _userEmail     :: email
  , _userUsername  :: username
  }
$(makeLensesWith abbreviatedFields ''UserPoly)
$(deriveToRecordWrite ''UserPoly)

-- 使用示例
type DbRecordRead = DbRecordPoly Int UTCTime UTCTime String
type DbRecordWrite = DbRecordPoly () () () String

testConvert :: DbRecordWrite
testConvert = toRecordWrite (DbRecordPoly 1 (UTCTime (toEnum 0) 0) (UTCTime (toEnum 0) 0) "test")

这个TH函数会自动识别目标类型的前3个字段（对应id、createdAt、updatedAt），将它们替换为()，保留后续所有字段的值，生成对应的ToRecordWrite实例。

内容的提问来源于stack exchange，提问作者Saurabh Nanda