使用Parsec的Haskell HTML解析器

如何解决使用Parsec的Haskell HTML解析器

我当前正在用haskell编写html解析器。我正在使用parsec库。此时，解析器只考虑带有开始和结束标签且没有属性的标准元素。代码如下：

data Html = Element String [Html] | Content String
    deriving Show

element :: Parser Html
element = do
    name <- char '<' *> many1 letter <* char '>'
    children <- many $ (try element) <|> content
    string "</" >> string name >> char '>'
    return $ Element name children

content :: Parser Html
content = fmap Content $ many1 $ satisfy (\x -> x /='<')

如果我对内容使用字母和数字字符，则一切正常。但是，如果使用的是“较少”符号（

感谢和问候菲利普

解决方法

从技术上讲，类似<div>12 < 8</div>的内容是无效的HTML。应该改写为<div>12 < 8</div>。（注释<div>12 > 8</div>中提到的示例实际上是有效的HTML，尽管更常见的是将其转义为<div>12 > 8</div>。）但是，我认为您对编写一个完全正确的HTML解析器并不感兴趣，并且希望您的解析器接受<中的content个字符，这些字符不是有效的开始或结束标记的一部分。

因此，您想接受以下每个示例：

<div>12 < 8</div>
<p>x<y</div>
<pre><<<>>></pre>

但可能想拒绝：

<p>x<y>z</p>

根据<y>是有效的开始标签，但它缺少匹配的</y>并拒绝：

<div>x</dvi>

，因为</dvi>是与当前有效的开始标签不匹配的结束标签。

我将首先为开始和结束标签编写单独的解析器：

startTag :: Parser String
startTag = char '<' *> many1 letter <* char '>'

endTag :: Parser String
endTag = string "</" *> many1 letter <* char '>'

然后，为文本内容的String写一个解析器。这可能很棘手。即使不是理想的性能，这也是一个简单的实现：

contentString :: Parser String
contentString = do
  -- fail if start or end tag (so caller will handle them)
  notFollowedBy startTag
  notFollowedBy endTag
  -- otherwise,parse either '<' as content,or some non-empty '<'-free text
  txt <- string "<" <|> many1 (noneOf "<")
  -- and possibly more text
  rest <- contentString <|> pure ""
  return (txt ++ rest)

请注意我们如何首先确保没有看到<是有效（开始或结束）标记的一部分。然后，我们允许自己解析单个非标签<作为内容，或者解析一些完全不包含<的内容，然后再循环解析更多内容。这是一项很难完成的功能，因此测试是关键。（我花了两到三遍才得到可以处理所有测试用例的东西。）

现在，我们可以重写element来使用startTag和endTag解析器，如下所示：

element :: Parser Html
element = do
    name <- startTag
    children <- many $ try element <|> Content <$> contentString
    name' <- endTag
    when (name /= name') $ unexpected ("</" ++ name' ++ ">,expected </" ++ name ++ ">")
    return $ Element name children

现在我们得到：

λ> parseTest element "<div>12 < 8</div>"
Element "div" [Content "12 < 8"]
λ> parseTest element "<div>x<y</div>"
Element "div" [Content "x<y"]
λ> parseTest element "<pre><<<>>></pre>"
Element "pre" [Content "<<<>>>"]
λ> parseTest element "<p>x<y>z</p>"
parse error at (line 1,column 5):
unexpected "y"
expecting "</"
λ> parseTest element "<div>x</dvi>"
parse error at (line 1,column 13):
unexpected </dvi>,expected </div>

我们可以通过摆弄try中的element来稍微改善第四个测试用例中的错误报告：

element :: Parser Html
element = do
    -- add "try" here
    name <- try startTag
    -- remove "try" here
    children <- many $ element <|> Content <$> contentString
    name' <- endTag
    when (name /= name') $ unexpected ("</" ++ name' ++ ">,expected </" ++ name ++ ">")
    return $ Element name children

给出：

λ> parseTest element "<p>x<y>z</p>"
parse error at (line 1,column 13):
unexpected </p>,expected </y>

可能还有更多测试要做，但是在上述测试用例上似乎还可以，再加上下面给出的一些测试。完整代码：

import Text.Parsec
import Text.Parsec.String
import Control.Monad

data Html = Element String [Html] | Content String
    deriving Show

startTag :: Parser String
startTag = char '<' *> many1 letter <* char '>'

endTag :: Parser String
endTag = string "</" *> many1 letter <* char '>'

element :: Parser Html
element = do
  name <- try startTag
  children <- many $ element <|> Content <$> contentString
  name' <- endTag
  when (name /= name') $ unexpected ("</" ++ name' ++ ">,expected </" ++ name ++ ">")
  return $ Element name children

contentString :: Parser String
contentString = do
  -- fail if start or end tag (so caller will handle them)
  notFollowedBy startTag
  notFollowedBy endTag
  -- otherwise,or some non-empty text
  txt <- string "<" <|> many1 (noneOf "<")
  -- and possibly more text
  rest <- contentString <|> pure ""
  return (txt ++ rest)

main = do
  mapM_ (parseTest element)
    [ "<div>12 < 8</div>","<div>x<y</div>","<pre><<<>>></pre>","<p>x<y>z</p>","<div>x</dvi>","<table><tr><td>1</td><td>2</td></tr></table>","<empty></empty>"
    ]