module Example.Regress (regress) where
import Text.HTML.TagSoup
import Text.HTML.TagSoup.Entity
import qualified Text.HTML.TagSoup.Match as Match
import Control.Exception
data Test a = Pass
instance Monad Test where
a >> b = a `seq` b
return = error "No return for Monad Test"
(>>=) = error "No bind (>>=) for Monad Test"
instance Show (Test a) where
show x = x `seq` "All tests passed"
pass :: Test ()
pass = Pass
(===) :: (Show a, Eq a) => a -> a -> Test ()
a === b = if a == b then pass else fail $ "Does not equal: " ++ show a ++ " =/= " ++ show b
regress :: IO ()
regress = print $ do
parseTests
combiTests
entityTests
lazyTags == lazyTags `seq` pass
matchCombinators
lazyTags :: [Char]
lazyTags =
map ((!!1000) . show . parseTags) $
(cycle "Rhabarber") :
(repeat '&') :
("<"++cycle "html") :
("<html "++cycle "na!me=value ") :
("<html name="++cycle "value") :
("<html name=\""++cycle "value") :
("<html name="++cycle "val!ue") :
("<html "++cycle "name") :
("</"++cycle "html") :
("<!-- "++cycle "comment") :
("<!"++cycle "doctype") :
("<!DOCTYPE"++cycle " description") :
(cycle "1<2 ") :
("<html name="++cycle "val&ue") :
("<html name="++cycle "va&l!ue") :
("&" ++ cycle "t") :
(cycle "& test") :
[]
matchCombinators :: Test ()
matchCombinators = assert (and tests) pass
where
tests =
Match.tagText (const True) (TagText "test") :
Match.tagText ("test"==) (TagText "test") :
Match.tagText ("soup"/=) (TagText "test") :
Match.tagOpenNameLit "table"
(TagOpen "table" [("id", "name")]) :
Match.tagOpenLit "table" (Match.anyAttrLit ("id", "name"))
(TagOpen "table" [("id", "name")]) :
Match.tagOpenLit "table" (Match.anyAttrNameLit "id")
(TagOpen "table" [("id", "name")]) :
not (Match.tagOpenLit "table" (Match.anyAttrLit ("id", "name"))
(TagOpen "table" [("id", "other name")])) :
[]
parseTests :: Test ()
parseTests = do
parseTags "<!DOCTYPE TEST>" === [TagOpen "!DOCTYPE" [("TEST","")]]
parseTags "<test \"foo bar\">" === [TagOpen "test" [("","foo bar")]]
parseTags "<test \'foo bar\'>" === [TagOpen "test" [("","foo bar")]]
parseTags "<:test \'foo bar\'>" === [TagOpen ":test" [("","foo bar")]]
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 "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">" ===
[TagOpen "!DOCTYPE" [("HTML",""),("PUBLIC",""),("","-//W3C//DTD HTML 4.01//EN"),("","http://www.w3.org/TR/html4/strict.dtd")]]
parseTags "<script src=\"http://edge.jobthread.com/feeds/jobroll/?s_user_id=100540&subtype=slashdot\">" ===
[TagOpen "script" [("src","http://edge.jobthread.com/feeds/jobroll/?s_user_id=100540&subtype=slashdot")]]
parseTags "<a title='foo'bar' href=correct>text" === [TagOpen "a" [("title", "foo"),
("bar", ""),
("href", "correct")],
TagText "text"]
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" [] ~== "<test>") === True
(TagOpen "test" [] ~== "<soup>") === False
(TagOpen "test" [] ~/= "<soup>") === True