diff --git a/html-tokenizer.cabal b/html-tokenizer.cabal
--- a/html-tokenizer.cabal
+++ b/html-tokenizer.cabal
@@ -1,7 +1,7 @@
name:
html-tokenizer
version:
- 0.5.1
+ 0.5.2
synopsis:
An "attoparsec"-based HTML tokenizer
description:
diff --git a/library/HTMLTokenizer/Parsing.hs b/library/HTMLTokenizer/Parsing.hs
--- a/library/HTMLTokenizer/Parsing.hs
+++ b/library/HTMLTokenizer/Parsing.hs
@@ -20,45 +20,54 @@
token :: Parser Token
token =
labeled "HTML Token" $
- DoctypeToken <$> doctype <|>
- openingTag OpeningTagToken <|>
- ClosingTagToken <$> closingTag <|>
- TextToken <$> textBetweenTags <|>
- CommentToken <$> comment <|>
- fail "Invalid token"
-
-{-|
->>> parseOnly doctype ""
-Right "html PUBLIC \"-//W3C//DTD XHTML+RDFa 1.0//EN\" \"http://www.w3.org/MarkUp/DTD/xhtml-rdfa-1.dtd\""
--}
-doctype :: Parser Text
-doctype =
- labeled "Doctype" $ do
- string "')
- char '>'
- return contents
-
-openingTag :: (Name -> Vector Attribute -> Bool -> openingTag) -> Parser openingTag
-openingTag openingTag =
- labeled "Opening tag" $ do
- char '<'
- skipSpace
- tagName <- name
- attributes <- C.many (space *> skipSpace *> attribute)
- skipSpace
- closed <- (char '/' $> True) <|> pure False
- char '>'
- return (openingTag tagName attributes closed)
-
-closingTag :: Parser Name
-closingTag =
- labeled "Closing tag" $
- string " skipSpace *> name <* skipSpace <* char '>'
+ join
+ (mplus
+ (do
+ char '<'
+ mplus
+ (do
+ char '!'
+ mplus
+ (string "--" $> commentTagBody)
+ (asciiCI "doctype" $> doctypeTagBody))
+ (mplus
+ (char '/' $> closingTagBody)
+ (pure openingTagBody)))
+ (pure (TextToken <$> textBetweenTags)))
+ where
+ commentTagBody =
+ labeled "Comment" (CommentToken . A.run <$> loop mempty)
+ where
+ loop !builder =
+ do
+ textWithoutDashes <- A.text <$> takeWhile (/= '-')
+ mplus
+ (string "-->" $> builder <> textWithoutDashes)
+ (mplus
+ (char '-' *> loop (builder <> textWithoutDashes <> A.char '-'))
+ (return (builder <> textWithoutDashes)))
+ where
+ textWithoutDashes =
+ A.text <$> takeWhile1 (/= '-')
+ doctypeTagBody =
+ labeled "Doctype" $ do
+ space
+ skipSpace
+ contents <- takeWhile1 (/= '>')
+ char '>'
+ return (DoctypeToken contents)
+ closingTagBody =
+ labeled "Closing tag" $
+ skipSpace *> (ClosingTagToken <$> name) <* skipSpace <* char '>'
+ openingTagBody =
+ labeled "Opening tag" $ do
+ skipSpace
+ tagName <- name
+ attributes <- C.many (space *> skipSpace *> attribute)
+ skipSpace
+ closed <- (char '/' $> True) <|> pure False
+ char '>'
+ return (OpeningTagToken tagName attributes closed)
textBetweenTags :: Parser Text
textBetweenTags =
@@ -93,23 +102,6 @@
if D.null unconsumedSpace
then return builder
else return (builder <> A.char ' ')
-
-comment :: Parser Text
-comment =
- labeled "Comment" $
- string "" $> builder <> textWithoutDashes)
- (mplus
- (char '-' *> loop (builder <> textWithoutDashes <> A.char '-'))
- (return (builder <> textWithoutDashes)))
- where
- textWithoutDashes =
- A.text <$> takeWhile1 (/= '-')
attribute :: Parser Attribute
attribute =
diff --git a/tests/Main.hs b/tests/Main.hs
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -61,8 +61,8 @@
""
,
testTokenParsing "Closing tag"
- (Right (A.DoctypeToken "html"))
- ""
+ (Right (A.DoctypeToken "html PUBLIC \"-//W3C//DTD XHTML+RDFa 1.0//EN\" \"http://www.w3.org/MarkUp/DTD/xhtml-rdfa-1.dtd\""))
+ ""
,
testTokensParsing "Text between tags, stripped"
(Right