git.iko.soy/typeable/html-parse
on master help sign in
Merge pull request #8 from zerobuzz/parse-header-tags

Parsing `<H1>` fails?

commitaf5d28da690acd22eb35a8d22715fa1d50e9f698 authorBen Gamari <ben@smart-cactus.org> dateSat 31 Dec 2016, 11:20 (10 years ago) parent02fd95a15cc25f
2 files changed+59−29
compare with master
unifiedsplit
Text/HTML/Parser.hs+22−16 tests/Text/HTML/ParserSpec.hs+37−13
Text/HTML/Parser.hs+22−16
@@ -91,35 +91,41 @@ tagOpen =
9191 (char '!' >> markupDeclOpen)
9292 <|> (char '/' >> endTagOpen)
9393 <|> (char '?' >> bogusComment)
94− <|> tryStartTag
94+ <|> tagNameOpen
9595 <|> other
9696 where
97− tryStartTag = do
98− c <- peekChar'
99− guard $ isAsciiUpper c || isAsciiLower c
100− tagName
101−
10297 other = do
10398 return $ ContentChar '<'
10499
105100-- | /§8.2.4.9/: End tag open state
106−-- TODO: This isn't right
107101endTagOpen :: Parser Token
108−endTagOpen = do
109− name <- takeWhile $ \c -> isAsciiUpper c || isAsciiLower c
110− char '>'
111− return $ TagClose name
102+endTagOpen = tagNameClose
112103
113−-- | /§8.2.4.10/: Tag name state
104+-- | /§8.2.4.10/: Tag name state: the open case
114105--
115106-- deviation: no lower-casing
116−tagName :: Parser Token
117−tagName = do
118− tag <- takeWhile $ notInClass "\x09\x0a\x0c />"
107+tagNameOpen :: Parser Token
108+tagNameOpen = do
109+ tag <- tagName'
119110 id $ (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag [])
120111 <|> (char '/' >> selfClosingStartTag tag [])
121112 <|> (char '>' >> return (TagOpen tag []))
122113
114+-- | /§8.2.4.10/: Tag name state: close case
115+tagNameClose :: Parser Token
116+tagNameClose = do
117+ tag <- tagName'
118+ char '>' >> return (TagClose tag)
119+
120+-- | /§8.2.4.10/: Tag name state: common code
121+--
122+-- deviation: no lower-casing
123+tagName' :: Parser Text
124+tagName' = do
125+ c <- peekChar'
126+ guard $ isAsciiUpper c || isAsciiLower c
127+ takeWhile $ notInClass "\x09\x0a\x0c /<>"
128+
123129-- | /§8.2.4.43/: Self-closing start tag state
124130selfClosingStartTag :: TagName -> [Attr] -> Parser Token
125131selfClosingStartTag tag attrs = do
@@ -140,7 +146,7 @@ beforeAttrName tag attrs = do
140146-- | /§8.2.4.35/: Attribute name state
141147attrName :: TagName -> [Attr] -> Parser Token
142148attrName tag attrs = do
143− name <- takeWhile $ notInClass "\x09\x0a\x0c /=>\x00"
149+ name <- takeWhile $ notInClass "\x09\x0a\x0c /=<>\x00"
144150 id $ (satisfy (inClass "\x09\x0a\x0c ") >> afterAttrName tag attrs name)
145151 <|> (char '/' >> selfClosingStartTag tag attrs)
146152 <|> (char '=' >> beforeAttrValue tag attrs name)
tests/Text/HTML/ParserSpec.hs+37−13
@@ -11,6 +11,7 @@ where
1111
1212import Control.Applicative
1313import Data.Monoid
14+import Data.List ((\\))
1415import qualified Data.Text as T
1516import qualified Data.Text.Lazy as TL
1617import qualified Data.Text.Lazy.Builder as B
@@ -31,39 +32,57 @@ instance Arbitrary Token where
3132 shrink (Doctype t) = Doctype <$> shrink t
3233
3334instance Arbitrary Attr where
34− arbitrary = Attr <$> validXmlTag <*> validXmlText
35+ arbitrary = Attr <$> validXmlAttrName <*> validXmlAttrValue
3536 shrink (Attr k v) = Attr <$> shrink k <*> shrink v
3637
3738validOpen :: Gen Token
38−validOpen = TagOpen <$> validXmlTag <*> arbitrary
39+validOpen = TagOpen <$> validXmlTagName <*> arbitrary
3940
4041validClose :: Gen Token
41−validClose = TagClose <$> validXmlTag
42+validClose = TagClose <$> validXmlTagName
4243
4344validFlat :: Gen Token
4445validFlat = oneof
4546 [ ContentChar <$> validXmlChar
4647 , ContentText <$> validXmlText
47− , Comment . B.fromText <$> validXmlText
48+ , Comment . B.fromText <$> validXmlCommentText
4849 , Doctype <$> validXmlText
4950 ]
5051
52+-- FIXME: sometimes it is allowed to use '<' as text token, and we don't test that yet. (whether we
53+-- like this choice or not, we may want to follow the standard here.) (same in tag names, attr
54+-- names.)
5155validXmlChar :: Gen Char
52−validXmlChar = elements (' ' : ['a'..'z']) -- FIXME: generate wider range of values
53−
54−validXmlTag :: Gen T.Text
55−validXmlTag = T.pack <$> sized (`maxListOf1` elements ['a'..'z']) -- FIXME: generate wider range of values
56+validXmlChar = elements (['\x20'..'\x7E'] \\ "\x09\x0a\x0c /<>")
5657
5758validXmlText :: Gen T.Text
58−validXmlText = mconcat <$> sized (`maxListOf` (T.cons <$> validXmlChar <*> validXmlTag)) -- FIXME: generate wider range of values
59+validXmlText = T.pack <$> sized (`maxListOf` validXmlChar)
60+
61+validXmlTagName :: Gen T.Text
62+validXmlTagName = do
63+ initchar <- elements $ ['a'..'z'] <> ['A'..'Z']
64+ thenchars <- sized (`maxListOf` elements (['\x20'..'\x7E'] \\ "\x09\x0a\x0c /<>"))
65+ pure . T.pack $ initchar : thenchars
66+
67+validXmlAttrName :: Gen T.Text
68+validXmlAttrName = do
69+ initchar <- elements $ ['a'..'z'] <> ['A'..'Z']
70+ thenchars <- sized (`maxListOf` elements (['\x20'..'\x7E'] \\ "\x09\x0a\x0c /=<>\x00"))
71+ pure . T.pack $ initchar : thenchars
72+
73+-- FIXME: not sure if @Attr "key" "\""@ should be parseable, but it's not, so we don't test it.
74+validXmlAttrValue :: Gen T.Text
75+validXmlAttrValue = do
76+ T.pack <$> sized (`maxListOf` elements (['\x20'..'\x7E'] \\ "\x09\x0a\x0c /=<>\x00\""))
77+
78+-- FIXME: i think this should be 'validXmlChar', but that will fail the test suite.
79+validXmlCommentText :: Gen T.Text
80+validXmlCommentText = do
81+ T.pack <$> sized (`maxListOf` elements (['\x20'..'\x7E'] \\ "\x09\x0a\x0c /=<>\x00\"-"))
5982
6083maxListOf :: Int -> Gen a -> Gen [a]
6184maxListOf n g = take n <$> listOf g
6285
63−maxListOf1 :: Int -> Gen a -> Gen [a]
64−maxListOf1 (min 1 -> n) g = take n <$> listOf1 g
65−
66−
6786
6887spec :: Spec
6988spec = do
@@ -74,3 +93,8 @@ spec = do
7493 it "canonicalizeTokens is idempotent" . property . forAllShrink arbitrary shrink $
7594 \tokens
7695 -> canonicalizeTokens tokens `shouldBe` canonicalizeTokens (canonicalizeTokens tokens)
96+
97+ describe "regression tests" $ do
98+ describe "parseTokens" $ do
99+ it "works on `<h1>Heading</h1>`" $ do
100+ parseTokens "<h1>Heading</h1>" `shouldBe` [TagOpen "h1" [], ContentText "Heading", TagClose "h1"]