Haskell中如何从XML文件提取指定嵌套文本并格式化输出

我有一个包含多个<parent>标签的XML文件，格式如下：

<file>
<parent title = "counting">
<child>
  <notme></notme>
  <me>One <a>Two</a> Three</me>
  <notwanted></notwanted>
  <me>Four Five <a>Six</a></me>
  <notwanted></notwanted>
  <me>Seven Eight <a>Nine</a></me>
</child>
</parent>
</file>

期望处理后，每个<parent>标签对应输出：

Title - counting
One Two Three
Four Five Six
Seven Eight Nine

尝试过hxt、text.xml等XML库，但未成功实现，核心难点是将<a>标签内的文本正确嵌入到周围文本中，需要实现该功能的小型函数或合适的库推荐。

推荐使用Haskell生态中的xml-conduit库，它对嵌套节点的文本提取支持非常友好，能轻松解决你遇到的问题。

步骤1：添加依赖 #

在项目的cabal配置文件中添加以下依赖：

build-depends: base >= 4.14 && < 5, xml-conduit, text, conduit

步骤2：实现处理函数 #

以下是完整的处理代码，可直接复用：

import Text.XML
import Text.XML.Cursor
import Data.Text (Text, unpack, concat)
import Prelude hiding (concat)

-- 处理指定路径的XML文件
processXML :: FilePath -> IO ()
processXML filePath = do
  doc <- readFile def filePath
  let cursor = fromDocument doc
      -- 定位所有parent节点
      parents = cursor $// element "parent"
  -- 逐个处理每个parent节点
  mapM_ processParent parents
  where
    processParent parent = do
      -- 提取parent标签的title属性
      let title = parent $/ attribute "title"
      putStrLn $ "Title - " ++ unpack (head title)
      -- 提取所有me节点，并合并每个me节点下的所有文本（含嵌套a标签的内容）
      let meNodes = parent $// element "me"
          meTexts = map (concat . ($/ content)) meNodes
      -- 输出每个me节点的合并文本
      mapM_ (putStrLn . unpack) meTexts

-- 调用示例：processXML "your-input.xml"

代码说明 #

• $// element "parent"：递归遍历XML文档，找到所有<parent>节点
• attribute "title"：提取<parent>标签的title属性值
• $/ content：提取当前节点及其所有子节点的文本内容，自动合并嵌套标签（如<a>）内的文本
• concat：将同一<me>节点下的多个文本片段合并为完整字符串

备选方案：使用tagsoup库 #

如果偏好更轻量的标签流处理方式，可以选择tagsoup库，它的innerText函数能直接提取标签块内的所有文本：

添加依赖 #

build-depends: base >= 4.14 && < 5, tagsoup, text

实现代码 #

import Text.HTML.TagSoup
import Data.Text (unpack)
import Data.List (break)

processXMLWithTagSoup :: FilePath -> IO ()
processXMLWithTagSoup filePath = do
  content <- readFile filePath
  let tags = parseTags content
      parents = splitParentBlocks tags
  mapM_ processParentBlock parents
  where
    -- 分割出每个parent标签块
    splitParentBlocks [] = []
    splitParentBlocks tags =
      let (parent, rest) = break (~== TagClose "parent") tags
      in parent : splitParentBlocks (drop 1 rest)
    -- 处理单个parent标签块
    processParentBlock parent = do
      let title = [v | TagOpen "parent" attrs <- parent, (k, v) <- attrs, k == "title"]
      putStrLn $ "Title - " ++ unpack (head title)
      let meBlocks = splitMeBlocks parent
          meTexts = map (unpack . innerText) meBlocks
      mapM_ putStrLn meTexts
    -- 分割出每个me标签块
    splitMeBlocks [] = []
    splitMeBlocks tags =
      case break (~== TagOpen "me") tags of
        (_, []) -> []
        (_, rest) -> let (me, r) = break (~== TagClose "me") rest in me : splitMeBlocks (drop 1 r)

说明 #

innerText函数会自动遍历标签块内的所有节点，将所有文本内容拼接成字符串，完美解决嵌套<a>标签的文本嵌入问题。

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