@@ -19,8 +19,9 @@ module Data.Aeson.Types
1919 , Pair
2020 , Object
2121 , emptyObject
22− -- * Convenience types
22+ -- * Convenience types and functions
2323 , DotNetTime(..)
24+ , typeMismatch
2425 -- * Type conversion
2526 , Parser
2627 , Result(..)
@@ -191,7 +192,7 @@ parse m v = runParser (m v) Error Success
191192-- optional, use '(.:?)' instead.
192193(.:) :: (FromJSON a) => Object -> Text -> Parser a
193194obj .: key = case M.lookup key obj of
194− Nothing -> empty
195+ Nothing -> fail $ "key " ++ show key ++ " not present"
195196 Just v -> parseJSON v
196197{-# INLINE (.:) #-}
197198
@@ -273,7 +274,7 @@ instance ToJSON Bool where
273274
274275instance FromJSON Bool where
275276 parseJSON (Bool b) = pure b
276− parseJSON _ = empty
277+ parseJSON v = typeMismatch "Bool" v
277278 {-# INLINE parseJSON #-}
278279
279280instance ToJSON () where
@@ -282,7 +283,7 @@ instance ToJSON () where
282283
283284instance FromJSON () where
284285 parseJSON (Array v) | V.null v = pure ()
285− parseJSON _ = empty
286+ parseJSON v = typeMismatch "()" v
286287 {-# INLINE parseJSON #-}
287288
288289instance ToJSON [Char] where
@@ -291,7 +292,7 @@ instance ToJSON [Char] where
291292
292293instance FromJSON [Char] where
293294 parseJSON (String t) = pure (T.unpack t)
294− parseJSON _ = empty
295+ parseJSON v = typeMismatch "String" v
295296 {-# INLINE parseJSON #-}
296297
297298instance ToJSON Char where
@@ -301,7 +302,7 @@ instance ToJSON Char where
301302instance FromJSON Char where
302303 parseJSON (String t)
303304 | T.compareLength t 1 == EQ = pure (T.head t)
304− parseJSON _ = empty
305+ parseJSON v = typeMismatch "Char" v
305306 {-# INLINE parseJSON #-}
306307
307308instance ToJSON Double where
@@ -312,7 +313,7 @@ instance FromJSON Double where
312313 parseJSON (Number n) = case n of
313314 D d -> pure d
314315 I i -> pure (fromIntegral i)
315− parseJSON _ = empty
316+ parseJSON v = typeMismatch "Double" v
316317 {-# INLINE parseJSON #-}
317318
318319instance ToJSON Number where
@@ -321,7 +322,7 @@ instance ToJSON Number where
321322
322323instance FromJSON Number where
323324 parseJSON (Number n) = pure n
324− parseJSON _ = empty
325+ parseJSON v = typeMismatch "Number" v
325326 {-# INLINE parseJSON #-}
326327
327328instance ToJSON Float where
@@ -332,7 +333,7 @@ instance FromJSON Float where
332333 parseJSON (Number n) = case n of
333334 D d -> pure . fromRational . toRational $ d
334335 I i -> pure (fromIntegral i)
335− parseJSON _ = empty
336+ parseJSON v = typeMismatch "Float" v
336337 {-# INLINE parseJSON #-}
337338
338339instance ToJSON (Ratio Integer) where
@@ -343,7 +344,7 @@ instance FromJSON (Ratio Integer) where
343344 parseJSON (Number n) = case n of
344345 D d -> pure . toRational $ d
345346 I i -> pure (fromIntegral i)
346− parseJSON _ = empty
347+ parseJSON v = typeMismatch "Ratio Integer" v
347348 {-# INLINE parseJSON #-}
348349
349350instance ToJSON Int where
@@ -356,7 +357,7 @@ instance FromJSON Int where
356357
357358parseIntegral :: Integral a => Value -> Parser a
358359parseIntegral (Number n) = pure (floor n)
359−parseIntegral _ = empty
360+parseIntegral v = typeMismatch "Integral" v
360361{-# INLINE parseIntegral #-}
361362
362363instance ToJSON Integer where
@@ -445,7 +446,7 @@ instance ToJSON Text where
445446
446447instance FromJSON Text where
447448 parseJSON (String t) = pure t
448− parseJSON _ = empty
449+ parseJSON v = typeMismatch "Text" v
449450 {-# INLINE parseJSON #-}
450451
451452instance ToJSON LT.Text where
@@ -454,7 +455,7 @@ instance ToJSON LT.Text where
454455
455456instance FromJSON LT.Text where
456457 parseJSON (String t) = pure (LT.fromStrict t)
457− parseJSON _ = empty
458+ parseJSON v = typeMismatch "Lazy Text" v
458459 {-# INLINE parseJSON #-}
459460
460461instance ToJSON B.ByteString where
@@ -463,7 +464,7 @@ instance ToJSON B.ByteString where
463464
464465instance FromJSON B.ByteString where
465466 parseJSON (String t) = pure . encodeUtf8 $ t
466− parseJSON _ = empty
467+ parseJSON v = typeMismatch "ByteString" v
467468 {-# INLINE parseJSON #-}
468469
469470instance ToJSON LB.ByteString where
@@ -472,7 +473,7 @@ instance ToJSON LB.ByteString where
472473
473474instance FromJSON LB.ByteString where
474475 parseJSON (String t) = pure . lazy $ t
475− parseJSON _ = empty
476+ parseJSON v = typeMismatch "Lazy ByteString" v
476477 {-# INLINE parseJSON #-}
477478
478479instance (ToJSON a) => ToJSON [a] where
@@ -481,7 +482,7 @@ instance (ToJSON a) => ToJSON [a] where
481482
482483instance (FromJSON a) => FromJSON [a] where
483484 parseJSON (Array a) = mapM parseJSON (V.toList a)
484− parseJSON _ = empty
485+ parseJSON v = typeMismatch "[a]" v
485486 {-# INLINE parseJSON #-}
486487
487488instance (ToJSON a) => ToJSON (Vector a) where
@@ -490,7 +491,7 @@ instance (ToJSON a) => ToJSON (Vector a) where
490491
491492instance (FromJSON a) => FromJSON (Vector a) where
492493 parseJSON (Array a) = V.mapM parseJSON a
493− parseJSON _ = empty
494+ parseJSON v = typeMismatch "Vector a" v
494495 {-# INLINE parseJSON #-}
495496
496497instance (ToJSON a) => ToJSON (Set.Set a) where
@@ -516,7 +517,7 @@ instance (ToJSON v) => ToJSON (M.Map Text v) where
516517instance (FromJSON v) => FromJSON (M.Map Text v) where
517518 parseJSON (Object o) = M.fromAscList <$> mapM go (M.toAscList o)
518519 where go (k,v) = ((,) k) <$> parseJSON v
519− parseJSON _ = empty
520+ parseJSON v = typeMismatch "Map Text a" v
520521
521522instance (ToJSON v) => ToJSON (M.Map LT.Text v) where
522523 toJSON = Object . transformMap LT.toStrict toJSON
@@ -549,7 +550,7 @@ instance (ToJSON v) => ToJSON (H.HashMap Text v) where
549550instance (FromJSON v) => FromJSON (H.HashMap Text v) where
550551 parseJSON (Object o) = H.fromList <$> mapM go (M.toList o)
551552 where go (k,v) = ((,) k) <$> parseJSON v
552− parseJSON _ = empty
553+ parseJSON v = typeMismatch "HashMap Text a" v
553554
554555instance (ToJSON v) => ToJSON (H.HashMap LT.Text v) where
555556 toJSON = Object . M.fromList . H.foldrWithKey (\k v -> ((LT.toStrict k,toJSON v) :)) []
@@ -598,8 +599,8 @@ instance FromJSON DotNetTime where
598599 parseJSON (String t) =
599600 case parseTime defaultTimeLocale "/Date(%s)/" (unpack t) of
600601 Just d -> pure (DotNetTime d)
601− _ -> empty
602− parseJSON _ = empty
602+ _ -> fail "could not parse .NET time"
603+ parseJSON v = typeMismatch "DotNetTime" v
603604 {-# INLINE parseJSON #-}
604605
605606instance ToJSON UTCTime where
@@ -609,10 +610,10 @@ instance ToJSON UTCTime where
609610
610611instance FromJSON UTCTime where
611612 parseJSON (String t) =
612− case parseTime defaultTimeLocale "%FT%X%QZ" (unpack t) of
613+ case parseTime defaultTimeLocale "%FT%T%QZ" (unpack t) of
613614 Just d -> pure d
614− _ -> empty
615− parseJSON _ = empty
615+ _ -> fail "could not parse ISO-8601 date"
616+ parseJSON v = typeMismatch "UTCTime" v
616617 {-# INLINE parseJSON #-}
617618
618619instance (ToJSON a, ToJSON b) => ToJSON (a,b) where
@@ -620,10 +621,25 @@ instance (ToJSON a, ToJSON b) => ToJSON (a,b) where
620621 {-# INLINE toJSON #-}
621622
622623instance (FromJSON a, FromJSON b) => FromJSON (a,b) where
623− parseJSON (Array ab) = case V.toList ab of
624− [a,b] -> (,) <$> parseJSON a <*> parseJSON b
625− _ -> empty
626− parseJSON _ = empty
624+ parseJSON (Array ab) =
625+ case V.toList ab of
626+ [a,b] -> (,) <$> parseJSON a <*> parseJSON b
627+ _ -> fail $ "cannot unpack array of length " ++
628+ show (V.length ab) ++ " into a pair"
629+ parseJSON v = typeMismatch "(a,b)" v
630+ {-# INLINE parseJSON #-}
631+
632+instance (ToJSON a, ToJSON b, ToJSON c) => ToJSON (a,b,c) where
633+ toJSON (a,b,c) = toJSON [toJSON a, toJSON b, toJSON c]
634+ {-# INLINE toJSON #-}
635+
636+instance (FromJSON a, FromJSON b, FromJSON c) => FromJSON (a,b,c) where
637+ parseJSON (Array abc) =
638+ case V.toList abc of
639+ [a,b,c] -> (,,) <$> parseJSON a <*> parseJSON b <*> parseJSON c
640+ _ -> fail $ "cannot unpack array of length " ++
641+ show (V.length abc) ++ " into a 3-tuple"
642+ parseJSON v = typeMismatch "(a,b,c)" v
627643 {-# INLINE parseJSON #-}
628644
629645instance ToJSON a => ToJSON (Dual a) where
@@ -649,3 +665,19 @@ instance ToJSON a => ToJSON (Last a) where
649665instance FromJSON a => FromJSON (Last a) where
650666 parseJSON = fmap Last . parseJSON
651667 {-# INLINE parseJSON #-}
668+
669+-- | Fail parsing due to a type mismatch, with a descriptive message.
670+typeMismatch :: String -- ^ The name of the type you are trying to parse.
671+ -> Value -- ^ The actual value encountered.
672+ -> Parser a
673+typeMismatch expected actual =
674+ fail $ "when expecting a " ++ expected ++ ", encountered " ++ name ++
675+ " instead"
676+ where
677+ name = case actual of
678+ Object _ -> "Object"
679+ Array _ -> "Array"
680+ String _ -> "String"
681+ Number _ -> "Number"
682+ Bool _ -> "Boolean"
683+ Null -> "Null"