fd923d6 · typeable/html-parse

git.iko.soy/typeable/html-parse

on master help sign in

Merge branch 'master' of github.com:bgamari/html-parse

fd923d6Ben Gamari8 years ago

Text/HTML/Parser.hs+31−12

compare with master

unifiedsplit

@@ -2,6 +2,8 @@

2{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE LambdaCase #-}

5+{-# OPTIONS_GHC -O2 #-}

5-- | This is a performance-oriented HTML tokenizer aim at web-crawling

7-- | This is a performance-oriented HTML tokenizer aim at web-crawling

6-- applications. It follows the HTML5 parsing specification quite closely,

8-- applications. It follows the HTML5 parsing specification quite closely,

7-- so it behaves reasonable well on ill-formed documents from the open Web.

9-- so it behaves reasonable well on ill-formed documents from the open Web.

@@ -109,13 +111,29 @@ tagOpen =

109endTagOpen :: Parser Token

111endTagOpen :: Parser Token

110endTagOpen = tagNameClose

112endTagOpen = tagNameClose

111

113

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+

112-- | /§8.2.4.8/: Tag name state: the open case

130-- | /§8.2.4.8/: Tag name state: the open case

113--

131--

114-- deviation: no lower-casing, don't handle NULL characters

132-- deviation: no lower-casing, don't handle NULL characters

115tagNameOpen :: Parser Token

133tagNameOpen :: Parser Token

116tagNameOpen = do

134tagNameOpen = do

117 tag <- tagName'

135 tag <- tagName'

118− id $ (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag [])

136+ id $ (satisfy isWhitespace >> beforeAttrName tag [])

119 <|> (char '/' >> selfClosingStartTag tag [])

137 <|> (char '/' >> selfClosingStartTag tag [])

120 <|> (char '>' >> return (TagOpen tag []))

138 <|> (char '>' >> return (TagOpen tag []))

121

139

@@ -132,7 +150,7 @@ tagName' :: Parser Text

132tagName' = do

150tagName' = do

133 c <- peekChar'

151 c <- peekChar'

134 guard $ isAsciiUpper c || isAsciiLower c

152 guard $ isAsciiUpper c || isAsciiLower c

135− takeWhile $ notInClass "\x09\x0a\x0c /<>"

153+ takeWhile $ not . (isWhitespace `orC` isC '/' `orC` isC '<' `orC` isC '>')

136

154

137-- | /§8.2.4.40/: Self-closing start tag state

155-- | /§8.2.4.40/: Self-closing start tag state

138selfClosingStartTag :: TagName -> [Attr] -> Parser Token

156selfClosingStartTag :: TagName -> [Attr] -> Parser Token

@@ -146,7 +164,7 @@ selfClosingStartTag tag attrs = do

146-- deviation: no lower-casing

164-- deviation: no lower-casing

147beforeAttrName :: TagName -> [Attr] -> Parser Token

165beforeAttrName :: TagName -> [Attr] -> Parser Token

148beforeAttrName tag attrs = do

166beforeAttrName tag attrs = do

149− skipWhile $ inClass "\x09\x0a\x0c "

167+ skipWhile isWhitespace

150 id $ (char '/' >> selfClosingStartTag tag attrs)

168 id $ (char '/' >> selfClosingStartTag tag attrs)

151 <|> (char '>' >> return (TagOpen tag attrs))

169 <|> (char '>' >> return (TagOpen tag attrs))

152 -- <|> (char '\x00' >> attrName tag attrs) -- TODO: NULL

170 -- <|> (char '\x00' >> attrName tag attrs) -- TODO: NULL

@@ -155,19 +173,20 @@ beforeAttrName tag attrs = do

155-- | /§8.2.4.33/: Attribute name state

173-- | /§8.2.4.33/: Attribute name state

156attrName :: TagName -> [Attr] -> Parser Token

174attrName :: TagName -> [Attr] -> Parser Token

157attrName tag attrs = do

175attrName tag attrs = do

158− name <- takeWhile $ notInClass "\x09\x0a\x0c /=>"

176+ name <- takeWhile $ not . (isWhitespace `orC` isC '/' `orC` isC '=' `orC` isC '>')

159 id $ (endOfInput >> afterAttrName tag attrs name)

177 id $ (endOfInput >> afterAttrName tag attrs name)

160 <|> (char '=' >> beforeAttrValue tag attrs name)

178 <|> (char '=' >> beforeAttrValue tag attrs name)

161 <|> try (do mc <- peekChar

179 <|> try (do mc <- peekChar

162 case mc of

180 case mc of

163− Just c | inClass "\x09\x0a\x0c />" c -> afterAttrName tag attrs name

181+ Just c | notNameChar c -> afterAttrName tag attrs name

164 _ -> empty)

182 _ -> empty)

165 -- <|> -- TODO: NULL

183 -- <|> -- TODO: NULL

184+ where notNameChar = isWhitespace `orC` isC '/' `orC` isC '>'

166

185

167-- | /§8.2.4.34/: After attribute name state

186-- | /§8.2.4.34/: After attribute name state

168afterAttrName :: TagName -> [Attr] -> AttrName -> Parser Token

187afterAttrName :: TagName -> [Attr] -> AttrName -> Parser Token

169afterAttrName tag attrs name = do

188afterAttrName tag attrs name = do

170− skipWhile $ inClass "\x09\x0a\x0c "

189+ skipWhile isWhitespace

171 id $ (char '/' >> selfClosingStartTag tag attrs)

190 id $ (char '/' >> selfClosingStartTag tag attrs)

172 <|> (char '=' >> beforeAttrValue tag attrs name)

191 <|> (char '=' >> beforeAttrValue tag attrs name)

173 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))

192 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))

@@ -177,7 +196,7 @@ afterAttrName tag attrs name = do

177-- | /§8.2.4.35/: Before attribute value state

196-- | /§8.2.4.35/: Before attribute value state

178beforeAttrValue :: TagName -> [Attr] -> AttrName -> Parser Token

197beforeAttrValue :: TagName -> [Attr] -> AttrName -> Parser Token

179beforeAttrValue tag attrs name = do

198beforeAttrValue tag attrs name = do

180− skipWhile $ inClass "\x09\x0a\x0c "

199+ skipWhile isWhitespace

181 id $ (char '"' >> attrValueDQuoted tag attrs name)

200 id $ (char '"' >> attrValueDQuoted tag attrs name)

182 <|> (char '\'' >> attrValueSQuoted tag attrs name)

201 <|> (char '\'' >> attrValueSQuoted tag attrs name)

183 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))

202 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))

@@ -200,15 +219,15 @@ attrValueSQuoted tag attrs name = do

200-- | /§8.2.4.38/: Attribute value (unquoted) state

219-- | /§8.2.4.38/: Attribute value (unquoted) state

201attrValueUnquoted :: TagName -> [Attr] -> AttrName -> Parser Token

220attrValueUnquoted :: TagName -> [Attr] -> AttrName -> Parser Token

202attrValueUnquoted tag attrs name = do

221attrValueUnquoted tag attrs name = do

203− value <- takeTill (inClass "\x09\x0a\x0c >")

222+ value <- takeTill $ isWhitespace `orC` isC '>'

204− id $ (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag attrs) -- unsure: don't emit?

223+ id $ (satisfy isWhitespace >> beforeAttrName tag attrs) -- unsure: don't emit?

205 <|> (char '>' >> return (TagOpen tag (Attr name value : attrs)))

224 <|> (char '>' >> return (TagOpen tag (Attr name value : attrs)))

206 <|> (endOfInput >> return endOfFileToken)

225 <|> (endOfInput >> return endOfFileToken)

207

226

208-- | /§8.2.4.39/: After attribute value (quoted) state

227-- | /§8.2.4.39/: After attribute value (quoted) state

209afterAttrValueQuoted :: TagName -> [Attr] -> AttrName -> AttrValue -> Parser Token

228afterAttrValueQuoted :: TagName -> [Attr] -> AttrName -> AttrValue -> Parser Token

210afterAttrValueQuoted tag attrs name value =

229afterAttrValueQuoted tag attrs name value =

211− (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag attrs')

230+ (satisfy isWhitespace >> beforeAttrName tag attrs')

212 <|> (char '/' >> selfClosingStartTag tag attrs')

231 <|> (char '/' >> selfClosingStartTag tag attrs')

213 <|> (char '>' >> return (TagOpen tag attrs'))

232 <|> (char '>' >> return (TagOpen tag attrs'))

214 <|> (endOfInput >> return endOfFileToken)

233 <|> (endOfInput >> return endOfFileToken)

@@ -229,7 +248,7 @@ markupDeclOpen =

229 <|> try docType

248 <|> try docType

230 <|> bogusComment mempty

249 <|> bogusComment mempty

231 where

250 where

232− comment_ = string "--" >> commentStart

251+ comment_ = char '-' >> char '-' >> commentStart

233 docType = do

252 docType = do

234 -- switching this to asciiCI slowed things down by a factor of two

253 -- switching this to asciiCI slowed things down by a factor of two

235 s <- take 7

254 s <- take 7

@@ -254,7 +273,7 @@ commentStartDash =

254-- | /§8.2.4.45/: Comment state

273-- | /§8.2.4.45/: Comment state

255comment :: Builder -> Parser Token

274comment :: Builder -> Parser Token

256comment content0 = do

275comment content0 = do

257− content <- B.fromText <$> takeWhile (notInClass "-\x00<")

276+ content <- B.fromText <$> takeWhile (not . (isC '-' `orC` isC '\x00' `orC` isC '<'))

258 id $ (char '<' >> commentLessThan (content0 <> content <> "<"))

277 id $ (char '<' >> commentLessThan (content0 <> content <> "<"))

259 <|> (char '-' >> commentEndDash (content0 <> content))

278 <|> (char '-' >> commentEndDash (content0 <> content))

260 <|> (char '\x00' >> comment (content0 <> content <> B.singleton '\xfffd'))

279 <|> (char '\x00' >> comment (content0 <> content <> B.singleton '\xfffd'))

html-parse.cabal+14−14

@@ -16,31 +16,31 @@ description:

16 TagSelfClose "br" []]

17 .

18 The package targets similar use-cases to the venerable @tagsoup@ library,

19− but is significantly more efficient, achieving parsing speeds of over 50

19+ but is significantly more efficient, achieving parsing speeds of over 80

20 megabytes per second on modern hardware and typical web documents.

21 Here are some typical performance numbers taken from parsing a Wikipedia

22 article of moderate length:

23 .

24 @

25 benchmarking Forced/tagsoup fast Text

26− time 171.2 ms (166.4 ms .. 177.3 ms)

26+ time 186.1 ms (175.3 ms .. 194.6 ms)

27− 0.999 R² (0.997 R² .. 1.000 R²)

27+ 0.999 R² (0.995 R² .. 1.000 R²)

28− mean 171.9 ms (169.4 ms .. 173.2 ms)

28+ mean 191.7 ms (188.9 ms .. 198.3 ms)

29− std dev 2.516 ms (1.104 ms .. 3.558 ms)

29+ std dev 5.053 ms (1.092 ms .. 6.809 ms)

30− variance introduced by outliers: 12% (moderately inflated)

30+ variance introduced by outliers: 14% (moderately inflated)

31 .

32 benchmarking Forced/tagsoup normal Text

33− time 176.9 ms (167.3 ms .. 188.5 ms)

33+ time 189.7 ms (182.8 ms .. 197.7 ms)

34− 0.998 R² (0.994 R² .. 1.000 R²)

34+ 0.999 R² (0.998 R² .. 1.000 R²)

35− mean 180.7 ms (177.5 ms .. 183.7 ms)

35+ mean 196.5 ms (193.1 ms .. 202.1 ms)

36− std dev 4.246 ms (2.316 ms .. 5.803 ms)

36+ std dev 5.481 ms (2.141 ms .. 7.383 ms)

37 variance introduced by outliers: 14% (moderately inflated)

38 .

39 benchmarking Forced/html-parser

40− time 20.88 ms (20.60 ms .. 21.25 ms)

40+ time 15.81 ms (15.75 ms .. 15.89 ms)

41− 0.999 R² (0.998 R² .. 0.999 R²)

41+ 1.000 R² (1.000 R² .. 1.000 R²)

42− mean 20.99 ms (20.81 ms .. 21.20 ms)

42+ mean 15.72 ms (15.66 ms .. 15.77 ms)

43− std dev 446.1 μs (336.4 μs .. 596.2 μs)

43+ std dev 140.9 μs (113.6 μs .. 174.5 μs)

44 @

46homepage: http://github.com/bgamari/html-parse