63aa05c · typeable/html-parse

git.iko.soy/typeable/html-parse

Token rendering, text canonicalization, minimal test suite.

commit63aa05c9ee895098ec1b068caf15fd6588d8a1d5 authorMatthias Fischmann <mf@zerobuzz.net> dateWed 28 Dec 2016, 00:05 (10 years ago) parentd1d336a

4 files changed+136−1

compare with master

unifiedsplit

Text/HTML/Parser.hs+46 html-parse.cabal+15−1 tests/Spec.hs+1 tests/Text/HTML/ParserSpec.hs+74

Text/HTML/Parser.hs+46

@@ -1,5 +1,6 @@

11{-# LANGUAGE OverloadedStrings #-}

22{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE LambdaCase #-}

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) -> [""]

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

4242 text,

4343 tagsoup >= 0.13,

4444 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 #-}

7+{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}

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)