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
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
|
{-# LANGUAGE OverloadedStrings #-}
module Text.XmlHtml.OASISTest (testsOASIS) where
import Blaze.ByteString.Builder
import Control.Applicative
import Control.Monad
import qualified Data.ByteString as B
import Data.Maybe
import qualified Data.Text as T
import System.Directory
import Test.Framework
import Test.Framework.Providers.HUnit
import Test.HUnit hiding (Test, Node)
import Text.XmlHtml
------------------------------------------------------------------------------
-- | Runs the OASIS XML conformance test suite. The test cases sit in
-- directories inside of @test/resources@. This test reads them, parses them,
-- and ensures that they behave as expected:
--
-- * If there is a file in the same directory named /filename/@.correct@
-- or /filename/@.incorrect@, the parsing is expected to either succeed
-- or fail, as indicated. Otherwise, the remaining cases apply.
--
-- * For those tests marked @not-wf@, the test expects an error message.
--
-- * For tests marked @valid@ or @invalid@ (there is no distinction since
-- @xmlhtml@ is not a validating parser), the test expects a successful
-- parse, but does not verify the parse result.
--
-- For tests that should succeed as XML but not HTML, or vice versa, files
-- can be named /filename/@.xml.correct@, and so on (all 4 combinations).
testsOASIS :: [Test]
testsOASIS = [
testCase "xmlhtml/ibm-not-wf " $ oasisP "ibm/ibm_oasis_not-wf.xml",
testCase "xmlhtml/ibm-invalid " $ oasisP "ibm/ibm_oasis_invalid.xml",
testCase "xmlhtml/ibm-valid " $ oasisP "ibm/ibm_oasis_valid.xml",
testCase "xmlhtml/oasis " $ oasisP "oasis/oasis.xml",
testCase "xmlhtml/r-ibm-not-wf " $ oasisR "ibm/ibm_oasis_not-wf.xml",
testCase "xmlhtml/r-ibm-invalid " $ oasisR "ibm/ibm_oasis_invalid.xml",
testCase "xmlhtml/r-ibm-valid " $ oasisR "ibm/ibm_oasis_valid.xml",
testCase "xmlhtml/r-oasis " $ oasisR "oasis/oasis.xml",
testCase "xmlhtml/h-ibm-not-wf " $ oasisHP "ibm/ibm_oasis_not-wf.xml",
testCase "xmlhtml/h-ibm-invalid " $ oasisHP "ibm/ibm_oasis_invalid.xml",
testCase "xmlhtml/h-ibm-valid " $ oasisHP "ibm/ibm_oasis_valid.xml",
testCase "xmlhtml/h-oasis " $ oasisHP "oasis/oasis.xml",
testCase "xmlhtml/hr-ibm-not-wf " $ oasisHR "ibm/ibm_oasis_not-wf.xml",
testCase "xmlhtml/hr-ibm-invalid " $ oasisHR "ibm/ibm_oasis_invalid.xml",
testCase "xmlhtml/hr-ibm-valid " $ oasisHR "ibm/ibm_oasis_valid.xml",
testCase "xmlhtml/hr-oasis " $ oasisHR "oasis/oasis.xml"
]
oasisP :: String -> Assertion
oasisP name = do
tests <- getOASIS ".xml" name
forM_ tests $ \(fn, ty) -> case ty of
True -> oasisWF fn
False -> oasisNotWF fn
oasisR :: String -> Assertion
oasisR name = do
tests <- getOASIS ".xml" name
forM_ tests $ \(fn, ty) -> case ty of
True -> oasisRerender fn
False -> return ()
oasisHP :: String -> Assertion
oasisHP name = do
tests <- getOASIS ".html" name
forM_ tests $ \(fn, ty) -> case ty of
True -> hOasisWF fn
False -> hOasisNotWF fn
oasisHR :: String -> Assertion
oasisHR name = do
tests <- getOASIS ".html" name
forM_ tests $ \(fn, ty) -> case ty of
True -> hOasisRerender fn
False -> return ()
getOASIS :: String -> String -> IO [(String, Bool)]
getOASIS sub name = do
testListSrc <- B.readFile ("resources/" ++ name)
let Right (XmlDocument _ _ ns) = parseXML name testListSrc
let Just c = listToMaybe (filter isElement ns)
oasisTestCases sub name c
oasisTestCases :: String -> String -> Node -> IO [(String, Bool)]
oasisTestCases sub name n = do
fmap concat $ forM (childElements n) $ \t -> case tagName t of
Just "TESTCASES" -> oasisTestCases sub name t
Just "TEST" -> oasisTest sub name t
_ -> error (show t)
oasisTest :: String -> String -> Node -> IO [(String, Bool)]
oasisTest sub name t = do
let fn = file $ fromJust $ getAttribute "URI" t
fe <- doesFileExist fn
ce <- (||) <$> doesFileExist (fn ++ ".correct")
<*> doesFileExist (fn ++ sub ++ ".correct")
ie <- (||) <$> doesFileExist (fn ++ ".incorrect")
<*> doesFileExist (fn ++ sub ++ ".incorrect")
let ty = getAttribute "TYPE" t
if fe then case () of
() | ce -> return [(fn, True)]
| ie -> return [(fn, False)]
| ty == Just "not-wf" -> return [(fn, False)]
| ty == Just "invalid" -> return [(fn, True)]
| ty == Just "valid" -> return [(fn, True)]
| otherwise -> return [(fn, True)]
else return []
where
file f = "resources/" ++ toLastSlash name ++ T.unpack f
toLastSlash s = snd (go s)
where go [] = (False, [])
go (c:cs) = let (found, ccs) = go cs
in if found then (True, c:ccs)
else if c == '/' then (True, "/")
else (False, c:cs)
oasisNotWF :: String -> Assertion
oasisNotWF name = do
src <- B.readFile name
assertBool ("not-wf parse " ++ name) $ isLeft (parseXML name src)
where
isLeft (Left _) = True
isLeft _ = False
oasisWF :: String -> Assertion
oasisWF name = do
src <- B.readFile name
assertBool ("wf parse " ++ name) $ isRight (parseXML name src)
where
isRight (Right _) = True
isRight _ = False
oasisRerender :: String -> Assertion
oasisRerender name = do
src <- B.readFile name
let Right d = parseXML "" src
let src2 = toByteString (render d)
let Right d2 = parseXML "" src2
assertEqual ("rerender " ++ name) d d2
hOasisNotWF :: String -> Assertion
hOasisNotWF name = do
src <- B.readFile name
assertBool ("not-wf parse " ++ name) $ isLeft (parseHTML name src)
where
isLeft (Left _) = True
isLeft _ = False
hOasisWF :: String -> Assertion
hOasisWF name = do
src <- B.readFile name
assertBool ("wf parse " ++ name) $ isRight (parseHTML name src)
where
isRight (Right _) = True
isRight _ = False
hOasisRerender :: String -> Assertion
hOasisRerender name = do
src <- B.readFile name
let Right d = parseHTML "" src
let src2 = toByteString (render d)
let Right d2 = parseHTML "" src2
assertEqual ("rerender " ++ name) d d2
|
