git.iko.soy/typeable/aeson
on master help sign in
Add lifted typeclasses and some instances
commit79fcb38ae663e1cd3f7933e0e4433dd157ef0fc8 authorOleg Grenrus <oleg.grenrus@iki.fi> dateThu 24 Mar 2016, 15:35 (11 years ago) parentd951768
3 files changed+165−20
compare with master
unifiedsplit
Data/Aeson/Types.hs+12 Data/Aeson/Types/Class.hs+70 Data/Aeson/Types/Instances.hs+83−20
Data/Aeson/Types.hs+12
@@ -45,6 +45,18 @@ module Data.Aeson.Types
4545 , fromJSONKeyCoerce
4646 , coerceFromJSONKeyFunction
4747
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+
4860 -- ** Generic JSON classes
4961 , GFromJSON(..)
5062 , GToJSON(..)
Data/Aeson/Types/Class.hs+70
@@ -17,6 +17,17 @@ module Data.Aeson.Types.Class
1717 -- * Core JSON classes
1818 FromJSON(..)
1919 , 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
2031 -- * Generic JSON classes
2132 , GFromJSON(..)
2233 , GToJSON(..)
@@ -385,3 +396,62 @@ typeMismatch expected actual =
385396 Number _ -> "Number"
386397 Bool _ -> "Boolean"
387398 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
3434 , FromJSONKeyFunction(..)
3535 , fromJSONKeyCoerce
3636 , 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
3748 -- ** Generic JSON classes
3849 , GFromJSON(..)
3950 , GToJSON(..)
@@ -159,50 +170,102 @@ toJSONPair keySerialiser (a, b) = Array $ V.create $ do
159170 VM.unsafeWrite mv 1 (toJSON b)
160171 return mv
161172
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+
162180instance (ToJSON a) => ToJSON (Identity a) where
163− toJSON (Identity a) = toJSON a
181+ toJSON = toJSON1
164182 {-# INLINE toJSON #-}
165183
166− toEncoding (Identity a) = toEncoding a
184+ toEncoding = toEncoding1
167185 {-# INLINE toEncoding #-}
168186
187+instance FromJSON1 Identity where
188+ liftParseJSON p a = Identity <$> p a
189+ {-# INLINE liftParseJSON #-}
190+
169191instance (FromJSON a) => FromJSON (Identity a) where
170− parseJSON a = Identity <$> parseJSON a
192+ parseJSON = parseJSON1
171193 {-# INLINE parseJSON #-}
172194
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+
173205instance (ToJSON a) => ToJSON (Maybe a) where
174− toJSON (Just a) = toJSON a
175− toJSON Nothing = Null
206+ toJSON = toJSON1
176207 {-# INLINE toJSON #-}
177208
178− toEncoding (Just a) = toEncoding a
179− toEncoding Nothing = Encoding E.null_
209+ toEncoding = toEncoding1
180210 {-# INLINE toEncoding #-}
181211
212+instance FromJSON1 Maybe where
213+ liftParseJSON _ Null = pure Nothing
214+ liftParseJSON p a = Just <$> p a
215+ {-# INLINE liftParseJSON #-}
216+
182217instance (FromJSON a) => FromJSON (Maybe a) where
183− parseJSON Null = pure Nothing
184− parseJSON a = Just <$> parseJSON a
218+ parseJSON = parseJSON1
185219 {-# INLINE parseJSON #-}
186220
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+
187245instance (ToJSON a, ToJSON b) => ToJSON (Either a b) where
188− toJSON (Left a) = object [left .= a]
189− toJSON (Right b) = object [right .= b]
246+ toJSON = toJSON2
190247 {-# INLINE toJSON #-}
191248
192− toEncoding (Left a) = Encoding $
193− B.shortByteString "{\"Left\":" <> builder a <> B.char7 '}'
194− toEncoding (Right a) = Encoding $
195− B.shortByteString "{\"Right\":" <> builder a <> B.char7 '}'
249+ toEncoding = toEncoding2
196250 {-# INLINE toEncoding #-}
197251
198−instance (FromJSON a, FromJSON b) => FromJSON (Either a b) where
199− parseJSON (Object (H.toList -> [(key, value)]))
200− | key == left = Left <$> parseJSON value <?> Key left
201− | key == right = Right <$> parseJSON value <?> Key right
202− parseJSON _ = fail $
252+instance FromJSON2 Either where
253+ liftParseJSON2 pA pB (Object (H.toList -> [(key, value)]))
254+ | key == left = Left <$> pA value <?> Key left
255+ | key == right = Right <$> pB value <?> Key right
256+
257+ liftParseJSON2 _ _ _ = fail $
203258 "expected an object with a single property " ++
204259 "where the property key should be either " ++
205260 "\"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
206269 {-# INLINE parseJSON #-}
207270
208271left, right :: Text