git.iko.soy/typeable/aeson
on master help sign in
Add lifted typeclasses and some instances
79fcb38Oleg Grenrus
Data/Aeson/Types.hs+12
compare with master
unifiedsplit
@@ -45,6 +45,18 @@ module Data.Aeson.Types
45 , fromJSONKeyCoerce
45 , fromJSONKeyCoerce
46 , coerceFromJSONKeyFunction
46 , coerceFromJSONKeyFunction
47
47
48+ -- ** Liftings to unary and binary type constructors
49+ , FromJSON1(..)
50+ , parseJSON1
51+ , FromJSON2(..)
52+ , parseJSON2
53+ , ToJSON1(..)
54+ , toJSON1
55+ , toEncoding1
56+ , ToJSON2(..)
57+ , toJSON2
58+ , toEncoding2
59+
48 -- ** Generic JSON classes
60 -- ** Generic JSON classes
49 , GFromJSON(..)
61 , GFromJSON(..)
50 , GToJSON(..)
62 , GToJSON(..)
Data/Aeson/Types/Class.hs+70
@@ -17,6 +17,17 @@ module Data.Aeson.Types.Class
17 -- * Core JSON classes
17 -- * Core JSON classes
18 FromJSON(..)
18 FromJSON(..)
19 , ToJSON(..)
19 , ToJSON(..)
20+ -- * Liftings to unary and binary type constructors
21+ , FromJSON1(..)
22+ , parseJSON1
23+ , FromJSON2(..)
24+ , parseJSON2
25+ , ToJSON1(..)
26+ , toJSON1
27+ , toEncoding1
28+ , ToJSON2(..)
29+ , toJSON2
30+ , toEncoding2
20 -- * Generic JSON classes
31 -- * Generic JSON classes
21 , GFromJSON(..)
32 , GFromJSON(..)
22 , GToJSON(..)
33 , GToJSON(..)
@@ -385,3 +396,62 @@ typeMismatch expected actual =
385 Number _ -> "Number"
396 Number _ -> "Number"
386 Bool _ -> "Boolean"
397 Bool _ -> "Boolean"
387 Null -> "Null"
398 Null -> "Null"
399+
400+-------------------------------------------------------------------------------
401+-- Lifings of FromJSON and ToJSON to unary and binary type constructors
402+-------------------------------------------------------------------------------
403+
404+-- | Lifting of the 'FromJSON' class to unary type constructors.
405+class FromJSON1 f where
406+ liftParseJSON :: (Value -> Parser a) -> Value -> Parser (f a)
407+
408+-- | Lift the standard 'parseJSON' function through the type constructor.
409+parseJSON1 :: (FromJSON1 f, FromJSON a) => Value -> Parser (f a)
410+parseJSON1 = liftParseJSON parseJSON
411+{-# INLINE parseJSON1 #-}
412+
413+-- | Lifting of the 'ToJSON' class to unary type constructors.
414+class ToJSON1 f where
415+ liftToJSON :: (a -> Value) -> f a -> Value
416+
417+ -- | Unfortunately there cannot be default implementation of 'liftToEncoding'.
418+ liftToEncoding :: (a -> Encoding) -> f a -> Encoding
419+
420+-- | Lift the standard 'toJSON' function through the type constructor.
421+toJSON1 :: (ToJSON1 f, ToJSON a) => f a -> Value
422+toJSON1 = liftToJSON toJSON
423+{-# INLINE toJSON1 #-}
424+
425+-- | Lift the standard 'toEncoding' function through the type constructor.
426+toEncoding1 :: (ToJSON1 f, ToJSON a) => f a -> Encoding
427+toEncoding1 = liftToEncoding toEncoding
428+{-# INLINE toEncoding1 #-}
429+
430+
431+-- | Lifting of the 'FromJSON' class to binary type constructors.
432+class FromJSON2 f where
433+ liftParseJSON2
434+ :: (Value -> Parser a)
435+ -> (Value -> Parser b)
436+ -> Value -> Parser (f a b)
437+
438+-- | Lift the standard 'parseJSON' function through the type constructor.
439+parseJSON2 :: (FromJSON2 f, FromJSON a, FromJSON b) => Value -> Parser (f a b)
440+parseJSON2 = liftParseJSON2 parseJSON parseJSON
441+{-# INLINE parseJSON2 #-}
442+
443+-- | Lifting of the 'ToJSON' class to binary type constructors.
444+class ToJSON2 f where
445+ liftToJSON2 :: (a -> Value) -> (b -> Value) -> f a b -> Value
446+
447+ liftToEncoding2 :: (a -> Encoding) -> (b -> Encoding) -> f a b -> Encoding
448+
449+-- | Lift the standard 'toJSON' function through the type constructor.
450+toJSON2 :: (ToJSON2 f, ToJSON a, ToJSON b) => f a b -> Value
451+toJSON2 = liftToJSON2 toJSON toJSON
452+{-# INLINE toJSON2 #-}
453+
454+-- | Lift the standard 'toEncoding' function through the type constructor.
455+toEncoding2 :: (ToJSON2 f, ToJSON a, ToJSON b) => f a b -> Encoding
456+toEncoding2 = liftToEncoding2 toEncoding toEncoding
457+{-# INLINE toEncoding2 #-}
Data/Aeson/Types/Instances.hs+83−20
@@ -34,6 +34,17 @@ module Data.Aeson.Types.Instances
34 , FromJSONKeyFunction(..)
34 , FromJSONKeyFunction(..)
35 , fromJSONKeyCoerce
35 , fromJSONKeyCoerce
36 , coerceFromJSONKeyFunction
36 , coerceFromJSONKeyFunction
37+ -- ** Liftings to unary and binary type constructors
38+ , FromJSON1(..)
39+ , parseJSON1
40+ , FromJSON2(..)
41+ , parseJSON2
42+ , ToJSON1(..)
43+ , toJSON1
44+ , toEncoding1
45+ , ToJSON2(..)
46+ , toJSON2
47+ , toEncoding2
37 -- ** Generic JSON classes
48 -- ** Generic JSON classes
38 , GFromJSON(..)
49 , GFromJSON(..)
39 , GToJSON(..)
50 , GToJSON(..)
@@ -159,50 +170,102 @@ toJSONPair keySerialiser (a, b) = Array $ V.create $ do
159 VM.unsafeWrite mv 1 (toJSON b)
170 VM.unsafeWrite mv 1 (toJSON b)
160 return mv
171 return mv
161
172
173+instance ToJSON1 Identity where
174+ liftToJSON to (Identity a) = to a
175+ {-# INLINE liftToJSON #-}
176+
177+ liftToEncoding to (Identity a) = to a
178+ {-# INLINE liftToEncoding #-}
179+
162instance (ToJSON a) => ToJSON (Identity a) where
180instance (ToJSON a) => ToJSON (Identity a) where
163− toJSON (Identity a) = toJSON a
181+ toJSON = toJSON1
164 {-# INLINE toJSON #-}
182 {-# INLINE toJSON #-}
165
183
166− toEncoding (Identity a) = toEncoding a
184+ toEncoding = toEncoding1
167 {-# INLINE toEncoding #-}
185 {-# INLINE toEncoding #-}
168
186
187+instance FromJSON1 Identity where
188+ liftParseJSON p a = Identity <$> p a
189+ {-# INLINE liftParseJSON #-}
190+
169instance (FromJSON a) => FromJSON (Identity a) where
191instance (FromJSON a) => FromJSON (Identity a) where
170− parseJSON a = Identity <$> parseJSON a
192+ parseJSON = parseJSON1
171 {-# INLINE parseJSON #-}
193 {-# INLINE parseJSON #-}
172
194
195+
196+instance ToJSON1 Maybe where
197+ liftToJSON to (Just a) = to a
198+ liftToJSON _ Nothing = Null
199+ {-# INLINE liftToJSON #-}
200+
201+ liftToEncoding to (Just a) = to a
202+ liftToEncoding _ Nothing = Encoding E.null_
203+ {-# INLINE liftToEncoding #-}
204+
173instance (ToJSON a) => ToJSON (Maybe a) where
205instance (ToJSON a) => ToJSON (Maybe a) where
174− toJSON (Just a) = toJSON a
206+ toJSON = toJSON1
175− toJSON Nothing = Null
176 {-# INLINE toJSON #-}
207 {-# INLINE toJSON #-}
177
208
178− toEncoding (Just a) = toEncoding a
209+ toEncoding = toEncoding1
179− toEncoding Nothing = Encoding E.null_
180 {-# INLINE toEncoding #-}
210 {-# INLINE toEncoding #-}
181
211
212+instance FromJSON1 Maybe where
213+ liftParseJSON _ Null = pure Nothing
214+ liftParseJSON p a = Just <$> p a
215+ {-# INLINE liftParseJSON #-}
216+
182instance (FromJSON a) => FromJSON (Maybe a) where
217instance (FromJSON a) => FromJSON (Maybe a) where
183− parseJSON Null = pure Nothing
218+ parseJSON = parseJSON1
184− parseJSON a = Just <$> parseJSON a
185 {-# INLINE parseJSON #-}
219 {-# INLINE parseJSON #-}
186
220
221+
222+instance ToJSON2 Either where
223+ liftToJSON2 toA _toB (Left a) = Object $ H.singleton left (toA a)
224+ liftToJSON2 _toA toB (Right b) = Object $ H.singleton right (toB b)
225+ {-# INLINE liftToJSON2 #-}
226+
227+ liftToEncoding2 toA _toB (Left a) =
228+ Encoding (B.shortByteString "{\"Left\":")
229+ <> toA a
230+ <> Encoding (B.char7 '}')
231+
232+ liftToEncoding2 _toA toB (Right b) =
233+ Encoding (B.shortByteString "{\"Right\":")
234+ <> toB b
235+ <> Encoding (B.char7 '}')
236+ {-# INLINE liftToEncoding2 #-}
237+
238+instance (ToJSON a) => ToJSON1 (Either a) where
239+ liftToJSON = liftToJSON2 toJSON
240+ {-# INLINE liftToJSON #-}
241+
242+ liftToEncoding = liftToEncoding2 toEncoding
243+ {-# INLINE liftToEncoding #-}
244+
187instance (ToJSON a, ToJSON b) => ToJSON (Either a b) where
245instance (ToJSON a, ToJSON b) => ToJSON (Either a b) where
188− toJSON (Left a) = object [left .= a]
246+ toJSON = toJSON2
189− toJSON (Right b) = object [right .= b]
190 {-# INLINE toJSON #-}
247 {-# INLINE toJSON #-}
191
248
192− toEncoding (Left a) = Encoding $
249+ toEncoding = toEncoding2
193− B.shortByteString "{\"Left\":" <> builder a <> B.char7 '}'
194− toEncoding (Right a) = Encoding $
195− B.shortByteString "{\"Right\":" <> builder a <> B.char7 '}'
196 {-# INLINE toEncoding #-}
250 {-# INLINE toEncoding #-}
197
251
198−instance (FromJSON a, FromJSON b) => FromJSON (Either a b) where
252+instance FromJSON2 Either where
199− parseJSON (Object (H.toList -> [(key, value)]))
253+ liftParseJSON2 pA pB (Object (H.toList -> [(key, value)]))
200− | key == left = Left <$> parseJSON value <?> Key left
254+ | key == left = Left <$> pA value <?> Key left
201− | key == right = Right <$> parseJSON value <?> Key right
255+ | key == right = Right <$> pB value <?> Key right
202− parseJSON _ = fail $
256+
257+ liftParseJSON2 _ _ _ = fail $
203 "expected an object with a single property " ++
258 "expected an object with a single property " ++
204 "where the property key should be either " ++
259 "where the property key should be either " ++
205 "\"Left\" or \"Right\""
260 "\"Left\" or \"Right\""
261+ {-# INLINE liftParseJSON2 #-}
262+
263+instance (FromJSON a) => FromJSON1 (Either a) where
264+ liftParseJSON = liftParseJSON2 parseJSON
265+ {-# INLINE liftParseJSON #-}
266+
267+instance (FromJSON a, FromJSON b) => FromJSON (Either a b) where
268+ parseJSON = parseJSON2
206 {-# INLINE parseJSON #-}
269 {-# INLINE parseJSON #-}
207
270
208left, right :: Text
271left, right :: Text