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