{-# 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.Exception 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 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 "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")]] -- real cases reported by users 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 "" === "" rp "hello & world" === "hello & world" rp "" === "" rp "" === "" rp "" === "" rp "" === "" rp "" === "" rp "" === "" 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 escapeXMLChar 'a' === Nothing escapeXMLChar '&' === Just "amp" 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 warnTests :: Test () warnTests = do return () {- -- TODO: Check that when there is a warning, it shows up at the right place warns "neil &foo bar" = missing ; let parse = parseTagsOptions parseOptions{ let noWarn x = {optTagPosition :: Bool -- ^ Should 'TagPosition' values be given before some items (default=False,fast=False) ,optTagWarning :: Bool -- ^ Should 'TagWarning' values be given (default=False,fast=False) -}