Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP

Loading…

Add functions for inspecting Values #90

Merged
merged 2 commits into from

2 participants

@basvandijk
Collaborator

Hi Bryan,

I use these with* functions a lot at Erudify. Would you consider merging them into aeson?

Cheers,

Bas

@bos bos merged commit 32e0c2d into from
@bos
Owner

Nice patch, thanks.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
This page is out of date. Refresh to see the latest.
Showing with 112 additions and 68 deletions.
  1. +6 −0 Data/Aeson.hs
  2. +8 −0 Data/Aeson/Types.hs
  3. +98 −68 Data/Aeson/Types/Class.hs
View
6 Data/Aeson.hs
@@ -28,6 +28,12 @@ module Data.Aeson
, Result(..)
, fromJSON
, ToJSON(..)
+ -- * Inspecting @'Value's@
+ , withObject
+ , withText
+ , withArray
+ , withNumber
+ , withBool
-- * Constructors and accessors
, (.=)
, (.:)
View
8 Data/Aeson/Types.hs
@@ -32,6 +32,14 @@ module Data.Aeson.Types
, parseEither
, parseMaybe
, ToJSON(..)
+
+ -- * Inspecting @'Value's@
+ , withObject
+ , withText
+ , withArray
+ , withNumber
+ , withBool
+
-- * Constructors and accessors
, (.=)
, (.:)
View
166 Data/Aeson/Types/Class.hs
@@ -30,6 +30,14 @@ module Data.Aeson.Types.Class
#endif
-- * Types
, DotNetTime(..)
+
+ -- * Inspecting @'Value's@
+ , withObject
+ , withText
+ , withArray
+ , withNumber
+ , withBool
+
-- * Functions
, fromJSON
, (.:)
@@ -228,8 +236,7 @@ instance ToJSON Bool where
{-# INLINE toJSON #-}
instance FromJSON Bool where
- parseJSON (Bool b) = pure b
- parseJSON v = typeMismatch "Bool" v
+ parseJSON = withBool "Bool" pure
{-# INLINE parseJSON #-}
instance ToJSON () where
@@ -237,8 +244,10 @@ instance ToJSON () where
{-# INLINE toJSON #-}
instance FromJSON () where
- parseJSON (Array v) | V.null v = pure ()
- parseJSON v = typeMismatch "()" v
+ parseJSON = withArray "()" $ \v ->
+ if V.null v
+ then pure ()
+ else fail "Expected an empty array"
{-# INLINE parseJSON #-}
instance ToJSON [Char] where
@@ -246,8 +255,7 @@ instance ToJSON [Char] where
{-# INLINE toJSON #-}
instance FromJSON [Char] where
- parseJSON (String t) = pure (T.unpack t)
- parseJSON v = typeMismatch "String" v
+ parseJSON = withText "String" $ pure . T.unpack
{-# INLINE parseJSON #-}
instance ToJSON Char where
@@ -255,9 +263,10 @@ instance ToJSON Char where
{-# INLINE toJSON #-}
instance FromJSON Char where
- parseJSON (String t)
- | T.compareLength t 1 == EQ = pure (T.head t)
- parseJSON v = typeMismatch "Char" v
+ parseJSON = withText "Char" $ \t ->
+ if T.compareLength t 1 == EQ
+ then pure $ T.head t
+ else fail "Expected a string of length 1"
{-# INLINE parseJSON #-}
instance ToJSON Double where
@@ -299,10 +308,10 @@ instance ToJSON (Ratio Integer) where
{-# INLINE toJSON #-}
instance FromJSON (Ratio Integer) where
- parseJSON (Number n) = pure $ case n of
- D d -> toRational d
- I i -> fromIntegral i
- parseJSON v = typeMismatch "Ratio Integer" v
+ parseJSON = withNumber "Ration Integer" $ \n ->
+ pure $ case n of
+ D d -> toRational d
+ I i -> fromIntegral i
{-# INLINE parseJSON #-}
instance ToJSON Int where
@@ -314,8 +323,7 @@ instance FromJSON Int where
{-# INLINE parseJSON #-}
parseIntegral :: Integral a => Value -> Parser a
-parseIntegral (Number n) = pure (floor n)
-parseIntegral v = typeMismatch "Integral" v
+parseIntegral = withNumber "Integral" $ pure . floor
{-# INLINE parseIntegral #-}
instance ToJSON Integer where
@@ -403,8 +411,7 @@ instance ToJSON Text where
{-# INLINE toJSON #-}
instance FromJSON Text where
- parseJSON (String t) = pure t
- parseJSON v = typeMismatch "Text" v
+ parseJSON = withText "Text" pure
{-# INLINE parseJSON #-}
instance ToJSON LT.Text where
@@ -412,8 +419,7 @@ instance ToJSON LT.Text where
{-# INLINE toJSON #-}
instance FromJSON LT.Text where
- parseJSON (String t) = pure (LT.fromStrict t)
- parseJSON v = typeMismatch "Lazy Text" v
+ parseJSON = withText "Lazy Text" $ pure . LT.fromStrict
{-# INLINE parseJSON #-}
instance ToJSON B.ByteString where
@@ -421,8 +427,7 @@ instance ToJSON B.ByteString where
{-# INLINE toJSON #-}
instance FromJSON B.ByteString where
- parseJSON (String t) = pure . encodeUtf8 $ t
- parseJSON v = typeMismatch "ByteString" v
+ parseJSON = withText "ByteString" $ pure . encodeUtf8
{-# INLINE parseJSON #-}
instance ToJSON LB.ByteString where
@@ -430,8 +435,7 @@ instance ToJSON LB.ByteString where
{-# INLINE toJSON #-}
instance FromJSON LB.ByteString where
- parseJSON (String t) = pure . lazy $ t
- parseJSON v = typeMismatch "Lazy ByteString" v
+ parseJSON = withText "Lazy ByteString" $ pure . lazy
{-# INLINE parseJSON #-}
instance (ToJSON a) => ToJSON [a] where
@@ -439,8 +443,7 @@ instance (ToJSON a) => ToJSON [a] where
{-# INLINE toJSON #-}
instance (FromJSON a) => FromJSON [a] where
- parseJSON (Array a) = mapM parseJSON (V.toList a)
- parseJSON v = typeMismatch "[a]" v
+ parseJSON = withArray "[a]" $ mapM parseJSON . V.toList
{-# INLINE parseJSON #-}
instance (ToJSON a) => ToJSON (Vector a) where
@@ -448,8 +451,7 @@ instance (ToJSON a) => ToJSON (Vector a) where
{-# INLINE toJSON #-}
instance (FromJSON a) => FromJSON (Vector a) where
- parseJSON (Array a) = V.mapM parseJSON a
- parseJSON v = typeMismatch "Vector a" v
+ parseJSON = withArray "Vector a" $ V.mapM parseJSON
{-# INLINE parseJSON #-}
vectorToJSON :: (VG.Vector v a, ToJSON a) => v a -> Value
@@ -457,8 +459,7 @@ vectorToJSON = Array . V.map toJSON . V.convert
{-# INLINE vectorToJSON #-}
vectorParseJSON :: (FromJSON a, VG.Vector w a) => String -> Value -> Parser (w a)
-vectorParseJSON _ (Array a) = V.convert <$> V.mapM parseJSON a
-vectorParseJSON s v = typeMismatch s v
+vectorParseJSON s = withArray s $ fmap V.convert . V.mapM parseJSON
{-# INLINE vectorParseJSON #-}
instance (Storable a, ToJSON a) => ToJSON (VS.Vector a) where
@@ -516,8 +517,8 @@ instance (ToJSON v) => ToJSON (M.Map Text v) where
{-# INLINE toJSON #-}
instance (FromJSON v) => FromJSON (M.Map Text v) where
- parseJSON (Object o) = H.foldrWithKey M.insert M.empty <$> traverse parseJSON o
- parseJSON v = typeMismatch "Map Text a" v
+ parseJSON = withObject "Map Text a" $
+ fmap (H.foldrWithKey M.insert M.empty) . traverse parseJSON
instance (ToJSON v) => ToJSON (M.Map LT.Text v) where
toJSON = Object . mapHashKeyVal LT.toStrict toJSON
@@ -548,8 +549,7 @@ instance (ToJSON v) => ToJSON (H.HashMap Text v) where
{-# INLINE toJSON #-}
instance (FromJSON v) => FromJSON (H.HashMap Text v) where
- parseJSON (Object o) = traverse parseJSON o
- parseJSON v = typeMismatch "HashMap Text a" v
+ parseJSON = withObject "HashMap Text a" $ traverse parseJSON
instance (ToJSON v) => ToJSON (H.HashMap LT.Text v) where
toJSON = Object . mapKeyVal LT.toStrict toJSON
@@ -602,13 +602,12 @@ instance ToJSON DotNetTime where
{-# INLINE toJSON #-}
instance FromJSON DotNetTime where
- parseJSON (String t) =
- case parseTime defaultTimeLocale "/Date(%s%Q)/" (unpack t') of
- Just d -> pure (DotNetTime d)
- _ -> fail "could not parse .NET time"
- where (s,m) = T.splitAt (T.length t - 5) t
+ parseJSON = withText "DotNetTime" $ \t ->
+ let (s,m) = T.splitAt (T.length t - 5) t
t' = T.concat [s,".",m]
- parseJSON v = typeMismatch "DotNetTime" v
+ in case parseTime defaultTimeLocale "/Date(%s%Q)/" (unpack t') of
+ Just d -> pure (DotNetTime d)
+ _ -> fail "could not parse .NET time"
{-# INLINE parseJSON #-}
instance ToJSON UTCTime where
@@ -617,11 +616,10 @@ instance ToJSON UTCTime where
{-# INLINE toJSON #-}
instance FromJSON UTCTime where
- parseJSON (String t) =
+ parseJSON = withText "UTCTime" $ \t ->
case parseTime defaultTimeLocale "%FT%T%QZ" (unpack t) of
Just d -> pure d
_ -> fail "could not parse ISO-8601 date"
- parseJSON v = typeMismatch "UTCTime" v
{-# INLINE parseJSON #-}
instance (ToJSON a, ToJSON b) => ToJSON (a,b) where
@@ -633,14 +631,13 @@ instance (ToJSON a, ToJSON b) => ToJSON (a,b) where
{-# INLINE toJSON #-}
instance (FromJSON a, FromJSON b) => FromJSON (a,b) where
- parseJSON (Array ab)
- | n == 2 = (,) <$> parseJSON (V.unsafeIndex ab 0)
- <*> parseJSON (V.unsafeIndex ab 1)
- | otherwise = fail $ "cannot unpack array of length " ++
- show n ++ " into a pair"
- where
- n = V.length ab
- parseJSON v = typeMismatch "(a,b)" v
+ parseJSON = withArray "(a,b)" $ \ab ->
+ let n = V.length ab
+ in if n == 2
+ then (,) <$> parseJSON (V.unsafeIndex ab 0)
+ <*> parseJSON (V.unsafeIndex ab 1)
+ else fail $ "cannot unpack array of length " ++
+ show n ++ " into a pair"
{-# INLINE parseJSON #-}
instance (ToJSON a, ToJSON b, ToJSON c) => ToJSON (a,b,c) where
@@ -653,15 +650,14 @@ instance (ToJSON a, ToJSON b, ToJSON c) => ToJSON (a,b,c) where
{-# INLINE toJSON #-}
instance (FromJSON a, FromJSON b, FromJSON c) => FromJSON (a,b,c) where
- parseJSON (Array abc)
- | n == 3 = (,,) <$> parseJSON (V.unsafeIndex abc 0)
- <*> parseJSON (V.unsafeIndex abc 1)
- <*> parseJSON (V.unsafeIndex abc 2)
- | otherwise = fail $ "cannot unpack array of length " ++
- show n ++ " into a 3-tuple"
- where
- n = V.length abc
- parseJSON v = typeMismatch "(a,b,c)" v
+ parseJSON = withArray "(a,b,c)" $ \abc ->
+ let n = V.length abc
+ in if n == 3
+ then (,,) <$> parseJSON (V.unsafeIndex abc 0)
+ <*> parseJSON (V.unsafeIndex abc 1)
+ <*> parseJSON (V.unsafeIndex abc 2)
+ else fail $ "cannot unpack array of length " ++
+ show n ++ " into a 3-tuple"
{-# INLINE parseJSON #-}
instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where
@@ -675,16 +671,15 @@ instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where
{-# INLINE toJSON #-}
instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) => FromJSON (a,b,c,d) where
- parseJSON (Array abcd)
- | n == 4 = (,,,) <$> parseJSON (V.unsafeIndex abcd 0)
- <*> parseJSON (V.unsafeIndex abcd 1)
- <*> parseJSON (V.unsafeIndex abcd 2)
- <*> parseJSON (V.unsafeIndex abcd 3)
- | otherwise = fail $ "cannot unpack array of length " ++
- show n ++ " into a 4-tuple"
- where
- n = V.length abcd
- parseJSON v = typeMismatch "(a,b,c,d)" v
+ parseJSON = withArray "(a,b,c,d)" $ \abcd ->
+ let n = V.length abcd
+ in if n == 4
+ then (,,,) <$> parseJSON (V.unsafeIndex abcd 0)
+ <*> parseJSON (V.unsafeIndex abcd 1)
+ <*> parseJSON (V.unsafeIndex abcd 2)
+ <*> parseJSON (V.unsafeIndex abcd 3)
+ else fail $ "cannot unpack array of length " ++
+ show n ++ " into a 4-tuple"
{-# INLINE parseJSON #-}
instance ToJSON a => ToJSON (Dual a) where
@@ -711,6 +706,41 @@ instance FromJSON a => FromJSON (Last a) where
parseJSON = fmap Last . parseJSON
{-# INLINE parseJSON #-}
+-- | @withObject expected f value@ applies @f@ to the 'Object' when @value@ is an @Object@
+-- and fails using @'typeMismatch' expected@ otherwise.
+withObject :: String -> (Object -> Parser a) -> Value -> Parser a
+withObject _ f (Object obj) = f obj
+withObject expected _ v = typeMismatch expected v
+{-# INLINE withObject #-}
+
+-- | @withObject expected f value@ applies @f@ to the 'Text' when @value@ is a @String@
+-- and fails using @'typeMismatch' expected@ otherwise.
+withText :: String -> (Text -> Parser a) -> Value -> Parser a
+withText _ f (String txt) = f txt
+withText expected _ v = typeMismatch expected v
+{-# INLINE withText #-}
+
+-- | @withObject expected f value@ applies @f@ to the 'Array' when @value@ is an @Array@
+-- and fails using @'typeMismatch' expected@ otherwise.
+withArray :: String -> (Array -> Parser a) -> Value -> Parser a
+withArray _ f (Array arr) = f arr
+withArray expected _ v = typeMismatch expected v
+{-# INLINE withArray #-}
+
+-- | @withObject expected f value@ applies @f@ to the 'Number' when @value@ is a @Number@
+-- and fails using @'typeMismatch' expected@ otherwise.
+withNumber :: String -> (Number -> Parser a) -> Value -> Parser a
+withNumber _ f (Number num) = f num
+withNumber expected _ v = typeMismatch expected v
+{-# INLINE withNumber #-}
+
+-- | @withObject expected f value@ applies @f@ to the 'Bool' when @value@ is a @Bool@
+-- and fails using @'typeMismatch' expected@ otherwise.
+withBool :: String -> (Bool -> Parser a) -> Value -> Parser a
+withBool _ f (Bool arr) = f arr
+withBool expected _ v = typeMismatch expected v
+{-# INLINE withBool #-}
+
-- | Construct a 'Pair' from a key and a value.
(.=) :: ToJSON a => Text -> a -> Pair
name .= value = (name, toJSON value)
Something went wrong with that request. Please try again.