36ebc06 · typeable/aeson

git.iko.soy/typeable/aeson

on master help sign in

Add Compose instances, correct Identity

36ebc06Oleg Grenrus10 years ago

Data/Aeson/Types/FromJSON.hs+43−10

compare with master

unifiedsplit

@@ -82,6 +82,7 @@ import Control.Monad ((<=<))

82import Data.Attoparsec.Number (Number (..))

83import Data.Bits (unsafeShiftR)

84import Data.Fixed (Fixed, HasResolution)

85+import Data.Functor.Compose (Compose (..))

85import Data.Functor.Identity (Identity (..))

86import Data.Functor.Identity (Identity (..))

86import Data.Hashable (Hashable (..))

87import Data.Hashable (Hashable (..))

87import Data.Int (Int16, Int32, Int64, Int8)

88import Data.Int (Int16, Int32, Int64, Int8)

@@ -961,13 +962,6 @@ notFound key = fail $ "The key \"" ++ unpack key ++ "\" was not found"

961-- base

962-- base

962-------------------------------------------------------------------------------

963-------------------------------------------------------------------------------

963

964

964−instance FromJSON1 Identity where

965− liftParseJSON p _ a = Identity <$> p a

966− {-# INLINE liftParseJSON #-}

967−

968−instance (FromJSON a) => FromJSON (Identity a) where

969− parseJSON = parseJSON1

970− {-# INLINE parseJSON #-}

971

965

972instance FromJSON2 Const where

966instance FromJSON2 Const where

973 liftParseJSON2 p _ _ _ = fmap Const . p

967 liftParseJSON2 p _ _ _ = fmap Const . p

@@ -1256,6 +1250,48 @@ instance (FromJSON a) => FromJSON (DList.DList a) where

1256 parseJSON = parseJSON1

1250 parseJSON = parseJSON1

1257 {-# INLINE parseJSON #-}

1251 {-# INLINE parseJSON #-}

1258

1252

1253+-------------------------------------------------------------------------------

1254+-- tranformers - Functors

1255+-------------------------------------------------------------------------------

1256+

1257+instance FromJSON1 Identity where

1258+ liftParseJSON p _ a = Identity <$> p a

1259+ {-# INLINE liftParseJSON #-}

1260+

1261+ liftParseJSONList _ p a = fmap Identity <$> p a

1262+ {-# INLINE liftParseJSONList #-}

1263+

1264+instance (FromJSON a) => FromJSON (Identity a) where

1265+ parseJSON = parseJSON1

1266+ {-# INLINE parseJSON #-}

1267+

1268+ parseJSONList = liftParseJSONList parseJSON parseJSONList

1269+ {-# INLINE parseJSONList #-}

1270+

1271+instance (FromJSONKey a, FromJSON a) => FromJSONKey (Identity a) where

1272+ fromJSONKey = mapFromJSONKeyFunction Identity fromJSONKey

1273+

1274+

1275+instance (FromJSON1 f, FromJSON1 g) => FromJSON1 (Compose f g) where

1276+ liftParseJSON p pl a = Compose <$> liftParseJSON g gl a

1277+ where

1278+ g = liftParseJSON p pl

1279+ gl = liftParseJSONList p pl

1280+ {-# INLINE liftParseJSON #-}

1281+

1282+ liftParseJSONList p pl a = map Compose <$> liftParseJSONList g gl a

1283+ where

1284+ g = liftParseJSON p pl

1285+ gl = liftParseJSONList p pl

1286+ {-# INLINE liftParseJSONList #-}

1287+

1288+instance (FromJSON1 f, FromJSON1 g, FromJSON a) => FromJSON (Compose f g a) where

1289+ parseJSON = parseJSON1

1290+ {-# INLINE parseJSON #-}

1291+

1292+ parseJSONList = liftParseJSONList parseJSON parseJSONList

1293+ {-# INLINE parseJSONList #-}

1294+

1259-------------------------------------------------------------------------------

1295-------------------------------------------------------------------------------

1260-- containers

1296-- containers

1261-------------------------------------------------------------------------------

1297-------------------------------------------------------------------------------

@@ -1514,9 +1550,6 @@ instance FromJSONKey Char where

1514instance (FromJSONKey a, FromJSON a) => FromJSONKey [a] where

1550instance (FromJSONKey a, FromJSON a) => FromJSONKey [a] where

1515 fromJSONKey = fromJSONKeyList

1551 fromJSONKey = fromJSONKeyList

1516

1552

1517−instance (FromJSONKey a, FromJSON a) => FromJSONKey (Identity a) where

1518− fromJSONKey = mapFromJSONKeyFunction Identity fromJSONKey

1519−

1520-------------------------------------------------------------------------------

1553-------------------------------------------------------------------------------

1521-- Tuple instances, see tuple-instances-from.hs

1554-- Tuple instances, see tuple-instances-from.hs

1522-------------------------------------------------------------------------------

1555-------------------------------------------------------------------------------

Data/Aeson/Types/ToJSON.hs+80−25

@@ -72,6 +72,7 @@ import Data.Bits (unsafeShiftR)

72import Data.DList (DList)

73import Data.Fixed (Fixed, HasResolution)

74import Data.Foldable (toList)

75+import Data.Functor.Compose (Compose (..))

75import Data.Functor.Identity (Identity (..))

76import Data.Functor.Identity (Identity (..))

76import Data.Int (Int16, Int32, Int64, Int8)

77import Data.Int (Int16, Int32, Int64, Int8)

77import Data.List (intersperse)

78import Data.List (intersperse)

@@ -305,7 +306,7 @@ instance KeyValue Pair where

305

306

306-- | Typeclass for types that can be used as the key of a map-like container

307-- | Typeclass for types that can be used as the key of a map-like container

307-- (like 'Map' or 'HashMap'). For example, since 'Text' has a 'ToJSONKey'

308-- (like 'Map' or 'HashMap'). For example, since 'Text' has a 'ToJSONKey'

308−-- instance and 'Char' has a 'ToJSON' instance, we can encode a value of

309+-- instance and 'Char' has a 'ToJSON' instance, we can encode a value of

309-- type 'Map' 'Text' 'Char':

310-- type 'Map' 'Text' 'Char':

310--

311--

311-- >>> LBC8.putStrLn $ encode $ Map.fromList [("foo" :: Text, 'a')]

312-- >>> LBC8.putStrLn $ encode $ Map.fromList [("foo" :: Text, 'a')]

@@ -351,16 +352,16 @@ instance KeyValue Pair where

351-- >>> let m = Map.fromList [(Foo 4 "bar",'a'),(Foo 6 "arg",'b')]

352-- >>> let m = Map.fromList [(Foo 4 "bar",'a'),(Foo 6 "arg",'b')]

352-- >>> LBC8.putStrLn $ encode m

353-- >>> LBC8.putStrLn $ encode m

353-- [[{"fooName":"bar","fooAge":4},"a"],[{"fooName":"arg","fooAge":6},"b"]]

354-- [[{"fooName":"bar","fooAge":4},"a"],[{"fooName":"arg","fooAge":6},"b"]]

354−--

355+--

355-- The next case to consider is if we have a type that is a

356-- The next case to consider is if we have a type that is a

356-- newtype wrapper around 'Text'. The recommended approach is to use

357-- newtype wrapper around 'Text'. The recommended approach is to use

357-- generalized newtype deriving:

358-- generalized newtype deriving:

358--

359--

359-- > newtype RecordId = RecordId { getRecordId :: Text}

360-- > newtype RecordId = RecordId { getRecordId :: Text}

360-- > deriving (Eq,Ord,ToJSONKey)

361-- > deriving (Eq,Ord,ToJSONKey)

361−--

362+--

362-- Then we may write:

363-- Then we may write:

363−--

364+--

364-- >>> LBC8.putStrLn $ encode $ Map.fromList [(RecordId "abc",'a')]

365-- >>> LBC8.putStrLn $ encode $ Map.fromList [(RecordId "abc",'a')]

365-- {"abc":"a"}

366-- {"abc":"a"}

366--

367--

@@ -378,7 +379,7 @@ instance KeyValue Pair where

378-- > instance ToJSONKey Color where

379-- > instance ToJSONKey Color where

379-- > toJSONKey = ToJSONKeyText f g

380-- > toJSONKey = ToJSONKeyText f g

380-- > where f = Text.pack . show

381-- > where f = Text.pack . show

381−-- > g = text . Text.pack . show

382+-- > g = text . Text.pack . show

382-- > -- text function is from Data.Aeson.Encoding

383-- > -- text function is from Data.Aeson.Encoding

383--

384--

384-- The situation of needing to turning function @a -> Text@ into

385-- The situation of needing to turning function @a -> Text@ into

@@ -387,7 +388,7 @@ instance KeyValue Pair where

387--

388--

388-- > instance ToJSONKey Color where

389-- > instance ToJSONKey Color where

389-- > toJSONKey = toJSONKeyText (Text.pack . show)

390-- > toJSONKey = toJSONKeyText (Text.pack . show)

390−--

391+--

391-- The performance of the above instance can be improved by

392-- The performance of the above instance can be improved by

392-- not using 'String' as an intermediate step when converting to

393-- not using 'String' as an intermediate step when converting to

393-- 'Text'. One option for improving performance would be to use

394-- 'Text'. One option for improving performance would be to use

@@ -396,7 +397,7 @@ instance KeyValue Pair where

396-- builder) is generated by encoding the 'Text' to a 'ByteString',

397-- builder) is generated by encoding the 'Text' to a 'ByteString',

397-- an intermediate step that could be avoided. The fastest possible

398-- an intermediate step that could be avoided. The fastest possible

398-- implementation would be:

399-- implementation would be:

399−--

400+--

400-- > -- Assuming that OverloadedStrings is enabled

401-- > -- Assuming that OverloadedStrings is enabled

401-- > instance ToJSONKey Color where

402-- > instance ToJSONKey Color where

402-- > toJSONKey = ToJSONKeyText f g

403-- > toJSONKey = ToJSONKeyText f g

@@ -1163,21 +1164,6 @@ instance ( GToEncoding arity a

1163-- base

1164-- base

1164-------------------------------------------------------------------------------

1165-------------------------------------------------------------------------------

1165

1166

1166−instance ToJSON1 Identity where

1167− liftToJSON t _ (Identity a) = t a

1168− {-# INLINE liftToJSON #-}

1169−

1170− liftToEncoding t _ (Identity a) = t a

1171− {-# INLINE liftToEncoding #-}

1172−

1173−instance (ToJSON a) => ToJSON (Identity a) where

1174− toJSON = toJSON1

1175− {-# INLINE toJSON #-}

1176−

1177− toEncoding = toEncoding1

1178− {-# INLINE toEncoding #-}

1179−

1180−

1181instance ToJSON2 Const where

1167instance ToJSON2 Const where

1182 liftToJSON2 t _ _ _ (Const x) = t x

1168 liftToJSON2 t _ _ _ (Const x) = t x

1183 {-# INLINE liftToJSON2 #-}

1169 {-# INLINE liftToJSON2 #-}

@@ -1574,6 +1560,78 @@ instance (ToJSON a) => ToJSON (DList.DList a) where

1574 toEncoding = toEncoding1

1560 toEncoding = toEncoding1

1575 {-# INLINE toEncoding #-}

1561 {-# INLINE toEncoding #-}

1576

1562

1563+-------------------------------------------------------------------------------

1564+-- transformers - Functors

1565+-------------------------------------------------------------------------------

1566+

1567+instance ToJSON1 Identity where

1568+ liftToJSON t _ (Identity a) = t a

1569+ {-# INLINE liftToJSON #-}

1570+

1571+ liftToJSONList _ tl xs = tl (map runIdentity xs)

1572+ {-# INLINE liftToJSONList #-}

1573+

1574+ liftToEncoding t _ (Identity a) = t a

1575+ {-# INLINE liftToEncoding #-}

1576+

1577+ liftToEncodingList _ tl xs = tl (map runIdentity xs)

1578+ {-# INLINE liftToEncodingList #-}

1579+

1580+instance (ToJSON a) => ToJSON (Identity a) where

1581+ toJSON = toJSON1

1582+ {-# INLINE toJSON #-}

1583+

1584+ toJSONList = liftToJSONList toJSON toJSONList

1585+ {-# INLINE toJSONList #-}

1586+

1587+ toEncoding = toEncoding1

1588+ {-# INLINE toEncoding #-}

1589+

1590+ toEncodingList = liftToEncodingList toEncoding toEncodingList

1591+ {-# INLINE toEncodingList #-}

1592+

1593+instance (ToJSONKey a, ToJSON a) => ToJSONKey (Identity a) where

1594+ toJSONKey = contramapToJSONKeyFunction runIdentity toJSONKey

1595+

1596+

1597+instance (ToJSON1 f, ToJSON1 g) => ToJSON1 (Compose f g) where

1598+ liftToJSON tv tvl (Compose x) = liftToJSON g gl x

1599+ where

1600+ g = liftToJSON tv tvl

1601+ gl = liftToJSONList tv tvl

1602+ {-# INLINE liftToJSON #-}

1603+

1604+ liftToJSONList te tel xs = liftToJSONList g gl (map getCompose xs)

1605+ where

1606+ g = liftToJSON te tel

1607+ gl = liftToJSONList te tel

1608+ {-# INLINE liftToJSONList #-}

1609+

1610+ liftToEncoding te tel (Compose x) = liftToEncoding g gl x

1611+ where

1612+ g = liftToEncoding te tel

1613+ gl = liftToEncodingList te tel

1614+ {-# INLINE liftToEncoding #-}

1615+

1616+ liftToEncodingList te tel xs = liftToEncodingList g gl (map getCompose xs)

1617+ where

1618+ g = liftToEncoding te tel

1619+ gl = liftToEncodingList te tel

1620+ {-# INLINE liftToEncodingList #-}

1621+

1622+instance (ToJSON1 f, ToJSON1 g, ToJSON a) => ToJSON (Compose f g a) where

1623+ toJSON = toJSON1

1624+ {-# INLINE toJSON #-}

1625+

1626+ toJSONList = liftToJSONList toJSON toJSONList

1627+ {-# INLINE toJSONList #-}

1628+

1629+ toEncoding = toEncoding1

1630+ {-# INLINE toEncoding #-}

1631+

1632+ toEncodingList = liftToEncodingList toEncoding toEncodingList

1633+ {-# INLINE toEncodingList #-}

1634+

1577-------------------------------------------------------------------------------

1635-------------------------------------------------------------------------------

1578-- containers

1636-- containers

1579-------------------------------------------------------------------------------

1637-------------------------------------------------------------------------------

@@ -1954,9 +2012,6 @@ instance ToJSONKey Char where

1954instance (ToJSONKey a, ToJSON a) => ToJSONKey [a] where

2012instance (ToJSONKey a, ToJSON a) => ToJSONKey [a] where

1955 toJSONKey = toJSONKeyList

2013 toJSONKey = toJSONKeyList

1956

2014

1957−instance (ToJSONKey a, ToJSON a) => ToJSONKey (Identity a) where

1958− toJSONKey = contramapToJSONKeyFunction runIdentity toJSONKey

1959−

1960-------------------------------------------------------------------------------

2015-------------------------------------------------------------------------------

1961-- Tuple instances, see tuple-instances-to.hs

2016-- Tuple instances, see tuple-instances-to.hs

1962-------------------------------------------------------------------------------

2017-------------------------------------------------------------------------------

aeson.cabal+3−1

@@ -174,7 +174,9 @@ test-suite tests

174 quickcheck-instances >=0.3.12

175

176 if !impl(ghc >= 8.0)

177+ build-depends:

177− build-depends: semigroups >= 0.16.1 && < 0.19

178+ semigroups >= 0.16.1 && < 0.19,

179+ transformers >= 0.2.2.0

178

180

179 if !impl(ghc >= 7.10)

181 if !impl(ghc >= 7.10)

180 build-depends: nats >=1 && <1.2

182 build-depends: nats >=1 && <1.2

tests/Instances.hs+24−1

@@ -1,5 +1,6 @@

1{-# LANGUAGE CPP #-}

2{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE RecordWildCards #-}

5{-# LANGUAGE RecordWildCards #-}

5{-# LANGUAGE StandaloneDeriving #-}

6{-# LANGUAGE StandaloneDeriving #-}

@@ -23,8 +24,11 @@ import Data.Aeson.Types

23import Control.Applicative (Const(..), empty)

24import Control.Applicative (Const(..), empty)

24import Data.Tagged (Tagged(..))

25import Data.Tagged (Tagged(..))

25import Data.Proxy (Proxy(..))

26import Data.Proxy (Proxy(..))

27+import Data.Functor.Identity (Identity (..))

28+import Data.Functor.Compose (Compose (..))

26import Functions

29import Functions

27import qualified Data.DList as DList

30import qualified Data.DList as DList

31+import qualified Data.HashMap.Strict as HM

29import Data.Orphans ()

33import Data.Orphans ()

30import Test.QuickCheck.Instances ()

34import Test.QuickCheck.Instances ()

@@ -57,8 +61,20 @@ instance ApproxEq UTCTime where

57instance ApproxEq DotNetTime where

61instance ApproxEq DotNetTime where

58 (=~) = (=~) `on` fromDotNetTime

62 (=~) = (=~) `on` fromDotNetTime

64+instance ApproxEq Float where

65+ a =~ b

66+ | isNaN a && isNaN b = True

67+ | otherwise = approxEq a b

68+

60instance ApproxEq Double where

69instance ApproxEq Double where

70+ a =~ b

71+ | isNaN a && isNaN b = True

61− (=~) = approxEq

72+ | otherwise = approxEq a b

73+

74+instance (ApproxEq k, Eq v) => ApproxEq (HM.HashMap k v) where

75+ a =~ b = and $ zipWith eq (HM.toList a) (HM.toList b)

76+ where

77+ eq (x,y) (u,v) = x =~ u && y == v

63-- Test-related types.

79-- Test-related types.

@@ -180,3 +196,10 @@ instance Arbitrary a => Arbitrary (Const a b) where

180

196

181instance Arbitrary a => Arbitrary (DList.DList a) where

197instance Arbitrary a => Arbitrary (DList.DList a) where

182 arbitrary = DList.fromList <$> arbitrary

198 arbitrary = DList.fromList <$> arbitrary

199+

200+-- would like to have -- https://github.com/nick8325/quickcheck/issues/73

201+instance Arbitrary a => Arbitrary (Identity a) where

202+ arbitrary = Identity <$> arbitrary

203+

204+instance Arbitrary (f (g a)) => Arbitrary (Compose f g a) where

205+ arbitrary = Compose <$> arbitrary

tests/Properties.hs+40

@@ -1,5 +1,8 @@

1{-# LANGUAGE CPP, OverloadedStrings, ScopedTypeVariables #-}

3+-- For Arbitrary Compose

4+{-# LANGUAGE FlexibleContexts #-}

3module Properties where

6module Properties where

5import Prelude ()

8import Prelude ()

@@ -16,6 +19,7 @@ import Data.Sequence (Seq)

16import Data.DList (DList)

19import Data.DList (DList)

17import Data.Hashable (Hashable)

20import Data.Hashable (Hashable)

18import Data.HashMap.Strict (HashMap)

21import Data.HashMap.Strict (HashMap)

22+import Data.Functor.Compose (Compose (..))

19import Data.Map (Map)

23import Data.Map (Map)

20import Data.Ratio (Ratio)

24import Data.Ratio (Ratio)

21import Data.List.NonEmpty (NonEmpty)

25import Data.List.NonEmpty (NonEmpty)

@@ -137,6 +141,7 @@ isObjectWithSingleField _ = False

137

141

138--------------------------------------------------------------------------------

142--------------------------------------------------------------------------------

139

143

144+

140tests :: Test

145tests :: Test

141tests = testGroup "properties" [

146tests = testGroup "properties" [

142 testGroup "encode" [

147 testGroup "encode" [

@@ -169,6 +174,41 @@ tests = testGroup "properties" [

169 , testProperty "Seq" $ roundTripEq (undefined :: Seq Int)

174 , testProperty "Seq" $ roundTripEq (undefined :: Seq Int)

170 , testProperty "Rational" $ roundTripEq (undefined :: Rational)

175 , testProperty "Rational" $ roundTripEq (undefined :: Rational)

171 , testProperty "Ratio Int" $ roundTripEq (undefined :: Ratio Int)

176 , testProperty "Ratio Int" $ roundTripEq (undefined :: Ratio Int)

177+ , testGroup "functors"

178+ [ testProperty "Identity Char" $ roundTripEq (undefined :: I Int)

179+

180+ , testProperty "Identity Char" $ roundTripEq (undefined :: I Char)

181+ , testProperty "Identity [Char]" $ roundTripEq (undefined :: I [Char])

182+ , testProperty "[Identity Char]" $ roundTripEq (undefined :: [I Char])

183+

184+ , testProperty "Compose I I Int" $ roundTripEq (undefined :: Compose I I Int)

185+ , testProperty "Compose [] I Int" $ roundTripEq (undefined :: Compose [] I Int)

186+ , testProperty "Compose I [] Int" $ roundTripEq (undefined :: Compose I [] Int)

187+ , testProperty "Compose [] [] Int" $ roundTripEq (undefined :: Compose [] [] Int)

188+

189+ , testProperty "Compose I I Char" $ roundTripEq (undefined :: Compose I I Char)

190+ , testProperty "Compose [] I Char" $ roundTripEq (undefined :: Compose [] I Char)

191+ , testProperty "Compose I [] Char" $ roundTripEq (undefined :: Compose I [] Char)

192+ , testProperty "Compose [] [] Char" $ roundTripEq (undefined :: Compose [] [] Char)

193+

194+ , testProperty "Compose3 I I I Char" $ roundTripEq (undefined :: Compose3 I I I Char)

195+ , testProperty "Compose3 I [] I Char" $ roundTripEq (undefined :: Compose3 I [] I Char)

196+ , testProperty "Compose3 I I [] Char" $ roundTripEq (undefined :: Compose3 I I [] Char)

197+ , testProperty "Compose3 I [] [] Char" $ roundTripEq (undefined :: Compose3 I [] [] Char)

198+ , testProperty "Compose3 [] I I Char" $ roundTripEq (undefined :: Compose3 [] I I Char)

199+ , testProperty "Compose3 [] [] I Char" $ roundTripEq (undefined :: Compose3 [] [] I Char)

200+ , testProperty "Compose3 [] I [] Char" $ roundTripEq (undefined :: Compose3 [] I [] Char)

201+ , testProperty "Compose3 [] [] [] Char" $ roundTripEq (undefined :: Compose3 [] [] [] Char)

202+

203+ , testProperty "Compose3' I I I Char" $ roundTripEq (undefined :: Compose3' I I I Char)

204+ , testProperty "Compose3' I [] I Char" $ roundTripEq (undefined :: Compose3' I [] I Char)

205+ , testProperty "Compose3' I I [] Char" $ roundTripEq (undefined :: Compose3' I I [] Char)

206+ , testProperty "Compose3' I [] [] Char" $ roundTripEq (undefined :: Compose3' I [] [] Char)

207+ , testProperty "Compose3' [] I I Char" $ roundTripEq (undefined :: Compose3' [] I I Char)

208+ , testProperty "Compose3' [] [] I Char" $ roundTripEq (undefined :: Compose3' [] [] I Char)

209+ , testProperty "Compose3' [] I [] Char" $ roundTripEq (undefined :: Compose3' [] I [] Char)

210+ , testProperty "Compose3' [] [] [] Char" $ roundTripEq (undefined :: Compose3' [] [] [] Char)

211+ ]

172 , testGroup "ghcGenerics" [

212 , testGroup "ghcGenerics" [

173 testProperty "OneConstructor" $ roundTripEq OneConstructor

213 testProperty "OneConstructor" $ roundTripEq OneConstructor

174 , testProperty "Product2" $ roundTripEq (undefined :: Product2 Int Bool)

214 , testProperty "Product2" $ roundTripEq (undefined :: Product2 Int Bool)

tests/Types.hs+6

@@ -12,6 +12,12 @@ import Data.Data

12import Data.Text

13import GHC.Generics

14import Test.QuickCheck (Property, counterexample)

15+import Data.Functor.Compose (Compose (..))

16+import Data.Functor.Identity (Identity (..))

17+

18+type I = Identity

19+type Compose3 f g h = Compose (Compose f g) h

20+type Compose3' f g h = Compose f (Compose g h)

16data Foo = Foo {

22data Foo = Foo {

17 fooInt :: Int

23 fooInt :: Int

tests/UnitTests.hs+85−22

@@ -1,4 +1,4 @@

1−{-# LANGUAGE CPP, DeriveGeneric, OverloadedStrings, ScopedTypeVariables, TemplateHaskell, GeneralizedNewtypeDeriving #-}

1+{-# LANGUAGE CPP, GADTs, DeriveGeneric, OverloadedStrings, ScopedTypeVariables, TemplateHaskell, GeneralizedNewtypeDeriving #-}

2#if __GLASGOW_HASKELL__ >= 708

3{-# LANGUAGE DataKinds #-}

4#endif

@@ -10,6 +10,9 @@ module UnitTests (ioTests, tests) where

10import Prelude ()

11import Prelude.Compat

13+import Types (I, Compose3, Compose3', Approx(..))

14+import Instances ()

15+

13import Control.Applicative (Const(..))

16import Control.Applicative (Const(..))

14import Control.Monad (forM)

17import Control.Monad (forM)

15import Data.Aeson (FromJSONKeyFunction(..), FromJSONKey(..), decode, eitherDecode, encode, genericToJSON, genericToEncoding, object, FromJSON(..), withObject, (.=), (.:), (.:?), (.:!))

18import Data.Aeson (FromJSONKeyFunction(..), FromJSONKey(..), decode, eitherDecode, encode, genericToJSON, genericToEncoding, object, FromJSON(..), withObject, (.=), (.:), (.:?), (.:!))

@@ -20,6 +23,8 @@ import Data.Aeson.Types (ToJSON(..), Value, camelTo, camelTo2, defaultOptions, o

20import Data.Char (toUpper)

23import Data.Char (toUpper)

21import Data.Hashable (hash)

24import Data.Hashable (hash)

22import Data.List.NonEmpty (NonEmpty(..))

25import Data.List.NonEmpty (NonEmpty(..))

26+import Data.Functor.Compose (Compose (..))

27+import Data.Functor.Identity (Identity (..))

23import Data.Maybe (fromMaybe)

28import Data.Maybe (fromMaybe)

24import Data.Proxy (Proxy(..))

29import Data.Proxy (Proxy(..))

25import Data.Sequence (Seq)

30import Data.Sequence (Seq)

@@ -70,6 +75,7 @@ tests = testGroup "unit" [

70 , testGroup ".:, .:?, .:!" $ fmap (testCase "-") dotColonMark

75 , testGroup ".:, .:?, .:!" $ fmap (testCase "-") dotColonMark

71 , testGroup "To JSON representation" $ fmap (testCase "-") jsonEncoding

76 , testGroup "To JSON representation" $ fmap (testCase "-") jsonEncoding

72 , testGroup "From JSON representation" $ fmap (testCase "-") jsonDecoding

77 , testGroup "From JSON representation" $ fmap (testCase "-") jsonDecoding

78+ , testGroup "To/From JSON representation" $ fmap assertJsonExample jsonExamples

73 , testGroup "JSONPath" $ fmap (testCase "-") jsonPath

79 , testGroup "JSONPath" $ fmap (testCase "-") jsonPath

74 , testGroup "Hashable laws" $ fmap (testCase "-") hashableLaws

80 , testGroup "Hashable laws" $ fmap (testCase "-") hashableLaws

75 , testGroup "Issue #351" $ fmap (testCase "-") issue351

81 , testGroup "Issue #351" $ fmap (testCase "-") issue351

@@ -234,31 +240,88 @@ dotColonMark = [

234-----------------------------------------------------------------------------

240-----------------------------------------------------------------------------

235

241

236jsonEncoding :: [Assertion]

242jsonEncoding :: [Assertion]

237−jsonEncoding = [

243+jsonEncoding =

244+ [

245+ -- https://github.com/bos/aeson/issues/376

246+ assertEqual "Just Nothing" "null" $ encode (Just Nothing :: Maybe (Maybe Int))

247+ -- infinities cannot be recovered, null is decoded as NaN

248+ , assertEqual "inf :: Double" "null" $ encode (Approx $ 1/0 :: Approx Double)

249+ ]

250+

251+data Example where

252+ Example

253+ :: (Eq a, Show a, ToJSON a, FromJSON a)

254+ => String -> L.ByteString -> a -> Example

255+

256+assertJsonExample :: Example -> Test

257+assertJsonExample (Example name bs val) = testCase name $ do

258+ assertEqual "encode" bs (encode val)

259+ assertEqual "decode" (Just val) (decode bs)

260+

261+jsonExamples :: [Example]

262+jsonExamples =

263+ [

238− assertEqual "Either Left" "{\"Left\":1}" $ encode (Left 1 :: Either Int Int)

264+ Example "Either Left" "{\"Left\":1}" (Left 1 :: Either Int Int)

239− , assertEqual "Either Right" "{\"Right\":1}" $ encode (Right 1 :: Either Int Int)

265+ , Example "Either Right" "{\"Right\":1}" (Right 1 :: Either Int Int)

240− , assertEqual "Nothing" "null" $ encode (Nothing :: Maybe Int)

266+ , Example "Nothing" "null" (Nothing :: Maybe Int)

241− , assertEqual "Just" "1" $ encode (Just 1 :: Maybe Int)

267+ , Example "Just" "1" (Just 1 :: Maybe Int)

242− , assertEqual "Just Nothing" "null" $ encode (Just Nothing :: Maybe (Maybe Int))

243− , assertEqual "Proxy Int" "null" $ encode (Proxy :: Proxy Int)

268+ , Example "Proxy Int" "null" (Proxy :: Proxy Int)

244− , assertEqual "Tagged Char Int" "1" $ encode (Tagged 1 :: Tagged Char Int)

269+ , Example "Tagged Char Int" "1" (Tagged 1 :: Tagged Char Int)

245#if __GLASGOW_HASKELL__ >= 708

270#if __GLASGOW_HASKELL__ >= 708

246 -- Test Tagged instance is polykinded

271 -- Test Tagged instance is polykinded

247− , assertEqual "Tagged 123 Int" "1" $ encode (Tagged 1 :: Tagged 123 Int)

272+ , Example "Tagged 123 Int" "1" (Tagged 1 :: Tagged 123 Int)

248#endif

273#endif

249− , assertEqual "Const Char Int" "\"c\"" $ encode (Const 'c' :: Const Char Int)

274+ , Example "Const Char Int" "\"c\"" (Const 'c' :: Const Char Int)

250− , assertEqual "Tuple" "[1,2]" $ encode ((1, 2) :: (Int, Int))

275+ , Example "Tuple" "[1,2]" ((1, 2) :: (Int, Int))

251− , assertEqual "NonEmpty" "[1,2,3]" $ encode (1 :| [2, 3] :: NonEmpty Int)

276+ , Example "NonEmpty" "[1,2,3]" (1 :| [2, 3] :: NonEmpty Int)

252− , assertEqual "Seq" "[1,2,3]" $ encode (Seq.fromList [1, 2, 3] :: Seq.Seq Int)

277+ , Example "Seq" "[1,2,3]" (Seq.fromList [1, 2, 3] :: Seq.Seq Int)

253− , assertEqual "DList" "[1,2,3]" $ encode (DList.fromList [1, 2, 3] :: DList.DList Int)

278+ , Example "DList" "[1,2,3]" (DList.fromList [1, 2, 3] :: DList.DList Int)

254− , assertEqual "()" "[]" $ encode ()

279+ , Example "()" "[]" ()

255− , assertEqual "HashMap Int Int" "{\"0\":1,\"2\":3}" $ encode (HM.fromList [(0,1),(2,3)] :: HM.HashMap Int Int)

280+ , Example "HashMap Int Int" "{\"0\":1,\"2\":3}" (HM.fromList [(0,1),(2,3)] :: HM.HashMap Int Int)

256− , assertEqual "nan :: Double" "null" $ encode (0/0 :: Double)

281+ , Example "nan :: Double" "null" (Approx $ 0/0 :: Approx Double)

257− , assertEqual "inf :: Double" "null" $ encode (1/0 :: Double)

258 -- Three separate cases, as ordering in HashMap is not defined

282 -- Three separate cases, as ordering in HashMap is not defined

259− , assertEqual "HashMap Float Int, NaN" "{\"NaN\":1}" $ encode (HM.singleton (0/0) 1 :: HM.HashMap Float Int)

283+ , Example "HashMap Float Int, NaN" "{\"NaN\":1}" (Approx $ HM.singleton (0/0) 1 :: Approx (HM.HashMap Float Int))

260− , assertEqual "HashMap Float Int, Infinity" "{\"Infinity\":1}" $ encode (HM.singleton (1/0) 1 :: HM.HashMap Float Int)

284+ , Example "HashMap Float Int, Infinity" "{\"Infinity\":1}" (HM.singleton (1/0) 1 :: HM.HashMap Float Int)

261− , assertEqual "HashMap Float Int, +Infinity" "{\"-Infinity\":1}" $ encode (HM.singleton (negate 1/0) 1 :: HM.HashMap Float Int)

285+ , Example "HashMap Float Int, +Infinity" "{\"-Infinity\":1}" (HM.singleton (negate 1/0) 1 :: HM.HashMap Float Int)

286+

287+ -- Functors

288+ , Example "Identity Int" "1" (pure 1 :: Identity Int)

289+

290+ , Example "Identity Char" "\"x\"" (pure 'x' :: Identity Char)

291+ , Example "Identity String" "\"foo\"" (pure "foo" :: Identity String)

292+ , Example "[Identity Char]" "\"xy\"" ([pure 'x', pure 'y'] :: [Identity Char])

293+

294+ , Example "Maybe Char" "\"x\"" (pure 'x' :: Maybe Char)

295+ , Example "Maybe String" "\"foo\"" (pure "foo" :: Maybe String)

296+ , Example "Maybe [Identity Char]" "\"xy\"" (pure [pure 'x', pure 'y'] :: Maybe [Identity Char])

297+

298+ , Example "Compose I I Int" "1" (pure 1 :: Compose I I Int)

299+ , Example "Compose I [] Int" "[1]" (pure 1 :: Compose I [] Int)

300+ , Example "Compose [] I Int" "[1]" (pure 1 :: Compose [] I Int)

301+ , Example "Compose [] [] Int" "[[1]]" (pure 1 :: Compose [] [] Int)

302+

303+ , Example "Compose I I Char" "\"x\"" (pure 'x' :: Compose I I Char)

304+ , Example "Compose I [] Char" "\"x\"" (pure 'x' :: Compose I [] Char)

305+ , Example "Compose [] I Char" "\"x\"" (pure 'x' :: Compose [] I Char)

306+ , Example "Compose [] [] Char" "[\"x\"]" (pure 'x' :: Compose [] [] Char)

307+

308+ , Example "Compose3 I I I Char" "\"x\"" (pure 'x' :: Compose3 I I I Char)

309+ , Example "Compose3 I I [] Char" "\"x\"" (pure 'x' :: Compose3 I I [] Char)

310+ , Example "Compose3 I [] I Char" "\"x\"" (pure 'x' :: Compose3 I [] I Char)

311+ , Example "Compose3 I [] [] Char" "[\"x\"]" (pure 'x' :: Compose3 I [] [] Char)

312+ , Example "Compose3 [] I I Char" "\"x\"" (pure 'x' :: Compose3 [] I I Char)

313+ , Example "Compose3 [] I [] Char" "[\"x\"]" (pure 'x' :: Compose3 [] I [] Char)

314+ , Example "Compose3 [] [] I Char" "[\"x\"]" (pure 'x' :: Compose3 [] [] I Char)

315+ , Example "Compose3 [] [] [] Char" "[[\"x\"]]" (pure 'x' :: Compose3 [] [] [] Char)

316+

317+ , Example "Compose3' I I I Char" "\"x\"" (pure 'x' :: Compose3' I I I Char)

318+ , Example "Compose3' I I [] Char" "\"x\"" (pure 'x' :: Compose3' I I [] Char)

319+ , Example "Compose3' I [] I Char" "\"x\"" (pure 'x' :: Compose3' I [] I Char)

320+ , Example "Compose3' I [] [] Char" "[\"x\"]" (pure 'x' :: Compose3' I [] [] Char)

321+ , Example "Compose3' [] I I Char" "\"x\"" (pure 'x' :: Compose3' [] I I Char)

322+ , Example "Compose3' [] I [] Char" "[\"x\"]" (pure 'x' :: Compose3' [] I [] Char)

323+ , Example "Compose3' [] [] I Char" "[\"x\"]" (pure 'x' :: Compose3' [] [] I Char)

324+ , Example "Compose3' [] [] [] Char" "[[\"x\"]]" (pure 'x' :: Compose3' [] [] [] Char)

262 ]

325 ]

263

326

264jsonDecoding :: [Assertion]

327jsonDecoding :: [Assertion]