-- |
-- HUnit - Haskell XML Toolbox examples and tests for arrows
--
-- Author: Uwe Schmidt uwe@fh-wedel.de
--
module Main where
import System
import Test.HUnit
import Text.XML.HXT.Arrow
import Text.XML.HXT.XPath
-- |
-- auxiliary function to make haskell string constants with quotes more readable
singleToDoubleQuote :: String -> String
singleToDoubleQuote
= map (\ c -> if c == '\'' then '\"' else c)
testLA :: String -> String -> LA XmlTree XmlTree -> Test
testLA doc expected f
= TestCase $ assertEqual "LA XmlTree XmlTree:" [expected] res
where
res = runLA (xread >>> xshow f) doc
testLAString :: String -> String -> LA XmlTree String -> Test
testLAString doc expected f
= TestCase $ assertEqual "LA XmlTree String:" [expected] res
where
res = runLA (xread >>> f) doc
mkTestSeqLA :: String -> [(String, LA XmlTree XmlTree)] -> [Test]
mkTestSeqLA doc
= map (\ (res, f) -> testLA doc (singleToDoubleQuote res) f)
nodeSetTests :: Test
nodeSetTests
= TestList $
[ TestLabel "node set and simple XPath tests with getXPathTrees" $
TestList $
mkTestSeqLA doc (testGetXPathTrees tests)
, TestLabel "node set and simple XPath tests with getXPathNodeSet" $
TestList $
mkTestSeqLA doc (testGetXPathNodes tests)
, TestLabel "node set and simple XPath tests with processFromNodeSet" $
TestList $
mkTestSeqLA doc (testProcessXPath processTests)
, TestLabel "node set and simple XPath tests with processXPathTrees" $
TestList $
mkTestSeqLA doc (testProcessXPath' processTests)
]
where
doc = ".0.1.0.2.3.0.3.1.0.4"
testGetXPathTrees = map (\ (r, xp) -> (r, getXPathTrees xp)) -- these arrows are equivalent
testGetXPathNodes = map (\ (r, xp) -> (r, getFromNodeSet $< getXPathNodeSet xp)) -- except for the ordering of the result set
-- which does not matter for these tests
testProcessXPath = map (\ (r, xp, a) -> (r, processFromNodeSet a $< getXPathNodeSet xp))
testProcessXPath' = map (\ (r, xp, a) -> (r, processXPathTrees a xp))
tests = [ (doc , "/x" )
, (".3.0.3.1.0" , "/x/y" )
, (".3.1.0" , "/x/y/x" )
, (".0.2.4" , "/x/text()" )
, (".3.0" , "/x/y/text()" )
, (".1.0.3.1.0" , "/x//x" )
]
processTests
= [ ("xxxxxx", "//text()", changeText (const "x") )
, (".0.1.0.2.3.0x.4", "/x/y/x/text()", changeText (const "x") )
, (".0.1.0.2.3.0.4", "/x/y/x", none )
, (".0.1.0.2.3.0zzz.4", "/x/y/x", txt "zzz" )
, (".0.1.0.2.3.0.3.1.0.4",
"/x/y/x", addAttr "q" "3.2" )
]
-- |
-- the complete set of test cases
allTests :: Test
allTests
= TestList
[ nodeSetTests
]
main :: IO ()
main
= do
c <- runTestTT allTests
putStrLn $ show c
let errs = errors c
fails = failures c
System.exitWith (codeGet errs fails)
codeGet :: Int -> Int -> ExitCode
codeGet errs fails
| fails > 0 = ExitFailure 2
| errs > 0 = ExitFailure 1
| otherwise = ExitSuccess
-- ----------------------------------------------------------