git.iko.soy/typeable/html-parse
on master help sign in
Merge pull request #8 from zerobuzz/parse-header-tags
af5d28dBen Gamari
Text/HTML/Parser.hs+22−16
compare with master
unifiedsplit
@@ -91,35 +91,41 @@ tagOpen =
91 (char '!' >> markupDeclOpen)
91 (char '!' >> markupDeclOpen)
92 <|> (char '/' >> endTagOpen)
92 <|> (char '/' >> endTagOpen)
93 <|> (char '?' >> bogusComment)
93 <|> (char '?' >> bogusComment)
94− <|> tryStartTag
94+ <|> tagNameOpen
95 <|> other
95 <|> other
96 where
96 where
97− tryStartTag = do
98− c <- peekChar'
99− guard $ isAsciiUpper c || isAsciiLower c
100− tagName
101−
102 other = do
97 other = do
103 return $ ContentChar '<'
98 return $ ContentChar '<'
104
99
105-- | /§8.2.4.9/: End tag open state
100-- | /§8.2.4.9/: End tag open state
106−-- TODO: This isn't right
107endTagOpen :: Parser Token
101endTagOpen :: Parser Token
108−endTagOpen = do
102+endTagOpen = tagNameClose
109− name <- takeWhile $ \c -> isAsciiUpper c || isAsciiLower c
110− char '>'
111− return $ TagClose name
112
103
113−-- | /§8.2.4.10/: Tag name state
104+-- | /§8.2.4.10/: Tag name state: the open case
114--
105--
115-- deviation: no lower-casing
106-- deviation: no lower-casing
116−tagName :: Parser Token
107+tagNameOpen :: Parser Token
117−tagName = do
108+tagNameOpen = do
118− tag <- takeWhile $ notInClass "\x09\x0a\x0c />"
109+ tag <- tagName'
119 id $ (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag [])
110 id $ (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag [])
120 <|> (char '/' >> selfClosingStartTag tag [])
111 <|> (char '/' >> selfClosingStartTag tag [])
121 <|> (char '>' >> return (TagOpen tag []))
112 <|> (char '>' >> return (TagOpen tag []))
122
113
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+
123-- | /§8.2.4.43/: Self-closing start tag state
129-- | /§8.2.4.43/: Self-closing start tag state
124selfClosingStartTag :: TagName -> [Attr] -> Parser Token
130selfClosingStartTag :: TagName -> [Attr] -> Parser Token
125selfClosingStartTag tag attrs = do
131selfClosingStartTag tag attrs = do
@@ -140,7 +146,7 @@ beforeAttrName tag attrs = do
140-- | /§8.2.4.35/: Attribute name state
146-- | /§8.2.4.35/: Attribute name state
141attrName :: TagName -> [Attr] -> Parser Token
147attrName :: TagName -> [Attr] -> Parser Token
142attrName tag attrs = do
148attrName tag attrs = do
143− name <- takeWhile $ notInClass "\x09\x0a\x0c /=>\x00"
149+ name <- takeWhile $ notInClass "\x09\x0a\x0c /=<>\x00"
144 id $ (satisfy (inClass "\x09\x0a\x0c ") >> afterAttrName tag attrs name)
150 id $ (satisfy (inClass "\x09\x0a\x0c ") >> afterAttrName tag attrs name)
145 <|> (char '/' >> selfClosingStartTag tag attrs)
151 <|> (char '/' >> selfClosingStartTag tag attrs)
146 <|> (char '=' >> beforeAttrValue tag attrs name)
152 <|> (char '=' >> beforeAttrValue tag attrs name)
tests/Text/HTML/ParserSpec.hs+37−13
@@ -11,6 +11,7 @@ where
11
11
12import Control.Applicative
12import Control.Applicative
13import Data.Monoid
13import Data.Monoid
14+import Data.List ((\\))
14import qualified Data.Text as T
15import qualified Data.Text as T
15import qualified Data.Text.Lazy as TL
16import qualified Data.Text.Lazy as TL
16import qualified Data.Text.Lazy.Builder as B
17import qualified Data.Text.Lazy.Builder as B
@@ -31,39 +32,57 @@ instance Arbitrary Token where
31 shrink (Doctype t) = Doctype <$> shrink t
32 shrink (Doctype t) = Doctype <$> shrink t
32
33
33instance Arbitrary Attr where
34instance Arbitrary Attr where
34− arbitrary = Attr <$> validXmlTag <*> validXmlText
35+ arbitrary = Attr <$> validXmlAttrName <*> validXmlAttrValue
35 shrink (Attr k v) = Attr <$> shrink k <*> shrink v
36 shrink (Attr k v) = Attr <$> shrink k <*> shrink v
36
37
37validOpen :: Gen Token
38validOpen :: Gen Token
38−validOpen = TagOpen <$> validXmlTag <*> arbitrary
39+validOpen = TagOpen <$> validXmlTagName <*> arbitrary
39
40
40validClose :: Gen Token
41validClose :: Gen Token
41−validClose = TagClose <$> validXmlTag
42+validClose = TagClose <$> validXmlTagName
42
43
43validFlat :: Gen Token
44validFlat :: Gen Token
44validFlat = oneof
45validFlat = oneof
45 [ ContentChar <$> validXmlChar
46 [ ContentChar <$> validXmlChar
46 , ContentText <$> validXmlText
47 , ContentText <$> validXmlText
47− , Comment . B.fromText <$> validXmlText
48+ , Comment . B.fromText <$> validXmlCommentText
48 , Doctype <$> validXmlText
49 , Doctype <$> validXmlText
49 ]
50 ]
50
51
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.)
51validXmlChar :: Gen Char
55validXmlChar :: Gen Char
52−validXmlChar = elements (' ' : ['a'..'z']) -- FIXME: generate wider range of values
56+validXmlChar = elements (['\x20'..'\x7E'] \\ "\x09\x0a\x0c /<>")
53−
54−validXmlTag :: Gen T.Text
55−validXmlTag = T.pack <$> sized (`maxListOf1` elements ['a'..'z']) -- FIXME: generate wider range of values
56
57
57validXmlText :: Gen T.Text
58validXmlText :: 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\"-"))
59
82
60maxListOf :: Int -> Gen a -> Gen [a]
83maxListOf :: Int -> Gen a -> Gen [a]
61maxListOf n g = take n <$> listOf g
84maxListOf n g = take n <$> listOf g
62
85
63−maxListOf1 :: Int -> Gen a -> Gen [a]
64−maxListOf1 (min 1 -> n) g = take n <$> listOf1 g
65−
66−
67
86
68spec :: Spec
87spec :: Spec
69spec = do
88spec = do
@@ -74,3 +93,8 @@ spec = do
74 it "canonicalizeTokens is idempotent" . property . forAllShrink arbitrary shrink $
93 it "canonicalizeTokens is idempotent" . property . forAllShrink arbitrary shrink $
75 \tokens
94 \tokens
76 -> canonicalizeTokens tokens `shouldBe` canonicalizeTokens (canonicalizeTokens tokens)
95 -> 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"]