@@ -1,6 +1,6 @@
11{-# LANGUAGE TemplateHaskell #-}
22
3−module Main where
3+module Lib where
44
55import Control.Applicative
66import Control.Monad
@@ -10,22 +10,15 @@ import qualified Data.ByteString.Lazy as LBS
1010import Data.Char (toLower)
1111import qualified Data.HashMap.Strict as H
1212import Data.JsonSchema
13−import Data.List (isSuffixOf)
1413import Data.Monoid
1514import Data.Text (Text)
1615import qualified Data.Text as T
1716import qualified Data.Vector as V
18−import System.Directory (getDirectoryContents)
1917import System.FilePath ((</>))
2018import Test.Framework
2119import Test.Framework.Providers.HUnit
2220import qualified Test.HUnit as HU
2321
24−main :: IO ()
25−main = do
26− ts <- readSchemaTests
27− defaultMain (toTest <$> ts)
28−
2922data SchemaTest = SchemaTest
3023 { _stDescription :: Text
3124 , _stSchema :: RawSchema
@@ -48,22 +41,31 @@ instance FromJSON SchemaTest where
4841 <*> o .: "schema"
4942 <*> o .: "tests" -- I wish this were "cases"
5043
51−readSchemaTests :: IO [SchemaTest]
52−readSchemaTests = do
53− jsonFiles <- filter (".json" `isSuffixOf`) <$> getDirectoryContents dir
54− fmap concat $ forM jsonFiles $ \file -> do
55− let fullPath = dir </> file
56− jsonBS <- LBS.readFile fullPath
57− case eitherDecode jsonBS of
58− Left err -> fail $ "couldn't parse file '" <> fullPath <> "': " <> err
59− Right schemas -> return $ prependFileName file <$> schemas
44+isLocal :: String -> Bool
45+isLocal file = (file /= "definitions.json")
46+ && (file /= "ref.json")
47+ && (file /= "refRemote.json")
48+
49+readSchemaTests :: String -> [String] -> IO [SchemaTest]
50+readSchemaTests dir jsonFiles = concatMapM fileToCases jsonFiles
6051 where
61− dir = "JSON-Schema-Test-Suite/tests/draft4"
52+ -- Each file contains an array of SchemaTests, not just one.
53+ fileToCases :: String -> IO [SchemaTest]
54+ fileToCases name = do
55+ let fullPath = dir </> name
56+ jsonBS <- LBS.readFile fullPath
57+ case eitherDecode jsonBS of
58+ Left e -> fail $ "couldn't parse file '" <> fullPath <> "': " <> e
59+ Right schemaTests -> return $ prependFileName name <$> schemaTests
60+
6261 prependFileName :: String -> SchemaTest -> SchemaTest
6362 prependFileName fileName s = s
6463 { _stDescription = T.pack fileName <> ": " <> _stDescription s
6564 }
6665
66+ concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b]
67+ concatMapM f xs = liftM concat (mapM f xs)
68+
6769toTest :: SchemaTest -> Test
6870toTest st = testGroup groupName (mkCase <$> _stCases st)
6971 where