diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,18 @@ # Revision history for smash-aeson +## 0.3.0 -- 2026-10-26 + +* Start the `0.3` major release series and require `smash >=0.2.0 && <0.3`. +* Preserve the explicit ordinary and lifted JSON wire formats across `aeson` 2.0–2.3. + +## 0.2.0.2 -- 2026-10-26 + +* Update dependency bounds and the supported GHC matrix to 9.6–9.14. +* Update copyrights through 2026. +* Support `aeson >=2.0 && <2.4` while retaining the explicit JSON wire formats. +* Decode two-field objects independently of key order. +* Add fixed wire-format fixtures, malformed-input tests, and ordinary/lifted instance properties. + ## 0.2.0.1 -- 2022-04-03 * Update `base` bounds to allow GHC 9.2.x diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2020, Emily Pillmore +Copyright (c) 2020-2026, Emily Pillmore All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,23 @@ # smash-aeson: Aeson support for the smash library -[![Build Status](https://travis-ci.com/emilypi/smash.svg?branch=master)](https://travis-ci.com/emilypi/smash) +[![CI](https://github.com/emilypi/smash/actions/workflows/haskell-ci.yml/badge.svg)](https://github.com/emilypi/smash/actions/workflows/haskell-ci.yml) [![Hackage](https://img.shields.io/hackage/v/smash-aeson.svg)](https://hackage.haskell.org/package/smash-aeson) + +The instances use an explicit, stable object format across supported `aeson` +versions. Import the corresponding `Data.Can.Aeson`, `Data.Smash.Aeson`, or +`Data.Wedge.Aeson` module to bring the instances into scope. + +| Value | JSON | +| --- | --- | +| `Non`, `Nada`, `Nowhere` | `{}` | +| `One a` | `{"One": a}` | +| `Eno b` | `{"Eno": b}` | +| `Two a b` | `{"One": a, "Eno": b}` | +| `Smash a b` | `{"SmashL": a, "SmashR": b}` | +| `Here a` | `{"Here": a}` | +| `There b` | `{"There": b}` | + +Ordinary and lifted instances use the same representation. Object key order is +irrelevant when decoding. Unexpected or missing keys are rejected, and nullable +payloads retain their constructor keys even when their values are `null`. diff --git a/smash-aeson.cabal b/smash-aeson.cabal --- a/smash-aeson.cabal +++ b/smash-aeson.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: smash-aeson -version: 0.2.0.1 +version: 0.3.0 synopsis: Aeson support for the smash library description: Aeson support for the `smash` library homepage: https://github.com/emilypi/smash @@ -9,19 +9,19 @@ license-file: LICENSE author: Emily Pillmore maintainer: emilypi@cohomolo.gy -copyright: (c) 2020-2022 Emily Pillmore +copyright: (c) 2020-2026 Emily Pillmore category: Data build-type: Simple -extra-source-files: +extra-doc-files: CHANGELOG.md README.md tested-with: - GHC ==8.6.5 - || ==8.8.4 - || ==8.10.7 - || ==9.0.2 - || ==9.2.2 + GHC ==9.6.7 + || ==9.8.4 + || ==9.10.3 + || ==9.12.4 + || ==9.14.1 library exposed-modules: @@ -30,11 +30,28 @@ Data.Wedge.Aeson build-depends: - aeson >=2.0 && <2.1 - , base >=4.1 && <4.17 - , smash >=0.1.3 - , unordered-containers + aeson >=2.0 && <2.4 + , base >=4.15 && <4.23 + , smash >=0.2.0 && <0.3 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + +test-suite smash-aeson-tests + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + base >=4.15 && <4.23 + , smash-aeson + , tasty >=1.4 && <1.6 + , tasty-hunit >=0.10 && <0.11 + , tasty-quickcheck >=0.10 && <0.12 + , QuickCheck >=2.14 && <2.17 + , smash >=0.2.0 && <0.3 + , aeson >=2.0 && <2.4 + , bytestring + + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N diff --git a/src/Data/Can/Aeson.hs b/src/Data/Can/Aeson.hs --- a/src/Data/Can/Aeson.hs +++ b/src/Data/Can/Aeson.hs @@ -3,7 +3,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Can.Aeson --- Copyright : (c) 2020-2022 Emily Pillmore +-- Copyright : (c) 2020-2026 Emily Pillmore -- License : BSD-3-Clause -- -- Maintainer : Emily Pillmore @@ -12,16 +12,13 @@ -- -- This module contains the Aeson instances for the 'Can' datatype. -- -module Data.Can.Aeson where +module Data.Can.Aeson () where import Data.Aeson import Data.Aeson.Encoding (emptyObject_, pair) import qualified Data.Aeson.KeyMap as KM import Data.Can (Can(..)) -#if __GLASGOW_HASKELL__ < 804 -import Data.Semigroup (Semigroup(..)) -#endif instance (ToJSON a, ToJSON b) => ToJSON (Can a b) where @@ -36,52 +33,88 @@ toEncoding Non = emptyObject_ instance (FromJSON a, FromJSON b) => FromJSON (Can a b) where - parseJSON = withObject "Can a b" (go . KM.toList) + parseJSON = withObject "Can a b" (go . KM.toAscList) where go [("One", a)] = One <$> parseJSON a go [("Eno", b)] = Eno <$> parseJSON b - go [("One", a), ("Eno", b)] = Two <$> parseJSON a <*> parseJSON b + go [("Eno", b), ("One", a)] = Two <$> parseJSON a <*> parseJSON b go [] = pure Non go _ = fail "Expected either empty object, or 'One' and 'Eno' keys, 'One' or 'Eno' keys only" instance ToJSON2 Can where +#if MIN_VERSION_aeson(2,2,0) + liftToJSON2 _ f _ _ _ _ (One a) = object [ "One" .= f a ] + liftToJSON2 _ _ _ _ g _ (Eno b) = object [ "Eno" .= g b ] + liftToJSON2 _ f _ _ g _ (Two a b) = object [ "One" .= f a, "Eno" .= g b ] + liftToJSON2 _ _ _ _ _ _ Non = object [] +#else liftToJSON2 f _ _ _ (One a) = object [ "One" .= f a ] liftToJSON2 _ _ g _ (Eno b) = object [ "Eno" .= g b ] liftToJSON2 f _ g _ (Two a b) = object [ "One" .= f a, "Eno" .= g b ] liftToJSON2 _ _ _ _ Non = object [] +#endif +#if MIN_VERSION_aeson(2,2,0) + liftToEncoding2 _ f _ _ _ _ (One a) = pairs $ pair "One" (f a) + liftToEncoding2 _ _ _ _ g _ (Eno b) = pairs $ pair "Eno" (g b) + liftToEncoding2 _ f _ _ g _ (Two a b) = pairs $ pair "One" (f a) <> pair "Eno" (g b) + liftToEncoding2 _ _ _ _ _ _ Non = emptyObject_ +#else liftToEncoding2 f _ _ _ (One a) = pairs $ pair "One" (f a) liftToEncoding2 _ _ g _ (Eno b) = pairs $ pair "Eno" (g b) liftToEncoding2 f _ g _ (Two a b) = pairs $ pair "One" (f a) <> pair "Eno" (g b) liftToEncoding2 _ _ _ _ Non = emptyObject_ +#endif instance ToJSON a => ToJSON1 (Can a) where +#if MIN_VERSION_aeson(2,2,0) + liftToJSON _ _ _ (One a) = object [ "One" .= a ] + liftToJSON _ g _ (Eno b) = object [ "Eno" .= g b ] + liftToJSON _ g _ (Two a b) = object [ "One" .= a, "Eno" .= g b ] + liftToJSON _ _ _ Non = object [] +#else liftToJSON _ _ (One a) = object [ "One" .= a ] liftToJSON g _ (Eno b) = object [ "Eno" .= g b ] liftToJSON g _ (Two a b) = object [ "One" .= a, "Eno" .= g b ] liftToJSON _ _ Non = object [] +#endif +#if MIN_VERSION_aeson(2,2,0) + liftToEncoding _ _ _ (One a) = pairs $ "One" .= a + liftToEncoding _ g _ (Eno b) = pairs $ pair "Eno" (g b) + liftToEncoding _ g _ (Two a b) = pairs $ "One" .= a <> pair "Eno" (g b) + liftToEncoding _ _ _ Non = emptyObject_ +#else liftToEncoding _ _ (One a) = pairs $ "One" .= a liftToEncoding g _ (Eno b) = pairs $ pair "Eno" (g b) liftToEncoding g _ (Two a b) = pairs $ "One" .= a <> pair "Eno" (g b) liftToEncoding _ _ Non = emptyObject_ +#endif instance FromJSON2 Can where - liftParseJSON2 f _ g _ = withObject "Can a b" (go . KM.toList) +#if MIN_VERSION_aeson(2,2,0) + liftParseJSON2 _ f _ _ g _ = withObject "Can a b" (go . KM.toAscList) +#else + liftParseJSON2 f _ g _ = withObject "Can a b" (go . KM.toAscList) +#endif where go [] = pure Non go [("One", a)] = One <$> f a go [("Eno", b)] = Eno <$> g b - go [("One", a), ("Eno", b)] = Two <$> f a <*> g b + go [("Eno", b), ("One", a)] = Two <$> f a <*> g b go _ = fail "Expected either empty object, or 'One' and 'Eno' keys, 'One' or 'Eno' keys only" instance FromJSON a => FromJSON1 (Can a) where - liftParseJSON f _ = withObject "Can a b" (go . KM.toList) +#if MIN_VERSION_aeson(2,2,0) + liftParseJSON _ f _ = withObject "Can a b" (go . KM.toAscList) +#else + liftParseJSON f _ = withObject "Can a b" (go . KM.toAscList) +#endif where go [] = pure Non go [("One", a)] = One <$> parseJSON a go [("Eno", b)] = Eno <$> f b - go [("One", a), ("Eno", b)] = Two <$> parseJSON a <*> f b + go [("Eno", b), ("One", a)] = Two <$> parseJSON a <*> f b go _ = fail "Expected either empty object, or 'One' and 'Eno' keys, 'One' or 'Eno' keys only" diff --git a/src/Data/Smash/Aeson.hs b/src/Data/Smash/Aeson.hs --- a/src/Data/Smash/Aeson.hs +++ b/src/Data/Smash/Aeson.hs @@ -3,7 +3,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Smash.Aeson --- Copyright : (c) 2020-2022 Emily Pillmore +-- Copyright : (c) 2020-2026 Emily Pillmore -- License : BSD-3-Clause -- -- Maintainer : Emily Pillmore @@ -13,15 +13,12 @@ -- This module contains the Aeson instances for the 'Smash' datatype. -- The 'Smash' instances, explicitly naming the tuple entries using `SmashL` and `SmashR` -- -module Data.Smash.Aeson where +module Data.Smash.Aeson () where import Data.Aeson import Data.Aeson.Encoding (emptyObject_, pair) import qualified Data.Aeson.KeyMap as KM -#if __GLASGOW_HASKELL__ < 804 -import Data.Semigroup (Semigroup(..)) -#endif import Data.Smash (Smash(..)) @@ -33,7 +30,7 @@ toEncoding Nada = emptyObject_ instance (FromJSON a, FromJSON b) => FromJSON (Smash a b) where - parseJSON = withObject "Smash a b" (go . KM.toList) + parseJSON = withObject "Smash a b" (go . KM.toAscList) where go [("SmashL", a), ("SmashR", b)] = Smash <$> parseJSON a <*> parseJSON b go [] = pure Nada @@ -41,29 +38,57 @@ instance ToJSON2 Smash where +#if MIN_VERSION_aeson(2,2,0) + liftToJSON2 _ f _ _ g _ (Smash a b) = object [ "SmashL" .= f a, "SmashR" .= g b ] + liftToJSON2 _ _ _ _ _ _ Nada = object [] +#else liftToJSON2 f _ g _ (Smash a b) = object [ "SmashL" .= f a, "SmashR" .= g b ] liftToJSON2 _ _ _ _ Nada = object [] +#endif +#if MIN_VERSION_aeson(2,2,0) + liftToEncoding2 _ f _ _ g _ (Smash a b) = pairs $ pair "SmashL" (f a) <> pair "SmashR" (g b) + liftToEncoding2 _ _ _ _ _ _ Nada = emptyObject_ +#else liftToEncoding2 f _ g _ (Smash a b) = pairs $ pair "SmashL" (f a) <> pair "SmashR" (g b) liftToEncoding2 _ _ _ _ Nada = emptyObject_ +#endif instance ToJSON a => ToJSON1 (Smash a) where +#if MIN_VERSION_aeson(2,2,0) + liftToJSON _ g _ (Smash a b) = object [ "SmashL" .= a, "SmashR" .= g b ] + liftToJSON _ _ _ Nada = object [] +#else liftToJSON g _ (Smash a b) = object [ "SmashL" .= a, "SmashR" .= g b ] liftToJSON _ _ Nada = object [] +#endif +#if MIN_VERSION_aeson(2,2,0) + liftToEncoding _ g _ (Smash a b) = pairs $ "SmashL" .= a <> pair "SmashR" (g b) + liftToEncoding _ _ _ Nada = emptyObject_ +#else liftToEncoding g _ (Smash a b) = pairs $ "SmashL" .= a <> pair "SmashR" (g b) liftToEncoding _ _ Nada = emptyObject_ +#endif instance FromJSON2 Smash where - liftParseJSON2 f _ g _ = withObject "Smash a b" (go . KM.toList) +#if MIN_VERSION_aeson(2,2,0) + liftParseJSON2 _ f _ _ g _ = withObject "Smash a b" (go . KM.toAscList) +#else + liftParseJSON2 f _ g _ = withObject "Smash a b" (go . KM.toAscList) +#endif where go [] = pure Nada go [("SmashL", a), ("SmashR", b)] = Smash <$> f a <*> g b go _ = fail "Expected either empty object, or a 'Smash' pair" instance FromJSON a => FromJSON1 (Smash a) where - liftParseJSON f _ = withObject "Smash a b" (go . KM.toList) +#if MIN_VERSION_aeson(2,2,0) + liftParseJSON _ f _ = withObject "Smash a b" (go . KM.toAscList) +#else + liftParseJSON f _ = withObject "Smash a b" (go . KM.toAscList) +#endif where go [] = pure Nada go [("SmashL", a), ("SmashR", b)] = Smash <$> parseJSON a <*> f b diff --git a/src/Data/Wedge/Aeson.hs b/src/Data/Wedge/Aeson.hs --- a/src/Data/Wedge/Aeson.hs +++ b/src/Data/Wedge/Aeson.hs @@ -1,8 +1,9 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Wedge.Aeson --- Copyright : (c) 2020-2022 Emily Pillmore +-- Copyright : (c) 2020-2026 Emily Pillmore -- License : BSD-3-Clause -- -- Maintainer : Emily Pillmore @@ -11,7 +12,7 @@ -- -- This module contains the Aeson instances for the 'Wedge' datatype. -- -module Data.Wedge.Aeson where +module Data.Wedge.Aeson () where import Data.Aeson @@ -30,7 +31,7 @@ toEncoding Nowhere = emptyObject_ instance (FromJSON a, FromJSON b) => FromJSON (Wedge a b) where - parseJSON = withObject "Wedge a b" (go . KM.toList) + parseJSON = withObject "Wedge a b" (go . KM.toAscList) where go [("Here", a)] = Here <$> parseJSON a go [("There", b)] = There <$> parseJSON b @@ -39,26 +40,54 @@ instance ToJSON2 Wedge where +#if MIN_VERSION_aeson(2,2,0) + liftToJSON2 _ f _ _ _ _ (Here a) = object [ "Here" .= f a ] + liftToJSON2 _ _ _ _ g _ (There b) = object [ "There" .= g b ] + liftToJSON2 _ _ _ _ _ _ Nowhere = object [] +#else liftToJSON2 f _ _ _ (Here a) = object [ "Here" .= f a ] liftToJSON2 _ _ g _ (There b) = object [ "There" .= g b ] liftToJSON2 _ _ _ _ Nowhere = object [] +#endif +#if MIN_VERSION_aeson(2,2,0) + liftToEncoding2 _ f _ _ _ _ (Here a) = pairs $ pair "Here" (f a) + liftToEncoding2 _ _ _ _ g _ (There b) = pairs $ pair "There" (g b) + liftToEncoding2 _ _ _ _ _ _ Nowhere = emptyObject_ +#else liftToEncoding2 f _ _ _ (Here a) = pairs $ pair "Here" (f a) liftToEncoding2 _ _ g _ (There b) = pairs $ pair "There" (g b) liftToEncoding2 _ _ _ _ Nowhere = emptyObject_ +#endif instance ToJSON a => ToJSON1 (Wedge a) where +#if MIN_VERSION_aeson(2,2,0) + liftToJSON _ _ _ (Here a) = object [ "Here" .= a ] + liftToJSON _ g _ (There b) = object [ "There" .= g b ] + liftToJSON _ _ _ Nowhere = object [] +#else liftToJSON _ _ (Here a) = object [ "Here" .= a ] liftToJSON g _ (There b) = object [ "There" .= g b ] liftToJSON _ _ Nowhere = object [] +#endif +#if MIN_VERSION_aeson(2,2,0) + liftToEncoding _ _ _ (Here a) = pairs $ "Here" .= a + liftToEncoding _ g _ (There b) = pairs $ pair "There" (g b) + liftToEncoding _ _ _ Nowhere = emptyObject_ +#else liftToEncoding _ _ (Here a) = pairs $ "Here" .= a liftToEncoding g _ (There b) = pairs $ pair "There" (g b) liftToEncoding _ _ Nowhere = emptyObject_ +#endif instance FromJSON2 Wedge where - liftParseJSON2 f _ g _ = withObject "Wedge a b" (go . KM.toList) +#if MIN_VERSION_aeson(2,2,0) + liftParseJSON2 _ f _ _ g _ = withObject "Wedge a b" (go . KM.toAscList) +#else + liftParseJSON2 f _ g _ = withObject "Wedge a b" (go . KM.toAscList) +#endif where go [] = pure Nowhere go [("Here", a)] = Here <$> f a @@ -66,7 +95,11 @@ go _ = fail "Expected either empty object, or one with 'Here' or 'There' keys only" instance FromJSON a => FromJSON1 (Wedge a) where - liftParseJSON f _ = withObject "Wedge a b" (go . KM.toList) +#if MIN_VERSION_aeson(2,2,0) + liftParseJSON _ f _ = withObject "Wedge a b" (go . KM.toAscList) +#else + liftParseJSON f _ = withObject "Wedge a b" (go . KM.toAscList) +#endif where go [] = pure Nowhere go [("Here", a)] = Here <$> parseJSON a diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- Copyright (c) 2020-2026 Emily Pillmore +module Main (main) where + +import Control.Monad (forM_) +import Data.Aeson +import Data.Aeson.Encoding (encodingToLazyByteString) +import Data.Aeson.Types (Parser, parseEither) +import Data.Bifunctor (Bifunctor, bimap) +import qualified Data.ByteString.Lazy.Char8 as BL +import Data.Can +import Data.Can.Aeson () +import Data.Either (isLeft) +import Data.Smash +import Data.Smash.Aeson () +import Data.Wedge +import Data.Wedge.Aeson () +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +main :: IO () +main = defaultMain $ testGroup "smash-aeson" + [ wireTests "Can" + [(Non, "{}"), (One 7, "{\"One\":7}"), (Eno 9, "{\"Eno\":9}"), + (Two 7 9, "{\"One\":7,\"Eno\":9}")] + (oneof [pure Non, One <$> arbitrary, Eno <$> arbitrary, Two <$> arbitrary <*> arbitrary]) + ["{\"Other\":1}", "{\"One\":1,\"Other\":2}", "{\"One\":1,\"Eno\":2,\"Other\":3}", + "{\"One\":null}", "{\"Eno\":false}", "{\"tag\":\"Non\"}"] + , wireTests "Smash" + [(Nada, "{}"), (Smash 7 9, "{\"SmashL\":7,\"SmashR\":9}")] + (oneof [pure Nada, Smash <$> arbitrary <*> arbitrary]) + ["{\"SmashL\":1}", "{\"SmashR\":2}", "{\"SmashL\":1,\"SmashR\":2,\"Other\":3}", + "{\"SmashL\":null,\"SmashR\":2}", "{\"tag\":\"Nada\"}"] + , wireTests "Wedge" + [(Nowhere, "{}"), (Here 7, "{\"Here\":7}"), (There 9, "{\"There\":9}")] + (oneof [pure Nowhere, Here <$> arbitrary, There <$> arbitrary]) + ["{\"Here\":1,\"There\":2}", "{\"Other\":1}", "{\"Here\":1,\"Other\":2}", + "{\"Here\":null}", "{\"There\":false}", "{\"tag\":\"Nowhere\"}"] + , testCase "Can accepts both object key orders" $ forM_ + ["{\"One\":7,\"Eno\":9}", "{\"Eno\":9,\"One\":7}"] $ \bytes -> + checkParsers (Two 7 9 :: Can Int Int) bytes + , testCase "Smash accepts both object key orders" $ forM_ + ["{\"SmashL\":7,\"SmashR\":9}", "{\"SmashR\":9,\"SmashL\":7}"] $ \bytes -> + checkParsers (Smash 7 9 :: Smash Int Int) bytes + , testCase "nullable payloads retain their constructor keys" $ do + checkNullable (Two Nothing Nothing :: Can (Maybe Int) (Maybe Int)) "{\"One\":null,\"Eno\":null}" + checkNullable (One Nothing :: Can (Maybe Int) (Maybe Int)) "{\"One\":null}" + checkNullable (Eno Nothing :: Can (Maybe Int) (Maybe Int)) "{\"Eno\":null}" + checkNullable (Smash Nothing Nothing :: Smash (Maybe Int) (Maybe Int)) "{\"SmashL\":null,\"SmashR\":null}" + checkNullable (Here Nothing :: Wedge (Maybe Int) (Maybe Int)) "{\"Here\":null}" + checkNullable (There Nothing :: Wedge (Maybe Int) (Maybe Int)) "{\"There\":null}" + ] + +wireTests + :: forall f. (Eq (f Int Int), Show (f Int Int), ToJSON (f Int Int), FromJSON (f Int Int), + ToJSON1 (f Int), FromJSON1 (f Int), ToJSON2 f, FromJSON2 f, Bifunctor f) + => String -> [(f Int Int, BL.ByteString)] -> Gen (f Int Int) -> [BL.ByteString] -> TestTree +wireTests name vectors gen invalid = testGroup name + [ testGroup "Legacy wire fixtures" + [ testCase (show x) $ do + encode x @?= bytes + toJSON x @?= fixtureValue bytes + toJSON1 x @?= fixtureValue bytes + toJSON2 x @?= fixtureValue bytes + encodingToLazyByteString (toEncoding1 x) @?= bytes + encodingToLazyByteString (toEncoding2 x) @?= bytes + checkParsers x bytes + | (x, bytes) <- vectors + ] + , testGroup "Reject malformed representations" + [ testCase (BL.unpack bytes) $ do + assertBool "ordinary parser accepted invalid input" (isLeft (eitherDecode bytes :: Either String (f Int Int))) + assertBool "unary parser accepted invalid input" (isLeft (parseEither parseJSON1 (fixtureValue bytes) :: Either String (f Int Int))) + assertBool "binary parser accepted invalid input" (isLeft (parseEither parseJSON2 (fixtureValue bytes) :: Either String (f Int Int))) + | bytes <- ["null", "[]", "7", "true", "\"Non\""] ++ invalid + ] + , testProperty "ordinary and lifted roundtrips" $ forAll gen $ \x -> conjoin + [ eitherDecode (encode x) === Right x + , parseEither parseJSON1 (toJSON1 x) === Right x + , parseEither parseJSON2 (toJSON2 x) === Right x + , eitherDecode (encodingToLazyByteString (toEncoding1 x)) === Right x + , eitherDecode (encodingToLazyByteString (toEncoding2 x)) === Right x + ] + , testProperty "lifted callbacks preserve keys and transform payloads" $ forAll gen $ \x -> conjoin + [ customJSON1 x === toJSON (fmapRight x) + , customJSON2 x === toJSON (bimap (+10) (*3) x) + , fixtureValue (encodingToLazyByteString (customEncoding1 x)) === customJSON1 x + , fixtureValue (encodingToLazyByteString (customEncoding2 x)) === customJSON2 x + , parseEither customParse1 (customJSON1 x) === Right x + , parseEither customParse2 (customJSON2 x) === Right x + ] + ] + where + fmapRight = bimap id (*3) + +fixtureValue :: BL.ByteString -> Value +fixtureValue bytes = either error id (eitherDecode bytes) + +checkParsers + :: (Eq (f Int Int), Show (f Int Int), FromJSON (f Int Int), FromJSON1 (f Int), FromJSON2 f) + => f Int Int -> BL.ByteString -> Assertion +checkParsers x bytes = do + eitherDecode bytes @?= Right x + parseEither parseJSON1 (fixtureValue bytes) @?= Right x + parseEither parseJSON2 (fixtureValue bytes) @?= Right x + +checkNullable + :: (Eq (f (Maybe Int) (Maybe Int)), Show (f (Maybe Int) (Maybe Int)), + ToJSON (f (Maybe Int) (Maybe Int)), FromJSON (f (Maybe Int) (Maybe Int)), + ToJSON1 (f (Maybe Int)), FromJSON1 (f (Maybe Int)), ToJSON2 f, FromJSON2 f) + => f (Maybe Int) (Maybe Int) -> BL.ByteString -> Assertion +checkNullable x bytes = do + encode x @?= bytes + toJSON1 x @?= fixtureValue bytes + toJSON2 x @?= fixtureValue bytes + encodingToLazyByteString (toEncoding1 x) @?= bytes + encodingToLazyByteString (toEncoding2 x) @?= bytes + eitherDecode bytes @?= Right x + parseEither parseJSON1 (fixtureValue bytes) @?= Right x + parseEither parseJSON2 (fixtureValue bytes) @?= Right x + +-- Aeson 2.2 added omission arguments. Explicit constructor fields must still +-- be emitted and required even when callbacks would allow their omission. +#if MIN_VERSION_aeson(2,2,0) +#define OMIT (const True) +#define MISSING (Just 42) +#else +#define OMIT +#define MISSING +#endif + +customJSON1 :: ToJSON1 f => f Int -> Value +customJSON1 = liftToJSON OMIT (toJSON . (*3)) toJSON + +customJSON2 :: ToJSON2 f => f Int Int -> Value +customJSON2 = liftToJSON2 OMIT (toJSON . (+10)) toJSON OMIT (toJSON . (*3)) toJSON + +customEncoding1 :: ToJSON1 f => f Int -> Encoding +customEncoding1 = liftToEncoding OMIT (toEncoding . (*3)) toEncoding + +customEncoding2 :: ToJSON2 f => f Int Int -> Encoding +customEncoding2 = liftToEncoding2 OMIT (toEncoding . (+10)) toEncoding OMIT (toEncoding . (*3)) toEncoding + +customParse1 :: FromJSON1 f => Value -> Parser (f Int) +customParse1 = liftParseJSON MISSING (fmap (`div` 3) . parseJSON) parseJSON + +customParse2 :: FromJSON2 f => Value -> Parser (f Int Int) +customParse2 = liftParseJSON2 MISSING (fmap (subtract 10) . parseJSON) parseJSON MISSING (fmap (`div` 3) . parseJSON) parseJSON