git.iko.soy/typeable/html-parse
on master help sign in
Token rendering, text canonicalization, minimal test suite.
63aa05cMatthias Fischmann
Text/HTML/Parser.hs+46
compare with master
unifiedsplit
@@ -1,5 +1,6 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE DeriveGeneric #-}
2{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE LambdaCase #-}
3
4
4-- | This is a performance-oriented HTML tokenizer aim at web-crawling
5-- | This is a performance-oriented HTML tokenizer aim at web-crawling
5-- applications. It follows the HTML5 parsing specification quite closely,
6-- applications. It follows the HTML5 parsing specification quite closely,
@@ -14,6 +15,12 @@ module Text.HTML.Parser
14 , Token(..)
15 , Token(..)
15 , TagName, AttrName, AttrValue
16 , TagName, AttrName, AttrValue
16 , Attr(..)
17 , Attr(..)
18+ -- * Rendering, text canonicalization
19+ , renderTokens
20+ , renderToken
21+ , renderAttrs
22+ , renderAttr
23+ , canonicalizeTokens
17 ) where
24 ) where
18
25
19import Data.Char hiding (isSpace)
26import Data.Char hiding (isSpace)
@@ -277,3 +284,42 @@ parseTokensLazy = unfoldr f
277 case AL.parse token t of
284 case AL.parse token t of
278 AL.Done rest tok -> Just (tok, rest)
285 AL.Done rest tok -> Just (tok, rest)
279 _ -> Nothing
286 _ -> 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−1
@@ -42,4 +42,18 @@ benchmark bench
42 text,
42 text,
43 tagsoup >= 0.13,
43 tagsoup >= 0.13,
44 criterion >= 1.1
44 criterion >= 1.1
45− default-language: Haskell2010
45+ default-language: Haskell2010
46+
47+test-suite spec
48+ type: exitcode-stdio-1.0
49+ main-is: Spec.hs
50+ hs-source-dirs: tests
51+ ghc-options: -Wall -with-rtsopts=-T
52+ build-depends: base,
53+ hspec,
54+ html-parse,
55+ QuickCheck,
56+ quickcheck-instances,
57+ string-conversions,
58+ text
59+ 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)