dhodovsk / source-git / ghc-aeson

Forked from source-git/ghc-aeson 4 years ago
Clone

Blame tests/UnitTests.hs

Packit 9a2dfb
{-# LANGUAGE CPP #-}
Packit 9a2dfb
{-# LANGUAGE DeriveGeneric #-}
Packit 9a2dfb
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
Packit 9a2dfb
{-# LANGUAGE OverloadedStrings #-}
Packit 9a2dfb
{-# LANGUAGE ScopedTypeVariables #-}
Packit 9a2dfb
{-# LANGUAGE TemplateHaskell #-}
Packit 9a2dfb
Packit 9a2dfb
-- For Data.Aeson.Types.camelTo
Packit 9a2dfb
{-# OPTIONS_GHC -fno-warn-deprecations #-}
Packit 9a2dfb
Packit 9a2dfb
#if MIN_VERSION_base(4,9,0)
Packit 9a2dfb
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
Packit 9a2dfb
#endif
Packit 9a2dfb
Packit 9a2dfb
module UnitTests
Packit 9a2dfb
    (
Packit 9a2dfb
      ioTests
Packit 9a2dfb
    , tests
Packit 9a2dfb
    , withEmbeddedJSONTest
Packit 9a2dfb
    ) where
Packit 9a2dfb
Packit 9a2dfb
import Prelude ()
Packit 9a2dfb
import Prelude.Compat
Packit 9a2dfb
Packit 9a2dfb
import Control.Monad (forM, forM_)
Packit 9a2dfb
import Data.Aeson ((.=), (.:), (.:?), (.:!), FromJSON(..), FromJSONKeyFunction(..), FromJSONKey(..), ToJSON1(..), decode, eitherDecode, encode, fromJSON, genericParseJSON, genericToEncoding, genericToJSON, object, withObject, withEmbeddedJSON)
Packit 9a2dfb
import Data.Aeson.Internal (JSONPathElement(..), formatError)
Packit 9a2dfb
import Data.Aeson.TH (deriveJSON, deriveToJSON, deriveToJSON1)
Packit 9a2dfb
import Data.Aeson.Text (encodeToTextBuilder)
Packit 9a2dfb
import Data.Aeson.Types (Options(..), Result(Success), ToJSON(..), Value(Null), camelTo, camelTo2, defaultOptions, omitNothingFields, parse)
Packit 9a2dfb
import Data.Char (toUpper)
Packit 9a2dfb
import Data.Either.Compat (isLeft, isRight)
Packit 9a2dfb
import Data.Hashable (hash)
Packit 9a2dfb
import Data.List (sort)
Packit 9a2dfb
import Data.Maybe (fromMaybe)
Packit 9a2dfb
import Data.Sequence (Seq)
Packit 9a2dfb
import Data.Tagged (Tagged(..))
Packit 9a2dfb
import Data.Text (Text)
Packit 9a2dfb
import Data.Time (UTCTime)
Packit 9a2dfb
import Data.Time.Format (parseTime)
Packit 9a2dfb
import Data.Time.Locale.Compat (defaultTimeLocale)
Packit 9a2dfb
import GHC.Generics (Generic)
Packit 9a2dfb
import Instances ()
Packit 9a2dfb
import System.Directory (getDirectoryContents)
Packit 9a2dfb
import System.FilePath ((), takeExtension, takeFileName)
Packit 9a2dfb
import Test.Framework (Test, testGroup)
Packit 9a2dfb
import Test.Framework.Providers.HUnit (testCase)
Packit 9a2dfb
import Test.HUnit (Assertion, assertBool, assertFailure, assertEqual)
Packit 9a2dfb
import Text.Printf (printf)
Packit 9a2dfb
import UnitTests.NullaryConstructors (nullaryConstructors)
Packit 9a2dfb
import qualified Data.ByteString.Base16.Lazy as LBase16
Packit 9a2dfb
import qualified Data.ByteString.Lazy.Char8 as L
Packit 9a2dfb
import qualified Data.HashSet as HashSet
Packit 9a2dfb
import qualified Data.Text.Lazy as LT
Packit 9a2dfb
import qualified Data.Text.Lazy.Builder as TLB
Packit 9a2dfb
import qualified Data.Text.Lazy.Encoding as LT
Packit 9a2dfb
import qualified Data.Text.Lazy.Encoding as TLE
Packit 9a2dfb
import qualified ErrorMessages
Packit 9a2dfb
import qualified SerializationFormatSpec
Packit 9a2dfb
Packit 9a2dfb
-- Asserts that we can use both modules at once in the test suite.
Packit 9a2dfb
import Data.Aeson.Parser.UnescapeFFI ()
Packit 9a2dfb
import Data.Aeson.Parser.UnescapePure ()
Packit 9a2dfb
Packit 9a2dfb
tests :: Test
Packit 9a2dfb
tests = testGroup "unit" [
Packit 9a2dfb
    testGroup "SerializationFormatSpec" SerializationFormatSpec.tests
Packit 9a2dfb
  , testGroup "ErrorMessages" ErrorMessages.tests
Packit 9a2dfb
  , testGroup "camelCase" [
Packit 9a2dfb
      testCase "camelTo" $ roundTripCamel "aName"
Packit 9a2dfb
    , testCase "camelTo" $ roundTripCamel "another"
Packit 9a2dfb
    , testCase "camelTo" $ roundTripCamel "someOtherName"
Packit 9a2dfb
    , testCase "camelTo" $
Packit 9a2dfb
        assertEqual "" "camel_apicase" (camelTo '_' "CamelAPICase")
Packit 9a2dfb
    , testCase "camelTo2" $ roundTripCamel2 "aName"
Packit 9a2dfb
    , testCase "camelTo2" $ roundTripCamel2 "another"
Packit 9a2dfb
    , testCase "camelTo2" $ roundTripCamel2 "someOtherName"
Packit 9a2dfb
    , testCase "camelTo2" $
Packit 9a2dfb
        assertEqual "" "camel_api_case" (camelTo2 '_' "CamelAPICase")
Packit 9a2dfb
    ]
Packit 9a2dfb
  , testGroup "encoding" [
Packit 9a2dfb
      testCase "goodProducer" goodProducer
Packit 9a2dfb
    ]
Packit 9a2dfb
  , testGroup "utctime" [
Packit 9a2dfb
      testCase "good" utcTimeGood
Packit 9a2dfb
    , testCase "bad"  utcTimeBad
Packit 9a2dfb
    ]
Packit 9a2dfb
  , testGroup "formatError" [
Packit 9a2dfb
      testCase "example 1" formatErrorExample
Packit 9a2dfb
    ]
Packit 9a2dfb
  , testGroup ".:, .:?, .:!" $ fmap (testCase "-") dotColonMark
Packit 9a2dfb
  , testGroup "JSONPath" $ fmap (testCase "-") jsonPath
Packit 9a2dfb
  , testGroup "Hashable laws" $ fmap (testCase "-") hashableLaws
Packit 9a2dfb
  , testGroup "Issue #351" $ fmap (testCase "-") issue351
Packit 9a2dfb
  , testGroup "Nullary constructors" $ fmap (testCase "-") nullaryConstructors
Packit 9a2dfb
  , testGroup "FromJSONKey" $ fmap (testCase "-") fromJSONKeyAssertions
Packit 9a2dfb
  , testCase "PR #455" pr455
Packit 9a2dfb
  , testCase "Unescape string (PR #477)" unescapeString
Packit 9a2dfb
  , testCase "Show Options" showOptions
Packit 9a2dfb
  , testGroup "SingleMaybeField" singleMaybeField
Packit 9a2dfb
  , testCase "withEmbeddedJSON" withEmbeddedJSONTest
Packit 9a2dfb
  ]
Packit 9a2dfb
Packit 9a2dfb
roundTripCamel :: String -> Assertion
Packit 9a2dfb
roundTripCamel name = assertEqual "" name (camelFrom '_' $ camelTo '_' name)
Packit 9a2dfb
Packit 9a2dfb
roundTripCamel2 :: String -> Assertion
Packit 9a2dfb
roundTripCamel2 name = assertEqual "" name (camelFrom '_' $ camelTo2 '_' name)
Packit 9a2dfb
Packit 9a2dfb
camelFrom :: Char -> String -> String
Packit 9a2dfb
camelFrom c s = let (p:ps) = split c s
Packit 9a2dfb
                in concat $ p : map capitalize ps
Packit 9a2dfb
  where
Packit 9a2dfb
    split c' s' = map L.unpack $ L.split c' $ L.pack s'
Packit 9a2dfb
    capitalize t = toUpper (head t) : tail t
Packit 9a2dfb
Packit 9a2dfb
Packit 9a2dfb
data Wibble = Wibble {
Packit 9a2dfb
    wibbleString :: String
Packit 9a2dfb
  , wibbleInt :: Int
Packit 9a2dfb
  } deriving (Generic, Show, Eq)
Packit 9a2dfb
Packit 9a2dfb
instance FromJSON Wibble
Packit 9a2dfb
Packit 9a2dfb
instance ToJSON Wibble where
Packit 9a2dfb
    toJSON     = genericToJSON defaultOptions
Packit 9a2dfb
    toEncoding = genericToEncoding defaultOptions
Packit 9a2dfb
Packit 9a2dfb
-- Test that if we put a bomb in a data structure, but only demand
Packit 9a2dfb
-- part of it via lazy encoding, we do not unexpectedly fail.
Packit 9a2dfb
goodProducer :: Assertion
Packit 9a2dfb
goodProducer = assertEqual "partial encoding should not explode on undefined"
Packit 9a2dfb
                           '{' (L.head (encode wibble))
Packit 9a2dfb
  where
Packit 9a2dfb
    wibble = Wibble {
Packit 9a2dfb
                 wibbleString = replicate k 'a'
Packit 9a2dfb
               , wibbleInt = 1
Packit 9a2dfb
               }
Packit 9a2dfb
    k | arch32bit = 4047
Packit 9a2dfb
      | otherwise = 4030
Packit 9a2dfb
    arch32bit     = (maxBound :: Int) == 2147483647
Packit 9a2dfb
Packit 9a2dfb
-- Test decoding various UTC time formats
Packit 9a2dfb
--
Packit 9a2dfb
-- Note: the incomplete pattern matches for UTCTimes are completely
Packit 9a2dfb
-- intentional.  The test expects these parses to succeed.  If the
Packit 9a2dfb
-- pattern matches fails, there's a bug in either the test or in aeson
Packit 9a2dfb
-- and needs to be investigated.
Packit 9a2dfb
utcTimeGood :: Assertion
Packit 9a2dfb
utcTimeGood = do
Packit 9a2dfb
  let ts1 = "2015-01-01T12:13:00.00Z" :: LT.Text
Packit 9a2dfb
  let ts2 = "2015-01-01T12:13:00Z" :: LT.Text
Packit 9a2dfb
  -- 'T' between date and time is not required, can be space
Packit 9a2dfb
  let ts3 = "2015-01-03 12:13:00.00Z" :: LT.Text
Packit 9a2dfb
  let ts4 = "2015-01-03 12:13:00.125Z" :: LT.Text
Packit 9a2dfb
  let (Just (t1 ::  UTCTime)) = parseWithAeson ts1
Packit 9a2dfb
  let (Just (t2 ::  UTCTime)) = parseWithAeson ts2
Packit 9a2dfb
  let (Just (t3 ::  UTCTime)) = parseWithAeson ts3
Packit 9a2dfb
  let (Just (t4 ::  UTCTime)) = parseWithAeson ts4
Packit 9a2dfb
  assertEqual "utctime" (parseWithRead "%FT%T%QZ" ts1) t1
Packit 9a2dfb
  assertEqual "utctime" (parseWithRead "%FT%T%QZ" ts2) t2
Packit 9a2dfb
  assertEqual "utctime" (parseWithRead "%F %T%QZ" ts3) t3
Packit 9a2dfb
  assertEqual "utctime" (parseWithRead "%F %T%QZ" ts4) t4
Packit 9a2dfb
  -- Time zones.  Both +HHMM and +HH:MM are allowed for timezone
Packit 9a2dfb
  -- offset, and MM may be omitted.
Packit 9a2dfb
  let ts5 = "2015-01-01T12:30:00.00+00" :: LT.Text
Packit 9a2dfb
  let ts6 = "2015-01-01T12:30:00.00+01:15" :: LT.Text
Packit 9a2dfb
  let ts7 = "2015-01-01T12:30:00.00-02" :: LT.Text
Packit 9a2dfb
  let ts8 = "2015-01-01T22:00:00.00-03" :: LT.Text
Packit 9a2dfb
  let ts9 = "2015-01-01T22:00:00.00-04:30" :: LT.Text
Packit 9a2dfb
  let (Just (t5 ::  UTCTime)) = parseWithAeson ts5
Packit 9a2dfb
  let (Just (t6 ::  UTCTime)) = parseWithAeson ts6
Packit 9a2dfb
  let (Just (t7 ::  UTCTime)) = parseWithAeson ts7
Packit 9a2dfb
  let (Just (t8 ::  UTCTime)) = parseWithAeson ts8
Packit 9a2dfb
  let (Just (t9 ::  UTCTime)) = parseWithAeson ts9
Packit 9a2dfb
  assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-01T12:30:00.00Z") t5
Packit 9a2dfb
  assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-01T11:15:00.00Z") t6
Packit 9a2dfb
  assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-01T14:30:00Z") t7
Packit 9a2dfb
  -- ts8 wraps around to the next day in UTC
Packit 9a2dfb
  assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-02T01:00:00Z") t8
Packit 9a2dfb
  assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-02T02:30:00Z") t9
Packit 9a2dfb
Packit 9a2dfb
  -- Seconds in Time can be omitted
Packit 9a2dfb
  let ts10 = "2015-01-03T12:13Z" :: LT.Text
Packit 9a2dfb
  let ts11 = "2015-01-03 12:13Z" :: LT.Text
Packit 9a2dfb
  let ts12 = "2015-01-01T12:30-02" :: LT.Text
Packit 9a2dfb
  let (Just (t10 ::  UTCTime)) = parseWithAeson ts10
Packit 9a2dfb
  let (Just (t11 ::  UTCTime)) = parseWithAeson ts11
Packit 9a2dfb
  let (Just (t12 ::  UTCTime)) = parseWithAeson ts12
Packit 9a2dfb
  assertEqual "utctime" (parseWithRead "%FT%H:%MZ" ts10) t10
Packit 9a2dfb
  assertEqual "utctime" (parseWithRead "%F %H:%MZ" ts11) t11
Packit 9a2dfb
  assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-01T14:30:00Z") t12
Packit 9a2dfb
Packit 9a2dfb
  where
Packit 9a2dfb
    parseWithRead :: String -> LT.Text -> UTCTime
Packit 9a2dfb
    parseWithRead f s =
Packit 9a2dfb
      fromMaybe (error "parseTime input malformed") . parseTime defaultTimeLocale f . LT.unpack $ s
Packit 9a2dfb
    parseWithAeson :: LT.Text -> Maybe UTCTime
Packit 9a2dfb
    parseWithAeson s = decode . LT.encodeUtf8 $ LT.concat ["\"", s, "\""]
Packit 9a2dfb
Packit 9a2dfb
-- Test that a few non-timezone qualified timestamp formats get
Packit 9a2dfb
-- rejected if decoding to UTCTime.
Packit 9a2dfb
utcTimeBad :: Assertion
Packit 9a2dfb
utcTimeBad = do
Packit 9a2dfb
  verifyFailParse "2000-01-01T12:13:00" -- missing Zulu time not allowed (some TZ required)
Packit 9a2dfb
  verifyFailParse "2000-01-01 12:13:00" -- missing Zulu time not allowed (some TZ required)
Packit 9a2dfb
  verifyFailParse "2000-01-01"          -- date only not OK
Packit 9a2dfb
  verifyFailParse "2000-01-01Z"         -- date only not OK
Packit 9a2dfb
  verifyFailParse "2015-01-01T12:30:00.00+00Z" -- no Zulu if offset given
Packit 9a2dfb
  verifyFailParse "2015-01-01T12:30:00.00+00:00Z" -- no Zulu if offset given
Packit 9a2dfb
  verifyFailParse "2015-01-03 12:13:00.Z" -- decimal at the end but no digits
Packit 9a2dfb
  verifyFailParse "2015-01-03 12:13.000Z" -- decimal at the end, but no seconds
Packit 9a2dfb
  where
Packit 9a2dfb
    verifyFailParse (s :: LT.Text) =
Packit 9a2dfb
      let (dec :: Maybe UTCTime) = decode . LT.encodeUtf8 $ LT.concat ["\"", s, "\""] in
Packit 9a2dfb
      assertEqual "verify failure" Nothing dec
Packit 9a2dfb
Packit 9a2dfb
-- Non identifier keys should be escaped & enclosed in brackets
Packit 9a2dfb
formatErrorExample :: Assertion
Packit 9a2dfb
formatErrorExample =
Packit 9a2dfb
  let rhs = formatError [Index 0, Key "foo", Key "bar", Key "a.b.c", Key "", Key "'\\", Key "end"] "error msg"
Packit 9a2dfb
      lhs = "Error in $[0].foo.bar['a.b.c']['']['\\'\\\\'].end: error msg"
Packit 9a2dfb
  in assertEqual "formatError example" lhs rhs
Packit 9a2dfb
Packit 9a2dfb
------------------------------------------------------------------------------
Packit 9a2dfb
-- Comparison (.:?) and (.:!)
Packit 9a2dfb
------------------------------------------------------------------------------
Packit 9a2dfb
Packit 9a2dfb
newtype T1 = T1 (Maybe Int) deriving (Eq, Show)
Packit 9a2dfb
newtype T2 = T2 (Maybe Int) deriving (Eq, Show)
Packit 9a2dfb
newtype T3 = T3 (Maybe Int) deriving (Eq, Show)
Packit 9a2dfb
Packit 9a2dfb
instance FromJSON T1 where parseJSON = fmap T1 . withObject "T1" (.: "value")
Packit 9a2dfb
instance FromJSON T2 where parseJSON = fmap T2 . withObject "T2" (.:? "value")
Packit 9a2dfb
instance FromJSON T3 where parseJSON = fmap T3 . withObject "T3" (.:! "value")
Packit 9a2dfb
Packit 9a2dfb
dotColonMark :: [Assertion]
Packit 9a2dfb
dotColonMark = [
Packit 9a2dfb
    assertEqual ".:  not-present" Nothing               (decode ex1 :: Maybe T1)
Packit 9a2dfb
  , assertEqual ".:  42"          (Just (T1 (Just 42))) (decode ex2 :: Maybe T1)
Packit 9a2dfb
  , assertEqual ".:  null"        (Just (T1 Nothing))   (decode ex3 :: Maybe T1)
Packit 9a2dfb
Packit 9a2dfb
  , assertEqual ".:? not-present" (Just (T2 Nothing))   (decode ex1 :: Maybe T2)
Packit 9a2dfb
  , assertEqual ".:? 42"          (Just (T2 (Just 42))) (decode ex2 :: Maybe T2)
Packit 9a2dfb
  , assertEqual ".:? null"        (Just (T2 Nothing))   (decode ex3 :: Maybe T2)
Packit 9a2dfb
Packit 9a2dfb
  , assertEqual ".:! not-present" (Just (T3 Nothing))   (decode ex1 :: Maybe T3)
Packit 9a2dfb
  , assertEqual ".:! 42"          (Just (T3 (Just 42))) (decode ex2 :: Maybe T3)
Packit 9a2dfb
  , assertEqual ".:! null"        Nothing               (decode ex3 :: Maybe T3)
Packit 9a2dfb
  ]
Packit 9a2dfb
  where ex1 = "{}"
Packit 9a2dfb
        ex2 = "{\"value\": 42 }"
Packit 9a2dfb
        ex3 = "{\"value\": null }"
Packit 9a2dfb
Packit 9a2dfb
------------------------------------------------------------------------------
Packit 9a2dfb
-- These tests check that JSONPath is tracked correctly
Packit 9a2dfb
-----------------------------------------------------------------------------
Packit 9a2dfb
Packit 9a2dfb
jsonPath :: [Assertion]
Packit 9a2dfb
jsonPath = [
Packit 9a2dfb
    -- issue #356
Packit 9a2dfb
    assertEqual "Either"
Packit 9a2dfb
      (Left "Error in $[1].Left[1]: expected Bool, encountered Number")
Packit 9a2dfb
      (eitherDecode "[1,{\"Left\":[2,3]}]"
Packit 9a2dfb
         :: Either String (Int, Either (Int, Bool) ()))
Packit 9a2dfb
    -- issue #358
Packit 9a2dfb
  , assertEqual "Seq a"
Packit 9a2dfb
      (Left "Error in $[2]: expected Int, encountered Boolean")
Packit 9a2dfb
      (eitherDecode "[0,1,true]" :: Either String (Seq Int))
Packit 9a2dfb
  , assertEqual "Wibble"
Packit 9a2dfb
      (Left "Error in $.wibbleInt: expected Int, encountered Boolean")
Packit 9a2dfb
      (eitherDecode "{\"wibbleString\":\"\",\"wibbleInt\":true}"
Packit 9a2dfb
         :: Either String Wibble)
Packit 9a2dfb
  ]
Packit 9a2dfb
Packit 9a2dfb
------------------------------------------------------------------------------
Packit 9a2dfb
-- Check that the hashes of two equal Value are the same
Packit 9a2dfb
------------------------------------------------------------------------------
Packit 9a2dfb
Packit 9a2dfb
hashableLaws :: [Assertion]
Packit 9a2dfb
hashableLaws = [
Packit 9a2dfb
    assertEqual "Hashable Object" (hash a) (hash b)
Packit 9a2dfb
  ]
Packit 9a2dfb
  where
Packit 9a2dfb
  a = object ["223" .= False, "807882556" .= True]
Packit 9a2dfb
  b = object ["807882556" .= True, "223" .= False]
Packit 9a2dfb
Packit 9a2dfb
-------------------------------------------------------------------------------
Packit 9a2dfb
-- ToJSONKey
Packit 9a2dfb
-------------------------------------------------------------------------------
Packit 9a2dfb
Packit 9a2dfb
newtype MyText = MyText Text
Packit 9a2dfb
    deriving (FromJSONKey)
Packit 9a2dfb
Packit 9a2dfb
newtype MyText' = MyText' Text
Packit 9a2dfb
Packit 9a2dfb
instance FromJSONKey MyText' where
Packit 9a2dfb
    fromJSONKey = fmap MyText' fromJSONKey
Packit 9a2dfb
    fromJSONKeyList = error "not used"
Packit 9a2dfb
Packit 9a2dfb
fromJSONKeyAssertions :: [Assertion]
Packit 9a2dfb
fromJSONKeyAssertions =
Packit 9a2dfb
    [ assertIsCoerce  "Text"            (fromJSONKey :: FromJSONKeyFunction Text)
Packit 9a2dfb
    , assertIsCoerce  "Tagged Int Text" (fromJSONKey :: FromJSONKeyFunction (Tagged Int Text))
Packit 9a2dfb
    , assertIsCoerce  "MyText"          (fromJSONKey :: FromJSONKeyFunction MyText)
Packit 9a2dfb
Packit 9a2dfb
#if __GLASGOW_HASKELL__ >= 710
Packit 9a2dfb
    , assertIsCoerce' "MyText'"         (fromJSONKey :: FromJSONKeyFunction MyText')
Packit 9a2dfb
#endif
Packit 9a2dfb
    ]
Packit 9a2dfb
  where
Packit 9a2dfb
    assertIsCoerce _ (FromJSONKeyCoerce _) = pure ()
Packit 9a2dfb
    assertIsCoerce n _                     = assertFailure n
Packit 9a2dfb
Packit 9a2dfb
#if __GLASGOW_HASKELL__ >= 710
Packit 9a2dfb
    assertIsCoerce' _ (FromJSONKeyCoerce _) = pure ()
Packit 9a2dfb
    assertIsCoerce' n _                     = pickWithRules (assertFailure n) (pure ())
Packit 9a2dfb
Packit 9a2dfb
-- | Pick the first when RULES are enabled, e.g. optimisations are on
Packit 9a2dfb
pickWithRules
Packit 9a2dfb
    :: a -- ^ Pick this when RULES are on
Packit 9a2dfb
    -> a -- ^ use this otherwise
Packit 9a2dfb
    -> a
Packit 9a2dfb
pickWithRules _ = id
Packit 9a2dfb
{-# NOINLINE pickWithRules #-}
Packit 9a2dfb
{-# RULES "pickWithRules/rule" [0] forall x. pickWithRules x = const x #-}
Packit 9a2dfb
#endif
Packit 9a2dfb
Packit 9a2dfb
------------------------------------------------------------------------------
Packit 9a2dfb
-- Regressions
Packit 9a2dfb
------------------------------------------------------------------------------
Packit 9a2dfb
Packit 9a2dfb
-- A regression test for: https://github.com/bos/aeson/issues/351
Packit 9a2dfb
overlappingRegression :: FromJSON a => L.ByteString -> [a]
Packit 9a2dfb
overlappingRegression bs = fromMaybe [] $ decode bs
Packit 9a2dfb
Packit 9a2dfb
issue351 :: [Assertion]
Packit 9a2dfb
issue351 = [
Packit 9a2dfb
    assertEqual "Int"  ([1, 2, 3] :: [Int])  $ overlappingRegression "[1, 2, 3]"
Packit 9a2dfb
  , assertEqual "Char" ("abc"     :: String) $ overlappingRegression "\"abc\""
Packit 9a2dfb
  , assertEqual "Char" (""        :: String) $ overlappingRegression "[\"a\", \"b\", \"c\"]"
Packit 9a2dfb
  ]
Packit 9a2dfb
Packit 9a2dfb
------------------------------------------------------------------------------
Packit 9a2dfb
-- Comparison between bytestring and text encoders
Packit 9a2dfb
------------------------------------------------------------------------------
Packit 9a2dfb
Packit 9a2dfb
ioTests :: IO [Test]
Packit 9a2dfb
ioTests = do
Packit 9a2dfb
  enc <- encoderComparisonTests
Packit 9a2dfb
  js <- jsonTestSuite
Packit 9a2dfb
  return [enc, js]
Packit 9a2dfb
Packit 9a2dfb
encoderComparisonTests :: IO Test
Packit 9a2dfb
encoderComparisonTests = do
Packit 9a2dfb
  encoderTests <- forM testFiles $ \file0 -> do
Packit 9a2dfb
      let file = "benchmarks/json-data/" ++ file0
Packit 9a2dfb
      return $ testCase file $ do
Packit 9a2dfb
          inp <- L.readFile file
Packit 9a2dfb
          case eitherDecode inp of
Packit 9a2dfb
            Left  err -> assertFailure $ "Decoding failure: " ++ err
Packit 9a2dfb
            Right val -> assertEqual "" (encode val) (encodeViaText val)
Packit 9a2dfb
  return $ testGroup "encoders" encoderTests
Packit 9a2dfb
 where
Packit 9a2dfb
  encodeViaText :: Value -> L.ByteString
Packit 9a2dfb
  encodeViaText =
Packit 9a2dfb
      TLE.encodeUtf8 . TLB.toLazyText . encodeToTextBuilder . toJSON
Packit 9a2dfb
Packit 9a2dfb
  testFiles =
Packit 9a2dfb
    [ "example.json"
Packit 9a2dfb
    , "integers.json"
Packit 9a2dfb
    , "jp100.json"
Packit 9a2dfb
    , "numbers.json"
Packit 9a2dfb
    , "twitter10.json"
Packit 9a2dfb
    , "twitter20.json"
Packit 9a2dfb
    , "geometry.json"
Packit 9a2dfb
    , "jp10.json"
Packit 9a2dfb
    , "jp50.json"
Packit 9a2dfb
    , "twitter1.json"
Packit 9a2dfb
    , "twitter100.json"
Packit 9a2dfb
    , "twitter50.json"
Packit 9a2dfb
    ]
Packit 9a2dfb
Packit 9a2dfb
-- A regression test for: https://github.com/bos/aeson/issues/293
Packit 9a2dfb
data MyRecord = MyRecord {_field1 :: Maybe Int, _field2 :: Maybe Bool}
Packit 9a2dfb
Packit 9a2dfb
data MyRecord2 = MyRecord2 {_field3 :: Maybe Int, _field4 :: Maybe Bool}
Packit 9a2dfb
  deriving Generic
Packit 9a2dfb
Packit 9a2dfb
instance ToJSON   MyRecord2
Packit 9a2dfb
instance FromJSON MyRecord2
Packit 9a2dfb
Packit 9a2dfb
-- A regression test for: https://github.com/bos/aeson/pull/477
Packit 9a2dfb
unescapeString :: Assertion
Packit 9a2dfb
unescapeString = do
Packit 9a2dfb
  assertEqual "Basic escaping"
Packit 9a2dfb
     (Right ("\" / \\ \b \f \n \r \t" :: String))
Packit 9a2dfb
     (eitherDecode "\"\\\" \\/ \\\\ \\b \\f \\n \\r \\t\"")
Packit 9a2dfb
Packit 9a2dfb
  forM_ [minBound .. maxBound :: Char] $ \ c ->
Packit 9a2dfb
    let s = LT.pack [c] in
Packit 9a2dfb
    assertEqual (printf "UTF-16 encoded '\\x%X'" c)
Packit 9a2dfb
      (Right s) (eitherDecode $ utf16Char s)
Packit 9a2dfb
  where
Packit 9a2dfb
    utf16Char = formatString . LBase16.encode . LT.encodeUtf16BE
Packit 9a2dfb
    formatString s
Packit 9a2dfb
      | L.length s == 4 = L.concat ["\"\\u", s, "\""]
Packit 9a2dfb
      | L.length s == 8 =
Packit 9a2dfb
          L.concat ["\"\\u", L.take 4 s, "\\u", L.drop 4 s, "\""]
Packit 9a2dfb
      | otherwise = error "unescapeString: can't happen"
Packit 9a2dfb
Packit 9a2dfb
-- JSONTestSuite
Packit 9a2dfb
Packit 9a2dfb
jsonTestSuiteTest :: FilePath -> Test
Packit 9a2dfb
jsonTestSuiteTest path = testCase fileName $ do
Packit 9a2dfb
    payload <- L.readFile path
Packit 9a2dfb
    let result = eitherDecode payload :: Either String Value
Packit 9a2dfb
    assertBool fileName $ case take 2 fileName of
Packit 9a2dfb
      "i_" -> isRight result
Packit 9a2dfb
      "n_" -> isLeft result
Packit 9a2dfb
      "y_" -> isRight result
Packit 9a2dfb
      _    -> isRight result -- test_transform tests have inconsistent names
Packit 9a2dfb
  where
Packit 9a2dfb
    fileName = takeFileName path
Packit 9a2dfb
Packit 9a2dfb
-- Build a collection of tests based on the current contents of the
Packit 9a2dfb
-- JSONTestSuite test directories.
Packit 9a2dfb
Packit 9a2dfb
jsonTestSuite :: IO Test
Packit 9a2dfb
jsonTestSuite = do
Packit 9a2dfb
  let suitePath = "tests/JSONTestSuite"
Packit 9a2dfb
  let suites = ["test_parsing", "test_transform"]
Packit 9a2dfb
  testPaths <- fmap (sort . concat) . forM suites $ \suite -> do
Packit 9a2dfb
    let dir = suitePath  suite
Packit 9a2dfb
    entries <- getDirectoryContents dir
Packit 9a2dfb
    let ok name = takeExtension name == ".json" &&
Packit 9a2dfb
                  not (name `HashSet.member` blacklist)
Packit 9a2dfb
    return . map (dir ) . filter ok $ entries
Packit 9a2dfb
  return $ testGroup "JSONTestSuite" $ map jsonTestSuiteTest testPaths
Packit 9a2dfb
Packit 9a2dfb
-- The set expected-to-be-failing JSONTestSuite tests.
Packit 9a2dfb
-- Not all of these failures are genuine bugs.
Packit 9a2dfb
-- Of those that are bugs, not all are worth fixing.
Packit 9a2dfb
Packit 9a2dfb
blacklist :: HashSet.HashSet String
Packit 9a2dfb
-- blacklist = HashSet.empty
Packit 9a2dfb
blacklist = _blacklist
Packit 9a2dfb
Packit 9a2dfb
_blacklist :: HashSet.HashSet String
Packit 9a2dfb
_blacklist = HashSet.fromList [
Packit 9a2dfb
    "i_object_key_lone_2nd_surrogate.json"
Packit 9a2dfb
  , "i_string_1st_surrogate_but_2nd_missing.json"
Packit 9a2dfb
  , "i_string_1st_valid_surrogate_2nd_invalid.json"
Packit 9a2dfb
  , "i_string_UTF-16LE_with_BOM.json"
Packit 9a2dfb
  , "i_string_UTF-16_invalid_lonely_surrogate.json"
Packit 9a2dfb
  , "i_string_UTF-16_invalid_surrogate.json"
Packit 9a2dfb
  , "i_string_UTF-8_invalid_sequence.json"
Packit 9a2dfb
  , "i_string_incomplete_surrogate_and_escape_valid.json"
Packit 9a2dfb
  , "i_string_incomplete_surrogate_pair.json"
Packit 9a2dfb
  , "i_string_incomplete_surrogates_escape_valid.json"
Packit 9a2dfb
  , "i_string_invalid_lonely_surrogate.json"
Packit 9a2dfb
  , "i_string_invalid_surrogate.json"
Packit 9a2dfb
  , "i_string_inverted_surrogates_U+1D11E.json"
Packit 9a2dfb
  , "i_string_lone_second_surrogate.json"
Packit 9a2dfb
  , "i_string_not_in_unicode_range.json"
Packit 9a2dfb
  , "i_string_truncated-utf-8.json"
Packit 9a2dfb
  , "i_structure_UTF-8_BOM_empty_object.json"
Packit 9a2dfb
  , "n_string_unescaped_crtl_char.json"
Packit 9a2dfb
  , "n_string_unescaped_newline.json"
Packit 9a2dfb
  , "n_string_unescaped_tab.json"
Packit 9a2dfb
  , "string_1_escaped_invalid_codepoint.json"
Packit 9a2dfb
  , "string_1_invalid_codepoint.json"
Packit 9a2dfb
  , "string_1_invalid_codepoints.json"
Packit 9a2dfb
  , "string_2_escaped_invalid_codepoints.json"
Packit 9a2dfb
  , "string_2_invalid_codepoints.json"
Packit 9a2dfb
  , "string_3_escaped_invalid_codepoints.json"
Packit 9a2dfb
  , "string_3_invalid_codepoints.json"
Packit 9a2dfb
  , "y_string_utf16BE_no_BOM.json"
Packit 9a2dfb
  , "y_string_utf16LE_no_BOM.json"
Packit 9a2dfb
  ]
Packit 9a2dfb
Packit 9a2dfb
-- A regression test for: https://github.com/bos/aeson/pull/455
Packit 9a2dfb
data Foo a = FooNil | FooCons (Foo Int)
Packit 9a2dfb
Packit 9a2dfb
pr455 :: Assertion
Packit 9a2dfb
pr455 = assertEqual "FooCons FooNil"
Packit 9a2dfb
          (toJSON foo) (liftToJSON undefined undefined foo)
Packit 9a2dfb
  where
Packit 9a2dfb
    foo :: Foo Int
Packit 9a2dfb
    foo = FooCons FooNil
Packit 9a2dfb
Packit 9a2dfb
showOptions :: Assertion
Packit 9a2dfb
showOptions =
Packit 9a2dfb
    assertEqual
Packit 9a2dfb
        "Show Options"
Packit 9a2dfb
        (  "Options {"
Packit 9a2dfb
        ++   "fieldLabelModifier =~ \"exampleField\""
Packit 9a2dfb
        ++ ", constructorTagModifier =~ \"ExampleConstructor\""
Packit 9a2dfb
        ++ ", allNullaryToStringTag = True"
Packit 9a2dfb
        ++ ", omitNothingFields = False"
Packit 9a2dfb
        ++ ", sumEncoding = TaggedObject {tagFieldName = \"tag\", contentsFieldName = \"contents\"}"
Packit 9a2dfb
        ++ ", unwrapUnaryRecords = False"
Packit 9a2dfb
        ++ ", tagSingleConstructors = False"
Packit 9a2dfb
        ++ "}")
Packit 9a2dfb
        (show defaultOptions)
Packit 9a2dfb
Packit 9a2dfb
newtype SingleMaybeField = SingleMaybeField { smf :: Maybe Int }
Packit 9a2dfb
  deriving (Eq, Show, Generic)
Packit 9a2dfb
Packit 9a2dfb
singleMaybeField :: [Test]
Packit 9a2dfb
singleMaybeField = do
Packit 9a2dfb
  (gName, gToJSON, gToEncoding, gFromJSON) <-
Packit 9a2dfb
    [ ("generic", genericToJSON opts, genericToEncoding opts, parse (genericParseJSON opts))
Packit 9a2dfb
    , ("th", toJSON, toEncoding, fromJSON) ]
Packit 9a2dfb
  return $
Packit 9a2dfb
    testCase gName $ do
Packit 9a2dfb
      assertEqual "toJSON"     Null (gToJSON v)
Packit 9a2dfb
      assertEqual "toEncoding" (toEncoding (gToJSON v)) (gToEncoding v)
Packit 9a2dfb
      assertEqual "fromJSON"   (Success v) (gFromJSON Null)
Packit 9a2dfb
  where
Packit 9a2dfb
    v = SingleMaybeField Nothing
Packit 9a2dfb
    opts = defaultOptions{omitNothingFields=True,unwrapUnaryRecords=True}
Packit 9a2dfb
Packit 9a2dfb
Packit 9a2dfb
newtype EmbeddedJSONTest = EmbeddedJSONTest Int
Packit 9a2dfb
  deriving (Eq, Show)
Packit 9a2dfb
Packit 9a2dfb
instance FromJSON EmbeddedJSONTest where
Packit 9a2dfb
  parseJSON =
Packit 9a2dfb
    withObject "Object" $ \o ->
Packit 9a2dfb
      EmbeddedJSONTest <$> (o .: "prop" >>= withEmbeddedJSON "Quoted Int" parseJSON)
Packit 9a2dfb
Packit 9a2dfb
withEmbeddedJSONTest :: Assertion
Packit 9a2dfb
withEmbeddedJSONTest =
Packit 9a2dfb
  assertEqual "Unquote embedded JSON" (Right $ EmbeddedJSONTest 1) (eitherDecode "{\"prop\":\"1\"}")
Packit 9a2dfb
Packit 9a2dfb
deriveJSON defaultOptions{omitNothingFields=True} ''MyRecord
Packit 9a2dfb
Packit 9a2dfb
deriveToJSON  defaultOptions ''Foo
Packit 9a2dfb
deriveToJSON1 defaultOptions ''Foo
Packit 9a2dfb
Packit 9a2dfb
deriveJSON defaultOptions{omitNothingFields=True,unwrapUnaryRecords=True} ''SingleMaybeField