html-parse 0.2.0.0 → 0.2.0.1
raw patch · 6 files changed
+419/−63 lines, 6 filesdep +QuickCheckdep +containersdep +hspecdep ~basedep ~text
Dependencies added: QuickCheck, containers, hspec, hspec-discover, html-parse, quickcheck-instances, string-conversions
Dependency ranges changed: base, text
Files
- Text/HTML/Parser.hs +167/−59
- Text/HTML/Tree.hs +71/−0
- html-parse.cabal +32/−4
- tests/Spec.hs +1/−0
- tests/Text/HTML/ParserSpec.hs +102/−0
- tests/Text/HTML/TreeSpec.hs +46/−0
Text/HTML/Parser.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-} -- | This is a performance-oriented HTML tokenizer aim at web-crawling -- applications. It follows the HTML5 parsing specification quite closely,@@ -14,6 +15,12 @@ , Token(..) , TagName, AttrName, AttrValue , Attr(..)+ -- * Rendering, text canonicalization+ , renderTokens+ , renderToken+ , renderAttrs+ , renderAttr+ , canonicalizeTokens ) where import Data.Char hiding (isSpace)@@ -33,6 +40,8 @@ import qualified Data.Text.Lazy.Builder as B import Prelude hiding (take, takeWhile) +-- Section numbers refer to W3C HTML 5.2 specification.+ -- | A tag name (e.g. @body@) type TagName = Text @@ -46,6 +55,8 @@ data Token -- | An opening tag. Attribute ordering is arbitrary. = TagOpen !TagName [Attr]+ -- | A self-closing tag.+ | TagSelfClose !TagName [Attr] -- | A closing tag. | TagClose !TagName -- | The content between tags.@@ -58,6 +69,10 @@ | Doctype !Text deriving (Show, Ord, Eq, Generic) +-- | This is a bit of a hack+endOfFileToken :: Token+endOfFileToken = ContentText ""+ -- | An attribute of a tag data Attr = Attr !AttrName !AttrValue deriving (Show, Eq, Ord)@@ -78,48 +93,55 @@ then return $ ContentText content else char '<' >> tagOpen --- | /§8.2.4.3/: Tag open state+-- | /§8.2.4.6/: Tag open state tagOpen :: Parser Token tagOpen = (char '!' >> markupDeclOpen) <|> (char '/' >> endTagOpen)- <|> (char '?' >> bogusComment)- <|> tryStartTag+ <|> (char '?' >> bogusComment mempty)+ <|> tagNameOpen <|> other where- tryStartTag = do- c <- peekChar'- guard $ isAsciiUpper c || isAsciiLower c- tagName- other = do return $ ContentChar '<' --- | /§8.2.4.9/: End tag open state--- TODO: This isn't right+-- | /§8.2.4.7/: End tag open state endTagOpen :: Parser Token-endTagOpen = do- name <- takeWhile $ \c -> isAsciiUpper c || isAsciiLower c- char '>'- return $ TagClose name+endTagOpen = tagNameClose --- | /§8.2.4.10/: Tag name state+-- | /§8.2.4.8/: Tag name state: the open case ----- deviation: no lower-casing-tagName :: Parser Token-tagName = do- tag <- takeWhile $ notInClass "\x09\x0a\x0c />"+-- deviation: no lower-casing, don't handle NULL characters+tagNameOpen :: Parser Token+tagNameOpen = do+ tag <- tagName' id $ (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag []) <|> (char '/' >> selfClosingStartTag tag []) <|> (char '>' >> return (TagOpen tag [])) --- | /§8.2.4.43/: Self-closing start tag state+-- | /§8.2.4.10/: Tag name state: close case+tagNameClose :: Parser Token+tagNameClose = do+ tag <- tagName'+ char '>' >> return (TagClose tag)++-- | /§8.2.4.10/: Tag name state: common code+--+-- deviation: no lower-casing, don't handle NULL characters+tagName' :: Parser Text+tagName' = do+ c <- peekChar'+ guard $ isAsciiUpper c || isAsciiLower c+ takeWhile $ notInClass "\x09\x0a\x0c /<>"++-- | /§8.2.4.40/: Self-closing start tag state selfClosingStartTag :: TagName -> [Attr] -> Parser Token selfClosingStartTag tag attrs = do- (char '>' >> return (TagOpen tag attrs))+ (char '>' >> return (TagSelfClose tag attrs))+ <|> (endOfInput >> return endOfFileToken) <|> beforeAttrName tag attrs --- | /§8.2.4.34/: Before attribute name state+-- | /§8.2.4.32/: Before attribute name state -- -- deviation: no lower-casing beforeAttrName :: TagName -> [Attr] -> Parser Token@@ -130,26 +152,29 @@ -- <|> (char '\x00' >> attrName tag attrs) -- TODO: NULL <|> attrName tag attrs --- | /§8.2.4.35/: Attribute name state+-- | /§8.2.4.33/: Attribute name state attrName :: TagName -> [Attr] -> Parser Token attrName tag attrs = do- name <- takeWhile $ notInClass "\x09\x0a\x0c /=>\x00"- id $ (satisfy (inClass "\x09\x0a\x0c ") >> afterAttrName tag attrs name)- <|> (char '/' >> selfClosingStartTag tag attrs)+ name <- takeWhile $ notInClass "\x09\x0a\x0c /=>"+ id $ (endOfInput >> afterAttrName tag attrs name) <|> (char '=' >> beforeAttrValue tag attrs name)- <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))+ <|> try (do mc <- peekChar+ case mc of+ Just c | inClass "\x09\x0a\x0c />" c -> afterAttrName tag attrs name+ _ -> empty) -- <|> -- TODO: NULL --- | /§8.2.4.36/: After attribute name state+-- | /§8.2.4.34/: After attribute name state afterAttrName :: TagName -> [Attr] -> AttrName -> Parser Token afterAttrName tag attrs name = do skipWhile $ inClass "\x09\x0a\x0c " id $ (char '/' >> selfClosingStartTag tag attrs) <|> (char '=' >> beforeAttrValue tag attrs name) <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))+ <|> (endOfInput >> return endOfFileToken) <|> attrName tag (Attr name T.empty : attrs) -- not exactly sure this is right --- | /§8.2.4.37/: Before attribute value state+-- | /§8.2.4.35/: Before attribute value state beforeAttrValue :: TagName -> [Attr] -> AttrName -> Parser Token beforeAttrValue tag attrs name = do skipWhile $ inClass "\x09\x0a\x0c "@@ -158,98 +183,141 @@ <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs))) <|> attrValueUnquoted tag attrs name --- | /§8.2.4.38/: Attribute value (double-quoted) state+-- | /§8.2.4.36/: Attribute value (double-quoted) state attrValueDQuoted :: TagName -> [Attr] -> AttrName -> Parser Token attrValueDQuoted tag attrs name = do value <- takeWhile (/= '"')- char '"'+ _ <- char '"' afterAttrValueQuoted tag attrs name value --- | /§8.2.4.39/: Attribute value (single-quoted) state+-- | /§8.2.4.37/: Attribute value (single-quoted) state attrValueSQuoted :: TagName -> [Attr] -> AttrName -> Parser Token attrValueSQuoted tag attrs name = do value <- takeWhile (/= '\'')- char '\''+ _ <- char '\'' afterAttrValueQuoted tag attrs name value --- | /§8.2.4.40/: Attribute value (unquoted) state+-- | /§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? <|> (char '>' >> return (TagOpen tag (Attr name value : attrs)))+ <|> (endOfInput >> return endOfFileToken) --- | /§8.2.4.42/: After attribute value (quoted) state+-- | /§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') <|> (char '/' >> selfClosingStartTag tag attrs') <|> (char '>' >> return (TagOpen tag attrs'))+ <|> (endOfInput >> return endOfFileToken) where attrs' = Attr name value : attrs --- | /§8.2.4.45/: Markup declaration open state+-- | /§8.2.4.41/: Bogus comment state+bogusComment :: Builder -> Parser Token+bogusComment content = do+ (char '>' >> return (Comment content))+ <|> (endOfInput >> return (Comment content))+ <|> (char '\x00' >> bogusComment (content <> "\xfffd"))+ <|> (anyChar >>= \c -> bogusComment (content <> B.singleton c))++-- | /§8.2.4.42/: Markup declaration open state markupDeclOpen :: Parser Token markupDeclOpen =- try comment+ try comment_ <|> try docType- -- TODO: Fix the rest+ <|> bogusComment mempty where- comment = string "--" >> commentStart+ comment_ = string "--" >> commentStart docType = do -- switching this to asciiCI slowed things down by a factor of two s <- take 7 guard $ T.toLower s == "doctype" doctype --- | /§8.2.4.46/: Comment start state+-- | /§8.2.4.43/: Comment start state commentStart :: Parser Token commentStart = do (char '-' >> commentStartDash) <|> (char '>' >> return (Comment mempty)) <|> comment mempty --- | /§8.2.4.47/: Comment start dash state+-- | /§8.2.4.44/: Comment start dash state commentStartDash :: Parser Token commentStartDash = (char '-' >> commentEnd mempty) <|> (char '>' >> return (Comment mempty))- <|> (do c <- anyChar- comment (B.singleton '-' <> B.singleton c) )+ <|> (endOfInput >> return (Comment mempty))+ <|> (comment (B.singleton '-')) --- | /§8.2.4.48/: Comment state+-- | /§8.2.4.45/: Comment state comment :: Builder -> Parser Token comment content0 = do- content <- B.fromText <$> takeWhile (notInClass "-")- id $ (char '-' >> commentEndDash (content0 <> content))+ content <- B.fromText <$> takeWhile (notInClass "-\x00<")+ id $ (char '<' >> commentLessThan (content0 <> content <> "<"))+ <|> (char '-' >> commentEndDash (content0 <> content)) <|> (char '\x00' >> comment (content0 <> content <> B.singleton '\xfffd'))+ <|> (endOfInput >> return (Comment $ content0 <> content)) --- | /§8.2.4.49/: Comment end dash state+-- | /§8.2.46/: Comment less-than sign state+commentLessThan :: Builder -> Parser Token+commentLessThan content =+ (char '!' >> commentLessThanBang (content <> "!"))+ <|> (char '<' >> commentLessThan (content <> "<"))+ <|> comment content++-- | /§8.2.47/: Comment less-than sign bang state+commentLessThanBang :: Builder -> Parser Token+commentLessThanBang content =+ (char '-' >> commentLessThanBangDash content)+ <|> comment content++-- | /§8.2.48/: Comment less-than sign bang dash state+commentLessThanBangDash :: Builder -> Parser Token+commentLessThanBangDash content =+ (char '-' >> commentLessThanBangDashDash content)+ <|> commentEndDash content++-- | /§8.2.49/: Comment less-than sign bang dash dash state+commentLessThanBangDashDash :: Builder -> Parser Token+commentLessThanBangDashDash content =+ (char '>' >> comment content)+ <|> (endOfInput >> comment content)+ <|> commentEnd content++-- | /§8.2.4.50/: Comment end dash state commentEndDash :: Builder -> Parser Token commentEndDash content = do (char '-' >> commentEnd content)- <|> (char '\x00' >> comment (content <> "-\xfffd"))- <|> (anyChar >>= \c -> comment (content <> "-" <> B.singleton c))+ <|> (endOfInput >> return (Comment content))+ <|> (comment (content <> "-")) --- | /§8.2.4.50/: Comment end state+-- | /§8.2.4.51/: Comment end state commentEnd :: Builder -> Parser Token commentEnd content = do (char '>' >> return (Comment content))- <|> (char '\x00' >> comment (content <> "-\xfffd"))- -- <|> () TODO: other cases- <|> (anyChar >>= \c -> comment (content <> "-" <> B.singleton c))+ <|> (char '!' >> commentEndBang content)+ <|> (char '-' >> commentEnd (content <> "-"))+ <|> (endOfInput >> return (Comment content))+ <|> (comment (content <> "--")) --- | /§8.2.4.52/: DOCTYPE state+-- | /§8.2.4.52/: Comment end bang state+commentEndBang :: Builder -> Parser Token+commentEndBang content = do+ (char '-' >> commentEndDash (content <> "--!"))+ <|> (char '>' >> return (Comment content))+ <|> (endOfInput >> return (Comment content))+ <|> (comment (content <> "--!"))++-- | /§8.2.4.53/: DOCTYPE state -- FIXME doctype :: Parser Token doctype = do content <- takeTill (=='>')- char '>'+ _ <- char '>' return $ Doctype content --- | /§8.2.4.44/: Bogus comment state-bogusComment :: Parser Token-bogusComment = fail "Bogus comment"- -- | Parse a lazy list of tokens from strict 'Text'. parseTokens :: Text -> [Token] parseTokens = unfoldr f@@ -277,3 +345,43 @@ case AL.parse token t of AL.Done rest tok -> Just (tok, rest) _ -> Nothing++-- | See 'renderToken'.+renderTokens :: [Token] -> TL.Text+renderTokens = mconcat . fmap renderToken++-- | (Somewhat) canonical string representation of 'Token'.+renderToken :: Token -> TL.Text+renderToken = TL.fromStrict . mconcat . \case+ (TagOpen n []) -> ["<", n, ">"]+ (TagOpen n attrs) -> ["<", n, " ", renderAttrs attrs, ">"]+ (TagSelfClose n attrs) -> ["<", n, " ", renderAttrs attrs, " />"]+ (TagClose n) -> ["</", n, ">"]+ (ContentChar c) -> [T.singleton c]+ (ContentText t) -> [t]+ (Comment builder) -> ["<!--", TL.toStrict $ B.toLazyText builder, "-->"]+ (Doctype t) -> ["<!DOCTYPE", t, ">"]++-- | See 'renderAttr'.+renderAttrs :: [Attr] -> Text+renderAttrs = T.unwords . fmap renderAttr . reverse++-- | Does not escape quotation in attribute values!+renderAttr :: Attr -> Text+renderAttr (Attr k v) = mconcat [k, "=\"", v, "\""]++-- | Meld neighoring 'ContentChar' and 'ContentText' constructors together and drops empty text+-- elements.+canonicalizeTokens :: [Token] -> [Token]+canonicalizeTokens = filter (/= ContentText "") . meldTextTokens++meldTextTokens :: [Token] -> [Token]+meldTextTokens = concatTexts . fmap charToText+ where+ charToText (ContentChar c) = ContentText (T.singleton c)+ charToText t = t++ concatTexts = \case+ (ContentText t : ContentText t' : ts) -> concatTexts $ ContentText (t <> t') : ts+ (t : ts) -> t : concatTexts ts+ [] -> []
+ Text/HTML/Tree.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}++module Text.HTML.Tree+ ( -- * Constructing forests+ tokensToForest+ , ParseTokenForestError(..), PStack(..)+ , nonClosing+ -- * Deconstructing forests+ , tokensFromForest+ , tokensFromTree+ ) where++import Data.Monoid+import Data.Text (Text)+import Data.Tree+import Text.HTML.Parser+++tokensToForest :: [Token] -> Either ParseTokenForestError (Forest Token)+tokensToForest = f (PStack [] [])+ where+ f (PStack ss []) [] = Right (reverse ss)+ f pstack [] = Left $ ParseTokenForestErrorBracketMismatch pstack Nothing+ f pstack (t : ts) = case t of+ TagOpen n _ -> if n `elem` nonClosing+ then f (pushFlatSibling t pstack) ts+ else f (pushParent t pstack) ts+ TagSelfClose {} -> f (pushFlatSibling t pstack) ts+ TagClose n -> (`f` ts) =<< popParent n pstack+ ContentChar _ -> f (pushFlatSibling t pstack) ts+ ContentText _ -> f (pushFlatSibling t pstack) ts+ Comment _ -> f (pushFlatSibling t pstack) ts+ Doctype _ -> f (pushFlatSibling t pstack) ts++nonClosing :: [Text]+nonClosing = ["br", "hr", "img"]++data ParseTokenForestError =+ ParseTokenForestErrorBracketMismatch PStack (Maybe Token)+ deriving (Eq, Show)++data PStack = PStack+ { _pstackToplevelSiblings :: Forest Token+ , _pstackParents :: [(Token, Forest Token)]+ }+ deriving (Eq, Show)++pushParent :: Token -> PStack -> PStack+pushParent t (PStack ss ps) = PStack [] ((t, ss) : ps)++popParent :: TagName -> PStack -> Either ParseTokenForestError PStack+popParent n (PStack ss ((p@(TagOpen n' _), ss') : ps))+ | n == n' = Right $ PStack (Node p (reverse ss) : ss') ps+popParent n pstack+ = Left $ ParseTokenForestErrorBracketMismatch pstack (Just $ TagClose n)++pushFlatSibling :: Token -> PStack -> PStack+pushFlatSibling t (PStack ss ps) = PStack (Node t [] : ss) ps+++tokensFromForest :: Forest Token -> [Token]+tokensFromForest = mconcat . fmap tokensFromTree++tokensFromTree :: Tree Token -> [Token]+tokensFromTree (Node o@(TagOpen n _) ts) | n `notElem` nonClosing+ = [o] <> tokensFromForest ts <> [TagClose n]+tokensFromTree (Node t [])+ = [t]+tokensFromTree _+ = error "renderTokenTree: leaf node with children."
html-parse.cabal view
@@ -1,5 +1,5 @@ name: html-parse-version: 0.2.0.0+version: 0.2.0.1 synopsis: A high-performance HTML tokenizer description: This package provides a fast and reasonably robust HTML5 tokenizer built@@ -9,6 +9,13 @@ 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 "<div><h1 class=widget>Hello World</h1><br/>"+ [TagOpen "div" [],TagOpen "h1" [Attr "class" "widget"],+ ContentText "Hello World",TagClose "h1",TagSelfClose "br" []]+ homepage: http://github.com/bgamari/html-parse license: BSD3 license-file: LICENSE@@ -18,18 +25,22 @@ category: Text build-type: Simple cabal-version: >=1.10+tested-with: GHC==8.0.2, GHC==7.10.3, GHC==7.8.4 + source-repository head type: git location: git://github.com/bgamari/html-parse library- exposed-modules: Text.HTML.Parser+ exposed-modules: Text.HTML.Parser, Text.HTML.Tree+ ghc-options: -Wall other-extensions: OverloadedStrings, DeriveGeneric- build-depends: base >=4.8 && <4.10,+ build-depends: base >=4.7 && <4.11, deepseq >=1.4 && <1.5, attoparsec >=0.13 && <0.14,- text >=1.2 && <1.3+ text >=1.2 && <1.3,+ containers >=0.5 && <0.6 default-language: Haskell2010 benchmark bench@@ -42,4 +53,21 @@ text, tagsoup >= 0.13, criterion >= 1.1+ default-language: Haskell2010++test-suite spec+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ main-is: Spec.hs+ other-modules: Text.HTML.ParserSpec, Text.HTML.TreeSpec+ ghc-options: -Wall -with-rtsopts=-T+ build-depends: base,+ containers,+ hspec,+ hspec-discover,+ html-parse,+ QuickCheck,+ quickcheck-instances,+ string-conversions,+ text default-language: Haskell2010
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ tests/Text/HTML/ParserSpec.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans -fno-warn-unused-imports #-}++module Text.HTML.ParserSpec+where++import Control.Applicative+import Data.Monoid+import Data.List ((\\))+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as B+import Test.Hspec+import Test.QuickCheck+import Test.QuickCheck.Instances ()+import Text.HTML.Parser+++instance Arbitrary Token where+ arbitrary = oneof [validOpen, validClose, validFlat]++ shrink (TagOpen n as) = TagOpen n <$> shrink as+ shrink (TagSelfClose n as) = TagSelfClose n <$> shrink as+ shrink (TagClose _) = []+ shrink (ContentText _) = []+ shrink (ContentChar _) = []+ shrink (Comment b) = Comment . B.fromText <$> (shrink . TL.toStrict . B.toLazyText $ b)+ shrink (Doctype t) = Doctype <$> shrink t++instance Arbitrary Attr where+ arbitrary = Attr <$> validXmlAttrName <*> validXmlAttrValue+ shrink (Attr k v) = Attr <$> shrink k <*> shrink v++validOpen :: Gen Token+validOpen = TagOpen <$> validXmlTagName <*> arbitrary++validClose :: Gen Token+validClose = TagClose <$> validXmlTagName++validFlat :: Gen Token+validFlat = oneof+ [ TagSelfClose <$> validXmlTagName <*> arbitrary+ , ContentChar <$> validXmlChar+ , ContentText <$> validXmlText+ , Comment . B.fromText <$> validXmlCommentText+ , Doctype <$> validXmlText+ ]++-- FIXME: sometimes it is allowed to use '<' as text token, and we don't test that yet. (whether we+-- like this choice or not, we may want to follow the standard here.) (same in tag names, attr+-- names.)+validXmlChar :: Gen Char+validXmlChar = elements (['\x20'..'\x7E'] \\ "\x09\x0a\x0c /<>")++validXmlText :: Gen T.Text+validXmlText = T.pack <$> sized (`maxListOf` validXmlChar)++validXmlTagName :: Gen T.Text+validXmlTagName = do+ initchar <- elements $ ['a'..'z'] <> ['A'..'Z']+ thenchars <- sized (`maxListOf` elements (['\x20'..'\x7E'] \\ "\x09\x0a\x0c /<>"))+ pure . T.pack $ initchar : thenchars++validXmlAttrName :: Gen T.Text+validXmlAttrName = do+ initchar <- elements $ ['a'..'z'] <> ['A'..'Z']+ thenchars <- sized (`maxListOf` elements (['\x20'..'\x7E'] \\ "\x09\x0a\x0c /=<>\x00"))+ pure . T.pack $ initchar : thenchars++-- FIXME: not sure if @Attr "key" "\""@ should be parseable, but it's not, so we don't test it.+validXmlAttrValue :: Gen T.Text+validXmlAttrValue = do+ T.pack <$> sized (`maxListOf` elements (['\x20'..'\x7E'] \\ "\x09\x0a\x0c /=<>\x00\""))++-- FIXME: i think this should be 'validXmlChar', but that will fail the test suite.+validXmlCommentText :: Gen T.Text+validXmlCommentText = do+ T.pack <$> sized (`maxListOf` elements (['\x20'..'\x7E'] \\ "\x09\x0a\x0c /=<>\x00\"-"))++maxListOf :: Int -> Gen a -> Gen [a]+maxListOf n g = take n <$> listOf g+++spec :: Spec+spec = do+ it "parseTokens and renderTokens are inverse" . property . forAllShrink arbitrary shrink $+ \(canonicalizeTokens -> tokens)+ -> (parseTokens . TL.toStrict . renderTokens $ tokens) `shouldBe` tokens++ it "canonicalizeTokens is idempotent" . property . forAllShrink arbitrary shrink $+ \tokens+ -> canonicalizeTokens tokens `shouldBe` canonicalizeTokens (canonicalizeTokens tokens)++ describe "regression tests" $ do+ describe "parseTokens" $ do+ it "works on `<h1>Heading</h1>`" $ do+ parseTokens "<h1>Heading</h1>" `shouldBe` [TagOpen "h1" [], ContentText "Heading", TagClose "h1"]
+ tests/Text/HTML/TreeSpec.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}++module Text.HTML.TreeSpec+where++import Control.Applicative+import Data.Tree+import Test.Hspec+import Test.QuickCheck+import Test.QuickCheck.Instances ()+import Text.HTML.Parser+import Text.HTML.ParserSpec+import Text.HTML.Tree+import Prelude+++arbitraryTokenForest :: Gen (Forest Token)+arbitraryTokenForest = listOf arbitraryTokenTree++arbitraryTokenTree :: Gen (Tree Token)+arbitraryTokenTree = oneof+ [ Node <$> validClosingOpen <*> scale (`div` 5) arbitraryTokenForest+ , Node <$> validNonClosingOpen <*> pure []+ , Node <$> validFlat <*> pure []+ ]+++validNonClosingOpen :: Gen Token+validNonClosingOpen = TagOpen <$> elements nonClosing <*> arbitrary++validClosingOpen :: Gen Token+validClosingOpen = do+ n <- validXmlTagName+ let n' = if n `elem` nonClosing then "_" else n+ TagOpen n' <$> arbitrary+++spec :: Spec+spec = do+ it "parseTokenForests and renderTokenForest are inverses"+ . property . forAllShrink arbitraryTokenForest shrink $+ \forest -> tokensToForest (tokensFromForest forest) `shouldBe` Right forest