@@ -1,5 +1,5 @@
11{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, IncoherentInstances,
2− OverlappingInstances #-}
2+ OverlappingInstances, Rank2Types #-}
33
44-- Module: Data.Aeson.Types
55-- Copyright: (c) 2011 MailRank, Inc.
@@ -20,7 +20,11 @@ module Data.Aeson.Types
2020 , Object
2121 , emptyObject
2222 -- * Type conversion
23+ , Parser
24+ , Result(..)
2325 , FromJSON(..)
26+ , fromJSON
27+ , parse
2428 , ToJSON(..)
2529 -- * Constructors and accessors
2630 , (.=)
@@ -30,6 +34,8 @@ module Data.Aeson.Types
3034 ) where
3135
3236import Control.Applicative
37+import Control.Monad (MonadPlus(..))
38+import Data.Monoid (Monoid(..))
3339import Control.DeepSeq (NFData(..))
3440import Data.Data (Data)
3541import Data.Int (Int8, Int16, Int32, Int64)
@@ -54,6 +60,70 @@ import qualified Data.Text.Lazy as LT
5460import qualified Data.Vector as V
5561import Data.Aeson.Functions
5662
63+-- | The result of running a 'Parser'.
64+data Result a = Error String
65+ | Success a
66+ deriving (Eq, Show, Typeable)
67+
68+-- | Failure continuation. Constructs an 'Error'.
69+type Failure r = String -> Result r
70+-- | Success continuation. Constructs a 'Success'.
71+type Success a r = a -> Result r
72+
73+-- | A continuation-based parser type.
74+newtype Parser a = Parser {
75+ runParser :: forall r.
76+ Failure r
77+ -> Success a r
78+ -> Result r
79+ }
80+
81+instance Monad Parser where
82+ m >>= g = Parser $ \kf ks -> let ks' a = runParser (g a) kf ks
83+ in runParser m kf ks'
84+ {-# INLINE (>>=) #-}
85+ return a = Parser $ \_kf ks -> ks a
86+ {-# INLINE return #-}
87+ fail msg = Parser $ \kf _ks -> kf msg
88+ {-# INLINE fail #-}
89+
90+instance Functor Parser where
91+ fmap f m = Parser $ \kf ks -> let ks' a = ks (f a)
92+ in runParser m kf ks'
93+ {-# INLINE fmap #-}
94+
95+instance Applicative Parser where
96+ pure = return
97+ {-# INLINE pure #-}
98+ (<*>) = apP
99+ {-# INLINE (<*>) #-}
100+
101+instance Alternative Parser where
102+ empty = fail "empty"
103+ {-# INLINE empty #-}
104+ (<|>) = mplus
105+ {-# INLINE (<|>) #-}
106+
107+instance MonadPlus Parser where
108+ mzero = fail "mzero"
109+ {-# INLINE mzero #-}
110+ mplus a b = Parser $ \kf ks -> let kf' _ = runParser b kf ks
111+ in runParser a kf' ks
112+ {-# INLINE mplus #-}
113+
114+instance Monoid (Parser a) where
115+ mempty = fail "mempty"
116+ {-# INLINE mempty #-}
117+ mappend = mplus
118+ {-# INLINE mappend #-}
119+
120+apP :: Parser (a -> b) -> Parser a -> Parser b
121+apP d e = do
122+ b <- d
123+ a <- e
124+ return (b a)
125+{-# INLINE apP #-}
126+
57127-- | A JSON \"object\" (key\/value map).
58128type Object = Map Text Value
59129
@@ -93,6 +163,16 @@ type Pair = (Text, Value)
93163name .= value = (name, toJSON value)
94164{-# INLINE (.=) #-}
95165
166+-- | Convert a value from JSON, failing if the types do not match.
167+fromJSON :: (FromJSON a) => Value -> Result a
168+fromJSON = parse parseJSON
169+{-# INLINE fromJSON #-}
170+
171+-- | Run a 'Parser'.
172+parse :: (a -> Parser b) -> a -> Result b
173+parse m v = runParser (m v) Error Success
174+{-# INLINE parse #-}
175+
96176-- | Retrieve the value associated with the given key of an 'Object'.
97177-- The result is 'empty' if the key is not present or the value cannot
98178-- be converted to the desired type.
@@ -100,10 +180,10 @@ name .= value = (name, toJSON value)
100180-- This accessor is appropriate if the key and value /must/ be present
101181-- in an object for it to be valid. If the key and value are
102182-- optional, use '(.:?)' instead.
103−(.:) :: (Alternative m, FromJSON a) => Object -> Text -> m a
183+(.:) :: (FromJSON a) => Object -> Text -> Parser a
104184obj .: key = case M.lookup key obj of
105185 Nothing -> empty
106− Just v -> fromJSON v
186+ Just v -> parseJSON v
107187{-# INLINE (.:) #-}
108188
109189-- | Retrieve the value associated with the given key of an 'Object'.
@@ -113,10 +193,10 @@ obj .: key = case M.lookup key obj of
113193-- This accessor is most useful if the key and value can be absent
114194-- from an object without affecting its validity. If the key and
115195-- value are mandatory, use '(.:?)' instead.
116−(.:?) :: (Alternative m, FromJSON a) => Object -> Text -> m (Maybe a)
196+(.:?) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)
117197obj .:? key = case M.lookup key obj of
118198 Nothing -> pure Nothing
119− Just v -> fromJSON v
199+ Just v -> parseJSON v
120200{-# INLINE (.:?) #-}
121201
122202-- | Create a 'Value' from a list of name\/value 'Pair's. If duplicate
@@ -140,24 +220,24 @@ class ToJSON a where
140220-- | A type that can be converted from JSON, with the possibility of
141221-- failure.
142222--
143−-- When writing an instance, use 'mzero' to make a conversion fail,
144−-- e.g. if an 'Object' is missing a required key, or the value is of
145−-- the wrong type.
223+-- When writing an instance, use 'mzero' or 'fail' to make a
224+-- conversion fail, e.g. if an 'Object' is missing a required key, or
225+-- the value is of the wrong type.
146226--
147227-- An example type and instance:
148228--
149229-- @data Coord { x :: Double, y :: Double }
150230--
151231-- instance FromJSON Coord where
152−-- fromJSON ('Object' v) = Coord '<$>'
232+-- parseJSON ('Object' v) = Coord '<$>'
153233-- v '.:' \"x\" '<*>'
154234-- v '.:' \"y\"
155235--
156236-- \-- A non-'Object' value is of the wrong type, so use 'mzero' to fail.
157−-- fromJSON _ = 'mzero'
237+-- parseJSON _ = 'mzero'
158238-- @
159239class FromJSON a where
160− fromJSON :: Alternative m => Value -> m a
240+ parseJSON :: Value -> Parser a
161241
162242instance (ToJSON a) => ToJSON (Maybe a) where
163243 toJSON (Just a) = toJSON a
@@ -165,9 +245,9 @@ instance (ToJSON a) => ToJSON (Maybe a) where
165245 {-# INLINE toJSON #-}
166246
167247instance (FromJSON a) => FromJSON (Maybe a) where
168− fromJSON Null = pure Nothing
169− fromJSON a = Just <$> fromJSON a
170− {-# INLINE fromJSON #-}
248+ parseJSON Null = pure Nothing
249+ parseJSON a = Just <$> parseJSON a
250+ {-# INLINE parseJSON #-}
171251
172252instance (ToJSON a, ToJSON b) => ToJSON (Either a b) where
173253 toJSON (Left a) = toJSON a
@@ -175,272 +255,272 @@ instance (ToJSON a, ToJSON b) => ToJSON (Either a b) where
175255 {-# INLINE toJSON #-}
176256
177257instance (FromJSON a, FromJSON b) => FromJSON (Either a b) where
178− fromJSON a = Left <$> fromJSON a <|> Right <$> fromJSON a
179− {-# INLINE fromJSON #-}
258+ parseJSON a = Left <$> parseJSON a <|> Right <$> parseJSON a
259+ {-# INLINE parseJSON #-}
180260
181261instance ToJSON Bool where
182262 toJSON = Bool
183263 {-# INLINE toJSON #-}
184264
185265instance FromJSON Bool where
186− fromJSON (Bool b) = pure b
187− fromJSON _ = empty
188− {-# INLINE fromJSON #-}
266+ parseJSON (Bool b) = pure b
267+ parseJSON _ = empty
268+ {-# INLINE parseJSON #-}
189269
190270instance ToJSON () where
191271 toJSON _ = emptyArray
192272 {-# INLINE toJSON #-}
193273
194274instance FromJSON () where
195− fromJSON (Array v) | V.null v = pure ()
196− fromJSON _ = empty
197− {-# INLINE fromJSON #-}
275+ parseJSON (Array v) | V.null v = pure ()
276+ parseJSON _ = empty
277+ {-# INLINE parseJSON #-}
198278
199279instance ToJSON [Char] where
200280 toJSON = String . T.pack
201281 {-# INLINE toJSON #-}
202282
203283instance FromJSON [Char] where
204− fromJSON (String t) = pure (T.unpack t)
205− fromJSON _ = empty
206− {-# INLINE fromJSON #-}
284+ parseJSON (String t) = pure (T.unpack t)
285+ parseJSON _ = empty
286+ {-# INLINE parseJSON #-}
207287
208288instance ToJSON Char where
209289 toJSON = String . T.singleton
210290 {-# INLINE toJSON #-}
211291
212292instance FromJSON Char where
213− fromJSON (String t)
293+ parseJSON (String t)
214294 | T.compareLength t 1 == EQ = pure (T.head t)
215− fromJSON _ = empty
216− {-# INLINE fromJSON #-}
295+ parseJSON _ = empty
296+ {-# INLINE parseJSON #-}
217297
218298instance ToJSON Double where
219299 toJSON = Number
220300 {-# INLINE toJSON #-}
221301
222302instance FromJSON Double where
223− fromJSON (Number n) = pure n
224− fromJSON _ = empty
225− {-# INLINE fromJSON #-}
303+ parseJSON (Number n) = pure n
304+ parseJSON _ = empty
305+ {-# INLINE parseJSON #-}
226306
227307instance ToJSON Float where
228308 toJSON = Number . fromRational . toRational
229309 {-# INLINE toJSON #-}
230310
231311instance FromJSON Float where
232− fromJSON (Number n) = pure . fromRational . toRational $ n
233− fromJSON _ = empty
234− {-# INLINE fromJSON #-}
312+ parseJSON (Number n) = pure . fromRational . toRational $ n
313+ parseJSON _ = empty
314+ {-# INLINE parseJSON #-}
235315
236316instance ToJSON (Ratio Integer) where
237317 toJSON = Number . fromRational
238318 {-# INLINE toJSON #-}
239319
240320instance FromJSON (Ratio Integer) where
241− fromJSON (Number n) = pure . toRational $ n
242− fromJSON _ = empty
243− {-# INLINE fromJSON #-}
321+ parseJSON (Number n) = pure . toRational $ n
322+ parseJSON _ = empty
323+ {-# INLINE parseJSON #-}
244324
245325instance ToJSON Int where
246326 toJSON = Number . fromIntegral
247327 {-# INLINE toJSON #-}
248328
249329instance FromJSON Int where
250− fromJSON (Number n) = pure (floor n)
251− fromJSON _ = empty
252− {-# INLINE fromJSON #-}
330+ parseJSON (Number n) = pure (floor n)
331+ parseJSON _ = empty
332+ {-# INLINE parseJSON #-}
253333
254334instance ToJSON Integer where
255335 toJSON = Number . fromIntegral
256336 {-# INLINE toJSON #-}
257337
258338instance FromJSON Integer where
259− fromJSON (Number n) = pure (floor n)
260− fromJSON _ = empty
261− {-# INLINE fromJSON #-}
339+ parseJSON (Number n) = pure (floor n)
340+ parseJSON _ = empty
341+ {-# INLINE parseJSON #-}
262342
263343instance ToJSON Int8 where
264344 toJSON = Number . fromIntegral
265345 {-# INLINE toJSON #-}
266346
267347instance FromJSON Int8 where
268− fromJSON (Number n) = pure (floor n)
269− fromJSON _ = empty
270− {-# INLINE fromJSON #-}
348+ parseJSON (Number n) = pure (floor n)
349+ parseJSON _ = empty
350+ {-# INLINE parseJSON #-}
271351
272352instance ToJSON Int16 where
273353 toJSON = Number . fromIntegral
274354 {-# INLINE toJSON #-}
275355
276356instance FromJSON Int16 where
277− fromJSON (Number n) = pure (floor n)
278− fromJSON _ = empty
279− {-# INLINE fromJSON #-}
357+ parseJSON (Number n) = pure (floor n)
358+ parseJSON _ = empty
359+ {-# INLINE parseJSON #-}
280360
281361instance ToJSON Int32 where
282362 toJSON = Number . fromIntegral
283363 {-# INLINE toJSON #-}
284364
285365instance FromJSON Int32 where
286− fromJSON (Number n) = pure (floor n)
287− fromJSON _ = empty
288− {-# INLINE fromJSON #-}
366+ parseJSON (Number n) = pure (floor n)
367+ parseJSON _ = empty
368+ {-# INLINE parseJSON #-}
289369
290370instance ToJSON Int64 where
291371 toJSON = Number . fromIntegral
292372 {-# INLINE toJSON #-}
293373
294374instance FromJSON Int64 where
295− fromJSON (Number n) = pure (floor n)
296− fromJSON _ = empty
297− {-# INLINE fromJSON #-}
375+ parseJSON (Number n) = pure (floor n)
376+ parseJSON _ = empty
377+ {-# INLINE parseJSON #-}
298378
299379instance ToJSON Word where
300380 toJSON = Number . fromIntegral
301381 {-# INLINE toJSON #-}
302382
303383instance FromJSON Word where
304− fromJSON (Number n) = pure (floor n)
305− fromJSON _ = empty
306− {-# INLINE fromJSON #-}
384+ parseJSON (Number n) = pure (floor n)
385+ parseJSON _ = empty
386+ {-# INLINE parseJSON #-}
307387
308388instance ToJSON Word8 where
309389 toJSON = Number . fromIntegral
310390 {-# INLINE toJSON #-}
311391
312392instance FromJSON Word8 where
313− fromJSON (Number n) = pure (floor n)
314− fromJSON _ = empty
315− {-# INLINE fromJSON #-}
393+ parseJSON (Number n) = pure (floor n)
394+ parseJSON _ = empty
395+ {-# INLINE parseJSON #-}
316396
317397instance ToJSON Word16 where
318398 toJSON = Number . fromIntegral
319399 {-# INLINE toJSON #-}
320400
321401instance FromJSON Word16 where
322− fromJSON (Number n) = pure (floor n)
323− fromJSON _ = empty
324− {-# INLINE fromJSON #-}
402+ parseJSON (Number n) = pure (floor n)
403+ parseJSON _ = empty
404+ {-# INLINE parseJSON #-}
325405
326406instance ToJSON Word32 where
327407 toJSON = Number . fromIntegral
328408 {-# INLINE toJSON #-}
329409
330410instance FromJSON Word32 where
331− fromJSON (Number n) = pure (floor n)
332− fromJSON _ = empty
333− {-# INLINE fromJSON #-}
411+ parseJSON (Number n) = pure (floor n)
412+ parseJSON _ = empty
413+ {-# INLINE parseJSON #-}
334414
335415instance ToJSON Word64 where
336416 toJSON = Number . fromIntegral
337417 {-# INLINE toJSON #-}
338418
339419instance FromJSON Word64 where
340− fromJSON (Number n) = pure (floor n)
341− fromJSON _ = empty
342− {-# INLINE fromJSON #-}
420+ parseJSON (Number n) = pure (floor n)
421+ parseJSON _ = empty
422+ {-# INLINE parseJSON #-}
343423
344424instance ToJSON Text where
345425 toJSON = String
346426 {-# INLINE toJSON #-}
347427
348428instance FromJSON Text where
349− fromJSON (String t) = pure t
350− fromJSON _ = empty
351− {-# INLINE fromJSON #-}
429+ parseJSON (String t) = pure t
430+ parseJSON _ = empty
431+ {-# INLINE parseJSON #-}
352432
353433instance ToJSON LT.Text where
354434 toJSON = String . LT.toStrict
355435 {-# INLINE toJSON #-}
356436
357437instance FromJSON LT.Text where
358− fromJSON (String t) = pure (LT.fromStrict t)
359− fromJSON _ = empty
360− {-# INLINE fromJSON #-}
438+ parseJSON (String t) = pure (LT.fromStrict t)
439+ parseJSON _ = empty
440+ {-# INLINE parseJSON #-}
361441
362442instance ToJSON B.ByteString where
363443 toJSON = String . decodeUtf8
364444 {-# INLINE toJSON #-}
365445
366446instance FromJSON B.ByteString where
367− fromJSON (String t) = pure . encodeUtf8 $ t
368− fromJSON _ = empty
369− {-# INLINE fromJSON #-}
447+ parseJSON (String t) = pure . encodeUtf8 $ t
448+ parseJSON _ = empty
449+ {-# INLINE parseJSON #-}
370450
371451instance ToJSON LB.ByteString where
372452 toJSON = toJSON . B.concat . LB.toChunks
373453 {-# INLINE toJSON #-}
374454
375455instance FromJSON LB.ByteString where
376− fromJSON (String t) = pure . LB.fromChunks . (:[]) . encodeUtf8 $ t
377− fromJSON _ = empty
378− {-# INLINE fromJSON #-}
456+ parseJSON (String t) = pure . LB.fromChunks . (:[]) . encodeUtf8 $ t
457+ parseJSON _ = empty
458+ {-# INLINE parseJSON #-}
379459
380460instance (ToJSON a) => ToJSON [a] where
381461 toJSON = Array . V.fromList . map toJSON
382462 {-# INLINE toJSON #-}
383463
384464instance (FromJSON a) => FromJSON [a] where
385− fromJSON (Array a) = mapA fromJSON (V.toList a)
386− fromJSON _ = empty
387− {-# INLINE fromJSON #-}
465+ parseJSON (Array a) = mapA parseJSON (V.toList a)
466+ parseJSON _ = empty
467+ {-# INLINE parseJSON #-}
388468
389469instance (ToJSON a) => ToJSON (Vector a) where
390470 toJSON = Array . V.map toJSON
391471 {-# INLINE toJSON #-}
392472
393473instance (FromJSON a) => FromJSON (Vector a) where
394− fromJSON (Array a) = V.fromList <$> mapA fromJSON (V.toList a)
395− fromJSON _ = empty
396− {-# INLINE fromJSON #-}
474+ parseJSON (Array a) = V.fromList <$> mapA parseJSON (V.toList a)
475+ parseJSON _ = empty
476+ {-# INLINE parseJSON #-}
397477
398478instance (ToJSON a) => ToJSON (Set.Set a) where
399479 toJSON = toJSON . Set.toList
400480 {-# INLINE toJSON #-}
401481
402482instance (Ord a, FromJSON a) => FromJSON (Set.Set a) where
403− fromJSON = fmap Set.fromList . fromJSON
404− {-# INLINE fromJSON #-}
483+ parseJSON = fmap Set.fromList . parseJSON
484+ {-# INLINE parseJSON #-}
405485
406486instance ToJSON IntSet.IntSet where
407487 toJSON = toJSON . IntSet.toList
408488 {-# INLINE toJSON #-}
409489
410490instance FromJSON IntSet.IntSet where
411− fromJSON = fmap IntSet.fromList . fromJSON
412− {-# INLINE fromJSON #-}
491+ parseJSON = fmap IntSet.fromList . parseJSON
492+ {-# INLINE parseJSON #-}
413493
414494instance (ToJSON v) => ToJSON (M.Map Text v) where
415495 toJSON = Object . M.map toJSON
416496 {-# INLINE toJSON #-}
417497
418498instance (FromJSON v) => FromJSON (M.Map Text v) where
419− fromJSON (Object o) = M.fromAscList <$> go (M.toAscList o)
499+ parseJSON (Object o) = M.fromAscList <$> go (M.toAscList o)
420500 where
421− go ((k,v):kvs) = ((:) . (,) k) <$> fromJSON v <*> go kvs
501+ go ((k,v):kvs) = ((:) . (,) k) <$> parseJSON v <*> go kvs
422502 go _ = pure []
423− fromJSON _ = empty
503+ parseJSON _ = empty
424504
425505instance (ToJSON v) => ToJSON (M.Map LT.Text v) where
426506 toJSON = Object . transformMap LT.toStrict toJSON
427507
428508instance (FromJSON v) => FromJSON (M.Map LT.Text v) where
429− fromJSON = fmap (M.mapKeysMonotonic LT.fromStrict) . fromJSON
509+ parseJSON = fmap (M.mapKeysMonotonic LT.fromStrict) . parseJSON
430510
431511instance (ToJSON v) => ToJSON (M.Map String v) where
432512 toJSON = Object . transformMap pack toJSON
433513
434514instance (FromJSON v) => FromJSON (M.Map String v) where
435− fromJSON = fmap (M.mapKeysMonotonic unpack) . fromJSON
515+ parseJSON = fmap (M.mapKeysMonotonic unpack) . parseJSON
436516
437517instance ToJSON Value where
438518 toJSON a = a
439519 {-# INLINE toJSON #-}
440520
441521instance FromJSON Value where
442− fromJSON a = pure a
443− {-# INLINE fromJSON #-}
522+ parseJSON a = pure a
523+ {-# INLINE parseJSON #-}
444524
445525-- We happen to use the same JSON formatting for a UTCTime as .NET
446526-- does for a DateTime. How handy!
@@ -449,47 +529,47 @@ instance ToJSON UTCTime where
449529 {-# INLINE toJSON #-}
450530
451531instance FromJSON UTCTime where
452− fromJSON (String t) =
532+ parseJSON (String t) =
453533 case parseTime defaultTimeLocale "/Date(%s)/" (unpack t) of
454534 Just d -> pure d
455535 _ -> empty
456− fromJSON _ = empty
457− {-# INLINE fromJSON #-}
536+ parseJSON _ = empty
537+ {-# INLINE parseJSON #-}
458538
459539instance (ToJSON a, ToJSON b) => ToJSON (a,b) where
460540 toJSON (a,b) = toJSON [toJSON a, toJSON b]
461541 {-# INLINE toJSON #-}
462542
463543instance (FromJSON a, FromJSON b) => FromJSON (a,b) where
464− fromJSON (Array ab) = case V.toList ab of
465− [a,b] -> (,) <$> fromJSON a <*> fromJSON b
544+ parseJSON (Array ab) = case V.toList ab of
545+ [a,b] -> (,) <$> parseJSON a <*> parseJSON b
466546 _ -> empty
467− fromJSON _ = empty
468− {-# INLINE fromJSON #-}
547+ parseJSON _ = empty
548+ {-# INLINE parseJSON #-}
469549
470550instance ToJSON a => ToJSON (Dual a) where
471551 toJSON = toJSON . getDual
472552 {-# INLINE toJSON #-}
473553
474554instance FromJSON a => FromJSON (Dual a) where
475− fromJSON = fmap Dual . fromJSON
476− {-# INLINE fromJSON #-}
555+ parseJSON = fmap Dual . parseJSON
556+ {-# INLINE parseJSON #-}
477557
478558instance ToJSON a => ToJSON (First a) where
479559 toJSON = toJSON . getFirst
480560 {-# INLINE toJSON #-}
481561
482562instance FromJSON a => FromJSON (First a) where
483− fromJSON = fmap First . fromJSON
484− {-# INLINE fromJSON #-}
563+ parseJSON = fmap First . parseJSON
564+ {-# INLINE parseJSON #-}
485565
486566instance ToJSON a => ToJSON (Last a) where
487567 toJSON = toJSON . getLast
488568 {-# INLINE toJSON #-}
489569
490570instance FromJSON a => FromJSON (Last a) where
491− fromJSON = fmap Last . fromJSON
492− {-# INLINE fromJSON #-}
571+ parseJSON = fmap Last . parseJSON
572+ {-# INLINE parseJSON #-}
493573
494574mapA :: (Alternative m) => (t -> m a) -> [t] -> m [a]
495575mapA f = go