on master help sign in
Some more refactoring in Data.Aeson.Types.Generic
commit1329a06117d6c0587b52de38c5e5d79d0b06c956 authorBas van Dijk <v.dijk.bas@gmail.com> dateMon 22 Apr 2013, 00:52 (13 years ago) parentc2f43bb
1 file changed+72−68
Data/Aeson/Types/Generic.hs+72−68
Data/Aeson/Types/Generic.hs+72−68
@@ -54,15 +54,15 @@ instance GToJSON U1 where
5454
5555instance (ConsToJSON a) => GToJSON (C1 c a) where
5656 -- Constructors need to be encoded differently depending on whether they're
57− -- a record or not. This distinction is made by constToJSON:
57+ -- a record or not. This distinction is made by 'constToJSON':
5858 gToJSON opts = consToJSON opts . unM1
5959 {-# INLINE gToJSON #-}
6060
6161instance ( WriteProduct a, WriteProduct b
6262 , ProductSize a, ProductSize b ) => GToJSON (a :*: b) where
6363 -- 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:
64+ -- the same size as the product and write the product's elements to it using
65+ -- 'writeProduct':
6666 gToJSON opts p =
6767 Array $ V.create $ do
6868 mv <- VM.unsafeNew lenProduct
@@ -73,19 +73,19 @@ instance ( WriteProduct a, WriteProduct b
7373 productSize
7474 {-# INLINE gToJSON #-}
7575
76−instance ( AllNullary (a :+: b) bool
77− , SumToJSON (a :+: b) bool ) => GToJSON (a :+: b) where
76+instance ( AllNullary (a :+: b) allNullary
77+ , SumToJSON (a :+: b) allNullary ) => GToJSON (a :+: b) where
7878 -- If all constructors of a sum datatype are nullary and the
7979 -- 'nullaryToString' option is set they are encoded to strings.
8080 -- This distinction is made by 'sumToJSON':
81− gToJSON opts = (unTagged :: Tagged bool Value -> Value)
81+ gToJSON opts = (unTagged :: Tagged allNullary Value -> Value)
8282 . sumToJSON opts
8383 {-# INLINE gToJSON #-}
8484
8585--------------------------------------------------------------------------------
8686
87−class SumToJSON f bool where
88− sumToJSON :: Options -> f a -> Tagged bool Value
87+class SumToJSON f allNullary where
88+ sumToJSON :: Options -> f a -> Tagged allNullary Value
8989
9090instance ( GetConName f
9191 , ObjectWithType f
@@ -128,21 +128,21 @@ instance ( ObjectWithType a
128128 objectWithType opts typeFieldName valueFieldName x
129129 {-# INLINE objectWithType #-}
130130
131−instance ( IsRecord a bool
132− , ObjectWithType' a bool
131+instance ( IsRecord a isRecord
132+ , ObjectWithType' a isRecord
133133 , Constructor c ) => ObjectWithType (C1 c a) where
134134 objectWithType opts typeFieldName valueFieldName =
135135 (pack typeFieldName .= constructorNameModifier opts
136136 (conName (undefined :: t c a p)) :) .
137− (unTagged :: Tagged bool [Pair] -> [Pair]) .
137+ (unTagged :: Tagged isRecord [Pair] -> [Pair]) .
138138 objectWithType' opts valueFieldName . unM1
139139 {-# INLINE objectWithType #-}
140140
141−class ObjectWithType' f bool where
142− objectWithType' :: Options -> String -> f a -> Tagged bool [Pair]
141+class ObjectWithType' f isRecord where
142+ objectWithType' :: Options -> String -> f a -> Tagged isRecord [Pair]
143143
144−instance (GRecordToPairs f) => ObjectWithType' f True where
145− objectWithType' opts _ = Tagged . toList . gRecordToPairs opts
144+instance (RecordToPairs f) => ObjectWithType' f True where
145+ objectWithType' opts _ = Tagged . toList . recordToPairs opts
146146 {-# INLINE objectWithType' #-}
147147
148148instance (GToJSON f) => ObjectWithType' f False where
@@ -190,17 +190,17 @@ instance ( GToJSON a, ConsToJSON a
190190class ConsToJSON f where
191191 consToJSON :: Options -> f a -> Value
192192
193−class ConsToJSON' f bool where
194− consToJSON' :: Options -> f a -> Tagged bool Value
193+class ConsToJSON' f isRecord where
194+ consToJSON' :: Options -> f a -> Tagged isRecord Value
195195
196−instance ( IsRecord f bool
197− , ConsToJSON' f bool ) => ConsToJSON f where
198− consToJSON opts = (unTagged :: Tagged bool Value -> Value)
196+instance ( IsRecord f isRecord
197+ , ConsToJSON' f isRecord ) => ConsToJSON f where
198+ consToJSON opts = (unTagged :: Tagged isRecord Value -> Value)
199199 . consToJSON' opts
200200 {-# INLINE consToJSON #-}
201201
202−instance (GRecordToPairs f) => ConsToJSON' f True where
203− consToJSON' opts = Tagged . object . toList . gRecordToPairs opts
202+instance (RecordToPairs f) => ConsToJSON' f True where
203+ consToJSON' opts = Tagged . object . toList . recordToPairs opts
204204 {-# INLINE consToJSON' #-}
205205
206206instance GToJSON f => ConsToJSON' f False where
@@ -209,27 +209,29 @@ instance GToJSON f => ConsToJSON' f False where
209209
210210--------------------------------------------------------------------------------
211211
212−class GRecordToPairs f where
213− gRecordToPairs :: Options -> f a -> DList Pair
212+class RecordToPairs f where
213+ recordToPairs :: Options -> f a -> DList Pair
214214
215−instance (GRecordToPairs a, GRecordToPairs b) => GRecordToPairs (a :*: b) where
216− gRecordToPairs opts (a :*: b) = gRecordToPairs opts a `mappend`
217− gRecordToPairs opts b
218− {-# INLINE gRecordToPairs #-}
215+instance (RecordToPairs a, RecordToPairs b) => RecordToPairs (a :*: b) where
216+ recordToPairs opts (a :*: b) = recordToPairs opts a `mappend`
217+ recordToPairs opts b
218+ {-# INLINE recordToPairs #-}
219219
220−instance (Selector s, GToJSON a) => GRecordToPairs (S1 s a) where
221− gRecordToPairs opts m1 = pure ( pack $ fieldNameModifier opts $ selName m1
222− , gToJSON opts (unM1 m1)
223− )
224− {-# INLINE gRecordToPairs #-}
220+instance (Selector s, GToJSON a) => RecordToPairs (S1 s a) where
221+ recordToPairs = fieldToPair
222+ {-# INLINE recordToPairs #-}
225223
226−instance (Selector s, ToJSON a) => GRecordToPairs (S1 s (K1 i (Maybe a))) where
227− gRecordToPairs opts (M1 k1) | omitNothingFields opts
228− , K1 Nothing <- k1 = empty
229− gRecordToPairs opts m1 = pure ( pack $ fieldNameModifier opts $ selName m1
230− , gToJSON opts (unM1 m1)
231− )
232− {-# INLINE gRecordToPairs #-}
224+instance (Selector s, ToJSON a) => RecordToPairs (S1 s (K1 i (Maybe a))) where
225+ recordToPairs opts (M1 k1) | omitNothingFields opts
226+ , K1 Nothing <- k1 = empty
227+ recordToPairs opts m1 = fieldToPair opts m1
228+ {-# INLINE recordToPairs #-}
229+
230+fieldToPair :: (Selector s, GToJSON a) => Options -> S1 s a p -> DList Pair
231+fieldToPair opts m1 = pure ( pack $ fieldNameModifier opts $ selName m1
232+ , gToJSON opts (unM1 m1)
233+ )
234+{-# INLINE fieldToPair #-}
233235
234236--------------------------------------------------------------------------------
235237
@@ -318,20 +320,20 @@ instance ( FromProduct a, FromProduct b
318320 " elements instead"
319321 {-# INLINE gParseJSON #-}
320322
321−instance ( AllNullary (a :+: b) bool
322− , ParseSum (a :+: b) bool ) => GFromJSON (a :+: b) where
323+instance ( AllNullary (a :+: b) allNullary
324+ , ParseSum (a :+: b) allNullary ) => GFromJSON (a :+: b) where
323325 -- If all constructors of a sum datatype are nullary and the
324326 -- 'nullaryToString' option is set they are expected to be encoded as
325327 -- strings. This distinction is made by 'parseSum':
326− gParseJSON opts = (unTagged :: Tagged bool (Parser ((a :+: b) d)) ->
327− (Parser ((a :+: b) d)))
328+ gParseJSON opts = (unTagged :: Tagged allNullary (Parser ((a :+: b) d)) ->
329+ (Parser ((a :+: b) d)))
328330 . parseSum opts
329331 {-# INLINE gParseJSON #-}
330332
331333--------------------------------------------------------------------------------
332334
333−class ParseSum f bool where
334− parseSum :: Options -> Value -> Tagged bool (Parser (f a))
335+class ParseSum f allNullary where
336+ parseSum :: Options -> Value -> Tagged allNullary (Parser (f a))
335337
336338instance ( SumFromString (a :+: b)
337339 , FromPair (a :+: b)
@@ -429,15 +431,15 @@ instance ( FromObjectWithType' f
429431class FromObjectWithType' f where
430432 parseFromObjectWithType' :: Options -> String -> Object -> Parser (f a)
431433
432−class FromObjectWithType'' f bool where
434+class FromObjectWithType'' f isRecord where
433435 parseFromObjectWithType'' :: Options -> String -> Object
434− -> Tagged bool (Parser (f a))
436+ -> Tagged isRecord (Parser (f a))
435437
436−instance ( IsRecord f bool
437− , FromObjectWithType'' f bool
438+instance ( IsRecord f isRecord
439+ , FromObjectWithType'' f isRecord
438440 ) => FromObjectWithType' f where
439441 parseFromObjectWithType' opts valueFieldName =
440− (unTagged :: Tagged bool (Parser (f a)) -> Parser (f a)) .
442+ (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a)) .
441443 parseFromObjectWithType'' opts valueFieldName
442444 {-# INLINE parseFromObjectWithType' #-}
443445
@@ -455,13 +457,13 @@ instance (GFromJSON f) => FromObjectWithType'' f False where
455457class ConsFromJSON f where
456458 consParseJSON :: Options -> Value -> Parser (f a)
457459
458−class ConsFromJSON' f bool where
459− consParseJSON' :: Options -> Value -> Tagged bool (Parser (f a))
460+class ConsFromJSON' f isRecord where
461+ consParseJSON' :: Options -> Value -> Tagged isRecord (Parser (f a))
460462
461−instance ( IsRecord f bool
462− , ConsFromJSON' f bool
463+instance ( IsRecord f isRecord
464+ , ConsFromJSON' f isRecord
463465 ) => ConsFromJSON f where
464− consParseJSON opts = (unTagged :: Tagged bool (Parser (f a)) -> Parser (f a))
466+ consParseJSON opts = (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a))
465467 . consParseJSON' opts
466468 {-# INLINE consParseJSON #-}
467469
@@ -551,30 +553,32 @@ instance (Constructor c, GFromJSON a, ConsFromJSON a) => FromPair (C1 c a) where
551553
552554--------------------------------------------------------------------------------
553555
554−class IsRecord (f :: * -> *) bool | f -> bool
556+class IsRecord (f :: * -> *) isRecord | f -> isRecord
555557
556−data True
557−data False
558−
559−instance (IsRecord f bool) => IsRecord (f :*: g) bool
558+instance (IsRecord f isRecord) => IsRecord (f :*: g) isRecord
560559instance IsRecord (M1 S NoSelector f) False
561−instance (IsRecord f bool) => IsRecord (M1 S c f) bool
560+instance (IsRecord f isRecord) => IsRecord (M1 S c f) isRecord
562561instance IsRecord (K1 i c) True
563562instance IsRecord U1 False
564563
565564--------------------------------------------------------------------------------
566565
567−class AllNullary (f :: * -> *) bool | f -> bool
566+class AllNullary (f :: * -> *) allNullary | f -> allNullary
568567
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
568+instance ( AllNullary a allNullaryL
569+ , AllNullary b allNullaryR
570+ , And allNullaryL allNullaryR allNullary
571+ ) => AllNullary (a :+: b) allNullary
572+instance AllNullary a allNullary => AllNullary (M1 i c a) allNullary
574573instance AllNullary (a :*: b) False
575574instance AllNullary (K1 i c) False
576575instance AllNullary U1 True
577576
577+--------------------------------------------------------------------------------
578+
579+data True
580+data False
581+
578582class And bool1 bool2 bool3 | bool1 bool2 -> bool3
579583
580584instance And True True True