@@ -31,6 +31,14 @@ module Data.Aeson.Types.Class
3131#endif
3232 -- * Types
3333 , DotNetTime(..)
34+
35+ -- * Inspecting @'Value's@
36+ , withObject
37+ , withText
38+ , withArray
39+ , withNumber
40+ , withBool
41+
3442 -- * Functions
3543 , fromJSON
3644 , (.:)
@@ -230,8 +238,7 @@ instance ToJSON Bool where
230238 {-# INLINE toJSON #-}
231239
232240instance FromJSON Bool where
233− parseJSON (Bool b) = pure b
234− parseJSON v = typeMismatch "Bool" v
241+ parseJSON = withBool "Bool" pure
235242 {-# INLINE parseJSON #-}
236243
237244instance ToJSON () where
@@ -239,8 +246,10 @@ instance ToJSON () where
239246 {-# INLINE toJSON #-}
240247
241248instance FromJSON () where
242− parseJSON (Array v) | V.null v = pure ()
243− parseJSON v = typeMismatch "()" v
249+ parseJSON = withArray "()" $ \v ->
250+ if V.null v
251+ then pure ()
252+ else fail "Expected an empty array"
244253 {-# INLINE parseJSON #-}
245254
246255instance ToJSON [Char] where
@@ -248,8 +257,7 @@ instance ToJSON [Char] where
248257 {-# INLINE toJSON #-}
249258
250259instance FromJSON [Char] where
251− parseJSON (String t) = pure (T.unpack t)
252− parseJSON v = typeMismatch "String" v
260+ parseJSON = withText "String" $ pure . T.unpack
253261 {-# INLINE parseJSON #-}
254262
255263instance ToJSON Char where
@@ -257,9 +265,10 @@ instance ToJSON Char where
257265 {-# INLINE toJSON #-}
258266
259267instance FromJSON Char where
260− parseJSON (String t)
261− | T.compareLength t 1 == EQ = pure (T.head t)
262− parseJSON v = typeMismatch "Char" v
268+ parseJSON = withText "Char" $ \t ->
269+ if T.compareLength t 1 == EQ
270+ then pure $ T.head t
271+ else fail "Expected a string of length 1"
263272 {-# INLINE parseJSON #-}
264273
265274instance ToJSON Double where
@@ -301,10 +310,10 @@ instance ToJSON (Ratio Integer) where
301310 {-# INLINE toJSON #-}
302311
303312instance FromJSON (Ratio Integer) where
304− parseJSON (Number n) = pure $ case n of
305− D d -> toRational d
306− I i -> fromIntegral i
307− parseJSON v = typeMismatch "Ratio Integer" v
313+ parseJSON = withNumber "Ration Integer" $ \n ->
314+ pure $ case n of
315+ D d -> toRational d
316+ I i -> fromIntegral i
308317 {-# INLINE parseJSON #-}
309318
310319instance HasResolution a => ToJSON (Fixed a) where
@@ -327,8 +336,7 @@ instance FromJSON Int where
327336 {-# INLINE parseJSON #-}
328337
329338parseIntegral :: Integral a => Value -> Parser a
330−parseIntegral (Number n) = pure (floor n)
331−parseIntegral v = typeMismatch "Integral" v
339+parseIntegral = withNumber "Integral" $ pure . floor
332340{-# INLINE parseIntegral #-}
333341
334342instance ToJSON Integer where
@@ -416,8 +424,7 @@ instance ToJSON Text where
416424 {-# INLINE toJSON #-}
417425
418426instance FromJSON Text where
419− parseJSON (String t) = pure t
420− parseJSON v = typeMismatch "Text" v
427+ parseJSON = withText "Text" pure
421428 {-# INLINE parseJSON #-}
422429
423430instance ToJSON LT.Text where
@@ -425,8 +432,7 @@ instance ToJSON LT.Text where
425432 {-# INLINE toJSON #-}
426433
427434instance FromJSON LT.Text where
428− parseJSON (String t) = pure (LT.fromStrict t)
429− parseJSON v = typeMismatch "Lazy Text" v
435+ parseJSON = withText "Lazy Text" $ pure . LT.fromStrict
430436 {-# INLINE parseJSON #-}
431437
432438instance ToJSON B.ByteString where
@@ -434,8 +440,7 @@ instance ToJSON B.ByteString where
434440 {-# INLINE toJSON #-}
435441
436442instance FromJSON B.ByteString where
437− parseJSON (String t) = pure . encodeUtf8 $ t
438− parseJSON v = typeMismatch "ByteString" v
443+ parseJSON = withText "ByteString" $ pure . encodeUtf8
439444 {-# INLINE parseJSON #-}
440445
441446instance ToJSON LB.ByteString where
@@ -443,8 +448,7 @@ instance ToJSON LB.ByteString where
443448 {-# INLINE toJSON #-}
444449
445450instance FromJSON LB.ByteString where
446− parseJSON (String t) = pure . lazy $ t
447− parseJSON v = typeMismatch "Lazy ByteString" v
451+ parseJSON = withText "Lazy ByteString" $ pure . lazy
448452 {-# INLINE parseJSON #-}
449453
450454instance (ToJSON a) => ToJSON [a] where
@@ -452,8 +456,7 @@ instance (ToJSON a) => ToJSON [a] where
452456 {-# INLINE toJSON #-}
453457
454458instance (FromJSON a) => FromJSON [a] where
455− parseJSON (Array a) = mapM parseJSON (V.toList a)
456− parseJSON v = typeMismatch "[a]" v
459+ parseJSON = withArray "[a]" $ mapM parseJSON . V.toList
457460 {-# INLINE parseJSON #-}
458461
459462instance (ToJSON a) => ToJSON (Vector a) where
@@ -461,8 +464,7 @@ instance (ToJSON a) => ToJSON (Vector a) where
461464 {-# INLINE toJSON #-}
462465
463466instance (FromJSON a) => FromJSON (Vector a) where
464− parseJSON (Array a) = V.mapM parseJSON a
465− parseJSON v = typeMismatch "Vector a" v
467+ parseJSON = withArray "Vector a" $ V.mapM parseJSON
466468 {-# INLINE parseJSON #-}
467469
468470vectorToJSON :: (VG.Vector v a, ToJSON a) => v a -> Value
@@ -470,8 +472,7 @@ vectorToJSON = Array . V.map toJSON . V.convert
470472{-# INLINE vectorToJSON #-}
471473
472474vectorParseJSON :: (FromJSON a, VG.Vector w a) => String -> Value -> Parser (w a)
473−vectorParseJSON _ (Array a) = V.convert <$> V.mapM parseJSON a
474−vectorParseJSON s v = typeMismatch s v
475+vectorParseJSON s = withArray s $ fmap V.convert . V.mapM parseJSON
475476{-# INLINE vectorParseJSON #-}
476477
477478instance (Storable a, ToJSON a) => ToJSON (VS.Vector a) where
@@ -529,8 +530,8 @@ instance (ToJSON v) => ToJSON (M.Map Text v) where
529530 {-# INLINE toJSON #-}
530531
531532instance (FromJSON v) => FromJSON (M.Map Text v) where
532− parseJSON (Object o) = H.foldrWithKey M.insert M.empty <$> traverse parseJSON o
533− parseJSON v = typeMismatch "Map Text a" v
533+ parseJSON = withObject "Map Text a" $
534+ fmap (H.foldrWithKey M.insert M.empty) . traverse parseJSON
534535
535536instance (ToJSON v) => ToJSON (M.Map LT.Text v) where
536537 toJSON = Object . mapHashKeyVal LT.toStrict toJSON
@@ -561,8 +562,7 @@ instance (ToJSON v) => ToJSON (H.HashMap Text v) where
561562 {-# INLINE toJSON #-}
562563
563564instance (FromJSON v) => FromJSON (H.HashMap Text v) where
564− parseJSON (Object o) = traverse parseJSON o
565− parseJSON v = typeMismatch "HashMap Text a" v
565+ parseJSON = withObject "HashMap Text a" $ traverse parseJSON
566566
567567instance (ToJSON v) => ToJSON (H.HashMap LT.Text v) where
568568 toJSON = Object . mapKeyVal LT.toStrict toJSON
@@ -615,13 +615,12 @@ instance ToJSON DotNetTime where
615615 {-# INLINE toJSON #-}
616616
617617instance FromJSON DotNetTime where
618− parseJSON (String t) =
619− case parseTime defaultTimeLocale "/Date(%s%Q)/" (unpack t') of
620− Just d -> pure (DotNetTime d)
621− _ -> fail "could not parse .NET time"
622− where (s,m) = T.splitAt (T.length t - 5) t
618+ parseJSON = withText "DotNetTime" $ \t ->
619+ let (s,m) = T.splitAt (T.length t - 5) t
623620 t' = T.concat [s,".",m]
624− parseJSON v = typeMismatch "DotNetTime" v
621+ in case parseTime defaultTimeLocale "/Date(%s%Q)/" (unpack t') of
622+ Just d -> pure (DotNetTime d)
623+ _ -> fail "could not parse .NET time"
625624 {-# INLINE parseJSON #-}
626625
627626instance ToJSON ZonedTime where
@@ -659,11 +658,10 @@ instance ToJSON UTCTime where
659658 {-# INLINE toJSON #-}
660659
661660instance FromJSON UTCTime where
662− parseJSON (String t) =
661+ parseJSON = withText "UTCTime" $ \t ->
663662 case parseTime defaultTimeLocale "%FT%T%QZ" (unpack t) of
664663 Just d -> pure d
665664 _ -> fail "could not parse ISO-8601 date"
666− parseJSON v = typeMismatch "UTCTime" v
667665 {-# INLINE parseJSON #-}
668666
669667instance (ToJSON a, ToJSON b) => ToJSON (a,b) where
@@ -675,14 +673,13 @@ instance (ToJSON a, ToJSON b) => ToJSON (a,b) where
675673 {-# INLINE toJSON #-}
676674
677675instance (FromJSON a, FromJSON b) => FromJSON (a,b) where
678− parseJSON (Array ab)
679− | n == 2 = (,) <$> parseJSON (V.unsafeIndex ab 0)
680− <*> parseJSON (V.unsafeIndex ab 1)
681− | otherwise = fail $ "cannot unpack array of length " ++
682− show n ++ " into a pair"
683− where
684− n = V.length ab
685− parseJSON v = typeMismatch "(a,b)" v
676+ parseJSON = withArray "(a,b)" $ \ab ->
677+ let n = V.length ab
678+ in if n == 2
679+ then (,) <$> parseJSON (V.unsafeIndex ab 0)
680+ <*> parseJSON (V.unsafeIndex ab 1)
681+ else fail $ "cannot unpack array of length " ++
682+ show n ++ " into a pair"
686683 {-# INLINE parseJSON #-}
687684
688685instance (ToJSON a, ToJSON b, ToJSON c) => ToJSON (a,b,c) where
@@ -695,15 +692,14 @@ instance (ToJSON a, ToJSON b, ToJSON c) => ToJSON (a,b,c) where
695692 {-# INLINE toJSON #-}
696693
697694instance (FromJSON a, FromJSON b, FromJSON c) => FromJSON (a,b,c) where
698− parseJSON (Array abc)
699− | n == 3 = (,,) <$> parseJSON (V.unsafeIndex abc 0)
700− <*> parseJSON (V.unsafeIndex abc 1)
701− <*> parseJSON (V.unsafeIndex abc 2)
702− | otherwise = fail $ "cannot unpack array of length " ++
703− show n ++ " into a 3-tuple"
704− where
705− n = V.length abc
706− parseJSON v = typeMismatch "(a,b,c)" v
695+ parseJSON = withArray "(a,b,c)" $ \abc ->
696+ let n = V.length abc
697+ in if n == 3
698+ then (,,) <$> parseJSON (V.unsafeIndex abc 0)
699+ <*> parseJSON (V.unsafeIndex abc 1)
700+ <*> parseJSON (V.unsafeIndex abc 2)
701+ else fail $ "cannot unpack array of length " ++
702+ show n ++ " into a 3-tuple"
707703 {-# INLINE parseJSON #-}
708704
709705instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where
@@ -717,16 +713,15 @@ instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where
717713 {-# INLINE toJSON #-}
718714
719715instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) => FromJSON (a,b,c,d) where
720− parseJSON (Array abcd)
721− | n == 4 = (,,,) <$> parseJSON (V.unsafeIndex abcd 0)
722− <*> parseJSON (V.unsafeIndex abcd 1)
723− <*> parseJSON (V.unsafeIndex abcd 2)
724− <*> parseJSON (V.unsafeIndex abcd 3)
725− | otherwise = fail $ "cannot unpack array of length " ++
726− show n ++ " into a 4-tuple"
727− where
728− n = V.length abcd
729− parseJSON v = typeMismatch "(a,b,c,d)" v
716+ parseJSON = withArray "(a,b,c,d)" $ \abcd ->
717+ let n = V.length abcd
718+ in if n == 4
719+ then (,,,) <$> parseJSON (V.unsafeIndex abcd 0)
720+ <*> parseJSON (V.unsafeIndex abcd 1)
721+ <*> parseJSON (V.unsafeIndex abcd 2)
722+ <*> parseJSON (V.unsafeIndex abcd 3)
723+ else fail $ "cannot unpack array of length " ++
724+ show n ++ " into a 4-tuple"
730725 {-# INLINE parseJSON #-}
731726
732727instance ToJSON a => ToJSON (Dual a) where
@@ -753,6 +748,41 @@ instance FromJSON a => FromJSON (Last a) where
753748 parseJSON = fmap Last . parseJSON
754749 {-# INLINE parseJSON #-}
755750
751+-- | @withObject expected f value@ applies @f@ to the 'Object' when @value@ is an @Object@
752+-- and fails using @'typeMismatch' expected@ otherwise.
753+withObject :: String -> (Object -> Parser a) -> Value -> Parser a
754+withObject _ f (Object obj) = f obj
755+withObject expected _ v = typeMismatch expected v
756+{-# INLINE withObject #-}
757+
758+-- | @withObject expected f value@ applies @f@ to the 'Text' when @value@ is a @String@
759+-- and fails using @'typeMismatch' expected@ otherwise.
760+withText :: String -> (Text -> Parser a) -> Value -> Parser a
761+withText _ f (String txt) = f txt
762+withText expected _ v = typeMismatch expected v
763+{-# INLINE withText #-}
764+
765+-- | @withObject expected f value@ applies @f@ to the 'Array' when @value@ is an @Array@
766+-- and fails using @'typeMismatch' expected@ otherwise.
767+withArray :: String -> (Array -> Parser a) -> Value -> Parser a
768+withArray _ f (Array arr) = f arr
769+withArray expected _ v = typeMismatch expected v
770+{-# INLINE withArray #-}
771+
772+-- | @withObject expected f value@ applies @f@ to the 'Number' when @value@ is a @Number@
773+-- and fails using @'typeMismatch' expected@ otherwise.
774+withNumber :: String -> (Number -> Parser a) -> Value -> Parser a
775+withNumber _ f (Number num) = f num
776+withNumber expected _ v = typeMismatch expected v
777+{-# INLINE withNumber #-}
778+
779+-- | @withObject expected f value@ applies @f@ to the 'Bool' when @value@ is a @Bool@
780+-- and fails using @'typeMismatch' expected@ otherwise.
781+withBool :: String -> (Bool -> Parser a) -> Value -> Parser a
782+withBool _ f (Bool arr) = f arr
783+withBool expected _ v = typeMismatch expected v
784+{-# INLINE withBool #-}
785+
756786-- | Construct a 'Pair' from a key and a value.
757787(.=) :: ToJSON a => Text -> a -> Pair
758788name .= value = (name, toJSON value)