@@ -1,7 +1,7 @@
11{-# LANGUAGE DefaultSignatures, EmptyDataDecls, FlexibleInstances,
22 FunctionalDependencies, KindSignatures, OverlappingInstances,
33 ScopedTypeVariables, TypeOperators, UndecidableInstances,
4− ViewPatterns, NamedFieldPuns #-}
4+ ViewPatterns, NamedFieldPuns, FlexibleContexts, PatternGuards #-}
55{-# OPTIONS_GHC -fno-warn-orphans #-}
66
77-- |
@@ -25,10 +25,9 @@ import Data.Aeson.Types.Internal
2525import Data.Bits (shiftR)
2626import Data.DList (DList, toList)
2727import Data.Monoid (mappend)
28−import Data.Text (pack, unpack)
28+import Data.Text (Text, pack, unpack)
2929import GHC.Generics
3030import qualified Data.HashMap.Strict as H
31−import qualified Data.Text as T
3231import qualified Data.Vector as V
3332import qualified Data.Vector.Mutable as VM
3433
@@ -278,20 +277,138 @@ instance ( GFromProduct a, GFromProduct b
278277 gParseJSON _opts v = typeMismatch "product (:*:)" v
279278 {-# INLINE gParseJSON #-}
280279
281−instance (GFromSum a, GFromSum b) => GFromJSON (a :+: b) where
282− gParseJSON opts (Object (H.toList -> [keyVal@(key, _)])) =
283− case gParseSum opts keyVal of
284− Nothing -> notFound $ unpack key
285− Just p -> p
286− gParseJSON _opts v = typeMismatch "sum (:+:)" v
280+instance (AllNullary (a :+: b) c, GParseSum' c (a :+: b)) => GFromJSON (a :+: b) where
281+ gParseJSON = unTagged (gParseSum' :: Tagged c (Options -> Value -> Parser ((a :+: b) d)))
287282 {-# INLINE gParseJSON #-}
288283
284+class GParseSum' b f where
285+ gParseSum' :: Tagged b (Options -> Value -> Parser (f a))
286+
287+instance (GSumFromString (a :+: b), GFromPair (a :+: b), GFromObjectWithType (a :+: b)) =>
288+ GParseSum' True (a :+: b) where
289+ gParseSum' = Tagged $ \opts v ->
290+ if nullaryToString opts
291+ then parseSumFromString opts v
292+ else parseSum opts v
293+ {-# INLINE gParseSum' #-}
294+
295+instance (GFromPair (a :+: b), GFromObjectWithType (a :+: b)) => GParseSum' False (a :+: b) where
296+ gParseSum' = Tagged parseSum
297+ {-# INLINE gParseSum' #-}
298+
299+--------------------------------------------------------------------------------
300+
301+parseSumFromString :: GSumFromString f => Options -> Value -> Parser (f a)
302+parseSumFromString opts (String key) = case gParseSumFromString opts key of
303+ Nothing -> notFound $ unpack key
304+ Just x -> return x
305+parseSumFromString _ v = typeMismatch "String" v
306+{-# INLINE parseSumFromString #-}
307+
308+class GSumFromString f where
309+ gParseSumFromString :: Options -> Text -> Maybe (f a)
310+
311+instance (GSumFromString a, GSumFromString b) => GSumFromString (a :+: b) where
312+ gParseSumFromString opts key = (L1 <$> gParseSumFromString opts key) <|>
313+ (R1 <$> gParseSumFromString opts key)
314+ {-# INLINE gParseSumFromString #-}
315+
316+instance (Constructor c) => GSumFromString (C1 c U1) where
317+ gParseSumFromString opts key | key == name = Just $ M1 U1
318+ | otherwise = Nothing
319+ where
320+ name = pack $ constructorNameModifier opts $ conName (undefined :: t c U1 p)
321+ {-# INLINE gParseSumFromString #-}
322+
323+--------------------------------------------------------------------------------
324+
325+parseSum :: (GFromPair (a :+: b), GFromObjectWithType (a :+: b)) =>
326+ Options -> Value -> Parser ((a :+: b) c)
327+parseSum opts v =
328+ case sumEncoding opts of
329+ TwoElemArray -> parseTwoElemArray opts v
330+ ObjectWithType{typeFieldName,valueFieldName} ->
331+ parseFromObjectWithType opts typeFieldName valueFieldName v
332+ ObjectWithSingleField -> parseFromObjectWithSingleField opts v
333+{-# INLINE parseSum #-}
334+
335+parseFromObjectWithSingleField :: (GFromPair (a :+: b)) => Options -> Value -> Parser ((a :+: b) c)
336+parseFromObjectWithSingleField opts (Object (H.toList -> [keyVal@(key, _)])) =
337+ case gParsePair opts keyVal of
338+ Nothing -> notFound $ unpack key
339+ Just p -> p
340+parseFromObjectWithSingleField _opts v = typeMismatch "Object with single field" v
341+{-# INLINE parseFromObjectWithSingleField #-}
342+
289343notFound :: String -> Parser a
290344notFound key = fail $ "The key \"" ++ key ++ "\" was not found"
291345{-# INLINE notFound #-}
292346
293347--------------------------------------------------------------------------------
294348
349+parseTwoElemArray :: GFromPair f => Options -> Value -> Parser (f a)
350+parseTwoElemArray opts (Array arr)
351+ | V.length arr == 2
352+ , String key <- V.unsafeIndex arr 0 =
353+ case gParsePair opts (key, V.unsafeIndex arr 1) of
354+ Nothing -> notFound $ unpack key
355+ Just p -> p
356+parseTwoElemArray _ v = typeMismatch "Array with a key and value element" v
357+{-# INLINE parseTwoElemArray #-}
358+
359+--------------------------------------------------------------------------------
360+
361+parseFromObjectWithType :: (GFromObjectWithType f)
362+ => Options -> String -> String -> Value -> Parser (f a)
363+parseFromObjectWithType opts typeFieldName valueFieldName (Object obj) = do
364+ key <- obj .: pack typeFieldName
365+ case gParseFromObjectWithType opts valueFieldName obj key of
366+ Nothing -> notFound $ unpack key
367+ Just p -> p
368+parseFromObjectWithType _ _ _ v = typeMismatch "Object" v
369+{-# INLINE parseFromObjectWithType #-}
370+
371+class GFromObjectWithType f where
372+ gParseFromObjectWithType :: Options -> String -> Object -> Text -> Maybe (Parser (f a))
373+
374+instance (GFromObjectWithType a, GFromObjectWithType b) =>
375+ GFromObjectWithType (a :+: b) where
376+ gParseFromObjectWithType opts valueFieldName obj key =
377+ (fmap L1 <$> gParseFromObjectWithType opts valueFieldName obj key) <|>
378+ (fmap R1 <$> gParseFromObjectWithType opts valueFieldName obj key)
379+ {-# INLINE gParseFromObjectWithType #-}
380+
381+instance (GFromObjectWithType' f, Constructor c) => GFromObjectWithType (C1 c f) where
382+ gParseFromObjectWithType opts valueFieldName obj key
383+ | key == name = Just $ M1 <$> gParseFromObjectWithType' opts valueFieldName obj
384+ | otherwise = Nothing
385+ where
386+ name = pack $ constructorNameModifier opts $ conName (undefined :: t c f p)
387+ {-# INLINE gParseFromObjectWithType #-}
388+
389+class GFromObjectWithType' f where
390+ gParseFromObjectWithType' :: Options -> String -> Object -> Parser (f a)
391+
392+instance (IsRecord f b, GFromObjectWithType'' b f) => GFromObjectWithType' f where
393+ gParseFromObjectWithType' =
394+ unTagged (gParseFromObjectWithType'' ::
395+ Tagged b (Options -> String -> Object -> Parser (f a)))
396+ {-# INLINE gParseFromObjectWithType' #-}
397+
398+class GFromObjectWithType'' b f where
399+ gParseFromObjectWithType'' :: Tagged b (Options -> String -> Object -> Parser (f a))
400+
401+instance (GFromRecord f) => GFromObjectWithType'' True f where
402+ gParseFromObjectWithType'' = Tagged $ \opts _ obj -> gParseRecord opts obj
403+ {-# INLINE gParseFromObjectWithType'' #-}
404+
405+instance (GFromJSON f) => GFromObjectWithType'' False f where
406+ gParseFromObjectWithType'' = Tagged $ \opts valueFieldName obj ->
407+ gParseJSON opts =<< (obj .: pack valueFieldName)
408+ {-# INLINE gParseFromObjectWithType'' #-}
409+
410+--------------------------------------------------------------------------------
411+
295412class ConsFromJSON f where
296413 consParseJSON :: Options -> Value -> Parser (f a)
297414class ConsFromJSON' b f where
@@ -325,7 +442,7 @@ instance (GFromRecord a, GFromRecord b) => GFromRecord (a :*: b) where
325442
326443instance (Selector s, GFromJSON a) => GFromRecord (S1 s a) where
327444 gParseRecord opts = maybe (notFound key) (gParseJSON opts)
328− . H.lookup (T.pack key)
445+ . H.lookup (pack key)
329446 where
330447 key = fieldNameModifier opts $ selName (undefined :: t s a p)
331448 {-# INLINE gParseRecord #-}
@@ -340,9 +457,11 @@ newtype Tagged2 (s :: * -> *) b = Tagged2 {unTagged2 :: b}
340457instance (ProductSize a, ProductSize b) => ProductSize (a :*: b) where
341458 productSize = Tagged2 $ unTagged2 (productSize :: Tagged2 a Int) +
342459 unTagged2 (productSize :: Tagged2 b Int)
460+ {-# INLINE productSize #-}
343461
344462instance ProductSize (S1 s a) where
345463 productSize = Tagged2 1
464+ {-# INLINE productSize #-}
346465
347466--------------------------------------------------------------------------------
348467
@@ -365,22 +484,21 @@ instance (GFromJSON a) => GFromProduct (S1 s a) where
365484
366485--------------------------------------------------------------------------------
367486
368−class GFromSum f where
369− gParseSum :: Options -> Pair -> Maybe (Parser (f a))
487+class GFromPair f where
488+ gParsePair :: Options -> Pair -> Maybe (Parser (f a))
370489
371−instance (GFromSum a, GFromSum b) => GFromSum (a :+: b) where
372− gParseSum opts keyVal = (fmap L1 <$> gParseSum opts keyVal) <|>
373− (fmap R1 <$> gParseSum opts keyVal)
374− {-# INLINE gParseSum #-}
490+instance (GFromPair a, GFromPair b) => GFromPair (a :+: b) where
491+ gParsePair opts keyVal = (fmap L1 <$> gParsePair opts keyVal) <|>
492+ (fmap R1 <$> gParsePair opts keyVal)
493+ {-# INLINE gParsePair #-}
375494
376−instance (Constructor c, GFromJSON a, ConsFromJSON a) => GFromSum (C1 c a) where
377− gParseSum opts (key, value)
378− | key == pack ( constructorNameModifier opts
379− $ conName (undefined :: t c a p)
380− )
381− = Just $ gParseJSON opts value
382− | otherwise = Nothing
383− {-# INLINE gParseSum #-}
495+instance (Constructor c, GFromJSON a, ConsFromJSON a) => GFromPair (C1 c a) where
496+ gParsePair opts (key, value)
497+ | key == name = Just $ gParseJSON opts value
498+ | otherwise = Nothing
499+ where
500+ name = pack $ constructorNameModifier opts $ conName (undefined :: t c a p)
501+ {-# INLINE gParsePair #-}
384502
385503--------------------------------------------------------------------------------
386504