{-# LANGUAGE FlexibleInstances, OverloadedStrings #-} module Main where import Control.Applicative import Test.Framework (defaultMain, testGroup, Test) import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2 import Test.HUnit hiding (Test) import Test.QuickCheck import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S import qualified Data.Conduit as C import qualified Data.Conduit.List as CL import Text.HTML.TagStream main :: IO () main = defaultMain [ testGroup "Property" [ testProperty "Text nodes can't be empty" propTextNotEmpty , testProperty "Parse results can't empty" propResultNotEmpty ] , testGroup "One pass parse" onePassTests , testGroup "Streamline parse" streamlineTests ] propTextNotEmpty :: ByteString -> Bool propTextNotEmpty = either (const False) text_not_empty . decode where text_not_empty = all not_empty not_empty (Text s) = S.length s > 0 not_empty _ = True propResultNotEmpty :: ByteString -> Bool propResultNotEmpty s = either (const False) not_empty . decode $ s where not_empty tokens = (S.null s && null tokens) || (not (S.null s) && not (null tokens)) onePassTests :: [Test] onePassTests = map one testcases where one (str, tokens) = testCase (S.unpack str) $ do result <- combineText <$> assertDecode str assertEqual "one-pass parse result incorrect" tokens result streamlineTests :: [Test] streamlineTests = map one testcases where isIncomplete (Incomplete _) = True isIncomplete _ = False one (str, tokens) = testCase (S.unpack str) $ do -- streamline parse result don't contain the trailing Incomplete token. let tokens' = reverse . dropWhile isIncomplete . reverse $ tokens result <- combineText <$> C.runResourceT ( CL.sourceList (map S.singleton (S.unpack str)) C.$= tokenStream C.$$ CL.consume ) assertEqual "streamline parse result incorrect" tokens' result testcases :: [(ByteString, [Token])] testcases = -- attributes {{{ [ ( "
\"=\"xx \\\"'\\\\
\">" , [TagOpen "span" [("xx \"'\\
", "xx \"'\\
")] False] ) , ( "xx \\\"\\'\\\\'='xx \\\"\\'\\\\
'>" , [TagOpen "span" [("xx \"'\\
", "xx \"'\\
")] False] ) -- }}} -- attribute and tag end {{{ , ( "text
" , [TagOpen "p" [] False, Text "text", TagClose "p"] ) , ( "<>" , [TagOpen "" [] False] ) , ( "" , [TagOpen "a" [("title", "foo bar"), ("alt", "/")] False] ) -- }}} -- comment tag {{{ , ( "" , [Comment "foo"] ) , ( "" , [Comment "f--oo->"] ) , ( "bar-->" , [Comment "foo", Text "bar-->"] ) -- }}} -- special tag {{{ , ( "" , [Special "DOCTYPE" "html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\""] ) , ( "" , [Special "DOCTYPE" "html"] ) -- }}} -- close tag {{{ , ( "\r\t\nbr>" , [TagClose "\r\t\nbr"] ) , ( "" , [TagClose "br/"] ) , ( ">" , [TagClose ""] ) -- }}} -- incomplete test {{{ -- }}} -- script tag TODO{{{ , ( "" , [TagOpen "script" [] False, TagClose "script"] ) , ( "" , [TagOpen "script" [] False, Text "var x=\"", TagClose "script"] ) --, ( "\";" -- , [TagOpen "script" [] False, Text "var x=\"\";", TagClose "script"] -- ) , ( "" , [TagOpen "script" [] False, Text "// '\r\n", TagClose "script"] ) -- }}} ] testChar :: Gen Char testChar = growingElements "<>/=\"' \t\r\nabcde\\" testString :: Gen String testString = listOf testChar testBS :: Gen ByteString testBS = S.pack <$> testString instance Arbitrary ByteString where arbitrary = testBS assertEither :: Either String a -> Assertion assertEither = either (assertFailure . ("Left:"++)) (const $ return ()) assertDecode :: ByteString -> IO [Token] assertDecode s = do let result = decode s assertEither result let (Right tokens) = result return tokens combineText :: [Token] -> [Token] combineText [] = [] combineText (Text t1 : Text t2 : xs) = combineText $ Text (S.append t1 t2) : xs combineText (x:xs) = x : combineText xs