Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Fix for generic toJSON and parseJSON

The bug was caused by an incorrect assumption that products where build in a right associative way where in reallity they have a tree shape.
  • Loading branch information...
commit 3755b1722fdc5a73ed889d7aa67a10debb382440 1 parent c8a0c5f
@basvandijk basvandijk authored
Showing with 91 additions and 76 deletions.
  1. +90 −75 Data/Aeson/Types/Internal.hs
  2. +1 −1  aeson.cabal
View
165 Data/Aeson/Types/Internal.hs
@@ -896,83 +896,126 @@ class GFromJSON f where
--------------------------------------------------------------------------------
--- | Meta-information is stripped:
instance (GToJSON a) => GToJSON (M1 i c a) where
gToJSON = gToJSON . unM1
--- | Meta-information is added:
instance (GFromJSON a) => GFromJSON (M1 i c a) where
gParseJSON = fmap M1 . gParseJSON
+--------------------------------------------------------------------------------
--- | Constants are converted using toJSON:
instance (ToJSON a) => GToJSON (K1 i a) where
gToJSON = toJSON . unK1
--- | Constants are parsed using parseJSON:
instance (FromJSON a) => GFromJSON (K1 i a) where
gParseJSON = fmap K1 . parseJSON
+--------------------------------------------------------------------------------
--- | Constructors without arguments are converted to the empty array:
instance GToJSON U1 where
gToJSON _ = emptyArray
--- | Constructors without arguments must be represented by the empty array:
instance GFromJSON U1 where
gParseJSON v
| isEmptyArray v = pure U1
| otherwise = typeMismatch "unary constructor (U1)" v
+--------------------------------------------------------------------------------
+
+instance (Constructor c, GRecordToObject a, GToJSON a) => GToJSON (C1 c a) where
+ gToJSON m1@(M1 x)
+ | conIsRecord m1 = Object $ gRecordToObject x
+ | otherwise = gToJSON x
+
+instance (Constructor c, GFromRecord a, GFromJSON a) => GFromJSON (C1 c a) where
+ gParseJSON v
+ | conIsRecord (undefined :: t c a p) =
+ case v of
+ Object obj -> M1 <$> gParseRecord obj
+ _ -> typeMismatch "record (:*:)" v
+ | otherwise = M1 <$> gParseJSON v
+
+--------------------------------------------------------------------------------
+
+instance (GProductToValues a, GProductToValues b) => GToJSON (a :*: b) where
+ gToJSON = toJSON . toList . gProductToValues
+
+instance (GFromProduct a, GFromProduct b) => GFromJSON (a :*: b) where
+ gParseJSON (Array arr) = gParseProduct arr
+ gParseJSON v = typeMismatch "product (:*:)" v
+
+--------------------------------------------------------------------------------
--- | Each value of a sum type is converted to an object
--- with a single key-value association where the key is the name of the constructor:
instance (GObject a, GObject b) => GToJSON (a :+: b) where
gToJSON (L1 x) = Object $ gObject x
gToJSON (R1 x) = Object $ gObject x
--- | A sum type must be represented by an object with a single key-value association.
--- When this is the case, the sum will be recursively parsed using gParseSum:
instance (GFromSum a, GFromSum b) => GFromJSON (a :+: b) where
gParseJSON (Object (M.toList -> [keyVal])) = gParseSum keyVal
gParseJSON v = typeMismatch "sum (:+:)" v
+--------------------------------------------------------------------------------
--- | Product types without field names are flattened and converted to an array:
-instance (GToJSON a, Flatten b) => GToJSON (S1 NoSelector a :*: b) where
- gToJSON = toJSON . flatten
+class GFromRecord f where
+ gParseRecord :: Object -> Parser (f a)
--- | Product types without field names must be represented as an array.
--- When this is the case the product will be recursively parsed sing gParseProduct:
-instance (GFromJSON a, GFromProduct b) => GFromJSON (S1 NoSelector a :*: b) where
- gParseJSON (Array arr) = gParseProduct arr 0
- gParseJSON v = typeMismatch "product (:*:)" v
+instance (GFromRecord a, GFromRecord b) => GFromRecord (a :*: b) where
+ gParseRecord obj = (:*:) <$> gParseRecord obj <*> gParseRecord obj
+
+instance (Selector s, GFromJSON a) => GFromRecord (S1 s a) where
+ gParseRecord obj = case M.lookup (T.pack key) obj of
+ Nothing -> notFound key
+ Just v -> gParseJSON v
+ where
+ key = selName (undefined :: t s a p)
+
+instance GFromRecord (a :+: b) where gParseRecord = undefined
+instance GFromRecord U1 where gParseRecord = undefined
+instance GFromRecord (K1 i c) where gParseRecord = undefined
+instance GFromRecord (M1 i c f) where gParseRecord = undefined
+
+--------------------------------------------------------------------------------
+class GRecordToObject f where
+ gRecordToObject :: f a -> Object
--- | Other product types, so the ones with field names (records),
--- are converted to a single object.
-instance (GObject a, GObject b) => GToJSON (a :*: b) where
- gToJSON = Object . gObject
+instance (GRecordToObject a, GRecordToObject b) => GRecordToObject (a :*: b) where
+ gRecordToObject (a :*: b) = gRecordToObject a `M.union` gRecordToObject b
--- | Product types with field names (records) must be represented as a single object.
--- If this is the case the product will be recursively parsed using gParseRecord.
-instance (GFromRecord a, GFromRecord b) => GFromJSON (a :*: b) where
- gParseJSON (Object obj) = gParseRecord obj
- gParseJSON v = typeMismatch "record (:*:)" v
+instance (Selector s, GToJSON a) => GRecordToObject (S1 s a) where
+ gRecordToObject m1 = M.singleton (pack (selName m1)) (gToJSON (unM1 m1))
+
+instance GRecordToObject (a :+: b) where gRecordToObject = undefined
+instance GRecordToObject U1 where gRecordToObject = undefined
+instance GRecordToObject (K1 i c) where gRecordToObject = undefined
+instance GRecordToObject (M1 i c f) where gRecordToObject = undefined
--------------------------------------------------------------------------------
--- | Flatten /flattens/ a product type. For example:
--- a :*: (b :*: (c :*: d)) is converted to:
--- [gToJSON a, gToJSON b, gToJSON c, gToJSON d]
-class Flatten f where
- flatten :: f a -> [Value]
+class GProductToValues f where
+ gProductToValues :: f a -> DList Value
+
+instance (GProductToValues a, GProductToValues b) => GProductToValues (a :*: b) where
+ gProductToValues (a :*: b) = gProductToValues a `append` gProductToValues b
+
+instance (GToJSON a) => GProductToValues a where
+ gProductToValues = singleton . gToJSON
+
+--------------------------------------------------------------------------------
+
+class GFromProduct f where
+ gParseProduct :: Array -> Parser (f a)
+
+instance (GFromProduct a, GFromProduct b) => GFromProduct (a :*: b) where
+ gParseProduct arr = (:*:) <$> gParseProduct arrL <*> gParseProduct arrR
+ where
+ (arrL, arrR) = V.splitAt (V.length arr `div` 2) arr
-instance (GToJSON a, Flatten b) => Flatten (S1 NoSelector a :*: b) where
- flatten (m1 :*: r) = gToJSON m1 : flatten r
+instance (GFromJSON a) => GFromProduct (S1 NoSelector a) where
+ gParseProduct ((!? 0) -> Just v) = gParseJSON v
+ gParseProduct _ = fail "Array to small"
-instance (GToJSON a) => Flatten (S1 NoSelector a) where
- flatten m1 = [gToJSON $ unM1 m1]
+instance GFromProduct (M1 i c f) where gParseProduct = undefined
--------------------------------------------------------------------------------
@@ -983,17 +1026,8 @@ instance (GObject a, GObject b) => GObject (a :+: b) where
gObject (L1 x) = gObject x
gObject (R1 x) = gObject x
-instance (GObject a, GObject b) => GObject (a :*: b) where
- gObject (a :*: b) = gObject a `M.union` gObject b
-
-instance (Selector s, GToJSON a) => GObject (S1 s a) where
- gObject = objectNamed selName
-
-instance (Constructor c, GToJSON a) => GObject (C1 c a) where
- gObject = objectNamed conName
-
-objectNamed :: GToJSON f => (M1 i c f p -> String) -> M1 i c f p -> Object
-objectNamed getName m1 = M.singleton (pack (getName m1)) (gToJSON (unM1 m1))
+instance (Constructor c, GToJSON a, GRecordToObject a) => GObject (C1 c a) where
+ gObject m1 = M.singleton (pack (conName m1)) (gToJSON m1)
--------------------------------------------------------------------------------
@@ -1001,9 +1035,9 @@ class GFromSum f where
gParseSum :: Pair -> Parser (f a)
instance (GFromSum a, GFromSum b) => GFromSum (a :+: b) where
- gParseSum keyVal = fmap L1 (gParseSum keyVal) <|> fmap R1 (gParseSum keyVal)
+ gParseSum keyVal = (L1 <$> gParseSum keyVal) <|> (R1 <$> gParseSum keyVal)
-instance (Constructor c, GFromJSON a) => GFromSum (C1 c a) where
+instance (Constructor c, GFromJSON a, GFromRecord a) => GFromSum (C1 c a) where
gParseSum (key, value)
| key == pack (conName (undefined :: t c a p)) = gParseJSON value
| otherwise = notFound $ unpack key
@@ -1013,35 +1047,16 @@ notFound key = fail $ "The key \"" ++ key ++ "\" was not found"
--------------------------------------------------------------------------------
-class GFromProduct f where
- gParseProduct :: Array -> Int -> Parser (f a)
+type DList a = [a] -> [a]
-instance (GFromJSON a, GFromProduct b) => GFromProduct (a :*: b) where
- gParseProduct arr ix =
- case arr !? ix of
- Nothing -> arrayToSmall ix
- Just v -> (:*:) <$> gParseJSON v <*> gParseProduct arr (ix+1)
+toList :: DList a -> [a]
+toList = ($ [])
-instance (GFromJSON a) => GFromProduct (S1 NoSelector a) where
- gParseProduct arr ix = case arr !? ix of
- Nothing -> arrayToSmall ix
- Just v -> gParseJSON v
+singleton :: a -> DList a
+singleton = (:)
-arrayToSmall :: Int -> Parser a
-arrayToSmall ix = fail $ "Expected an array of at least " ++ show ix ++ " values"
+append :: DList a -> DList a -> DList a
+append = (.)
--------------------------------------------------------------------------------
-
-class GFromRecord f where
- gParseRecord :: Object -> Parser (f a)
-
-instance (GFromRecord a, GFromRecord b) => GFromRecord (a :*: b) where
- gParseRecord obj = (:*:) <$> gParseRecord obj <*> gParseRecord obj
-
-instance (Selector s, GFromJSON a) => GFromRecord (S1 s a) where
- gParseRecord obj = case M.lookup (T.pack key) obj of
- Nothing -> notFound key
- Just v -> gParseJSON v
- where
- key = selName (undefined :: t s a p)
#endif
View
2  aeson.cabal
@@ -131,7 +131,7 @@ library
template-haskell >= 2.5,
time,
unordered-containers >= 0.1.3.0,
- vector >= 0.7
+ vector >= 0.7.1
if flag(developer)
ghc-options: -Werror
Please sign in to comment.
Something went wrong with that request. Please try again.