1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
|
-- |
-- 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.Core
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 = "<x p='.'>.0<x p='.1'>.1.0</x>.2<y p='.3'>.3.0<x p='.3.1'>.3.1.0</x></y>.4</x>"
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" )
, ("<y p='.3'>.3.0<x p='.3.1'>.3.1.0</x></y>" , "/x/y" )
, ("<x p='.3.1'>.3.1.0</x>" , "/x/y/x" )
, (".0.2.4" , "/x/text()" )
, (".3.0" , "/x/y/text()" )
, ("<x p='.1'>.1.0</x><x p='.3.1'>.3.1.0</x>" , "/x//x" )
]
processTests
= [ ("<x p='.'>x<x p='.1'>x</x>x<y p='.3'>x<x p='.3.1'>x</x></y>x</x>", "//text()", changeText (const "x") )
, ("<x p='.'>.0<x p='.1'>.1.0</x>.2<y p='.3'>.3.0<x p='.3.1'>x</x></y>.4</x>", "/x/y/x/text()", changeText (const "x") )
, ("<x p='.'>.0<x p='.1'>.1.0</x>.2<y p='.3'>.3.0</y>.4</x>", "/x/y/x", none )
, ("<x p='.'>.0<x p='.1'>.1.0</x>.2<y p='.3'>.3.0zzz</y>.4</x>", "/x/y/x", txt "zzz" )
, ("<x p='.'>.0<x p='.1'>.1.0</x>.2<y p='.3'>.3.0<x p='.3.1' q='3.2'>.3.1.0</x></y>.4</x>",
"/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
-- ----------------------------------------------------------
|
