Merge pull request #969 from haskell/JSONTestSuite-cleanup

JSONTestSuite cleanup

Author: phadej

aeson.cabal

@@ -166,6 +166,7 @@ test-suite aeson-tests
     ErrorMessages
     Functions
     Instances
+    JSONTestSuite
     Options
     Properties
     PropertyGeneric

tests/JSONTestSuite.hs

@@ -0,0 +1,80 @@
+module JSONTestSuite (tests) where
+
+import Test.Tasty (TestTree, testGroup)
+import Data.Either.Compat (isLeft, isRight)
+import Test.Tasty.HUnit ( testCase, assertBool )
+import System.Directory (getDirectoryContents)
+import System.FilePath ((</>), takeExtension, takeFileName)
+import Data.List (sort)
+import Control.Monad (forM)
+
+import qualified Data.ByteString.Lazy as L
+import qualified Data.HashSet as HashSet
+
+import Data.Aeson
+
+jsonTestSuiteTest :: FilePath -> TestTree
+jsonTestSuiteTest path = testCase fileName $ do
+    payload <- L.readFile path
+    let result = eitherDecode payload :: Either String Value
+    assertBool (show result) $ case take 2 fileName of
+      "n_"                                                -> isLeft result
+      "y_"                                                -> isRight result
+      "i_" | fileName `HashSet.member` ignore_accepted    -> isRight result
+           | otherwise                                    -> isLeft result
+      _    | fileName `HashSet.member` transform_rejected -> isLeft result
+           | otherwise                                    -> isRight result -- test_transform tests have inconsistent names
+  where
+    fileName = takeFileName path
+
+-- Build a collection of tests based on the current contents of the
+-- JSONTestSuite test directories.
+
+tests :: IO TestTree
+tests = do
+  let suitePath = "tests/JSONTestSuite"
+  let suites = ["test_parsing", "test_transform"]
+  testPaths <- fmap (sort . concat) . forM suites $ \suite -> do
+    let dir = suitePath </> suite
+    entries <- getDirectoryContents dir
+    let ok name = takeExtension name == ".json"
+    return . map (dir </>) . filter ok $ entries
+  return $ testGroup "JSONTestSuite" $ map jsonTestSuiteTest testPaths
+
+-- The set expected-to-be-failing JSONTestSuite tests.
+-- Not all of these failures are genuine bugs.
+-- Of those that are bugs, not all are worth fixing.
+
+-- | The @i@ cases we can ignore. We don't.
+--
+-- @i_@ - parsers are free to accept or reject content
+--
+-- We specify which @i_@ case we accept, so we can catch changes even in unspecified behavior.
+-- (There is less case we accept)
+ignore_accepted :: HashSet.HashSet FilePath
+ignore_accepted = HashSet.fromList
+    [ "i_number_double_huge_neg_exp.json"
+    , "i_number_huge_exp.json"
+    , "i_number_neg_int_huge_exp.json"
+    , "i_number_pos_double_huge_exp.json"
+    , "i_number_real_neg_overflow.json"
+    , "i_number_real_pos_overflow.json"
+    , "i_number_real_underflow.json"
+    , "i_number_too_big_neg_int.json"
+    , "i_number_too_big_pos_int.json"
+    , "i_number_very_big_negative_int.json"
+    , "i_structure_500_nested_arrays.json"
+    ]
+
+-- | Transform folder contain weird structures and characters that parsers may understand differently.
+--
+-- We don't even try to understand some.
+transform_rejected :: HashSet.HashSet FilePath
+transform_rejected = HashSet.fromList
+    [ "string_1_escaped_invalid_codepoint.json"
+    , "string_1_invalid_codepoint.json"
+    , "string_2_escaped_invalid_codepoints.json"
+    , "string_2_invalid_codepoints.json"
+    , "string_3_escaped_invalid_codepoints.json"
+    , "string_3_invalid_codepoints.json"
+    ]