git.iko.soy/typeable/aeson
on 1.4.5.0 help sign in
typeable/aeson/tests/UnitTests.hs
645 lines 26 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DeriveGeneric #-}
3{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4{-# LANGUAGE NoImplicitPrelude #-}
5{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE TemplateHaskell #-}
8{-# LANGUAGE QuasiQuotes #-}
10-- For Data.Aeson.Types.camelTo
11{-# OPTIONS_GHC -fno-warn-deprecations #-}
13#if MIN_VERSION_base(4,9,0)
14{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
15#endif
17module UnitTests
18 (
19 ioTests
20 , tests
21 , withEmbeddedJSONTest
22 ) where
24import Prelude.Compat
26import Control.Monad (forM, forM_)
27import Data.Aeson ((.=), (.:), (.:?), (.:!), FromJSON(..), FromJSONKeyFunction(..), FromJSONKey(..), ToJSON1(..), decode, eitherDecode, encode, fromJSON, genericParseJSON, genericToEncoding, genericToJSON, object, withObject, withEmbeddedJSON)
28import Data.Aeson.Internal (JSONPathElement(..), formatError)
29import Data.Aeson.QQ.Simple (aesonQQ)
30import Data.Aeson.TH (deriveJSON, deriveToJSON, deriveToJSON1)
31import Data.Aeson.Text (encodeToTextBuilder)
32import Data.Aeson.Parser
33 ( json, jsonLast, jsonAccum, jsonNoDup
34 , json', jsonLast', jsonAccum', jsonNoDup')
35import Data.Aeson.Types
36 ( Options(..), Result(Success), ToJSON(..), Value(Array, Bool, Null, Object)
37 , camelTo, camelTo2, defaultOptions, omitNothingFields, parse)
38import Data.Attoparsec.ByteString (Parser, parseOnly)
39import Data.Char (toUpper)
40import Data.Either.Compat (isLeft, isRight)
41import Data.Hashable (hash)
42import Data.HashMap.Strict (HashMap)
43import Data.List (sort)
44import Data.Maybe (fromMaybe)
45import Data.Scientific (Scientific, scientific)
46import Data.Tagged (Tagged(..))
47import Data.Text (Text)
48import Data.Time (UTCTime)
49import Data.Time.Format.Compat (parseTimeM, defaultTimeLocale)
50import GHC.Generics (Generic)
51import Instances ()
52import Numeric.Natural (Natural)
53import System.Directory (getDirectoryContents)
54import System.FilePath ((</>), takeExtension, takeFileName)
55import Test.Tasty (TestTree, testGroup)
56import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, assertEqual, testCase, (@?=))
57import Text.Printf (printf)
58import UnitTests.NullaryConstructors (nullaryConstructors)
59import qualified Data.ByteString as S
60import qualified Data.ByteString.Base16.Lazy as LBase16
61import qualified Data.ByteString.Lazy.Char8 as L
62import qualified Data.HashSet as HashSet
63import qualified Data.HashMap.Lazy as HashMap
64import qualified Data.Text.Lazy as LT
65import qualified Data.Text.Lazy.Builder as TLB
66import qualified Data.Text.Lazy.Encoding as LT
67import qualified Data.Text.Lazy.Encoding as TLE
68import qualified Data.Vector as Vector
69import qualified ErrorMessages
70import qualified SerializationFormatSpec
72-- Asserts that we can use both modules at once in the test suite.
73import Data.Aeson.Parser.UnescapeFFI ()
74import Data.Aeson.Parser.UnescapePure ()
76tests :: TestTree
77tests = testGroup "unit" [
78 testGroup "SerializationFormatSpec" SerializationFormatSpec.tests
79 , testGroup "ErrorMessages" ErrorMessages.tests
80 , testGroup "camelCase" [
81 testCase "camelTo" $ roundTripCamel "aName"
82 , testCase "camelTo" $ roundTripCamel "another"
83 , testCase "camelTo" $ roundTripCamel "someOtherName"
84 , testCase "camelTo" $
85 assertEqual "" "camel_apicase" (camelTo '_' "CamelAPICase")
86 , testCase "camelTo2" $ roundTripCamel2 "aName"
87 , testCase "camelTo2" $ roundTripCamel2 "another"
88 , testCase "camelTo2" $ roundTripCamel2 "someOtherName"
89 , testCase "camelTo2" $
90 assertEqual "" "camel_api_case" (camelTo2 '_' "CamelAPICase")
91 ]
92 , testGroup "encoding" [
93 testCase "goodProducer" goodProducer
94 ]
95 , testGroup "utctime" [
96 testCase "good" utcTimeGood
97 , testCase "bad" utcTimeBad
98 ]
99 , testGroup "formatError" [
100 testCase "example 1" formatErrorExample
101 ]
102 , testGroup ".:, .:?, .:!" $ fmap (testCase "-") dotColonMark
103 , testGroup "Hashable laws" $ fmap (testCase "-") hashableLaws
104 , testGroup "Object construction" $ fmap (testCase "-") objectConstruction
105 , testGroup "Issue #351" $ fmap (testCase "-") issue351
106 , testGroup "Nullary constructors" $ fmap (testCase "-") nullaryConstructors
107 , testGroup "FromJSONKey" $ fmap (testCase "-") fromJSONKeyAssertions
108 , testCase "PR #455" pr455
109 , testCase "Unescape string (PR #477)" unescapeString
110 , testCase "Show Options" showOptions
111 , testGroup "SingleMaybeField" singleMaybeField
112 , testCase "withEmbeddedJSON" withEmbeddedJSONTest
113 , testCase "SingleFieldCon" singleFieldCon
114 , testGroup "Ordering of object keys" keyOrdering
115 , testCase "Ratio with denominator 0" ratioDenominator0
116 , testCase "Big scientific exponent" bigScientificExponent
117 , testCase "Big integer decoding" bigIntegerDecoding
118 , testCase "Big natural decading" bigNaturalDecoding
119 , testCase "Big integer key decoding" bigIntegerKeyDecoding
120 , testGroup "QQ.Simple"
121 [ testCase "example" $
122 assertEqual "" (object ["foo" .= True]) [aesonQQ| {"foo": true } |]
123 ]
124 ]
126roundTripCamel :: String -> Assertion
127roundTripCamel name = assertEqual "" name (camelFrom '_' $ camelTo '_' name)
129roundTripCamel2 :: String -> Assertion
130roundTripCamel2 name = assertEqual "" name (camelFrom '_' $ camelTo2 '_' name)
132camelFrom :: Char -> String -> String
133camelFrom c s = let (p:ps) = split c s
134 in concat $ p : map capitalize ps
135 where
136 split c' s' = map L.unpack $ L.split c' $ L.pack s'
137 capitalize t = toUpper (head t) : tail t
140data Wibble = Wibble {
141 wibbleString :: String
142 , wibbleInt :: Int
143 } deriving (Generic, Show, Eq)
145instance FromJSON Wibble
147instance ToJSON Wibble where
148 toJSON = genericToJSON defaultOptions
149 toEncoding = genericToEncoding defaultOptions
151-- Test that if we put a bomb in a data structure, but only demand
152-- part of it via lazy encoding, we do not unexpectedly fail.
153goodProducer :: Assertion
154goodProducer = assertEqual "partial encoding should not explode on undefined"
155 '{' (L.head (encode wibble))
156 where
157 wibble = Wibble {
158 wibbleString = replicate k 'a'
159 , wibbleInt = 1
160 }
161 k | arch32bit = 4047
162 | otherwise = 4030
163 arch32bit = (maxBound :: Int) == 2147483647
165-- Test decoding various UTC time formats
166--
167-- Note: the incomplete pattern matches for UTCTimes are completely
168-- intentional. The test expects these parses to succeed. If the
169-- pattern matches fails, there's a bug in either the test or in aeson
170-- and needs to be investigated.
171utcTimeGood :: Assertion
172utcTimeGood = do
173 let ts1 = "2015-01-01T12:13:00.00Z" :: LT.Text
174 let ts2 = "2015-01-01T12:13:00Z" :: LT.Text
175 -- 'T' between date and time is not required, can be space
176 let ts3 = "2015-01-03 12:13:00.00Z" :: LT.Text
177 let ts4 = "2015-01-03 12:13:00.125Z" :: LT.Text
178 let (Just (t1 :: UTCTime)) = parseWithAeson ts1
179 let (Just (t2 :: UTCTime)) = parseWithAeson ts2
180 let (Just (t3 :: UTCTime)) = parseWithAeson ts3
181 let (Just (t4 :: UTCTime)) = parseWithAeson ts4
182 assertEqual "utctime" (parseWithRead "%FT%T%QZ" ts1) t1
183 assertEqual "utctime" (parseWithRead "%FT%T%QZ" ts2) t2
184 assertEqual "utctime" (parseWithRead "%F %T%QZ" ts3) t3
185 assertEqual "utctime" (parseWithRead "%F %T%QZ" ts4) t4
186 -- Time zones. Both +HHMM and +HH:MM are allowed for timezone
187 -- offset, and MM may be omitted.
188 let ts5 = "2015-01-01T12:30:00.00+00" :: LT.Text
189 let ts6 = "2015-01-01T12:30:00.00+01:15" :: LT.Text
190 let ts7 = "2015-01-01T12:30:00.00-02" :: LT.Text
191 let ts8 = "2015-01-01T22:00:00.00-03" :: LT.Text
192 let ts9 = "2015-01-01T22:00:00.00-04:30" :: LT.Text
193 let (Just (t5 :: UTCTime)) = parseWithAeson ts5
194 let (Just (t6 :: UTCTime)) = parseWithAeson ts6
195 let (Just (t7 :: UTCTime)) = parseWithAeson ts7
196 let (Just (t8 :: UTCTime)) = parseWithAeson ts8
197 let (Just (t9 :: UTCTime)) = parseWithAeson ts9
198 assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-01T12:30:00.00Z") t5
199 assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-01T11:15:00.00Z") t6
200 assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-01T14:30:00Z") t7
201 -- ts8 wraps around to the next day in UTC
202 assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-02T01:00:00Z") t8
203 assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-02T02:30:00Z") t9
205 -- Seconds in Time can be omitted
206 let ts10 = "2015-01-03T12:13Z" :: LT.Text
207 let ts11 = "2015-01-03 12:13Z" :: LT.Text
208 let ts12 = "2015-01-01T12:30-02" :: LT.Text
209 let (Just (t10 :: UTCTime)) = parseWithAeson ts10
210 let (Just (t11 :: UTCTime)) = parseWithAeson ts11
211 let (Just (t12 :: UTCTime)) = parseWithAeson ts12
212 assertEqual "utctime" (parseWithRead "%FT%H:%MZ" ts10) t10
213 assertEqual "utctime" (parseWithRead "%F %H:%MZ" ts11) t11
214 assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-01T14:30:00Z") t12
216 -- leap seconds are included correctly
217 let ts13 = "2015-08-23T23:59:60.128+00" :: LT.Text
218 let (Just (t13 :: UTCTime)) = parseWithAeson ts13
219 assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-08-23T23:59:60.128Z") t13
220 let ts14 = "2015-08-23T23:59:60.999999999999+00" :: LT.Text
221 let (Just (t14 :: UTCTime)) = parseWithAeson ts14
222 assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-08-23T23:59:60.999999999999Z") t14
224 where
225 parseWithRead :: String -> LT.Text -> UTCTime
226 parseWithRead f s =
227 fromMaybe (error "parseTime input malformed") . parseTimeM True defaultTimeLocale f . LT.unpack $ s
228 parseWithAeson :: LT.Text -> Maybe UTCTime
229 parseWithAeson s = decode . LT.encodeUtf8 $ LT.concat ["\"", s, "\""]
231-- Test that a few non-timezone qualified timestamp formats get
232-- rejected if decoding to UTCTime.
233utcTimeBad :: Assertion
234utcTimeBad = do
235 verifyFailParse "2000-01-01T12:13:00" -- missing Zulu time not allowed (some TZ required)
236 verifyFailParse "2000-01-01 12:13:00" -- missing Zulu time not allowed (some TZ required)
237 verifyFailParse "2000-01-01" -- date only not OK
238 verifyFailParse "2000-01-01Z" -- date only not OK
239 verifyFailParse "2015-01-01T12:30:00.00+00Z" -- no Zulu if offset given
240 verifyFailParse "2015-01-01T12:30:00.00+00:00Z" -- no Zulu if offset given
241 verifyFailParse "2015-01-03 12:13:00.Z" -- decimal at the end but no digits
242 verifyFailParse "2015-01-03 12:13.000Z" -- decimal at the end, but no seconds
243 verifyFailParse "2015-01-03 23:59:61Z" -- exceeds allowed seconds per day
244 where
245 verifyFailParse (s :: LT.Text) =
246 let (dec :: Maybe UTCTime) = decode . LT.encodeUtf8 $ LT.concat ["\"", s, "\""] in
247 assertEqual "verify failure" Nothing dec
249-- Non identifier keys should be escaped & enclosed in brackets
250formatErrorExample :: Assertion
251formatErrorExample =
252 let rhs = formatError [Index 0, Key "foo", Key "bar", Key "a.b.c", Key "", Key "'\\", Key "end"] "error msg"
253 lhs = "Error in $[0].foo.bar['a.b.c']['']['\\'\\\\'].end: error msg"
254 in assertEqual "formatError example" lhs rhs
256------------------------------------------------------------------------------
257-- Comparison (.:?) and (.:!)
258------------------------------------------------------------------------------
260newtype T1 = T1 (Maybe Int) deriving (Eq, Show)
261newtype T2 = T2 (Maybe Int) deriving (Eq, Show)
262newtype T3 = T3 (Maybe Int) deriving (Eq, Show)
264instance FromJSON T1 where parseJSON = fmap T1 . withObject "T1" (.: "value")
265instance FromJSON T2 where parseJSON = fmap T2 . withObject "T2" (.:? "value")
266instance FromJSON T3 where parseJSON = fmap T3 . withObject "T3" (.:! "value")
268dotColonMark :: [Assertion]
269dotColonMark = [
270 assertEqual ".: not-present" Nothing (decode ex1 :: Maybe T1)
271 , assertEqual ".: 42" (Just (T1 (Just 42))) (decode ex2 :: Maybe T1)
272 , assertEqual ".: null" (Just (T1 Nothing)) (decode ex3 :: Maybe T1)
274 , assertEqual ".:? not-present" (Just (T2 Nothing)) (decode ex1 :: Maybe T2)
275 , assertEqual ".:? 42" (Just (T2 (Just 42))) (decode ex2 :: Maybe T2)
276 , assertEqual ".:? null" (Just (T2 Nothing)) (decode ex3 :: Maybe T2)
278 , assertEqual ".:! not-present" (Just (T3 Nothing)) (decode ex1 :: Maybe T3)
279 , assertEqual ".:! 42" (Just (T3 (Just 42))) (decode ex2 :: Maybe T3)
280 , assertEqual ".:! null" Nothing (decode ex3 :: Maybe T3)
281 ]
282 where ex1 = "{}"
283 ex2 = "{\"value\": 42 }"
284 ex3 = "{\"value\": null }"
286------------------------------------------------------------------------------
287-- Check that the hashes of two equal Value are the same
288------------------------------------------------------------------------------
290hashableLaws :: [Assertion]
291hashableLaws = [
292 assertEqual "Hashable Object" (hash a) (hash b)
293 ]
294 where
295 a = object ["223" .= False, "807882556" .= True]
296 b = object ["807882556" .= True, "223" .= False]
298------------------------------------------------------------------------------
299-- Check that an alternative way to construct objects works
300------------------------------------------------------------------------------
302objectConstruction :: [Assertion]
303objectConstruction = [
304 assertEqual "Equal objects constructed differently" recommended notRecommended
305 ]
306 where
307 recommended = object ["foo" .= True, "bar" .= (-1 :: Int)]
308 notRecommended = Object (mconcat ["foo" .= True, "bar" .= (-1 :: Int)])
310-------------------------------------------------------------------------------
311-- ToJSONKey
312-------------------------------------------------------------------------------
314newtype MyText = MyText Text
315 deriving (FromJSONKey)
317newtype MyText' = MyText' Text
319instance FromJSONKey MyText' where
320 fromJSONKey = fmap MyText' fromJSONKey
321 fromJSONKeyList = error "not used"
323fromJSONKeyAssertions :: [Assertion]
324fromJSONKeyAssertions =
325 [ assertIsCoerce "Text" (fromJSONKey :: FromJSONKeyFunction Text)
326 , assertIsCoerce "Tagged Int Text" (fromJSONKey :: FromJSONKeyFunction (Tagged Int Text))
327 , assertIsCoerce "MyText" (fromJSONKey :: FromJSONKeyFunction MyText)
329#if __GLASGOW_HASKELL__ >= 710
330 , assertIsCoerce' "MyText'" (fromJSONKey :: FromJSONKeyFunction MyText')
331#endif
332 ]
333 where
334 assertIsCoerce _ (FromJSONKeyCoerce _) = pure ()
335 assertIsCoerce n _ = assertFailure n
337#if __GLASGOW_HASKELL__ >= 710
338 assertIsCoerce' _ (FromJSONKeyCoerce _) = pure ()
339 assertIsCoerce' n _ = pickWithRules (assertFailure n) (pure ())
341-- | Pick the first when RULES are enabled, e.g. optimisations are on
342pickWithRules
343 :: a -- ^ Pick this when RULES are on
344 -> a -- ^ use this otherwise
345 -> a
346pickWithRules _ = id
347{-# NOINLINE pickWithRules #-}
348{-# RULES "pickWithRules/rule" [0] forall x. pickWithRules x = const x #-}
349#endif
351------------------------------------------------------------------------------
352-- Regressions
353------------------------------------------------------------------------------
355-- A regression test for: https://github.com/bos/aeson/issues/351
356overlappingRegression :: FromJSON a => L.ByteString -> [a]
357overlappingRegression bs = fromMaybe [] $ decode bs
359issue351 :: [Assertion]
360issue351 = [
361 assertEqual "Int" ([1, 2, 3] :: [Int]) $ overlappingRegression "[1, 2, 3]"
362 , assertEqual "Char" ("abc" :: String) $ overlappingRegression "\"abc\""
363 , assertEqual "Char" ("" :: String) $ overlappingRegression "[\"a\", \"b\", \"c\"]"
364 ]
366------------------------------------------------------------------------------
367-- Comparison between bytestring and text encoders
368------------------------------------------------------------------------------
370ioTests :: IO [TestTree]
371ioTests = do
372 enc <- encoderComparisonTests
373 js <- jsonTestSuite
374 return [enc, js]
376encoderComparisonTests :: IO TestTree
377encoderComparisonTests = do
378 encoderTests <- forM testFiles $ \file0 -> do
379 let file = "benchmarks/json-data/" ++ file0
380 return $ testCase file $ do
381 inp <- L.readFile file
382 case eitherDecode inp of
383 Left err -> assertFailure $ "Decoding failure: " ++ err
384 Right val -> assertEqual "" (encode val) (encodeViaText val)
385 return $ testGroup "encoders" encoderTests
386 where
387 encodeViaText :: Value -> L.ByteString
388 encodeViaText =
389 TLE.encodeUtf8 . TLB.toLazyText . encodeToTextBuilder . toJSON
391 testFiles =
392 [ "example.json"
393 , "integers.json"
394 , "jp100.json"
395 , "numbers.json"
396 , "twitter10.json"
397 , "twitter20.json"
398 , "geometry.json"
399 , "jp10.json"
400 , "jp50.json"
401 , "twitter1.json"
402 , "twitter100.json"
403 , "twitter50.json"
404 ]
406-- A regression test for: https://github.com/bos/aeson/issues/293
407data MyRecord = MyRecord {_field1 :: Maybe Int, _field2 :: Maybe Bool}
409data MyRecord2 = MyRecord2 {_field3 :: Maybe Int, _field4 :: Maybe Bool}
410 deriving Generic
412instance ToJSON MyRecord2
413instance FromJSON MyRecord2
415-- A regression test for: https://github.com/bos/aeson/pull/477
416unescapeString :: Assertion
417unescapeString = do
418 assertEqual "Basic escaping"
419 (Right ("\" / \\ \b \f \n \r \t" :: String))
420 (eitherDecode "\"\\\" \\/ \\\\ \\b \\f \\n \\r \\t\"")
422 forM_ [minBound .. maxBound :: Char] $ \ c ->
423 let s = LT.pack [c] in
424 assertEqual (printf "UTF-16 encoded '\\x%X'" c)
425 (Right s) (eitherDecode $ utf16Char s)
426 where
427 utf16Char = formatString . LBase16.encode . LT.encodeUtf16BE
428 formatString s
429 | L.length s == 4 = L.concat ["\"\\u", s, "\""]
430 | L.length s == 8 =
431 L.concat ["\"\\u", L.take 4 s, "\\u", L.drop 4 s, "\""]
432 | otherwise = error "unescapeString: can't happen"
434-- JSONTestSuite
436jsonTestSuiteTest :: FilePath -> TestTree
437jsonTestSuiteTest path = testCase fileName $ do
438 payload <- L.readFile path
439 let result = eitherDecode payload :: Either String Value
440 assertBool fileName $ case take 2 fileName of
441 "i_" -> isRight result
442 "n_" -> isLeft result
443 "y_" -> isRight result
444 _ -> isRight result -- test_transform tests have inconsistent names
445 where
446 fileName = takeFileName path
448-- Build a collection of tests based on the current contents of the
449-- JSONTestSuite test directories.
451jsonTestSuite :: IO TestTree
452jsonTestSuite = do
453 let suitePath = "tests/JSONTestSuite"
454 let suites = ["test_parsing", "test_transform"]
455 testPaths <- fmap (sort . concat) . forM suites $ \suite -> do
456 let dir = suitePath </> suite
457 entries <- getDirectoryContents dir
458 let ok name = takeExtension name == ".json" &&
459 not (name `HashSet.member` blacklist)
460 return . map (dir </>) . filter ok $ entries
461 return $ testGroup "JSONTestSuite" $ map jsonTestSuiteTest testPaths
463-- The set expected-to-be-failing JSONTestSuite tests.
464-- Not all of these failures are genuine bugs.
465-- Of those that are bugs, not all are worth fixing.
467blacklist :: HashSet.HashSet String
468-- blacklist = HashSet.empty
469blacklist = _blacklist
471_blacklist :: HashSet.HashSet String
472_blacklist = HashSet.fromList [
473 "i_object_key_lone_2nd_surrogate.json"
474 , "i_string_1st_surrogate_but_2nd_missing.json"
475 , "i_string_1st_valid_surrogate_2nd_invalid.json"
476 , "i_string_UTF-16LE_with_BOM.json"
477 , "i_string_UTF-16_invalid_lonely_surrogate.json"
478 , "i_string_UTF-16_invalid_surrogate.json"
479 , "i_string_UTF-8_invalid_sequence.json"
480 , "i_string_incomplete_surrogate_and_escape_valid.json"
481 , "i_string_incomplete_surrogate_pair.json"
482 , "i_string_incomplete_surrogates_escape_valid.json"
483 , "i_string_invalid_lonely_surrogate.json"
484 , "i_string_invalid_surrogate.json"
485 , "i_string_inverted_surrogates_U+1D11E.json"
486 , "i_string_lone_second_surrogate.json"
487 , "i_string_not_in_unicode_range.json"
488 , "i_string_truncated-utf-8.json"
489 , "i_structure_UTF-8_BOM_empty_object.json"
490 , "n_string_unescaped_crtl_char.json"
491 , "n_string_unescaped_newline.json"
492 , "n_string_unescaped_tab.json"
493 , "string_1_escaped_invalid_codepoint.json"
494 , "string_1_invalid_codepoint.json"
495 , "string_1_invalid_codepoints.json"
496 , "string_2_escaped_invalid_codepoints.json"
497 , "string_2_invalid_codepoints.json"
498 , "string_3_escaped_invalid_codepoints.json"
499 , "string_3_invalid_codepoints.json"
500 , "y_string_utf16BE_no_BOM.json"
501 , "y_string_utf16LE_no_BOM.json"
502 ]
504-- A regression test for: https://github.com/bos/aeson/pull/455
505data Foo a = FooNil | FooCons (Foo Int)
507pr455 :: Assertion
508pr455 = assertEqual "FooCons FooNil"
509 (toJSON foo) (liftToJSON undefined undefined foo)
510 where
511 foo :: Foo Int
512 foo = FooCons FooNil
514showOptions :: Assertion
515showOptions =
516 assertEqual
517 "Show Options"
518 ( "Options {"
519 ++ "fieldLabelModifier =~ \"exampleField\""
520 ++ ", constructorTagModifier =~ \"ExampleConstructor\""
521 ++ ", allNullaryToStringTag = True"
522 ++ ", omitNothingFields = False"
523 ++ ", sumEncoding = TaggedObject {tagFieldName = \"tag\", contentsFieldName = \"contents\"}"
524 ++ ", unwrapUnaryRecords = False"
525 ++ ", tagSingleConstructors = False"
526 ++ "}")
527 (show defaultOptions)
529newtype SingleMaybeField = SingleMaybeField { smf :: Maybe Int }
530 deriving (Eq, Show, Generic)
532singleMaybeField :: [TestTree]
533singleMaybeField = do
534 (gName, gToJSON, gToEncoding, gFromJSON) <-
535 [ ("generic", genericToJSON opts, genericToEncoding opts, parse (genericParseJSON opts))
536 , ("th", toJSON, toEncoding, fromJSON) ]
537 return $
538 testCase gName $ do
539 assertEqual "toJSON" Null (gToJSON v)
540 assertEqual "toEncoding" (toEncoding (gToJSON v)) (gToEncoding v)
541 assertEqual "fromJSON" (Success v) (gFromJSON Null)
542 where
543 v = SingleMaybeField Nothing
544 opts = defaultOptions{omitNothingFields=True,unwrapUnaryRecords=True}
547newtype EmbeddedJSONTest = EmbeddedJSONTest Int
548 deriving (Eq, Show)
550instance FromJSON EmbeddedJSONTest where
551 parseJSON =
552 withObject "Object" $ \o ->
553 EmbeddedJSONTest <$> (o .: "prop" >>= withEmbeddedJSON "Quoted Int" parseJSON)
555withEmbeddedJSONTest :: Assertion
556withEmbeddedJSONTest =
557 assertEqual "Unquote embedded JSON" (Right $ EmbeddedJSONTest 1) (eitherDecode "{\"prop\":\"1\"}")
559-- Regression test for https://github.com/bos/aeson/issues/627
560newtype SingleFieldCon = SingleFieldCon Int deriving (Eq, Show, Generic)
562instance FromJSON SingleFieldCon where
563 parseJSON = genericParseJSON defaultOptions{unwrapUnaryRecords=True}
564 -- This option should have no effect on this type
566singleFieldCon :: Assertion
567singleFieldCon =
568 assertEqual "fromJSON" (Right (SingleFieldCon 0)) (eitherDecode "0")
570testParser :: (Eq a, Show a)
571 => String -> Parser a -> S.ByteString -> Either String a -> TestTree
572testParser name json_ s expected =
573 testCase name (parseOnly json_ s @?= expected)
575keyOrdering :: [TestTree]
576keyOrdering =
577 [ testParser "json" json
578 "{\"k\":true,\"k\":false}" $
579 Right (Object (HashMap.fromList [("k", Bool True)]))
580 , testParser "jsonLast" jsonLast
581 "{\"k\":true,\"k\":false}" $
582 Right (Object (HashMap.fromList [("k", Bool False)]))
583 , testParser "jsonAccum" jsonAccum
584 "{\"k\":true,\"k\":false}" $
585 Right (Object (HashMap.fromList [("k", Array (Vector.fromList [Bool True, Bool False]))]))
586 , testParser "jsonNoDup" jsonNoDup
587 "{\"k\":true,\"k\":false}" $
588 Left "Failed reading: found duplicate key: \"k\""
590 , testParser "json'" json'
591 "{\"k\":true,\"k\":false}" $
592 Right (Object (HashMap.fromList [("k", Bool True)]))
593 , testParser "jsonLast'" jsonLast'
594 "{\"k\":true,\"k\":false}" $
595 Right (Object (HashMap.fromList [("k", Bool False)]))
596 , testParser "jsonAccum'" jsonAccum'
597 "{\"k\":true,\"k\":false}" $
598 Right (Object (HashMap.fromList [("k", Array (Vector.fromList [Bool True, Bool False]))]))
599 , testParser "jsonNoDup'" jsonNoDup'
600 "{\"k\":true,\"k\":false}" $
601 Left "Failed reading: found duplicate key: \"k\""
602 ]
604ratioDenominator0 :: Assertion
605ratioDenominator0 =
606 assertEqual "Ratio with denominator 0"
607 (Left "Error in $: Ratio denominator was 0")
608 (eitherDecode "{ \"numerator\": 1, \"denominator\": 0 }" :: Either String Rational)
610bigScientificExponent :: Assertion
611bigScientificExponent =
612 assertEqual "Encoding an integral scientific with a large exponent should normalize it"
613 "1.0e2000"
614 (encode (scientific 1 2000 :: Scientific))
616bigIntegerDecoding :: Assertion
617bigIntegerDecoding =
618 assertEqual "Decoding an Integer with a large exponent should fail"
619 (Left "Error in $: parsing Integer failed, found a number with exponent 2000, but it must not be greater than 1024")
620 ((eitherDecode :: L.ByteString -> Either String Integer) "1e2000")
622bigNaturalDecoding :: Assertion
623bigNaturalDecoding =
624 assertEqual "Decoding a Natural with a large exponent should fail"
625 (Left "Error in $: parsing Natural failed, found a number with exponent 2000, but it must not be greater than 1024")
626 ((eitherDecode :: L.ByteString -> Either String Natural) "1e2000")
628bigIntegerKeyDecoding :: Assertion
629bigIntegerKeyDecoding =
630 assertEqual "Decoding an Integer key with a large exponent should fail"
631 (Left "Error in $['1e2000']: parsing Integer failed, found a number with exponent 2000, but it must not be greater than 1024")
632 ((eitherDecode :: L.ByteString -> Either String (HashMap Integer Value)) "{ \"1e2000\": null }")
634bigNaturalKeyDecoding :: Assertion
635bigNaturalKeyDecoding =
636 assertEqual "Decoding an Integer key with a large exponent should fail"
637 (Left "Error in $['1e2000']: found a number with exponent 2000, but it must not be greater than 1024")
638 ((eitherDecode :: L.ByteString -> Either String (HashMap Natural Value)) "{ \"1e2000\": null }")
640deriveJSON defaultOptions{omitNothingFields=True} ''MyRecord
642deriveToJSON defaultOptions ''Foo
643deriveToJSON1 defaultOptions ''Foo
645deriveJSON defaultOptions{omitNothingFields=True,unwrapUnaryRecords=True} ''SingleMaybeField