git.iko.soy/typeable/html-parse
on master help sign in
typeable/html-parse/tests/Text/HTML/ParserSpec.hs
112 lines 4.7 kB history raw
1{-# LANGUAGE GADTs #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE ViewPatterns #-}
7{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans -fno-warn-unused-imports #-}
9module Text.HTML.ParserSpec
10where
12import Control.Applicative
13import Data.Monoid
14import Data.List ((\\))
15import qualified Data.Text as T
16import qualified Data.Text.Lazy as TL
17import qualified Data.Text.Lazy.Builder as B
18import Test.Hspec
19import Test.QuickCheck
20import Test.QuickCheck.Instances ()
21import Text.HTML.Parser
24instance Arbitrary Token where
25 arbitrary = oneof [validOpen, validClose, validFlat]
27 shrink (TagOpen n as) = TagOpen n <$> shrink as
28 shrink (TagSelfClose n as) = TagSelfClose n <$> shrink as
29 shrink (TagClose _) = []
30 shrink (ContentText _) = []
31 shrink (ContentChar _) = []
32 shrink (Comment b) = Comment . B.fromText <$> (shrink . TL.toStrict . B.toLazyText $ b)
33 shrink (Doctype t) = Doctype <$> shrink t
35instance Arbitrary Attr where
36 arbitrary = Attr <$> validXmlAttrName <*> validXmlAttrValue
37 shrink (Attr k v) = Attr <$> shrink k <*> shrink v
39validOpen :: Gen Token
40validOpen = TagOpen <$> validXmlTagName <*> arbitrary
42validClose :: Gen Token
43validClose = TagClose <$> validXmlTagName
45validFlat :: Gen Token
46validFlat = oneof
47 [ TagSelfClose <$> validXmlTagName <*> arbitrary
48 , ContentChar <$> validXmlChar
49 , ContentText <$> validXmlText
50 , Comment . B.fromText <$> validXmlCommentText
51 , Doctype <$> validXmlText
52 ]
54-- FIXME: sometimes it is allowed to use '<' as text token, and we don't test that yet. (whether we
55-- like this choice or not, we may want to follow the standard here.) (same in tag names, attr
56-- names). We also avoid '&' since this may produce spurious character references.
57validXmlChar :: Gen Char
58validXmlChar = elements (['\x20'..'\x7E'] \\ "\x09\x0a\x0c &/<>")
60validXmlText :: Gen T.Text
61validXmlText = T.pack <$> sized (`maxListOf` validXmlChar)
63validXmlTagName :: Gen T.Text
64validXmlTagName = do
65 initchar <- elements $ ['a'..'z'] <> ['A'..'Z']
66 thenchars <- sized (`maxListOf` elements (['\x20'..'\x7E'] \\ "\x09\x0a\x0c &/<>"))
67 pure . T.pack $ initchar : thenchars
69validXmlAttrName :: Gen T.Text
70validXmlAttrName = do
71 initchar <- elements $ ['a'..'z'] <> ['A'..'Z']
72 thenchars <- sized (`maxListOf` elements (['\x20'..'\x7E'] \\ "\x09\x0a\x0c /=<>\x00"))
73 pure . T.pack $ initchar : thenchars
75-- FIXME: not sure if @Attr "key" "\""@ should be parseable, but it's not, so we don't test it.
76validXmlAttrValue :: Gen T.Text
77validXmlAttrValue = do
78 T.pack <$> sized (`maxListOf` elements (['\x20'..'\x7E'] \\ "\x09\x0a\x0c /=<>\x00\""))
80-- FIXME: i think this should be 'validXmlChar', but that will fail the test suite.
81validXmlCommentText :: Gen T.Text
82validXmlCommentText = do
83 T.pack <$> sized (`maxListOf` elements (['\x20'..'\x7E'] \\ "\x09\x0a\x0c /=<>\x00\"-"))
85maxListOf :: Int -> Gen a -> Gen [a]
86maxListOf n g = take n <$> listOf g
89spec :: Spec
90spec = do
91 it "parseTokens and renderTokens are inverse" . property . forAllShrink arbitrary shrink $
92 \(canonicalizeTokens -> tokens)
93 -> (canonicalizeTokens . parseTokens . TL.toStrict . renderTokens $ tokens) `shouldBe` tokens
95 it "canonicalizeTokens is idempotent" . property . forAllShrink arbitrary shrink $
96 \tokens
97 -> canonicalizeTokens tokens `shouldBe` canonicalizeTokens (canonicalizeTokens tokens)
99 describe "regression tests" $ do
100 describe "parseTokens" $ do
101 it "works on `<h1>Heading</h1>`" $ do
102 parseTokens "<h1>Heading</h1>" `shouldBe` [TagOpen "h1" [], ContentText "Heading", TagClose "h1"]
103 it "terminates on truncated tags" $ do
104 parseTokens "19 -167.44 <A HREF=\"http://walrus.wr.usgs" `shouldBe` [ContentText "19 -167.44 ", ContentText ""]
105 it "parses comment correctly" $ do
106 parseTokens "<!-- 3. Change Banner -->" `shouldBe` [Comment " 3. Change Banner "]
107 it "parses commented tag correctly" $ do
108 parseTokens "<!-- img src=\"/www_images/NCEP_GFS.gif\">" `shouldBe` [Comment " img src=\"/www_images/NCEP_GFS.gif\">"]
109 it "parses funky comment" $ do
110 parseTokens "<!-- img src=\"/www_images/NCEP_GFS.gif\"><!- -------------------------------------------------------- >" `shouldBe` [Comment " img src=\"/www_images/NCEP_GFS.gif\"><!- -------------------------------------------------------- >"]
111 it "parses entity" $ do
112 parseTokens "&lt;" `shouldBe` [ContentText "<"]