6ff3395 · typeable/aeson

git.iko.soy/typeable/aeson

on master help sign in

Add instances for Sum and Product, resolves #408

6ff3395Oleg Grenrus10 years ago

Data/Aeson/Types/FromJSON.hs+40−3

compare with master

unifiedsplit

@@ -84,6 +84,8 @@ import Data.Bits (unsafeShiftR)

84import Data.Fixed (Fixed, HasResolution)

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

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

87+import Data.Functor.Product (Product (..))

88+import Data.Functor.Sum (Sum (..))

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

89import Data.Hashable (Hashable (..))

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

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

89import Data.List.NonEmpty (NonEmpty (..))

91import Data.List.NonEmpty (NonEmpty (..))

@@ -991,6 +993,10 @@ instance FromJSON2 Either where

991 liftParseJSON2 pA _ pB _ (Object (H.toList -> [(key, value)]))

993 liftParseJSON2 pA _ pB _ (Object (H.toList -> [(key, value)]))

992 | key == left = Left <$> pA value <?> Key left

994 | key == left = Left <$> pA value <?> Key left

993 | key == right = Right <$> pB value <?> Key right

995 | key == right = Right <$> pB value <?> Key right

996+ where

997+ left, right :: Text

998+ left = "Left"

999+ right = "Right"

994

1000

995 liftParseJSON2 _ _ _ _ _ = fail $

1001 liftParseJSON2 _ _ _ _ _ = fail $

996 "expected an object with a single property " ++

1002 "expected an object with a single property " ++

@@ -1006,9 +1012,6 @@ instance (FromJSON a, FromJSON b) => FromJSON (Either a b) where

1006 parseJSON = parseJSON2

1012 parseJSON = parseJSON2

1007 {-# INLINE parseJSON #-}

1013 {-# INLINE parseJSON #-}

1008

1014

1009−left, right :: Text

1010−left = "Left"

1011−right = "Right"

1012

1015

1013

1016

1014instance FromJSON Bool where

1017instance FromJSON Bool where

@@ -1293,6 +1296,40 @@ instance (FromJSON1 f, FromJSON1 g, FromJSON a) => FromJSON (Compose f g a) wher

1293 parseJSONList = liftParseJSONList parseJSON parseJSONList

1296 parseJSONList = liftParseJSONList parseJSON parseJSONList

1294 {-# INLINE parseJSONList #-}

1297 {-# INLINE parseJSONList #-}

1295

1298

1299+

1300+instance (FromJSON1 f, FromJSON1 g) => FromJSON1 (Product f g) where

1301+ liftParseJSON p pl a = uncurry Pair <$> liftParseJSON2 px pxl py pyl a

1302+ where

1303+ px = liftParseJSON p pl

1304+ pxl = liftParseJSONList p pl

1305+ py = liftParseJSON p pl

1306+ pyl = liftParseJSONList p pl

1307+ {-# INLINE liftParseJSON #-}

1308+

1309+instance (FromJSON1 f, FromJSON1 g, FromJSON a) => FromJSON (Product f g a) where

1310+ parseJSON = parseJSON1

1311+ {-# INLINE parseJSON #-}

1312+

1313+

1314+instance (FromJSON1 f, FromJSON1 g) => FromJSON1 (Sum f g) where

1315+ liftParseJSON p pl (Object (H.toList -> [(key, value)]))

1316+ | key == inl = InL <$> liftParseJSON p pl value <?> Key inl

1317+ | key == inr = InR <$> liftParseJSON p pl value <?> Key inl

1318+ where

1319+ inl, inr :: Text

1320+ inl = "InL"

1321+ inr = "InR"

1322+

1323+ liftParseJSON _ _ _ = fail $

1324+ "expected an object with a single property " ++

1325+ "where the property key should be either " ++

1326+ "\"InL\" or \"InR\""

1327+ {-# INLINE liftParseJSON #-}

1328+

1329+instance (FromJSON1 f, FromJSON1 g, FromJSON a) => FromJSON (Sum f g a) where

1330+ parseJSON = parseJSON1

1331+ {-# INLINE parseJSON #-}

1332+

1296-------------------------------------------------------------------------------

1333-------------------------------------------------------------------------------

1297-- containers

1334-- containers

1298-------------------------------------------------------------------------------

1335-------------------------------------------------------------------------------

Data/Aeson/Types/ToJSON.hs+62−27

@@ -74,6 +74,8 @@ import Data.Fixed (Fixed, HasResolution)

74import Data.Foldable (toList)

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

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

77+import Data.Functor.Product (Product (..))

78+import Data.Functor.Sum (Sum (..))

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

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

78import Data.List (intersperse)

80import Data.List (intersperse)

79import Data.List.NonEmpty (NonEmpty (..))

81import Data.List.NonEmpty (NonEmpty (..))

@@ -94,27 +96,27 @@ import Foreign.Storable (Storable)

94import GHC.Generics

96import GHC.Generics

95import Numeric.Natural (Natural)

97import Numeric.Natural (Natural)

97−import qualified Data.ByteString.Lazy as L

99+import qualified Data.ByteString.Lazy as L

98−import qualified Data.DList as DList

100+import qualified Data.DList as DList

99−import qualified Data.HashMap.Strict as H

101+import qualified Data.HashMap.Strict as H

100−import qualified Data.HashSet as HashSet

102+import qualified Data.HashSet as HashSet

101−import qualified Data.IntMap as IntMap

103+import qualified Data.IntMap as IntMap

102−import qualified Data.IntSet as IntSet

104+import qualified Data.IntSet as IntSet

103−import qualified Data.List.NonEmpty as NE

105+import qualified Data.List.NonEmpty as NE

104−import qualified Data.Map as M

106+import qualified Data.Map as M

105−import qualified Data.Scientific as Scientific

107+import qualified Data.Scientific as Scientific

106−import qualified Data.Sequence as Seq

108+import qualified Data.Sequence as Seq

107−import qualified Data.Set as Set

109+import qualified Data.Set as Set

108−import qualified Data.Text as T

110+import qualified Data.Text as T

109−import qualified Data.Text.Encoding as T

111+import qualified Data.Text.Encoding as T

110−import qualified Data.Text.Lazy as LT

112+import qualified Data.Text.Lazy as LT

111−import qualified Data.Tree as Tree

113+import qualified Data.Tree as Tree

112−import qualified Data.Vector as V

114+import qualified Data.Vector as V

113−import qualified Data.Vector.Generic as VG

115+import qualified Data.Vector.Generic as VG

114−import qualified Data.Vector.Mutable as VM

116+import qualified Data.Vector.Mutable as VM

115−import qualified Data.Vector.Primitive as VP

117+import qualified Data.Vector.Primitive as VP

116−import qualified Data.Vector.Storable as VS

118+import qualified Data.Vector.Storable as VS

117−import qualified Data.Vector.Unboxed as VU

119+import qualified Data.Vector.Unboxed as VU

118

120

119toJSONPair :: (a -> Value) -> (b -> Value) -> (a, b) -> Value

121toJSONPair :: (a -> Value) -> (b -> Value) -> (a, b) -> Value

120toJSONPair a b = liftToJSON2 a (listValue a) b (listValue b)

122toJSONPair a b = liftToJSON2 a (listValue a) b (listValue b)

@@ -1204,8 +1206,8 @@ instance (ToJSON a) => ToJSON (Maybe a) where

1204

1206

1205

1207

1206instance ToJSON2 Either where

1208instance ToJSON2 Either where

1207− liftToJSON2 toA _ _toB _ (Left a) = Object $ H.singleton left (toA a)

1209+ liftToJSON2 toA _ _toB _ (Left a) = Object $ H.singleton "Left" (toA a)

1208− liftToJSON2 _toA _ toB _ (Right b) = Object $ H.singleton right (toB b)

1210+ liftToJSON2 _toA _ toB _ (Right b) = Object $ H.singleton "Right" (toB b)

1209 {-# INLINE liftToJSON2 #-}

1211 {-# INLINE liftToJSON2 #-}

1210

1212

1211 liftToEncoding2 toA _ _toB _ (Left a) = E.pairs $ E.pair "Left" $ toA a

1213 liftToEncoding2 toA _ _toB _ (Left a) = E.pairs $ E.pair "Left" $ toA a

@@ -1227,10 +1229,6 @@ instance (ToJSON a, ToJSON b) => ToJSON (Either a b) where

1227 toEncoding = toEncoding2

1229 toEncoding = toEncoding2

1228 {-# INLINE toEncoding #-}

1230 {-# INLINE toEncoding #-}

1229

1231

1230−left, right :: Text

1231−left = "Left"

1232−right = "Right"

1233−

1234

1232

1235instance ToJSON Bool where

1233instance ToJSON Bool where

1236 toJSON = Bool

1234 toJSON = Bool

@@ -1633,6 +1631,43 @@ instance (ToJSON1 f, ToJSON1 g, ToJSON a) => ToJSON (Compose f g a) where

1633 toEncodingList = liftToEncodingList toEncoding toEncodingList

1631 toEncodingList = liftToEncodingList toEncoding toEncodingList

1634 {-# INLINE toEncodingList #-}

1632 {-# INLINE toEncodingList #-}

1635

1633

1634+

1635+instance (ToJSON1 f, ToJSON1 g) => ToJSON1 (Product f g) where

1636+ liftToJSON tv tvl (Pair x y) = liftToJSON2 tx txl ty tyl (x, y)

1637+ where

1638+ tx = liftToJSON tv tvl

1639+ txl = liftToJSONList tv tvl

1640+ ty = liftToJSON tv tvl

1641+ tyl = liftToJSONList tv tvl

1642+

1643+ liftToEncoding te tel (Pair x y) = liftToEncoding2 tx txl ty tyl (x, y)

1644+ where

1645+ tx = liftToEncoding te tel

1646+ txl = liftToEncodingList te tel

1647+ ty = liftToEncoding te tel

1648+ tyl = liftToEncodingList te tel

1649+

1650+instance (ToJSON1 f, ToJSON1 g, ToJSON a) => ToJSON (Product f g a) where

1651+ toJSON = toJSON1

1652+ {-# INLINE toJSON #-}

1653+

1654+ toEncoding = toEncoding1

1655+ {-# INLINE toEncoding #-}

1656+

1657+instance (ToJSON1 f, ToJSON1 g) => ToJSON1 (Sum f g) where

1658+ liftToJSON tv tvl (InL x) = Object $ H.singleton "InL" (liftToJSON tv tvl x)

1659+ liftToJSON tv tvl (InR y) = Object $ H.singleton "InR" (liftToJSON tv tvl y)

1660+

1661+ liftToEncoding te tel (InL x) = E.pairs $ E.pair "InL" $ liftToEncoding te tel x

1662+ liftToEncoding te tel (InR y) = E.pairs $ E.pair "InR" $ liftToEncoding te tel y

1663+

1664+instance (ToJSON1 f, ToJSON1 g, ToJSON a) => ToJSON (Sum f g a) where

1665+ toJSON = toJSON1

1666+ {-# INLINE toJSON #-}

1667+

1668+ toEncoding = toEncoding1

1669+ {-# INLINE toEncoding #-}

1670+

1636-------------------------------------------------------------------------------

1671-------------------------------------------------------------------------------

1637-- containers

1672-- containers

1638-------------------------------------------------------------------------------

1673-------------------------------------------------------------------------------

aeson.cabal+3−1

@@ -112,6 +112,7 @@ library

112 build-depends:

113 semigroups >= 0.16.1 && < 0.19,

114 transformers >= 0.2.2.0,

115+ transformers-compat >= 0.3,

115 fail == 4.9.*

116 fail == 4.9.*

116

117

117 if !impl(ghc >= 7.10)

118 if !impl(ghc >= 7.10)

@@ -176,7 +177,8 @@ test-suite tests

176 if !impl(ghc >= 8.0)

177 if !impl(ghc >= 8.0)

177 build-depends:

178 build-depends:

178 semigroups >= 0.16.1 && < 0.19,

179 semigroups >= 0.16.1 && < 0.19,

179− transformers >= 0.2.2.0

180+ transformers >= 0.2.2.0,

181+ transformers-compat >= 0.3

180

182

181 if !impl(ghc >= 7.10)

183 if !impl(ghc >= 7.10)

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

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

tests/UnitTests.hs+10

@@ -24,6 +24,8 @@ import Data.Char (toUpper)

24import Data.Hashable (hash)

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

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

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

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

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

29import Data.Functor.Identity (Identity (..))

28import Data.Maybe (fromMaybe)

30import Data.Maybe (fromMaybe)

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

31import Data.Proxy (Proxy(..))

@@ -304,6 +306,14 @@ jsonExamples =

304 , Example "Maybe String" "\"foo\"" (pure "foo" :: Maybe String)

306 , Example "Maybe String" "\"foo\"" (pure "foo" :: Maybe String)

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

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

306

308

309+ , Example "Product I Maybe Int" "[1,2]" (Pair (pure 1) (pure 2) :: Product I Maybe Int)

310+ , Example "Product I Maybe Int" "[1,null]" (Pair (pure 1) Nothing :: Product I Maybe Int)

311+ , Example "Product I [] Char" "[\"a\",\"foo\"]" (Pair (pure 'a') "foo" :: Product I [] Char)

312+

313+ , Example "Sum I [] Int: InL" "{\"InL\":1}" (InL (pure 1) :: Sum I [] Int)

314+ , Example "Sum I [] Int: InR" "{\"InR\":[1,2]}" (InR [1, 2] :: Sum I [] Int)

315+ , Example "Sum I [] Char: InR" "{\"InR\":\"foo\"}" (InR "foo" :: Sum I [] Char)

316+

307 , Example "Compose I I Int" "1" (pure 1 :: Compose I I Int)

317 , Example "Compose I I Int" "1" (pure 1 :: Compose I I Int)

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

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

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

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