@@ -2,6 +2,8 @@
22{-# LANGUAGE DeriveGeneric #-}
33{-# LANGUAGE LambdaCase #-}
44
5+{-# OPTIONS_GHC -O2 #-}
6+
57-- | This is a performance-oriented HTML tokenizer aim at web-crawling
68-- applications. It follows the HTML5 parsing specification quite closely,
79-- so it behaves reasonable well on ill-formed documents from the open Web.
@@ -109,13 +111,29 @@ tagOpen =
109111endTagOpen :: Parser Token
110112endTagOpen = tagNameClose
111113
114+-- | Equivalent to @inClass "\x09\x0a\x0c "@
115+isWhitespace :: Char -> Bool
116+isWhitespace '\x09' = True
117+isWhitespace '\x0a' = True
118+isWhitespace '\x0c' = True
119+isWhitespace ' ' = True
120+isWhitespace _ = False
121+
122+orC :: (Char -> Bool) -> (Char -> Bool) -> Char -> Bool
123+orC f g c = f c || g c
124+{-# INLINE orC #-}
125+
126+isC :: Char -> Char -> Bool
127+isC = (==)
128+{-# INLINE isC #-}
129+
112130-- | /§8.2.4.8/: Tag name state: the open case
113131--
114132-- deviation: no lower-casing, don't handle NULL characters
115133tagNameOpen :: Parser Token
116134tagNameOpen = do
117135 tag <- tagName'
118− id $ (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag [])
136+ id $ (satisfy isWhitespace >> beforeAttrName tag [])
119137 <|> (char '/' >> selfClosingStartTag tag [])
120138 <|> (char '>' >> return (TagOpen tag []))
121139
@@ -132,7 +150,7 @@ tagName' :: Parser Text
132150tagName' = do
133151 c <- peekChar'
134152 guard $ isAsciiUpper c || isAsciiLower c
135− takeWhile $ notInClass "\x09\x0a\x0c /<>"
153+ takeWhile $ not . (isWhitespace `orC` isC '/' `orC` isC '<' `orC` isC '>')
136154
137155-- | /§8.2.4.40/: Self-closing start tag state
138156selfClosingStartTag :: TagName -> [Attr] -> Parser Token
@@ -146,7 +164,7 @@ selfClosingStartTag tag attrs = do
146164-- deviation: no lower-casing
147165beforeAttrName :: TagName -> [Attr] -> Parser Token
148166beforeAttrName tag attrs = do
149− skipWhile $ inClass "\x09\x0a\x0c "
167+ skipWhile isWhitespace
150168 id $ (char '/' >> selfClosingStartTag tag attrs)
151169 <|> (char '>' >> return (TagOpen tag attrs))
152170 -- <|> (char '\x00' >> attrName tag attrs) -- TODO: NULL
@@ -155,19 +173,20 @@ beforeAttrName tag attrs = do
155173-- | /§8.2.4.33/: Attribute name state
156174attrName :: TagName -> [Attr] -> Parser Token
157175attrName tag attrs = do
158− name <- takeWhile $ notInClass "\x09\x0a\x0c /=>"
176+ name <- takeWhile $ not . (isWhitespace `orC` isC '/' `orC` isC '=' `orC` isC '>')
159177 id $ (endOfInput >> afterAttrName tag attrs name)
160178 <|> (char '=' >> beforeAttrValue tag attrs name)
161179 <|> try (do mc <- peekChar
162180 case mc of
163− Just c | inClass "\x09\x0a\x0c />" c -> afterAttrName tag attrs name
181+ Just c | notNameChar c -> afterAttrName tag attrs name
164182 _ -> empty)
165183 -- <|> -- TODO: NULL
184+ where notNameChar = isWhitespace `orC` isC '/' `orC` isC '>'
166185
167186-- | /§8.2.4.34/: After attribute name state
168187afterAttrName :: TagName -> [Attr] -> AttrName -> Parser Token
169188afterAttrName tag attrs name = do
170− skipWhile $ inClass "\x09\x0a\x0c "
189+ skipWhile isWhitespace
171190 id $ (char '/' >> selfClosingStartTag tag attrs)
172191 <|> (char '=' >> beforeAttrValue tag attrs name)
173192 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
@@ -177,7 +196,7 @@ afterAttrName tag attrs name = do
177196-- | /§8.2.4.35/: Before attribute value state
178197beforeAttrValue :: TagName -> [Attr] -> AttrName -> Parser Token
179198beforeAttrValue tag attrs name = do
180− skipWhile $ inClass "\x09\x0a\x0c "
199+ skipWhile isWhitespace
181200 id $ (char '"' >> attrValueDQuoted tag attrs name)
182201 <|> (char '\'' >> attrValueSQuoted tag attrs name)
183202 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
@@ -200,15 +219,15 @@ attrValueSQuoted tag attrs name = do
200219-- | /§8.2.4.38/: Attribute value (unquoted) state
201220attrValueUnquoted :: TagName -> [Attr] -> AttrName -> Parser Token
202221attrValueUnquoted tag attrs name = do
203− value <- takeTill (inClass "\x09\x0a\x0c >")
204− id $ (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag attrs) -- unsure: don't emit?
222+ value <- takeTill $ isWhitespace `orC` isC '>'
223+ id $ (satisfy isWhitespace >> beforeAttrName tag attrs) -- unsure: don't emit?
205224 <|> (char '>' >> return (TagOpen tag (Attr name value : attrs)))
206225 <|> (endOfInput >> return endOfFileToken)
207226
208227-- | /§8.2.4.39/: After attribute value (quoted) state
209228afterAttrValueQuoted :: TagName -> [Attr] -> AttrName -> AttrValue -> Parser Token
210229afterAttrValueQuoted tag attrs name value =
211− (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag attrs')
230+ (satisfy isWhitespace >> beforeAttrName tag attrs')
212231 <|> (char '/' >> selfClosingStartTag tag attrs')
213232 <|> (char '>' >> return (TagOpen tag attrs'))
214233 <|> (endOfInput >> return endOfFileToken)
@@ -229,7 +248,7 @@ markupDeclOpen =
229248 <|> try docType
230249 <|> bogusComment mempty
231250 where
232− comment_ = string "--" >> commentStart
251+ comment_ = char '-' >> char '-' >> commentStart
233252 docType = do
234253 -- switching this to asciiCI slowed things down by a factor of two
235254 s <- take 7
@@ -254,7 +273,7 @@ commentStartDash =
254273-- | /§8.2.4.45/: Comment state
255274comment :: Builder -> Parser Token
256275comment content0 = do
257− content <- B.fromText <$> takeWhile (notInClass "-\x00<")
276+ content <- B.fromText <$> takeWhile (not . (isC '-' `orC` isC '\x00' `orC` isC '<'))
258277 id $ (char '<' >> commentLessThan (content0 <> content <> "<"))
259278 <|> (char '-' >> commentEndDash (content0 <> content))
260279 <|> (char '\x00' >> comment (content0 <> content <> B.singleton '\xfffd'))