@@ -1,7 +1,15 @@
1−{-# LANGUAGE DefaultSignatures, EmptyDataDecls, FlexibleContexts,
2− FlexibleInstances, FunctionalDependencies, IncoherentInstances,
3− KindSignatures, OverlappingInstances, ScopedTypeVariables, TypeOperators,
4− UndecidableInstances, ViewPatterns #-}
1+{-# LANGUAGE DefaultSignatures
2+ , EmptyDataDecls
3+ , FlexibleInstances
4+ , FunctionalDependencies
5+ , KindSignatures
6+ , OverlappingInstances
7+ , ScopedTypeVariables
8+ , TypeOperators
9+ , UndecidableInstances
10+ , ViewPatterns
11+ #-}
12+
513{-# OPTIONS_GHC -fno-warn-orphans #-}
614
715-- |
@@ -18,10 +26,10 @@ module Data.Aeson.Types.Generic ( ) where
1826
1927import Control.Applicative
2028import Control.Monad.State.Strict
29+import Data.Bits (shiftR)
2130import Data.Aeson.Types.Class
2231import Data.Aeson.Types.Internal
2332import Data.Text (pack, unpack)
24−import Data.Vector ((!?))
2533import GHC.Generics
2634import qualified Data.Map as M
2735import qualified Data.Text as T
@@ -60,6 +68,8 @@ instance (GObject a, GObject b) => GToJSON (a :+: b) where
6068class ConsToJSON f where consToJSON :: f a -> Value
6169class ConsToJSON' b f where consToJSON' :: Tagged b (f a -> Value)
6270
71+newtype Tagged s b = Tagged {unTagged :: b}
72+
6373instance (IsRecord f b, ConsToJSON' b f) => ConsToJSON f where
6474 consToJSON = unTagged (consToJSON' :: Tagged b (f a -> Value))
6575 {-# INLINE consToJSON #-}
@@ -109,7 +119,7 @@ instance (GObject a, GObject b) => GObject (a :+: b) where
109119 {-# INLINE gObject #-}
110120
111121instance (Constructor c, GToJSON a, ConsToJSON a) => GObject (C1 c a) where
112− gObject m1 = M.singleton (pack (conName m1)) (gToJSON m1)
122+ gObject = M.singleton (pack $ conName (undefined :: t c a p)) . gToJSON
113123 {-# INLINE gObject #-}
114124
115125--------------------------------------------------------------------------------
@@ -133,16 +143,33 @@ instance (ConsFromJSON a) => GFromJSON (C1 c a) where
133143 gParseJSON = fmap M1 . consParseJSON
134144 {-# INLINE gParseJSON #-}
135145
136−instance (GFromProduct a, GFromProduct b) => GFromJSON (a :*: b) where
137− gParseJSON (Array arr) = gParseProduct arr
146+instance ( GFromProduct a, GFromProduct b
147+ , ProductSize a, ProductSize b) => GFromJSON (a :*: b) where
148+ gParseJSON (Array arr)
149+ | lenArray == lenProduct = gParseProduct arr 0 lenProduct
150+ | otherwise =
151+ fail $ "When expecting a product of " ++ show lenProduct ++
152+ " values, encountered an Array of " ++ show lenArray ++
153+ " elements instead"
154+ where
155+ lenArray = V.length arr
156+ lenProduct = unTagged2 (productSize :: Tagged2 (a :*: b) Int)
157+
138158 gParseJSON v = typeMismatch "product (:*:)" v
139159 {-# INLINE gParseJSON #-}
140160
141161instance (GFromSum a, GFromSum b) => GFromJSON (a :+: b) where
142− gParseJSON (Object (M.toList -> [keyVal])) = gParseSum keyVal
162+ gParseJSON (Object (M.toList -> [keyVal@(key, _)])) =
163+ case gParseSum keyVal of
164+ Nothing -> notFound $ unpack key
165+ Just p -> p
143166 gParseJSON v = typeMismatch "sum (:+:)" v
144167 {-# INLINE gParseJSON #-}
145168
169+notFound :: String -> Parser a
170+notFound key = fail $ "The key \"" ++ key ++ "\" was not found"
171+{-# INLINE notFound #-}
172+
146173--------------------------------------------------------------------------------
147174
148175class ConsFromJSON f where consParseJSON :: Value -> Parser (f a)
@@ -173,56 +200,66 @@ instance (GFromRecord a, GFromRecord b) => GFromRecord (a :*: b) where
173200 {-# INLINE gParseRecord #-}
174201
175202instance (Selector s, GFromJSON a) => GFromRecord (S1 s a) where
176− gParseRecord obj = case M.lookup (T.pack key) obj of
177− Nothing -> notFound key
178− Just v -> gParseJSON v
203+ gParseRecord = maybe (notFound key) gParseJSON . M.lookup (T.pack key)
179204 where
180205 key = selName (undefined :: t s a p)
181206 {-# INLINE gParseRecord #-}
182207
183208--------------------------------------------------------------------------------
184209
210+class ProductSize f where
211+ productSize :: Tagged2 f Int
212+
213+newtype Tagged2 (s :: * -> *) b = Tagged2 {unTagged2 :: b}
214+
215+instance (ProductSize a, ProductSize b) => ProductSize (a :*: b) where
216+ productSize = Tagged2 $ unTagged2 (productSize :: Tagged2 a Int) +
217+ unTagged2 (productSize :: Tagged2 b Int)
218+
219+instance ProductSize (S1 s a) where
220+ productSize = Tagged2 1
221+
222+--------------------------------------------------------------------------------
223+
185224class GFromProduct f where
186− gParseProduct :: Array -> Parser (f a)
225+ gParseProduct :: Array -> Int -> Int -> Parser (f a)
187226
188227instance (GFromProduct a, GFromProduct b) => GFromProduct (a :*: b) where
189− gParseProduct arr = (:*:) <$> gParseProduct arrL <*> gParseProduct arrR
228+ gParseProduct arr ix len = (:*:) <$> gParseProduct arr ix lenL
229+ <*> gParseProduct arr ixR lenR
190230 where
191− (arrL, arrR) = V.splitAt (V.length arr `div` 2) arr
231+ lenL = len `shiftR` 1
232+ ixR = ix + lenL
233+ lenR = len - lenL
192234 {-# INLINE gParseProduct #-}
193235
194−instance (GFromJSON a) => GFromProduct a where
195− gParseProduct ((!? 0) -> Just v) = gParseJSON v
196− gParseProduct _ = fail "Array to small"
236+instance (GFromJSON a) => GFromProduct (S1 s a) where
237+ gParseProduct arr ix _ = gParseJSON $ V.unsafeIndex arr ix
197238 {-# INLINE gParseProduct #-}
198239
199240--------------------------------------------------------------------------------
200241
201242class GFromSum f where
202− gParseSum :: Pair -> Parser (f a)
243+ gParseSum :: Pair -> Maybe (Parser (f a))
203244
204245instance (GFromSum a, GFromSum b) => GFromSum (a :+: b) where
205− gParseSum keyVal = (L1 <$> gParseSum keyVal) <|> (R1 <$> gParseSum keyVal)
246+ gParseSum keyVal = (fmap L1 <$> gParseSum keyVal) <|>
247+ (fmap R1 <$> gParseSum keyVal)
206248 {-# INLINE gParseSum #-}
207249
208250instance (Constructor c, GFromJSON a, ConsFromJSON a) => GFromSum (C1 c a) where
209251 gParseSum (key, value)
210− | key == pack (conName (undefined :: t c a p)) = gParseJSON value
211− | otherwise = notFound $ unpack key
252+ | key == pack (conName (undefined :: t c a p)) = Just $ gParseJSON value
253+ | otherwise = Nothing
212254 {-# INLINE gParseSum #-}
213255
214−notFound :: String -> Parser a
215−notFound key = fail $ "The key \"" ++ key ++ "\" was not found"
216−
217256--------------------------------------------------------------------------------
218257
219−newtype Tagged s b = Tagged {unTagged :: b}
258+class IsRecord (f :: * -> *) b | f -> b
220259
221260data True
222261data False
223262
224−class IsRecord (f :: * -> *) b | f -> b
225−
226263instance (IsRecord f b) => IsRecord (f :*: g) b
227264instance IsRecord (M1 S NoSelector f) False
228265instance (IsRecord f b) => IsRecord (M1 S c f) b