@@ -21,19 +21,21 @@ import Prelude ()
2121import Prelude.Compat
2222
2323import Control.Applicative (Const(..))
24−import Control.Monad (forM, forM_)
24+import Control.Monad (forM, forM_, unless)
2525import Data.Aeson ((.=), (.:), (.:?), (.:!), FromJSON(..), FromJSONKeyFunction(..), FromJSONKey(..), ToJSON1(..), decode, eitherDecode, encode, genericParseJSON, genericToEncoding, genericToJSON, object, withObject)
2626import Data.Aeson.Internal (JSONPathElement(..), formatError)
2727import Data.Aeson.TH (deriveJSON, deriveToJSON, deriveToJSON1)
2828import Data.Aeson.Text (encodeToTextBuilder)
2929import Data.Aeson.Types (Options(..), SumEncoding(..), ToJSON(..), Value, camelTo, camelTo2, defaultOptions, omitNothingFields)
3030import Data.Char (toUpper)
31+import Data.Either (isLeft, isRight)
3132import Data.Fixed (Pico)
3233import Data.Functor.Compose (Compose(..))
3334import Data.Functor.Identity (Identity(..))
3435import Data.Functor.Product (Product(..))
3536import Data.Functor.Sum (Sum(..))
3637import Data.Hashable (hash)
38+import Data.List (sort)
3739import Data.List.NonEmpty (NonEmpty(..))
3840import Data.Maybe (fromMaybe)
3941import Data.Proxy (Proxy(..))
@@ -47,9 +49,13 @@ import Data.Time.Locale.Compat (defaultTimeLocale)
4749import Data.Word (Word8)
4850import GHC.Generics (Generic)
4951import Instances ()
52+import System.Directory (doesDirectoryExist, getDirectoryContents)
53+import System.Exit (exitWith, ExitCode(ExitFailure))
54+import System.IO (hPutStrLn, stderr)
55+import System.FilePath ((</>), takeExtension, takeFileName)
5056import Test.Framework (Test, testGroup)
5157import Test.Framework.Providers.HUnit (testCase)
52−import Test.HUnit (Assertion, assertFailure, assertEqual)
58+import Test.HUnit (Assertion, assertBool, assertFailure, assertEqual)
5359import Text.Printf (printf)
5460import Types (Approx(..), Compose3, Compose3', I)
5561import UnitTests.NullaryConstructors (nullaryConstructors)
@@ -536,7 +542,8 @@ issue351 = [
536542ioTests :: IO [Test]
537543ioTests = do
538544 enc <- encoderComparisonTests
539− return [enc]
545+ js <- jsonTestSuite
546+ return [enc, js]
540547
541548encoderComparisonTests :: IO Test
542549encoderComparisonTests = do
@@ -596,6 +603,91 @@ unescapeString = do
596603 L.concat ["\"\\u", L.take 4 s, "\\u", L.drop 4 s, "\""]
597604 | otherwise = error "unescapeString: can't happen"
598605
606+-- JSONTestSuite
607+
608+jsonTestSuiteTest :: FilePath -> L.ByteString -> Test
609+jsonTestSuiteTest path payload =
610+ testCase fileName .
611+ assertBool fileName $
612+ case take 2 fileName of
613+ "i_" -> isRight result
614+ "n_" -> isLeft result
615+ "y_" -> isRight result
616+ _ -> isRight result -- test_transform tests have inconsistent names
617+ where
618+ fileName = takeFileName path
619+ result = eitherDecode payload :: Either String Value
620+
621+-- Build a collection of tests based on the current contents of the
622+-- JSONTestSuite test directories.
623+
624+jsonTestSuite :: IO Test
625+jsonTestSuite = do
626+ let suitePath = "tests/JSONTestSuite"
627+ exists <- doesDirectoryExist suitePath
628+ unless exists $ do
629+ hPutStrLn stderr $ "git clone https://github.com/nst/JSONTestSuite " ++
630+ suitePath
631+ exitWith (ExitFailure 1)
632+ -- ignore test_transform for now
633+ let suites = ["test_parsing", "test_transform"]
634+ testPaths <- fmap (sort . concat) . forM suites $ \suite -> do
635+ let dir = suitePath </> suite
636+ entries <- getDirectoryContents dir
637+ let ok name = takeExtension name == ".json" &&
638+ not (name `HashSet.member` blacklist)
639+ return . map (dir </>) . filter ok $ entries
640+ fmap (testGroup "JSONTestSuite") . forM testPaths $ \path ->
641+ jsonTestSuiteTest path <$> L.readFile path
642+
643+-- The set expected-to-be-failing JSONTestSuite tests.
644+-- Not all of these failures are genuine bugs.
645+-- Of those that are bugs, not all are worth fixing.
646+
647+blacklist :: HashSet.HashSet String
648+-- blacklist = HashSet.empty
649+blacklist = _blacklist
650+
651+_blacklist :: HashSet.HashSet String
652+_blacklist = HashSet.fromList [
653+ "i_object_key_lone_2nd_surrogate.json"
654+ , "i_string_1st_surrogate_but_2nd_missing.json"
655+ , "i_string_1st_valid_surrogate_2nd_invalid.json"
656+ , "i_string_UTF-16LE_with_BOM.json"
657+ , "i_string_UTF-16_invalid_lonely_surrogate.json"
658+ , "i_string_UTF-16_invalid_surrogate.json"
659+ , "i_string_UTF-8_invalid_sequence.json"
660+ , "i_string_incomplete_surrogate_and_escape_valid.json"
661+ , "i_string_incomplete_surrogate_pair.json"
662+ , "i_string_incomplete_surrogates_escape_valid.json"
663+ , "i_string_inverted_surrogates_U+1D11E.json"
664+ , "i_string_lone_second_surrogate.json"
665+ , "i_string_not_in_unicode_range.json"
666+ , "i_string_truncated-utf-8.json"
667+ , "i_structure_UTF-8_BOM_empty_object.json"
668+ , "n_number_-01.json"
669+ , "n_number_-2..json"
670+ , "n_number_0.e1.json"
671+ , "n_number_2.e+3.json"
672+ , "n_number_2.e-3.json"
673+ , "n_number_2.e3.json"
674+ , "n_number_neg_int_starting_with_zero.json"
675+ , "n_number_real_without_fractional_part.json"
676+ , "n_number_with_leading_zero.json"
677+ , "n_string_unescaped_crtl_char.json"
678+ , "n_string_unescaped_newline.json"
679+ , "n_string_unescaped_tab.json"
680+ , "n_structure_whitespace_formfeed.json"
681+ , "string_1_escaped_invalid_codepoint.json"
682+ , "string_1_invalid_codepoint.json"
683+ , "string_2_escaped_invalid_codepoints.json"
684+ , "string_1_invalid_codepoints.json"
685+ , "string_3_escaped_invalid_codepoints.json"
686+ , "string_3_invalid_codepoints.json"
687+ , "y_string_utf16BE_no_BOM.json"
688+ , "y_string_utf16LE_no_BOM.json"
689+ ]
690+
599691-- A regression test for: https://github.com/bos/aeson/pull/455
600692data Foo a = FooNil | FooCons (Foo Int)
601693