@@ -0,0 +1,163 @@
1+{-# LANGUAGE OverloadedStrings #-}
8+import Data.Text (Text)
9+import qualified Data.Text as Text
12+import Control.Exception
13+import System.FilePath
14+import System.IO.Unsafe (unsafePerformIO)
15+import qualified System.IO as IO
17+import Text.XML.Cursor
22+ { statTestSet :: Text
24+ , statSucceeded :: Int
28+{-# NOINLINE errRef #-}
30+errRef = unsafePerformIO (newIORef 0)
32+{-# NOINLINE okRef #-}
34+okRef = unsafePerformIO (newIORef 0)
36+{-# NOINLINE statsRef #-}
37+statsRef :: IORef [Stat]
38+statsRef = unsafePerformIO (newIORef [])
40+dumpResults :: [Stat] -> IO ()
41+dumpResults stats = IO.withFile "xsts.md" IO.WriteMode $ \h -> do
42+ IO.hPutStrLn h "This table is generated automatically by `xsts` test."
43+ IO.hPutStrLn h "It contains number of xsd files successfully parsed."
44+ IO.hPutStrLn h "Note that we don't currently attempt to validate xml files"
45+ IO.hPutStrLn h "against the schemata."
47+ IO.hPutStrLn h "Test set | Total tests | Passed tests"
48+ IO.hPutStrLn h "--- | --- | ---"
49+ forM_ stats $ \s -> do
50+ IO.hPutStrLn h $ mconcat
51+ [ Text.unpack (statTestSet s), " | "
52+ , show (statTotal s), " | "
53+ , show (statSucceeded s)
56+expectedFailures :: Int
57+expectedFailures = 5316
61+ let path = "./xsdtests/suite.xml"
62+ doc <- Text.XML.readFile def path
63+ runSuite path (fromDocument doc)
64+ oks <- readIORef okRef
65+ readIORef statsRef >>= dumpResults
66+ putStrLn $ "Succeeded: " ++ show oks
67+ errs <- readIORef errRef
68+ putStrLn $ "Failed: " ++ show errs
69+ unless (errs == expectedFailures) $
70+ fail $ "There were " ++ show errs ++ " errors, expected "
71+ ++ show expectedFailures
73+runSuite :: FilePath -> Cursor -> IO ()
74+runSuite path c = mapM_ (runTestSetRef dir) (c $/ laxElement "testSetRef")
76+ dir = takeDirectory path
78+runTestSetRef :: FilePath -> Cursor -> IO ()
79+runTestSetRef dir c = do
80+ ref <- theAttribute c "href"
81+ let path = normalise (dir </> Text.unpack ref)
84+runTestSet :: FilePath -> IO ()
86+ doc <- Text.XML.readFile def path
87+ let c = fromDocument doc
88+ name <- theAttribute c "name"
89+ putStrLn ("----- Test set " <> Text.unpack name)
90+ results <- mapM (runTestGroup dir) (c $/ laxElement "testGroup")
94+ , statTotal = (sum . map fst) results
95+ , statSucceeded = (sum . map snd) results
97+ modifyIORef' statsRef (stat :)
99+ dir = takeDirectory path
101+runTestGroup :: FilePath -> Cursor -> IO (Int, Int)
102+runTestGroup dir c = do
103+ name <- theAttribute c "name"
104+ results <- mapM (runSchemaTest dir name) (aChild c "schemaTest")
105+ case join results of
106+ Nothing -> return (0, 0)
107+ Just True -> return (1, 1)
108+ Just False -> return (1, 0)
110+runSchemaTest :: FilePath -> Text -> Cursor -> IO (Maybe Bool)
111+runSchemaTest dir groupName c = do
113+ c' <- theChild c "schemaDocument"
114+ theAttribute c' "href"
116+ c' <- theChild c "expected"
117+ valid <- theAttribute c' "validity"
119+ "valid" -> return (Just True)
120+ "invalid" -> return (Just False)
123+ Nothing -> return Nothing -- indetermined
125+ res <- try (Xsd.getSchema (dir </> Text.unpack path))
126+ case (res, valid) of
127+ (Left _, False) -> do
128+ modifyIORef' okRef succ
130+ (Right _, True) -> do
131+ modifyIORef' okRef succ
133+ (Right _, False) -> do
134+ modifyIORef' errRef succ
135+ putStrLn $ "invalid xsd passed: " <> Text.unpack groupName
136+ <> " (" <> dir </> Text.unpack path <> ")"
138+ (Left err, True) -> do
139+ modifyIORef' errRef succ
140+ putStrLn $ "valid xsd didn't pass: " <> Text.unpack groupName
141+ <> " (" <> dir </> Text.unpack path <> ")"
142+ <> ": " <> show (err :: SomeException)
145+anAttribute :: Cursor -> Text -> Maybe Text
146+anAttribute c name = case c $| laxAttribute name of
150+theAttribute :: Cursor -> Text -> IO Text
151+theAttribute c name = maybe err return (anAttribute c name)
153+ err = fail $ "no attribute " <> Text.unpack name
155+aChild :: Cursor -> Text -> Maybe Cursor
156+aChild c name = case c $/ laxElement name of
160+theChild :: Cursor -> Text -> IO Cursor
161+theChild c name = case aChild c name of
163+ _ -> fail $ "no element " <> Text.unpack name