如何使用Control.Lens/Optics实现带累加器的嵌套折叠逻辑？

我有一段用于数据转换的Haskell代码，核心是通过多层折叠传递累加器实现逻辑：

newtype XXX = XXX
  { xxx :: [ Text ]
  } deriving (Eq, Show)

oldToNew
  :: [XXX] -> [(Int, [(Int, Text)])]
  -> [[(Int, Int, Text)]]
oldToNew xs old                = map    go1          xs
 where
  go1 (XXX eqs)                = foldr  go2      []  eqs
  go2 l                    acc = foldr (go3 l)   acc old
  go3 l (i, w)             acc = foldr (go4 i l) acc w
  go4 idx1 label1 (idx2, label2) acc =
    if label1 == label2
    then (idx1, idx2, label2):acc
    else acc

这段代码有两个关键特点：

1. 所有折叠操作都以空列表作为初始累加器；
2. 每层折叠会将参数传递给下一层的处理函数。

现在想改用Control.Lens或Optics库实现完全相同的逻辑，测试用例如下：

oldToNewSpec :: Spec
oldToNewSpec  =
  it "oldToNew" $
    oldToNew [ XXX ["this", "that", "also"]
             , XXX ["here", "there"] ]

             [ (0, [(4, "this")])
             , (0, [(1, "here")])
             , (1, [(5, "that")])
             , (2, [(2, "also")])
             , (2, [(3, "there")]) ]
    `shouldBe`
    [ [(0,4,"this"),(1,5,"that"),(2,2,"also")]
    , [(0,1,"here"),(2,3,"there")] ]

实现方案 #

方案1：完全保留原折叠结构（Optics替代标准foldr） #

这个方案直接复用原代码的处理逻辑，只是用Control.Lens的foldrOf替代标准库的foldr，既满足Optics的使用要求，又完全保留原代码的行为和顺序：

import Control.Lens
import Data.Text (Text)
import Test.Hspec (Spec, it, shouldBe)

newtype XXX = XXX
  { xxx :: [Text]
  } deriving (Eq, Show)

oldToNew :: [XXX] -> [(Int, [(Int, Text)])] -> [[(Int, Int, Text)]]
oldToNew xs old = xs ^.. traversed . to (\(XXX eqs) -> 
  foldrOf traversed go2 [] eqs
)
  where
    go2 l acc = foldrOf traversed (go3 l) acc old
    go3 l (idx1, ws) acc = foldrOf traversed (go4 idx1 l) acc ws
    go4 idx1 label1 (idx2, label2) acc = 
      if label1 == label2 then (idx1, idx2, label2):acc else acc

-- 测试用例
oldToNewSpec :: Spec
oldToNewSpec  =
  it "oldToNew" $
    oldToNew [ XXX ["this", "that", "also"]
             , XXX ["here", "there"] ]

             [ (0, [(4, "this")])
             , (0, [(1, "here")])
             , (1, [(5, "that")])
             , (2, [(2, "also")])
             , (2, [(3, "there")]) ]
    `shouldBe`
    [ [(0,4,"this"),(1,5,"that"),(2,2,"also")]
    , [(0,1,"here"),(2,3,"there")] ]

说明

• foldrOf traversed是Optics中用于遍历折叠的函数，对于列表类型，它和标准库foldr的行为完全一致，因为traversed是列表的默认遍历光学元件。
• 原代码中的go2/go3/go4函数完全保留，延续了原有的累加器传递逻辑和匹配判断逻辑，确保结果和原代码完全一致。

方案2：更贴合Optics风格的遍历筛选 #

如果想更充分利用Optics的遍历和筛选能力，可以用traversed结合filtered来简化逻辑，避免显式的折叠累加：

import Control.Lens
import Data.Text (Text)
import Test.Hspec (Spec, it, shouldBe)

newtype XXX = XXX
  { xxx :: [Text]
  } deriving (Eq, Show)

oldToNew :: [XXX] -> [(Int, [(Int, Text)])] -> [[(Int, Int, Text)]]
oldToNew xs old = xs ^.. traversed . to processXXX
  where
    -- 处理单个XXX结构，收集所有匹配的三元组
    processXXX (XXX labels) = concatMap findMatches labels
    
    -- 为单个label查找所有匹配的三元组
    findMatches label = old ^.. traversed
        -- 筛选出包含目标label的old条目
        . filtered (\(_, ws) -> ws ^. has (traversed . filtered (\(_, l) -> l == label)))
        -- 从符合条件的条目中提取三元组
        . to (\(idx1, ws) -> ws ^.. traversed
            . filtered (\(_, l) -> l == label)
            . to (\(idx2, l) -> (idx1, idx2, l))
          )
        -- 展平嵌套列表
        . folded

-- 测试用例保持不变
oldToNewSpec :: Spec
oldToNewSpec  =
  it "oldToNew" $
    oldToNew [ XXX ["this", "that", "also"]
             , XXX ["here", "there"] ]

             [ (0, [(4, "this")])
             , (0, [(1, "here")])
             , (1, [(5, "that")])
             , (2, [(2, "also")])
             , (2, [(3, "there")]) ]
    `shouldBe`
    [ [(0,4,"this"),(1,5,"that"),(2,2,"also")]
    , [(0,1,"here"),(2,3,"there")] ]

说明

• 用traversed遍历所有层级的列表，结合filtered筛选出符合条件的元素，避免了手动管理累加器。
• has函数用于检查是否存在符合条件的元素，快速筛选出包含目标label的old条目。
• 最终通过folded展平嵌套的结果列表，得到和原代码一致的输出结构。

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