git.iko.soy/typeable/html-parse
on master help sign in
Merge branch 'tests-and-things' of git://github.com/zerobuzz/html-parse
commit2ab6186273d4758ef3f3474ed87eae44db66ff58 authorBen Gamari <ben@smart-cactus.org> dateWed 28 Dec 2016, 09:58 (10 years ago) parent7152b627357802
5 files changed+137
compare with master
unifiedsplit
.travis.yml+1 Text/HTML/Parser.hs+46 html-parse.cabal+15 tests/Spec.hs+1 tests/Text/HTML/ParserSpec.hs+74
.travis.yml+1
@@ -43,6 +43,7 @@ before_install:
4343 - PKGNAME='html-parse'
4444
4545install:
46+ - cabal update && cabal install hspec-discover
4647 - cabal --version
4748 - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
4849 - BENCH=${BENCH---enable-benchmarks}
Text/HTML/Parser.hs+46
@@ -1,5 +1,6 @@
11{-# LANGUAGE OverloadedStrings #-}
22{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE LambdaCase #-}
34
45-- | This is a performance-oriented HTML tokenizer aim at web-crawling
56-- applications. It follows the HTML5 parsing specification quite closely,
@@ -14,6 +15,12 @@ module Text.HTML.Parser
1415 , Token(..)
1516 , TagName, AttrName, AttrValue
1617 , Attr(..)
18+ -- * Rendering, text canonicalization
19+ , renderTokens
20+ , renderToken
21+ , renderAttrs
22+ , renderAttr
23+ , canonicalizeTokens
1724 ) where
1825
1926import Data.Char hiding (isSpace)
@@ -277,3 +284,42 @@ parseTokensLazy = unfoldr f
277284 case AL.parse token t of
278285 AL.Done rest tok -> Just (tok, rest)
279286 _ -> Nothing
287+
288+-- | See 'renderToken'.
289+renderTokens :: [Token] -> TL.Text
290+renderTokens = mconcat . fmap renderToken
291+
292+-- | (Somewhat) canonical string representation of 'Token'.
293+renderToken :: Token -> TL.Text
294+renderToken = TL.fromStrict . mconcat . \case
295+ (TagOpen n []) -> ["<", n, ">"]
296+ (TagOpen n attrs) -> ["<", n, " ", renderAttrs attrs, ">"]
297+ (TagClose n) -> ["</", n, ">"]
298+ (ContentChar c) -> [T.singleton c]
299+ (ContentText t) -> [t]
300+ (Comment builder) -> ["<!--", TL.toStrict $ B.toLazyText builder, "-->"]
301+ (Doctype t) -> ["<!DOCTYPE", t, ">"]
302+
303+-- | See 'renderAttr'.
304+renderAttrs :: [Attr] -> Text
305+renderAttrs = T.unwords . fmap renderAttr . reverse
306+
307+-- | Does not escape quotation in attribute values!
308+renderAttr :: Attr -> Text
309+renderAttr (Attr k v) = mconcat [k, "=\"", v, "\""]
310+
311+-- | Meld neighoring 'ContentChar' and 'ContentText' constructors together and drops empty text
312+-- elements.
313+canonicalizeTokens :: [Token] -> [Token]
314+canonicalizeTokens = filter (/= ContentText "") . meldTextTokens
315+
316+meldTextTokens :: [Token] -> [Token]
317+meldTextTokens = concatTexts . fmap charToText
318+ where
319+ charToText (ContentChar c) = ContentText (T.singleton c)
320+ charToText t = t
321+
322+ concatTexts = \case
323+ (ContentText t : ContentText t' : ts) -> concatTexts $ ContentText (t <> t') : ts
324+ (t : ts) -> t : concatTexts ts
325+ [] -> []
html-parse.cabal+15
@@ -45,3 +45,18 @@ benchmark bench
4545 tagsoup >= 0.13,
4646 criterion >= 1.1
4747 default-language: Haskell2010
48+
49+test-suite spec
50+ type: exitcode-stdio-1.0
51+ main-is: Spec.hs
52+ hs-source-dirs: tests
53+ ghc-options: -Wall -with-rtsopts=-T
54+ build-depends: base,
55+ hspec,
56+ hspec-discover,
57+ html-parse,
58+ QuickCheck,
59+ quickcheck-instances,
60+ string-conversions,
61+ text
62+ default-language: Haskell2010
tests/Spec.hsnew file+1
@@ -0,0 +1 @@
1+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
tests/Text/HTML/ParserSpec.hsnew file+74
@@ -0,0 +1,74 @@
1+{-# LANGUAGE GADTs #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE ViewPatterns #-}
6+
7+{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}
8+
9+module Text.HTML.ParserSpec
10+where
11+
12+import qualified Data.Text as T
13+import qualified Data.Text.Lazy as TL
14+import qualified Data.Text.Lazy.Builder as B
15+import Test.Hspec
16+import Test.QuickCheck
17+import Test.QuickCheck.Instances ()
18+import Text.HTML.Parser
19+
20+
21+instance Arbitrary Token where
22+ arbitrary = oneof [validOpen, validClose, validFlat]
23+
24+ shrink (TagOpen n as) = TagOpen n <$> shrink as
25+ shrink (TagClose _) = []
26+ shrink (ContentText _) = []
27+ shrink (ContentChar _) = []
28+ shrink (Comment b) = Comment . B.fromText <$> (shrink . TL.toStrict . B.toLazyText $ b)
29+ shrink (Doctype t) = Doctype <$> shrink t
30+
31+instance Arbitrary Attr where
32+ arbitrary = Attr <$> validXmlTag <*> validXmlText
33+ shrink (Attr k v) = Attr <$> shrink k <*> shrink v
34+
35+validOpen :: Gen Token
36+validOpen = TagOpen <$> validXmlTag <*> arbitrary
37+
38+validClose :: Gen Token
39+validClose = TagClose <$> validXmlTag
40+
41+validFlat :: Gen Token
42+validFlat = oneof
43+ [ ContentChar <$> validXmlChar
44+ , ContentText <$> validXmlText
45+ , Comment . B.fromText <$> validXmlText
46+ , Doctype <$> validXmlText
47+ ]
48+
49+validXmlChar :: Gen Char
50+validXmlChar = elements (' ' : ['a'..'z']) -- FIXME: generate wider range of values
51+
52+validXmlTag :: Gen T.Text
53+validXmlTag = T.pack <$> sized (`maxListOf1` elements ['a'..'z']) -- FIXME: generate wider range of values
54+
55+validXmlText :: Gen T.Text
56+validXmlText = mconcat <$> sized (`maxListOf` (T.cons <$> validXmlChar <*> validXmlTag)) -- FIXME: generate wider range of values
57+
58+maxListOf :: Int -> Gen a -> Gen [a]
59+maxListOf n g = take n <$> listOf g
60+
61+maxListOf1 :: Int -> Gen a -> Gen [a]
62+maxListOf1 (min 1 -> n) g = take n <$> listOf1 g
63+
64+
65+
66+spec :: Spec
67+spec = do
68+ it "parseTokens and renderTokens are inverse" . property . forAllShrink arbitrary shrink $
69+ \(canonicalizeTokens -> tokens)
70+ -> (parseTokens . TL.toStrict . renderTokens $ tokens) `shouldBe` tokens
71+
72+ it "canonicalizeTokens is idempotent" . property . forAllShrink arbitrary shrink $
73+ \tokens
74+ -> canonicalizeTokens tokens `shouldBe` canonicalizeTokens (canonicalizeTokens tokens)