@@ -1,7 +1,8 @@
11{-# LANGUAGE DefaultSignatures, EmptyDataDecls, FlexibleInstances,
22 FunctionalDependencies, KindSignatures, OverlappingInstances,
33 ScopedTypeVariables, TypeOperators, UndecidableInstances,
4− ViewPatterns, NamedFieldPuns, FlexibleContexts, PatternGuards #-}
4+ ViewPatterns, NamedFieldPuns, FlexibleContexts, PatternGuards,
5+ RecordWildCards #-}
56{-# OPTIONS_GHC -fno-warn-orphans #-}
67
78-- |
@@ -19,6 +20,7 @@
1920module Data.Aeson.Types.Generic ( ) where
2021
2122import Control.Applicative ((<*>), (<$>), (<|>), pure)
23+import Control.Monad ((<=<))
2224import Control.Monad.ST (ST)
2325import Data.Aeson.Types.Class
2426import Data.Aeson.Types.Internal
@@ -36,151 +38,173 @@ import qualified Data.Vector.Mutable as VM
3638-- Generic toJSON
3739
3840instance (GToJSON a) => GToJSON (M1 i c a) where
41+ -- Meta-information, which is not handled elsewhere, is ignored:
3942 gToJSON opts = gToJSON opts . unM1
4043 {-# INLINE gToJSON #-}
4144
4245instance (ToJSON a) => GToJSON (K1 i a) where
46+ -- Constant values are encoded using their ToJSON instance:
4347 gToJSON _opts = toJSON . unK1
4448 {-# INLINE gToJSON #-}
4549
4650instance GToJSON U1 where
51+ -- Empty constructors are encoded to an empty array:
4752 gToJSON _opts _ = emptyArray
4853 {-# INLINE gToJSON #-}
4954
5055instance (ConsToJSON a) => GToJSON (C1 c a) where
56+ -- Constructors need to be encoded differently depending on whether they're
57+ -- a record or not. This distinction is made by constToJSON:
5158 gToJSON opts = consToJSON opts . unM1
5259 {-# INLINE gToJSON #-}
5360
54−instance ( GProductToValues a, GProductToValues b
55− , ProductSize a, ProductSize b) => GToJSON (a :*: b) where
61+instance ( WriteProduct a, WriteProduct b
62+ , ProductSize a, ProductSize b ) => GToJSON (a :*: b) where
63+ -- Products are encoded to an array. Here we allocate a mutable vector of
64+ -- the the same size as the product and write the product's elements to it
65+ -- using writeProduct:
5666 gToJSON opts p =
5767 Array $ V.create $ do
5868 mv <- VM.unsafeNew lenProduct
59− gProductToValues opts mv 0 lenProduct p
69+ writeProduct opts mv 0 lenProduct p
6070 return mv
6171 where
62− lenProduct = unTagged2 (productSize :: Tagged2 (a :*: b) Int)
72+ lenProduct = (unTagged2 :: Tagged2 (a :*: b) Int -> Int)
73+ productSize
6374 {-# INLINE gToJSON #-}
6475
65−instance (AllNullary (a :+: b) c, GSumToJSON' c (a :+: b)) => GToJSON (a :+: b) where
66− gToJSON = unTagged (gSumToJSON' :: Tagged c (Options -> (a :+: b) d -> Value))
76+instance ( AllNullary (a :+: b) bool
77+ , SumToJSON (a :+: b) bool ) => GToJSON (a :+: b) where
78+ -- If all constructors of a sum datatype are nullary and the
79+ -- 'nullaryToString' option is set they are encoded to strings.
80+ -- This distinction is made by 'sumToJSON':
81+ gToJSON opts = (unTagged :: Tagged bool Value -> Value)
82+ . sumToJSON opts
6783 {-# INLINE gToJSON #-}
6884
69−class GSumToJSON' b f where
70− gSumToJSON' :: Tagged b (Options -> f a -> Value)
71−
72−instance ( GSumToString f
73− , GExtractSum f
74− , GObjectWithType f
75− , GObjectWithSingleField f
76− ) => GSumToJSON' True f where
77− gSumToJSON' = Tagged $ \opts x ->
78− if nullaryToString opts
79− then gSumToString opts x
80− else sumToJSON opts x
81− {-# INLINE gSumToJSON' #-}
82−
83−instance (GExtractSum f, GObjectWithType f, GObjectWithSingleField f) => GSumToJSON' False f where
84− gSumToJSON' = Tagged sumToJSON
85− {-# INLINE gSumToJSON' #-}
86−
87−sumToJSON :: (GExtractSum f, GObjectWithType f, GObjectWithSingleField f) => Options -> f a -> Value
88−sumToJSON opts x =
89− case sumEncoding opts of
90− TwoElemArray ->
91− Array $ V.create $ do
92− let (typ, val) = gExtractSum x opts
93− mv <- VM.unsafeNew 2
94− VM.unsafeWrite mv 0 typ
95− VM.unsafeWrite mv 1 val
96− return mv
97− ObjectWithType{typeFieldName,valueFieldName} ->
98− object $ gObjectWithType opts typeFieldName valueFieldName x
99− ObjectWithSingleField ->
100− Object $ gObjectWithSingleField opts x
101−{-# INLINE sumToJSON #-}
102−
10385--------------------------------------------------------------------------------
10486
105−class GObjectWithType f where
106− gObjectWithType :: Options -> String -> String -> f a -> [Pair]
87+class SumToJSON f bool where
88+ sumToJSON :: Options -> f a -> Tagged bool Value
89+
90+instance ( GetConName f
91+ , ObjectWithType f
92+ , ObjectWithSingleField f
93+ , TwoElemArray f ) => SumToJSON f True where
94+ sumToJSON opts
95+ | nullaryToString opts = Tagged . String . pack
96+ . constructorNameModifier opts . getConName
97+ | otherwise = Tagged . nonAllNullarySumToJSON opts
98+ {-# INLINE sumToJSON #-}
99+
100+instance ( TwoElemArray f
101+ , ObjectWithType f
102+ , ObjectWithSingleField f ) => SumToJSON f False where
103+ sumToJSON opts = Tagged . nonAllNullarySumToJSON opts
104+ {-# INLINE sumToJSON #-}
105+
106+nonAllNullarySumToJSON :: ( TwoElemArray f
107+ , ObjectWithType f
108+ , ObjectWithSingleField f
109+ ) => Options -> f a -> Value
110+nonAllNullarySumToJSON opts =
111+ case sumEncoding opts of
112+ ObjectWithType{..} -> object . objectWithType opts typeFieldName
113+ valueFieldName
114+ ObjectWithSingleField -> Object . objectWithSingleField opts
115+ TwoElemArray -> Array . twoElemArray opts
116+{-# INLINE nonAllNullarySumToJSON #-}
107117
108−instance (GObjectWithType a, GObjectWithType b) => GObjectWithType (a :+: b) where
109− gObjectWithType opts typeFieldName valueFieldName (L1 x) =
110− gObjectWithType opts typeFieldName valueFieldName x
111− gObjectWithType opts typeFieldName valueFieldName (R1 x) =
112− gObjectWithType opts typeFieldName valueFieldName x
113− {-# INLINE gObjectWithType #-}
118+--------------------------------------------------------------------------------
114119
115−instance (IsRecord a b, Constructor c, GObjectWithType' b a) =>
116− GObjectWithType (C1 c a) where
117− gObjectWithType opts typeFieldName valueFieldName x =
120+class ObjectWithType f where
121+ objectWithType :: Options -> String -> String -> f a -> [Pair]
122+
123+instance ( ObjectWithType a
124+ , ObjectWithType b ) => ObjectWithType (a :+: b) where
125+ objectWithType opts typeFieldName valueFieldName (L1 x) =
126+ objectWithType opts typeFieldName valueFieldName x
127+ objectWithType opts typeFieldName valueFieldName (R1 x) =
128+ objectWithType opts typeFieldName valueFieldName x
129+ {-# INLINE objectWithType #-}
130+
131+instance ( IsRecord a bool
132+ , ObjectWithType' a bool
133+ , Constructor c ) => ObjectWithType (C1 c a) where
134+ objectWithType opts typeFieldName valueFieldName =
118135 (pack typeFieldName .= constructorNameModifier opts
119− (conName (undefined :: t c a p))) :
120− unTagged (gObjectWithType' opts valueFieldName (unM1 x) :: Tagged b [Pair])
121− {-# INLINE gObjectWithType #-}
136+ (conName (undefined :: t c a p)) :) .
137+ (unTagged :: Tagged bool [Pair] -> [Pair]) .
138+ objectWithType' opts valueFieldName . unM1
139+ {-# INLINE objectWithType #-}
122140
123−class GObjectWithType' b f where
124− gObjectWithType' :: Options -> String -> f a -> Tagged b [Pair]
141+class ObjectWithType' f bool where
142+ objectWithType' :: Options -> String -> f a -> Tagged bool [Pair]
125143
126−instance (GRecordToPairs f) => GObjectWithType' True f where
127− gObjectWithType' opts _ x = Tagged $ toList $ gRecordToPairs opts x
128− {-# INLINE gObjectWithType' #-}
144+instance (GRecordToPairs f) => ObjectWithType' f True where
145+ objectWithType' opts _ = Tagged . toList . gRecordToPairs opts
146+ {-# INLINE objectWithType' #-}
129147
130−instance (GToJSON f) => GObjectWithType' False f where
131− gObjectWithType' opts valueFieldName x =
132− Tagged [pack valueFieldName .= gToJSON opts x]
133− {-# INLINE gObjectWithType' #-}
148+instance (GToJSON f) => ObjectWithType' f False where
149+ objectWithType' opts valueFieldName =
150+ Tagged . (:[]) . (pack valueFieldName .=) . gToJSON opts
151+ {-# INLINE objectWithType' #-}
134152
135153--------------------------------------------------------------------------------
136154
137−class GSumToString f where
138− gSumToString :: Options -> f a -> Value
155+-- | Get the name of the constructor of a sum datatype.
156+class GetConName f where
157+ getConName :: f a -> String
139158
140−instance (GSumToString a, GSumToString b) => GSumToString (a :+: b) where
141− gSumToString opts (L1 x) = gSumToString opts x
142− gSumToString opts (R1 x) = gSumToString opts x
143− {-# INLINE gSumToString #-}
159+instance (GetConName a, GetConName b) => GetConName (a :+: b) where
160+ getConName (L1 x) = getConName x
161+ getConName (R1 x) = getConName x
162+ {-# INLINE getConName #-}
144163
145−instance (Constructor c, GToJSON a, ConsToJSON a) => GSumToString (C1 c a) where
146− gSumToString opts _ = String $ pack $ constructorNameModifier opts
147− $ conName (undefined :: t c a p)
148− {-# INLINE gSumToString #-}
164+instance (Constructor c, GToJSON a, ConsToJSON a) => GetConName (C1 c a) where
165+ getConName = conName
166+ {-# INLINE getConName #-}
149167
150168--------------------------------------------------------------------------------
151169
152−class GExtractSum f where
153− gExtractSum :: f a -> Options -> (Value, Value)
170+class TwoElemArray f where
171+ twoElemArray :: Options -> f a -> V.Vector Value
154172
155−instance (GExtractSum a, GExtractSum b) => GExtractSum (a :+: b) where
156− gExtractSum (L1 x) = gExtractSum x
157− gExtractSum (R1 x) = gExtractSum x
158− {-# INLINE gExtractSum #-}
173+instance (TwoElemArray a, TwoElemArray b) => TwoElemArray (a :+: b) where
174+ twoElemArray opts (L1 x) = twoElemArray opts x
175+ twoElemArray opts (R1 x) = twoElemArray opts x
176+ {-# INLINE twoElemArray #-}
159177
160−instance (Constructor c, GToJSON a, ConsToJSON a) => GExtractSum (C1 c a) where
161− gExtractSum x opts = ( String $ pack $ constructorNameModifier opts
162− $ conName (undefined :: t c a p)
163− , gToJSON opts x
164− )
165− {-# INLINE gExtractSum #-}
178+instance ( GToJSON a, ConsToJSON a
179+ , Constructor c ) => TwoElemArray (C1 c a) where
180+ twoElemArray opts x = V.create $ do
181+ mv <- VM.unsafeNew 2
182+ VM.unsafeWrite mv 0 $ String $ pack $ constructorNameModifier opts
183+ $ conName (undefined :: t c a p)
184+ VM.unsafeWrite mv 1 $ gToJSON opts x
185+ return mv
186+ {-# INLINE twoElemArray #-}
166187
167188--------------------------------------------------------------------------------
168189
169−class ConsToJSON f where consToJSON :: Options -> f a -> Value
170−class ConsToJSON' b f where consToJSON' :: Tagged b (Options -> f a -> Value)
190+class ConsToJSON f where
191+ consToJSON :: Options -> f a -> Value
171192
172−newtype Tagged s b = Tagged {unTagged :: b}
193+class ConsToJSON' f bool where
194+ consToJSON' :: Options -> f a -> Tagged bool Value
173195
174−instance (IsRecord f b, ConsToJSON' b f) => ConsToJSON f where
175− consToJSON = unTagged (consToJSON' :: Tagged b (Options -> f a -> Value))
196+instance ( IsRecord f bool
197+ , ConsToJSON' f bool ) => ConsToJSON f where
198+ consToJSON opts = (unTagged :: Tagged bool Value -> Value)
199+ . consToJSON' opts
176200 {-# INLINE consToJSON #-}
177201
178−instance (GRecordToPairs f) => ConsToJSON' True f where
179− consToJSON' = Tagged (\opts -> object . toList . gRecordToPairs opts)
202+instance (GRecordToPairs f) => ConsToJSON' f True where
203+ consToJSON' opts = Tagged . object . toList . gRecordToPairs opts
180204 {-# INLINE consToJSON' #-}
181205
182−instance GToJSON f => ConsToJSON' False f where
183− consToJSON' = Tagged gToJSON
206+instance GToJSON f => ConsToJSON' f False where
207+ consToJSON' opts = Tagged . gToJSON opts
184208 {-# INLINE consToJSON' #-}
185209
186210--------------------------------------------------------------------------------
@@ -209,257 +233,275 @@ instance (Selector s, ToJSON a) => GRecordToPairs (S1 s (K1 i (Maybe a))) where
209233
210234--------------------------------------------------------------------------------
211235
212−class GProductToValues f where
213− gProductToValues :: Options
214− -> VM.MVector s Value
215− -> Int -- ^ index
216− -> Int -- ^ length
217− -> f a
218− -> ST s ()
219−
220−instance (GProductToValues a, GProductToValues b) => GProductToValues (a :*: b) where
221− gProductToValues opts mv ix len (a :*: b) = do
222− gProductToValues opts mv ix lenL a
223− gProductToValues opts mv ixR lenR b
236+class WriteProduct f where
237+ writeProduct :: Options
238+ -> VM.MVector s Value
239+ -> Int -- ^ index
240+ -> Int -- ^ length
241+ -> f a
242+ -> ST s ()
243+
244+instance ( WriteProduct a
245+ , WriteProduct b ) => WriteProduct (a :*: b) where
246+ writeProduct opts mv ix len (a :*: b) = do
247+ writeProduct opts mv ix lenL a
248+ writeProduct opts mv ixR lenR b
224249 where
225250 lenL = len `shiftR` 1
226− ixR = ix + lenL
227251 lenR = len - lenL
228− {-# INLINE gProductToValues #-}
252+ ixR = ix + lenL
253+ {-# INLINE writeProduct #-}
229254
230−instance (GToJSON a) => GProductToValues a where
231− gProductToValues opts mv ix _ = VM.unsafeWrite mv ix . gToJSON opts
232− {-# INLINE gProductToValues #-}
255+instance (GToJSON a) => WriteProduct a where
256+ writeProduct opts mv ix _ = VM.unsafeWrite mv ix . gToJSON opts
257+ {-# INLINE writeProduct #-}
233258
234259--------------------------------------------------------------------------------
235260
236−class GObjectWithSingleField f where
237− gObjectWithSingleField :: Options -> f a -> Object
261+class ObjectWithSingleField f where
262+ objectWithSingleField :: Options -> f a -> Object
238263
239−instance (GObjectWithSingleField a, GObjectWithSingleField b) =>
240− GObjectWithSingleField (a :+: b) where
241− gObjectWithSingleField opts (L1 x) = gObjectWithSingleField opts x
242− gObjectWithSingleField opts (R1 x) = gObjectWithSingleField opts x
243− {-# INLINE gObjectWithSingleField #-}
264+instance ( ObjectWithSingleField a
265+ , ObjectWithSingleField b ) => ObjectWithSingleField (a :+: b) where
266+ objectWithSingleField opts (L1 x) = objectWithSingleField opts x
267+ objectWithSingleField opts (R1 x) = objectWithSingleField opts x
268+ {-# INLINE objectWithSingleField #-}
244269
245−instance (Constructor c, GToJSON a, ConsToJSON a) =>
246− GObjectWithSingleField (C1 c a) where
247− gObjectWithSingleField opts x =
248− H.singleton ( pack $ constructorNameModifier opts
249− $ conName (undefined :: t c a p)
250− ) $ gToJSON opts x
251− {-# INLINE gObjectWithSingleField #-}
270+instance ( GToJSON a, ConsToJSON a
271+ , Constructor c ) => ObjectWithSingleField (C1 c a) where
272+ objectWithSingleField opts = H.singleton typ . gToJSON opts
273+ where
274+ typ = pack $ constructorNameModifier opts $
275+ conName (undefined :: t c a p)
276+ {-# INLINE objectWithSingleField #-}
252277
253278--------------------------------------------------------------------------------
254279-- Generic parseJSON
255280
256281instance (GFromJSON a) => GFromJSON (M1 i c a) where
282+ -- Meta-information, which is not handled elsewhere, is just added to the
283+ -- parsed value:
257284 gParseJSON opts = fmap M1 . gParseJSON opts
258285 {-# INLINE gParseJSON #-}
259286
260287instance (FromJSON a) => GFromJSON (K1 i a) where
288+ -- Constant values are decoded using their FromJSON instance:
261289 gParseJSON _opts = fmap K1 . parseJSON
262290 {-# INLINE gParseJSON #-}
263291
264292instance GFromJSON U1 where
293+ -- Empty constructors are expected to be encoded as an empty array:
265294 gParseJSON _opts v
266295 | isEmptyArray v = pure U1
267296 | otherwise = typeMismatch "unit constructor (U1)" v
268297 {-# INLINE gParseJSON #-}
269298
270299instance (ConsFromJSON a) => GFromJSON (C1 c a) where
300+ -- Constructors need to be decoded differently depending on whether they're
301+ -- a record or not. This distinction is made by consParseJSON:
271302 gParseJSON opts = fmap M1 . consParseJSON opts
272303 {-# INLINE gParseJSON #-}
273304
274−instance ( GFromProduct a, GFromProduct b
275− , ProductSize a, ProductSize b) => GFromJSON (a :*: b) where
305+instance ( FromProduct a, FromProduct b
306+ , ProductSize a, ProductSize b ) => GFromJSON (a :*: b) where
307+ -- Products are expected to be encoded to an array. Here we check whether we
308+ -- got an array of the same size as the product, then parse each of the
309+ -- product's elements using parseProduct:
276310 gParseJSON opts = withArray "product (:*:)" $ \arr ->
277311 let lenArray = V.length arr
278− lenProduct = unTagged2 (productSize :: Tagged2 (a :*: b) Int) in
312+ lenProduct = (unTagged2 :: Tagged2 (a :*: b) Int -> Int)
313+ productSize in
279314 if lenArray == lenProduct
280− then gParseProduct opts arr 0 lenProduct
315+ then parseProduct opts arr 0 lenProduct
281316 else fail $ "When expecting a product of " ++ show lenProduct ++
282317 " values, encountered an Array of " ++ show lenArray ++
283318 " elements instead"
284319 {-# INLINE gParseJSON #-}
285320
286−instance (AllNullary (a :+: b) c, GParseSum' c (a :+: b)) => GFromJSON (a :+: b) where
287− gParseJSON = unTagged (gParseSum' :: Tagged c (Options -> Value -> Parser ((a :+: b) d)))
321+instance ( AllNullary (a :+: b) bool
322+ , ParseSum (a :+: b) bool ) => GFromJSON (a :+: b) where
323+ -- If all constructors of a sum datatype are nullary and the
324+ -- 'nullaryToString' option is set they are expected to be encoded as
325+ -- strings. This distinction is made by 'parseSum':
326+ gParseJSON opts = (unTagged :: Tagged bool (Parser ((a :+: b) d)) ->
327+ (Parser ((a :+: b) d)))
328+ . parseSum opts
288329 {-# INLINE gParseJSON #-}
289330
290−class GParseSum' b f where
291− gParseSum' :: Tagged b (Options -> Value -> Parser (f a))
331+--------------------------------------------------------------------------------
332+
333+class ParseSum f bool where
334+ parseSum :: Options -> Value -> Tagged bool (Parser (f a))
292335
293−instance (GSumFromString (a :+: b), GFromPair (a :+: b), GFromObjectWithType (a :+: b)) =>
294− GParseSum' True (a :+: b) where
295− gParseSum' = Tagged $ \opts v ->
296− if nullaryToString opts
297− then parseSumFromString opts v
298− else parseSum opts v
299− {-# INLINE gParseSum' #-}
336+instance ( SumFromString (a :+: b)
337+ , FromPair (a :+: b)
338+ , FromObjectWithType (a :+: b) ) => ParseSum (a :+: b) True where
339+ parseSum opts
340+ | nullaryToString opts = Tagged . parseAllNullarySum opts
341+ | otherwise = Tagged . parseNonAllNullarySum opts
342+ {-# INLINE parseSum #-}
300343
301−instance (GFromPair (a :+: b), GFromObjectWithType (a :+: b)) => GParseSum' False (a :+: b) where
302− gParseSum' = Tagged parseSum
303− {-# INLINE gParseSum' #-}
344+instance ( FromPair (a :+: b)
345+ , FromObjectWithType (a :+: b) ) => ParseSum (a :+: b) False where
346+ parseSum opts = Tagged . parseNonAllNullarySum opts
347+ {-# INLINE parseSum #-}
304348
305349--------------------------------------------------------------------------------
306350
307−parseSumFromString :: GSumFromString f => Options -> Value -> Parser (f a)
308−parseSumFromString opts = withText "Text" $ \key ->
351+parseAllNullarySum :: SumFromString f => Options -> Value -> Parser (f a)
352+parseAllNullarySum opts = withText "Text" $ \key ->
309353 maybe (notFound $ unpack key) return $
310− gParseSumFromString opts key
311−{-# INLINE parseSumFromString #-}
354+ parseSumFromString opts key
355+{-# INLINE parseAllNullarySum #-}
312356
313−class GSumFromString f where
314− gParseSumFromString :: Options -> Text -> Maybe (f a)
357+class SumFromString f where
358+ parseSumFromString :: Options -> Text -> Maybe (f a)
315359
316−instance (GSumFromString a, GSumFromString b) => GSumFromString (a :+: b) where
317− gParseSumFromString opts key = (L1 <$> gParseSumFromString opts key) <|>
318− (R1 <$> gParseSumFromString opts key)
319− {-# INLINE gParseSumFromString #-}
360+instance (SumFromString a, SumFromString b) => SumFromString (a :+: b) where
361+ parseSumFromString opts key = (L1 <$> parseSumFromString opts key) <|>
362+ (R1 <$> parseSumFromString opts key)
363+ {-# INLINE parseSumFromString #-}
320364
321−instance (Constructor c) => GSumFromString (C1 c U1) where
322− gParseSumFromString opts key | key == name = Just $ M1 U1
323− | otherwise = Nothing
365+instance (Constructor c) => SumFromString (C1 c U1) where
366+ parseSumFromString opts key | key == name = Just $ M1 U1
367+ | otherwise = Nothing
324368 where
325− name = pack $ constructorNameModifier opts $ conName (undefined :: t c U1 p)
326− {-# INLINE gParseSumFromString #-}
369+ name = pack $ constructorNameModifier opts $
370+ conName (undefined :: t c U1 p)
371+ {-# INLINE parseSumFromString #-}
327372
328373--------------------------------------------------------------------------------
329374
330−parseSum :: (GFromPair (a :+: b), GFromObjectWithType (a :+: b)) =>
331− Options -> Value -> Parser ((a :+: b) c)
332−parseSum opts v =
375+parseNonAllNullarySum :: ( FromPair (a :+: b)
376+ , FromObjectWithType (a :+: b)
377+ ) => Options -> Value -> Parser ((a :+: b) c)
378+parseNonAllNullarySum opts =
333379 case sumEncoding opts of
334− TwoElemArray -> parseTwoElemArray opts v
335− ObjectWithType{typeFieldName,valueFieldName} ->
336− parseFromObjectWithType opts typeFieldName valueFieldName v
337− ObjectWithSingleField -> parseFromObjectWithSingleField opts v
338−{-# INLINE parseSum #-}
339−
340−parseFromObjectWithSingleField :: (GFromPair (a :+: b)) => Options -> Value -> Parser ((a :+: b) c)
341−parseFromObjectWithSingleField opts = withObject "Object" $ \obj ->
342− case H.toList obj of
343− [keyVal@(key, _)] -> fromMaybe (notFound $ unpack key) $ gParsePair opts keyVal
344− _ -> fail "Object doesn't have a single field"
345−{-# INLINE parseFromObjectWithSingleField #-}
346−
347−notFound :: String -> Parser a
348−notFound key = fail $ "The key \"" ++ key ++ "\" was not found"
349−{-# INLINE notFound #-}
380+ ObjectWithType{..} ->
381+ withObject "Object" $ \obj -> do
382+ key <- obj .: pack typeFieldName
383+ fromMaybe (notFound $ unpack key) $
384+ parseFromObjectWithType opts valueFieldName obj key
350385
351−--------------------------------------------------------------------------------
386+ ObjectWithSingleField ->
387+ withObject "Object" $ \obj ->
388+ case H.toList obj of
389+ [keyVal@(key, _)] -> fromMaybe (notFound $ unpack key) $
390+ parsePair opts keyVal
391+ _ -> fail "Object doesn't have a single field"
352392
353−parseTwoElemArray :: GFromPair f => Options -> Value -> Parser (f a)
354−parseTwoElemArray opts = withArray "Array" $ \arr ->
355− if V.length arr == 2
356− then case V.unsafeIndex arr 0 of
357− String key -> fromMaybe (notFound $ unpack key) $
358− gParsePair opts (key, V.unsafeIndex arr 1)
359− _ -> fail "First element is not a String"
360− else fail "Array doesn't have 2 elements"
361−{-# INLINE parseTwoElemArray #-}
393+ TwoElemArray ->
394+ withArray "Array" $ \arr ->
395+ if V.length arr == 2
396+ then case V.unsafeIndex arr 0 of
397+ String key -> fromMaybe (notFound $ unpack key) $
398+ parsePair opts (key, V.unsafeIndex arr 1)
399+ _ -> fail "First element is not a String"
400+ else fail "Array doesn't have 2 elements"
401+{-# INLINE parseNonAllNullarySum #-}
362402
363403--------------------------------------------------------------------------------
364404
365−parseFromObjectWithType :: (GFromObjectWithType f)
366− => Options -> String -> String -> Value -> Parser (f a)
367−parseFromObjectWithType opts typeFieldName valueFieldName = withObject "Object" $ \obj -> do
368− key <- obj .: pack typeFieldName
369− fromMaybe (notFound $ unpack key) $
370− gParseFromObjectWithType opts valueFieldName obj key
371−{-# INLINE parseFromObjectWithType #-}
372−
373−class GFromObjectWithType f where
374− gParseFromObjectWithType :: Options -> String -> Object -> Text -> Maybe (Parser (f a))
375−
376−instance (GFromObjectWithType a, GFromObjectWithType b) =>
377− GFromObjectWithType (a :+: b) where
378− gParseFromObjectWithType opts valueFieldName obj key =
379− (fmap L1 <$> gParseFromObjectWithType opts valueFieldName obj key) <|>
380− (fmap R1 <$> gParseFromObjectWithType opts valueFieldName obj key)
381− {-# INLINE gParseFromObjectWithType #-}
382−
383−instance (GFromObjectWithType' f, Constructor c) => GFromObjectWithType (C1 c f) where
384− gParseFromObjectWithType opts valueFieldName obj key
385− | key == name = Just $ M1 <$> gParseFromObjectWithType' opts valueFieldName obj
405+class FromObjectWithType f where
406+ parseFromObjectWithType :: Options -> String -> Object -> Text
407+ -> Maybe (Parser (f a))
408+
409+instance (FromObjectWithType a, FromObjectWithType b) =>
410+ FromObjectWithType (a :+: b) where
411+ parseFromObjectWithType opts valueFieldName obj key =
412+ (fmap L1 <$> parseFromObjectWithType opts valueFieldName obj key) <|>
413+ (fmap R1 <$> parseFromObjectWithType opts valueFieldName obj key)
414+ {-# INLINE parseFromObjectWithType #-}
415+
416+instance ( FromObjectWithType' f
417+ , Constructor c ) => FromObjectWithType (C1 c f) where
418+ parseFromObjectWithType opts valueFieldName obj key
419+ | key == name = Just $ M1 <$> parseFromObjectWithType'
420+ opts valueFieldName obj
386421 | otherwise = Nothing
387422 where
388− name = pack $ constructorNameModifier opts $ conName (undefined :: t c f p)
389− {-# INLINE gParseFromObjectWithType #-}
423+ name = pack $ constructorNameModifier opts $
424+ conName (undefined :: t c f p)
425+ {-# INLINE parseFromObjectWithType #-}
426+
427+--------------------------------------------------------------------------------
390428
391−class GFromObjectWithType' f where
392− gParseFromObjectWithType' :: Options -> String -> Object -> Parser (f a)
429+class FromObjectWithType' f where
430+ parseFromObjectWithType' :: Options -> String -> Object -> Parser (f a)
393431
394−instance (IsRecord f b, GFromObjectWithType'' b f) => GFromObjectWithType' f where
395− gParseFromObjectWithType' =
396− unTagged (gParseFromObjectWithType'' ::
397− Tagged b (Options -> String -> Object -> Parser (f a)))
398− {-# INLINE gParseFromObjectWithType' #-}
432+class FromObjectWithType'' f bool where
433+ parseFromObjectWithType'' :: Options -> String -> Object
434+ -> Tagged bool (Parser (f a))
399435
400−class GFromObjectWithType'' b f where
401− gParseFromObjectWithType'' :: Tagged b (Options -> String -> Object -> Parser (f a))
436+instance ( IsRecord f bool
437+ , FromObjectWithType'' f bool
438+ ) => FromObjectWithType' f where
439+ parseFromObjectWithType' opts valueFieldName =
440+ (unTagged :: Tagged bool (Parser (f a)) -> Parser (f a)) .
441+ parseFromObjectWithType'' opts valueFieldName
442+ {-# INLINE parseFromObjectWithType' #-}
402443
403−instance (GFromRecord f) => GFromObjectWithType'' True f where
404− gParseFromObjectWithType'' = Tagged $ \opts _ obj -> gParseRecord opts obj
405− {-# INLINE gParseFromObjectWithType'' #-}
444+instance (FromRecord f) => FromObjectWithType'' f True where
445+ parseFromObjectWithType'' opts _ = Tagged . parseRecord opts
446+ {-# INLINE parseFromObjectWithType'' #-}
406447
407−instance (GFromJSON f) => GFromObjectWithType'' False f where
408− gParseFromObjectWithType'' = Tagged $ \opts valueFieldName obj ->
409− gParseJSON opts =<< (obj .: pack valueFieldName)
410− {-# INLINE gParseFromObjectWithType'' #-}
448+instance (GFromJSON f) => FromObjectWithType'' f False where
449+ parseFromObjectWithType'' opts valueFieldName = Tagged .
450+ (gParseJSON opts <=< (.: pack valueFieldName))
451+ {-# INLINE parseFromObjectWithType'' #-}
411452
412453--------------------------------------------------------------------------------
413454
414−class ConsFromJSON f where
415− consParseJSON :: Options -> Value -> Parser (f a)
416−class ConsFromJSON' b f where
417− consParseJSON' :: Tagged b (Options -> Value -> Parser (f a))
455+class ConsFromJSON f where
456+ consParseJSON :: Options -> Value -> Parser (f a)
418457
419−instance (IsRecord f b, ConsFromJSON' b f) => ConsFromJSON f where
420− consParseJSON =
421− unTagged (consParseJSON' :: Tagged b (Options -> Value -> Parser (f a)))
458+class ConsFromJSON' f bool where
459+ consParseJSON' :: Options -> Value -> Tagged bool (Parser (f a))
460+
461+instance ( IsRecord f bool
462+ , ConsFromJSON' f bool
463+ ) => ConsFromJSON f where
464+ consParseJSON opts = (unTagged :: Tagged bool (Parser (f a)) -> Parser (f a))
465+ . consParseJSON' opts
422466 {-# INLINE consParseJSON #-}
423467
424−instance (GFromRecord f) => ConsFromJSON' True f where
425− consParseJSON' = Tagged $ withObject "record (:*:)" . gParseRecord
468+instance (FromRecord f) => ConsFromJSON' f True where
469+ consParseJSON' opts = Tagged . (withObject "record (:*:)" $ parseRecord opts)
426470 {-# INLINE consParseJSON' #-}
427471
428−instance (GFromJSON f) => ConsFromJSON' False f where
429− consParseJSON' = Tagged gParseJSON
472+instance (GFromJSON f) => ConsFromJSON' f False where
473+ consParseJSON' opts = Tagged . gParseJSON opts
430474 {-# INLINE consParseJSON' #-}
431475
432476--------------------------------------------------------------------------------
433477
434−class GFromRecord f where
435− gParseRecord :: Options -> Object -> Parser (f a)
478+class FromRecord f where
479+ parseRecord :: Options -> Object -> Parser (f a)
436480
437−instance (GFromRecord a, GFromRecord b) => GFromRecord (a :*: b) where
438− gParseRecord opts obj = (:*:) <$> gParseRecord opts obj
439− <*> gParseRecord opts obj
440− {-# INLINE gParseRecord #-}
481+instance (FromRecord a, FromRecord b) => FromRecord (a :*: b) where
482+ parseRecord opts obj = (:*:) <$> parseRecord opts obj
483+ <*> parseRecord opts obj
484+ {-# INLINE parseRecord #-}
441485
442−instance (Selector s, GFromJSON a) => GFromRecord (S1 s a) where
443− gParseRecord opts = maybe (notFound key) (gParseJSON opts)
486+instance (Selector s, GFromJSON a) => FromRecord (S1 s a) where
487+ parseRecord opts = maybe (notFound key) (gParseJSON opts)
444488 . H.lookup (pack key)
445489 where
446490 key = fieldNameModifier opts $ selName (undefined :: t s a p)
447− {-# INLINE gParseRecord #-}
491+ {-# INLINE parseRecord #-}
448492
449−instance (Selector s, FromJSON a) => GFromRecord (S1 s (K1 i (Maybe a))) where
450− gParseRecord opts obj = (M1 . K1) <$> obj .:? pack key
493+instance (Selector s, FromJSON a) => FromRecord (S1 s (K1 i (Maybe a))) where
494+ parseRecord opts obj = (M1 . K1) <$> obj .:? pack key
451495 where
452496 key = fieldNameModifier opts $
453497 selName (undefined :: t s (K1 i (Maybe a)) p)
454− {-# INLINE gParseRecord #-}
498+ {-# INLINE parseRecord #-}
455499
456500--------------------------------------------------------------------------------
457501
458502class ProductSize f where
459503 productSize :: Tagged2 f Int
460504
461−newtype Tagged2 (s :: * -> *) b = Tagged2 {unTagged2 :: b}
462−
463505instance (ProductSize a, ProductSize b) => ProductSize (a :*: b) where
464506 productSize = Tagged2 $ unTagged2 (productSize :: Tagged2 a Int) +
465507 unTagged2 (productSize :: Tagged2 b Int)
@@ -471,71 +513,83 @@ instance ProductSize (S1 s a) where
471513
472514--------------------------------------------------------------------------------
473515
474−class GFromProduct f where
475− gParseProduct :: Options -> Array -> Int -> Int -> Parser (f a)
516+class FromProduct f where
517+ parseProduct :: Options -> Array -> Int -> Int -> Parser (f a)
476518
477−instance (GFromProduct a, GFromProduct b) => GFromProduct (a :*: b) where
478− gParseProduct opts arr ix len =
479− (:*:) <$> gParseProduct opts arr ix lenL
480− <*> gParseProduct opts arr ixR lenR
519+instance (FromProduct a, FromProduct b) => FromProduct (a :*: b) where
520+ parseProduct opts arr ix len =
521+ (:*:) <$> parseProduct opts arr ix lenL
522+ <*> parseProduct opts arr ixR lenR
481523 where
482524 lenL = len `shiftR` 1
483525 ixR = ix + lenL
484526 lenR = len - lenL
485− {-# INLINE gParseProduct #-}
527+ {-# INLINE parseProduct #-}
486528
487−instance (GFromJSON a) => GFromProduct (S1 s a) where
488− gParseProduct opts arr ix _ = gParseJSON opts $ V.unsafeIndex arr ix
489− {-# INLINE gParseProduct #-}
529+instance (GFromJSON a) => FromProduct (S1 s a) where
530+ parseProduct opts arr ix _ = gParseJSON opts $ V.unsafeIndex arr ix
531+ {-# INLINE parseProduct #-}
490532
491533--------------------------------------------------------------------------------
492534
493−class GFromPair f where
494− gParsePair :: Options -> Pair -> Maybe (Parser (f a))
535+class FromPair f where
536+ parsePair :: Options -> Pair -> Maybe (Parser (f a))
495537
496−instance (GFromPair a, GFromPair b) => GFromPair (a :+: b) where
497− gParsePair opts keyVal = (fmap L1 <$> gParsePair opts keyVal) <|>
498− (fmap R1 <$> gParsePair opts keyVal)
499− {-# INLINE gParsePair #-}
538+instance (FromPair a, FromPair b) => FromPair (a :+: b) where
539+ parsePair opts keyVal = (fmap L1 <$> parsePair opts keyVal) <|>
540+ (fmap R1 <$> parsePair opts keyVal)
541+ {-# INLINE parsePair #-}
500542
501−instance (Constructor c, GFromJSON a, ConsFromJSON a) => GFromPair (C1 c a) where
502− gParsePair opts (key, value)
543+instance (Constructor c, GFromJSON a, ConsFromJSON a) => FromPair (C1 c a) where
544+ parsePair opts (key, value)
503545 | key == name = Just $ gParseJSON opts value
504546 | otherwise = Nothing
505547 where
506− name = pack $ constructorNameModifier opts $ conName (undefined :: t c a p)
507− {-# INLINE gParsePair #-}
548+ name = pack $ constructorNameModifier opts $
549+ conName (undefined :: t c a p)
550+ {-# INLINE parsePair #-}
508551
509552--------------------------------------------------------------------------------
510553
511−class IsRecord (f :: * -> *) b | f -> b
554+class IsRecord (f :: * -> *) bool | f -> bool
512555
513556data True
514557data False
515558
516−instance (IsRecord f b) => IsRecord (f :*: g) b
559+instance (IsRecord f bool) => IsRecord (f :*: g) bool
517560instance IsRecord (M1 S NoSelector f) False
518−instance (IsRecord f b) => IsRecord (M1 S c f) b
561+instance (IsRecord f bool) => IsRecord (M1 S c f) bool
519562instance IsRecord (K1 i c) True
520563instance IsRecord U1 False
521564
522565--------------------------------------------------------------------------------
523566
524−class AllNullary (f :: * -> *) b | f -> b
567+class AllNullary (f :: * -> *) bool | f -> bool
525568
526−instance (AllNullary a b1, AllNullary c b2, And b1 b2 b3) =>
527− AllNullary (a :+: c) b3
528−instance AllNullary a b => AllNullary (M1 i c a) b
529−instance AllNullary (a :*: c) False
569+instance ( AllNullary a bool1
570+ , AllNullary b bool2
571+ , And bool1 bool2 bool3
572+ ) => AllNullary (a :+: b) bool3
573+instance AllNullary a bool => AllNullary (M1 i c a) bool
574+instance AllNullary (a :*: b) False
530575instance AllNullary (K1 i c) False
531576instance AllNullary U1 True
532577
533−class And b1 b2 b3 | b1 b2 -> b3
578+class And bool1 bool2 bool3 | bool1 bool2 -> bool3
579+
580+instance And True True True
581+instance And False False False
582+instance And False True False
583+instance And True False False
534584
535−instance And True True True
585+--------------------------------------------------------------------------------
586+
587+newtype Tagged s b = Tagged {unTagged :: b}
536588
537−instance And False False False
538−instance And False True False
539−instance And True False False
589+newtype Tagged2 (s :: * -> *) b = Tagged2 {unTagged2 :: b}
540590
541591--------------------------------------------------------------------------------
592+
593+notFound :: String -> Parser a
594+notFound key = fail $ "The key \"" ++ key ++ "\" was not found"
595+{-# INLINE notFound #-}