@@ -0,0 +1,163 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+module Main
4+( main
5+)
6+where
7+
8+import Data.Text (Text)
9+import qualified Data.Text as Text
10+import Data.IORef
11+import Control.Monad
12+import Control.Exception
13+import System.FilePath
14+import System.IO.Unsafe (unsafePerformIO)
15+import qualified System.IO as IO
16+import Text.XML
17+import Text.XML.Cursor
18+
19+import qualified Xsd
20+
21+data Stat = Stat
22+ { statTestSet :: Text
23+ , statTotal :: Int
24+ , statSucceeded :: Int
25+ }
26+ deriving (Show)
27+
28+{-# NOINLINE errRef #-}
29+errRef :: IORef Int
30+errRef = unsafePerformIO (newIORef 0)
31+
32+{-# NOINLINE okRef #-}
33+okRef :: IORef Int
34+okRef = unsafePerformIO (newIORef 0)
35+
36+{-# NOINLINE statsRef #-}
37+statsRef :: IORef [Stat]
38+statsRef = unsafePerformIO (newIORef [])
39+
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."
46+ IO.hPutStrLn h ""
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)
54+ ]
55+
56+expectedFailures :: Int
57+expectedFailures = 5316
58+
59+main :: IO ()
60+main = do
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
72+
73+runSuite :: FilePath -> Cursor -> IO ()
74+runSuite path c = mapM_ (runTestSetRef dir) (c $/ laxElement "testSetRef")
75+ where
76+ dir = takeDirectory path
77+
78+runTestSetRef :: FilePath -> Cursor -> IO ()
79+runTestSetRef dir c = do
80+ ref <- theAttribute c "href"
81+ let path = normalise (dir </> Text.unpack ref)
82+ runTestSet path
83+
84+runTestSet :: FilePath -> IO ()
85+runTestSet path = do
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")
91+ let
92+ stat = Stat
93+ { statTestSet = name
94+ , statTotal = (sum . map fst) results
95+ , statSucceeded = (sum . map snd) results
96+ }
97+ modifyIORef' statsRef (stat :)
98+ where
99+ dir = takeDirectory path
100+
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)
109+
110+runSchemaTest :: FilePath -> Text -> Cursor -> IO (Maybe Bool)
111+runSchemaTest dir groupName c = do
112+ path <- do
113+ c' <- theChild c "schemaDocument"
114+ theAttribute c' "href"
115+ mvalid <- do
116+ c' <- theChild c "expected"
117+ valid <- theAttribute c' "validity"
118+ case valid of
119+ "valid" -> return (Just True)
120+ "invalid" -> return (Just False)
121+ _ -> return Nothing
122+ case mvalid of
123+ Nothing -> return Nothing -- indetermined
124+ Just valid -> do
125+ res <- try (Xsd.getSchema (dir </> Text.unpack path))
126+ case (res, valid) of
127+ (Left _, False) -> do
128+ modifyIORef' okRef succ
129+ return (Just True)
130+ (Right _, True) -> do
131+ modifyIORef' okRef succ
132+ return (Just True)
133+ (Right _, False) -> do
134+ modifyIORef' errRef succ
135+ putStrLn $ "invalid xsd passed: " <> Text.unpack groupName
136+ <> " (" <> dir </> Text.unpack path <> ")"
137+ return (Just False)
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)
143+ return (Just False)
144+
145+anAttribute :: Cursor -> Text -> Maybe Text
146+anAttribute c name = case c $| laxAttribute name of
147+ (a:_) -> Just a
148+ _ -> Nothing
149+
150+theAttribute :: Cursor -> Text -> IO Text
151+theAttribute c name = maybe err return (anAttribute c name)
152+ where
153+ err = fail $ "no attribute " <> Text.unpack name
154+
155+aChild :: Cursor -> Text -> Maybe Cursor
156+aChild c name = case c $/ laxElement name of
157+ (a:_) -> Just a
158+ _ -> Nothing
159+
160+theChild :: Cursor -> Text -> IO Cursor
161+theChild c name = case aChild c name of
162+ Just a -> return a
163+ _ -> fail $ "no element " <> Text.unpack name