{-# OPTIONS_GHC -fno-warn-deprecations #-} module TagSoup.Test(test) where import Text.HTML.TagSoup import Text.HTML.TagSoup.Entity import Text.HTML.TagSoup.Match import Control.Monad import Data.List import Test.QuickCheck -- * The Test Monad type Test a = IO a pass :: Test () pass = return () runTest :: Test () -> IO () runTest x = x >> putStrLn "All tests passed" (===) :: (Show a, Eq a) => a -> a -> IO () a === b = if a == b then pass else fail $ "Does not equal: " ++ show a ++ " =/= " ++ show b check :: Testable prop => prop -> IO () check prop = do res <- quickCheckWithResult stdArgs{maxSuccess=1000} prop case res of Success{} -> pass _ -> fail "Property failed" newtype HTML = HTML String deriving Show instance Arbitrary HTML where arbitrary = fmap (HTML . concat) $ listOf $ elements frags where frags = map (:[]) " \n!-#&;xy01[]?'\"" ++ ["CDATA","amp","gt","lt"] shrink (HTML x) = map HTML $ zipWith (++) (inits x) (tail $ tails x) -- * The Main section test :: IO () test = runTest $ do warnTests parseTests optionsTests renderTests combiTests entityTests lazyTags == lazyTags `seq` pass matchCombinators {- | This routine tests the laziness of the TagSoup parser. For each critical part of the parser we provide a test input with a token of infinite size. Then the output must be infinite too. If the laziness is broken, then the output will stop early. We collect the thousandth character of the output of each test case. If computation of the list stops somewhere, you have found a laziness stopper. -} lazyTags :: [Char] lazyTags = map ((!!1000) . show . parseTags) [cycle "Rhabarber" ,repeat '&' ,"<"++cycle "html" ,"" === [TagOpen "!DOCTYPE" [("TEST","")]] parseTags "" === [TagOpen "test" [("\"foo",""),("bar\"","")]] parseTags "" === [TagOpen "test" [("baz",""),("\"foo\"","")]] parseTags "" === [TagOpen "test" [("'foo",""),("bar'","")]] parseTags "" === [TagOpen "test" [("bar",""),("'","")], TagClose "test"] parseTags "" === [TagOpen "test2" [("a",""),("b","")]] parseTags "" === [TagOpen "test2" [("''","")]] parseTags "" === [TagClose "test"] parseTags "" === [TagOpen "test" [], TagClose "test"] parseTags "" === [TagOpen "test1" [("a","b")]] parseTags "hello & world" === [TagText "hello & world"] parseTags "hello @ world" === [TagText "hello @ world"] parseTags "hello @ world" === [TagText "hello @ world"] parseTags "hello &haskell; world" === [TagText "hello &haskell; world"] parseTags "hello \n\t world" === [TagText "hello \n\t world"] parseTags "" === [TagOpen "a" [("href","http://www.google.com")]] parseTags "" === [TagOpen "foo" [("bar","bar6baz")]] parseTags "" === [TagOpen "foo" [("bar","bar&baz")]] parseTags "hey &how are you" === [TagText "hey &how are you"] parseTags "hey &how; are you" === [TagText "hey &how; are you"] parseTags "hey & are you" === [TagText "hey & are you"] parseTags "hey & are you" === [TagText "hey & are you"] -- real cases reported by users parseTags "↖x≧̸" === [TagText ['\x2196','x','\x2267','\x0338']] parseTags "test � test" === [TagText "test ? test"] parseTags "" === [TagOpen "a" [("href","series.php?view=single&ID=72710")]] parseTags "" === [TagOpen "!DOCTYPE" [("HTML",""),("PUBLIC",""),("","-//W3C//DTD HTML 4.01//EN"),("","http://www.w3.org/TR/html4/strict.dtd")]] parseTags "" === [TagOpen "script" [], TagText " if (x if (x if (x" === [TagOpen "SCRIPT" [("language","foo")], TagText " if (x" === [TagOpen "script" [], TagClose "script", TagOpen "test" []] optionsTests :: Test () optionsTests = check $ \(HTML x) -> all (f x) $ replicateM 3 [False,True] where f str [pos,warn,merge] = bool "merge" (not merge || adjacentTagText tags) && bool "warn" (warn || all (not . isTagWarning) tags) && bool "pos" (if pos then alternatePos tags else all (not . isTagPosition) tags) where tags = parseTagsOptions parseOptions{optTagPosition=pos,optTagWarning=warn,optTagTextMerge=merge} str bool x b = b || error ("optionsTests failed with " ++ x ++ " on " ++ show (pos,warn,merge,str,tags)) -- optTagTextMerge implies no adjacent TagText cells -- and none separated by only warnings or positions adjacentTagText = g True -- can the next be a tag text where g i (x:xs) | isTagText x = i && g False xs | isTagPosition x || isTagWarning x = g i xs | otherwise = g True xs g i [] = True -- optTagPosition implies every element must be followed -- by a position node, no two position nodes must be adjacent -- and all positions must be increasing alternatePos (TagPosition l1 c1 : x : TagPosition l2 c2 : xs) | (l1,c1) <= (l2,c2) && not (isTagPosition x) = alternatePos $ TagPosition l2 c2 : xs alternatePos [TagPosition l1 c1, x] | not $ isTagPosition x = True alternatePos [] = True alternatePos _ = False renderTests :: Test () renderTests = do let rp = renderTags . parseTags rp "" === "" rp "

" === "
" rp "" === "" rp "hello & world" === "hello & world" rp "" === "" rp "" === "" rp "" === "" rp "" === "" rp "" === "" rp "" === "" rp "" === "" escapeHTML "this is a &\" '" === "this is a &" <test> '" check $ \(HTML x) -> let y = rp x in rp y == (y :: String) entityTests :: Test () entityTests = do lookupNumericEntity "65" === Just "A" lookupNumericEntity "x41" === Just "A" lookupNumericEntity "x4E" === Just "N" lookupNumericEntity "x4e" === Just "N" lookupNumericEntity "Haskell" === Nothing lookupNumericEntity "" === Nothing lookupNumericEntity "89439085908539082" === Nothing lookupNamedEntity "amp" === Just "&" lookupNamedEntity "haskell" === Nothing escapeXML "hello world" === "hello world" escapeXML "hello & world" === "hello & world" combiTests :: Test () combiTests = do (TagText "test" ~== TagText "" ) === True (TagText "test" ~== TagText "test") === True (TagText "test" ~== TagText "soup") === False (TagText "test" ~== "test") === True (TagOpen "test" [] ~== "") === True (TagOpen "test" [] ~== "") === False (TagOpen "test" [] ~/= "") === True (TagComment "foo" ~== "") === True (TagComment "bar" ~== "") === True warnTests :: Test () warnTests = do let p = parseTagsOptions parseOptions{optTagPosition=True,optTagWarning=True} wt x = [(msg,c) | TagWarning msg:TagPosition _ c:_ <- tails $ p x] wt "neil &foo bar" === [("Unknown entity: foo",10)]