diff --git a/Text/HTML/Parser.hs b/Text/HTML/Parser.hs --- a/Text/HTML/Parser.hs +++ b/Text/HTML/Parser.hs @@ -2,6 +2,8 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -O2 #-} + -- | This is a performance-oriented HTML tokenizer aim at web-crawling -- applications. It follows the HTML5 parsing specification quite closely, -- so it behaves reasonable well on ill-formed documents from the open Web. @@ -109,13 +111,29 @@ endTagOpen :: Parser Token endTagOpen = tagNameClose +-- | Equivalent to @inClass "\x09\x0a\x0c "@ +isWhitespace :: Char -> Bool +isWhitespace '\x09' = True +isWhitespace '\x0a' = True +isWhitespace '\x0c' = True +isWhitespace ' ' = True +isWhitespace _ = False + +orC :: (Char -> Bool) -> (Char -> Bool) -> Char -> Bool +orC f g c = f c || g c +{-# INLINE orC #-} + +isC :: Char -> Char -> Bool +isC = (==) +{-# INLINE isC #-} + -- | /§8.2.4.8/: Tag name state: the open case -- -- deviation: no lower-casing, don't handle NULL characters tagNameOpen :: Parser Token tagNameOpen = do tag <- tagName' - id $ (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag []) + id $ (satisfy isWhitespace >> beforeAttrName tag []) <|> (char '/' >> selfClosingStartTag tag []) <|> (char '>' >> return (TagOpen tag [])) @@ -132,7 +150,7 @@ tagName' = do c <- peekChar' guard $ isAsciiUpper c || isAsciiLower c - takeWhile $ notInClass "\x09\x0a\x0c /<>" + takeWhile $ not . (isWhitespace `orC` isC '/' `orC` isC '<' `orC` isC '>') -- | /§8.2.4.40/: Self-closing start tag state selfClosingStartTag :: TagName -> [Attr] -> Parser Token @@ -146,7 +164,7 @@ -- deviation: no lower-casing beforeAttrName :: TagName -> [Attr] -> Parser Token beforeAttrName tag attrs = do - skipWhile $ inClass "\x09\x0a\x0c " + skipWhile isWhitespace id $ (char '/' >> selfClosingStartTag tag attrs) <|> (char '>' >> return (TagOpen tag attrs)) -- <|> (char '\x00' >> attrName tag attrs) -- TODO: NULL @@ -155,19 +173,20 @@ -- | /§8.2.4.33/: Attribute name state attrName :: TagName -> [Attr] -> Parser Token attrName tag attrs = do - name <- takeWhile $ notInClass "\x09\x0a\x0c /=>" + name <- takeWhile $ not . (isWhitespace `orC` isC '/' `orC` isC '=' `orC` isC '>') id $ (endOfInput >> afterAttrName tag attrs name) <|> (char '=' >> beforeAttrValue tag attrs name) <|> try (do mc <- peekChar case mc of - Just c | inClass "\x09\x0a\x0c />" c -> afterAttrName tag attrs name + Just c | notNameChar c -> afterAttrName tag attrs name _ -> empty) -- <|> -- TODO: NULL + where notNameChar = isWhitespace `orC` isC '/' `orC` isC '>' -- | /§8.2.4.34/: After attribute name state afterAttrName :: TagName -> [Attr] -> AttrName -> Parser Token afterAttrName tag attrs name = do - skipWhile $ inClass "\x09\x0a\x0c " + skipWhile isWhitespace id $ (char '/' >> selfClosingStartTag tag attrs) <|> (char '=' >> beforeAttrValue tag attrs name) <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs))) @@ -177,7 +196,7 @@ -- | /§8.2.4.35/: Before attribute value state beforeAttrValue :: TagName -> [Attr] -> AttrName -> Parser Token beforeAttrValue tag attrs name = do - skipWhile $ inClass "\x09\x0a\x0c " + skipWhile isWhitespace id $ (char '"' >> attrValueDQuoted tag attrs name) <|> (char '\'' >> attrValueSQuoted tag attrs name) <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs))) @@ -200,15 +219,15 @@ -- | /§8.2.4.38/: Attribute value (unquoted) state attrValueUnquoted :: TagName -> [Attr] -> AttrName -> Parser Token attrValueUnquoted tag attrs name = do - value <- takeTill (inClass "\x09\x0a\x0c >") - id $ (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag attrs) -- unsure: don't emit? + value <- takeTill $ isWhitespace `orC` isC '>' + id $ (satisfy isWhitespace >> beforeAttrName tag attrs) -- unsure: don't emit? <|> (char '>' >> return (TagOpen tag (Attr name value : attrs))) <|> (endOfInput >> return endOfFileToken) -- | /§8.2.4.39/: After attribute value (quoted) state afterAttrValueQuoted :: TagName -> [Attr] -> AttrName -> AttrValue -> Parser Token afterAttrValueQuoted tag attrs name value = - (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag attrs') + (satisfy isWhitespace >> beforeAttrName tag attrs') <|> (char '/' >> selfClosingStartTag tag attrs') <|> (char '>' >> return (TagOpen tag attrs')) <|> (endOfInput >> return endOfFileToken) @@ -229,7 +248,7 @@ <|> try docType <|> bogusComment mempty where - comment_ = string "--" >> commentStart + comment_ = char '-' >> char '-' >> commentStart docType = do -- switching this to asciiCI slowed things down by a factor of two s <- take 7 @@ -254,7 +273,7 @@ -- | /§8.2.4.45/: Comment state comment :: Builder -> Parser Token comment content0 = do - content <- B.fromText <$> takeWhile (notInClass "-\x00<") + content <- B.fromText <$> takeWhile (not . (isC '-' `orC` isC '\x00' `orC` isC '<')) id $ (char '<' >> commentLessThan (content0 <> content <> "<")) <|> (char '-' >> commentEndDash (content0 <> content)) <|> (char '\x00' >> comment (content0 <> content <> B.singleton '\xfffd')) diff --git a/html-parse.cabal b/html-parse.cabal --- a/html-parse.cabal +++ b/html-parse.cabal @@ -1,20 +1,47 @@ name: html-parse -version: 0.2.0.1 +version: 0.2.0.2 synopsis: A high-performance HTML tokenizer description: This package provides a fast and reasonably robust HTML5 tokenizer built upon the @attoparsec@ library. The parsing strategy is based upon the HTML5 parsing specification with few deviations. . - The package targets similar use-cases to the venerable @tagsoup@ library, - but is significantly more efficient, achieving parsing speeds of over 50 - megabytes per second on modern hardware with and typical web documents. - . For instance, . >>> parseTokens "

Hello World


" - [TagOpen "div" [],TagOpen "h1" [Attr "class" "widget"], - ContentText "Hello World",TagClose "h1",TagSelfClose "br" []] + [TagOpen "div" [], + TagOpen "h1" [Attr "class" "widget"], + ContentText "Hello World", + TagClose "h1", + TagSelfClose "br" []] + . + The package targets similar use-cases to the venerable @tagsoup@ library, + but is significantly more efficient, achieving parsing speeds of over 80 + megabytes per second on modern hardware and typical web documents. + Here are some typical performance numbers taken from parsing a Wikipedia + article of moderate length: + . + @ + benchmarking Forced/tagsoup fast Text + time 186.1 ms (175.3 ms .. 194.6 ms) + 0.999 R² (0.995 R² .. 1.000 R²) + mean 191.7 ms (188.9 ms .. 198.3 ms) + std dev 5.053 ms (1.092 ms .. 6.809 ms) + variance introduced by outliers: 14% (moderately inflated) + . + benchmarking Forced/tagsoup normal Text + time 189.7 ms (182.8 ms .. 197.7 ms) + 0.999 R² (0.998 R² .. 1.000 R²) + mean 196.5 ms (193.1 ms .. 202.1 ms) + std dev 5.481 ms (2.141 ms .. 7.383 ms) + variance introduced by outliers: 14% (moderately inflated) + . + benchmarking Forced/html-parser + time 15.81 ms (15.75 ms .. 15.89 ms) + 1.000 R² (1.000 R² .. 1.000 R²) + mean 15.72 ms (15.66 ms .. 15.77 ms) + std dev 140.9 μs (113.6 μs .. 174.5 μs) + @ homepage: http://github.com/bgamari/html-parse license: BSD3 @@ -36,11 +63,11 @@ exposed-modules: Text.HTML.Parser, Text.HTML.Tree ghc-options: -Wall other-extensions: OverloadedStrings, DeriveGeneric - build-depends: base >=4.7 && <4.11, - deepseq >=1.4 && <1.5, + build-depends: base >=4.7 && <4.13, + deepseq >=1.3 && <1.5, attoparsec >=0.13 && <0.14, text >=1.2 && <1.3, - containers >=0.5 && <0.6 + containers >=0.5 && <0.7 default-language: Haskell2010 benchmark bench diff --git a/tests/Text/HTML/ParserSpec.hs b/tests/Text/HTML/ParserSpec.hs --- a/tests/Text/HTML/ParserSpec.hs +++ b/tests/Text/HTML/ParserSpec.hs @@ -100,3 +100,11 @@ describe "parseTokens" $ do it "works on `

Heading

`" $ do parseTokens "

Heading

" `shouldBe` [TagOpen "h1" [], ContentText "Heading", TagClose "h1"] + it "terminates on truncated tags" $ do + parseTokens "19 -167.44 " `shouldBe` [Comment " 3. Change Banner "] + it "parses commented tag correctly" $ do + parseTokens "