git.iko.soy/typeable/aeson
on 1.1.0.0 help sign in
typeable/aeson/tests/UnitTests.hs
707 lines 31 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DeriveGeneric #-}
3{-# LANGUAGE GADTs #-}
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE TemplateHaskell #-}
8#if __GLASGOW_HASKELL__ >= 708
9{-# LANGUAGE DataKinds #-}
10#endif
12{-# OPTIONS_GHC -fno-warn-deprecations #-}
14module UnitTests
15 (
16 ioTests
17 , tests
18 ) where
20import Prelude ()
21import Prelude.Compat
23import Control.Applicative (Const(..))
24import Control.Monad (forM, forM_, unless)
25import Data.Aeson ((.=), (.:), (.:?), (.:!), FromJSON(..), FromJSONKeyFunction(..), FromJSONKey(..), ToJSON1(..), decode, eitherDecode, encode, genericParseJSON, genericToEncoding, genericToJSON, object, withObject)
26import Data.Aeson.Internal (JSONPathElement(..), formatError)
27import Data.Aeson.TH (deriveJSON, deriveToJSON, deriveToJSON1)
28import Data.Aeson.Text (encodeToTextBuilder)
29import Data.Aeson.Types (Options(..), SumEncoding(..), ToJSON(..), Value, camelTo, camelTo2, defaultOptions, omitNothingFields)
30import Data.Char (toUpper)
31import Data.Either.Compat (isLeft, isRight)
32import Data.Fixed (Pico)
33import Data.Functor.Compose (Compose(..))
34import Data.Functor.Identity (Identity(..))
35import Data.Functor.Product (Product(..))
36import Data.Functor.Sum (Sum(..))
37import Data.Hashable (hash)
38import Data.List (sort)
39import Data.List.NonEmpty (NonEmpty(..))
40import Data.Maybe (fromMaybe)
41import Data.Proxy (Proxy(..))
42import Data.Scientific (Scientific)
43import Data.Sequence (Seq)
44import Data.Tagged (Tagged(..))
45import Data.Text (Text)
46import Data.Time (UTCTime, fromGregorian)
47import Data.Time.Format (parseTime)
48import Data.Time.Locale.Compat (defaultTimeLocale)
49import Data.Word (Word8)
50import GHC.Generics (Generic)
51import Instances ()
52import System.Directory (doesDirectoryExist, getDirectoryContents)
53import System.Exit (exitWith, ExitCode(ExitFailure))
54import System.IO (hPutStrLn, stderr)
55import System.FilePath ((</>), takeExtension, takeFileName)
56import Test.Framework (Test, testGroup)
57import Test.Framework.Providers.HUnit (testCase)
58import Test.HUnit (Assertion, assertBool, assertFailure, assertEqual)
59import Text.Printf (printf)
60import Types (Approx(..), Compose3, Compose3', I)
61import UnitTests.NullaryConstructors (nullaryConstructors)
62import qualified Data.ByteString.Base16.Lazy as LBase16
63import qualified Data.ByteString.Lazy.Char8 as L
64import qualified Data.DList as DList
65import qualified Data.HashMap.Strict as HM
66import qualified Data.HashSet as HashSet
67import qualified Data.IntMap as IntMap
68import qualified Data.IntSet as IntSet
69import qualified Data.Map as M
70import qualified Data.Monoid as Monoid
71import qualified Data.Semigroup as Semigroup
72import qualified Data.Sequence as Seq
73import qualified Data.Set as Set
74import qualified Data.Text.Lazy as LT
75import qualified Data.Text.Lazy.Builder as TLB
76import qualified Data.Text.Lazy.Encoding as LT
77import qualified Data.Text.Lazy.Encoding as TLE
78import qualified Data.Tree as Tree
79import qualified Data.UUID.Types as UUID
80import qualified Data.Vector as Vector
82tests :: Test
83tests = testGroup "unit" [
84 testGroup "camelCase" [
85 testCase "camelTo" $ roundTripCamel "aName"
86 , testCase "camelTo" $ roundTripCamel "another"
87 , testCase "camelTo" $ roundTripCamel "someOtherName"
88 , testCase "camelTo" $
89 assertEqual "" "camel_apicase" (camelTo '_' "CamelAPICase")
90 , testCase "camelTo2" $ roundTripCamel2 "aName"
91 , testCase "camelTo2" $ roundTripCamel2 "another"
92 , testCase "camelTo2" $ roundTripCamel2 "someOtherName"
93 , testCase "camelTo2" $
94 assertEqual "" "camel_api_case" (camelTo2 '_' "CamelAPICase")
95 ]
96 , testGroup "encoding" [
97 testCase "goodProducer" $ goodProducer
98 ]
99 , testGroup "utctime" [
100 testCase "good" $ utcTimeGood
101 , testCase "bad" $ utcTimeBad
102 ]
103 , testGroup "formatError" [
104 testCase "example 1" $ formatErrorExample
105 ]
106 , testGroup ".:, .:?, .:!" $ fmap (testCase "-") dotColonMark
107 , testGroup "To JSON representation" $ fmap assertJsonEncodingExample jsonEncodingExamples
108 , testGroup "From JSON representation" $ fmap assertJsonExample jsonDecodingExamples
109 , testGroup "To/From JSON representation" $ fmap assertJsonExample jsonExamples
110 , testGroup "JSONPath" $ fmap (testCase "-") jsonPath
111 , testGroup "Hashable laws" $ fmap (testCase "-") hashableLaws
112 , testGroup "Issue #351" $ fmap (testCase "-") issue351
113 , testGroup "Nullary constructors" $ fmap (testCase "-") nullaryConstructors
114 , testGroup "FromJSONKey" $ fmap (testCase "-") fromJSONKeyAssertions
115 , testCase "PR #455" pr455
116 , testCase "Unescape string (PR #477)" unescapeString
117 ]
119roundTripCamel :: String -> Assertion
120roundTripCamel name = assertEqual "" name (camelFrom '_' $ camelTo '_' name)
122roundTripCamel2 :: String -> Assertion
123roundTripCamel2 name = assertEqual "" name (camelFrom '_' $ camelTo2 '_' name)
125camelFrom :: Char -> String -> String
126camelFrom c s = let (p:ps) = split c s
127 in concat $ p : map capitalize ps
128 where
129 split c' s' = map L.unpack $ L.split c' $ L.pack s'
130 capitalize t = toUpper (head t) : tail t
133data MyEither a b = MyLeft a | MyRight b
134 deriving (Generic, Show, Eq)
136instance (ToJSON a, ToJSON b) => ToJSON (MyEither a b) where
137 toJSON = genericToJSON defaultOptions { sumEncoding = UntaggedValue }
138 toEncoding = genericToEncoding defaultOptions { sumEncoding = UntaggedValue }
140instance (FromJSON a, FromJSON b) => FromJSON (MyEither a b) where
141 parseJSON = genericParseJSON defaultOptions { sumEncoding = UntaggedValue }
144data Wibble = Wibble {
145 wibbleString :: String
146 , wibbleInt :: Int
147 } deriving (Generic, Show, Eq)
149instance FromJSON Wibble
151instance ToJSON Wibble where
152 toJSON = genericToJSON defaultOptions
153 toEncoding = genericToEncoding defaultOptions
155-- Test that if we put a bomb in a data structure, but only demand
156-- part of it via lazy encoding, we do not unexpectedly fail.
157goodProducer :: Assertion
158goodProducer = assertEqual "partial encoding should not explode on undefined"
159 '{' (L.head (encode wibble))
160 where
161 wibble = Wibble {
162 wibbleString = replicate k 'a'
163 , wibbleInt = 1
164 }
165 k | arch32bit = 4047
166 | otherwise = 4030
167 arch32bit = (maxBound :: Int) == 2147483647
169-- Test decoding various UTC time formats
170--
171-- Note: the incomplete pattern matches for UTCTimes are completely
172-- intentional. The test expects these parses to succeed. If the
173-- pattern matches fails, there's a bug in either the test or in aeson
174-- and needs to be investigated.
175utcTimeGood :: Assertion
176utcTimeGood = do
177 let ts1 = "2015-01-01T12:13:00.00Z" :: LT.Text
178 let ts2 = "2015-01-01T12:13:00Z" :: LT.Text
179 -- 'T' between date and time is not required, can be space
180 let ts3 = "2015-01-03 12:13:00.00Z" :: LT.Text
181 let ts4 = "2015-01-03 12:13:00.125Z" :: LT.Text
182 let (Just (t1 :: UTCTime)) = parseWithAeson ts1
183 let (Just (t2 :: UTCTime)) = parseWithAeson ts2
184 let (Just (t3 :: UTCTime)) = parseWithAeson ts3
185 let (Just (t4 :: UTCTime)) = parseWithAeson ts4
186 assertEqual "utctime" (parseWithRead "%FT%T%QZ" ts1) t1
187 assertEqual "utctime" (parseWithRead "%FT%T%QZ" ts2) t2
188 assertEqual "utctime" (parseWithRead "%F %T%QZ" ts3) t3
189 assertEqual "utctime" (parseWithRead "%F %T%QZ" ts4) t4
190 -- Time zones. Both +HHMM and +HH:MM are allowed for timezone
191 -- offset, and MM may be omitted.
192 let ts5 = "2015-01-01T12:30:00.00+00" :: LT.Text
193 let ts6 = "2015-01-01T12:30:00.00+01:15" :: LT.Text
194 let ts7 = "2015-01-01T12:30:00.00-02" :: LT.Text
195 let ts8 = "2015-01-01T22:00:00.00-03" :: LT.Text
196 let ts9 = "2015-01-01T22:00:00.00-04:30" :: LT.Text
197 let (Just (t5 :: UTCTime)) = parseWithAeson ts5
198 let (Just (t6 :: UTCTime)) = parseWithAeson ts6
199 let (Just (t7 :: UTCTime)) = parseWithAeson ts7
200 let (Just (t8 :: UTCTime)) = parseWithAeson ts8
201 let (Just (t9 :: UTCTime)) = parseWithAeson ts9
202 assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-01T12:30:00.00Z") t5
203 assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-01T11:15:00.00Z") t6
204 assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-01T14:30:00Z") t7
205 -- ts8 wraps around to the next day in UTC
206 assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-02T01:00:00Z") t8
207 assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-02T02:30:00Z") t9
209 -- Seconds in Time can be omitted
210 let ts10 = "2015-01-03T12:13Z" :: LT.Text
211 let ts11 = "2015-01-03 12:13Z" :: LT.Text
212 let ts12 = "2015-01-01T12:30-02" :: LT.Text
213 let (Just (t10 :: UTCTime)) = parseWithAeson ts10
214 let (Just (t11 :: UTCTime)) = parseWithAeson ts11
215 let (Just (t12 :: UTCTime)) = parseWithAeson ts12
216 assertEqual "utctime" (parseWithRead "%FT%H:%MZ" ts10) t10
217 assertEqual "utctime" (parseWithRead "%F %H:%MZ" ts11) t11
218 assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-01T14:30:00Z") t12
220 where
221 parseWithRead :: String -> LT.Text -> UTCTime
222 parseWithRead f s =
223 case parseTime defaultTimeLocale f . LT.unpack $ s of
224 Nothing -> error "parseTime input malformed"
225 Just t -> t
226 parseWithAeson :: LT.Text -> Maybe UTCTime
227 parseWithAeson s = decode . LT.encodeUtf8 $ (LT.concat ["\"", s, "\""])
229-- Test that a few non-timezone qualified timestamp formats get
230-- rejected if decoding to UTCTime.
231utcTimeBad :: Assertion
232utcTimeBad = do
233 verifyFailParse "2000-01-01T12:13:00" -- missing Zulu time not allowed (some TZ required)
234 verifyFailParse "2000-01-01 12:13:00" -- missing Zulu time not allowed (some TZ required)
235 verifyFailParse "2000-01-01" -- date only not OK
236 verifyFailParse "2000-01-01Z" -- date only not OK
237 verifyFailParse "2015-01-01T12:30:00.00+00Z" -- no Zulu if offset given
238 verifyFailParse "2015-01-01T12:30:00.00+00:00Z" -- no Zulu if offset given
239 verifyFailParse "2015-01-03 12:13:00.Z" -- decimal at the end but no digits
240 verifyFailParse "2015-01-03 12:13.000Z" -- decimal at the end, but no seconds
241 where
242 verifyFailParse (s :: LT.Text) =
243 let (dec :: Maybe UTCTime) = decode . LT.encodeUtf8 $ (LT.concat ["\"", s, "\""]) in
244 assertEqual "verify failure" Nothing dec
246-- Non identifier keys should be escaped & enclosed in brackets
247formatErrorExample :: Assertion
248formatErrorExample =
249 let rhs = formatError [Index 0, Key "foo", Key "bar", Key "a.b.c", Key "", Key "'\\", Key "end"] "error msg"
250 lhs = "Error in $[0].foo.bar['a.b.c']['']['\\'\\\\'].end: error msg"
251 in assertEqual "formatError example" lhs rhs
253------------------------------------------------------------------------------
254-- Comparison (.:?) and (.:!)
255------------------------------------------------------------------------------
257newtype T1 = T1 (Maybe Int) deriving (Eq, Show)
258newtype T2 = T2 (Maybe Int) deriving (Eq, Show)
259newtype T3 = T3 (Maybe Int) deriving (Eq, Show)
261instance FromJSON T1 where parseJSON = fmap T1 . withObject "T1" (.: "value")
262instance FromJSON T2 where parseJSON = fmap T2 . withObject "T2" (.:? "value")
263instance FromJSON T3 where parseJSON = fmap T3 . withObject "T3" (.:! "value")
265dotColonMark :: [Assertion]
266dotColonMark = [
267 assertEqual ".: not-present" Nothing (decode ex1 :: Maybe T1)
268 , assertEqual ".: 42" (Just (T1 (Just 42))) (decode ex2 :: Maybe T1)
269 , assertEqual ".: null" (Just (T1 Nothing)) (decode ex3 :: Maybe T1)
271 , assertEqual ".:? not-present" (Just (T2 (Nothing))) (decode ex1 :: Maybe T2)
272 , assertEqual ".:? 42" (Just (T2 (Just 42))) (decode ex2 :: Maybe T2)
273 , assertEqual ".:? null" (Just (T2 Nothing)) (decode ex3 :: Maybe T2)
275 , assertEqual ".:! not-present" (Just (T3 (Nothing))) (decode ex1 :: Maybe T3)
276 , assertEqual ".:! 42" (Just (T3 (Just 42))) (decode ex2 :: Maybe T3)
277 , assertEqual ".:! null" Nothing (decode ex3 :: Maybe T3)
278 ]
279 where ex1 = "{}"
280 ex2 = "{\"value\": 42 }"
281 ex3 = "{\"value\": null }"
283------------------------------------------------------------------------------
284-- These tests assert that the JSON serialization doesn't change by accident.
285-----------------------------------------------------------------------------
287data Example where
288 Example
289 :: (Eq a, Show a, ToJSON a, FromJSON a)
290 => String -> L.ByteString -> a -> Example
291 MaybeExample
292 :: (Eq a, Show a, FromJSON a)
293 => String -> L.ByteString -> Maybe a -> Example
295assertJsonExample :: Example -> Test
296assertJsonExample (Example name bs val) = testCase name $ do
297 assertEqual "encode" bs (encode val)
298 assertEqual "encode/via value" bs (encode $ toJSON val)
299 assertEqual "decode" (Just val) (decode bs)
300assertJsonExample (MaybeExample name bs mval) = testCase name $
301 assertEqual "decode" mval (decode bs)
303assertJsonEncodingExample :: Example -> Test
304assertJsonEncodingExample (Example name bs val) = testCase name $ do
305 assertEqual "encode" bs (encode val)
306 assertEqual "encode/via value" bs (encode $ toJSON val)
307assertJsonEncodingExample (MaybeExample name _ _) = testCase name $
308 assertFailure "cannot encode MaybeExample"
310jsonEncodingExamples :: [Example]
311jsonEncodingExamples =
312 [
313 -- Maybe serialising is lossy
314 -- https://github.com/bos/aeson/issues/376
315 Example "Just Nothing" "null" (Just Nothing :: Maybe (Maybe Int))
316 -- infinities cannot be recovered, null is decoded as NaN
317 , Example "inf :: Double" "null" (Approx $ 1/0 :: Approx Double)
318 ]
320jsonDecodingExamples :: [Example]
321jsonDecodingExamples = [
322 -- Maybe serialising is lossy
323 -- https://github.com/bos/aeson/issues/376
324 MaybeExample "Nothing" "null" (Just $ Nothing :: Maybe (Maybe Int))
325 , MaybeExample "Just" "1" (Just $ Just 1 :: Maybe (Maybe Int))
326 , MaybeExample "Just Nothing" "null" (Just $ Nothing :: Maybe (Maybe (Maybe Int)))
327 -- Integral values are truncated, and overflowed
328 -- https://github.com/bos/aeson/issues/317
329 , MaybeExample "Word8 3" "3" (Just 3 :: Maybe Word8)
330 , MaybeExample "Word8 3.00" "3.00" (Just 3 :: Maybe Word8)
331 , MaybeExample "Word8 3.14" "3.14" (Nothing :: Maybe Word8)
332 , MaybeExample "Word8 -1" "-1" (Nothing :: Maybe Word8)
333 , MaybeExample "Word8 300" "300" (Nothing :: Maybe Word8)
334 -- Negative zero year, encoding never produces such:
335 , MaybeExample "Day -0000-02-03" "\"-0000-02-03\"" (Just (fromGregorian 0 2 3))
336 ]
338jsonExamples :: [Example]
339jsonExamples =
340 [
341 Example "Either Left" "{\"Left\":1}" (Left 1 :: Either Int Int)
342 , Example "Either Right" "{\"Right\":1}" (Right 1 :: Either Int Int)
343 , Example "Nothing" "null" (Nothing :: Maybe Int)
344 , Example "Just" "1" (Just 1 :: Maybe Int)
345 , Example "Proxy Int" "null" (Proxy :: Proxy Int)
346 , Example "Tagged Char Int" "1" (Tagged 1 :: Tagged Char Int)
347#if __GLASGOW_HASKELL__ >= 708
348 -- Test Tagged instance is polykinded
349 , Example "Tagged 123 Int" "1" (Tagged 1 :: Tagged 123 Int)
350#endif
351 , Example "Const Char Int" "\"c\"" (Const 'c' :: Const Char Int)
352 , Example "Tuple" "[1,2]" ((1, 2) :: (Int, Int))
353 , Example "NonEmpty" "[1,2,3]" (1 :| [2, 3] :: NonEmpty Int)
354 , Example "Seq" "[1,2,3]" (Seq.fromList [1, 2, 3] :: Seq.Seq Int)
355 , Example "DList" "[1,2,3]" (DList.fromList [1, 2, 3] :: DList.DList Int)
356 , Example "()" "[]" ()
358 , Example "HashMap Int Int" "{\"0\":1,\"2\":3}" (HM.fromList [(0,1),(2,3)] :: HM.HashMap Int Int)
359 , Example "Map Int Int" "{\"0\":1,\"2\":3}" (M.fromList [(0,1),(2,3)] :: M.Map Int Int)
360 , Example "Map (Tagged Int Int) Int" "{\"0\":1,\"2\":3}" (M.fromList [(Tagged 0,1),(Tagged 2,3)] :: M.Map (Tagged Int Int) Int)
361 , Example "Map [Int] Int" "[[[0],1],[[2],3]]" (M.fromList [([0],1),([2],3)] :: M.Map [Int] Int)
362 , Example "Map [Char] Int" "{\"ab\":1,\"cd\":3}" (M.fromList [("ab",1),("cd",3)] :: M.Map [Char] Int)
363 , Example "Map [I Char] Int" "{\"ab\":1,\"cd\":3}" (M.fromList [(map pure "ab",1),(map pure "cd",3)] :: M.Map [I Char] Int)
365 , Example "nan :: Double" "null" (Approx $ 0/0 :: Approx Double)
367 , Example "Ordering LT" "\"LT\"" LT
368 , Example "Ordering EQ" "\"EQ\"" EQ
369 , Example "Ordering GT" "\"GT\"" GT
371 , Example "Float" "3.14" (3.14 :: Float)
372 , Example "Pico" "3.14" (3.14 :: Pico)
373 , Example "Scientific" "3.14" (3.14 :: Scientific)
375 , Example "UUID" "\"c2cc10e1-57d6-4b6f-9899-38d972112d8c\"" $ UUID.fromWords
376 0xc2cc10e1 0x57d64b6f 0x989938d9 0x72112d8c
378 , Example "Set Int" "[1,2,3]" (Set.fromList [3, 2, 1] :: Set.Set Int)
379 , Example "IntSet" "[1,2,3]" (IntSet.fromList [3, 2, 1])
380 , Example "IntMap" "[[1,2],[3,4]]" (IntMap.fromList [(3,4), (1,2)] :: IntMap.IntMap Int)
381 , Example "Vector" "[1,2,3]" (Vector.fromList [1, 2, 3] :: Vector.Vector Int)
382 , Example "HashSet Int" "[1,2,3]" (HashSet.fromList [3, 2, 1] :: HashSet.HashSet Int)
383 , Example "Tree Int" "[1,[[2,[[3,[]],[4,[]]]],[5,[]]]]" (let n = Tree.Node in n 1 [n 2 [n 3 [], n 4 []], n 5 []] :: Tree.Tree Int)
385 -- Three separate cases, as ordering in HashMap is not defined
386 , Example "HashMap Float Int, NaN" "{\"NaN\":1}" (Approx $ HM.singleton (0/0) 1 :: Approx (HM.HashMap Float Int))
387 , Example "HashMap Float Int, Infinity" "{\"Infinity\":1}" (HM.singleton (1/0) 1 :: HM.HashMap Float Int)
388 , Example "HashMap Float Int, +Infinity" "{\"-Infinity\":1}" (HM.singleton (negate 1/0) 1 :: HM.HashMap Float Int)
390 -- Functors
391 , Example "Identity Int" "1" (pure 1 :: Identity Int)
393 , Example "Identity Char" "\"x\"" (pure 'x' :: Identity Char)
394 , Example "Identity String" "\"foo\"" (pure "foo" :: Identity String)
395 , Example "[Identity Char]" "\"xy\"" ([pure 'x', pure 'y'] :: [Identity Char])
397 , Example "Maybe Char" "\"x\"" (pure 'x' :: Maybe Char)
398 , Example "Maybe String" "\"foo\"" (pure "foo" :: Maybe String)
399 , Example "Maybe [Identity Char]" "\"xy\"" (pure [pure 'x', pure 'y'] :: Maybe [Identity Char])
401 , Example "Day; year >= 1000" "\"1999-10-12\"" (fromGregorian 1999 10 12)
402 , Example "Day; year > 0 && < 1000" "\"0500-03-04\"" (fromGregorian 500 3 4)
403 , Example "Day; year == 0" "\"0000-02-20\"" (fromGregorian 0 2 20)
404 , Example "Day; year < 0" "\"-0234-01-01\"" (fromGregorian (-234) 1 1)
405 , Example "Day; year < -1000" "\"-1234-01-01\"" (fromGregorian (-1234) 1 1)
407 , Example "Product I Maybe Int" "[1,2]" (Pair (pure 1) (pure 2) :: Product I Maybe Int)
408 , Example "Product I Maybe Int" "[1,null]" (Pair (pure 1) Nothing :: Product I Maybe Int)
409 , Example "Product I [] Char" "[\"a\",\"foo\"]" (Pair (pure 'a') "foo" :: Product I [] Char)
411 , Example "Sum I [] Int: InL" "{\"InL\":1}" (InL (pure 1) :: Sum I [] Int)
412 , Example "Sum I [] Int: InR" "{\"InR\":[1,2]}" (InR [1, 2] :: Sum I [] Int)
413 , Example "Sum I [] Char: InR" "{\"InR\":\"foo\"}" (InR "foo" :: Sum I [] Char)
415 , Example "Compose I I Int" "1" (pure 1 :: Compose I I Int)
416 , Example "Compose I [] Int" "[1]" (pure 1 :: Compose I [] Int)
417 , Example "Compose [] I Int" "[1]" (pure 1 :: Compose [] I Int)
418 , Example "Compose [] [] Int" "[[1]]" (pure 1 :: Compose [] [] Int)
420 , Example "Compose I I Char" "\"x\"" (pure 'x' :: Compose I I Char)
421 , Example "Compose I [] Char" "\"x\"" (pure 'x' :: Compose I [] Char)
422 , Example "Compose [] I Char" "\"x\"" (pure 'x' :: Compose [] I Char)
423 , Example "Compose [] [] Char" "[\"x\"]" (pure 'x' :: Compose [] [] Char)
425 , Example "Compose3 I I I Char" "\"x\"" (pure 'x' :: Compose3 I I I Char)
426 , Example "Compose3 I I [] Char" "\"x\"" (pure 'x' :: Compose3 I I [] Char)
427 , Example "Compose3 I [] I Char" "\"x\"" (pure 'x' :: Compose3 I [] I Char)
428 , Example "Compose3 I [] [] Char" "[\"x\"]" (pure 'x' :: Compose3 I [] [] Char)
429 , Example "Compose3 [] I I Char" "\"x\"" (pure 'x' :: Compose3 [] I I Char)
430 , Example "Compose3 [] I [] Char" "[\"x\"]" (pure 'x' :: Compose3 [] I [] Char)
431 , Example "Compose3 [] [] I Char" "[\"x\"]" (pure 'x' :: Compose3 [] [] I Char)
432 , Example "Compose3 [] [] [] Char" "[[\"x\"]]" (pure 'x' :: Compose3 [] [] [] Char)
434 , Example "Compose3' I I I Char" "\"x\"" (pure 'x' :: Compose3' I I I Char)
435 , Example "Compose3' I I [] Char" "\"x\"" (pure 'x' :: Compose3' I I [] Char)
436 , Example "Compose3' I [] I Char" "\"x\"" (pure 'x' :: Compose3' I [] I Char)
437 , Example "Compose3' I [] [] Char" "[\"x\"]" (pure 'x' :: Compose3' I [] [] Char)
438 , Example "Compose3' [] I I Char" "\"x\"" (pure 'x' :: Compose3' [] I I Char)
439 , Example "Compose3' [] I [] Char" "[\"x\"]" (pure 'x' :: Compose3' [] I [] Char)
440 , Example "Compose3' [] [] I Char" "[\"x\"]" (pure 'x' :: Compose3' [] [] I Char)
441 , Example "Compose3' [] [] [] Char" "[[\"x\"]]" (pure 'x' :: Compose3' [] [] [] Char)
443 , Example "MyEither Int String: Left" "42" (MyLeft 42 :: MyEither Int String)
444 , Example "MyEither Int String: Right" "\"foo\"" (MyRight "foo" :: MyEither Int String)
446 -- newtypes from Monoid/Semigroup
447 , Example "Monoid.Dual Int" "2" (pure 2 :: Monoid.Dual Int)
448 , Example "Monoid.First Int" "2" (pure 2 :: Monoid.First Int)
449 , Example "Monoid.Last Int" "2" (pure 2 :: Monoid.Last Int)
450 , Example "Semigroup.Min Int" "2" (pure 2 :: Semigroup.Min Int)
451 , Example "Semigroup.Max Int" "2" (pure 2 :: Semigroup.Max Int)
452 , Example "Semigroup.First Int" "2" (pure 2 :: Semigroup.First Int)
453 , Example "Semigroup.Last Int" "2" (pure 2 :: Semigroup.Last Int)
454 , Example "Semigroup.WrappedMonoid Int" "2" (Semigroup.WrapMonoid 2 :: Semigroup.WrappedMonoid Int)
455 , Example "Semigroup.Option Just" "2" (pure 2 :: Semigroup.Option Int)
456 , Example "Semigroup.Option Nothing" "null" (Semigroup.Option (Nothing :: Maybe Bool))
457 ]
461------------------------------------------------------------------------------
462-- These tests check that JSONPath is tracked correctly
463-----------------------------------------------------------------------------
465jsonPath :: [Assertion]
466jsonPath = [
467 -- issue #356
468 assertEqual "Either"
469 (Left "Error in $[1].Left[1]: expected Bool, encountered Number")
470 (eitherDecode "[1,{\"Left\":[2,3]}]"
471 :: Either String (Int, Either (Int, Bool) ()))
472 -- issue #358
473 , assertEqual "Seq a"
474 (Left "Error in $[2]: expected Int, encountered Boolean")
475 (eitherDecode "[0,1,true]" :: Either String (Seq Int))
476 , assertEqual "Wibble"
477 (Left "Error in $.wibbleInt: expected Int, encountered Boolean")
478 (eitherDecode "{\"wibbleString\":\"\",\"wibbleInt\":true}"
479 :: Either String Wibble)
480 ]
482------------------------------------------------------------------------------
483-- Check that the hashes of two equal Value are the same
484------------------------------------------------------------------------------
486hashableLaws :: [Assertion]
487hashableLaws = [
488 assertEqual "Hashable Object" (hash a) (hash b)
489 ]
490 where
491 a = object ["223" .= False, "807882556" .= True]
492 b = object ["807882556" .= True, "223" .= False]
494-------------------------------------------------------------------------------
495-- ToJSONKey
496-------------------------------------------------------------------------------
498newtype MyText = MyText Text
499 deriving (FromJSONKey)
501newtype MyText' = MyText' Text
503instance FromJSONKey MyText' where
504 fromJSONKey = fmap MyText' fromJSONKey
505 fromJSONKeyList = error "not used"
507fromJSONKeyAssertions :: [Assertion]
508fromJSONKeyAssertions =
509 [ assertIsCoerce "Text" (fromJSONKey :: FromJSONKeyFunction Text)
510 , assertIsCoerce "Tagged Int Text" (fromJSONKey :: FromJSONKeyFunction (Tagged Int Text))
511 , assertIsCoerce "MyText" (fromJSONKey :: FromJSONKeyFunction MyText)
513#if __GLASGOW_HASKELL__ >= 710
514 , assertIsCoerce' "MyText'" (fromJSONKey :: FromJSONKeyFunction MyText')
515#endif
516 ]
517 where
518 assertIsCoerce _ (FromJSONKeyCoerce _) = pure ()
519 assertIsCoerce n _ = assertFailure n
521#if __GLASGOW_HASKELL__ >= 710
522 assertIsCoerce' _ (FromJSONKeyCoerce _) = pure ()
523 assertIsCoerce' n _ = pickWithRules (assertFailure n) (pure ())
525-- | Pick the first when RULES are enabled, e.g. optimisations are on
526pickWithRules
527 :: a -- ^ Pick this when RULES are on
528 -> a -- ^ use this otherwise
529 -> a
530pickWithRules _ = id
531{-# NOINLINE pickWithRules #-}
532{-# RULES "pickWithRules/rule" [0] forall x. pickWithRules x = const x #-}
533#endif
535------------------------------------------------------------------------------
536-- Regressions
537------------------------------------------------------------------------------
539-- A regression test for: https://github.com/bos/aeson/issues/351
540overlappingRegression :: FromJSON a => L.ByteString -> [a]
541overlappingRegression bs = fromMaybe [] $ decode bs
543issue351 :: [Assertion]
544issue351 = [
545 assertEqual "Int" ([1, 2, 3] :: [Int]) $ overlappingRegression "[1, 2, 3]"
546 , assertEqual "Char" ("abc" :: String) $ overlappingRegression "\"abc\""
547 , assertEqual "Char" ("" :: String) $ overlappingRegression "[\"a\", \"b\", \"c\"]"
548 ]
550------------------------------------------------------------------------------
551-- Comparison between bytestring and text encoders
552------------------------------------------------------------------------------
554ioTests :: IO [Test]
555ioTests = do
556 enc <- encoderComparisonTests
557 js <- jsonTestSuite
558 return [enc, js]
560encoderComparisonTests :: IO Test
561encoderComparisonTests = do
562 encoderTests <- forM testFiles $ \file0 -> do
563 let file = "benchmarks/json-data/" ++ file0
564 return $ testCase file $ do
565 inp <- L.readFile file
566 case eitherDecode inp of
567 Left err -> assertFailure $ "Decoding failure: " ++ err
568 Right val -> assertEqual "" (encode val) (encodeViaText val)
569 return $ testGroup "encoders" encoderTests
570 where
571 encodeViaText :: Value -> L.ByteString
572 encodeViaText =
573 TLE.encodeUtf8 . TLB.toLazyText . encodeToTextBuilder . toJSON
575 testFiles =
576 [ "example.json"
577 , "integers.json"
578 , "jp100.json"
579 , "numbers.json"
580 , "twitter10.json"
581 , "twitter20.json"
582 , "geometry.json"
583 , "jp10.json"
584 , "jp50.json"
585 , "twitter1.json"
586 , "twitter100.json"
587 , "twitter50.json"
588 ]
590-- A regression test for: https://github.com/bos/aeson/issues/293
591data MyRecord = MyRecord {_field1 :: Maybe Int, _field2 :: Maybe Bool}
593data MyRecord2 = MyRecord2 {_field3 :: Maybe Int, _field4 :: Maybe Bool}
594 deriving Generic
596instance ToJSON MyRecord2
597instance FromJSON MyRecord2
599-- A regression test for: https://github.com/bos/aeson/pull/477
600unescapeString :: Assertion
601unescapeString = do
602 assertEqual "Basic escaping"
603 (Right ("\" / \\ \b \f \n \r \t" :: String))
604 (eitherDecode "\"\\\" \\/ \\\\ \\b \\f \\n \\r \\t\"")
606 forM_ [minBound .. maxBound :: Char] $ \ c ->
607 let s = LT.pack [c] in
608 assertEqual (printf "UTF-16 encoded '\\x%X'" c)
609 (Right s) (eitherDecode $ utf16Char s)
610 where
611 utf16Char = formatString . LBase16.encode . LT.encodeUtf16BE
612 formatString s
613 | L.length s == 4 = L.concat ["\"\\u", s, "\""]
614 | L.length s == 8 =
615 L.concat ["\"\\u", L.take 4 s, "\\u", L.drop 4 s, "\""]
616 | otherwise = error "unescapeString: can't happen"
618-- JSONTestSuite
620jsonTestSuiteTest :: FilePath -> Test
621jsonTestSuiteTest path = testCase fileName $ do
622 payload <- L.readFile path
623 let result = eitherDecode payload :: Either String Value
624 assertBool fileName $ case take 2 fileName of
625 "i_" -> isRight result
626 "n_" -> isLeft result
627 "y_" -> isRight result
628 _ -> isRight result -- test_transform tests have inconsistent names
629 where
630 fileName = takeFileName path
632-- Build a collection of tests based on the current contents of the
633-- JSONTestSuite test directories.
635jsonTestSuite :: IO Test
636jsonTestSuite = do
637 let suitePath = "tests/JSONTestSuite"
638 exists <- doesDirectoryExist suitePath
639 unless exists $ do
640 hPutStrLn stderr $ "git clone https://github.com/nst/JSONTestSuite " ++
641 suitePath
642 exitWith (ExitFailure 1)
643 -- ignore test_transform for now
644 let suites = ["test_parsing", "test_transform"]
645 testPaths <- fmap (sort . concat) . forM suites $ \suite -> do
646 let dir = suitePath </> suite
647 entries <- getDirectoryContents dir
648 let ok name = takeExtension name == ".json" &&
649 not (name `HashSet.member` blacklist)
650 return . map (dir </>) . filter ok $ entries
651 return $ testGroup "JSONTestSuite" $ map jsonTestSuiteTest testPaths
653-- The set expected-to-be-failing JSONTestSuite tests.
654-- Not all of these failures are genuine bugs.
655-- Of those that are bugs, not all are worth fixing.
657blacklist :: HashSet.HashSet String
658-- blacklist = HashSet.empty
659blacklist = _blacklist
661_blacklist :: HashSet.HashSet String
662_blacklist = HashSet.fromList [
663 "i_object_key_lone_2nd_surrogate.json"
664 , "i_string_1st_surrogate_but_2nd_missing.json"
665 , "i_string_1st_valid_surrogate_2nd_invalid.json"
666 , "i_string_UTF-16LE_with_BOM.json"
667 , "i_string_UTF-16_invalid_lonely_surrogate.json"
668 , "i_string_UTF-16_invalid_surrogate.json"
669 , "i_string_UTF-8_invalid_sequence.json"
670 , "i_string_incomplete_surrogate_and_escape_valid.json"
671 , "i_string_incomplete_surrogate_pair.json"
672 , "i_string_incomplete_surrogates_escape_valid.json"
673 , "i_string_invalid_lonely_surrogate.json"
674 , "i_string_invalid_surrogate.json"
675 , "i_string_inverted_surrogates_U+1D11E.json"
676 , "i_string_lone_second_surrogate.json"
677 , "i_string_not_in_unicode_range.json"
678 , "i_string_truncated-utf-8.json"
679 , "i_structure_UTF-8_BOM_empty_object.json"
680 , "n_string_unescaped_crtl_char.json"
681 , "n_string_unescaped_newline.json"
682 , "n_string_unescaped_tab.json"
683 , "string_1_escaped_invalid_codepoint.json"
684 , "string_1_invalid_codepoint.json"
685 , "string_1_invalid_codepoints.json"
686 , "string_2_escaped_invalid_codepoints.json"
687 , "string_2_invalid_codepoints.json"
688 , "string_3_escaped_invalid_codepoints.json"
689 , "string_3_invalid_codepoints.json"
690 , "y_string_utf16BE_no_BOM.json"
691 , "y_string_utf16LE_no_BOM.json"
692 ]
694-- A regression test for: https://github.com/bos/aeson/pull/455
695data Foo a = FooNil | FooCons (Foo Int)
697pr455 :: Assertion
698pr455 = assertEqual "FooCons FooNil"
699 (toJSON foo) (liftToJSON undefined undefined foo)
700 where
701 foo :: Foo Int
702 foo = FooCons FooNil
704deriveJSON defaultOptions{omitNothingFields=True} ''MyRecord
706deriveToJSON defaultOptions ''Foo
707deriveToJSON1 defaultOptions ''Foo